Example #1
0
GEN
nffactormod(GEN nf, GEN x, GEN pr)
{
  long j, l, vx = varn(x), vn;
  pari_sp av = avma;
  GEN F, E, rep, xrd, modpr, T, p;

  nf = checknf(nf);
  vn = varn(nf[1]);
  if (typ(x)!=t_POL) pari_err(typeer,"nffactormod");
  if (varncmp(vx,vn) >= 0)
    pari_err(talker,"polynomial variable must have highest priority in nffactormod");

  modpr = nf_to_ff_init(nf, &pr, &T, &p);
  xrd = modprX(x, nf, modpr);
  rep = FqX_factor(xrd,T,p);
  settyp(rep, t_MAT);
  F = gel(rep,1); l = lg(F);
  E = gel(rep,2); settyp(E, t_COL);
  for (j = 1; j < l; j++) {
    gel(F,j) = modprX_lift(gel(F,j), modpr);
    gel(E,j) = stoi(E[j]);
  }
  return gerepilecopy(av, rep);
}
Example #2
0
void 
install0(char *name, char *code, char *gpname, char *lib)
{
  void *f, *handle;

  if (! *lib) lib = DL_DFLT_NAME;
  if (! *gpname) gpname = name;
  if (lib) lib = expand_tilde(lib);

#ifndef RTLD_GLOBAL /* OSF1 has dlopen but not RTLD_GLOBAL*/
#  define RTLD_GLOBAL 0
#endif
  handle = dlopen(lib, RTLD_LAZY|RTLD_GLOBAL);

  if (!handle)
  {
    const char *s = dlerror(); if (s) fprintferr("%s\n\n",s);
    if (lib) pari_err(talker,"couldn't open dynamic library '%s'",lib);
    pari_err(talker,"couldn't open dynamic symbol table of process");
  }
  f = dlsym(handle, name);
  if (!f)
  {
    if (lib) pari_err(talker,"can't find symbol '%s' in library '%s'",name,lib);
    pari_err(talker,"can't find symbol '%s' in dynamic symbol table of process",name);
  }
  if (lib) free(lib);
  install(f, gpname, code);
}
Example #3
0
void 
install0(char *name, char *code, char *gpname, char *lib)
{
  FARPROC f;
  HMODULE handle;
#ifdef WINCE
  short wlib[256], wname[256];

  MultiByteToWideChar(CP_ACP, 0, lib, strlen(lib)+1, wlib, 256);
  MultiByteToWideChar(CP_ACP, 0, name, strlen(name)+1, wname, 256);
  lib = wlib;
  name = wname;
#endif

#ifdef DL_DFLT_NAME
  if (! *lib) lib = DL_DFLT_NAME;
#endif
  if (! *gpname) gpname=name;
  if (lib) lib = expand_tilde(lib);
  
  handle = LoadLibrary(lib);
  if (!handle)
  {
    if (lib) pari_err(talker,"couldn't open dynamic library '%s'",lib);
    pari_err(talker,"couldn't open dynamic symbol table of process");
  }
  f = GetProcAddress(handle,name);
  if (!f)
  {
    if (lib) pari_err(talker,"can't find symbol '%s' in library '%s'",name,lib);
    pari_err(talker,"can't find symbol '%s' in dynamic symbol table of process",name);
  }
  if (lib) free(lib);
  install((void*)f,gpname,code);
}
Example #4
0
/* If flag = 0 (default): check if s existed in 1.39.15 and print verbosely
 * the answer.
 * If flag > 0: silently return n+1 if function changed, 0 otherwise.
 *   (where n is the index of s in whatnowlist).
 * If flag < 0: -flag-1 is the index in whatnowlist
 */
