Пример #1
0
Файл: add.c Проект: jpflori/pari
static GEN
addsr_sign(long x, GEN y, long sy)
{
  long e, l, ly, sx;
  GEN z;

  if (!x) return rcopy_sign(y, sy);
  if (x < 0) { sx = -1; x = -x; } else sx = 1;
  e = expo(y) - expu(x);
  if (!sy)
  {
    if (e >= 0) return rcopy_sign(y, sy);
    if (sx == -1) x = -x;
    return stor(x, nbits2prec(-e));
  }

  ly = lg(y);
  if (e > 0)
  {
    l = ly - divsBIL(e);
    if (l < 3) return rcopy_sign(y, sy);
  }
  else l = ly + nbits2extraprec(-e);
  z = (GEN)avma;
  y = addrr_sign(stor(x,l), sx, y, sy);
  ly = lg(y); while (ly--) *--z = y[ly];
  avma = (pari_sp)z; return z;
}
Пример #2
0
Файл: add.c Проект: jpflori/pari
GEN
addir_sign(GEN x, long sx, GEN y, long sy)
{
  long e, l, ly;
  GEN z;

  if (!sx) return rcopy_sign(y, sy);
  e = expo(y) - expi(x);
  if (!sy)
  {
    if (e >= 0) return rcopy_sign(y, sy);
    z = itor(x, nbits2prec(-e));
    setsigne(z, sx); return z;
  }

  ly = lg(y);
  if (e > 0)
  {
    l = ly - divsBIL(e);
    if (l < 3) return rcopy_sign(y, sy);
  }
  else l = ly + nbits2extraprec(-e);
  z = (GEN)avma;
  y = addrr_sign(itor(x,l), sx, y, sy);
  ly = lg(y); while (ly--) *--z = y[ly];
  avma = (pari_sp)z; return z;
}
Пример #3
0
static GEN
real_read(pari_sp av, const char **s, GEN y, long prec)
{
  long l, n = 0;
  switch(**s)
  {
    default: return y; /* integer */
    case '.':
    {
      const char *old = ++*s;
      if (isalpha((int)**s) || **s=='.')
      {
        if (**s == 'E' || **s == 'e') {
          n = exponent(s);
          if (!signe(y)) { avma = av; return real_0_digits(n); }
          break;
        }
        --*s; return y; /* member */
      }
      y = int_read_more(y, s);
      n = old - *s;
      if (**s != 'E' && **s != 'e')
      {
        if (!signe(y)) { avma = av; return real_0(prec); }
        break;
      }
    }
    /* Fall through */
    case 'E': case 'e':
      n += exponent(s);
      if (!signe(y)) { avma = av; return real_0_digits(n); }
  }
  l = nbits2prec(bit_accuracy(lgefint(y)));
  if (l < prec) l = prec; else prec = l;
  if (!n) return itor(y, prec);
  incrprec(l);
  y = itor(y, l);
  if (n > 0)
    y = mulrr(y, rpowuu(10UL, (ulong)n, l));
  else
    y = divrr(y, rpowuu(10UL, (ulong)-n, l));
  return gerepileuptoleaf(av, rtor(y, prec));
}
Пример #4
0
Файл: add.c Проект: jpflori/pari
GEN
addrr_sign(GEN x, long sx, GEN y, long sy)
{
  long lx, ex = expo(x);
  long ly, ey = expo(y), e = ey - ex;
  long i, j, lz, ez, m;
  int extend, f2;
  GEN z;
  LOCAL_OVERFLOW;

  if (!sy)
  {
    if (!sx)
    {
      if (e > 0) ex = ey;
      return real_0_bit(ex);
    }
    if (e >= 0) return real_0_bit(ey);
    lz = nbits2prec(-e);
    lx = lg(x); if (lz > lx) lz = lx;
    z = cgetr(lz); while(--lz) z[lz] = x[lz];
    setsigne(z,sx); return z;
  }
  if (!sx)
  {
    if (e <= 0) return real_0_bit(ex);
    lz = nbits2prec(e);
    ly = lg(y); if (lz > ly) lz = ly;
    z = cgetr(lz); while (--lz) z[lz] = y[lz];
    setsigne(z,sy); return z;
  }

  if (e < 0) { swap(x,y); lswap(sx,sy); ey=ex; e=-e; }
  /* now ey >= ex */
  lx = lg(x);
  ly = lg(y);
  /* If exponents differ, need to shift one argument, here x. If
   * extend = 1: extension of x,z by m < BIL bits (round to 1 word) */
  /* in this case, lz = lx + d + 1, otherwise lx + d */
  extend = 0;
  if (e)
  {
    long d = dvmdsBIL(e, &m), l = ly-d;
    if (l <= 2) return rcopy_sign(y, sy);
    if (l > lx) { lz = lx + d + 1; extend = 1; }
    else        { lz = ly; lx = l; }
    if (m)
    { /* shift x right m bits */
      const pari_sp av = avma;
      const ulong sh = BITS_IN_LONG-m;
      GEN p1 = x; x = new_chunk(lx + lz + 1);
      shift_right(x,p1,2,lx, 0,m);
      if (extend) uel(x,lx) = uel(p1,lx-1) << sh;
      avma = av; /* HACK: cgetr(lz) will not overwrite x */
    }
  }
  else
  { /* d = 0 */
    m = 0;
    if (lx > ly) lx = ly;
    lz = lx;
  }

  if (sx == sy)
  { /* addition */
    i = lz-1;
    j = lx-1;
    if (extend) {
      ulong garde = addll(x[lx], y[i]);
      if (m < 4) /* don't extend for few correct bits */
        z = cgetr(--lz);
      else
      {
        z = cgetr(lz);
        z[i] = garde;
      }
    }
    else
    {
      z = cgetr(lz);
      z[i] = addll(x[j], y[i]); j--;
    }
    i--;
    for (; j>=2; i--,j--) z[i] = addllx(x[j],y[i]);
    if (overflow)
    {
      z[1] = 1; /* stops since z[1] != 0 */
      for (;;) { z[i] = uel(y,i)+1; if (z[i--]) break; }
      if (i <= 0)
      {
        shift_right(z,z, 2,lz, 1,1);
        z[1] = evalsigne(sx) | evalexpo(ey+1); return z;
      }
    }
    for (; i>=2; i--) z[i] = y[i];
    z[1] = evalsigne(sx) | evalexpo(ey); return z;
  }

  /* subtraction */
  if (e) f2 = 1;
  else
  {
    i = 2; while (i < lx && x[i] == y[i]) i++;
    if (i==lx) return real_0_bit(ey+1 - prec2nbits(lx));
    f2 = (uel(y,i) > uel(x,i));
  }
  /* result is non-zero. f2 = (y > x) */
  i = lz-1; z = cgetr(lz);
  if (f2)
  {
    j = lx-1;
    if (extend) z[i] = subll(y[i], x[lx]);
    else        z[i] = subll(y[i], x[j--]);
    for (i--; j>=2; i--) z[i] = subllx(y[i], x[j--]);
    if (overflow) /* stops since y[1] != 0 */
      for (;;) { z[i] = uel(y,i)-1; if (y[i--]) break; }
    for (; i>=2; i--) z[i] = y[i];
    sx = sy;
  }
  else
  {
    if (extend) z[i] = subll(x[lx], y[i]);
    else        z[i] = subll(x[i],  y[i]);
    for (i--; i>=2; i--) z[i] = subllx(x[i], y[i]);
  }

  x = z+2; i = 0; while (!x[i]) i++;
  lz -= i; z += i;
  j = bfffo(z[2]); /* need to shift left by j bits to normalize mantissa */
  ez = ey - (j | (i * BITS_IN_LONG));
  if (extend)
  { /* z was extended by d+1 words [should be e bits = d words + m bits] */
    /* not worth keeping extra word if less than 5 significant bits in there */
    if (m - j < 5 && lz > 3)
    { /* shorten z */
      ulong last = (ulong)z[--lz]; /* cancelled word */

      /* if we need to shift anyway, shorten from left
       * If not, shorten from right, neutralizing last word of z */
      if (j == 0)
        /* stackdummy((pari_sp)(z + lz+1), (pari_sp)(z + lz)); */
        z[lz] = evaltyp(t_VECSMALL) | _evallg(1);
      else
      {
        GEN t = z;
        z++; shift_left(z,t,2,lz-1, last,j);
      }
      if ((last<<j) & HIGHBIT)
      { /* round up */
        i = lz-1;
        while (++((ulong*)z)[i] == 0 && i > 1) i--;
        if (i == 1) { ez++; z[2] = (long)HIGHBIT; }
      }
    }
    else if (j) shift_left(z,z,2,lz-1, 0,j);
  }
  else if (j) shift_left(z,z,2,lz-1, 0,j);
  z[1] = evalsigne(sx) | evalexpo(ez);
  z[0] = evaltyp(t_REAL) | evallg(lz);
  avma = (pari_sp)z; return z;
}
Пример #5
0
engine_RawRingElementArrayOrNull rawRoots(const RingElement *p, long prec,
                                          int unique) {
  const Ring *R = p->get_ring();
  const PolynomialRing *P = R->cast_to_PolynomialRing();
  if (P == 0) {
    ERROR("expected a polynomial ring");
    return NULL;
  }
  const int n = P->n_vars();
  if (n != 1) {
    ERROR("expected a univariate polynomial ring");
    return NULL;
  }
  const Ring *K = P->getCoefficients();
  int degree = 0;
  for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
    degree = max(degree, abs(*(t->monom)));
  }
  if (prec == -1) {
    prec = (K->get_precision() == 0 ? 53 : K->get_precision());
  }

  engine_RawRingElementArrayOrNull result = nullptr;

  /* Start PARI computations. */
  pari_CATCH(e_STACK) {
#ifdef NDEBUG
    /*
     * Every time the stack is changed PARI writes a message to the file pari_errfile
     * which by default is /dev/stderr. To avoid showing this message to the user we
     * redirect to /dev/null before the PARI's stack is modified.
     */
    FILE *tmp, *dev_null = fopen("/dev/null", "w");
    if (dev_null != NULL) {
      tmp = pari_errfile;
      pari_errfile = dev_null;
    }
#endif
  allocatemem(0); // passing 0 will double the current stack size.
#ifdef NDEBUG
    /*
     * We set pari_errfile back to the default value just in case PARI crashes.
     */
    if (dev_null != NULL) {
      pari_errfile = tmp;
      fclose(dev_null);
    }
#endif
  } pari_RETRY {
    const pari_sp av = avma;

    GEN q = cgetg(2 + degree + 1, t_POL);
    setsigne(q, 1);
    setvarn(q, 0);
    for (int i = 0; i < degree + 1; ++i) {
      gel(q, 2 + i) = gen_0;
    }

    switch (K->ringID()) {
    case M2::ring_ZZ:
    ZZ_GMP:
      for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
        gel(q, 2 + abs(*(t->monom))) =
            mpz_get_GEN(reinterpret_cast<const mpz_ptr>(t->coeff.poly_val));
      }
      break;
    case M2::ring_QQ:
      for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
        gel(q, 2 + abs(*(t->monom))) =
            mpq_get_GEN(reinterpret_cast<const mpq_ptr>(t->coeff.poly_val));
      }
      break;
    case M2::ring_RR:
      pari_CATCH(e_OVERFLOW) {
        ERROR("coefficient is NaN or Infinity");
        avma = av;
        return NULL;
      }
      pari_TRY {
        for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
          gel(q, 2 + abs(*(t->monom))) =
              dbltor(*reinterpret_cast<double *>(t->coeff.poly_val));
        }
      }
      pari_ENDCATCH
      break;
    case M2::ring_CC:
      pari_CATCH(e_OVERFLOW) {
        ERROR("coefficient is NaN or Infinity");
        avma = av;
        return NULL;
      }
      pari_TRY {
        for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
          GEN z = cgetg(3, t_COMPLEX);
          gel(z, 1) = dbltor(reinterpret_cast<complex *>(t->coeff.poly_val)->re);
          gel(z, 2) = dbltor(reinterpret_cast<complex *>(t->coeff.poly_val)->im);
          gel(q, 2 + abs(*(t->monom))) = z;
        }
      }
      pari_ENDCATCH
      break;
    case M2::ring_RRR:
      for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
        gel(q, 2 + abs(*(t->monom))) =
            mpfr_get_GEN(reinterpret_cast<const mpfr_ptr>(t->coeff.poly_val));
      }
      break;
    case M2::ring_CCC:
      for (Nterm *t = p->get_value(); t != NULL; t = t->next) {
        gel(q, 2 + abs(*(t->monom))) =
            mpc_get_GEN(reinterpret_cast<const mpc_ptr>(t->coeff.poly_val));
      }
      break;
    case M2::ring_old:
      if (K->is_ZZ()) {
        goto ZZ_GMP;
      }
    default:
      ERROR("expected coefficient ring of the form ZZ, QQ, RR or CC");
      return NULL;
    }

    if (unique) {
      q = RgX_div(q, RgX_gcd_simple(q, RgX_deriv(q)));
    }

    GEN roots = cleanroots(q, nbits2prec(prec));

    const size_t num_roots = lg(roots) - 1;
    result = getmemarraytype(engine_RawRingElementArray, num_roots);
    result->len = static_cast<int>(num_roots);

    ring_elem m2_root;
    if (prec <= 53) {
      const RingCC *CC = dynamic_cast<const RingCC *>(IM2_Ring_CCC(prec));

      for (int i = 0; i < num_roots; ++i) {
        const pari_sp av2 = avma;

        GEN pari_root = gel(roots, 1 + i);
        const complex root = {rtodbl(greal(pari_root)),
                              rtodbl(gimag(pari_root))};
        CC->ring().to_ring_elem(m2_root, root);
        result->array[i] = RingElement::make_raw(CC, m2_root);

        avma = av2;
      }
    } else {
      const RingCCC *CCC = dynamic_cast<const RingCCC *>(IM2_Ring_CCC(prec));

      for (int i = 0; i < num_roots; ++i) {
        const pari_sp av2 = avma;

        mpc_t root;
        auto root1 = reinterpret_cast<mpfc_t*>(&root);
        pari_mpc_init_set_GEN(root, gel(roots, 1 + i), GMP_RNDN);
        //        CCC->ring().to_ring_elem(m2_root, **reinterpret_cast<mpfc_t*>(&root));
        CCC->ring().to_ring_elem(m2_root, **root1);
        result->array[i] = RingElement::make_raw(CCC, m2_root);

        avma = av2;
      }
    }

    /* End PARI computations. */
    avma = av;
  }
  pari_ENDCATCH

  return result;
}