Sindbad~EG File Manager

/*
Numerical factoring of polynomials for MathXpert
M. Beeson
Original date 3.1.92
Last modified 6.14.98
5.31.13  corrected factornumerically, which had a bug in case two or more pairs of complex conjugate roots have the same real part.
11.18.24 shortened the error message in factornumerically, which will never be used anyway.
*/

#include <time.h>  /* for randomize */
#include <stdlib.h>  /* for memset */
#include <assert.h>
#include <math.h>
#include <string.h>

#include "globals.h"
#include "dcomplex.h"
#include "polynoms.h"
#include "algaux.h"
#include "ceval.h"
#include "order.h"
#include "newton.h"
#include "drandom.h"
#include "deval.h"
#include "symbols.h"
#include "errbuf.h"
#include "proot.h"  /* polyroot2 */
#include "pvalaux.h"  /* strongnegate */

/*_________________________________________________________________*/
int factornumerically(term t, term arg, term *next, char *reason)
/* calculate the roots of polynomial t numerically and thus
factor it.  Assumes that varlist[eigenvariable] is the variable. */
#define EPS 1.0e-12  /* accept roots as real if imaginary part is less than EPS */
{ term w,x,p,a,b,xsq,c,cc,sqfree;
  double u,v,qq;
  long actualval;
  int *multiplicities;
  int nroots;
  int signflag = 1;
  int realrootflag = 0;
  unsigned short n,m,r;
  int natoms,qflag = 1;
  term *atomlist;
  int i,j,err;
  unsigned short kk,k;
  dcomplex *roots;
  if(FUNCTOR(t) != '+')
     return 1;
  natoms = atomsin(t,&atomlist);
  if(natoms > 1)
     { errbuf(0, english(363));
           /* Numerical factoring works only on */
       errbuf(1, english(364));
          /* polynomials in only one variable. */
       // It won't be on the term selection menu if natoms > 1  anyway
     }
  x = atomlist[0];
  free2(atomlist);
  err = makepoly(t,x,&p);
  if(err)
     goto notpoly;
  n = ARITY(p);   /* 1 + degree(p)  */
  if(n <= 2)
     return 1;
  /* If this is a polynomial in Z[x] or Q[x] we want to
     call squarefree first, so we don't call Newton's method on
     multiple roots */
  for(i=0;i<n;i++)
    { w = ARG(i,p);
      if(NEGATIVE(w))
         w = ARG(0,w);
      if(!OBJECT(w))
          goto notpoly;
      if(TYPE(w) == BIGNUM)
         { errbuf(0, english(367));
               /* Coefficient too large to handle */
           return 1;
         }
      if(TYPE(w) == DOUBLE)
          qflag = 0;
    }
  if(qflag)  /* it's in Z[x] or Q[x] */
     sqfree = squarefree(p,&cc);
  roots = (dcomplex *) callocate(n,sizeof(dcomplex));
  if(roots == NULL)
     { nospace();
       return 1;
     }
  if(qflag)
     { m = ARITY(sqfree);
       /* sqfree is a product of POLYnomials; m == 1 is allowed;
          the i-th factor is the product of roots of multiplicity i+1.
       */
       multiplicities = (int *) callocate(n,sizeof(int));
       if(multiplicities==NULL)
          { nospace();
            return 1;
          }
             /* multiplicities[i] will be the multiplicity of roots[i] */
       k=0;
       for(i=0;i<m;i++)
          { w = ARG(i,sqfree);
            if(ARITY(w) == 1)
               continue;  /* no roots of multiplicity i+1 */
            if(ARITY(w) == 2)
               { ceval(tnegate(ARG(0,w)),roots+k);
                 multiplicities[k] = i+1;
                 ++k;
                 continue;
               }
            err = polyroot2(w,roots+k,&nroots);
            if(err)
               { free2(multiplicities);
                 goto fail;
               }
            r = ARITY(w);
            for(j=0;j<r-1;j++)
               { multiplicities[k+j] = i+1;
               }
            k += (unsigned short)(r-1);  /* increase k by degree(w)  */
         }
     }
  else   /* at least one coefficient is a double */
     { err = polyroot2(p,roots,&nroots);
       if(err)
          goto fail;
       k =(unsigned short)(n-1);
     }
  /* Now k is the actual number of roots, in either case, and
     if(qflag), then the array multiplicities should be used */

  if(get_complex())
     { if(equals(ARG(n-1,p),minusone))
          { signflag = -1;
            *next = make_term('*',k);
            i = 0;
          }
       else if(!ONE(ARG(n-1,p)))  /* not monic */
          { *next = make_term('*',(unsigned short)(k+1));
            if(NEGATIVE(ARG(n-1,p)))
               ARGREP(*next,0,ARG(0,ARG(n-1,p)));
            else
               ARGREP(*next,0,ARG(n-1,p));
            i = 1;
          }
       else
          { *next = make_term('*',k);
            i = 0;
          }
       for(;i<k;i++)  /* i initialized already  */
           { a = make_complex(
                    nearint(roots[i].r,&actualval) ?
                            make_int(actualval) :
                            make_double(roots[i].r),
                            nearint(roots[i].i,&actualval) ?
                            make_int(actualval) :
                            make_double(roots[i].i)
                           );
             w = sum(x,strongnegate(a));
             ARGREP(*next,i,(multiplicities[i] > 1 && qflag) ? make_power(w,make_int(multiplicities[i])): w);
           }
       free2(roots);
       HIGHLIGHT(*next);
       if(FUNCTOR(*next) == '*')
          sortargs(*next);
       if(signflag == -1)
          *next = tnegate(*next);
       strcpy(reason, english(368)); /* calculate roots */
       return 0;
     }
  /*  now we want real factors; so we must find the complex conjugate of
      each root in the roots array and combine them. */
  if(equals(ARG(n-1,p),minusone))
     { *next = make_term('*',k);
       kk=0;
       signflag = -1;
     }
  else if(!ONE(ARG(n-1,p)))  /* not monic */
     { *next = make_term('*',(unsigned short)(k+1));
       if(NEGATIVE(ARG(n-1,p)))
          { ARGREP(*next,0,ARG(0,ARG(n-1,p)));
            signflag = -1;
          }
       else
          ARGREP(*next,0,ARG(n-1,p));
       kk = 1;
     }
  else
     { *next = make_term('*',k);
       kk = 0;
     }
  xsq = make_power(x,two);
  for(i=0; i<k;i++)
     { u = roots[i].r;
       v = roots[i].i;
       if(fabs(v) >= EPS)
          { /* root is not real, so look for its conjugate, which must be there, but may 
               not be at index i+1. */
            for(j=i+1;j<k;j++)
                { if(fabs(u-roots[j].r) < EPS && fabs(v + roots[j].i) < EPS)
                     break; // complex conjugate found 
                }
            if(j==k)
                assert(0);  // the complex conjugate MUST be there
            // swap it into position i+1
            if(j > i+1)
                { dcomplex swapit = roots[i+1];
                  roots[i+1] = roots[j];
                  roots[j] = swapit;
                }      
            if(nearint(2.0 *u, &actualval))
               b = make_int(actualval);
            else
               b = make_double(2.0 * u);
            qq = u*u + v*v;
            if(nearint(qq,&actualval))
               c = make_int(actualval);
            else
               c = make_double(qq);
            if(ZERO(b))
               /* don't produce an explicit 0 middle term */
               { a = make_term('+',2);
                 ARGREP(a,0,xsq);
                 ARGREP(a,1,c);
               }
            else
               { a = make_term('+',3);
                 ARGREP(a,0,xsq);
                 ARGREP(a,1,tnegate(signedproduct(b,x)));
                 ARGREP(a,2,c);
               }
            ARGREP(*next,kk,(qflag && multiplicities[i] > 1) ? make_power(a,make_int(multiplicities[i])) : a);
            ++kk;
            ++i;    /* skip the conjugate, which was swapped into the position where this will skip it. */
          }
       else  /* root is real */
          { realrootflag = 1;
            if(nearint(u,&actualval))
               w = sum(x,tnegate(make_int(actualval)));
            else
               w = sum(x,tnegate(make_double(u)));
            ARGREP(*next,kk, (qflag && multiplicities[i] > 1) ? make_power(w,make_int(multiplicities[i])): w);
                 /* Note, the order in the above line is important,
                   (multiplicities[i] > 1 && qflag) is an error because
                   multiplicities has only been allocated if(qflag) */
            ++kk;
          }
     }
  if(kk==1 && realrootflag == 0)
     /* two complex roots, conjugates of each other, when
        we want real roots, so we get a single quadratic
        factor when the incoming degree was only two.  */
     { errbuf(0, english(1336));  /* No real roots */
       return 1;
     }
  if(kk==1)
       /* only one factor */
     *next = ARG(0,*next);
     /* don't bother with RELEASE(*next) as reset_heap will be called soon. */
  else
     SETFUNCTOR(*next,'*',kk);
  HIGHLIGHT(*next);
  if(FUNCTOR(*next) == '*')
     sortargs(*next);
  if(signflag == -1)
     *next = tnegate(*next);
  strcpy(reason, english(368));   /* calculate roots */
  return 0;
  notpoly:
     errbuf(0, english(363));
         /* Numerical factoring works only on */
     errbuf(1,english(369));
        /* polynomials, i.e. sums of monomials. */
     return 1;
  fail:   /* polyroots failed, don't know why */
     errbuf(0, english(1505));
     /* Can't compute roots numerically. */
     return 1;
}
#undef EPS