int
whatnow(char *s, int flag)
{
  int n;
  char *def;
  whatnow_t wp;
  entree *ep;

  if (flag < 0) { n = -flag; flag = 0; }
  else
  {
    if (flag && strlen(s)==1) return 0; /* special case "i" and "o" */
    if (!is_identifier(s) || !is_entry_intern(s,funct_old_hash,NULL))
    {
      if (flag) return 0;
      pari_err(talker,"as far as I can recall, this function never existed");
    }
    n = 0;
    do
      def = (oldfonctions[n++]).name;
    while (def && strcmp(def,s));
    if (!def)
    {
      int m=0;
      do
        def = (functions_oldgp[m++]).name;
      while (def && strcmp(def,s));
      n += m - 1;
    }
  }

  wp=whatnowlist[n-1]; def=wp.name;
  if (def == SAME)
  {
    if (flag) return 0;
    pari_err(talker,"this function did not change");
  }
  if (flag) return n;

  if (def == REMOV)
    pari_err(talker,"this function was suppressed");
  if (!strcmp(def,"x*y"))
  {
    pariprintf("  %s is now called *.\n\n",s);
    pariprintf("    %s%s ===> %s%s\n\n",s,wp.oldarg,wp.name,wp.newarg);
    return 1;
  }
  ep = is_entry(wp.name);
  if (!ep) pari_err(bugparier,"whatnow");
  pariputs("New syntax: "); term_color(c_ERR);
  pariprintf("%s%s ===> %s%s\n\n",s,wp.oldarg,wp.name,wp.newarg);
  term_color(c_HELP);
  print_text(ep->help); pariputc('\n');
  term_color(c_NONE); return 1;
}
Example #5
0
File: anal.c Project: jkeuffer/pari
static long
check_proto(const char *code)
{
  long arity = 0;
  const char *s = code, *old;
  if (*s == 'l' || *s == 'v' || *s == 'i' || *s == 'm' || *s == 'u') s++;
  while (*s && *s != '\n') switch (*s++)
  {
    case '&':
    case 'C':
    case 'G':
    case 'I':
    case 'J':
    case 'U':
    case 'L':
    case 'M':
    case 'P':
    case 'W':
    case 'f':
    case 'n':
    case 'p':
    case 'r':
    case 'x':
      arity++;
      break;
    case 'E':
    case 's':
      if (*s == '*') s++;
      arity++;
      break;
    case 'D':
      if (*s == 'G' || *s == '&' || *s == 'n' || *s == 'I' || *s == 'E'
                    || *s == 'V' || *s == 'P' || *s == 's' || *s == 'r')
      {
        if (*s != 'V') arity++;
        s++; break;
      }
      old = s; while (*s && *s != ',') s++;
      if (*s != ',') pari_err(e_SYNTAX, "missing comma", old, code);
      break;
    case 'V':
    case '=':
    case ',': break;
    case '\n': break; /* Before the mnemonic */

    case 'm':
    case 'l':
    case 'i':
    case 'v': pari_err(e_SYNTAX, "this code has to come first", s-1, code);
    default: pari_err(e_SYNTAX, "unknown parser code", s-1, code);
  }
  if (arity > 20) pari_err_IMPL("functions with more than 20 parameters");
  return arity;
}
Example #6
0
File: anal.c Project: jkeuffer/pari
/* Kill ep, i.e free all memory it references, and reset to initial value */
void
kill0(const char *e)
{
  entree *ep = is_entry(e);
  if (!ep || EpSTATIC(ep)) pari_err(e_MISC,"can't kill that");
  killep(ep);
}
Example #7
0
File: anal.c Project: jkeuffer/pari
long
fetch_var_higher(void)
{
  if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
  varpriority[max_avail] = ++max_priority;
  return max_avail--;
}
Example #8
0
File: anal.c Project: jkeuffer/pari
static void
check_name(const char *name)
{
  const char *s = name;
  if (isalpha((int)*s))
    while (is_keyword_char(*++s)) /* empty */;
  if (*s) pari_err(e_SYNTAX,"not a valid identifier", s, name);
}
Example #9
0
/* assume x is squarefree */
int
nfissplit(GEN nf, GEN x)
{
  pari_sp av = avma;
  long l;
  if (typ(x) != t_POL) pari_err(typeer, "nfissplit");
  l = lg(nfsqff(checknf(nf), x, 2));
  avma = av; return l != 1;
}
Example #10
0
static void
digit_help(char *s, long flag)
{
  long n = atoi(s);
  if (n < 0 || n > MAX_SECTION+4)
    pari_err(e_SYNTAX,"no such section in help: ?",s,s);
  if (n == MAX_SECTION+1)
    community();
  else if (flag & h_LONG)
    external_help(s,3);
  else
    commands(n);
  return;
}
Example #11
0
File: anal.c Project: jkeuffer/pari
GEN
varhigher(const char *s, long w)
{
  long v;
  if (w >= 0)
  {
    hashentry *e = hash_select(h_polvar, (void*)s, (void*)w, _higher);
    if (e) return pol_x((long)e->val);
  }
  /* no luck: need to create */
  if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
  v = nvar++;
  varpriority[v]= ++max_priority;
  return var_register(v, s);
}
Example #12
0
File: anal.c Project: jkeuffer/pari
void
alias0(const char *s, const char *old)
{
  entree *ep, *e;
  GEN x;

  ep = fetch_entry(old);
  e  = fetch_entry(s);
  if (EpVALENCE(e) != EpALIAS && EpVALENCE(e) != EpNEW)
    pari_err(e_MISC,"can't replace an existing symbol by an alias");
  freeep(e);
  x = newblock(2); x[0] = evaltyp(t_STR)|_evallg(2); /* for getheap */
  gel(x,1) = (GEN)ep;
  e->value=x; e->valence=EpALIAS;
}
Example #13
0
/* return the roots of pol in nf */
GEN
nfroots(GEN nf,GEN pol)
{
  pari_sp av = avma;
  GEN A,g, T;
  long d;

  if (!nf) return nfrootsQ(pol);

  nf = checknf(nf); T = gel(nf,1);
  if (typ(pol) != t_POL) pari_err(notpoler,"nfroots");
  if (varncmp(varn(pol), varn(T)) >= 0)
    pari_err(talker,"polynomial variable must have highest priority in nfroots");
  d = degpol(pol);
  if (d == 0) return cgetg(1,t_VEC);
  if (d == 1)
  {
    A = gneg_i(gdiv(gel(pol,2),gel(pol,3)));
    return gerepilecopy(av, mkvec( basistoalg(nf,A) ));
  }
  A = fix_relative_pol(nf,pol,0);
  A = Q_primpart( lift_intern(A) );
  if (DEBUGLEVEL>3) fprintferr("test if polynomial is square-free\n");
  g = nfgcd(A, derivpol(A), T, gel(nf,4));

  if (degpol(g))
  { /* not squarefree */
    g = QXQX_normalize(g, T);
    A = RgXQX_div(A,g,T);
  }
  A = QXQX_normalize(A, T);
  A = Q_primpart(A);
  A = nfsqff(nf,A,1);
  A = RgXQV_to_mod(A, T);
  return gerepileupto(av, gen_sort(A, 0, cmp_pol));
}
Example #14
0
File: anal.c Project: jkeuffer/pari
long
fetch_user_var(const char *s)
{
  entree *ep = fetch_entry(s);
  long v;
  switch (EpVALENCE(ep))
  {
    case EpVAR: return varn((GEN)initial_value(ep));
    case EpNEW: break;
    default: pari_err(e_MISC, "%s already exists with incompatible valence", s);
  }
  v = pari_var_create(ep);
  ep->valence = EpVAR;
  ep->value = initial_value(ep);
  return v;
}
Example #15
0
static void
choose_prime(primedata *S, GEN pol, GEN dpol)
{
  byteptr di = diffptr + 1;
  long i, j, k, r, lcm, oldlcm, pp, N = degpol(pol), minp = N*N / 4;
  GEN Z, p, ff, oldff, n, oldn;
  pari_sp av;

  if (DEBUGLEVEL) (void)timer2();
  p = utoipos(2);
  while (p[2] <= minp) NEXT_PRIME_VIADIFF(p[2], di);
  oldlcm = 0;
  oldff = oldn = NULL; pp = 0; /* gcc -Wall */
  av = avma;
  for(k = 1; k < 11 || !oldlcm; k++,avma = av)
  {
    do NEXT_PRIME_VIADIFF(p[2], di); while (!smodis(dpol, p[2]));
    if (k > 5 * N) pari_err(talker,"sorry, too many block systems in nfsubfields");
    ff = (GEN)FpX_factor(pol, p)[1];
    r = lg(ff)-1;
    if (r == N || r >= BIL) continue;

    n = cgetg(r+1, t_VECSMALL); lcm = n[1] = degpol(ff[1]);
    for (j=2; j<=r; j++) { n[j] = degpol(ff[j]); lcm = clcm(lcm, n[j]); }
    if (lcm <= oldlcm) continue; /* false when oldlcm = 0 */

    if (DEBUGLEVEL) fprintferr("p = %ld,\tlcm = %ld,\torbits: %Z\n",p[2],lcm,n);
    pp = p[2];
    oldn = n;
    oldff = ff;
    oldlcm = lcm; if (r == 1) break;
    av = avma;
  }
  if (DEBUGLEVEL) fprintferr("Chosen prime: p = %ld\n", pp);
  S->ff = oldff;
  S->lcm= oldlcm;
  S->p  = utoipos(pp);
  S->pol = FpX_red(pol, S->p); init_primedata(S);

  n = oldn; r = lg(n); Z = cgetg(r,t_VEC);
  for (k=0,i=1; i<r; i++)
  {
    GEN t = cgetg(n[i]+1, t_VECSMALL); gel(Z,i) = t;
    for (j=1; j<=n[i]; j++) t[j] = ++k;
  }
  S->Z = Z;
}
Example #16
0
/* return U list of polynomials s.t U[i] = 1 mod fk[i] and 0 mod fk[j] for all
 * other j */
static GEN
get_bezout(GEN pol, GEN fk, GEN p)
{
  long i, l = lg(fk);
  GEN A, B, d, u, v, U = cgetg(l, t_VEC);
  for (i=1; i<l; i++)
  {
    A = gel(fk,i);
    B = FpX_div(pol, A, p);
    d = FpX_extgcd(A,B,p, &u, &v);
    if (degpol(d) > 0) pari_err(talker, "relatively prime polynomials expected");
    d = constant_term(d);
    if (!gcmp1(d)) v = FpX_Fp_mul(v, Fp_inv(d, p), p);
    gel(U,i) = FpX_mul(B,v, p);
  }
  return U;
}
Example #17
0
File: anal.c Project: jkeuffer/pari
long
pari_var_create(entree *ep)
{
  GEN p = (GEN)initial_value(ep);
  long v;
  if (*p) return varn(p);
  if (nvar == max_avail) pari_err(e_MISC,"no more variables available");
  v = nvar++;
  /* set p = pol_x(v) */
  p[0] = evaltyp(t_POL) | _evallg(4);
  p[1] = evalsigne(1) | evalvarn(v);
  gel(p,2) = gen_0;
  gel(p,3) = gen_1;
  varentries_set(v, ep);
  varpriority[v]= min_priority--;
  return v;
}
Example #18
0
File: anal.c Project: jkeuffer/pari
void
name_var(long n, const char *s)
{
  entree *ep;
  char *u;

  if (n < pari_var_next())
    pari_err(e_MISC, "renaming a GP variable is forbidden");
  if (n > (long)MAXVARN)
    pari_err_OVERFLOW("variable number");

  ep = (entree*)pari_malloc(sizeof(entree) + strlen(s) + 1);
  u = (char *)initial_value(ep);
  ep->valence = EpVAR;
  ep->name = u; strcpy(u,s);
  ep->value = gen_0; /* in case geval is called */
  varentries_reset(n, ep);
}
Example #19
0
File: anal.c Project: jkeuffer/pari
entree *
install(void *f, const char *name, const char *code)
{
  long arity = check_proto(code);
  entree *ep;

  check_name(name);
  ep = fetch_entry(name);
  if (ep->valence != EpNEW)
  {
    if (ep->valence != EpINSTALL)
      pari_err(e_MISC,"[install] identifier '%s' already in use", name);
    pari_warn(warner, "[install] updating '%s' prototype; module not reloaded", name);
    if (ep->code) pari_free((void*)ep->code);
  }
  else
  {
    ep->value = f;
    ep->valence = EpINSTALL;
  }
  ep->code = pari_strdup(code);
  ep->arity = arity; return ep;
}
Example #20
0
/* return the characteristic polynomial of alpha over nf, where alpha
   is an element of the algebra nf[X]/(T) given as a polynomial in X */
GEN
rnfcharpoly(GEN nf, GEN T, GEN alpha, long v)
{
  long vnf, vT, lT;
  pari_sp av = avma;
  GEN p1;

  nf=checknf(nf); vnf = varn(nf[1]);
  if (v<0) v = 0;
  T = fix_relative_pol(nf,T,1);
  if (typ(alpha) == t_POLMOD) alpha = lift_to_pol(alpha);
  lT = lg(T);
  if (typ(alpha) != t_POL || varn(alpha) == vnf)
    return gerepileupto(av, gpowgs(gsub(pol_x[v], alpha), lT - 3));
  vT = varn(T);
  if (varn(alpha) != vT || varncmp(v, vnf)>=0)
    pari_err(talker,"incorrect variables in rnfcharpoly");
  if (lg(alpha) >= lT) alpha = RgX_rem(alpha, T);
  if (lT <= 4)
    return gerepileupto(av, gsub(pol_x[v], alpha));
  p1 = caract2(T, unifpol(nf,alpha, t_POLMOD), v);
  return gerepileupto(av, unifpol(nf, p1, t_POLMOD));
}
Example #21
0
/* query external help program for s. num < 0 [keyword] or chapter number */
static void
external_help(const char *s, int num)
{
  long nbli = term_height()-3, li = 0;
  char buf[256], *str;
  const char *opt = "", *ar = "", *cdir = "";
  char *t, *help = GP_DATA->help;
  pariFILE *z;
  FILE *f;

  if (!has_ext_help()) pari_err(e_MISC,"no external help program");
  t = filter_quotes(s);
  if (num < 0)
    opt = "-k";
  else if (t[strlen(t)-1] != '@')
    ar = stack_sprintf("@%d",num);
#ifdef _WIN32
  if (*help=='@')
  {
    const char *basedir = win32_basedir();
    help++;
    cdir = stack_sprintf("%c:& cd %s & ", *basedir, basedir);
  }
#endif
  str=stack_sprintf("%s%s -fromgp %s %c%s%s%c",cdir,help,opt,
                                               SHELL_Q,t,ar,SHELL_Q);
  z = try_pipe(str,0); f = z->file;
  pari_free(t);
  while (fgets(buf, numberof(buf), f))
  {
    if (!strncmp("ugly_kludge_done",buf,16)) break;
    pari_puts(buf);
    if (nl_read(buf) && ++li > nbli) { pari_hit_return(); li = 0; }
  }
  pari_fclose(z);
}
Example #22
0
/* return the factorization of x in nf */
GEN
nffactor(GEN nf,GEN pol)
{
  GEN A,g,y,p1,T, rep = cgetg(3, t_MAT);
  long l, j, dA;
  pari_sp av = avma;
  pari_timer ti;

  if (DEBUGLEVEL>2) { TIMERstart(&ti); fprintferr("\nEntering nffactor:\n"); }
  nf = checknf(nf); T = gel(nf,1);
  if (typ(pol) != t_POL) pari_err(notpoler,"nffactor");
  if (varncmp(varn(pol), varn(T)) >= 0)
    pari_err(talker,"polynomial variable must have highest priority in nffactor");

  A = fix_relative_pol(nf,pol,0);
  dA = degpol(A);
  if (dA <= 0) {
    avma = (pari_sp)(rep + 3);
    return dA == 0? trivfact(): zerofact(varn(pol));
  }
  A = Q_primpart( QXQX_normalize(A, T) );
  if (dA == 1) {
    GEN c;
    A = gerepilecopy(av, A); c = gel(A,2);
    if (typ(c) == t_POL && degpol(c) > 0) gel(A,2) = mkpolmod(c, gcopy(T));
    gel(rep,1) = mkcol(A);
    gel(rep,2) = mkcol(gen_1); return rep;
  }
  if (degpol(T) == 1)
    return gerepileupto(av, factpol(Q_primpart(simplify(pol)), 0));

  A = Q_primpart( lift_intern(A) );
  g = nfgcd(A, derivpol(A), T, gel(nf,4));

  A = QXQX_normalize(A, T);
  A = Q_primpart(A);
  if (DEBUGLEVEL>2) msgTIMER(&ti, "squarefree test");

  if (degpol(g))
  { /* not squarefree */
    pari_sp av1;
    GEN ex;
    g = QXQX_normalize(g, T);
    A = RgXQX_div(A,g, T);

    y = nfsqff(nf,A,0); av1 = avma;
    l = lg(y);
    ex=(GEN)gpmalloc(l * sizeof(long));
    for (j=l-1; j>=1; j--)
    {
      GEN fact = lift(gel(y,j)), quo = g, q;
      long e = 0;
      for(e = 1;; e++)
      {
        q = RgXQX_divrem(quo,fact,T, ONLY_DIVIDES);
        if (!q) break;
        quo = q;
      }
      ex[j] = e;
    }
    avma = av1; y = gerepileupto(av, RgXQXV_to_mod(y,T));
    p1 = cgetg(l, t_COL); for (j=l-1; j>=1; j--) gel(p1,j) = utoipos(ex[j]);
    free(ex);
  }
  else
  {
    y = gerepileupto(av, RgXQXV_to_mod(nfsqff(nf,A,0), T));
    l = lg(y);
    p1 = cgetg(l, t_COL); for (j=l-1; j>=1; j--) gel(p1,j) = gen_1;
  }
  if (DEBUGLEVEL>3)
    fprintferr("number of factor(s) found: %ld\n", lg(y)-1);
  gel(rep,1) = y;
  gel(rep,2) = p1; return sort_factor(rep, cmp_pol);
}
Example #23
0
/* nf = K[y] / (P) [P irreducible / K]. Is nf Galois over K ? */
int
nfisgalois(GEN nf, GEN P)
{
  if (typ(P) != t_POL) pari_err(typeer, "nfissplit");
  return degpol(P) <= 2 || nfissplit(nf, P);
}
Example #24
0
/* LOCATE GPRC */
static void
err_gprc(const char *s, char *t, char *u)
{
  err_printf("\n");
  pari_err(e_SYNTAX,s,t,u);
}
Example #25
0
/* return the factorization of the square-free polynomial x.
   The coeffs of x are in Z_nf and its leading term is a rational integer.
   deg(x) > 1, deg(nfpol) > 1
   If fl = 1, return only the roots of x in nf
   If fl = 2, as fl=1 if pol splits, [] otherwise */
static GEN
nfsqff(GEN nf, GEN pol, long fl)
{
  long n, nbf, dpol = degpol(pol);
  GEN pr, C0, polbase, init_fa = NULL;
  GEN N2, rep, polmod, polred, lt, nfpol = gel(nf,1);
  nfcmbf_t T;
  nflift_t L;
  pari_timer ti, ti_tot;

  if (DEBUGLEVEL>2) { TIMERstart(&ti); TIMERstart(&ti_tot); }
  n = degpol(nfpol);
  polbase = unifpol(nf, pol, t_COL);
  if (typ(polbase) != t_POL) pari_err(typeer, "nfsqff");
  polmod  = lift_intern( unifpol(nf, pol, t_POLMOD) );
  if (dpol == 1) return mkvec(QXQX_normalize(polmod, nfpol));
  /* heuristic */
  if (dpol*3 < n) 
  {
    GEN z, t;
    long i;
    if (DEBUGLEVEL>2) fprintferr("Using Trager's method\n");
    z = (GEN)polfnf(polmod, nfpol)[1];
    if (fl) {
      long l = lg(z);
      for (i = 1; i < l; i++)
      {
        t = gel(z,i); if (degpol(t) > 1) break;
        gel(z,i) = gneg(gdiv(gel(t,2), gel(t,3)));
      }
      setlg(z, i);
      if (fl == 2 && i != l) return cgetg(1,t_VEC);
    }
    return z;
  }

  nbf = nf_pick_prime(5, nf, polbase, fl, &lt, &init_fa, &pr, &L.Tp);
  if (fl == 2 && nbf < dpol) return cgetg(1,t_VEC);
  if (nbf <= 1)
  {
    if (!fl) return mkvec(QXQX_normalize(polmod, nfpol)); /* irreducible */
    if (!nbf) return cgetg(1,t_VEC); /* no root */
  }

  if (DEBUGLEVEL>2) {
    msgTIMER(&ti, "choice of a prime ideal");
    fprintferr("Prime ideal chosen: %Z\n", pr);
  }

  pol = simplify_i(lift(polmod));
  L.tozk = gel(nf,8);
  L.topow= Q_remove_denom(gel(nf,7), &L.topowden);
  T.ZC = L2_bound(nf, L.tozk, &(T.dn));
  T.Br = nf_root_bounds(pol, nf); if (lt) T.Br = gmul(T.Br, lt);

  if (fl) C0 = normlp(T.Br, 2, n);
  else    C0 = nf_factor_bound(nf, polbase); /* bound for T_2(Q_i), Q | P */
  T.bound = mulrr(T.ZC, C0); /* bound for |Q_i|^2 in Z^n on chosen Z-basis */

  N2 = mulsr(dpol*dpol, normlp(T.Br, 4, n)); /* bound for T_2(lt * S_2) */
  T.BS_2 = mulrr(T.ZC, N2); /* bound for |S_2|^2 on chosen Z-basis */

  if (DEBUGLEVEL>2) {
    msgTIMER(&ti, "bound computation");
    fprintferr("  1) T_2 bound for %s: %Z\n", fl?"root":"factor", C0);
    fprintferr("  2) Conversion from T_2 --> | |^2 bound : %Z\n", T.ZC);
    fprintferr("  3) Final bound: %Z\n", T.bound);
  }

  L.p = gel(pr,1);
  if (L.Tp && degpol(L.Tp) == 1) L.Tp = NULL;
  bestlift_init(0, nf, pr, T.bound, &L);
  if (DEBUGLEVEL>2) TIMERstart(&ti);
  polred = ZqX_normalize(polbase, lt, &L); /* monic */

  if (fl) {
    GEN z = nf_DDF_roots(pol, polred, nfpol, lt, init_fa, nbf, fl, &L);
    if (lg(z) == 1) return cgetg(1, t_VEC);
    return z;
  }

  {
    pari_sp av = avma;
    if (L.Tp)
      rep = FqX_split_all(init_fa, L.Tp, L.p);
    else
    {
      long d;
      rep = cgetg(dpol + 1, t_VEC); gel(rep,1) = FpX_red(polred,L.p);
      d = FpX_split_Berlekamp((GEN*)(rep + 1), L.p);
      setlg(rep, d + 1);
    }
    T.fact  = gerepilecopy(av, sort_vecpol(rep, &cmp_pol));
  }
  if (DEBUGLEVEL>2) msgTIMER(&ti, "splitting mod %Z", pr);
  T.pr = pr;
  T.L  = &L;
  T.polbase = polbase;
  T.pol   = pol;
  T.nf    = nf;
  T.hint  = 1; /* useless */

  rep = nf_combine_factors(&T, polred, L.p, L.k, dpol-1);
  if (DEBUGLEVEL>2)
    fprintferr("Total Time: %ld\n===========\n", TIMER(&ti_tot));
  return rep;
}
Example #26
0
void 
install0(char *name, char *code, char *gpname, char *lib) { pari_err(archer); }
Example #27
0
File: anal.c Project: jkeuffer/pari
long
eval_mnemonic(GEN str, const char *tmplate)
{
  pari_sp av=avma;
  ulong retval = 0;
  const char *etmplate = NULL;
  const char *arg;

  if (typ(str)==t_INT) return itos(str);
  if (typ(str)!=t_STR) pari_err_TYPE("eval_mnemonic",str);

  arg=GSTR(str);
  etmplate = strchr(tmplate, '\n');
  if (!etmplate)
    etmplate = tmplate + strlen(tmplate);

  while (1)
  {
    long numarg;
    const char *e, *id;
    const char *negated;                /* action found with 'no'-ID */
    int negate;                 /* Arg has 'no' prefix removed */
    ulong l, action = 0, first = 1, singleton = 0;
    char *buf, *inibuf;
    static char b[80];

    while (isspace((int)*arg)) arg++;
    if (!*arg)
      break;
    e = arg;
    while (IS_ID(*e)) e++;
    /* Now the ID is whatever is between arg and e. */
    l = e - arg;
    if (l >= sizeof(b))
      pari_err(e_MISC,"id too long in a stringified flag");
    if (!l)                             /* Garbage after whitespace? */
      pari_err(e_MISC,"a stringified flag does not start with an id");
    strncpy(b, arg, l);
    b[l] = 0;
    arg = e;
    e = inibuf = buf = b;
    while (('0' <= *e) && (*e <= '9'))
      e++;
    if (*e == 0)
      pari_err(e_MISC,"numeric id in a stringified flag");
    negate = 0;
    negated = NULL;
find:
    id = tmplate;
    while ((id = strstr(id, buf)) && id < etmplate)
    {
      if (IS_ID(id[l])) {       /* We do not allow abbreviations yet */
        id += l;                /* False positive */
        continue;
      }
      if ((id >= tmplate + 2) && (IS_ID(id[-1])))
      {
        const char *s = id;

        if ( !negate && s >= tmplate+3
            && ((id[-1] == '_') || (id[-1] == '-')) )
          s--;
        /* Check whether we are preceeded by "no" */
        if ( negate             /* buf initially started with "no" */
            || (s < tmplate+2) || (s[-1] != 'o') || (s[-2] != 'n')
            || (s >= tmplate+3 && IS_ID(s[-3]))) {
          id += l;              /* False positive */
          continue;
        }
        /* Found noID in the template! */
        id += l;
        negated = id;
        continue;               /* Try to find without 'no'. */
      }
      /* Found as is */
      id += l;
      break;
    }
    if ( !id && !negated && !negate
        && (l > 2) && buf[0] == 'n' && buf[1] == 'o' ) {
      /* Try to find the flag without the prefix "no". */
      buf += 2; l -= 2;
      if ((buf[0] == '_') || (buf[0] == '-')) { buf++; l--; }
      negate = 1;
      if (buf[0])
        goto find;
    }
    if (!id && negated) /* Negated and AS_IS forms, prefer AS_IS */
    {
      id = negated;     /* Otherwise, use negated form */
      negate = 1;
    }
    if (!id)
      pari_err(e_MISC,"Unrecognized id '%s' in a stringified flag", inibuf);
    if (singleton && !first)
      pari_err(e_MISC,"Singleton id non-single in a stringified flag");
    if (id[0] == '=') {
      if (negate)
        pari_err(e_MISC,"Cannot negate id=value in a stringified flag");
      if (!first)
        pari_err(e_MISC,"Assign action should be first in a stringified flag");
      action = A_ACTION_ASSIGN;
      id++;
      if (id[0] == '=') {
        singleton = 1;
        id++;
      }
    } else if (id[0] == '^') {
      if (id[1] != '~')
        pari_err(e_MISC, "Unrecognized action in a template");
      id += 2;
      if (negate)
        action = A_ACTION_SET;
      else
        action = A_ACTION_UNSET;
    } else if (id[0] == '|') {
      id++;
      if (negate)
        action = A_ACTION_UNSET;
      else
        action = A_ACTION_SET;
    }

    e = id;

    while ((*e >= '0' && *e <= '9')) e++;
    while (isspace((int)*e))
      e++;
    if (*e && (*e != ';') && (*e != ','))
      pari_err(e_MISC, "Non-numeric argument of an action in a template");
    numarg = atol(id);          /* Now it is safe to get it... */
    switch (action) {
    case A_ACTION_SET:
      retval |= numarg;
      break;
    case A_ACTION_UNSET:
      retval &= ~numarg;
      break;
    case A_ACTION_ASSIGN:
      retval = numarg;
      break;
    default:
      pari_err(e_MISC,"error in parse_option_string");
    }
    first = 0;
    while (isspace((int)*arg))
      arg++;
    if (*arg && !(ispunct((int)*arg) && *arg != '-'))
      pari_err(e_MISC,"Junk after an id in a stringified flag");
    /* Skip punctuation */
    if (*arg)
      arg++;
  }
  avma=av;
  return retval;
}
Example #28
0
int
invmod(GEN a, GEN b, GEN *res)
#endif
{
  GEN v,v1,d,d1,q,r;
  pari_sp av, av1, lim;
  long s;
  ulong g;
  ulong xu,xu1,xv,xv1;		/* Lehmer stage recurrence matrix */
  int lhmres;			/* Lehmer stage return value */

  if (typ(a) != t_INT || typ(b) != t_INT) pari_err(arither1);
  if (!signe(b)) { *res=absi(a); return 0; }
  av = avma;
  if (lgefint(b) == 3) /* single-word affair */
  {
    ulong d1 = umodiu(a, (ulong)(b[2]));
    if (d1 == 0)
    {
      if (b[2] == 1L)
        { *res = gen_0; return 1; }
      else
        { *res = absi(b); return 0; }
    }
    g = xgcduu((ulong)(b[2]), d1, 1, &xv, &xv1, &s);
#ifdef DEBUG_LEHMER
    fprintferr(" <- %lu,%lu\n", (ulong)(b[2]), (ulong)(d1[2]));
    fprintferr(" -> %lu,%ld,%lu; %lx\n", g,s,xv1,avma);
#endif
    avma = av;
    if (g != 1UL) { *res = utoipos(g); return 0; }
    xv = xv1 % (ulong)(b[2]); if (s < 0) xv = ((ulong)(b[2])) - xv;
    *res = utoipos(xv); return 1;
  }

  (void)new_chunk(lgefint(b));
  d = absi(b); d1 = modii(a,d);

  v=gen_0; v1=gen_1;	/* general case */
#ifdef DEBUG_LEHMER
  fprintferr("INVERT: -------------------------\n");
  output(d1);
#endif
  av1 = avma; lim = stack_lim(av,1);

  while (lgefint(d) > 3 && signe(d1))
  {
#ifdef DEBUG_LEHMER
    fprintferr("Calling Lehmer:\n");
#endif
    lhmres = lgcdii((ulong*)d, (ulong*)d1, &xu, &xu1, &xv, &xv1, MAXULONG);
    if (lhmres != 0)		/* check progress */
    {				/* apply matrix */
#ifdef DEBUG_LEHMER
      fprintferr("Lehmer returned %d [%lu,%lu;%lu,%lu].\n",
	      lhmres, xu, xu1, xv, xv1);
#endif
      if ((lhmres == 1) || (lhmres == -1))
      {
	if (xv1 == 1)
	{
	  r = subii(d,d1); d=d1; d1=r;
	  a = subii(v,v1); v=v1; v1=a;
	}
	else
	{
	  r = subii(d, mului(xv1,d1)); d=d1; d1=r;
	  a = subii(v, mului(xv1,v1)); v=v1; v1=a;
	}
      }
      else
      {
	r  = subii(muliu(d,xu),  muliu(d1,xv));
	a  = subii(muliu(v,xu),  muliu(v1,xv));
	d1 = subii(muliu(d,xu1), muliu(d1,xv1)); d = r;
	v1 = subii(muliu(v,xu1), muliu(v1,xv1)); v = a;
        if (lhmres&1)
	{
          setsigne(d,-signe(d));
          setsigne(v,-signe(v));
        }
        else
	{
          if (signe(d1)) { setsigne(d1,-signe(d1)); }
          setsigne(v1,-signe(v1));
        }
      }
    }
#ifdef DEBUG_LEHMER
    else
      fprintferr("Lehmer returned 0.\n");
    output(d); output(d1); output(v); output(v1);
    sleep(1);
#endif

    if (lhmres <= 0 && signe(d1))
    {
      q = dvmdii(d,d1,&r);
#ifdef DEBUG_LEHMER
      fprintferr("Full division:\n");
      printf("  q = "); output(q); sleep (1);
#endif
      a = subii(v,mulii(q,v1));
      v=v1; v1=a;
      d=d1; d1=r;
    }
    if (low_stack(lim, stack_lim(av,1)))
    {
      GEN *gptr[4]; gptr[0]=&d; gptr[1]=&d1; gptr[2]=&v; gptr[3]=&v1;
      if(DEBUGMEM>1) pari_warn(warnmem,"invmod");
      gerepilemany(av1,gptr,4);
    }
  } /* end while */

  /* Postprocessing - final sprint */
  if (signe(d1))
  {
    /* Assertions: lgefint(d)==lgefint(d1)==3, and
     * gcd(d,d1) is nonzero and fits into one word
     */
    g = xxgcduu((ulong)d[2], (ulong)d1[2], 1, &xu, &xu1, &xv, &xv1, &s);
#ifdef DEBUG_LEHMER
    output(d);output(d1);output(v);output(v1);
    fprintferr(" <- %lu,%lu\n", (ulong)d[2], (ulong)d1[2]);
    fprintferr(" -> %lu,%ld,%lu; %lx\n", g,s,xv1,avma);
#endif
    if (g != 1UL) { avma = av; *res = utoipos(g); return 0; }
    /* (From the xgcduu() blurb:)
     * For finishing the multiword modinv, we now have to multiply the
     * returned matrix  (with properly adjusted signs)  onto the values
     * v' and v1' previously obtained from the multiword division steps.
     * Actually, it is sufficient to take the scalar product of [v',v1']
     * with [u1,-v1], and change the sign if s==1.
     */
    v = subii(muliu(v,xu1),muliu(v1,xv1));
    if (s > 0) setsigne(v,-signe(v));
    avma = av; *res = modii(v,b);
#ifdef DEBUG_LEHMER
    output(*res); fprintfderr("============================Done.\n");
    sleep(1);
#endif
    return 1;
  }
  /* get here when the final sprint was skipped (d1 was zero already) */
  avma = av;
  if (!equalii(d,gen_1)) { *res = icopy(d); return 0; }
  *res = modii(v,b);
#ifdef DEBUG_LEHMER
  output(*res); fprintferr("============================Done.\n");
  sleep(1);
#endif
  return 1;
}
Example #29
0
int
ratlift(GEN x, GEN m, GEN *a, GEN *b, GEN amax, GEN bmax)
{
  GEN d,d1,v,v1,q,r;
  pari_sp av = avma, av1, lim;
  long lb,lr,lbb,lbr,s,s0;
  ulong vmax;
  ulong xu,xu1,xv,xv1;		/* Lehmer stage recurrence matrix */
  int lhmres;			/* Lehmer stage return value */

  if ((typ(x) | typ(m) | typ(amax) | typ(bmax)) != t_INT) pari_err(arither1);
  if (signe(bmax) <= 0)
    pari_err(talker, "ratlift: bmax must be > 0, found\n\tbmax=%Z\n", bmax);
  if (signe(amax) < 0)
    pari_err(talker, "ratilft: amax must be >= 0, found\n\tamax=%Z\n", amax);
  /* check 2*amax*bmax < m */
  if (cmpii(shifti(mulii(amax, bmax), 1), m) >= 0)
    pari_err(talker, "ratlift: must have 2*amax*bmax < m, found\n\tamax=%Z\n\tbmax=%Z\n\tm=%Z\n", amax,bmax,m);
  /* we _could_ silently replace x with modii(x,m) instead of the following,
   * but let's leave this up to the caller
   */
  avma = av; s = signe(x);
  if (s < 0 || cmpii(x,m) >= 0)
    pari_err(talker, "ratlift: must have 0 <= x < m, found\n\tx=%Z\n\tm=%Z\n", x,m);

  /* special cases x=0 and/or amax=0 */
  if (s == 0)
  {
    if (a != NULL) *a = gen_0;
    if (b != NULL) *b = gen_1;
    return 1;
  }
  else if (signe(amax)==0)
    return 0;
  /* assert: m > x > 0, amax > 0 */

  /* check here whether a=x, b=1 is a solution */
  if (cmpii(x,amax) <= 0)
  {
    if (a != NULL) *a = icopy(x);
    if (b != NULL) *b = gen_1;
    return 1;
  }

  /* There is no special case for single-word numbers since this is
   * mainly meant to be used with large moduli.
   */
  (void)new_chunk(lgefint(bmax) + lgefint(amax)); /* room for a,b */
  d = m; d1 = x;
  v = gen_0; v1 = gen_1;
  /* assert d1 > amax, v1 <= bmax here */
  lb = lgefint(bmax);
  lbb = bfffo(*int_MSW(bmax));
  s = 1;
  av1 = avma; lim = stack_lim(av, 1);

  /* general case: Euclidean division chain starting with m div x, and
   * with bounds on the sequence of convergents' denoms v_j.
   * Just to be different from what invmod and bezout are doing, we work
   * here with the all-nonnegative matrices [u,u1;v,v1]=prod_j([0,1;1,q_j]).
   * Loop invariants:
   * (a) (sign)*[-v,v1]*x = [d,d1] (mod m)  (componentwise)
   * (sign initially +1, changes with each Euclidean step)
   * so [a,b] will be obtained in the form [-+d,v] or [+-d1,v1];
   * this congruence is a consequence of
   * (b) [x,m]~ = [u,u1;v,v1]*[d1,d]~,
   * where u,u1 is the usual numerator sequence starting with 1,0
   * instead of 0,1  (just multiply the eqn on the left by the inverse
   * matrix, which is det*[v1,-u1;-v,u], where "det" is the same as the
   * "(sign)" in (a)).  From m = v*d1 + v1*d and
   * (c) d > d1 >= 0, 0 <= v < v1,
   * we have d >= m/(2*v1), so while v1 remains smaller than m/(2*amax),
   * the pair [-(sign)*d,v] satisfies (1) but violates (2) (d > amax).
   * Conversely, v1 > bmax indicates that no further solutions will be
   * forthcoming;  [-(sign)*d,v] will be the last, and first, candidate.
   * Thus there's at most one point in the chain division where a solution
   * can live:  v < bmax, v1 >= m/(2*amax) > bmax,  and this is acceptable
   * iff in fact d <= amax  (e.g. m=221, x=34 or 35, amax=bmax=10 fail on
   * this count while x=32,33,36,37 succeed).  However, a division may leave
   * a zero residue before we ever reach this point  (consider m=210, x=35,
   * amax=bmax=10),  and our caller may find that gcd(d,v) > 1  (numerous
   * examples -- keep m=210 and consider any of x=29,31,32,33,34,36,37,38,
   * 39,40,41).
   * Furthermore, at the start of the loop body we have in fact
   * (c') 0 <= v < v1 <= bmax, d > d1 > amax >= 0,
   * (and are never done already).
   *
   * Main loop is similar to those of invmod() and bezout(), except for
   * having to determine appropriate vmax bounds, and checking termination
   * conditions.  The signe(d1) condition is only for paranoia
   */
  while (lgefint(d) > 3 && signe(d1))
  {
    /* determine vmax for lgcdii so as to ensure v won't overshoot.
     * If v+v1 > bmax, the next step would take v1 beyond the limit, so
     * since [+-d1,v1] is not a solution, we give up.  Otherwise if v+v1
     * is way shorter than bmax, use vmax=MAXULUNG.  Otherwise, set vmax
     * to a crude lower approximation of bmax/(v+v1), or to 1, which will
     * allow the inner loop to do one step
     */
    r = addii(v,v1);
    lr = lb - lgefint(r);
    lbr = bfffo(*int_MSW(r));
    if (cmpii(r,bmax) > 0)	/* done, not found */
    {
      avma = av;
      return 0;
    }
    else if (lr > 1)		/* still more than a word's worth to go */
    {
      vmax = MAXULONG;
    }
    else			/* take difference of bit lengths */
    {
      lr = (lr << TWOPOTBITS_IN_LONG) - lbb + lbr;
      if ((ulong)lr > BITS_IN_LONG)
	vmax = MAXULONG;
      else if (lr == 0)
	vmax = 1UL;
      else
	vmax = 1UL << (lr-1);
      /* the latter is pessimistic but faster than a division */
    }
    /* do a Lehmer-Jebelean round */
    lhmres = lgcdii((ulong *)d, (ulong *)d1, &xu, &xu1, &xv, &xv1, vmax);
    if (lhmres != 0)		/* check progress */
    {				/* apply matrix */
      if ((lhmres == 1) || (lhmres == -1))
      {
	s = -s;
	if (xv1 == 1)
	{
	  /* re-use v+v1 computed above */
	  v=v1; v1=r;
	  r = subii(d,d1); d=d1; d1=r;
	}
	else
	{
	  r = subii(d, mului(xv1,d1)); d=d1; d1=r;
	  r = addii(v, mului(xv1,v1)); v=v1; v1=r;
	}
      }
      else
      {
	r  = subii(muliu(d,xu),  muliu(d1,xv));
	d1 = subii(muliu(d,xu1), muliu(d1,xv1)); d = r;
	r  = addii(muliu(v,xu),  muliu(v1,xv));
	v1 = addii(muliu(v,xu1), muliu(v1,xv1)); v = r;
        if (lhmres&1)
	{
          setsigne(d,-signe(d));
	  s = -s;
        }
        else if (signe(d1))
	{
          setsigne(d1,-signe(d1));
        }
      }
      /* check whether we're done.  Assert v <= bmax here.  Examine v1:
       * if v1 > bmax, check d and return 0 or 1 depending on the outcome;
       * if v1 <= bmax, check d1 and return 1 if d1 <= amax, otherwise
       * proceed.
       */
      if (cmpii(v1,bmax) > 0) /* certainly done */
      {
	avma = av;
	if (cmpii(d,amax) <= 0) /* done, found */
	{
	  if (a != NULL)
	  {
	    *a = icopy(d);
	    setsigne(*a,-s);	/* sign opposite to s */
	  }
	  if (b != NULL) *b = icopy(v);
	  return 1;
	}
	else			/* done, not found */
	  return 0;
      }
      else if (cmpii(d1,amax) <= 0) /* also done, found */
      {
	avma = av;
	if (a != NULL)
	{
	  if (signe(d1))
	  {
	    *a = icopy(d1);
	    setsigne(*a,s);	/* same sign as s */
	  }
	  else
	    *a = gen_0;
	}
	if (b != NULL) *b = icopy(v1);
	return 1;
      }
    } /* lhmres != 0 */

    if (lhmres <= 0 && signe(d1))
    {
      q = dvmdii(d,d1,&r);
#ifdef DEBUG_LEHMER
      fprintferr("Full division:\n");
      printf("  q = "); output(q); sleep (1);
#endif
      d=d1; d1=r;
      r = addii(v,mulii(q,v1));
      v=v1; v1=r;
      s = -s;
      /* check whether we are done now.  Since we weren't before the div, it
       * suffices to examine v1 and d1 -- the new d (former d1) cannot cut it
       */
      if (cmpii(v1,bmax) > 0) /* done, not found */
      {
	avma = av;
	return 0;
      }
      else if (cmpii(d1,amax) <= 0) /* done, found */
      {
	avma = av;
	if (a != NULL)
	{
	  if (signe(d1))
	  {
	    *a = icopy(d1);
	    setsigne(*a,s);	/* same sign as s */
	  }
	  else
	    *a = gen_0;
	}
	if (b != NULL) *b = icopy(v1);
	return 1;
      }
    }

    if (low_stack(lim, stack_lim(av,1)))
    {
      GEN *gptr[4]; gptr[0]=&d; gptr[1]=&d1; gptr[2]=&v; gptr[3]=&v1;
      if(DEBUGMEM>1) pari_warn(warnmem,"ratlift");
      gerepilemany(av1,gptr,4);
    }
  } /* end while */

  /* Postprocessing - final sprint.  Since we usually underestimate vmax,
   * this function needs a loop here instead of a simple conditional.
   * Note we can only get here when amax fits into one word  (which will
   * typically not be the case!).  The condition is bogus -- d1 is never
   * zero at the start of the loop.  There will be at most a few iterations,
   * so we don't bother collecting garbage
   */
  while (signe(d1))
  {
    /* Assertions: lgefint(d)==lgefint(d1)==3.
     * Moreover, we aren't done already, or we would have returned by now.
     * Recompute vmax...
     */
#ifdef DEBUG_RATLIFT
    fprintferr("rl-fs: d,d1=%Z,%Z\n", d, d1);
    fprintferr("rl-fs: v,v1=%Z,%Z\n", v, v1);
#endif
    r = addii(v,v1);
    lr = lb - lgefint(r);
    lbr = bfffo(*int_MSW(r));
    if (cmpii(r,bmax) > 0)	/* done, not found */
    {
      avma = av;
      return 0;
    }
    else if (lr > 1)		/* still more than a word's worth to go */
    {
      vmax = MAXULONG;		/* (cannot in fact happen) */
    }
    else			/* take difference of bit lengths */
    {
      lr = (lr << TWOPOTBITS_IN_LONG) - lbb + lbr;
      if ((ulong)lr > BITS_IN_LONG)
	vmax = MAXULONG;
      else if (lr == 0)
	vmax = 1UL;
      else
	vmax = 1UL << (lr-1);	/* as above */
    }
#ifdef DEBUG_RATLIFT
    fprintferr("rl-fs: vmax=%lu\n", vmax);
#endif
    /* single-word "Lehmer", discarding the gcd or whatever it returns */
    (void)rgcduu((ulong)*int_MSW(d), (ulong)*int_MSW(d1), vmax, &xu, &xu1, &xv, &xv1, &s0);
#ifdef DEBUG_RATLIFT
    fprintferr("rl-fs: [%lu,%lu; %lu,%lu] %s\n",
	       xu, xu1, xv, xv1,
	       s0 < 0 ? "-" : "+");
#endif
    if (xv1 == 1)		/* avoid multiplications */
    {
      /* re-use v+v1 computed above */
      v=v1; v1=r;
      r = subii(d,d1); d=d1; d1=r;
      s = -s;
    }
    else if (xu == 0)		/* and xv==1, xu1==1, xv1 > 1 */
    {
      r = subii(d, mului(xv1,d1)); d=d1; d1=r;
      r = addii(v, mului(xv1,v1)); v=v1; v1=r;
      s = -s;
    }
    else
    {
      r  = subii(muliu(d,xu),  muliu(d1,xv));
      d1 = subii(muliu(d,xu1), muliu(d1,xv1)); d = r;
      r  = addii(muliu(v,xu),  muliu(v1,xv));
      v1 = addii(muliu(v,xu1), muliu(v1,xv1)); v = r;
      if (s0 < 0)
      {
	setsigne(d,-signe(d));
	s = -s;
      }
      else if (signe(d1))		/* sic: might vanish now */
      {
	setsigne(d1,-signe(d1));
      }
    }
    /* check whether we're done, as above.  Assert v <= bmax.  Examine v1:
     * if v1 > bmax, check d and return 0 or 1 depending on the outcome;
     * if v1 <= bmax, check d1 and return 1 if d1 <= amax, otherwise proceed.
     */
    if (cmpii(v1,bmax) > 0) /* certainly done */
    {
      avma = av;
      if (cmpii(d,amax) <= 0) /* done, found */
      {
	if (a != NULL)
	{
	  *a = icopy(d);
	  setsigne(*a,-s);	/* sign opposite to s */
	}
	if (b != NULL) *b = icopy(v);
	return 1;
      }
      else			/* done, not found */
	return 0;
    }
    else if (cmpii(d1,amax) <= 0) /* also done, found */
    {
      avma = av;
      if (a != NULL)
      {
	if (signe(d1))
	{
	  *a = icopy(d1);
	  setsigne(*a,s);	/* same sign as s */
	}
	else
	  *a = gen_0;
      }
      if (b != NULL) *b = icopy(v1);
      return 1;
    }
  } /* while */

  /* get here when we have run into d1 == 0 before returning... in fact,
   * this cannot happen.
   */
  pari_err(talker, "ratlift failed to catch d1 == 0\n");
  /* NOTREACHED */
  return 0;
}
Example #30
0
/* Computation of potential block systems of given size d associated to a
 * rational prime p: give a row vector of row vectors containing the
 * potential block systems of imprimitivity; a potential block system is a
 * vector of row vectors (enumeration of the roots). */
static GEN
calc_block(blockdata *B, GEN Z, GEN Y, GEN SB)
{
  long r = lg(Z), lK, i, j, t, tp, T, u, nn, lnon, lY;
  GEN K, n, non, pn, pnon, e, Yp, Zp, Zpp;
  pari_sp av0 = avma;

  if (DEBUGLEVEL>3)
  {
    fprintferr("lg(Z) = %ld, lg(Y) = %ld\n", r,lg(Y));
    if (DEBUGLEVEL > 5)
    {
      fprintferr("Z = %Z\n",Z);
      fprintferr("Y = %Z\n",Y);
    }
  }
  lnon = min(BIL, r);
  e    = new_chunk(BIL);
  n    = new_chunk(r);
  non  = new_chunk(lnon);
  pnon = new_chunk(lnon);
  pn   = new_chunk(lnon);

  Zp   = cgetg(lnon,t_VEC);
  Zpp  = cgetg(lnon,t_VEC); nn = 0;
  for (i=1; i<r; i++) { n[i] = lg(Z[i])-1; nn += n[i]; }
  lY = lg(Y); Yp = cgetg(lY+1,t_VEC);
  for (j=1; j<lY; j++) Yp[j] = Y[j];

  {
    pari_sp av = avma;
    long k = nn / B->size;
    for (j = 1; j < r; j++) 
      if (n[j] % k) break;
    if (j == r)
    {
      gel(Yp,lY) = Z;
      SB = print_block_system(B, Yp, SB);
      avma = av;
    }
  }
  gel(Yp,lY) = Zp;

  K = divisors(utoipos(n[1])); lK = lg(K);
  for (i=1; i<lK; i++)
  {
    long ngcd = n[1], k = itos(gel(K,i)), dk = B->size*k, lpn = 0;
    for (j=2; j<r; j++)
      if (n[j]%k == 0)
      {
        if (++lpn >= BIL) pari_err(talker,"overflow in calc_block");
        pn[lpn] = n[j]; pnon[lpn] = j;
        ngcd = cgcd(ngcd, n[j]);
      }
    if (dk % ngcd) continue;
    T = 1<<lpn;
    if (lpn == r-2)
    {
      T--; /* done already above --> print_block_system */
      if (!T) continue;
    }

    if (dk == n[1])
    { /* empty subset, t = 0. Split out for clarity */
      Zp[1] = Z[1]; setlg(Zp, 2);
      for (u=1,j=2; j<r; j++) Zpp[u++] = Z[j];
      setlg(Zpp, u);
      SB = calc_block(B, Zpp, Yp, SB);
    }

    for (t = 1; t < T; t++)
    { /* loop through all non-empty subsets of [1..lpn] */
      for (nn=n[1],tp=t, u=1; u<=lpn; u++,tp>>=1)
      {
        if (tp&1) { nn += pn[u]; e[u] = 1; } else e[u] = 0;
      }
      if (dk != nn) continue;

      for (j=1; j<r; j++) non[j]=0;
      Zp[1] = Z[1];
      for (u=2,j=1; j<=lpn; j++)
        if (e[j]) { Zp[u] = Z[pnon[j]]; non[pnon[j]] = 1; u++; }
      setlg(Zp, u);
      for (u=1,j=2; j<r; j++)
        if (!non[j]) Zpp[u++] = Z[j];
      setlg(Zpp, u);
      SB = calc_block(B, Zpp, Yp, SB);
    }
  }
  avma = av0; return SB;
}