Line data Source code
1 : /* Copyright (C) 2000 The PARI group.
2 :
3 : This file is part of the PARI/GP package.
4 :
5 : PARI/GP is free software; you can redistribute it and/or modify it under the
6 : terms of the GNU General Public License as published by the Free Software
7 : Foundation; either version 2 of the License, or (at your option) any later
8 : version. It is distributed in the hope that it will be useful, but WITHOUT
9 : ANY WARRANTY WHATSOEVER.
10 :
11 : Check the License for details. You should have received a copy of it, along
12 : with the package; see the file 'COPYING'. If not, write to the Free Software
13 : Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. */
14 : #include "pari.h"
15 : #include "paripriv.h"
16 :
17 : #define DEBUGLEVEL DEBUGLEVEL_alg
18 :
19 : #define dbg_printf(lvl) if (DEBUGLEVEL >= (lvl) + 3) err_printf
20 :
21 : /********************************************************************/
22 : /** **/
23 : /** ASSOCIATIVE ALGEBRAS, CENTRAL SIMPLE ALGEBRAS **/
24 : /** contributed by Aurel Page (2014) **/
25 : /** **/
26 : /********************************************************************/
27 : static GEN alg_subalg(GEN al, GEN basis);
28 : static GEN alg_maximal_primes(GEN al, GEN P);
29 : static GEN algnatmultable(GEN al, long D);
30 : static GEN _tablemul_ej(GEN mt, GEN x, long j);
31 : static GEN _tablemul_ej_Fp(GEN mt, GEN x, long j, GEN p);
32 : static GEN _tablemul_ej_Fl(GEN mt, GEN x, long j, ulong p);
33 : static ulong algtracei(GEN mt, ulong p, ulong expo, ulong modu);
34 : static GEN alg_pmaximal(GEN al, GEN p);
35 : static GEN alg_maximal(GEN al);
36 : static GEN algtracematrix(GEN al);
37 : static GEN algtableinit_i(GEN mt0, GEN p);
38 : static GEN algbasisrightmultable(GEN al, GEN x);
39 : static GEN algbasismul(GEN al, GEN x, GEN y);
40 : static GEN algbasismultable(GEN al, GEN x);
41 : static GEN algbasismultable_Flm(GEN mt, GEN x, ulong m);
42 : static GEN algeltfromnf_i(GEN al, GEN x);
43 : static void computesplitting(GEN al, long d, long v, long flag);
44 : static GEN alg_change_overorder_shallow(GEN al, GEN ord);
45 :
46 : static GEN H_inv(GEN x);
47 : static GEN H_norm(GEN x, long abs);
48 : static GEN H_trace(GEN x, long abs);
49 :
50 : static int
51 1382656 : checkalg_i(GEN al)
52 : {
53 : GEN mt, rnf;
54 : long t;
55 1382656 : if (typ(al) != t_VEC || lg(al) != 12) return 0;
56 1382362 : mt = alg_get_multable(al);
57 1382362 : if (typ(mt) != t_VEC || lg(mt) == 1 || typ(gel(mt,1)) != t_MAT) return 0;
58 1382341 : rnf = alg_get_splittingfield(al);
59 1382341 : if (isintzero(rnf) || !gequal0(alg_get_char(al)))
60 524784 : return 1;
61 857557 : if (typ(gel(al,2)) != t_VEC || lg(gel(al,2)) == 1) return 0;
62 : /* not checkrnf_i: beware placeholder from alg_csa_table */
63 857550 : t = typ(rnf);
64 857550 : return t==t_COMPLEX || t==t_REAL || (t==t_VEC && lg(rnf)==13);
65 : }
66 : void
67 1509986 : checkalg(GEN al)
68 : {
69 1509986 : if (al && !checkalg_i(al))
70 168 : pari_err_TYPE("checkalg [please apply alginit()]",al);
71 1509818 : }
72 :
73 : static int
74 186858 : checklat_i(GEN al, GEN lat)
75 : {
76 : long N,i,j;
77 : GEN m,t,c;
78 186858 : if (typ(lat)!=t_VEC || lg(lat) != 3) return 0;
79 186858 : t = gel(lat,2);
80 186858 : if (typ(t) != t_INT && typ(t) != t_FRAC) return 0;
81 186858 : if (gsigne(t)<=0) return 0;
82 186858 : m = gel(lat,1);
83 186858 : if (typ(m) != t_MAT) return 0;
84 186858 : N = alg_get_absdim(al);
85 186858 : if (lg(m)-1 != N || lg(gel(m,1))-1 != N) return 0;
86 1686020 : for (i=1; i<=N; i++)
87 14154399 : for (j=1; j<=N; j++) {
88 12655237 : c = gcoeff(m,i,j);
89 12655237 : if (typ(c) != t_INT) return 0;
90 12655237 : if (j<i && signe(gcoeff(m,i,j))) return 0;
91 12655237 : if (i==j && !signe(gcoeff(m,i,j))) return 0;
92 : }
93 186851 : return 1;
94 : }
95 186858 : void checklat(GEN al, GEN lat)
96 186858 : { if (!checklat_i(al,lat)) pari_err_TYPE("checklat [please apply alglathnf()]", lat); }
97 :
98 : /** ACCESSORS **/
99 : long
100 9805305 : alg_type(GEN al)
101 : {
102 : long t;
103 9805305 : if (!al) return al_REAL;
104 9675147 : t = typ(alg_get_splittingfield(al));
105 9675147 : if (t==t_REAL || t==t_COMPLEX) return al_REAL;
106 9671654 : if (isintzero(alg_get_splittingfield(al)) || !gequal0(alg_get_char(al))) return al_TABLE;
107 7555946 : switch(typ(gmael(al,2,1))) {
108 1658370 : case t_MAT: return al_CSA;
109 5897541 : case t_INT:
110 : case t_FRAC:
111 : case t_POL:
112 5897541 : case t_POLMOD: return al_CYCLIC;
113 35 : default: return al_NULL;
114 : }
115 : return -1; /*LCOV_EXCL_LINE*/
116 : }
117 : long
118 2233 : algtype(GEN al)
119 2233 : { return checkalg_i(al)? alg_type(al): al_NULL; }
120 :
121 : static long /* is a square special case? */
122 1148 : alg_is_asq(GEN al) { return typ(gmael(al,6,1)) == t_VEC; }
123 :
124 : /* absdim == dim for al_TABLE. */
125 : static long
126 259 : algreal_dim(GEN al)
127 : {
128 259 : switch(lg(alg_get_multable(al))) {
129 161 : case 2: case 3: return 1;
130 91 : case 5: return 4;
131 7 : default: pari_err_TYPE("algreal_dim", al);
132 : }
133 : return -1; /*LCOV_EXCL_LINE*/
134 : }
135 : long
136 402134 : alg_get_dim(GEN al)
137 : {
138 : long d;
139 402134 : if (!al) return 4;
140 402134 : switch(alg_type(al)) {
141 18527 : case al_TABLE: return lg(alg_get_multable(al))-1;
142 383495 : case al_CSA: return lg(alg_get_relmultable(al))-1;
143 77 : case al_CYCLIC: d = alg_get_degree(al); return d*d;
144 28 : case al_REAL: return algreal_dim(al);
145 7 : default: pari_err_TYPE("alg_get_dim", al);
146 : }
147 : return -1; /*LCOV_EXCL_LINE*/
148 : }
149 :
150 : long
151 2518797 : alg_get_absdim(GEN al)
152 : {
153 2518797 : if (!al) return 4;
154 2472079 : switch(alg_type(al)) {
155 899233 : case al_TABLE: case al_REAL: return lg(alg_get_multable(al))-1;
156 195636 : case al_CSA: return alg_get_dim(al)*nf_get_degree(alg_get_center(al));
157 1377203 : case al_CYCLIC:
158 1377203 : return rnf_get_absdegree(alg_get_splittingfield(al))*alg_get_degree(al);
159 7 : default: pari_err_TYPE("alg_get_absdim", al);
160 : }
161 : return -1;/*LCOV_EXCL_LINE*/
162 : }
163 :
164 : long
165 6160 : algdim(GEN al, long abs)
166 : {
167 6160 : checkalg(al);
168 6139 : if (abs) return alg_get_absdim(al);
169 5551 : return alg_get_dim(al);
170 : }
171 :
172 : /* only cyclic */
173 : GEN
174 17283 : alg_get_auts(GEN al)
175 : {
176 17283 : long ta = alg_type(al);
177 17283 : if (ta != al_CYCLIC && ta != al_REAL)
178 0 : pari_err_TYPE("alg_get_auts [noncyclic algebra]", al);
179 17283 : return gel(al,2);
180 : }
181 : GEN
182 133 : alg_get_aut(GEN al)
183 : {
184 133 : long ta = alg_type(al);
185 133 : if (ta != al_CYCLIC && ta != al_REAL)
186 28 : pari_err_TYPE("alg_get_aut [noncyclic algebra]", al);
187 105 : return gel(alg_get_auts(al),1);
188 : }
189 : GEN
190 63 : algaut(GEN al) { checkalg(al); return alg_get_aut(al); }
191 : GEN
192 17367 : alg_get_b(GEN al)
193 : {
194 17367 : long ta = alg_type(al);
195 17367 : if (ta != al_CYCLIC && ta != al_REAL)
196 28 : pari_err_TYPE("alg_get_b [noncyclic algebra]", al);
197 17339 : return gel(al,3);
198 : }
199 : GEN
200 91 : algb(GEN al) { checkalg(al); return alg_get_b(al); }
201 :
202 : /* only CSA */
203 : GEN
204 386099 : alg_get_relmultable(GEN al)
205 : {
206 386099 : if (alg_type(al) != al_CSA)
207 14 : pari_err_TYPE("alg_get_relmultable [algebra not given via mult. table]", al);
208 386085 : return gel(al,2);
209 : }
210 : GEN
211 70 : algrelmultable(GEN al) { checkalg(al); return alg_get_relmultable(al); }
212 : GEN
213 84 : alg_get_splittingdata(GEN al)
214 : {
215 84 : if (alg_type(al) != al_CSA)
216 14 : pari_err_TYPE("alg_get_splittingdata [algebra not given via mult. table]",al);
217 70 : return gel(al,3);
218 : }
219 : GEN
220 84 : algsplittingdata(GEN al) { checkalg(al); return alg_get_splittingdata(al); }
221 : GEN
222 4347 : alg_get_splittingbasis(GEN al)
223 : {
224 4347 : if (alg_type(al) != al_CSA)
225 0 : pari_err_TYPE("alg_get_splittingbasis [algebra not given via mult. table]",al);
226 4347 : return gmael(al,3,2);
227 : }
228 : GEN
229 4347 : alg_get_splittingbasisinv(GEN al)
230 : {
231 4347 : if (alg_type(al) != al_CSA)
232 0 : pari_err_TYPE("alg_get_splittingbasisinv [algebra not given via mult. table]",al);
233 4347 : return gmael(al,3,3);
234 : }
235 :
236 : /* only cyclic and CSA */
237 : GEN
238 25293201 : alg_get_splittingfield(GEN al) { return gel(al,1); }
239 : GEN
240 161 : algsplittingfield(GEN al)
241 : {
242 : long ta;
243 161 : checkalg(al);
244 161 : ta = alg_type(al);
245 161 : if (ta != al_CYCLIC && ta != al_CSA && ta != al_REAL)
246 7 : pari_err_TYPE("alg_get_splittingfield [use alginit]",al);
247 154 : return alg_get_splittingfield(al);
248 : }
249 : long
250 2456907 : alg_get_degree(GEN al)
251 : {
252 : long ta;
253 2456907 : ta = alg_type(al);
254 2456907 : if (ta == al_REAL) return algreal_dim(al)==1? 1 : 2;
255 2456823 : if (ta != al_CYCLIC && ta != al_CSA)
256 21 : pari_err_TYPE("alg_get_degree [use alginit]",al);
257 2456802 : return rnf_get_degree(alg_get_splittingfield(al));
258 : }
259 : long
260 679 : algdegree(GEN al)
261 : {
262 679 : checkalg(al);
263 672 : return alg_get_degree(al);
264 : }
265 :
266 : GEN
267 519163 : alg_get_center(GEN al)
268 : {
269 : long ta;
270 519163 : ta = alg_type(al);
271 519163 : if (ta == al_REAL)
272 : {
273 28 : if (algreal_dim(al) != 4) return alg_get_splittingfield(al);
274 14 : return stor(1, LOWDEFAULTPREC);
275 : }
276 519135 : if (ta != al_CSA && ta != al_CYCLIC)
277 14 : pari_err_TYPE("alg_get_center [use alginit]",al);
278 519121 : return rnf_get_nf(alg_get_splittingfield(al));
279 : }
280 : GEN
281 294 : alg_get_splitpol(GEN al)
282 : {
283 294 : long ta = alg_type(al);
284 294 : if (ta != al_CYCLIC && ta != al_CSA)
285 0 : pari_err_TYPE("alg_get_splitpol [use alginit]",al);
286 294 : return rnf_get_pol(alg_get_splittingfield(al));
287 : }
288 : GEN
289 93962 : alg_get_abssplitting(GEN al)
290 : {
291 93962 : long ta = alg_type(al), prec;
292 93962 : if (ta != al_CYCLIC && ta != al_CSA)
293 0 : pari_err_TYPE("alg_get_abssplitting [use alginit]",al);
294 93962 : prec = nf_get_prec(alg_get_center(al));
295 93962 : return rnf_build_nfabs(alg_get_splittingfield(al), prec);
296 : }
297 : GEN
298 1743 : alg_get_hasse_i(GEN al)
299 : {
300 1743 : long ta = alg_type(al);
301 1743 : if (ta != al_CYCLIC && ta != al_CSA && ta != al_REAL)
302 7 : pari_err_TYPE("alg_get_hasse_i [use alginit]",al);
303 1736 : if (ta == al_CSA && !alg_is_asq(al))
304 7 : pari_err_IMPL("computation of Hasse invariants over table CSA");
305 1729 : return gel(al,4);
306 : }
307 : GEN
308 252 : alghassei(GEN al) { checkalg(al); return alg_get_hasse_i(al); }
309 : GEN
310 3871 : alg_get_hasse_f(GEN al)
311 : {
312 3871 : long ta = alg_type(al);
313 : GEN hf;
314 3871 : if (ta != al_CYCLIC && ta != al_CSA)
315 7 : pari_err_TYPE("alg_get_hasse_f [use alginit]",al);
316 3864 : if (ta == al_CSA && !alg_is_asq(al))
317 7 : pari_err_IMPL("computation of Hasse invariants over table CSA");
318 3857 : hf = gel(al,5);
319 3857 : if (typ(hf) == t_INT) /* could be computed on the fly */
320 28 : pari_err(e_MISC, "Hasse invariants were not computed for this algebra");
321 3829 : return hf;
322 : }
323 : GEN
324 357 : alghassef(GEN al) { checkalg(al); return alg_get_hasse_f(al); }
325 :
326 : /* all types */
327 : GEN
328 3276 : alg_get_basis(GEN al) { return gel(al,7); }
329 : GEN
330 154 : algbasis(GEN al) { checkalg(al); return alg_get_basis(al); }
331 : GEN
332 82034 : alg_get_invbasis(GEN al) { return gel(al,8); }
333 : GEN
334 84 : alginvbasis(GEN al) { checkalg(al); return alg_get_invbasis(al); }
335 : GEN
336 3645462 : alg_get_multable(GEN al) { return gel(al,9); }
337 : GEN
338 308 : algmultable(GEN al) { checkalg(al); return alg_get_multable(al); }
339 : GEN
340 11357023 : alg_get_char(GEN al) { if (!al) return gen_0; return gel(al,10); }
341 : GEN
342 112 : algchar(GEN al) { checkalg(al); return alg_get_char(al); }
343 : GEN
344 587271 : alg_get_tracebasis(GEN al) { return gel(al,11); }
345 :
346 : /* lattices */
347 : GEN
348 251188 : alglat_get_primbasis(GEN lat) { return gel(lat,1); }
349 : GEN
350 296779 : alglat_get_scalar(GEN lat) { return gel(lat,2); }
351 :
352 : /* algmodpr */
353 : GEN
354 3948 : algmodpr_get_pr(GEN data) { return gel(data,1); }
355 : long
356 5005 : algmodpr_get_k(GEN data) { return gel(data,2)[1]; } /* target M_k(F_p^m) */
357 : long
358 2219 : algmodpr_get_m(GEN data) { return gel(data,2)[2]; } /* target M_k(F_p^m) */
359 : GEN
360 1715 : algmodpr_get_ff(GEN data) { return gel(data,3); }
361 : GEN
362 1708 : algmodpr_get_proj(GEN data) { return gel(data,4); }
363 : GEN
364 3003 : algmodpr_get_lift(GEN data) { return gel(data,5); }
365 : GEN
366 1729 : algmodpr_get_tau(GEN data) { return gel(data,6); }
367 : GEN
368 3948 : algmodpr_get_p(GEN data) { return pr_get_p(algmodpr_get_pr(data)); }
369 : GEN
370 3801 : algmodpr_get_T(GEN data) { return gel(data,2)[2]==1 ? NULL : gel(data,7); }
371 :
372 : /** ADDITIONAL **/
373 :
374 : /* is N=smooth*prime? */
375 15074 : static int Z_easyfactor(GEN N, ulong lim)
376 : {
377 : GEN fa;
378 15074 : if (lgefint(N) <= 3) return 1;
379 13629 : fa = absZ_factor_limit(N, lim);
380 13629 : return BPSW_psp(veclast(gel(fa,1)));
381 : }
382 :
383 : /* no garbage collection */
384 : static GEN
385 1491 : backtrackfacto(GEN y0, long n, GEN red, GEN pl, GEN nf, GEN data, int (*test)(GEN,GEN), GEN* fa, GEN N, GEN I)
386 : {
387 : long b, i;
388 1491 : ulong lim = 1UL << 17;
389 1491 : long *v = new_chunk(n+1);
390 1491 : pari_sp av = avma;
391 1491 : for (b = 0;; b += (2*b)/(3*n) + 1)
392 323 : {
393 : GEN ny, y1, y2;
394 1814 : set_avma(av);
395 5320 : for (i = 1; i <= n; i++) v[i] = -b;
396 1814 : v[n]--;
397 : for(;;)
398 : {
399 15434 : i = n;
400 16042 : while (i > 0)
401 15719 : { if (v[i] == b) v[i--] = -b; else { v[i]++; break; } }
402 15434 : if (i==0) break;
403 :
404 15111 : y1 = y0;
405 32913 : for (i = 1; i <= n; i++) y1 = nfadd(nf, y1, ZC_z_mul(gel(red,i), v[i]));
406 15111 : if (!nfchecksigns(nf, y1, pl)) continue;
407 :
408 15074 : ny = absi_shallow(nfnorm(nf, y1));
409 15074 : if (!signe(ny)) continue;
410 15074 : ny = diviiexact(ny, gcdii(ny, N));
411 15074 : if (!Z_easyfactor(ny, lim)) continue;
412 :
413 2053 : y2 = idealdivexact(nf, y1, idealadd(nf,y1,I));
414 2053 : *fa = idealfactor(nf, y2);
415 2053 : if (!data || test(data,*fa)) return y1;
416 : }
417 : }
418 : }
419 :
420 : /* if data == NULL, the test is skipped */
421 : /* in the test, the factorization does not contain the known factors */
422 : static GEN
423 1491 : factoredextchinesetest(GEN nf, GEN x, GEN y, GEN pl, GEN* fa, GEN data, int (*test)(GEN,GEN))
424 : {
425 1491 : pari_sp av = avma;
426 : long n,i;
427 1491 : GEN x1, y0, y1, red, N, I, P = gel(x,1), E = gel(x,2);
428 1491 : n = nf_get_degree(nf);
429 1491 : x = idealchineseinit(nf, mkvec2(x,pl));
430 1491 : x1 = gel(x,1);
431 1491 : red = lg(x1) == 1? matid(n): gmael(x1,1,1);
432 1491 : y0 = idealchinese(nf, x, y);
433 :
434 1491 : E = shallowcopy(E);
435 1491 : if (!gequal0(y0))
436 6826 : for (i=1; i<lg(E); i++)
437 : {
438 5335 : long v = nfval(nf,y0,gel(P,i));
439 5335 : if (cmpsi(v, gel(E,i)) < 0) gel(E,i) = stoi(v);
440 : }
441 : /* N and I : known factors */
442 1491 : I = factorbackprime(nf, P, E);
443 1491 : N = idealnorm(nf,I);
444 :
445 1491 : y1 = backtrackfacto(y0, n, red, pl, nf, data, test, fa, N, I);
446 :
447 : /* restore known factors */
448 6826 : for (i=1; i<lg(E); i++) gel(E,i) = stoi(nfval(nf,y1,gel(P,i)));
449 1491 : *fa = famat_reduce(famat_mul_shallow(*fa, mkmat2(P, E)));
450 1491 : return gc_all(av, 2, &y1, fa);
451 : }
452 :
453 : static GEN
454 1148 : factoredextchinese(GEN nf, GEN x, GEN y, GEN pl, GEN* fa)
455 1148 : { return factoredextchinesetest(nf,x,y,pl,fa,NULL,NULL); }
456 :
457 : /** OPERATIONS ON ASSOCIATIVE ALGEBRAS algebras.c **/
458 :
459 : /*
460 : Convention:
461 : (K/F,sigma,b) = sum_{i=0..n-1} u^i*K
462 : t*u = u*sigma(t)
463 :
464 : Natural basis:
465 : 1<=i<=d*n^2
466 : b_i = u^((i-1)/(dn))*ZKabs.((i-1)%(dn)+1)
467 :
468 : Integral basis:
469 : Basis of some order.
470 :
471 : al:
472 : 1- rnf of the cyclic splitting field of degree n over the center nf of degree d
473 : 2- VEC of aut^i 1<=i<=n if n>1, or i=0 if n=1
474 : 3- b in nf
475 : 4- infinite hasse invariants (mod n) : VECSMALL of size r1, values only 0 or n/2 (if integral)
476 : 5- finite hasse invariants (mod n) : VEC[VEC of primes, VECSMALL of hasse inv mod n]
477 : 6- currently unused (gen_0 placeholder)
478 : 7* dn^2*dn^2 matrix expressing the integral basis in terms of the natural basis
479 : 8* dn^2*dn^2 matrix expressing the natural basis in terms of the integral basis
480 : 9* VEC of dn^2 matrices giving the dn^2*dn^2 left multiplication tables of the integral basis
481 : 10* characteristic of the base field (used only for algebras given by a multiplication table)
482 : 11* trace of basis elements
483 :
484 : If al is given by a multiplication table (al_TABLE), only the * fields are present.
485 : The other ones are filled with gen_0 placeholders.
486 : */
487 :
488 : /* assumes same center and same variable */
489 : /* currently only works for coprime degrees */
490 : GEN
491 84 : algtensor(GEN al1, GEN al2, long flag) {
492 84 : pari_sp av = avma;
493 : long v, k, d1, d2;
494 : GEN nf, P1, P2, aut1, aut2, b1, b2, C, rnf, aut, b, x1, x2, al, rnfpol;
495 :
496 84 : checkalg(al1);
497 70 : checkalg(al2);
498 63 : if (alg_type(al1) != al_CYCLIC || alg_type(al2) != al_CYCLIC)
499 21 : pari_err_IMPL("tensor of noncyclic algebras"); /* TODO: do it. */
500 :
501 42 : nf = alg_get_center(al1);
502 42 : if (!gequal(alg_get_center(al2),nf))
503 7 : pari_err_OP("tensor product [not the same center]", al1, al2);
504 :
505 35 : P1=alg_get_splitpol(al1); aut1=alg_get_aut(al1); b1=alg_get_b(al1);
506 35 : P2=alg_get_splitpol(al2); aut2=alg_get_aut(al2); b2=alg_get_b(al2);
507 35 : v=varn(P1);
508 :
509 35 : d1=alg_get_degree(al1);
510 35 : d2=alg_get_degree(al2);
511 35 : if (ugcd(d1,d2) != 1)
512 7 : pari_err_IMPL("tensor of cyclic algebras of noncoprime degrees"); /* TODO */
513 :
514 28 : if (d1==1) return gcopy(al2);
515 21 : if (d2==1) return gcopy(al1);
516 :
517 14 : C = nfcompositum(nf, P1, P2, 3);
518 14 : rnfpol = gel(C,1);
519 14 : if (!(flag & al_FACTOR)) rnfpol = mkvec2(rnfpol, stoi(1<<20));
520 14 : rnf = rnfinit(nf, rnfpol);
521 : /* TODO use integral basis of P1 and P2 to get that of C */
522 14 : x1 = gel(C,2);
523 14 : x2 = gel(C,3);
524 14 : k = itos(gel(C,4));
525 14 : aut = gadd(gsubst(aut2,v,x2),gmulsg(k,gsubst(aut1,v,x1)));
526 14 : b = nfmul(nf,nfpow_u(nf,b1,d2),nfpow_u(nf,b2,d1));
527 14 : al = alg_cyclic(rnf, aut, b, flag);
528 14 : return gerepilecopy(av,al);
529 : }
530 :
531 : /* M an n x d Flm of rank d, n >= d. Initialize Mx = y solver */
532 : static GEN
533 7072 : Flm_invimage_init(GEN M, ulong p)
534 : {
535 7072 : GEN v = Flm_indexrank(M, p), perm = gel(v,1);
536 7072 : GEN MM = rowpermute(M, perm); /* square invertible */
537 7072 : return mkvec2(Flm_inv(MM,p), perm);
538 : }
539 : /* assume Mx = y has a solution, v = Flm_invimage_init(M,p); return x */
540 : static GEN
541 520237 : Flm_invimage_pre(GEN v, GEN y, ulong p)
542 : {
543 520237 : GEN inv = gel(v,1), perm = gel(v,2);
544 520237 : return Flm_Flc_mul(inv, vecsmallpermute(y, perm), p);
545 : }
546 :
547 : GEN
548 12824 : algradical(GEN al)
549 : {
550 12824 : pari_sp av = avma;
551 : GEN I, x, traces, K, MT, P, mt;
552 : long l,i,ni, n;
553 : ulong modu, expo, p;
554 12824 : checkalg(al);
555 12824 : if (alg_type(al) != al_TABLE) return gen_0;
556 12733 : P = alg_get_char(al);
557 12733 : mt = alg_get_multable(al);
558 12733 : n = alg_get_absdim(al);
559 12733 : dbg_printf(1)("algradical: char=%Ps, dim=%d\n", P, n);
560 12733 : traces = algtracematrix(al);
561 12733 : if (!signe(P))
562 : {
563 546 : dbg_printf(2)(" char 0, computing kernel...\n");
564 546 : K = ker(traces);
565 546 : dbg_printf(2)(" ...done.\n");
566 546 : ni = lg(K)-1; if (!ni) return gc_const(av, gen_0);
567 70 : return gerepileupto(av, K);
568 : }
569 12187 : dbg_printf(2)(" char>0, computing kernel...\n");
570 12187 : K = FpM_ker(traces, P);
571 12187 : dbg_printf(2)(" ...done.\n");
572 12187 : ni = lg(K)-1; if (!ni) return gc_const(av, gen_0);
573 6512 : if (abscmpiu(P,n)>0) return gerepileupto(av, K);
574 :
575 : /* tough case, p <= n. Ronyai's algorithm */
576 3944 : p = P[2]; l = 1;
577 3944 : expo = p; modu = p*p;
578 3944 : dbg_printf(2)(" char>0, hard case.\n");
579 7632 : while (modu<=(ulong)n) { l++; modu *= p; }
580 3944 : MT = ZMV_to_FlmV(mt, modu);
581 3944 : I = ZM_to_Flm(K,p); /* I_0 */
582 10582 : for (i=1; i<=l; i++) {/*compute I_i, expo = p^i, modu = p^(l+1) > n*/
583 : long j, lig,col;
584 7072 : GEN v = cgetg(ni+1, t_VECSMALL);
585 7072 : GEN invI = Flm_invimage_init(I, p);
586 7072 : dbg_printf(2)(" computing I_%d:\n", i);
587 7072 : traces = cgetg(ni+1,t_MAT);
588 48502 : for (j = 1; j <= ni; j++)
589 : {
590 41430 : GEN M = algbasismultable_Flm(MT, gel(I,j), modu);
591 41430 : uel(v,j) = algtracei(M, p,expo,modu);
592 : }
593 48502 : for (col=1; col<=ni; col++)
594 : {
595 41430 : GEN t = cgetg(n+1,t_VECSMALL); gel(traces,col) = t;
596 41430 : x = gel(I, col); /*col-th basis vector of I_{i-1}*/
597 561667 : for (lig=1; lig<=n; lig++)
598 : {
599 520237 : GEN y = _tablemul_ej_Fl(MT,x,lig,p);
600 520237 : GEN z = Flm_invimage_pre(invI, y, p);
601 520237 : uel(t,lig) = Flv_dotproduct(v, z, p);
602 : }
603 : }
604 7072 : dbg_printf(2)(" computing kernel...\n");
605 7072 : K = Flm_ker(traces, p);
606 7072 : dbg_printf(2)(" ...done.\n");
607 7072 : ni = lg(K)-1; if (!ni) return gc_const(av, gen_0);
608 6638 : I = Flm_mul(I,K,p);
609 6638 : expo *= p;
610 : }
611 3510 : return Flm_to_ZM(I);
612 : }
613 :
614 : /* compute the multiplication table of the element x, where mt is a
615 : * multiplication table in an arbitrary ring */
616 : static GEN
617 476 : Rgmultable(GEN mt, GEN x)
618 : {
619 476 : long i, l = lg(x);
620 476 : GEN z = NULL;
621 6188 : for (i = 1; i < l; i++)
622 : {
623 5712 : GEN c = gel(x,i);
624 5712 : if (!gequal0(c))
625 : {
626 714 : GEN M = RgM_Rg_mul(gel(mt,i),c);
627 714 : z = z? RgM_add(z, M): M;
628 : }
629 : }
630 476 : return z;
631 : }
632 :
633 : static GEN
634 56 : change_Rgmultable(GEN mt, GEN P, GEN Pi)
635 : {
636 : GEN mt2;
637 56 : long lmt = lg(mt), i;
638 56 : mt2 = cgetg(lmt,t_VEC);
639 532 : for (i=1;i<lmt;i++) {
640 476 : GEN mti = Rgmultable(mt,gel(P,i));
641 476 : gel(mt2,i) = RgM_mul(Pi, RgM_mul(mti,P));
642 : }
643 56 : return mt2;
644 : }
645 :
646 : /* S: lift (basis of quotient) ; Si: proj */
647 : static GEN
648 33713 : alg_quotient0(GEN al, GEN S, GEN Si, long nq, GEN p, long maps)
649 : {
650 33713 : GEN mt = cgetg(nq+1,t_VEC), P, Pi, d;
651 : long i;
652 33713 : dbg_printf(3)(" alg_quotient0: char=%Ps, dim=%d, dim I=%d\n", p, alg_get_absdim(al), lg(S)-1);
653 151271 : for (i=1; i<=nq; i++) {
654 117558 : GEN mti = algbasismultable(al,gel(S,i));
655 117558 : if (signe(p)) gel(mt,i) = FpM_mul(Si, FpM_mul(mti,S,p), p);
656 6076 : else gel(mt,i) = RgM_mul(Si, RgM_mul(mti,S));
657 : }
658 33713 : if (!signe(p) && !isint1(Q_denom(mt))) {
659 42 : dbg_printf(3)(" bad case: denominator=%Ps\n", Q_denom(mt));
660 42 : P = Q_remove_denom(Si,&d);
661 42 : P = ZM_hnf(P);
662 42 : P = RgM_Rg_div(P,d); /* P: new basis (Z-basis of image of order in al) */
663 42 : Pi = RgM_inv(P);
664 42 : mt = change_Rgmultable(mt,P,Pi);
665 42 : Si = RgM_mul(Pi,Si);
666 42 : S = RgM_mul(S,P);
667 : }
668 33713 : al = algtableinit_i(mt,p);
669 33713 : if (maps) al = mkvec3(al,Si,S); /* algebra, proj, lift */
670 33713 : return al;
671 : }
672 :
673 : /* quotient of an algebra by a nontrivial two-sided ideal */
674 : GEN
675 10901 : alg_quotient(GEN al, GEN I, long maps)
676 : {
677 10901 : pari_sp av = avma;
678 : GEN p, IS, ISi, S, Si;
679 : long n, ni;
680 :
681 10901 : checkalg(al);
682 10901 : if (alg_type(al) != al_TABLE) pari_err_TYPE("alg_quotient [not a table algebra]", al);
683 10894 : p = alg_get_char(al);
684 10894 : n = alg_get_absdim(al);
685 10894 : ni = lg(I)-1;
686 :
687 : /* force first vector of complement to be the identity */
688 10894 : IS = shallowconcat(I, gcoeff(alg_get_multable(al),1,1));
689 10894 : if (signe(p)) {
690 10866 : IS = FpM_suppl(IS,p);
691 10866 : ISi = FpM_inv(IS,p);
692 : }
693 : else {
694 28 : IS = suppl(IS);
695 28 : ISi = RgM_inv(IS);
696 : }
697 10894 : S = vecslice(IS, ni+1, n);
698 10894 : Si = rowslice(ISi, ni+1, n);
699 10894 : return gerepilecopy(av, alg_quotient0(al, S, Si, n-ni, p, maps));
700 : }
701 :
702 : static GEN
703 35628 : image_keep_first(GEN m, GEN p) /* assume first column is nonzero or m==0, no GC */
704 : {
705 : GEN ir, icol, irow, M, c, x;
706 : long i;
707 35628 : if (gequal0(gel(m,1))) return zeromat(nbrows(m),0);
708 :
709 35614 : if (signe(p)) ir = FpM_indexrank(m,p);
710 1708 : else ir = indexrank(m);
711 :
712 35614 : icol = gel(ir,2);
713 35614 : if (icol[1]==1) return extract0(m,icol,NULL);
714 :
715 14 : irow = gel(ir,1);
716 14 : M = extract0(m, irow, icol);
717 14 : c = extract0(gel(m,1), irow, NULL);
718 14 : if (signe(p)) x = FpM_FpC_invimage(M,c,p);
719 0 : else x = inverseimage(M,c); /* TODO modulo a small prime */
720 :
721 21 : for (i=1; i<lg(x); i++)
722 : {
723 21 : if (!gequal0(gel(x,i)))
724 : {
725 14 : icol[i] = 1;
726 14 : vecsmall_sort(icol);
727 14 : return extract0(m,icol,NULL);
728 : }
729 : }
730 :
731 : return NULL; /* LCOV_EXCL_LINE */
732 : }
733 :
734 : /* z[1],...z[nz] central elements such that z[1]A + z[2]A + ... + z[nz]A = A
735 : * is a direct sum. idempotents ==> first basis element is identity */
736 : GEN
737 11069 : alg_centralproj(GEN al, GEN z, long maps)
738 : {
739 11069 : pari_sp av = avma;
740 : GEN S, U, Ui, alq, p;
741 11069 : long i, iu, lz = lg(z), ta;
742 :
743 11069 : checkalg(al);
744 11069 : ta = alg_type(al);
745 11069 : if (ta != al_TABLE) pari_err_TYPE("algcentralproj [not a table algebra]", al);
746 11062 : if (typ(z) != t_VEC) pari_err_TYPE("alcentralproj",z);
747 11055 : p = alg_get_char(al);
748 11055 : dbg_printf(3)(" alg_centralproj: char=%Ps, dim=%d, #z=%d\n", p, alg_get_absdim(al), lz-1);
749 11055 : S = cgetg(lz,t_VEC); /* S[i] = Im(z_i) */
750 33888 : for (i=1; i<lz; i++)
751 : {
752 22833 : GEN mti = algbasismultable(al, gel(z,i));
753 22833 : gel(S,i) = image_keep_first(mti,p);
754 : }
755 11055 : U = shallowconcat1(S); /* U = [Im(z_1)|Im(z_2)|...|Im(z_nz)], n x n */
756 11055 : if (lg(U)-1 < alg_get_absdim(al)) pari_err_TYPE("alcentralproj [z[i]'s not surjective]",z);
757 11048 : if (signe(p)) Ui = FpM_inv(U,p);
758 854 : else Ui = RgM_inv(U);
759 : if (!Ui) pari_err_BUG("alcentralproj"); /*LCOV_EXCL_LINE*/
760 :
761 11048 : alq = cgetg(lz,t_VEC);
762 33867 : for (iu=0,i=1; i<lz; i++)
763 : {
764 22819 : long nq = lg(gel(S,i))-1, ju = iu + nq;
765 22819 : GEN Si = rowslice(Ui, iu+1, ju);
766 22819 : gel(alq, i) = alg_quotient0(al,gel(S,i),Si,nq,p,maps);
767 22819 : iu = ju;
768 : }
769 11048 : return gerepilecopy(av, alq);
770 : }
771 :
772 : /* al is an al_TABLE */
773 : static GEN
774 30613 : algtablecenter(GEN al)
775 : {
776 30613 : pari_sp av = avma;
777 : long n, i, j, k, ic;
778 : GEN C, cij, mt, p;
779 :
780 30613 : n = alg_get_absdim(al);
781 30613 : mt = alg_get_multable(al);
782 30613 : p = alg_get_char(al);
783 30613 : C = cgetg(n+1,t_MAT);
784 147573 : for (j=1; j<=n; j++)
785 : {
786 116960 : gel(C,j) = cgetg(n*n-n+1,t_COL);
787 116960 : ic = 1;
788 1079012 : for (i=2; i<=n; i++) {
789 962052 : if (signe(p)) cij = FpC_sub(gmael(mt,i,j),gmael(mt,j,i),p);
790 57694 : else cij = RgC_sub(gmael(mt,i,j),gmael(mt,j,i));
791 19631736 : for (k=1; k<=n; k++, ic++) gcoeff(C,ic,j) = gel(cij, k);
792 : }
793 : }
794 30613 : if (signe(p)) return gerepileupto(av, FpM_ker(C,p));
795 1785 : else return gerepileupto(av, ker(C));
796 : }
797 :
798 : GEN
799 11795 : algcenter(GEN al)
800 : {
801 11795 : checkalg(al);
802 11795 : if (alg_type(al)==al_TABLE) return algtablecenter(al);
803 2821 : return alg_get_center(al);
804 : }
805 :
806 : /* Only in positive characteristic. Assumes that al is semisimple. */
807 : GEN
808 8138 : algprimesubalg(GEN al)
809 : {
810 8138 : pari_sp av = avma;
811 : GEN p, Z, F, K;
812 : long nz, i;
813 8138 : checkalg(al);
814 8138 : p = alg_get_char(al);
815 8138 : if (!signe(p)) pari_err_DOMAIN("algprimesubalg","characteristic","=",gen_0,p);
816 :
817 8124 : Z = algtablecenter(al);
818 8124 : nz = lg(Z)-1;
819 8124 : if (nz==1) return Z;
820 :
821 5905 : F = cgetg(nz+1, t_MAT);
822 25330 : for (i=1; i<=nz; i++) {
823 19425 : GEN zi = gel(Z,i);
824 19425 : gel(F,i) = FpC_sub(algpow(al,zi,p),zi,p);
825 : }
826 5905 : K = FpM_ker(F,p);
827 5905 : return gerepileupto(av, FpM_mul(Z,K,p));
828 : }
829 :
830 : static GEN
831 18737 : out_decompose(GEN t, GEN Z, GEN P, GEN p)
832 : {
833 18737 : GEN ali = gel(t,1), projm = gel(t,2), liftm = gel(t,3), pZ;
834 18737 : if (signe(p)) pZ = FpM_image(FpM_mul(projm,Z,p),p);
835 1617 : else pZ = image(RgM_mul(projm,Z));
836 18737 : return mkvec5(ali, projm, liftm, pZ, P);
837 : }
838 : /* fa factorization of charpol(x) */
839 : static GEN
840 9407 : alg_decompose_from_facto(GEN al, GEN x, GEN fa, GEN Z, long mini)
841 : {
842 9407 : long k = lgcols(fa)-1, k2 = mini? 1: k/2;
843 9407 : GEN v1 = rowslice(fa,1,k2);
844 9407 : GEN v2 = rowslice(fa,k2+1,k);
845 9407 : GEN alq, P, Q, p = alg_get_char(al);
846 9407 : dbg_printf(3)(" alg_decompose_from_facto\n");
847 9407 : if (signe(p)) {
848 8581 : P = FpXV_factorback(gel(v1,1), gel(v1,2), p, 0);
849 8581 : Q = FpXV_factorback(gel(v2,1), gel(v2,2), p, 0);
850 8581 : P = FpX_mul(P, FpXQ_inv(P,Q,p), p);
851 : }
852 : else {
853 826 : P = factorback(v1);
854 826 : Q = factorback(v2);
855 826 : P = RgX_mul(P, RgXQ_inv(P,Q));
856 : }
857 9407 : P = algpoleval(al, P, x);
858 9407 : if (signe(p)) Q = FpC_sub(col_ei(lg(P)-1,1), P, p);
859 826 : else Q = gsub(gen_1, P);
860 9407 : if (gequal0(P) || gequal0(Q)) return NULL;
861 9407 : alq = alg_centralproj(al, mkvec2(P,Q), 1);
862 :
863 9407 : P = out_decompose(gel(alq,1), Z, P, p); if (mini) return P;
864 9330 : Q = out_decompose(gel(alq,2), Z, Q, p);
865 9330 : return mkvec2(P,Q);
866 : }
867 :
868 : static GEN
869 14664 : random_pm1(long n)
870 : {
871 14664 : GEN z = cgetg(n+1,t_VECSMALL);
872 : long i;
873 61100 : for (i = 1; i <= n; i++) z[i] = random_bits(5)%3 - 1;
874 14664 : return z;
875 : }
876 :
877 : static GEN alg_decompose(GEN al, GEN Z, long mini, GEN* pt_primelt);
878 : /* Try to split al using x's charpoly. Return gen_0 if simple, NULL if failure.
879 : * And a splitting otherwise
880 : * If pt_primelt!=NULL, compute a primitive element of the center when simple */
881 : static GEN
882 17534 : try_fact(GEN al, GEN x, GEN zx, GEN Z, GEN Zal, long mini, GEN* pt_primelt)
883 : {
884 17534 : GEN z, dec0, dec1, cp = algcharpoly(Zal,zx,0,1), fa, p = alg_get_char(al);
885 : long nfa, e;
886 17534 : dbg_printf(3)(" try_fact: zx=%Ps\n", zx);
887 17534 : if (signe(p)) fa = FpX_factor(cp,p);
888 1512 : else fa = factor(cp);
889 17534 : dbg_printf(3)(" charpoly=%Ps\n", fa);
890 17534 : nfa = nbrows(fa);
891 17534 : if (nfa == 1) {
892 8127 : if (signe(p)) e = gel(fa,2)[1];
893 686 : else e = itos(gcoeff(fa,1,2));
894 8127 : if (e == 1) {
895 4487 : if (pt_primelt != NULL) *pt_primelt = mkvec2(x, cp);
896 4487 : return gen_0;
897 : }
898 3640 : else return NULL;
899 : }
900 9407 : dec0 = alg_decompose_from_facto(al, x, fa, Z, mini);
901 9407 : if (!dec0) return NULL;
902 9407 : if (!mini) return dec0;
903 77 : dec1 = alg_decompose(gel(dec0,1), gel(dec0,4), 1, pt_primelt);
904 77 : z = gel(dec0,5);
905 77 : if (!isintzero(dec1)) {
906 7 : if (signe(p)) z = FpM_FpC_mul(gel(dec0,3),dec1,p);
907 7 : else z = RgM_RgC_mul(gel(dec0,3),dec1);
908 : }
909 77 : return z;
910 : }
911 : static GEN
912 7 : randcol(long n, GEN b)
913 : {
914 7 : GEN N = addiu(shifti(b,1), 1);
915 : long i;
916 7 : GEN res = cgetg(n+1,t_COL);
917 63 : for (i=1; i<=n; i++)
918 : {
919 56 : pari_sp av = avma;
920 56 : gel(res,i) = gerepileuptoint(av, subii(randomi(N),b));
921 : }
922 7 : return res;
923 : }
924 : /* Return gen_0 if already simple. mini: only returns a central idempotent
925 : * corresponding to one simple factor
926 : * if pt_primelt!=NULL, sets it to a primitive element of the center when simple */
927 : static GEN
928 26821 : alg_decompose(GEN al, GEN Z, long mini, GEN* pt_primelt)
929 : {
930 : pari_sp av;
931 : GEN Zal, x, zx, rand, dec0, B, p;
932 26821 : long i, nz = lg(Z)-1;
933 :
934 26821 : if (nz == 1) {
935 12927 : if (pt_primelt != 0) *pt_primelt = mkvec2(zerocol(alg_get_dim(al)), pol_x(0));
936 12927 : return gen_0;
937 : }
938 13894 : p = alg_get_char(al);
939 13894 : dbg_printf(2)(" alg_decompose: char=%Ps, dim=%d, dim Z=%d\n", p, alg_get_absdim(al), nz);
940 13894 : Zal = alg_subalg(al,Z);
941 13894 : Z = gel(Zal,2);
942 13894 : Zal = gel(Zal,1);
943 13894 : av = avma;
944 :
945 13894 : rand = random_pm1(nz);
946 13894 : zx = zc_to_ZC(rand);
947 13894 : if (signe(p)) {
948 12746 : zx = FpC_red(zx,p);
949 12746 : x = ZM_zc_mul(Z,rand);
950 12746 : x = FpC_red(x,p);
951 : }
952 1148 : else x = RgM_zc_mul(Z,rand);
953 13894 : dec0 = try_fact(al,x,zx,Z,Zal,mini,pt_primelt);
954 13894 : if (dec0) return dec0;
955 3570 : set_avma(av);
956 :
957 3640 : for (i=2; i<=nz; i++)
958 : {
959 3633 : dec0 = try_fact(al,gel(Z,i),col_ei(nz,i),Z,Zal,mini,pt_primelt);
960 3633 : if (dec0) return dec0;
961 70 : set_avma(av);
962 : }
963 7 : B = int2n(10);
964 : for (;;)
965 0 : {
966 7 : GEN x = randcol(nz,B), zx = ZM_ZC_mul(Z,x);
967 7 : dec0 = try_fact(al,x,zx,Z,Zal,mini,pt_primelt);
968 7 : if (dec0) return dec0;
969 0 : set_avma(av);
970 : }
971 : }
972 :
973 : static GEN
974 22481 : alg_decompose_total(GEN al, GEN Z, long maps)
975 : {
976 : GEN dec, sc, p;
977 : long i;
978 :
979 22481 : dec = alg_decompose(al, Z, 0, NULL);
980 22481 : if (isintzero(dec))
981 : {
982 13151 : if (maps) {
983 7971 : long n = alg_get_absdim(al);
984 7971 : al = mkvec3(al, matid(n), matid(n));
985 : }
986 13151 : return mkvec(al);
987 : }
988 9330 : p = alg_get_char(al); if (!signe(p)) p = NULL;
989 9330 : sc = cgetg(lg(dec), t_VEC);
990 27990 : for (i=1; i<lg(sc); i++) {
991 18660 : GEN D = gel(dec,i), a = gel(D,1), Za = gel(D,4);
992 18660 : GEN S = alg_decompose_total(a, Za, maps);
993 18660 : gel(sc,i) = S;
994 18660 : if (maps)
995 : {
996 12052 : GEN projm = gel(D,2), liftm = gel(D,3);
997 12052 : long j, lS = lg(S);
998 32462 : for (j=1; j<lS; j++)
999 : {
1000 20410 : GEN Sj = gel(S,j), p2 = gel(Sj,2), l2 = gel(Sj,3);
1001 20410 : if (p) p2 = FpM_mul(p2, projm, p);
1002 1449 : else p2 = RgM_mul(p2, projm);
1003 20410 : if (p) l2 = FpM_mul(liftm, l2, p);
1004 1449 : else l2 = RgM_mul(liftm, l2);
1005 20410 : gel(Sj,2) = p2;
1006 20410 : gel(Sj,3) = l2;
1007 : }
1008 : }
1009 : }
1010 9330 : return shallowconcat1(sc);
1011 : }
1012 :
1013 : static GEN
1014 13964 : alg_subalg(GEN al, GEN basis)
1015 : {
1016 13964 : GEN invbasis, mt, p = alg_get_char(al);
1017 : long i, j, n;
1018 :
1019 13964 : if (!signe(p)) p = NULL;
1020 13964 : basis = shallowmatconcat(mkvec2(col_ei(alg_get_absdim(al),1), basis));
1021 13964 : if (p)
1022 : {
1023 12795 : basis = image_keep_first(basis,p);
1024 12795 : invbasis = FpM_inv(basis,p);
1025 : }
1026 : else
1027 : { /* FIXME use an integral variant of image_keep_first */
1028 1169 : basis = QM_ImQ_hnf(basis);
1029 1169 : invbasis = RgM_inv(basis);
1030 : }
1031 13964 : n = lg(basis)-1;
1032 13964 : mt = cgetg(n+1,t_VEC);
1033 13964 : gel(mt,1) = matid(n);
1034 43797 : for (i = 2; i <= n; i++)
1035 : {
1036 29833 : GEN mtx = cgetg(n+1,t_MAT), x = gel(basis,i);
1037 29833 : gel(mtx,1) = col_ei(n,i);
1038 180856 : for (j = 2; j <= n; j++)
1039 : {
1040 151023 : GEN xy = algmul(al, x, gel(basis,j));
1041 151023 : if (p) gel(mtx,j) = FpM_FpC_mul(invbasis, xy, p);
1042 36253 : else gel(mtx,j) = RgM_RgC_mul(invbasis, xy);
1043 : }
1044 29833 : gel(mt,i) = mtx;
1045 : }
1046 13964 : return mkvec2(algtableinit_i(mt,p), basis);
1047 : }
1048 :
1049 : GEN
1050 84 : algsubalg(GEN al, GEN basis)
1051 : {
1052 84 : pari_sp av = avma;
1053 : GEN p;
1054 84 : checkalg(al);
1055 84 : if (alg_type(al) == al_REAL) pari_err_TYPE("algsubalg [real algebra]", al);
1056 77 : if (typ(basis) != t_MAT) pari_err_TYPE("algsubalg",basis);
1057 70 : p = alg_get_char(al);
1058 70 : if (signe(p)) basis = RgM_to_FpM(basis,p);
1059 70 : return gerepilecopy(av, alg_subalg(al,basis));
1060 : }
1061 :
1062 : static int
1063 14075 : cmp_algebra(GEN x, GEN y)
1064 : {
1065 : long d;
1066 14075 : d = gel(x,1)[1] - gel(y,1)[1]; if (d) return d < 0? -1: 1;
1067 12236 : d = gel(x,1)[2] - gel(y,1)[2]; if (d) return d < 0? -1: 1;
1068 12236 : return cmp_universal(gel(x,2), gel(y,2));
1069 : }
1070 :
1071 : GEN
1072 8243 : algsimpledec_ss(GEN al, long maps)
1073 : {
1074 8243 : pari_sp av = avma;
1075 : GEN Z, p, r, res, perm;
1076 : long i, l, n;
1077 8243 : checkalg(al);
1078 8243 : p = alg_get_char(al);
1079 8243 : dbg_printf(1)("algsimpledec_ss: char=%Ps, dim=%d\n", p, alg_get_absdim(al));
1080 8243 : if (signe(p)) Z = algprimesubalg(al);
1081 273 : else if (alg_type(al)!=al_TABLE) Z = gen_0;
1082 252 : else Z = algtablecenter(al);
1083 :
1084 8243 : if (lg(Z) == 2) {/* dim Z = 1 */
1085 4422 : n = alg_get_absdim(al);
1086 4422 : set_avma(av);
1087 4422 : if (!maps) return mkveccopy(al);
1088 3715 : retmkvec(mkvec3(gcopy(al), matid(n), matid(n)));
1089 : }
1090 3821 : res = alg_decompose_total(al, Z, maps);
1091 3821 : l = lg(res); r = cgetg(l, t_VEC);
1092 16972 : for (i = 1; i < l; i++)
1093 : {
1094 13151 : GEN A = maps? gmael(res,i,1): gel(res,i);
1095 13151 : gel(r,i) = mkvec2(mkvecsmall2(alg_get_dim(A), lg(algtablecenter(A))),
1096 : alg_get_multable(A));
1097 : }
1098 3821 : perm = gen_indexsort(r, (void*)cmp_algebra, &cmp_nodata);
1099 3821 : return gerepilecopy(av, vecpermute(res, perm));
1100 : }
1101 :
1102 : GEN
1103 2730 : algsimpledec(GEN al, long maps)
1104 : {
1105 2730 : pari_sp av = avma;
1106 : int ss;
1107 2730 : GEN rad, dec, res, proj=NULL, lift=NULL;
1108 2730 : rad = algradical(al);
1109 2730 : ss = gequal0(rad);
1110 2730 : if (!ss)
1111 : {
1112 1428 : al = alg_quotient(al, rad, maps);
1113 1428 : if (maps) {
1114 14 : proj = gel(al,2);
1115 14 : lift = gel(al,3);
1116 14 : al = gel(al,1);
1117 : }
1118 : }
1119 2730 : dec = algsimpledec_ss(al, maps);
1120 2730 : if (!ss && maps) /* update maps */
1121 : {
1122 14 : GEN p = alg_get_char(al);
1123 : long i;
1124 42 : for (i=1; i<lg(dec); i++)
1125 : {
1126 28 : if (signe(p))
1127 : {
1128 14 : gmael(dec,i,2) = FpM_mul(gmael(dec,i,2), proj, p);
1129 14 : gmael(dec,i,3) = FpM_mul(lift, gmael(dec,i,3), p);
1130 : }
1131 : else
1132 : {
1133 14 : gmael(dec,i,2) = RgM_mul(gmael(dec,i,2), proj);
1134 14 : gmael(dec,i,3) = RgM_mul(lift, gmael(dec,i,3));
1135 : }
1136 : }
1137 : }
1138 2730 : res = mkvec2(rad, dec);
1139 2730 : return gerepilecopy(av,res);
1140 : }
1141 :
1142 : static GEN alg_idempotent(GEN al, long n, long d);
1143 : static GEN
1144 13057 : try_split(GEN al, GEN x, long n, long d)
1145 : {
1146 13057 : GEN cp, p = alg_get_char(al), fa, e, pol, exp, P, Q, U, u, mx, mte, ire;
1147 13057 : long nfa, i, smalldim = alg_get_absdim(al)+1, dim, smalli = 0;
1148 13057 : cp = algcharpoly(al,x,0,1);
1149 13057 : fa = FpX_factor(cp,p);
1150 13057 : nfa = nbrows(fa);
1151 13057 : if (nfa == 1) return NULL;
1152 5061 : pol = gel(fa,1);
1153 5061 : exp = gel(fa,2);
1154 :
1155 : /* charpoly is always a d-th power */
1156 15696 : for (i=1; i<lg(exp); i++) {
1157 10642 : if (exp[i]%d) pari_err(e_MISC, "the algebra must be simple (try_split 1)");
1158 10635 : exp[i] /= d;
1159 : }
1160 5054 : cp = FpXV_factorback(gel(fa,1), gel(fa,2), p, 0);
1161 :
1162 : /* find smallest Fp-dimension of a characteristic space */
1163 15689 : for (i=1; i<lg(pol); i++) {
1164 10635 : dim = degree(gel(pol,i))*exp[i];
1165 10635 : if (dim < smalldim) {
1166 5126 : smalldim = dim;
1167 5126 : smalli = i;
1168 : }
1169 : }
1170 5054 : i = smalli;
1171 5054 : if (smalldim != n) return NULL;
1172 : /* We could also compute e*al*e and try again with this smaller algebra */
1173 : /* Fq-rank 1 = Fp-rank n idempotent: success */
1174 :
1175 : /* construct idempotent */
1176 5040 : mx = algbasismultable(al,x);
1177 5040 : P = gel(pol,i);
1178 5040 : P = FpX_powu(P, exp[i], p);
1179 5040 : Q = FpX_div(cp, P, p);
1180 5040 : e = algpoleval(al, Q, mkvec2(x,mx));
1181 5040 : U = FpXQ_inv(Q, P, p);
1182 5040 : u = algpoleval(al, U, mkvec2(x,mx));
1183 5040 : e = algbasismul(al, e, u);
1184 5040 : mte = algbasisrightmultable(al,e);
1185 5040 : ire = FpM_indexrank(mte,p);
1186 5040 : if (lg(gel(ire,1))-1 != smalldim*d) pari_err(e_MISC, "the algebra must be simple (try_split 2)");
1187 :
1188 5033 : return mkvec3(e,mte,ire);
1189 : }
1190 :
1191 : /*
1192 : * Given a simple algebra al of dimension d^2 over its center of degree n,
1193 : * find an idempotent e in al with rank n (which is minimal).
1194 : */
1195 : static GEN
1196 5047 : alg_idempotent(GEN al, long n, long d)
1197 : {
1198 5047 : pari_sp av = avma;
1199 5047 : long i, N = alg_get_absdim(al);
1200 5047 : GEN e, p = alg_get_char(al), x;
1201 12728 : for(i=2; i<=N; i++) {
1202 12385 : x = col_ei(N,i);
1203 12385 : e = try_split(al, x, n, d);
1204 12371 : if (e) return e;
1205 7681 : set_avma(av);
1206 : }
1207 : for(;;) {
1208 672 : x = random_FpC(N,p);
1209 672 : e = try_split(al, x, n, d);
1210 672 : if (e) return e;
1211 329 : set_avma(av);
1212 : }
1213 : }
1214 :
1215 : static GEN
1216 4585 : try_descend(GEN M, GEN B, GEN p, long m, long n, long d)
1217 : {
1218 4585 : GEN B2 = cgetg(m+1,t_MAT), b;
1219 4585 : long i, j, k=0;
1220 13321 : for (i=1; i<=d; i++)
1221 : {
1222 8736 : k++;
1223 8736 : b = gel(B,i);
1224 8736 : gel(B2,k) = b;
1225 20426 : for (j=1; j<n; j++)
1226 : {
1227 11690 : k++;
1228 11690 : b = FpM_FpC_mul(M,b,p);
1229 11690 : gel(B2,k) = b;
1230 : }
1231 : }
1232 4585 : if (!signe(FpM_det(B2,p))) return NULL;
1233 4165 : return FpM_inv(B2,p);
1234 : }
1235 :
1236 : /* Given an m*m matrix M with irreducible charpoly over F of degree n,
1237 : * let K = F(M), which is a field, and write m=d*n.
1238 : * Compute the d-dimensional K-vector space structure on V=F^m induced by M.
1239 : * Return [B,C] where:
1240 : * - B is m*d matrix over F giving a K-basis b_1,...,b_d of V
1241 : * - C is d*m matrix over F[x] expressing the canonical F-basis of V on the b_i
1242 : * Currently F = Fp TODO extend this. */
1243 : static GEN
1244 4165 : descend_i(GEN M, long n, GEN p)
1245 : {
1246 : GEN B, C;
1247 : long m,d,i;
1248 : pari_sp av;
1249 4165 : m = lg(M)-1;
1250 4165 : d = m/n;
1251 4165 : B = cgetg(d+1,t_MAT);
1252 4165 : av = avma;
1253 :
1254 : /* try a subset of the canonical basis */
1255 12061 : for (i=1; i<=d; i++)
1256 7896 : gel(B,i) = col_ei(m,n*(i-1)+1);
1257 4165 : C = try_descend(M,B,p,m,n,d);
1258 4165 : if (C) return mkvec2(B,C);
1259 385 : set_avma(av);
1260 :
1261 : /* try smallish elements */
1262 1155 : for (i=1; i<=d; i++)
1263 770 : gel(B,i) = FpC_red(zc_to_ZC(random_pm1(m)),p);
1264 385 : C = try_descend(M,B,p,m,n,d);
1265 385 : if (C) return mkvec2(B,C);
1266 35 : set_avma(av);
1267 :
1268 : /* try random elements */
1269 : for (;;)
1270 : {
1271 105 : for (i=1; i<=d; i++)
1272 70 : gel(B,i) = random_FpC(m,p);
1273 35 : C = try_descend(M,B,p,m,n,d);
1274 35 : if (C) return mkvec2(B,C);
1275 0 : set_avma(av);
1276 : }
1277 : }
1278 : static GEN
1279 18746 : RgC_contract(GEN C, long n, long v) /* n>1 */
1280 : {
1281 : GEN C2, P;
1282 : long m, d, i, j;
1283 18746 : m = lg(C)-1;
1284 18746 : d = m/n;
1285 18746 : C2 = cgetg(d+1,t_COL);
1286 55034 : for (i=1; i<=d; i++)
1287 : {
1288 36288 : P = pol_xn(n-1,v);
1289 131348 : for (j=1; j<=n; j++)
1290 95060 : gel(P,j+1) = gel(C,n*(i-1)+j);
1291 36288 : P = normalizepol(P);
1292 36288 : gel(C2,i) = P;
1293 : }
1294 18746 : return C2;
1295 : }
1296 : static GEN
1297 4165 : RgM_contract(GEN A, long n, long v) /* n>1 */
1298 : {
1299 4165 : GEN A2 = cgetg(lg(A),t_MAT);
1300 : long i;
1301 22911 : for (i=1; i<lg(A2); i++)
1302 18746 : gel(A2,i) = RgC_contract(gel(A,i),n,v);
1303 4165 : return A2;
1304 : }
1305 : static GEN
1306 4165 : descend(GEN M, long n, GEN p, long v)
1307 : {
1308 4165 : GEN res = descend_i(M,n,p);
1309 4165 : gel(res,2) = RgM_contract(gel(res,2),n,v);
1310 4165 : return res;
1311 : }
1312 :
1313 : /* isomorphism of Fp-vector spaces M_d(F_p^n) -> (F_p)^(d^2*n) */
1314 : static GEN
1315 49343 : RgM_mat2col(GEN M, long d, long n)
1316 : {
1317 49343 : long nd = d*n, N = d*nd, i, j, ni, nj;
1318 49343 : GEN C = cgetg(N+1, t_COL);
1319 168504 : for (i=1, ni = 0; i<=d; i++, ni += nd)
1320 459508 : for (j=1, nj = 0; j<=d; j++, nj += n)
1321 : {
1322 340347 : GEN P = gcoeff(M,i,j);
1323 340347 : long k, e = ni + nj + 1;
1324 340347 : if (typ(P)==t_POL)
1325 : {
1326 339731 : long dP = degpol(P);
1327 706050 : for (k = 0; k <= dP; k++)
1328 366319 : gel(C,e+k) = gel(P,k+2);
1329 : } else
1330 : {
1331 616 : gel(C,e) = P;
1332 616 : k = 1;
1333 : }
1334 555035 : for ( ; k < n; k++)
1335 214688 : gel(C,e+k) = gen_0;
1336 : }
1337 49343 : return C;
1338 : }
1339 : /* inverse isomorphism */
1340 : static GEN
1341 1708 : RgC_col2mat(GEN C, long d, long n, long v)
1342 : {
1343 : long i, j, start;
1344 1708 : GEN M = cgetg(d+1, t_MAT), cM;
1345 5432 : for (j=1; j<=d; j++)
1346 : {
1347 3724 : cM = cgetg(d+1, t_COL);
1348 14420 : for (i=1; i<=d; i++)
1349 : {
1350 10696 : start = n*(d*(i-1)+j-1)+1;
1351 10696 : if (n==1) gel(cM,i) = gel(C, start);
1352 4564 : else gel(cM,i) = RgV_to_RgX(vecslice(C, start, start+n-1), v);
1353 : }
1354 3724 : gel(M,j) = cM;
1355 : }
1356 1708 : return M;
1357 : }
1358 :
1359 : static GEN
1360 6510 : alg_finite_csa_split(GEN al, long v)
1361 : {
1362 : GEN Z, e, mte, ire, primelt, b, T, M, proje, lifte, extre, p, B, C, mt, mx, map, mapi, T2, ro;
1363 6510 : long n, d, N = alg_get_absdim(al), i;
1364 6510 : p = alg_get_char(al);
1365 : /* compute the center */
1366 6510 : Z = algcenter(al);
1367 : /* TODO option to give the center as input instead of computing it */
1368 6510 : n = lg(Z)-1;
1369 :
1370 : /* compute a minimal rank idempotent e */
1371 6510 : if (n==N) {
1372 1456 : d = 1;
1373 1456 : e = col_ei(N,1);
1374 1456 : mte = matid(N);
1375 1456 : ire = mkvec2(identity_perm(n),identity_perm(n));
1376 : }
1377 : else {
1378 5054 : d = usqrt(N/n);
1379 5054 : if (d*d*n != N) pari_err(e_MISC, "the algebra must be simple (alg_finite_csa_split 1)");
1380 5047 : e = alg_idempotent(al,n,d);
1381 5033 : mte = gel(e,2);
1382 5033 : ire = gel(e,3);
1383 5033 : e = gel(e,1);
1384 : }
1385 :
1386 : /* identify the center */
1387 6489 : if (n==1)
1388 : {
1389 2317 : T = pol_x(v);
1390 2317 : primelt = gen_0;
1391 : }
1392 : else
1393 : {
1394 4172 : b = alg_decompose(al, Z, 1, &primelt);
1395 4172 : if (!gequal0(b)) pari_err(e_MISC, "the algebra must be simple (alg_finite_csa_split 2)");
1396 4165 : T = gel(primelt,2);
1397 4165 : primelt = gel(primelt,1);
1398 4165 : setvarn(T,v);
1399 : }
1400 :
1401 : /* use the ffinit polynomial */
1402 6482 : if (n>1)
1403 : {
1404 4165 : T2 = init_Fq(p,n,v);
1405 4165 : setvarn(T,fetch_var_higher());
1406 4165 : ro = FpXQX_roots(T2,T,p);
1407 4165 : ro = gel(ro,1);
1408 4165 : primelt = algpoleval(al,ro,primelt);
1409 4165 : T = T2;
1410 4165 : delete_var();
1411 : }
1412 :
1413 : /* descend al*e to a vector space over the center */
1414 : /* lifte: al*e -> al ; proje: al*e -> al */
1415 6482 : lifte = shallowextract(mte,gel(ire,2));
1416 6482 : extre = shallowmatextract(mte,gel(ire,1),gel(ire,2));
1417 6482 : extre = FpM_inv(extre,p);
1418 6482 : proje = rowpermute(mte,gel(ire,1));
1419 6482 : proje = FpM_mul(extre,proje,p);
1420 6482 : if (n==1)
1421 : {
1422 2317 : B = lifte;
1423 2317 : C = proje;
1424 : }
1425 : else
1426 : {
1427 4165 : M = algbasismultable(al,primelt);
1428 4165 : M = FpM_mul(M,lifte,p);
1429 4165 : M = FpM_mul(proje,M,p);
1430 4165 : B = descend(M,n,p,v);
1431 4165 : C = gel(B,2);
1432 4165 : B = gel(B,1);
1433 4165 : B = FpM_mul(lifte,B,p);
1434 4165 : C = FqM_mul(C,proje,T,p);
1435 : }
1436 :
1437 : /* compute the isomorphism */
1438 6482 : mt = alg_get_multable(al);
1439 6482 : map = cgetg(N+1,t_VEC);
1440 6482 : M = cgetg(N+1,t_MAT);
1441 55321 : for (i=1; i<=N; i++)
1442 : {
1443 48839 : mx = gel(mt,i);
1444 48839 : mx = FpM_mul(mx,B,p);
1445 48839 : mx = FqM_mul(C,mx,T,p);
1446 48839 : gel(map,i) = mx;
1447 48839 : gel(M,i) = RgM_mat2col(mx,d,n);
1448 : }
1449 6482 : mapi = FpM_inv(M,p);
1450 6482 : if (!mapi) pari_err(e_MISC, "the algebra must be simple (alg_finite_csa_split 3)");
1451 6475 : return mkvec4(T,map,mapi,M);
1452 : }
1453 :
1454 : GEN
1455 3766 : algsplit(GEN al, long v)
1456 : {
1457 3766 : pari_sp av = avma;
1458 : GEN res, T, map, mapi, ff, p;
1459 : long i,j,k,li,lj;
1460 3766 : checkalg(al);
1461 3759 : p = alg_get_char(al);
1462 3759 : if (gequal0(p))
1463 7 : pari_err_IMPL("splitting a characteristic 0 algebra over its center");
1464 3752 : res = alg_finite_csa_split(al, v);
1465 3717 : T = gel(res,1);
1466 3717 : map = gel(res,2);
1467 3717 : mapi = gel(res,3);
1468 3717 : ff = Tp_to_FF(T,p);
1469 33593 : for (i=1; i<lg(map); i++)
1470 : {
1471 29876 : li = lg(gel(map,i));
1472 89908 : for (j=1; j<li; j++)
1473 : {
1474 60032 : lj = lg(gmael(map,i,j));
1475 190876 : for (k=1; k<lj; k++)
1476 130844 : gmael3(map,i,j,k) = Fq_to_FF(gmael3(map,i,j,k),ff);
1477 : }
1478 : }
1479 :
1480 3717 : return gerepilecopy(av, mkvec2(map,mapi));
1481 : }
1482 :
1483 : /* multiplication table sanity checks */
1484 : static GEN
1485 55566 : check_mt_noid(GEN mt, GEN p)
1486 : {
1487 : long i, l;
1488 55566 : GEN MT = cgetg_copy(mt, &l);
1489 55566 : if (typ(MT) != t_VEC || l == 1) return NULL;
1490 273852 : for (i = 1; i < l; i++)
1491 : {
1492 218335 : GEN M = gel(mt,i);
1493 218335 : if (typ(M) != t_MAT || lg(M) != l || lgcols(M) != l) return NULL;
1494 218307 : if (p) M = RgM_to_FpM(M,p);
1495 218307 : gel(MT,i) = M;
1496 : }
1497 55517 : return MT;
1498 : }
1499 : static GEN
1500 55041 : check_mt(GEN mt, GEN p)
1501 : {
1502 : long i;
1503 : GEN MT;
1504 55041 : MT = check_mt_noid(mt, p);
1505 55041 : if (!MT || !ZM_isidentity(gel(MT,1))) return NULL;
1506 214996 : for (i=2; i<lg(MT); i++)
1507 159983 : if (ZC_is_ei(gmael(MT,i,1)) != i) return NULL;
1508 55013 : return MT;
1509 : }
1510 :
1511 : static GEN
1512 245 : check_relmt(GEN nf, GEN mt)
1513 : {
1514 245 : long i, l = lg(mt), j, k;
1515 245 : GEN MT = gcopy(mt), a, b, d;
1516 245 : if (typ(MT) != t_VEC || l == 1) return NULL;
1517 1022 : for (i = 1; i < l; i++)
1518 : {
1519 798 : GEN M = gel(MT,i);
1520 798 : if (typ(M) != t_MAT || lg(M) != l || lgcols(M) != l) return NULL;
1521 4032 : for (k = 1; k < l; k++)
1522 18697 : for (j = 1; j < l; j++)
1523 : {
1524 15463 : a = gcoeff(M,j,k);
1525 15463 : if (typ(a)==t_INT) continue;
1526 2065 : b = algtobasis(nf,a);
1527 2065 : d = Q_denom(b);
1528 2065 : if (!isint1(d))
1529 14 : pari_err_DOMAIN("alg_csa_table", "denominator(mt)", "!=", gen_1, mt);
1530 2051 : gcoeff(M,j,k) = lift(basistoalg(nf,b));
1531 : }
1532 784 : if (i > 1 && RgC_is_ei(gel(M,1)) != i) return NULL; /* i = 1 checked at end */
1533 777 : gel(MT,i) = M;
1534 : }
1535 224 : if (!RgM_isidentity(gel(MT,1))) return NULL;
1536 224 : return MT;
1537 : }
1538 :
1539 : int
1540 532 : algisassociative(GEN mt0, GEN p)
1541 : {
1542 532 : pari_sp av = avma;
1543 : long i, j, k, n;
1544 : GEN M, mt;
1545 :
1546 532 : if (checkalg_i(mt0)) { p = alg_get_char(mt0); mt0 = alg_get_multable(mt0); }
1547 532 : if (!p) p = gen_0;
1548 532 : if (typ(p) != t_INT) pari_err_TYPE("algisassociative",p);
1549 525 : mt = check_mt_noid(mt0, isintzero(p)? NULL: p);
1550 525 : if (!mt) pari_err_TYPE("algisassociative (mult. table)", mt0);
1551 490 : if (!ZM_isidentity(gel(mt,1))) return gc_bool(av,0);
1552 476 : n = lg(mt)-1;
1553 476 : M = cgetg(n+1,t_MAT);
1554 3731 : for (j=1; j<=n; j++) gel(M,j) = cgetg(n+1,t_COL);
1555 3731 : for (i=1; i<=n; i++)
1556 : {
1557 3255 : GEN mi = gel(mt,i);
1558 36918 : for (j=1; j<=n; j++) gcoeff(M,i,j) = gel(mi,j); /* ei.ej */
1559 : }
1560 3241 : for (i=2; i<=n; i++) {
1561 2772 : GEN mi = gel(mt,i);
1562 30373 : for (j=2; j<=n; j++) {
1563 381451 : for (k=2; k<=n; k++) {
1564 : GEN x, y;
1565 353850 : if (signe(p)) {
1566 242039 : x = _tablemul_ej_Fp(mt,gcoeff(M,i,j),k,p);
1567 242039 : y = FpM_FpC_mul(mi,gcoeff(M,j,k),p);
1568 : }
1569 : else {
1570 111811 : x = _tablemul_ej(mt,gcoeff(M,i,j),k);
1571 111811 : y = RgM_RgC_mul(mi,gcoeff(M,j,k));
1572 : }
1573 : /* not cmp_universal: must not fail on 0 == Mod(0,2) for instance */
1574 353850 : if (!gequal(x,y)) return gc_bool(av,0);
1575 : }
1576 : }
1577 : }
1578 469 : return gc_bool(av,1);
1579 : }
1580 :
1581 : int
1582 392 : algiscommutative(GEN al) /* assumes e_1 = 1 */
1583 : {
1584 : long i,j,k,N,sp;
1585 : GEN mt,a,b,p;
1586 392 : checkalg(al);
1587 392 : if (alg_type(al) != al_TABLE) return alg_get_degree(al)==1;
1588 329 : N = alg_get_absdim(al);
1589 329 : mt = alg_get_multable(al);
1590 329 : p = alg_get_char(al);
1591 329 : sp = signe(p);
1592 1491 : for (i=2; i<=N; i++)
1593 9772 : for (j=2; j<=N; j++)
1594 89047 : for (k=1; k<=N; k++) {
1595 80514 : a = gcoeff(gel(mt,i),k,j);
1596 80514 : b = gcoeff(gel(mt,j),k,i);
1597 80514 : if (sp) {
1598 73423 : if (cmpii(Fp_red(a,p), Fp_red(b,p))) return 0;
1599 : }
1600 7091 : else if (gcmp(a,b)) return 0;
1601 : }
1602 252 : return 1;
1603 : }
1604 :
1605 : int
1606 392 : algissemisimple(GEN al)
1607 : {
1608 392 : pari_sp av = avma;
1609 : GEN rad;
1610 392 : checkalg(al);
1611 392 : if (alg_type(al) != al_TABLE) return 1;
1612 329 : rad = algradical(al);
1613 329 : set_avma(av);
1614 329 : return gequal0(rad);
1615 : }
1616 :
1617 : /* ss : known to be semisimple */
1618 : int
1619 301 : algissimple(GEN al, long ss)
1620 : {
1621 301 : pari_sp av = avma;
1622 : GEN Z, dec, p;
1623 301 : checkalg(al);
1624 301 : if (alg_type(al) != al_TABLE) return 1;
1625 245 : if (!ss && !algissemisimple(al)) return 0;
1626 :
1627 203 : p = alg_get_char(al);
1628 203 : if (signe(p)) Z = algprimesubalg(al);
1629 112 : else Z = algtablecenter(al);
1630 :
1631 203 : if (lg(Z) == 2) {/* dim Z = 1 */
1632 112 : set_avma(av);
1633 112 : return 1;
1634 : }
1635 91 : dec = alg_decompose(al, Z, 1, NULL);
1636 91 : set_avma(av);
1637 91 : return gequal0(dec);
1638 : }
1639 :
1640 : static long
1641 462 : is_place_emb(GEN nf, GEN pl)
1642 : {
1643 : long r, r1, r2;
1644 462 : if (typ(pl) != t_INT) pari_err_TYPE("is_place_emb", pl);
1645 448 : if (signe(pl)<=0) pari_err_DOMAIN("is_place_emb", "pl", "<=", gen_0, pl);
1646 441 : nf_get_sign(nf,&r1,&r2); r = r1+r2;
1647 441 : if (cmpiu(pl,r)>0) pari_err_DOMAIN("is_place_emb", "pl", ">", utoi(r), pl);
1648 427 : return itou(pl);
1649 : }
1650 :
1651 : static long
1652 427 : alghasse_emb(GEN al, long emb)
1653 : {
1654 427 : GEN nf = alg_get_center(al);
1655 427 : long r1 = nf_get_r1(nf);
1656 427 : return (emb <= r1)? alg_get_hasse_i(al)[emb]: 0;
1657 : }
1658 :
1659 : static long
1660 1652 : alghasse_pr(GEN al, GEN pr)
1661 : {
1662 1652 : GEN hf = alg_get_hasse_f(al);
1663 1645 : long i = tablesearch(gel(hf,1), pr, &cmp_prime_ideal);
1664 1645 : return i? gel(hf,2)[i]: 0;
1665 : }
1666 :
1667 : static long
1668 2149 : alghasse_0(GEN al, GEN pl)
1669 : {
1670 : long ta;
1671 : GEN pr, nf;
1672 2149 : ta = alg_type(al);
1673 2149 : if (ta == al_REAL) return algreal_dim(al)!=1;
1674 2128 : if (!pl)
1675 7 : pari_err(e_MISC, "must provide a place pl");
1676 2121 : if (ta == al_CSA && !alg_is_asq(al))
1677 7 : pari_err_IMPL("computation of Hasse invariants over table CSA");
1678 2114 : if ((pr = get_prid(pl))) return alghasse_pr(al, pr);
1679 462 : nf = alg_get_center(al);
1680 462 : return alghasse_emb(al, is_place_emb(nf, pl));
1681 : }
1682 : GEN
1683 336 : alghasse(GEN al, GEN pl)
1684 : {
1685 : long h;
1686 336 : checkalg(al);
1687 336 : if (alg_type(al) == al_TABLE) pari_err_TYPE("alghasse [use alginit]",al);
1688 329 : h = alghasse_0(al,pl);
1689 273 : return sstoQ(h, alg_get_degree(al));
1690 : }
1691 :
1692 : /* h >= 0, d >= 0 */
1693 : static long
1694 2219 : indexfromhasse(long h, long d) { return d/ugcd(h,d); }
1695 :
1696 : long
1697 2191 : algindex(GEN al, GEN pl)
1698 : {
1699 : long d, res, i, l, ta;
1700 : GEN hi, hf;
1701 :
1702 2191 : checkalg(al);
1703 2184 : ta = alg_type(al);
1704 2184 : if (ta == al_TABLE) pari_err_TYPE("algindex [use alginit]",al);
1705 2177 : if (ta == al_REAL) return algreal_dim(al)==1 ? 1 : 2;
1706 2093 : d = alg_get_degree(al);
1707 2093 : if (pl) return indexfromhasse(alghasse_0(al,pl), d);
1708 :
1709 : /* else : global index */
1710 273 : res = 1;
1711 273 : hi = alg_get_hasse_i(al); l = lg(hi);
1712 518 : for (i=1; i<l && res!=d; i++) res = ulcm(res, indexfromhasse(hi[i],d));
1713 273 : hf = gel(alg_get_hasse_f(al), 2); l = lg(hf);
1714 420 : for (i=1; i<l && res!=d; i++) res = ulcm(res, indexfromhasse(hf[i],d));
1715 266 : return res;
1716 : }
1717 :
1718 : int
1719 287 : algisdivision(GEN al, GEN pl)
1720 : {
1721 287 : checkalg(al);
1722 287 : if (alg_type(al) == al_TABLE) {
1723 21 : if (!algissimple(al,0)) return 0;
1724 14 : if (algiscommutative(al)) return 1;
1725 7 : pari_err_IMPL("algisdivision for table algebras");
1726 : }
1727 266 : return algindex(al,pl) == alg_get_degree(al);
1728 : }
1729 :
1730 : int
1731 1652 : algissplit(GEN al, GEN pl)
1732 : {
1733 1652 : checkalg(al);
1734 1652 : if (alg_type(al) == al_TABLE) pari_err_TYPE("algissplit [use alginit]", al);
1735 1638 : return algindex(al,pl) == 1;
1736 : }
1737 :
1738 : int
1739 1386 : algisramified(GEN al, GEN pl) { return !algissplit(al,pl); }
1740 :
1741 : GEN
1742 168 : algramifiedplaces(GEN al)
1743 : {
1744 168 : pari_sp av = avma;
1745 : GEN ram, hf, hi, Lpr;
1746 : long r1, count, i, ta;
1747 168 : checkalg(al);
1748 168 : ta = alg_type(al);
1749 168 : if (ta != al_CSA && ta != al_CYCLIC)
1750 14 : pari_err_TYPE("algramifiedplaces [not a central simple algebra"
1751 : " over a number field]", al);
1752 154 : r1 = nf_get_r1(alg_get_center(al));
1753 154 : hi = alg_get_hasse_i(al);
1754 154 : hf = alg_get_hasse_f(al);
1755 147 : Lpr = gel(hf,1);
1756 147 : hf = gel(hf,2);
1757 147 : ram = cgetg(r1+lg(Lpr), t_VEC);
1758 147 : count = 0;
1759 455 : for (i=1; i<=r1; i++)
1760 308 : if (hi[i]) {
1761 133 : count++;
1762 133 : gel(ram,count) = stoi(i);
1763 : }
1764 377 : for (i=1; i<lg(Lpr); i++)
1765 230 : if (hf[i]) {
1766 119 : count++;
1767 119 : gel(ram,count) = gel(Lpr,i);
1768 : }
1769 147 : setlg(ram, count+1);
1770 147 : return gerepilecopy(av, ram);
1771 : }
1772 :
1773 : GEN
1774 63 : algnewprec_shallow(GEN al, long prec)
1775 : {
1776 : GEN al2;
1777 63 : long t = algtype(al);
1778 63 : if (t != al_CYCLIC && t != al_CSA) return al;
1779 35 : al2 = shallowcopy(al);
1780 35 : gel(al2,1) = rnfnewprec_shallow(gel(al2,1), prec);
1781 35 : return al2;
1782 : };
1783 :
1784 : GEN
1785 63 : algnewprec(GEN al, long prec)
1786 : {
1787 63 : pari_sp av = avma;
1788 63 : GEN al2 = algnewprec_shallow(al, prec);
1789 63 : return gerepilecopy(av, al2);
1790 : }
1791 :
1792 : /** OPERATIONS ON ELEMENTS operations.c **/
1793 :
1794 : static long
1795 1872777 : alg_model0(GEN al, GEN x)
1796 : {
1797 1872777 : long t, N = alg_get_absdim(al), lx = lg(x), d, n, D, i;
1798 1872777 : if (typ(x) == t_MAT) return al_MATRIX;
1799 1826654 : if (typ(x) != t_COL) return al_INVALID;
1800 1826584 : if (N == 1) {
1801 7658 : if (lx != 2) return al_INVALID;
1802 7637 : switch(typ(gel(x,1)))
1803 : {
1804 4907 : case t_INT: case t_FRAC: return al_TRIVIAL; /* cannot distinguish basis and alg from size */
1805 2723 : case t_POL: case t_POLMOD: return al_ALGEBRAIC;
1806 7 : default: return al_INVALID;
1807 : }
1808 : }
1809 :
1810 1818926 : switch(alg_type(al)) {
1811 720184 : case al_TABLE:
1812 720184 : if (lx != N+1) return al_INVALID;
1813 720163 : return al_BASIS;
1814 934606 : case al_CYCLIC:
1815 934606 : d = alg_get_degree(al);
1816 934606 : if (lx == N+1) return al_BASIS;
1817 109173 : if (lx == d+1) return al_ALGEBRAIC;
1818 28 : return al_INVALID;
1819 164136 : case al_CSA:
1820 164136 : D = alg_get_dim(al);
1821 164136 : n = nf_get_degree(alg_get_center(al));
1822 164136 : if (n == 1) {
1823 22652 : if (lx != D+1) return al_INVALID;
1824 104433 : for (i=1; i<=D; i++) {
1825 84007 : t = typ(gel(x,i));
1826 84007 : if (t == t_POL || t == t_POLMOD) return al_ALGEBRAIC;
1827 : /* TODO t_COL for coefficients in basis form ? */
1828 : }
1829 20426 : return al_BASIS;
1830 : }
1831 : else {
1832 141484 : if (lx == N+1) return al_BASIS;
1833 25011 : if (lx == D+1) return al_ALGEBRAIC;
1834 7 : return al_INVALID;
1835 : }
1836 : }
1837 : return al_INVALID; /* LCOV_EXCL_LINE */
1838 : }
1839 :
1840 : static void
1841 1872616 : checkalgx(GEN x, long model)
1842 : {
1843 : long t, i;
1844 1872616 : switch(model) {
1845 1682495 : case al_BASIS:
1846 22543560 : for (i=1; i<lg(x); i++) {
1847 20861072 : t = typ(gel(x,i));
1848 20861072 : if (t != t_INT && t != t_FRAC)
1849 7 : pari_err_TYPE("checkalgx", gel(x,i));
1850 : }
1851 1682488 : return;
1852 143998 : case al_TRIVIAL:
1853 : case al_ALGEBRAIC:
1854 486734 : for (i=1; i<lg(x); i++) {
1855 342743 : t = typ(gel(x,i));
1856 342743 : if (t != t_INT && t != t_FRAC && t != t_POL && t != t_POLMOD)
1857 : /* TODO t_COL ? */
1858 7 : pari_err_TYPE("checkalgx", gel(x,i));
1859 : }
1860 143991 : return;
1861 : }
1862 : }
1863 :
1864 : long
1865 1872777 : alg_model(GEN al, GEN x)
1866 : {
1867 1872777 : long res = alg_model0(al, x);
1868 1872777 : if (res == al_INVALID) pari_err_TYPE("alg_model", x);
1869 1872616 : checkalgx(x, res); return res;
1870 : }
1871 :
1872 : static long
1873 462812 : H_model0(GEN x)
1874 : {
1875 : long i;
1876 462812 : switch(typ(x))
1877 : {
1878 15239 : case t_INT:
1879 : case t_FRAC:
1880 : case t_REAL:
1881 : case t_COMPLEX:
1882 15239 : return H_SCALAR;
1883 10157 : case t_MAT:
1884 10157 : return H_MATRIX;
1885 437304 : case t_COL:
1886 437304 : if (lg(x)!=5) return H_INVALID;
1887 2186408 : for (i=1; i<=4; i++) if (!is_real_t(typ(gel(x,i)))) return H_INVALID;
1888 437276 : return H_QUATERNION;
1889 112 : default:
1890 112 : return al_INVALID;
1891 : }
1892 : }
1893 :
1894 : static long
1895 462812 : H_model(GEN x)
1896 : {
1897 462812 : long res = H_model0(x);
1898 462812 : if (res == H_INVALID) pari_err_TYPE("H_model", x);
1899 462672 : return res;
1900 : }
1901 :
1902 : static GEN
1903 756 : alC_add_i(GEN al, GEN x, GEN y, long lx)
1904 : {
1905 756 : GEN A = cgetg(lx, t_COL);
1906 : long i;
1907 2296 : for (i=1; i<lx; i++) gel(A,i) = algadd(al, gel(x,i), gel(y,i));
1908 749 : return A;
1909 : }
1910 : static GEN
1911 406 : alM_add(GEN al, GEN x, GEN y)
1912 : {
1913 406 : long lx = lg(x), l, j;
1914 : GEN z;
1915 406 : if (lg(y) != lx) pari_err_DIM("alM_add (rows)");
1916 392 : if (lx == 1) return cgetg(1, t_MAT);
1917 385 : z = cgetg(lx, t_MAT); l = lgcols(x);
1918 385 : if (lgcols(y) != l) pari_err_DIM("alM_add (columns)");
1919 1127 : for (j = 1; j < lx; j++) gel(z,j) = alC_add_i(al, gel(x,j), gel(y,j), l);
1920 371 : return z;
1921 : }
1922 : static GEN
1923 17745 : H_add(GEN x, GEN y)
1924 : {
1925 17745 : long tx = H_model(x), ty = H_model(y);
1926 17724 : if ((tx==H_MATRIX) ^ (ty==H_MATRIX)) pari_err_TYPE2("H_add", x, y);
1927 17710 : if (tx>ty) { swap(x,y); lswap(tx,ty); }
1928 17710 : switch (tx)
1929 : {
1930 105 : case H_MATRIX: /* both H_MATRIX */ return alM_add(NULL, x, y);
1931 16681 : case H_QUATERNION: /* both H_QUATERNION */ return gadd(x,y);
1932 924 : case H_SCALAR:
1933 924 : if (ty == H_SCALAR) return gadd(x,y);
1934 : else /* ty == H_QUATERNION */
1935 : {
1936 217 : pari_sp av = avma;
1937 217 : GEN res = gcopy(y), im;
1938 217 : gel(res,1) = gadd(gel(res,1), real_i(x));
1939 217 : im = imag_i(x);
1940 217 : if (im != gen_0) gel(res,2) = gadd(gel(res,2), im);
1941 217 : return gerepileupto(av, res);
1942 : }
1943 : }
1944 : return NULL; /*LCOV_EXCL_LINE*/
1945 : }
1946 : GEN
1947 54999 : algadd(GEN al, GEN x, GEN y)
1948 : {
1949 54999 : pari_sp av = avma;
1950 : long tx, ty;
1951 : GEN p;
1952 54999 : checkalg(al);
1953 54999 : if (alg_type(al)==al_REAL) return H_add(x,y);
1954 37254 : tx = alg_model(al,x);
1955 37247 : ty = alg_model(al,y);
1956 37247 : p = alg_get_char(al);
1957 37247 : if (signe(p)) return FpC_add(x,y,p);
1958 37114 : if (tx==ty) {
1959 36232 : if (tx!=al_MATRIX) return gadd(x,y);
1960 301 : return gerepilecopy(av, alM_add(al,x,y));
1961 : }
1962 882 : if (tx==al_ALGEBRAIC) x = algalgtobasis(al,x);
1963 882 : if (ty==al_ALGEBRAIC) y = algalgtobasis(al,y);
1964 882 : return gerepileupto(av, gadd(x,y));
1965 : }
1966 :
1967 : static GEN
1968 98 : H_neg(GEN x)
1969 : {
1970 98 : (void)H_model(x);
1971 70 : return gneg(x);
1972 : }
1973 :
1974 : GEN
1975 245 : algneg(GEN al, GEN x)
1976 : {
1977 245 : checkalg(al);
1978 245 : if (alg_type(al)==al_REAL) return H_neg(x);
1979 147 : (void)alg_model(al,x);
1980 140 : return gneg(x);
1981 : }
1982 :
1983 : static GEN
1984 210 : alC_sub_i(GEN al, GEN x, GEN y, long lx)
1985 : {
1986 : long i;
1987 210 : GEN A = cgetg(lx, t_COL);
1988 630 : for (i=1; i<lx; i++) gel(A,i) = algsub(al, gel(x,i), gel(y,i));
1989 210 : return A;
1990 : }
1991 : static GEN
1992 126 : alM_sub(GEN al, GEN x, GEN y)
1993 : {
1994 126 : long lx = lg(x), l, j;
1995 : GEN z;
1996 126 : if (lg(y) != lx) pari_err_DIM("alM_sub (rows)");
1997 119 : if (lx == 1) return cgetg(1, t_MAT);
1998 112 : z = cgetg(lx, t_MAT); l = lgcols(x);
1999 112 : if (lgcols(y) != l) pari_err_DIM("alM_sub (columns)");
2000 315 : for (j = 1; j < lx; j++) gel(z,j) = alC_sub_i(al, gel(x,j), gel(y,j), l);
2001 105 : return z;
2002 : }
2003 : GEN
2004 1120 : algsub(GEN al, GEN x, GEN y)
2005 : {
2006 : long tx, ty;
2007 1120 : pari_sp av = avma;
2008 : GEN p;
2009 1120 : checkalg(al);
2010 1120 : if (alg_type(al)==al_REAL) return gerepileupto(av, algadd(NULL,x,gneg(y)));
2011 966 : tx = alg_model(al,x);
2012 959 : ty = alg_model(al,y);
2013 959 : p = alg_get_char(al);
2014 959 : if (signe(p)) return FpC_sub(x,y,p);
2015 868 : if (tx==ty) {
2016 546 : if (tx != al_MATRIX) return gsub(x,y);
2017 126 : return gerepilecopy(av, alM_sub(al,x,y));
2018 : }
2019 322 : if (tx==al_ALGEBRAIC) x = algalgtobasis(al,x);
2020 322 : if (ty==al_ALGEBRAIC) y = algalgtobasis(al,y);
2021 322 : return gerepileupto(av, gsub(x,y));
2022 : }
2023 :
2024 : static GEN
2025 1659 : algalgmul_cyc(GEN al, GEN x, GEN y)
2026 : {
2027 1659 : pari_sp av = avma;
2028 1659 : long n = alg_get_degree(al), i, k;
2029 : GEN xalg, yalg, res, rnf, auts, sum, b, prod, autx;
2030 1659 : rnf = alg_get_splittingfield(al);
2031 1659 : auts = alg_get_auts(al);
2032 1659 : b = alg_get_b(al);
2033 :
2034 1659 : xalg = cgetg(n+1, t_COL);
2035 4935 : for (i=0; i<n; i++)
2036 3276 : gel(xalg,i+1) = lift_shallow(rnfbasistoalg(rnf,gel(x,i+1)));
2037 :
2038 1659 : yalg = cgetg(n+1, t_COL);
2039 4935 : for (i=0; i<n; i++) gel(yalg,i+1) = rnfbasistoalg(rnf,gel(y,i+1));
2040 :
2041 1659 : res = cgetg(n+1,t_COL);
2042 4935 : for (k=0; k<n; k++) {
2043 3276 : gel(res,k+1) = gmul(gel(xalg,k+1),gel(yalg,1));
2044 5166 : for (i=1; i<=k; i++) {
2045 1890 : autx = poleval(gel(xalg,k-i+1),gel(auts,i));
2046 1890 : prod = gmul(autx,gel(yalg,i+1));
2047 1890 : gel(res,k+1) = gadd(gel(res,k+1), prod);
2048 : }
2049 :
2050 3276 : sum = gen_0;
2051 5166 : for (; i<n; i++) {
2052 1890 : autx = poleval(gel(xalg,k+n-i+1),gel(auts,i));
2053 1890 : prod = gmul(autx,gel(yalg,i+1));
2054 1890 : sum = gadd(sum,prod);
2055 : }
2056 3276 : sum = gmul(b,sum);
2057 :
2058 3276 : gel(res,k+1) = gadd(gel(res,k+1),sum);
2059 : }
2060 :
2061 1659 : return gerepilecopy(av, res);
2062 : }
2063 :
2064 : static GEN
2065 521612 : _tablemul(GEN mt, GEN x, GEN y)
2066 : {
2067 521612 : pari_sp av = avma;
2068 521612 : long D = lg(mt)-1, i;
2069 521612 : GEN res = NULL;
2070 8015056 : for (i=1; i<=D; i++) {
2071 7493444 : GEN c = gel(x,i);
2072 7493444 : if (!gequal0(c)) {
2073 1754087 : GEN My = RgM_RgC_mul(gel(mt,i),y);
2074 1754087 : GEN t = RgC_Rg_mul(My,c);
2075 1754087 : res = res? RgC_add(res,t): t;
2076 : }
2077 : }
2078 521612 : if (!res) { set_avma(av); return zerocol(D); }
2079 520702 : return gerepileupto(av, res);
2080 : }
2081 :
2082 : static GEN
2083 291196 : _tablemul_Fp(GEN mt, GEN x, GEN y, GEN p)
2084 : {
2085 291196 : pari_sp av = avma;
2086 291196 : long D = lg(mt)-1, i;
2087 291196 : GEN res = NULL;
2088 2825921 : for (i=1; i<=D; i++) {
2089 2534725 : GEN c = gel(x,i);
2090 2534725 : if (signe(c)) {
2091 521194 : GEN My = FpM_FpC_mul(gel(mt,i),y,p);
2092 521194 : GEN t = FpC_Fp_mul(My,c,p);
2093 521194 : res = res? FpC_add(res,t,p): t;
2094 : }
2095 : }
2096 291196 : if (!res) { set_avma(av); return zerocol(D); }
2097 290657 : return gerepileupto(av, res);
2098 : }
2099 :
2100 : /* x*ej */
2101 : static GEN
2102 111811 : _tablemul_ej(GEN mt, GEN x, long j)
2103 : {
2104 111811 : pari_sp av = avma;
2105 111811 : long D = lg(mt)-1, i;
2106 111811 : GEN res = NULL;
2107 1707468 : for (i=1; i<=D; i++) {
2108 1595657 : GEN c = gel(x,i);
2109 1595657 : if (!gequal0(c)) {
2110 162302 : GEN My = gel(gel(mt,i),j);
2111 162302 : GEN t = RgC_Rg_mul(My,c);
2112 162302 : res = res? RgC_add(res,t): t;
2113 : }
2114 : }
2115 111811 : if (!res) { set_avma(av); return zerocol(D); }
2116 111629 : return gerepileupto(av, res);
2117 : }
2118 : static GEN
2119 242039 : _tablemul_ej_Fp(GEN mt, GEN x, long j, GEN p)
2120 : {
2121 242039 : pari_sp av = avma;
2122 242039 : long D = lg(mt)-1, i;
2123 242039 : GEN res = NULL;
2124 4364787 : for (i=1; i<=D; i++) {
2125 4122748 : GEN c = gel(x,i);
2126 4122748 : if (!gequal0(c)) {
2127 289954 : GEN My = gel(gel(mt,i),j);
2128 289954 : GEN t = FpC_Fp_mul(My,c,p);
2129 289954 : res = res? FpC_add(res,t,p): t;
2130 : }
2131 : }
2132 242039 : if (!res) { set_avma(av); return zerocol(D); }
2133 241927 : return gerepileupto(av, res);
2134 : }
2135 :
2136 : static GEN
2137 520237 : _tablemul_ej_Fl(GEN mt, GEN x, long j, ulong p)
2138 : {
2139 520237 : pari_sp av = avma;
2140 520237 : long D = lg(mt)-1, i;
2141 520237 : GEN res = NULL;
2142 12252276 : for (i=1; i<=D; i++) {
2143 11732039 : ulong c = x[i];
2144 11732039 : if (c) {
2145 1113054 : GEN My = gel(gel(mt,i),j);
2146 1113054 : GEN t = Flv_Fl_mul(My,c, p);
2147 1113054 : res = res? Flv_add(res,t, p): t;
2148 : }
2149 : }
2150 520237 : if (!res) { set_avma(av); return zero_Flv(D); }
2151 520237 : return gerepileupto(av, res);
2152 : }
2153 :
2154 : static GEN
2155 686 : algalgmul_csa(GEN al, GEN x, GEN y)
2156 : {
2157 686 : GEN z, nf = alg_get_center(al);
2158 : long i;
2159 686 : z = _tablemul(alg_get_relmultable(al), x, y);
2160 2485 : for (i=1; i<lg(z); i++)
2161 1799 : gel(z,i) = basistoalg(nf,gel(z,i));
2162 686 : return z;
2163 : }
2164 :
2165 : /* assumes x and y in algebraic form */
2166 : static GEN
2167 2345 : algalgmul(GEN al, GEN x, GEN y)
2168 : {
2169 2345 : switch(alg_type(al))
2170 : {
2171 1659 : case al_CYCLIC: return algalgmul_cyc(al, x, y);
2172 686 : case al_CSA: return algalgmul_csa(al, x, y);
2173 : }
2174 : return NULL; /*LCOV_EXCL_LINE*/
2175 : }
2176 :
2177 : static GEN
2178 812122 : algbasismul(GEN al, GEN x, GEN y)
2179 : {
2180 812122 : GEN mt = alg_get_multable(al), p = alg_get_char(al);
2181 812122 : if (signe(p)) return _tablemul_Fp(mt, x, y, p);
2182 520926 : return _tablemul(mt, x, y);
2183 : }
2184 :
2185 : /* x[i,]*y. Assume lg(x) > 1 and 0 < i < lgcols(x) */
2186 : static GEN
2187 119651 : alMrow_alC_mul_i(GEN al, GEN x, GEN y, long i, long lx)
2188 : {
2189 119651 : pari_sp av = avma;
2190 119651 : GEN c = algmul(al,gcoeff(x,i,1),gel(y,1)), ZERO;
2191 : long k;
2192 119651 : ZERO = zerocol(alg_get_absdim(al));
2193 273308 : for (k = 2; k < lx; k++)
2194 : {
2195 153657 : GEN t = algmul(al, gcoeff(x,i,k), gel(y,k));
2196 153657 : if (!gequal(t,ZERO)) c = algadd(al, c, t);
2197 : }
2198 119651 : return gerepilecopy(av, c);
2199 : }
2200 : /* return x * y, 1 < lx = lg(x), l = lgcols(x) */
2201 : static GEN
2202 54502 : alM_alC_mul_i(GEN al, GEN x, GEN y, long lx, long l)
2203 : {
2204 54502 : GEN z = cgetg(l,t_COL);
2205 : long i;
2206 174153 : for (i=1; i<l; i++) gel(z,i) = alMrow_alC_mul_i(al,x,y,i,lx);
2207 54502 : return z;
2208 : }
2209 : static GEN
2210 25627 : alM_mul(GEN al, GEN x, GEN y)
2211 : {
2212 25627 : long j, l, lx=lg(x), ly=lg(y);
2213 : GEN z;
2214 25627 : if (ly==1) return cgetg(1,t_MAT);
2215 25529 : if (lx != lgcols(y)) pari_err_DIM("alM_mul");
2216 25508 : if (lx==1) return zeromat(0, ly-1);
2217 25501 : l = lgcols(x); z = cgetg(ly,t_MAT);
2218 80003 : for (j=1; j<ly; j++) gel(z,j) = alM_alC_mul_i(al,x,gel(y,j),lx,l);
2219 25501 : return z;
2220 : }
2221 :
2222 : static void
2223 205639 : H_compo(GEN x, GEN* a, GEN* b, GEN* c, GEN* d)
2224 : {
2225 205639 : switch(H_model(x))
2226 : {
2227 5173 : case H_SCALAR:
2228 5173 : *a = real_i(x);
2229 5173 : *b = imag_i(x);
2230 5173 : *c = gen_0;
2231 5173 : *d = gen_0;
2232 5173 : return;
2233 200466 : case H_QUATERNION:
2234 200466 : *a = gel(x,1);
2235 200466 : *b = gel(x,2);
2236 200466 : *c = gel(x,3);
2237 200466 : *d = gel(x,4);
2238 200466 : return;
2239 : default: *a = *b = *c = *d = NULL; return; /*LCOV_EXCL_LINE*/
2240 : }
2241 : }
2242 : static GEN
2243 108129 : H_mul(GEN x, GEN y)
2244 : {
2245 108129 : pari_sp av = avma;
2246 : GEN a,b,c,d,u,v,w,z;
2247 108129 : long tx = H_model(x), ty = H_model(y);
2248 108115 : if ((tx==H_MATRIX) ^ (ty==H_MATRIX)) pari_err_TYPE2("H_mul", x, y);
2249 108108 : if (tx == H_MATRIX) /* both H_MATRIX */ return alM_mul(NULL, x, y);
2250 103817 : if (tx == H_SCALAR && ty == H_SCALAR) return gmul(x,y);
2251 102620 : H_compo(x,&a,&b,&c,&d);
2252 102620 : H_compo(y,&u,&v,&w,&z);
2253 102620 : return gerepilecopy(av,mkcol4(
2254 : gsub(gmul(a,u), gadd(gadd(gmul(b,v),gmul(c,w)),gmul(d,z))),
2255 : gsub(gadd(gmul(a,v),gadd(gmul(b,u),gmul(c,z))), gmul(d,w)),
2256 : gsub(gadd(gmul(a,w),gadd(gmul(c,u),gmul(d,v))), gmul(b,z)),
2257 : gsub(gadd(gmul(a,z),gadd(gmul(b,w),gmul(d,u))), gmul(c,v))
2258 : ));
2259 : }
2260 :
2261 : GEN
2262 817753 : algmul(GEN al, GEN x, GEN y)
2263 : {
2264 817753 : pari_sp av = avma;
2265 : long tx, ty;
2266 817753 : checkalg(al);
2267 817753 : if (alg_type(al)==al_REAL) return H_mul(x,y);
2268 709904 : tx = alg_model(al,x);
2269 709890 : ty = alg_model(al,y);
2270 709890 : if (tx==al_MATRIX) {
2271 20832 : if (ty==al_MATRIX) return alM_mul(al,x,y);
2272 7 : pari_err_TYPE("algmul", y);
2273 : }
2274 689058 : if (signe(alg_get_char(al))) return algbasismul(al,x,y);
2275 520947 : if (tx==al_TRIVIAL) retmkcol(gmul(gel(x,1),gel(y,1)));
2276 520247 : if (tx==al_ALGEBRAIC && ty==al_ALGEBRAIC) return algalgmul(al,x,y);
2277 518721 : if (tx==al_ALGEBRAIC) x = algalgtobasis(al,x);
2278 518721 : if (ty==al_ALGEBRAIC) y = algalgtobasis(al,y);
2279 518721 : return gerepileupto(av,algbasismul(al,x,y));
2280 : }
2281 :
2282 : static GEN
2283 329 : H_sqr(GEN x)
2284 : {
2285 329 : pari_sp av = avma;
2286 329 : long tx = H_model(x);
2287 : GEN a,b,c,d;
2288 308 : if (tx == H_SCALAR) return gsqr(x);
2289 224 : if (tx == H_MATRIX) return H_mul(x,x);
2290 119 : H_compo(x,&a,&b,&c,&d);
2291 119 : return gerepilecopy(av, mkcol4(
2292 : gsub(gsqr(a), gadd(gsqr(b),gadd(gsqr(c),gsqr(d)))),
2293 : gshift(gmul(a,b),1),
2294 : gshift(gmul(a,c),1),
2295 : gshift(gmul(a,d),1)
2296 : ));
2297 : }
2298 :
2299 : GEN
2300 122364 : algsqr(GEN al, GEN x)
2301 : {
2302 122364 : pari_sp av = avma;
2303 : long tx;
2304 122364 : checkalg(al);
2305 122329 : if (alg_type(al)==al_REAL) return H_sqr(x);
2306 122000 : tx = alg_model(al,x);
2307 121930 : if (tx==al_MATRIX) return gerepilecopy(av,alM_mul(al,x,x));
2308 121419 : if (signe(alg_get_char(al))) return algbasismul(al,x,x);
2309 3374 : if (tx==al_TRIVIAL) retmkcol(gsqr(gel(x,1)));
2310 3024 : if (tx==al_ALGEBRAIC) return algalgmul(al,x,x);
2311 2205 : return gerepileupto(av,algbasismul(al,x,x));
2312 : }
2313 :
2314 : static GEN
2315 11970 : algmtK2Z_cyc(GEN al, GEN m)
2316 : {
2317 11970 : pari_sp av = avma;
2318 11970 : GEN nf = alg_get_abssplitting(al), res, mt, rnf = alg_get_splittingfield(al), c, dc;
2319 11970 : long n = alg_get_degree(al), N = nf_get_degree(nf), Nn, i, j, i1, j1;
2320 11970 : Nn = N*n;
2321 11970 : res = zeromatcopy(Nn,Nn);
2322 51982 : for (i=0; i<n; i++)
2323 226030 : for (j=0; j<n; j++) {
2324 186018 : c = gcoeff(m,i+1,j+1);
2325 186018 : if (!gequal0(c)) {
2326 40012 : c = rnfeltreltoabs(rnf,c);
2327 40012 : c = algtobasis(nf,c);
2328 40012 : c = Q_remove_denom(c,&dc);
2329 40012 : mt = zk_multable(nf,c);
2330 40012 : if (dc) mt = ZM_Z_div(mt,dc);
2331 348208 : for (i1=1; i1<=N; i1++)
2332 3253306 : for (j1=1; j1<=N; j1++)
2333 2945110 : gcoeff(res,i*N+i1,j*N+j1) = gcoeff(mt,i1,j1);
2334 : }
2335 : }
2336 11970 : return gerepilecopy(av,res);
2337 : }
2338 :
2339 : static GEN
2340 1379 : algmtK2Z_csa(GEN al, GEN m)
2341 : {
2342 1379 : pari_sp av = avma;
2343 1379 : GEN nf = alg_get_center(al), res, mt, c, dc;
2344 1379 : long d2 = alg_get_dim(al), n = nf_get_degree(nf), D, i, j, i1, j1;
2345 1379 : D = d2*n;
2346 1379 : res = zeromatcopy(D,D);
2347 7630 : for (i=0; i<d2; i++)
2348 39550 : for (j=0; j<d2; j++) {
2349 33299 : c = gcoeff(m,i+1,j+1);
2350 33299 : if (!gequal0(c)) {
2351 5887 : c = algtobasis(nf,c);
2352 5887 : c = Q_remove_denom(c,&dc);
2353 5887 : mt = zk_multable(nf,c);
2354 5887 : if (dc) mt = ZM_Z_div(mt,dc);
2355 18620 : for (i1=1; i1<=n; i1++)
2356 43526 : for (j1=1; j1<=n; j1++)
2357 30793 : gcoeff(res,i*n+i1,j*n+j1) = gcoeff(mt,i1,j1);
2358 : }
2359 : }
2360 1379 : return gerepilecopy(av,res);
2361 : }
2362 :
2363 : /* assumes al is a CSA or CYCLIC */
2364 : static GEN
2365 13349 : algmtK2Z(GEN al, GEN m)
2366 : {
2367 13349 : switch(alg_type(al))
2368 : {
2369 11970 : case al_CYCLIC: return algmtK2Z_cyc(al, m);
2370 1379 : case al_CSA: return algmtK2Z_csa(al, m);
2371 : }
2372 : return NULL; /*LCOV_EXCL_LINE*/
2373 : }
2374 :
2375 : /* left multiplication table, as a vector space of dimension n over the splitting field (by right multiplication) */
2376 : static GEN
2377 14735 : algalgmultable_cyc(GEN al, GEN x)
2378 : {
2379 14735 : pari_sp av = avma;
2380 14735 : long n = alg_get_degree(al), i, j;
2381 : GEN res, rnf, auts, b, pol;
2382 14735 : rnf = alg_get_splittingfield(al);
2383 14735 : auts = alg_get_auts(al);
2384 14735 : b = alg_get_b(al);
2385 14735 : pol = rnf_get_pol(rnf);
2386 :
2387 14735 : res = zeromatcopy(n,n);
2388 60333 : for (i=0; i<n; i++)
2389 45598 : gcoeff(res,i+1,1) = lift_shallow(rnfbasistoalg(rnf,gel(x,i+1)));
2390 :
2391 60333 : for (i=0; i<n; i++) {
2392 121730 : for (j=1; j<=i; j++)
2393 76132 : gcoeff(res,i+1,j+1) = gmodulo(poleval(gcoeff(res,i-j+1,1),gel(auts,j)),pol);
2394 121730 : for (; j<n; j++)
2395 76132 : gcoeff(res,i+1,j+1) = gmodulo(gmul(b,poleval(gcoeff(res,n+i-j+1,1),gel(auts,j))), pol);
2396 : }
2397 :
2398 60333 : for (i=0; i<n; i++)
2399 45598 : gcoeff(res,i+1,1) = gmodulo(gcoeff(res,i+1,1),pol);
2400 :
2401 14735 : return gerepilecopy(av, res);
2402 : }
2403 :
2404 : static GEN
2405 1848 : elementmultable(GEN mt, GEN x)
2406 : {
2407 1848 : pari_sp av = avma;
2408 1848 : long D = lg(mt)-1, i;
2409 1848 : GEN z = NULL;
2410 9681 : for (i=1; i<=D; i++)
2411 : {
2412 7833 : GEN c = gel(x,i);
2413 7833 : if (!gequal0(c))
2414 : {
2415 2618 : GEN M = RgM_Rg_mul(gel(mt,i),c);
2416 2618 : z = z? RgM_add(z, M): M;
2417 : }
2418 : }
2419 1848 : if (!z) { set_avma(av); return zeromatcopy(D,D); }
2420 1848 : return gerepileupto(av, z);
2421 : }
2422 : /* mt a t_VEC of Flm modulo m */
2423 : static GEN
2424 41430 : algbasismultable_Flm(GEN mt, GEN x, ulong m)
2425 : {
2426 41430 : pari_sp av = avma;
2427 41430 : long D = lg(gel(mt,1))-1, i;
2428 41430 : GEN z = NULL;
2429 561667 : for (i=1; i<=D; i++)
2430 : {
2431 520237 : ulong c = x[i];
2432 520237 : if (c)
2433 : {
2434 66780 : GEN M = Flm_Fl_mul(gel(mt,i),c, m);
2435 66780 : z = z? Flm_add(z, M, m): M;
2436 : }
2437 : }
2438 41430 : if (!z) { set_avma(av); return zero_Flm(D,D); }
2439 41430 : return gerepileupto(av, z);
2440 : }
2441 : static GEN
2442 336310 : elementabsmultable_Z(GEN mt, GEN x)
2443 : {
2444 336310 : long i, l = lg(x);
2445 336310 : GEN z = NULL;
2446 3909186 : for (i = 1; i < l; i++)
2447 : {
2448 3572876 : GEN c = gel(x,i);
2449 3572876 : if (signe(c))
2450 : {
2451 1030420 : GEN M = ZM_Z_mul(gel(mt,i),c);
2452 1030420 : z = z? ZM_add(z, M): M;
2453 : }
2454 : }
2455 336310 : return z;
2456 : }
2457 : static GEN
2458 149376 : elementabsmultable(GEN mt, GEN x)
2459 : {
2460 149376 : GEN d, z = elementabsmultable_Z(mt, Q_remove_denom(x,&d));
2461 149376 : return (z && d)? ZM_Z_div(z, d): z;
2462 : }
2463 : static GEN
2464 186934 : elementabsmultable_Fp(GEN mt, GEN x, GEN p)
2465 : {
2466 186934 : GEN z = elementabsmultable_Z(mt, x);
2467 186934 : return z? FpM_red(z, p): z;
2468 : }
2469 : static GEN
2470 336310 : algbasismultable(GEN al, GEN x)
2471 : {
2472 336310 : pari_sp av = avma;
2473 336310 : GEN z, p = alg_get_char(al), mt = alg_get_multable(al);
2474 336310 : z = signe(p)? elementabsmultable_Fp(mt, x, p): elementabsmultable(mt, x);
2475 336310 : if (!z)
2476 : {
2477 4205 : long D = lg(mt)-1;
2478 4205 : set_avma(av); return zeromat(D,D);
2479 : }
2480 332105 : return gerepileupto(av, z);
2481 : }
2482 :
2483 : static GEN
2484 1848 : algalgmultable_csa(GEN al, GEN x)
2485 : {
2486 1848 : GEN nf = alg_get_center(al), m;
2487 : long i,j;
2488 1848 : m = elementmultable(alg_get_relmultable(al), x);
2489 9681 : for (i=1; i<lg(m); i++)
2490 47166 : for(j=1; j<lg(m); j++)
2491 39333 : gcoeff(m,i,j) = basistoalg(nf,gcoeff(m,i,j));
2492 1848 : return m;
2493 : }
2494 :
2495 : /* assumes x in algebraic form */
2496 : static GEN
2497 16268 : algalgmultable(GEN al, GEN x)
2498 : {
2499 16268 : switch(alg_type(al))
2500 : {
2501 14735 : case al_CYCLIC: return algalgmultable_cyc(al, x);
2502 1533 : case al_CSA: return algalgmultable_csa(al, x);
2503 : }
2504 : return NULL; /*LCOV_EXCL_LINE*/
2505 : }
2506 :
2507 : /* on the natural basis */
2508 : /* assumes x in algebraic form */
2509 : static GEN
2510 13349 : algZmultable(GEN al, GEN x) {
2511 13349 : pari_sp av = avma;
2512 13349 : return gerepileupto(av, algmtK2Z(al,algalgmultable(al,x)));
2513 : }
2514 :
2515 : /* x integral */
2516 : static GEN
2517 41146 : algbasisrightmultable(GEN al, GEN x)
2518 : {
2519 41146 : long N = alg_get_absdim(al), i,j,k;
2520 41146 : GEN res = zeromatcopy(N,N), c, mt = alg_get_multable(al), p = alg_get_char(al);
2521 41146 : if (gequal0(p)) p = NULL;
2522 373639 : for (i=1; i<=N; i++) {
2523 332493 : c = gel(x,i);
2524 332493 : if (!gequal0(c)) {
2525 1336417 : for (j=1; j<=N; j++)
2526 20668180 : for(k=1; k<=N; k++) {
2527 19452623 : if (p) gcoeff(res,k,j) = Fp_add(gcoeff(res,k,j), Fp_mul(c, gcoeff(gel(mt,j),k,i), p), p);
2528 14537423 : else gcoeff(res,k,j) = addii(gcoeff(res,k,j), mulii(c, gcoeff(gel(mt,j),k,i)));
2529 : }
2530 : }
2531 : }
2532 41146 : return res;
2533 : }
2534 :
2535 : /* basis for matrices : 1, E_{i,j} for (i,j)!=(1,1) */
2536 : /* index : ijk = ((i-1)*N+j-1)*n + k */
2537 : /* square matrices only, coefficients in basis form, shallow function */
2538 : static GEN
2539 23961 : algmat2basis(GEN al, GEN M)
2540 : {
2541 23961 : long n = alg_get_absdim(al), N = lg(M)-1, i, j, k, ij, ijk;
2542 : GEN res, x;
2543 23961 : res = zerocol(N*N*n);
2544 75131 : for (i=1; i<=N; i++) {
2545 163310 : for (j=1, ij=(i-1)*N+1; j<=N; j++, ij++) {
2546 112140 : x = gcoeff(M,i,j);
2547 819532 : for (k=1, ijk=(ij-1)*n+1; k<=n; k++, ijk++) {
2548 707392 : gel(res, ijk) = gel(x, k);
2549 707392 : if (i>1 && i==j) gel(res, ijk) = gsub(gel(res,ijk), gel(res,k));
2550 : }
2551 : }
2552 : }
2553 :
2554 23961 : return res;
2555 : }
2556 :
2557 : static GEN
2558 294 : algbasis2mat(GEN al, GEN M, long N)
2559 : {
2560 294 : long n = alg_get_absdim(al), i, j, k, ij, ijk;
2561 : GEN res, x;
2562 294 : res = zeromatcopy(N,N);
2563 882 : for (i=1; i<=N; i++)
2564 1764 : for (j=1; j<=N; j++)
2565 1176 : gcoeff(res,i,j) = zerocol(n);
2566 :
2567 882 : for (i=1; i<=N; i++) {
2568 1764 : for (j=1, ij=(i-1)*N+1; j<=N; j++, ij++) {
2569 1176 : x = gcoeff(res,i,j);
2570 9240 : for (k=1, ijk=(ij-1)*n+1; k<=n; k++, ijk++) {
2571 8064 : gel(x,k) = gel(M,ijk);
2572 8064 : if (i>1 && i==j) gel(x,k) = gadd(gel(x,k), gel(M,k));
2573 : }
2574 : }
2575 : }
2576 :
2577 294 : return res;
2578 : }
2579 :
2580 : static GEN
2581 23884 : algmatbasis_ei(GEN al, long ijk, long N)
2582 : {
2583 23884 : long n = alg_get_absdim(al), i, j, k, ij;
2584 : GEN res;
2585 :
2586 23884 : res = zeromatcopy(N,N);
2587 74900 : for (i=1; i<=N; i++)
2588 162848 : for (j=1; j<=N; j++)
2589 111832 : gcoeff(res,i,j) = zerocol(n);
2590 :
2591 23884 : k = ijk%n;
2592 23884 : if (k==0) k=n;
2593 23884 : ij = (ijk-k)/n+1;
2594 :
2595 23884 : if (ij==1) {
2596 16947 : for (i=1; i<=N; i++)
2597 11410 : gcoeff(res,i,i) = col_ei(n,k);
2598 5537 : return res;
2599 : }
2600 :
2601 18347 : j = ij%N;
2602 18347 : if (j==0) j=N;
2603 18347 : i = (ij-j)/N+1;
2604 :
2605 18347 : gcoeff(res,i,j) = col_ei(n,k);
2606 18347 : return res;
2607 : }
2608 :
2609 : /* FIXME lazy implementation! */
2610 : static GEN
2611 910 : algleftmultable_mat(GEN al, GEN M)
2612 : {
2613 910 : long N = lg(M)-1, n = alg_get_absdim(al), D = N*N*n, j;
2614 : GEN res, x, Mx;
2615 910 : if (N == 0) return cgetg(1, t_MAT);
2616 903 : if (N != nbrows(M)) pari_err_DIM("algleftmultable_mat (nonsquare)");
2617 882 : res = cgetg(D+1, t_MAT);
2618 24766 : for (j=1; j<=D; j++) {
2619 23884 : x = algmatbasis_ei(al, j, N);
2620 23884 : Mx = algmul(al, M, x);
2621 23884 : gel(res, j) = algmat2basis(al, Mx);
2622 : }
2623 882 : return res;
2624 : }
2625 :
2626 : /* left multiplication table on integral basis */
2627 : static GEN
2628 22078 : algleftmultable(GEN al, GEN x)
2629 : {
2630 22078 : pari_sp av = avma;
2631 : long tx;
2632 : GEN res;
2633 :
2634 22078 : checkalg(al);
2635 22078 : tx = alg_model(al,x);
2636 22071 : switch(tx) {
2637 987 : case al_TRIVIAL : res = mkmatcopy(mkcol(gel(x,1))); break;
2638 259 : case al_ALGEBRAIC : x = algalgtobasis(al,x);
2639 20566 : case al_BASIS : res = algbasismultable(al,x); break;
2640 518 : case al_MATRIX : res = algleftmultable_mat(al,x); break;
2641 : default : return NULL; /* LCOV_EXCL_LINE */
2642 : }
2643 22064 : return gerepileupto(av,res);
2644 : }
2645 :
2646 : static GEN
2647 4347 : algbasissplittingmatrix_csa(GEN al, GEN x)
2648 : {
2649 4347 : long d = alg_get_degree(al), i, j;
2650 4347 : GEN rnf = alg_get_splittingfield(al), splba = alg_get_splittingbasis(al), splbainv = alg_get_splittingbasisinv(al), M;
2651 4347 : M = algbasismultable(al,x);
2652 4347 : M = RgM_mul(M, splba); /* TODO best order ? big matrix /Q vs small matrix /nf */
2653 4347 : M = RgM_mul(splbainv, M);
2654 12852 : for (i=1; i<=d; i++)
2655 25326 : for (j=1; j<=d; j++)
2656 16821 : gcoeff(M,i,j) = rnfeltabstorel(rnf, gcoeff(M,i,j));
2657 4347 : return M;
2658 : }
2659 :
2660 : static GEN
2661 728 : algmat_tomatrix(GEN al, GEN x) /* abs = 0 */
2662 : {
2663 : GEN res;
2664 : long i,j;
2665 728 : if (lg(x) == 1) return cgetg(1, t_MAT);
2666 700 : res = zeromatcopy(nbrows(x),lg(x)-1);
2667 2212 : for (j=1; j<lg(x); j++)
2668 4879 : for (i=1; i<lgcols(x); i++)
2669 3367 : gcoeff(res,i,j) = algtomatrix(al,gcoeff(x,i,j),0);
2670 700 : return shallowmatconcat(res);
2671 : }
2672 :
2673 : static GEN
2674 42 : R_tomatrix(GEN x)
2675 : {
2676 42 : long t = H_model(x);
2677 42 : if (t == H_QUATERNION) pari_err_TYPE("R_tomatrix", x);
2678 35 : if (t == H_MATRIX) return x;
2679 21 : return mkmat(mkcol(x));
2680 : }
2681 : static GEN
2682 84 : C_tomatrix(GEN z, long abs)
2683 : {
2684 : GEN x,y;
2685 84 : long t = H_model(z), nrows, ncols;
2686 84 : if (t == H_QUATERNION) pari_err_TYPE("C_tomatrix", z);
2687 77 : if (!abs)
2688 : {
2689 14 : if (t == H_MATRIX) return z;
2690 7 : return mkmat(mkcol(z));
2691 : }
2692 63 : if (t == H_MATRIX)
2693 : {
2694 : /* Warning: this is not the same choice of basis as for other algebras */
2695 : GEN res, a, b;
2696 : long i,j;
2697 56 : RgM_dimensions(z,&nrows,&ncols);
2698 56 : res = zeromatcopy(2*nrows,2*ncols);
2699 168 : for (i=1; i<=nrows; i++)
2700 336 : for (j=1; j<=ncols; j++)
2701 : {
2702 224 : a = real_i(gcoeff(z,i,j));
2703 224 : b = imag_i(gcoeff(z,i,j));
2704 224 : gcoeff(res,2*i-1,2*j-1) = a;
2705 224 : gcoeff(res,2*i,2*j) = a;
2706 224 : gcoeff(res,2*i-1,2*j) = gneg(b);
2707 224 : gcoeff(res,2*i,2*j-1) = b;
2708 : }
2709 56 : return res;
2710 : }
2711 7 : x = real_i(z);
2712 7 : y = imag_i(z);
2713 7 : return mkmat22(x,gneg(y),y,x);
2714 : }
2715 : static GEN
2716 2394 : H_tomatrix(GEN x, long abs)
2717 : {
2718 2394 : long tx = H_model(x);
2719 2387 : GEN a = NULL, b =NULL, c = NULL, d = NULL, md = NULL, M = NULL;
2720 2387 : if (abs) {
2721 350 : if (tx == H_MATRIX) return algleftmultable_mat(NULL,x);
2722 217 : switch(tx)
2723 : {
2724 56 : case H_SCALAR:
2725 56 : a = real_i(x);
2726 56 : b = imag_i(x);
2727 56 : c = gen_0;
2728 56 : d = gen_0;
2729 56 : break;
2730 161 : case H_QUATERNION:
2731 161 : a = gel(x,1);
2732 161 : b = gel(x,2);
2733 161 : c = gel(x,3);
2734 161 : d = gel(x,4);
2735 161 : break;
2736 : }
2737 217 : M = scalarmat(a,4);
2738 217 : gcoeff(M,2,1) = gcoeff(M,4,3) = b;
2739 217 : gcoeff(M,1,2) = gcoeff(M,3,4) = gneg(b);
2740 217 : gcoeff(M,3,1) = gcoeff(M,2,4) = c;
2741 217 : gcoeff(M,4,2) = gcoeff(M,1,3) = gneg(c);
2742 217 : gcoeff(M,4,1) = gcoeff(M,3,2) = d;
2743 217 : gcoeff(M,2,3) = gcoeff(M,1,4) = gneg(d);
2744 : }
2745 : else /* abs == 0 */
2746 : {
2747 2037 : if (tx == H_MATRIX) return algmat_tomatrix(NULL,x);
2748 1778 : switch(tx)
2749 : {
2750 273 : case H_SCALAR:
2751 273 : M = mkmat22(
2752 : x, gen_0,
2753 : gen_0, conj_i(x)
2754 : );
2755 273 : break;
2756 1505 : case H_QUATERNION:
2757 1505 : a = gel(x,1);
2758 1505 : b = gel(x,2);
2759 1505 : c = gel(x,3);
2760 1505 : md = gneg(gel(x,4));
2761 1505 : M = mkmat22(
2762 : mkcomplex(a,b), mkcomplex(gneg(c),md),
2763 : mkcomplex(c,md), mkcomplex(a,gneg(b))
2764 : );
2765 : }
2766 : }
2767 1995 : return M;
2768 : }
2769 :
2770 : GEN
2771 25109 : algtomatrix(GEN al, GEN x, long abs)
2772 : {
2773 25109 : pari_sp av = avma;
2774 25109 : GEN res = NULL;
2775 : long ta, tx;
2776 25109 : checkalg(al);
2777 25109 : ta = alg_type(al);
2778 25109 : if (ta==al_REAL)
2779 : {
2780 2268 : switch(alg_get_absdim(al)) {
2781 42 : case 1: res = R_tomatrix(x); break;
2782 84 : case 2: res = C_tomatrix(x,abs); break;
2783 2135 : case 4: res = H_tomatrix(x,abs); break;
2784 7 : default: pari_err_TYPE("algtomatrix [apply alginit]", al);
2785 : }
2786 2240 : return gerepilecopy(av, res);
2787 : }
2788 22841 : if (abs || ta==al_TABLE) return algleftmultable(al,x);
2789 7014 : tx = alg_model(al,x);
2790 7014 : if (tx == al_MATRIX) res = algmat_tomatrix(al,x);
2791 6545 : else switch (alg_type(al))
2792 : {
2793 2198 : case al_CYCLIC:
2794 2198 : if (tx==al_BASIS) x = algbasistoalg(al,x);
2795 2198 : res = algalgmultable(al,x);
2796 2198 : break;
2797 4347 : case al_CSA:
2798 4347 : if (tx==al_ALGEBRAIC) x = algalgtobasis(al,x);
2799 4347 : res = algbasissplittingmatrix_csa(al,x);
2800 4347 : break;
2801 : default: return NULL; /*LCOV_EXCL_LINE*/
2802 : }
2803 7014 : return gerepilecopy(av,res);
2804 : }
2805 :
2806 : /* x^(-1)*y, NULL if no solution */
2807 : static GEN
2808 112 : C_divl_i(GEN x, GEN y)
2809 : {
2810 112 : long tx = H_model(x), ty = H_model(y);
2811 112 : if (tx != ty) pari_err_TYPE2("C_divl", x, y);
2812 105 : switch (tx) {
2813 42 : case H_SCALAR:
2814 42 : if (gequal0(x)) return gequal0(y) ? gen_0 : NULL;
2815 14 : else return gdiv(y,x);
2816 56 : case H_MATRIX:
2817 56 : if ((lg(x)>1 && lg(x) != lgcols(x)) || (lg(y)>1 && lg(y) != lgcols(y)))
2818 7 : pari_err_DIM("C_divl (nonsquare)");
2819 49 : if (lg(x) != lg(y)) pari_err_DIM("C_divl");
2820 42 : if (lg(y) == 1) return cgetg(1, t_MAT);
2821 42 : return RgM_invimage(x, y);
2822 7 : default: pari_err_TYPE("C_divl", x); return NULL;
2823 : }
2824 : }
2825 : /* H^k -> C^2k */
2826 : static GEN
2827 140 : HC_to_CC(GEN v)
2828 : {
2829 140 : long l = lg(v), i;
2830 140 : GEN w = cgetg(2*l-1, t_COL), a, b, c, d;
2831 420 : for (i=1; i<l; i++)
2832 : {
2833 280 : H_compo(gel(v,i),&a,&b,&c,&d);
2834 280 : gel(w,2*i-1) = mkcomplex(a,b);
2835 280 : gel(w,2*i) = mkcomplex(c,gneg(d));
2836 : }
2837 140 : return w;
2838 : }
2839 : /* C^2k -> H^k */
2840 : static GEN
2841 98 : CC_to_HC(GEN w)
2842 : {
2843 98 : long l = lg(w), i, lv = (l+1)/2;
2844 98 : GEN v = cgetg(lv, t_COL), ab, cd;
2845 294 : for (i=1; i<lv; i++)
2846 : {
2847 196 : ab = gel(w,2*i-1);
2848 196 : cd = gel(w,2*i);
2849 196 : gel(v,i) = mkcol4(real_i(ab),imag_i(ab),real_i(cd),gneg(imag_i(cd)));
2850 : }
2851 98 : return v;
2852 : }
2853 : /* M_{k,n}(H) -> M_{2k,n}(C) */
2854 : static GEN
2855 210 : HM_to_CM(GEN x) pari_APPLY_same(HC_to_CC(gel(x,i)));
2856 : /* M_{2k,n}(C) -> M_{k,n}(H) */
2857 : static GEN
2858 147 : CM_to_HM(GEN x) pari_APPLY_same(CC_to_HC(gel(x,i)));
2859 : /* x^(-1)*y, NULL if no solution */
2860 : static GEN
2861 203 : H_divl_i(GEN x, GEN y)
2862 : {
2863 203 : pari_sp av = avma;
2864 203 : long tx = H_model(x), ty = H_model(y);
2865 189 : if ((tx==H_MATRIX) ^ (ty==H_MATRIX)) pari_err_TYPE2("H_divl", x, y);
2866 168 : if (tx==H_MATRIX)
2867 : {
2868 : GEN mx, my, mxdivy;
2869 98 : if ((lg(x)>1 && lg(x) != lgcols(x)) || (lg(y)>1 && lg(y) != lgcols(y)))
2870 14 : pari_err_DIM("H_divl (nonsquare)");
2871 84 : if (lg(x) != lg(y)) pari_err_DIM("H_divl");
2872 77 : if (lg(y) == 1) return cgetg(1, t_MAT);
2873 70 : mx = H_tomatrix(x,0);
2874 70 : my = HM_to_CM(y);
2875 70 : mxdivy = RgM_invimage(mx, my);
2876 70 : if (!mxdivy) return gc_NULL(av);
2877 49 : return gerepilecopy(av,CM_to_HM(mxdivy));
2878 : }
2879 70 : if (gequal0(y)) return gen_0;
2880 56 : if (gequal0(x)) return NULL;
2881 42 : return gerepilecopy(av,H_mul(H_inv(x),y));
2882 : }
2883 : /* x^(-1)*y, NULL if no solution */
2884 : static GEN
2885 1729 : algdivl_i(GEN al, GEN x, GEN y, long tx, long ty) {
2886 1729 : pari_sp av = avma;
2887 1729 : GEN res, p = alg_get_char(al), mtx;
2888 1729 : if (tx != ty) {
2889 343 : if (tx==al_ALGEBRAIC) { x = algalgtobasis(al,x); tx=al_BASIS; }
2890 343 : if (ty==al_ALGEBRAIC) { y = algalgtobasis(al,y); ty=al_BASIS; }
2891 : }
2892 1729 : if (ty == al_MATRIX)
2893 : {
2894 77 : if (alg_type(al) != al_TABLE) y = algalgtobasis(al,y);
2895 77 : y = algmat2basis(al,y);
2896 : }
2897 1729 : if (signe(p)) res = FpM_FpC_invimage(algbasismultable(al,x),y,p);
2898 : else
2899 : {
2900 1540 : if (ty==al_ALGEBRAIC) mtx = algalgmultable(al,x);
2901 833 : else mtx = algleftmultable(al,x);
2902 1540 : res = inverseimage(mtx,y);
2903 : }
2904 1729 : if (!res || lg(res)==1) return gc_NULL(av);
2905 1701 : if (tx == al_MATRIX) {
2906 294 : res = algbasis2mat(al, res, lg(x)-1);
2907 294 : return gerepilecopy(av,res);
2908 : }
2909 1407 : return gerepileupto(av,res);
2910 : }
2911 : static GEN
2912 1015 : algdivl_i2(GEN al, GEN x, GEN y)
2913 : {
2914 : long tx, ty;
2915 1015 : checkalg(al);
2916 1015 : if (alg_type(al)==al_REAL) switch(alg_get_absdim(al)) {
2917 112 : case 1: case 2: return C_divl_i(x,y);
2918 147 : case 4: return H_divl_i(x,y);
2919 : }
2920 756 : tx = alg_model(al,x);
2921 749 : ty = alg_model(al,y);
2922 749 : if (tx == al_MATRIX) {
2923 140 : if (ty != al_MATRIX) pari_err_TYPE2("\\", x, y);
2924 133 : if ((lg(x)>1 && lg(x) != lgcols(x)) || (lg(y)>1 && lg(y) != lgcols(y)))
2925 28 : pari_err_DIM("algdivl (nonsquare)");
2926 105 : if (lg(x) != lg(y)) pari_err_DIM("algdivl");
2927 84 : if (lg(y) == 1) return cgetg(1, t_MAT);
2928 : }
2929 686 : return algdivl_i(al,x,y,tx,ty);
2930 : }
2931 :
2932 889 : GEN algdivl(GEN al, GEN x, GEN y)
2933 : {
2934 : GEN z;
2935 889 : z = algdivl_i2(al,x,y);
2936 742 : if (!z) pari_err_INV("algdivl", x);
2937 728 : return z;
2938 : }
2939 :
2940 : int
2941 126 : algisdivl(GEN al, GEN x, GEN y, GEN* ptz)
2942 : {
2943 126 : pari_sp av = avma;
2944 126 : GEN z = algdivl_i2(al,x,y);
2945 126 : if (!z) return gc_bool(av,0);
2946 84 : if (ptz != NULL) *ptz = z;
2947 84 : return 1;
2948 : }
2949 :
2950 : static GEN
2951 140 : C_inv(GEN x)
2952 : {
2953 140 : switch (H_model(x))
2954 : {
2955 63 : case H_SCALAR: return gequal0(x) ? NULL : ginv(x);
2956 70 : case H_MATRIX: return RgM_inv(x);
2957 7 : default: pari_err_TYPE("alginv_i", x);
2958 : }
2959 : return NULL; /*LCOV_EXCL_LINE*/
2960 : }
2961 : static GEN
2962 259 : H_inv(GEN x)
2963 : {
2964 259 : pari_sp av = avma;
2965 : GEN nm, xi;
2966 : long i;
2967 259 : switch (H_model(x))
2968 : {
2969 28 : case H_SCALAR:
2970 28 : if (gequal0(x)) return NULL;
2971 14 : return ginv(x);
2972 161 : case H_QUATERNION:
2973 161 : if (gequal0(x)) return NULL;
2974 154 : nm = H_norm(x, 0);
2975 154 : xi = gdiv(x,nm);
2976 616 : for(i=2; i<=4; i++) gel(xi,i) = gneg(gel(xi,i));
2977 154 : return gerepilecopy(av,xi);
2978 63 : case H_MATRIX:
2979 63 : if (lg(x)==1) return cgetg(1,t_MAT);
2980 56 : return H_divl_i(x, matid(lg(x)-1));
2981 : }
2982 : return NULL; /*LCOV_EXCL_LINE*/
2983 : }
2984 : static GEN
2985 1512 : alginv_i(GEN al, GEN x)
2986 : {
2987 1512 : pari_sp av = avma;
2988 1512 : GEN res = NULL, p = alg_get_char(al);
2989 : long tx, n, ta;
2990 1512 : ta = alg_type(al);
2991 1512 : if (ta==al_REAL) switch(alg_get_absdim(al)) {
2992 140 : case 1: case 2: return C_inv(x);
2993 217 : case 4: return H_inv(x);
2994 7 : default: pari_err_TYPE("alginv_i [apply alginit]", al);
2995 : }
2996 1148 : tx = alg_model(al,x);
2997 1127 : switch(tx) {
2998 63 : case al_TRIVIAL :
2999 63 : if (signe(p)) { res = mkcol(Fp_inv(gel(x,1),p)); break; }
3000 49 : else { res = mkcol(ginv(gel(x,1))); break; }
3001 455 : case al_ALGEBRAIC :
3002 : switch(ta) {
3003 350 : case al_CYCLIC: n = alg_get_degree(al); break;
3004 105 : case al_CSA: n = alg_get_dim(al); break;
3005 : default: return NULL; /* LCOV_EXCL_LINE */
3006 : }
3007 455 : res = algdivl_i(al, x, col_ei(n,1), tx, al_ALGEBRAIC); break;
3008 371 : case al_BASIS : res = algdivl_i(al, x, col_ei(alg_get_absdim(al),1), tx,
3009 371 : al_BASIS); break;
3010 238 : case al_MATRIX :
3011 238 : n = lg(x)-1;
3012 238 : if (n==0) return cgetg(1, t_MAT);
3013 224 : if (n != nbrows(x)) pari_err_DIM("alginv_i (nonsquare)");
3014 217 : res = algdivl_i(al, x, col_ei(n*n*alg_get_absdim(al),1), tx, al_BASIS);
3015 : /* cheat on type because wrong dimension */
3016 : }
3017 1106 : if (!res) return gc_NULL(av);
3018 1092 : return gerepilecopy(av,res);
3019 : }
3020 : GEN
3021 1323 : alginv(GEN al, GEN x)
3022 : {
3023 : GEN z;
3024 1323 : checkalg(al);
3025 1323 : z = alginv_i(al,x);
3026 1274 : if (!z) pari_err_INV("alginv", x);
3027 1239 : return z;
3028 : }
3029 :
3030 : int
3031 189 : algisinv(GEN al, GEN x, GEN* ptix)
3032 : {
3033 189 : pari_sp av = avma;
3034 : GEN ix;
3035 189 : if (al) checkalg(al);
3036 189 : ix = alginv_i(al,x);
3037 189 : if (!ix) return gc_bool(av,0);
3038 133 : if (ptix != NULL) *ptix = ix;
3039 133 : return 1;
3040 : }
3041 :
3042 : /* x*y^(-1) */
3043 : GEN
3044 469 : algdivr(GEN al, GEN x, GEN y) { return algmul(al, x, alginv(al, y)); }
3045 :
3046 49113 : static GEN _mul(void* data, GEN x, GEN y) { return algmul((GEN)data,x,y); }
3047 119977 : static GEN _sqr(void* data, GEN x) { return algsqr((GEN)data,x); }
3048 :
3049 : static GEN
3050 21 : algmatid(GEN al, long N)
3051 : {
3052 21 : long n = alg_get_absdim(al), i, j;
3053 : GEN res, one, zero;
3054 :
3055 21 : res = zeromatcopy(N,N);
3056 21 : one = col_ei(n,1);
3057 21 : zero = zerocol(n);
3058 49 : for (i=1; i<=N; i++)
3059 84 : for (j=1; j<=N; j++)
3060 56 : gcoeff(res,i,j) = i==j ? one : zero;
3061 21 : return res;
3062 : }
3063 :
3064 : GEN
3065 20426 : algpow(GEN al, GEN x, GEN n)
3066 : {
3067 20426 : pari_sp av = avma;
3068 : GEN res;
3069 20426 : long s = signe(n);
3070 20426 : checkalg(al);
3071 20426 : if (!s && alg_type(al)==al_REAL)
3072 : {
3073 63 : if (H_model(x) == H_MATRIX) return matid(lg(x)-1);
3074 35 : else return gen_1;
3075 : }
3076 20363 : switch (s) {
3077 28 : case 0:
3078 28 : if (alg_model(al,x) == al_MATRIX)
3079 21 : res = algmatid(al,lg(x)-1);
3080 : else
3081 7 : res = col_ei(alg_get_absdim(al),1);
3082 28 : return res;
3083 20188 : case 1:
3084 20188 : res = gen_pow_i(x, n, (void*)al, _sqr, _mul); break;
3085 147 : default: /* -1 */
3086 147 : res = gen_pow_i(alginv(al,x), gneg(n), (void*)al, _sqr, _mul);
3087 : }
3088 20321 : return gerepilecopy(av,res);
3089 : }
3090 :
3091 : static GEN
3092 546 : algredcharpoly_i(GEN al, GEN x, long v)
3093 : {
3094 546 : GEN rnf = alg_get_splittingfield(al);
3095 546 : GEN cp = charpoly(algtomatrix(al,x,0),v);
3096 539 : long i, m = lg(cp);
3097 2184 : for (i=2; i<m; i++) gel(cp,i) = rnfeltdown(rnf, gel(cp,i));
3098 539 : return cp;
3099 : }
3100 :
3101 : /* assumes al is CSA or CYCLIC */
3102 : static GEN
3103 553 : algredcharpoly(GEN al, GEN x, long v)
3104 : {
3105 553 : pari_sp av = avma;
3106 553 : long w = gvar(rnf_get_pol(alg_get_center(al)));
3107 553 : if (varncmp(v,w)>=0) pari_err_PRIORITY("algredcharpoly",pol_x(v),">=",w);
3108 546 : switch(alg_type(al))
3109 : {
3110 546 : case al_CYCLIC:
3111 : case al_CSA:
3112 546 : return gerepileupto(av, algredcharpoly_i(al, x, v));
3113 : }
3114 : return NULL; /*LCOV_EXCL_LINE*/
3115 : }
3116 :
3117 : static GEN
3118 31473 : algbasischarpoly(GEN al, GEN x, long v)
3119 : {
3120 31473 : pari_sp av = avma;
3121 31473 : GEN p = alg_get_char(al), mx;
3122 31473 : if (alg_model(al,x) == al_MATRIX) mx = algleftmultable_mat(al,x);
3123 31382 : else mx = algbasismultable(al,x);
3124 31466 : if (signe(p)) {
3125 29198 : GEN res = FpM_charpoly(mx,p);
3126 29198 : setvarn(res,v);
3127 29198 : return gerepileupto(av, res);
3128 : }
3129 2268 : return gerepileupto(av, charpoly(mx,v));
3130 : }
3131 :
3132 : static GEN
3133 35 : R_charpoly(GEN x, long v, long abs)
3134 : {
3135 35 : pari_sp av = avma;
3136 35 : GEN res = NULL;
3137 35 : switch (H_model(x))
3138 : {
3139 14 : case H_SCALAR: res = mkpoln(2, gen_1, gneg(x)); break;
3140 14 : case H_MATRIX:
3141 14 : res = charpoly(x,v);
3142 14 : if (abs) res = gpowgs(res,nbrows(x));
3143 14 : break;
3144 7 : default: pari_err_TYPE("R_charpoly", x);
3145 : }
3146 28 : if (v) setvarn(res, v);
3147 28 : return gerepilecopy(av, res);
3148 : }
3149 : static GEN
3150 35 : C_charpoly(GEN x, long v, long abs)
3151 : {
3152 35 : pari_sp av = avma;
3153 35 : GEN res = NULL;
3154 35 : switch (H_model(x))
3155 : {
3156 14 : case H_SCALAR:
3157 14 : if (abs) res = mkpoln(3, gen_1, gneg(gshift(real_i(x),1)), cxnorm(x));
3158 7 : else res = mkpoln(2, gen_1, gneg(x));
3159 14 : break;
3160 14 : case H_MATRIX:
3161 14 : res = charpoly(x,v);
3162 14 : if (abs) res = gpowgs(real_i(gmul(res,gconj(res))),nbrows(x));
3163 14 : break;
3164 7 : default: pari_err_TYPE("C_charpoly", x);
3165 : }
3166 28 : if (v) setvarn(res, v);
3167 28 : return gerepilecopy(av, res);
3168 : }
3169 : static GEN
3170 98 : H_charpoly(GEN x, long v, long abs)
3171 : {
3172 98 : pari_sp av = avma;
3173 : GEN res;
3174 98 : if (H_model(x) == H_MATRIX) return greal(charpoly(H_tomatrix(x,abs),v));
3175 70 : res = mkpoln(3, gen_1, gneg(H_trace(x,0)), H_norm(x,0));
3176 70 : if (v) setvarn(res, v);
3177 70 : if (abs) res = gsqr(res);
3178 70 : return gerepilecopy(av, res);
3179 : }
3180 :
3181 : GEN
3182 31739 : algcharpoly(GEN al, GEN x, long v, long abs)
3183 : {
3184 : long ta;
3185 31739 : if (v<0) v=0;
3186 31739 : checkalg(al);
3187 31739 : ta = alg_type(al);
3188 31739 : if (ta == al_REAL) switch (alg_get_absdim(al)) {
3189 35 : case 1: return R_charpoly(x, v, abs);
3190 35 : case 2: return C_charpoly(x, v, abs);
3191 98 : case 4: return H_charpoly(x, v, abs);
3192 7 : default: pari_err_TYPE("algcharpoly [apply alginit]", al);
3193 : }
3194 :
3195 : /* gneg(x[1]) left on stack */
3196 31564 : if (alg_model(al,x) == al_TRIVIAL) {
3197 84 : GEN p = alg_get_char(al);
3198 84 : if (signe(p)) return deg1pol(gen_1,Fp_neg(gel(x,1),p),v);
3199 70 : return deg1pol(gen_1,gneg(gel(x,1)),v);
3200 : }
3201 :
3202 31473 : switch(ta) {
3203 665 : case al_CYCLIC: case al_CSA:
3204 665 : if (abs)
3205 : {
3206 112 : if (alg_model(al,x)==al_ALGEBRAIC) x = algalgtobasis(al,x);
3207 : }
3208 553 : else return algredcharpoly(al,x,v);
3209 30920 : case al_TABLE: return algbasischarpoly(al,x,v);
3210 : default : return NULL; /* LCOV_EXCL_LINE */
3211 : }
3212 : }
3213 :
3214 : /* assumes x in basis form */
3215 : static GEN
3216 587425 : algabstrace(GEN al, GEN x)
3217 : {
3218 587425 : pari_sp av = avma;
3219 587425 : GEN res = NULL, p = alg_get_char(al);
3220 587425 : if (signe(p)) return FpV_dotproduct(x, alg_get_tracebasis(al), p);
3221 48412 : switch(alg_model(al,x)) {
3222 154 : case al_TRIVIAL: return gcopy(gel(x,1)); break;
3223 48258 : case al_BASIS: res = RgV_dotproduct(x, alg_get_tracebasis(al)); break;
3224 : }
3225 48258 : return gerepileupto(av,res);
3226 : }
3227 :
3228 : static GEN
3229 1470 : algredtrace(GEN al, GEN x)
3230 : {
3231 1470 : pari_sp av = avma;
3232 1470 : GEN res = NULL;
3233 1470 : switch(alg_model(al,x)) {
3234 35 : case al_TRIVIAL: return gcopy(gel(x,1)); break;
3235 539 : case al_BASIS: return algredtrace(al, algbasistoalg(al,x));
3236 : /* TODO precompute too? */
3237 896 : case al_ALGEBRAIC:
3238 896 : switch(alg_type(al))
3239 : {
3240 581 : case al_CYCLIC:
3241 581 : res = rnfelttrace(alg_get_splittingfield(al),gel(x,1));
3242 581 : break;
3243 315 : case al_CSA:
3244 315 : res = gtrace(algalgmultable_csa(al,x));
3245 315 : res = gdiv(res, stoi(alg_get_degree(al)));
3246 315 : break;
3247 : default: return NULL; /* LCOV_EXCL_LINE */
3248 : }
3249 : }
3250 896 : return gerepileupto(av,res);
3251 : }
3252 :
3253 : static GEN
3254 469 : algtrace_mat(GEN al, GEN M, long abs) {
3255 469 : pari_sp av = avma;
3256 469 : long N = lg(M)-1, i;
3257 469 : GEN res, p = alg_get_char(al);
3258 469 : if (N == 0) return gen_0;
3259 448 : if (N != nbrows(M)) pari_err_DIM("algtrace_mat (nonsquare)");
3260 :
3261 434 : if (!signe(p)) p = NULL;
3262 434 : if (alg_type(al) == al_TABLE) abs = 1;
3263 434 : res = algtrace(al, gcoeff(M,1,1), abs);
3264 896 : for (i=2; i<=N; i++) {
3265 462 : if (p) res = Fp_add(res, algtrace(al,gcoeff(M,i,i),abs), p);
3266 455 : else res = gadd(res, algtrace(al,gcoeff(M,i,i),abs));
3267 : }
3268 434 : if (abs) res = gmulgu(res, N); /* absolute trace */
3269 434 : return gerepileupto(av, res);
3270 : }
3271 :
3272 : static GEN
3273 35 : R_trace(GEN x, long abs)
3274 : {
3275 35 : pari_sp av = avma;
3276 35 : GEN res = NULL;
3277 35 : switch (H_model(x))
3278 : {
3279 14 : case H_SCALAR: res = gcopy(x); break;
3280 14 : case H_MATRIX: res = abs? mulrs(gtrace(x),nbrows(x)) : gtrace(x); break;
3281 7 : default: pari_err_TYPE("R_trace", x);
3282 : }
3283 28 : return gerepilecopy(av, res);
3284 : }
3285 : static GEN
3286 35 : C_trace(GEN x, long abs)
3287 : {
3288 35 : pari_sp av = avma;
3289 35 : GEN res = NULL;
3290 35 : switch (H_model(x))
3291 : {
3292 14 : case H_SCALAR: res = abs ? gshift(real_i(x),1) : x; break;
3293 14 : case H_MATRIX:
3294 14 : res = abs ? mulrs(real_i(gtrace(x)),2*nbrows(x)) : gtrace(x); break;
3295 7 : default: pari_err_TYPE("C_trace", x);
3296 : }
3297 28 : return gerepilecopy(av, res);
3298 : }
3299 : static GEN
3300 567 : H_trace(GEN x, long abs)
3301 : {
3302 567 : long s = abs? 2 : 1;
3303 567 : switch (H_model(x))
3304 : {
3305 154 : case H_SCALAR: return gshift(real_i(x),s);
3306 329 : case H_QUATERNION: return gshift(gel(x,1),s);
3307 77 : case H_MATRIX:
3308 77 : return algtrace_mat(NULL, x, abs);
3309 : }
3310 : return NULL; /*LCOV_EXCL_LINE*/
3311 : }
3312 :
3313 : GEN
3314 2681 : algtrace(GEN al, GEN x, long abs)
3315 : {
3316 : long ta;
3317 2681 : checkalg(al);
3318 2681 : ta = alg_type(al);
3319 2681 : if (ta==al_REAL) switch (alg_get_absdim(al)) {
3320 35 : case 1: return R_trace(x,abs);
3321 35 : case 2: return C_trace(x,abs);
3322 497 : case 4: return H_trace(x,abs);
3323 7 : default: pari_err_TYPE("algtrace [apply alginit]", al);
3324 : }
3325 2107 : if (alg_model(al,x) == al_MATRIX) return algtrace_mat(al,x,abs);
3326 1715 : switch(ta) {
3327 1575 : case al_CYCLIC: case al_CSA:
3328 1575 : if (!abs) return algredtrace(al,x);
3329 644 : if (alg_model(al,x)==al_ALGEBRAIC) x = algalgtobasis(al,x);
3330 784 : case al_TABLE: return algabstrace(al,x);
3331 : default : return NULL; /* LCOV_EXCL_LINE */
3332 : }
3333 : }
3334 :
3335 : static GEN
3336 58493 : ZM_trace(GEN x)
3337 : {
3338 58493 : long i, lx = lg(x);
3339 : GEN t;
3340 58493 : if (lx < 3) return lx == 1? gen_0: gcopy(gcoeff(x,1,1));
3341 57611 : t = gcoeff(x,1,1);
3342 1020723 : for (i = 2; i < lx; i++) t = addii(t, gcoeff(x,i,i));
3343 57611 : return t;
3344 : }
3345 : static GEN
3346 200506 : FpM_trace(GEN x, GEN p)
3347 : {
3348 200506 : long i, lx = lg(x);
3349 : GEN t;
3350 200506 : if (lx < 3) return lx == 1? gen_0: gcopy(gcoeff(x,1,1));
3351 189069 : t = gcoeff(x,1,1);
3352 1598063 : for (i = 2; i < lx; i++) t = Fp_add(t, gcoeff(x,i,i), p);
3353 189069 : return t;
3354 : }
3355 :
3356 : static GEN
3357 58998 : algtracebasis(GEN al)
3358 : {
3359 58998 : pari_sp av = avma;
3360 58998 : GEN mt = alg_get_multable(al), p = alg_get_char(al);
3361 58998 : long i, l = lg(mt);
3362 58998 : GEN v = cgetg(l, t_VEC);
3363 259504 : if (signe(p)) for (i=1; i < l; i++) gel(v,i) = FpM_trace(gel(mt,i), p);
3364 65831 : else for (i=1; i < l; i++) gel(v,i) = ZM_trace(gel(mt,i));
3365 58998 : return gerepileupto(av,v);
3366 : }
3367 :
3368 : /* Assume: i > 0, expo := p^i <= absdim, x contained in I_{i-1} given by mult
3369 : * table modulo modu=p^(i+1). Return Tr(x^(p^i)) mod modu */
3370 : static ulong
3371 41430 : algtracei(GEN mt, ulong p, ulong expo, ulong modu)
3372 : {
3373 41430 : pari_sp av = avma;
3374 41430 : long j, l = lg(mt);
3375 41430 : ulong tr = 0;
3376 41430 : mt = Flm_powu(mt,expo,modu);
3377 561667 : for (j=1; j<l; j++) tr += ucoeff(mt,j,j);
3378 41430 : return gc_ulong(av, (tr/expo) % p);
3379 : }
3380 :
3381 : static GEN
3382 42 : R_norm(GEN x, long abs)
3383 : {
3384 42 : pari_sp av = avma;
3385 42 : GEN res = NULL;
3386 42 : switch (H_model(x))
3387 : {
3388 14 : case H_SCALAR: res = gcopy(x); break;
3389 21 : case H_MATRIX: res = abs ? powrs(det(x),nbrows(x)) : det(x); break;
3390 7 : default: pari_err_TYPE("R_norm", x);
3391 : }
3392 35 : return gerepilecopy(av,res);
3393 : }
3394 : static GEN
3395 42 : C_norm(GEN x, long abs)
3396 : {
3397 42 : pari_sp av = avma;
3398 42 : GEN res = NULL;
3399 42 : switch (H_model(x))
3400 : {
3401 14 : case H_SCALAR: res = abs ? cxnorm(x) : x; break;
3402 21 : case H_MATRIX: res = abs ? powrs(cxnorm(det(x)),nbrows(x)) : det(x); break;
3403 7 : default: pari_err_TYPE("C_norm", x);
3404 : }
3405 35 : return gerepilecopy(av,res);
3406 : }
3407 : static GEN
3408 434 : H_norm(GEN x, long abs)
3409 : {
3410 434 : pari_sp av = avma;
3411 434 : switch (H_model(x))
3412 : {
3413 42 : case H_SCALAR:
3414 42 : if (abs) return gerepilecopy(av,gsqr(gnorm(x)));
3415 35 : else return gnorm(x);
3416 322 : case H_QUATERNION:
3417 322 : if (abs) return gerepilecopy(av,gsqr(gnorml2(x)));
3418 294 : else return gnorml2(x);
3419 63 : case H_MATRIX:
3420 63 : return gerepilecopy(av,real_i(det(H_tomatrix(x,abs))));
3421 : }
3422 : return NULL; /*LCOV_EXCL_LINE*/
3423 : }
3424 :
3425 : GEN
3426 1309 : algnorm(GEN al, GEN x, long abs)
3427 : {
3428 1309 : pari_sp av = avma;
3429 : long tx, ta;
3430 : GEN p, rnf, res, mx;
3431 1309 : checkalg(al);
3432 1309 : ta = alg_type(al);
3433 1309 : if (ta==al_REAL) switch (alg_get_absdim(al)) {
3434 42 : case 1: return R_norm(x,abs);
3435 42 : case 2: return C_norm(x,abs);
3436 210 : case 4: return H_norm(x,abs);
3437 7 : default: pari_err_TYPE("algnorm [apply alginit]", al);
3438 : }
3439 1008 : p = alg_get_char(al);
3440 1008 : tx = alg_model(al,x);
3441 1008 : if (signe(p)) {
3442 21 : if (tx == al_MATRIX) mx = algleftmultable_mat(al,x);
3443 14 : else mx = algbasismultable(al,x);
3444 21 : return gerepileupto(av, FpM_det(mx,p));
3445 : }
3446 987 : if (tx == al_TRIVIAL) return gcopy(gel(x,1));
3447 :
3448 945 : switch(ta) {
3449 875 : case al_CYCLIC: case al_CSA:
3450 875 : if (abs)
3451 : {
3452 196 : if (alg_model(al,x)==al_ALGEBRAIC) x = algalgtobasis(al,x);
3453 : }
3454 : else
3455 : {
3456 679 : rnf = alg_get_splittingfield(al);
3457 679 : res = rnfeltdown(rnf, det(algtomatrix(al,x,0)));
3458 672 : break;
3459 : }
3460 : case al_TABLE:
3461 266 : if (tx == al_MATRIX) mx = algleftmultable_mat(al,x);
3462 105 : else mx = algbasismultable(al,x);
3463 259 : res = det(mx);
3464 259 : break;
3465 : default: return NULL; /* LCOV_EXCL_LINE */
3466 : }
3467 931 : return gerepileupto(av, res);
3468 : }
3469 :
3470 : static GEN
3471 66550 : algalgtonat_cyc(GEN al, GEN x)
3472 : {
3473 66550 : pari_sp av = avma;
3474 66550 : GEN nf = alg_get_abssplitting(al), rnf = alg_get_splittingfield(al), res, c;
3475 66550 : long n = alg_get_degree(al), N = nf_get_degree(nf), i, i1;
3476 66550 : res = zerocol(N*n);
3477 205978 : for (i=0; i<n; i++) {
3478 139428 : c = gel(x,i+1);
3479 139428 : c = rnfeltreltoabs(rnf,c);
3480 139428 : if (!gequal0(c)) {
3481 92674 : c = algtobasis(nf,c);
3482 483941 : for (i1=1; i1<=N; i1++) gel(res,i*N+i1) = gel(c,i1);
3483 : }
3484 : }
3485 66550 : return gerepilecopy(av, res);
3486 : }
3487 :
3488 : static GEN
3489 15400 : algalgtonat_csa(GEN al, GEN x)
3490 : {
3491 15400 : pari_sp av = avma;
3492 15400 : GEN nf = alg_get_center(al), res, c;
3493 15400 : long d2 = alg_get_dim(al), n = nf_get_degree(nf), i, i1;
3494 15400 : res = zerocol(d2*n);
3495 76650 : for (i=0; i<d2; i++) {
3496 61250 : c = gel(x,i+1);
3497 61250 : if (!gequal0(c)) {
3498 35196 : c = algtobasis(nf,c);
3499 105056 : for (i1=1; i1<=n; i1++) gel(res,i*n+i1) = gel(c,i1);
3500 : }
3501 : }
3502 15400 : return gerepilecopy(av, res);
3503 : }
3504 :
3505 : /* assumes al CSA or CYCLIC */
3506 : static GEN
3507 81950 : algalgtonat(GEN al, GEN x)
3508 : {
3509 81950 : switch(alg_type(al))
3510 : {
3511 66550 : case al_CYCLIC: return algalgtonat_cyc(al, x);
3512 15400 : case al_CSA: return algalgtonat_csa(al, x);
3513 : }
3514 : return NULL; /*LCOV_EXCL_LINE*/
3515 : }
3516 :
3517 : static GEN
3518 14658 : algnattoalg_cyc(GEN al, GEN x)
3519 : {
3520 14658 : pari_sp av = avma;
3521 14658 : GEN nf = alg_get_abssplitting(al), rnf = alg_get_splittingfield(al), res, c;
3522 14658 : long n = alg_get_degree(al), N = nf_get_degree(nf), i, i1;
3523 14658 : res = zerocol(n);
3524 14658 : c = zerocol(N);
3525 60039 : for (i=0; i<n; i++) {
3526 374801 : for (i1=1; i1<=N; i1++) gel(c,i1) = gel(x,i*N+i1);
3527 45381 : gel(res,i+1) = rnfeltabstorel(rnf,basistoalg(nf,c));
3528 : }
3529 14658 : return gerepilecopy(av, res);
3530 : }
3531 :
3532 : static GEN
3533 1813 : algnattoalg_csa(GEN al, GEN x)
3534 : {
3535 1813 : pari_sp av = avma;
3536 1813 : GEN nf = alg_get_center(al), res, c;
3537 1813 : long d2 = alg_get_dim(al), n = nf_get_degree(nf), i, i1;
3538 1813 : res = zerocol(d2);
3539 1813 : c = zerocol(n);
3540 9506 : for (i=0; i<d2; i++) {
3541 25116 : for (i1=1; i1<=n; i1++) gel(c,i1) = gel(x,i*n+i1);
3542 7693 : gel(res,i+1) = basistoalg(nf,c);
3543 : }
3544 1813 : return gerepilecopy(av, res);
3545 : }
3546 :
3547 : /* assumes al CSA or CYCLIC */
3548 : static GEN
3549 16471 : algnattoalg(GEN al, GEN x)
3550 : {
3551 16471 : switch(alg_type(al))
3552 : {
3553 14658 : case al_CYCLIC: return algnattoalg_cyc(al, x);
3554 1813 : case al_CSA: return algnattoalg_csa(al, x);
3555 : }
3556 : return NULL; /*LCOV_EXCL_LINE*/
3557 : }
3558 :
3559 : static GEN
3560 182 : algalgtobasis_mat(GEN al, GEN x) /* componentwise */
3561 : {
3562 182 : pari_sp av = avma;
3563 : long lx, lxj, i, j;
3564 : GEN res;
3565 182 : lx = lg(x);
3566 182 : res = cgetg(lx, t_MAT);
3567 546 : for (j=1; j<lx; j++) {
3568 364 : lxj = lg(gel(x,j));
3569 364 : gel(res,j) = cgetg(lxj, t_COL);
3570 1092 : for (i=1; i<lxj; i++)
3571 728 : gcoeff(res,i,j) = algalgtobasis(al,gcoeff(x,i,j));
3572 : }
3573 182 : return gerepilecopy(av,res);
3574 : }
3575 : GEN
3576 83749 : algalgtobasis(GEN al, GEN x)
3577 : {
3578 : pari_sp av;
3579 : long tx, ta;
3580 83749 : checkalg(al);
3581 83742 : ta = alg_type(al);
3582 83742 : if (ta != al_CYCLIC && ta != al_CSA) pari_err_TYPE("algalgtobasis [use alginit]", al);
3583 83707 : tx = alg_model(al,x);
3584 83700 : if (tx==al_BASIS) return gcopy(x);
3585 82048 : if (tx==al_MATRIX) return algalgtobasis_mat(al,x);
3586 81866 : av = avma;
3587 81866 : x = algalgtonat(al,x);
3588 81866 : x = RgM_RgC_mul(alg_get_invbasis(al),x);
3589 81866 : return gerepileupto(av, x);
3590 : }
3591 :
3592 : /*
3593 : Quaternion algebras special case:
3594 : al = (L/F, sigma, b) with L quadratic
3595 : > v^2-a: i = v
3596 : > v^2+A*v+B: i = 2*v+A: i^2 = a = A^2-4*B
3597 : al ~ (a,b)_F
3598 : */
3599 : /* We could improve efficiency, but these functions are just for convenience. */
3600 : GEN
3601 266 : algquattobasis(GEN al, GEN x)
3602 : {
3603 266 : pari_sp av = avma;
3604 : GEN L1, L2, pol, A, x2, nf;
3605 : long v, i, ta;
3606 266 : checkalg(al);
3607 259 : if (alg_is_asq(al))
3608 : {
3609 84 : x = algalgtonat(al,x);
3610 84 : x = RgM_RgC_mul(alg_get_invbasis(al),x);
3611 84 : return gerepileupto(av,x);
3612 : }
3613 175 : ta = alg_type(al);
3614 175 : if (ta != al_CYCLIC || alg_get_degree(al)!=2)
3615 28 : pari_err_TYPE("algquattobasis [not a quaternion algebra]", al);
3616 147 : if (typ(x)!=t_COL && typ(x)!=t_VEC) pari_err_TYPE("algquattobasis", x);
3617 140 : if (lg(x)!=5) pari_err_DIM("algquattobasis [quaternions have 4 components]");
3618 133 : nf = alg_get_center(al);
3619 133 : x2 = cgetg(5, t_COL);
3620 637 : for (i=1; i<=4; i++) gel(x2,i) = basistoalg(nf, gel(x,i));
3621 126 : gel(x2,4) = gneg(gel(x2,4));
3622 126 : pol = alg_get_splitpol(al);
3623 126 : v = varn(pol);
3624 126 : A = gel(pol,3); /* coeff of v^1 */
3625 126 : if (gequal0(A))
3626 : {
3627 : /* i = v */
3628 77 : L1 = deg1pol_shallow(gel(x2,2), gel(x2,1), v);
3629 77 : L2 = deg1pol_shallow(gel(x2,4), gel(x2,3), v);
3630 : }
3631 : else
3632 : {
3633 : /* i = 2*v+A */
3634 49 : L1 = deg1pol_shallow(gshift(gel(x2,2),1),
3635 49 : gadd(gel(x2,1),gmul(A,gel(x2,2))), v);
3636 49 : L2 = deg1pol_shallow(gshift(gel(x2,4),1),
3637 49 : gadd(gel(x2,3),gmul(A,gel(x2,4))), v);
3638 : }
3639 126 : return gerepileupto(av, algalgtobasis(al,mkcol2(L1,L2)));
3640 : }
3641 : GEN
3642 126 : algbasistoquat(GEN al, GEN x)
3643 : {
3644 126 : pari_sp av = avma;
3645 : GEN pol, A, x2, q;
3646 : long v, ta;
3647 126 : checkalg(al);
3648 119 : if (alg_is_asq(al))
3649 : {
3650 21 : x = RgM_RgC_mul(alg_get_basis(al),x);
3651 21 : x = algnattoalg(al,x);
3652 21 : return gerepileupto(av, x);
3653 : }
3654 98 : ta = alg_type(al);
3655 98 : if (ta != al_CYCLIC || alg_get_degree(al)!=2)
3656 28 : pari_err_TYPE("algbasistoquat [not a quaternion algebra]", al);
3657 70 : pol = alg_get_splitpol(al);
3658 70 : v = varn(pol);
3659 70 : A = gel(pol,3); /* coeff of v^1 */
3660 70 : x2 = algbasistoalg(al, x);
3661 56 : x2 = lift0(x2, v);
3662 56 : q = cgetg(5, t_COL);
3663 56 : if (gequal0(A))
3664 : {
3665 : /* v = i */
3666 42 : gel(q,1) = polcoef_i(gel(x2,1),0,v);
3667 42 : gel(q,2) = polcoef_i(gel(x2,1),1,v);
3668 42 : gel(q,3) = polcoef_i(gel(x2,2),0,v);
3669 42 : gel(q,4) = polcoef_i(gel(x2,2),1,v);
3670 42 : gel(q,4) = gneg(gel(q,4));
3671 : }
3672 : else
3673 : {
3674 : /* v = (i-A)/2 */
3675 14 : gel(q,2) = gshift(polcoef_i(gel(x2,1),1,v),-1);
3676 14 : gel(q,1) = gsub(polcoef_i(gel(x2,1),0,v), gmul(A,gel(q,2)));
3677 14 : gel(q,4) = gneg(gshift(polcoef_i(gel(x2,2),1,v),-1));
3678 14 : gel(q,3) = gadd(polcoef_i(gel(x2,2),0,v),gmul(A,gel(q,4)));
3679 : }
3680 56 : return gerepilecopy(av, q);
3681 : }
3682 : GEN
3683 91 : algisquatalg(GEN al)
3684 : {
3685 91 : pari_sp av = avma;
3686 : GEN pol, a;
3687 : long ta;
3688 91 : checkalg(al);
3689 84 : ta = alg_type(al);
3690 84 : if (ta == al_REAL && algreal_dim(al)==4)
3691 7 : return gerepilecopy(av, mkvec2(gen_m1,gen_m1));
3692 77 : if (alg_is_asq(al))
3693 21 : return gerepilecopy(av, mkvec2(gmael3(al,6,1,1),gmael3(al,6,1,2)));
3694 56 : if (ta != al_CYCLIC || alg_get_degree(al)!=2) return gc_const(av, gen_0);
3695 28 : pol = alg_get_splitpol(al);
3696 28 : if (gequal0(gel(pol,3))) a = gneg(gel(pol,2)); /* coeffs of v^1 and v^0 */
3697 7 : else a = RgX_disc(pol);
3698 28 : return gerepilecopy(av, mkvec2(a,lift_shallow(alg_get_b(al))));
3699 : }
3700 :
3701 : static GEN
3702 119 : algbasistoalg_mat(GEN al, GEN x) /* componentwise */
3703 : {
3704 119 : long j, lx = lg(x);
3705 119 : GEN res = cgetg(lx, t_MAT);
3706 357 : for (j=1; j<lx; j++) {
3707 238 : long i, lxj = lg(gel(x,j));
3708 238 : gel(res,j) = cgetg(lxj, t_COL);
3709 714 : for (i=1; i<lxj; i++) gcoeff(res,i,j) = algbasistoalg(al,gcoeff(x,i,j));
3710 : }
3711 119 : return res;
3712 : }
3713 : GEN
3714 3388 : algbasistoalg(GEN al, GEN x)
3715 : {
3716 : pari_sp av;
3717 : long tx, ta;
3718 3388 : checkalg(al);
3719 3388 : ta = alg_type(al);
3720 3388 : if (ta != al_CYCLIC && ta != al_CSA) pari_err_TYPE("algbasistoalg [use alginit]", al);
3721 3367 : tx = alg_model(al,x);
3722 3353 : if (tx==al_ALGEBRAIC) return gcopy(x);
3723 3220 : if (tx==al_MATRIX) return algbasistoalg_mat(al,x);
3724 3101 : av = avma;
3725 3101 : x = RgM_RgC_mul(alg_get_basis(al),x);
3726 3101 : x = algnattoalg(al,x);
3727 3101 : return gerepileupto(av, x);
3728 : }
3729 :
3730 : static GEN
3731 4466 : R_random(GEN b)
3732 : {
3733 4466 : pari_sp av = avma;
3734 4466 : long prec = realprec(b);
3735 4466 : GEN z = randomr(prec); shiftr_inplace(z, 1);
3736 4466 : return gerepileuptoleaf(av, mulrr(b,addsr(-1, z)));
3737 : }
3738 : static GEN
3739 182 : C_random(GEN b)
3740 : {
3741 182 : retmkcomplex(R_random(b), R_random(b));
3742 : }
3743 : static GEN
3744 980 : H_random(GEN b)
3745 : {
3746 980 : GEN res = cgetg(5, t_COL);
3747 : long i;
3748 4900 : for (i=1; i<=4; i++) gel(res,i) = R_random(b);
3749 980 : return res;
3750 : }
3751 : GEN
3752 19985 : algrandom(GEN al, GEN b)
3753 : {
3754 19985 : GEN res = NULL, p, N;
3755 : long i, n;
3756 19985 : checkalg(al);
3757 19971 : if (alg_type(al)==al_REAL)
3758 : {
3759 1365 : if (typ(b) != t_REAL) pari_err_TYPE("algrandom",b);
3760 1358 : if (signe(b) < 0) pari_err_DOMAIN("algrandom", "b", "<", gen_0, b);
3761 1351 : switch(alg_get_absdim(al))
3762 : {
3763 182 : case 1: res = R_random(b); break;
3764 182 : case 2: res = C_random(b); break;
3765 980 : case 4: res = H_random(b); break;
3766 7 : default: pari_err_TYPE("algrandom [apply alginit]", al);
3767 : }
3768 1344 : return res;
3769 : }
3770 18606 : if (typ(b) != t_INT) pari_err_TYPE("algrandom",b);
3771 18599 : if (signe(b) < 0) pari_err_DOMAIN("algrandom", "b", "<", gen_0, b);
3772 18592 : n = alg_get_absdim(al);
3773 18592 : N = addiu(shifti(b,1), 1); /* left on stack */
3774 18592 : p = alg_get_char(al); if (!signe(p)) p = NULL;
3775 18592 : res = cgetg(n+1,t_COL);
3776 167244 : for (i = 1; i <= n; i++)
3777 : {
3778 148652 : pari_sp av = avma;
3779 148652 : GEN t = subii(randomi(N),b);
3780 148652 : if (p) t = modii(t, p);
3781 148652 : gel(res,i) = gerepileuptoint(av, t);
3782 : }
3783 18592 : return res;
3784 : }
3785 :
3786 : static GEN
3787 84 : H_poleval(GEN pol, GEN x)
3788 : {
3789 84 : pari_sp av = avma;
3790 : GEN res;
3791 : long i;
3792 84 : switch (H_model(x))
3793 : {
3794 21 : case H_SCALAR: return RgX_cxeval(pol, x, NULL);
3795 49 : case H_QUATERNION: break;
3796 7 : default: pari_err_TYPE("H_poleval", x);
3797 : }
3798 :
3799 49 : res = zerocol(4);
3800 231 : for (i=lg(pol)-1; i>1; i--)
3801 : {
3802 182 : gel(res,1) = gadd(gel(res,1), gel(pol,i));
3803 182 : if (i>2) res = H_mul(x, res);
3804 : }
3805 :
3806 49 : return gerepilecopy(av,res);
3807 : }
3808 :
3809 : /* Assumes pol has coefficients in the same ring as the COL x; x either
3810 : * in basis or algebraic form or [x,mx] where mx is the mult. table of x.
3811 : TODO more general version: pol with coeffs in center and x in basis form */
3812 : GEN
3813 28797 : algpoleval(GEN al, GEN pol, GEN x)
3814 : {
3815 28797 : pari_sp av = avma;
3816 28797 : GEN p, mx = NULL, res, c;
3817 28797 : long i, xalg = 0;
3818 28797 : if (typ(pol) != t_POL) pari_err_TYPE("algpoleval", pol);
3819 28783 : checkalg(al);
3820 28783 : if (alg_type(al)==al_REAL) return H_poleval(pol,x);
3821 28699 : p = alg_get_char(al);
3822 28699 : if (typ(x) == t_VEC)
3823 : {
3824 10122 : if (lg(x) != 3) pari_err_TYPE("algpoleval [vector must be of length 2]", x);
3825 10115 : mx = gel(x,2);
3826 10115 : x = gel(x,1);
3827 10115 : if (typ(mx)!=t_MAT || !gequal(x,gel(mx,1)))
3828 21 : pari_err_TYPE("algpoleval [mx must be the multiplication table of x]", mx);
3829 : }
3830 : else
3831 : {
3832 18577 : switch(alg_model(al,x))
3833 : {
3834 14 : case al_ALGEBRAIC: mx = algalgmultable(al,x); xalg=1; break;
3835 18549 : case al_BASIS:
3836 18549 : case al_TRIVIAL: mx = algbasismultable(al,x); break;
3837 7 : default: pari_err_TYPE("algpoleval", x);
3838 : }
3839 : }
3840 28657 : res = zerocol(lg(mx)-1);
3841 28657 : if (signe(p)) {
3842 84620 : for (i=lg(pol)-1; i>1; i--)
3843 : {
3844 61661 : gel(res,1) = Fp_add(gel(res,1), gel(pol,i), p);
3845 61661 : if (i>2) res = FpM_FpC_mul(mx, res, p);
3846 : }
3847 : }
3848 : else {
3849 29071 : for (i=lg(pol)-1; i>1; i--)
3850 : {
3851 23373 : c = gel(pol,i);
3852 23373 : if (xalg || is_rational_t(typ(c))) gel(res,1) = gadd(gel(res,1), c);
3853 364 : else res = RgC_add(res, algeltfromnf_i(al,c));
3854 23373 : if (i>2) res = RgM_RgC_mul(mx, res);
3855 : }
3856 : }
3857 28657 : return gerepileupto(av, res);
3858 : }
3859 :
3860 : /** GRUNWALD-WANG **/
3861 : /*
3862 : Song Wang's PhD thesis (pdf pages)
3863 : p.25 definition of chi_b. K^Ker(chi_b) = K(b^(1/m))
3864 : p.26 bound on the conductor (also Cohen adv. GTM 193 p.166)
3865 : p.21 & p.34 description special case, also on wikipedia:
3866 : http://en.wikipedia.org/wiki/Grunwald%E2%80%93Wang_theorem#Special_fields
3867 : p.77 Kummer case
3868 : */
3869 :
3870 : /* n > 0. Is n = 2^k ? */
3871 : static int
3872 364 : uispow2(ulong n) { return !(n &(n-1)); }
3873 :
3874 : static GEN
3875 413 : get_phi0(GEN bnr, GEN Lpr, GEN Ld, GEN pl, long *pr, long *pn)
3876 : {
3877 413 : const long NTRY = 10; /* FIXME: magic constant */
3878 413 : const long n = (lg(Ld)==1)? 2: vecsmall_max(Ld);
3879 413 : GEN S = bnr_get_cyc(bnr);
3880 : GEN Sst, G, globGmod, loc, X, Rglob, Rloc, H, U, Lconj;
3881 : long i, j, r, nbfrob, nbloc, nz, t;
3882 :
3883 413 : *pn = n;
3884 413 : *pr = r = lg(S)-1;
3885 413 : if (!r) return NULL;
3886 364 : Sst = cgetg(r+1, t_VECSMALL); /* Z/n-dual */
3887 1659 : for (i=1; i<=r; i++) Sst[i] = ugcdiu(gel(S,i), n);
3888 364 : if (Sst[1] != n) return NULL;
3889 364 : Lconj = NULL;
3890 364 : nbloc = nbfrob = lg(Lpr)-1;
3891 364 : if (uispow2(n))
3892 : {
3893 266 : long l = lg(pl), k = 0;
3894 266 : GEN real = cgetg(l, t_VECSMALL);
3895 994 : for (i = 1; i < l; i++)
3896 728 : if (pl[i] == -1) real[++k] = i;
3897 266 : if (k)
3898 : {
3899 266 : GEN nf = bnr_get_nf(bnr), I = bid_get_fact(bnr_get_bid(bnr));
3900 266 : GEN v, y, C = idealchineseinit(bnr, I);
3901 266 : long r1 = nf_get_r1(nf), n = nbrows(I);
3902 266 : nbloc += k;
3903 266 : Lconj = cgetg(k+1, t_VEC);
3904 266 : v = const_vecsmall(r1, 1);
3905 266 : y = const_vec(n, gen_1);
3906 728 : for (i = 1; i <= k; i++)
3907 : {
3908 462 : v[real[i]] = -1; gel(Lconj,i) = idealchinese(nf, mkvec2(C,v), y);
3909 462 : v[real[i]] = 1;
3910 : }
3911 : }
3912 : }
3913 364 : globGmod = cgetg(r+1,t_MAT);
3914 364 : G = cgetg(r+1,t_VECSMALL);
3915 1659 : for (i = 1; i <= r; i++)
3916 : {
3917 1295 : G[i] = n / Sst[i]; /* pairing between S and Sst */
3918 1295 : gel(globGmod,i) = cgetg(nbloc+1,t_VECSMALL);
3919 : }
3920 :
3921 : /* compute images of Frobenius elements (and complex conjugation) */
3922 364 : loc = cgetg(nbloc+1,t_VECSMALL);
3923 805 : for (i = 1; i <= nbloc; i++)
3924 : {
3925 : long L;
3926 609 : if (i <= nbfrob)
3927 : {
3928 280 : X = gel(Lpr, i);
3929 280 : L = Ld[i];
3930 : }
3931 : else
3932 : { /* X = 1 (mod f), sigma_i(x) < 0, positive at all other real places */
3933 329 : X = gel(Lconj, i-nbfrob);
3934 329 : L = 2;
3935 : }
3936 609 : X = ZV_to_Flv(isprincipalray(bnr,X), n);
3937 2415 : for (nz=0,j=1; j<=r; j++)
3938 : {
3939 1806 : ulong c = (X[j] * G[j]) % L;
3940 1806 : ucoeff(globGmod,i,j) = c;
3941 1806 : if (c) nz = 1;
3942 : }
3943 609 : if (!nz) return NULL;
3944 441 : loc[i] = L;
3945 : }
3946 :
3947 : /* try some random elements in the dual */
3948 196 : Rglob = cgetg(r+1,t_VECSMALL);
3949 420 : for (t=0; t<NTRY; t++) {
3950 1533 : for (j = 1; j <= r; j++) Rglob[j] = random_Fl(Sst[j]);
3951 413 : Rloc = zm_zc_mul(globGmod,Rglob);
3952 1036 : for (i = 1; i <= nbloc; i++)
3953 847 : if (Rloc[i] % loc[i] == 0) break;
3954 413 : if (i > nbloc) return zv_to_ZV(Rglob);
3955 : }
3956 :
3957 : /* try to realize some random elements of the product of the local duals */
3958 7 : H = ZM_hnfall_i(shallowconcat(zm_to_ZM(globGmod),
3959 : diagonal_shallow(zv_to_ZV(loc))), &U, 2);
3960 : /* H,U nbloc x nbloc */
3961 7 : Rloc = cgetg(nbloc+1,t_COL);
3962 77 : for (t = 0; t < NTRY; t++)
3963 : { /* nonzero random coordinate */ /* TODO add special case ? */
3964 560 : for (i = 1; i <= nbloc; i++) gel(Rloc,i) = stoi(1 + random_Fl(loc[i]-1));
3965 70 : Rglob = hnf_invimage(H, Rloc);
3966 70 : if (Rglob)
3967 : {
3968 0 : Rglob = ZM_ZC_mul(U,Rglob);
3969 0 : return vecslice(Rglob,1,r);
3970 : }
3971 : }
3972 7 : return NULL;
3973 : }
3974 :
3975 : static GEN
3976 413 : bnrgwsearch(GEN bnr, GEN Lpr, GEN Ld, GEN pl)
3977 : {
3978 413 : pari_sp av = avma;
3979 : long n, r;
3980 413 : GEN phi0 = get_phi0(bnr,Lpr,Ld,pl, &r,&n), gn, v, H,U;
3981 413 : if (!phi0) return gc_const(av, gen_0);
3982 189 : gn = stoi(n);
3983 : /* compute kernel of phi0 */
3984 189 : v = ZV_extgcd(vec_append(phi0, gn));
3985 189 : U = vecslice(gel(v,2), 1,r);
3986 189 : H = ZM_hnfmodid(rowslice(U, 1,r), gn);
3987 189 : return gerepileupto(av, H);
3988 : }
3989 :
3990 : GEN
3991 189 : bnfgwgeneric(GEN bnf, GEN Lpr, GEN Ld, GEN pl, long var)
3992 : {
3993 189 : pari_sp av = avma;
3994 189 : const long n = (lg(Ld)==1)? 2: vecsmall_max(Ld);
3995 : forprime_t S;
3996 189 : GEN bnr = NULL, ideal = gen_1, nf, dec, H = gen_0, finf, pol;
3997 : ulong ell, p;
3998 : long deg, i, degell;
3999 189 : (void)uisprimepower(n, &ell);
4000 189 : nf = bnf_get_nf(bnf);
4001 189 : deg = nf_get_degree(nf);
4002 189 : degell = ugcd(deg,ell-1);
4003 189 : finf = cgetg(lg(pl),t_VEC);
4004 497 : for (i=1; i<lg(pl); i++) gel(finf,i) = pl[i]==-1 ? gen_1 : gen_0;
4005 :
4006 189 : u_forprime_init(&S, 2, ULONG_MAX);
4007 819 : while ((p = u_forprime_next(&S))) {
4008 819 : if (Fl_powu(p % ell, degell, ell) != 1) continue; /* ell | p^deg-1 ? */
4009 399 : dec = idealprimedec(nf, utoipos(p));
4010 735 : for (i=1; i<lg(dec); i++) {
4011 525 : GEN pp = gel(dec,i);
4012 525 : if (RgV_isin(Lpr,pp)) continue;
4013 : /* TODO also accept the prime ideals at which there is a condition
4014 : * (use local Artin)? */
4015 469 : if (smodis(idealnorm(nf,pp),ell) != 1) continue; /* ell | N(pp)-1 ? */
4016 413 : ideal = idealmul(bnf,ideal,pp);
4017 : /* TODO: give factorization ? */
4018 413 : bnr = Buchray(bnf, mkvec2(ideal,finf), nf_INIT);
4019 413 : H = bnrgwsearch(bnr,Lpr,Ld,pl);
4020 413 : if (H != gen_0)
4021 : {
4022 189 : pol = rnfkummer(bnr,H,nf_get_prec(nf));
4023 189 : setvarn(pol, var);
4024 189 : return gerepileupto(av,pol);
4025 : }
4026 : }
4027 : }
4028 : pari_err_BUG("bnfgwgeneric (no suitable p)"); /*LCOV_EXCL_LINE*/
4029 : return NULL;/*LCOV_EXCL_LINE*/
4030 : }
4031 :
4032 : /* pr.p != ell */
4033 : static GEN
4034 1575 : localextdeg(GEN nf, GEN pr, long d, ulong ell, long n)
4035 : {
4036 : GEN modpr, T, p, gen, k;
4037 1575 : if (d == 1) return gen_1;
4038 1561 : k = powuu(ell, Z_lval(subiu(pr_norm(pr),1), ell));
4039 1561 : k = divis(k, n / d);
4040 1561 : modpr = nf_to_Fq_init(nf, &pr, &T, &p);
4041 1561 : (void)Fq_sqrtn(gen_1, k, T, p, &gen);
4042 1561 : return Fq_to_nf(gen, modpr);
4043 : }
4044 : /* pr.p = ell */
4045 : static GEN
4046 161 : localextdegell(GEN nf, GEN pr, GEN E, long d, long n)
4047 : {
4048 : GEN x;
4049 161 : if (d == 1) return gen_1;
4050 154 : x = nfadd(nf, gen_1, pr_get_gen(pr));
4051 154 : return nfpowmodideal(nf, x, stoi(n / d), idealpow(nf, pr, E));
4052 : }
4053 :
4054 : /* Ld[i] must be nontrivial powers of the same prime ell */
4055 : /* pl : -1 at real places at which the extension must ramify, 0 elsewhere */
4056 : GEN
4057 245 : nfgwkummer(GEN nf, GEN Lpr, GEN Ld, GEN pl, long var)
4058 : {
4059 245 : const long n = (lg(Ld)==1)? 2: vecsmall_max(Ld);
4060 : ulong ell;
4061 245 : long i, l = lg(Lpr), v = uisprimepower(n, &ell);
4062 245 : GEN E = cgetg(l, t_COL), y = cgetg(l, t_VEC), fa;
4063 :
4064 1981 : for (i = 1; i < l; i++)
4065 : {
4066 1736 : GEN pr = gel(Lpr,i), p = pr_get_p(pr);
4067 1736 : if (!absequalui(ell, p))
4068 : {
4069 1575 : gel(E, i) = gen_1;
4070 1575 : gel(y, i) = localextdeg(nf, pr, Ld[i], ell, n);
4071 : }
4072 : else
4073 : {
4074 161 : long e = pr_get_e(pr);
4075 161 : gel(E, i) = addui(1 + v*e, divsi(e, subiu(p,1)));
4076 161 : gel(y, i) = localextdegell(nf, pr, gel(E,i), Ld[i], n);
4077 : }
4078 : }
4079 245 : y = factoredextchinese(nf, mkmat2(shallowtrans(Lpr),E), y, pl, &fa);
4080 245 : return gsub(gpowgs(pol_x(var),n), basistoalg(nf, y));
4081 : }
4082 :
4083 : static GEN
4084 973 : get_vecsmall(GEN v)
4085 : {
4086 973 : switch(typ(v))
4087 : {
4088 847 : case t_VECSMALL: return v;
4089 119 : case t_VEC: if (RgV_is_ZV(v)) return ZV_to_zv(v);
4090 : }
4091 7 : pari_err_TYPE("nfgrunwaldwang",v);
4092 : return NULL;/*LCOV_EXCL_LINE*/
4093 : }
4094 : GEN
4095 532 : nfgrunwaldwang(GEN nf0, GEN Lpr, GEN Ld, GEN pl, long var)
4096 : {
4097 : ulong n, ell, ell2;
4098 532 : pari_sp av = avma;
4099 : GEN nf, bnf;
4100 : long t, w, i, vnf;
4101 :
4102 532 : if (var < 0) var = 0;
4103 532 : nf = get_nf(nf0,&t);
4104 532 : if (!nf) pari_err_TYPE("nfgrunwaldwang",nf0);
4105 532 : vnf = nf_get_varn(nf);
4106 532 : if (varncmp(var, vnf) >= 0)
4107 7 : pari_err_PRIORITY("nfgrunwaldwang", pol_x(var), ">=", vnf);
4108 525 : if (typ(Lpr) != t_VEC) pari_err_TYPE("nfgrunwaldwang",Lpr);
4109 511 : if (lg(Lpr) != lg(Ld)) pari_err_DIM("nfgrunwaldwang [#Lpr != #Ld]");
4110 504 : if (nf_get_degree(nf)==1) Lpr = shallowcopy(Lpr);
4111 2534 : for (i=1; i<lg(Lpr); i++) {
4112 2037 : GEN pr = gel(Lpr,i);
4113 2037 : if (nf_get_degree(nf)==1 && typ(pr)==t_INT)
4114 77 : gel(Lpr,i) = gel(idealprimedec(nf,pr), 1);
4115 1960 : else checkprid(pr);
4116 : }
4117 497 : if (lg(pl)-1 != nf_get_r1(nf))
4118 7 : pari_err_DOMAIN("nfgrunwaldwang [pl should have r1 components]", "#pl",
4119 7 : "!=", stoi(nf_get_r1(nf)), stoi(lg(pl)-1));
4120 :
4121 490 : Ld = get_vecsmall(Ld);
4122 483 : pl = get_vecsmall(pl);
4123 483 : bnf = get_bnf(nf0,&t);
4124 483 : n = (lg(Ld)==1)? 2: vecsmall_max(Ld);
4125 :
4126 483 : if (!uisprimepower(n, &ell))
4127 7 : pari_err_IMPL("nfgrunwaldwang for non prime-power local degrees (a)");
4128 2471 : for (i=1; i<lg(Ld); i++)
4129 2002 : if (Ld[i]!=1 && (!uisprimepower(Ld[i],&ell2) || ell2!=ell))
4130 7 : pari_err_IMPL("nfgrunwaldwang for non prime-power local degrees (b)");
4131 1197 : for (i=1; i<lg(pl); i++)
4132 735 : if (pl[i]==-1 && ell%2)
4133 7 : pari_err_IMPL("nfgrunwaldwang for non prime-power local degrees (c)");
4134 :
4135 462 : w = bnf? bnf_get_tuN(bnf): itos(gel(nfrootsof1(nf),1));
4136 :
4137 : /* TODO choice between kummer and generic ? Let user choose between speed
4138 : * and size */
4139 462 : if (w%n==0 && lg(Ld)>1)
4140 245 : return gerepileupto(av, nfgwkummer(nf,Lpr,Ld,pl,var));
4141 217 : if (ell==n)
4142 : {
4143 189 : if (!bnf) bnf = Buchall(nf, nf_FORCE, 0);
4144 189 : return gerepileupto(av, bnfgwgeneric(bnf,Lpr,Ld,pl,var));
4145 : }
4146 28 : pari_err_IMPL("nfgrunwaldwang for nonprime degree");
4147 : return NULL; /*LCOV_EXCL_LINE*/
4148 : }
4149 :
4150 : /** HASSE INVARIANTS **/
4151 :
4152 : /* TODO long -> ulong + uel */
4153 : static GEN
4154 1274 : hasseconvert(GEN H, long n)
4155 : {
4156 : GEN h, c;
4157 : long i, l;
4158 1274 : switch(typ(H)) {
4159 1169 : case t_VEC:
4160 1169 : l = lg(H); h = cgetg(l,t_VECSMALL);
4161 1169 : if (l == 1) return h;
4162 1043 : c = gel(H,1);
4163 1043 : if (typ(c) == t_VEC && l == 3)
4164 406 : return mkvec2(gel(H,1),hasseconvert(gel(H,2),n));
4165 3136 : for (i=1; i<l; i++)
4166 : {
4167 2527 : c = gel(H,i);
4168 2527 : switch(typ(c)) {
4169 812 : case t_INT: break;
4170 7 : case t_INTMOD:
4171 7 : c = gel(c,2); break;
4172 1687 : case t_FRAC :
4173 1687 : c = gmulgs(c,n);
4174 1687 : if (typ(c) == t_INT) break;
4175 7 : pari_err_DOMAIN("hasseconvert [degree should be a denominator of the invariant]", "denom(h)", "ndiv", stoi(n), Q_denom(gel(H,i)));
4176 21 : default : pari_err_TYPE("Hasse invariant", c);
4177 : }
4178 2499 : h[i] = smodis(c,n);
4179 : }
4180 609 : return h;
4181 98 : case t_VECSMALL: return H;
4182 : }
4183 7 : pari_err_TYPE("Hasse invariant", H);
4184 : return NULL;/*LCOV_EXCL_LINE*/
4185 : }
4186 :
4187 : /* assume f >= 2 */
4188 : static long
4189 455 : cyclicrelfrob0(GEN nf, GEN aut, GEN pr, GEN q, long f, long g)
4190 : {
4191 455 : GEN T, p, a, b, modpr = nf_to_Fq_init(nf,&pr,&T,&p);
4192 : long s;
4193 :
4194 455 : a = pol_x(nf_get_varn(nf));
4195 455 : b = galoisapply(nf, aut, modpr_genFq(modpr));
4196 455 : b = nf_to_Fq(nf, b, modpr);
4197 1365 : for (s = 0; !ZX_equal(a, b); s++) a = Fq_pow(a, q, T, p);
4198 455 : return g * Fl_inv(s, f); /* < n */
4199 : }
4200 :
4201 : static long
4202 2926 : cyclicrelfrob(GEN rnf, GEN auts, GEN pr)
4203 : {
4204 2926 : pari_sp av = avma;
4205 2926 : long f,g,frob, n = rnf_get_degree(rnf);
4206 2926 : GEN P = rnfidealprimedec(rnf, pr);
4207 :
4208 2926 : if (pr_get_e(gel(P,1)) > pr_get_e(pr))
4209 0 : pari_err_DOMAIN("cyclicrelfrob","e(PR/pr)",">",gen_1,pr);
4210 2926 : g = lg(P) - 1;
4211 2926 : f = n / g;
4212 :
4213 2926 : if (f <= 2) frob = g % n;
4214 : else {
4215 455 : GEN nf2, PR = gel(P,1);
4216 455 : GEN autabs = rnfeltreltoabs(rnf,gel(auts,g));
4217 455 : nf2 = obj_check(rnf,rnf_NFABS);
4218 455 : autabs = nfadd(nf2, autabs, gmul(rnf_get_k(rnf), rnf_get_alpha(rnf)));
4219 455 : frob = cyclicrelfrob0(nf2, autabs, PR, pr_norm(pr), f, g);
4220 : }
4221 2926 : return gc_long(av, frob);
4222 : }
4223 :
4224 : static long
4225 903 : localhasse(GEN rnf, GEN cnd, GEN pl, GEN auts, GEN b, long k)
4226 : {
4227 903 : pari_sp av = avma;
4228 : long v, m, h, lfa, frob, n, i;
4229 : GEN previous, y, pr, nf, q, fa;
4230 903 : nf = rnf_get_nf(rnf);
4231 903 : n = rnf_get_degree(rnf);
4232 903 : pr = gcoeff(cnd,k,1);
4233 903 : v = nfval(nf, b, pr);
4234 903 : m = lg(cnd)>1 ? nbrows(cnd) : 0;
4235 :
4236 : /* add the valuation of b to the conductor... */
4237 903 : previous = gcoeff(cnd,k,2);
4238 903 : gcoeff(cnd,k,2) = addis(previous, v);
4239 :
4240 903 : y = const_vec(m, gen_1);
4241 903 : gel(y,k) = b;
4242 : /* find a factored element y congruent to b mod pr^(vpr(b)+vpr(cnd)) and to 1 mod the conductor. */
4243 903 : y = factoredextchinese(nf, cnd, y, pl, &fa);
4244 903 : h = 0;
4245 903 : lfa = nbrows(fa);
4246 : /* sum of all Hasse invariants of (rnf/nf,aut,y) is 0, Hasse invariants at q!=pr are easy, Hasse invariant at pr is the same as for al=(rnf/nf,aut,b). */
4247 1757 : for (i=1; i<=lfa; i++) {
4248 854 : q = gcoeff(fa,i,1);
4249 854 : if (cmp_prime_ideal(pr,q)) {
4250 805 : frob = cyclicrelfrob(rnf, auts, q);
4251 805 : frob = Fl_mul(frob,umodiu(gcoeff(fa,i,2),n),n);
4252 805 : h = Fl_add(h,frob,n);
4253 : }
4254 : }
4255 : /* ...then restore it. */
4256 903 : gcoeff(cnd,k,2) = previous;
4257 903 : return gc_long(av, Fl_neg(h,n));
4258 : }
4259 :
4260 : static GEN
4261 1127 : allauts(GEN rnf, GEN aut)
4262 : {
4263 1127 : long n = rnf_get_degree(rnf), i;
4264 1127 : GEN pol = rnf_get_pol(rnf), vaut;
4265 1127 : if (n==1) n=2;
4266 1127 : vaut = cgetg(n,t_VEC);
4267 1127 : aut = lift_shallow(rnfbasistoalg(rnf,aut));
4268 1127 : if (typ(aut) != t_POL || varn(pol) != varn(aut))
4269 0 : pari_err_TYPE("alg_cyclic", aut);
4270 1127 : gel(vaut,1) = aut;
4271 1519 : for (i=1; i<n-1; i++)
4272 392 : gel(vaut,i+1) = RgX_rem(poleval(gel(vaut,i), aut), pol);
4273 1127 : return vaut;
4274 : }
4275 :
4276 : static GEN
4277 343 : clean_factor(GEN fa)
4278 : {
4279 343 : GEN P2,E2, P = gel(fa,1), E = gel(fa,2);
4280 343 : long l = lg(P), i, j = 1;
4281 343 : P2 = cgetg(l, t_COL);
4282 343 : E2 = cgetg(l, t_COL);
4283 2570 : for (i = 1;i < l; i++)
4284 2227 : if (signe(gel(E,i))) {
4285 610 : gel(P2,j) = gel(P,i);
4286 610 : gel(E2,j) = gel(E,i); j++;
4287 : }
4288 343 : setlg(P2,j);
4289 343 : setlg(E2,j); return mkmat2(P2,E2);
4290 : }
4291 :
4292 : /* shallow concat x[1],...x[nx],y[1], ... y[ny], returning a t_COL. To be
4293 : * used when we do not know whether x,y are t_VEC or t_COL */
4294 : static GEN
4295 686 : colconcat(GEN x, GEN y)
4296 : {
4297 686 : long i, lx = lg(x), ly = lg(y);
4298 686 : GEN z=cgetg(lx+ly-1, t_COL);
4299 4046 : for (i=1; i<lx; i++) z[i] = x[i];
4300 1780 : for (i=1; i<ly; i++) z[lx+i-1]= y[i];
4301 686 : return z;
4302 : }
4303 :
4304 : /* return v(x) at all primes in listpr, replace x by cofactor */
4305 : static GEN
4306 1470 : nfmakecoprime(GEN nf, GEN *px, GEN listpr)
4307 : {
4308 1470 : long j, l = lg(listpr);
4309 1470 : GEN x1, x = *px, L = cgetg(l, t_COL);
4310 :
4311 1470 : if (typ(x) != t_MAT)
4312 : { /* scalar, divide at the end (fast valuation) */
4313 1281 : x1 = NULL;
4314 5636 : for (j=1; j<l; j++)
4315 : {
4316 4355 : GEN pr = gel(listpr,j), e;
4317 4355 : long v = nfval(nf, x, pr);
4318 4355 : e = stoi(v); gel(L,j) = e;
4319 6042 : if (v) x1 = x1? idealmulpowprime(nf, x1, pr, e)
4320 1687 : : idealpow(nf, pr, e);
4321 : }
4322 1281 : if (x1) x = idealdivexact(nf, idealhnf(nf,x), x1);
4323 : }
4324 : else
4325 : { /* HNF, divide as we proceed (reduce size) */
4326 378 : for (j=1; j<l; j++)
4327 : {
4328 189 : GEN pr = gel(listpr,j);
4329 189 : long v = idealval(nf, x, pr);
4330 189 : gel(L,j) = stoi(v);
4331 189 : if (v) x = idealmulpowprime(nf, x, pr, stoi(-v));
4332 : }
4333 : }
4334 1470 : *px = x; return L;
4335 : }
4336 :
4337 : /* Caveat: factorizations are not sorted wrt cmp_prime_ideal: Lpr comes first */
4338 : static GEN
4339 343 : computecnd(GEN rnf, GEN Lpr)
4340 : {
4341 : GEN id, nf, fa, Le, P,E;
4342 343 : long n = rnf_get_degree(rnf);
4343 :
4344 343 : nf = rnf_get_nf(rnf);
4345 343 : id = rnf_get_idealdisc(rnf);
4346 343 : Le = nfmakecoprime(nf, &id, Lpr);
4347 343 : fa = idealfactor(nf, id); /* part of D_{L/K} coprime with Lpr */
4348 343 : P = colconcat(Lpr,gel(fa,1));
4349 343 : E = colconcat(Le, gel(fa,2));
4350 343 : fa = mkmat2(P, gdiventgs(E, eulerphiu(n)));
4351 343 : return mkvec2(fa, clean_factor(fa));
4352 : }
4353 :
4354 : /* h >= 0 */
4355 : static void
4356 63 : nextgen(GEN gene, long h, GEN* gens, GEN* hgens, long* ngens, long* curgcd) {
4357 63 : long nextgcd = ugcd(h,*curgcd);
4358 63 : if (nextgcd == *curgcd) return;
4359 63 : (*ngens)++;
4360 63 : gel(*gens,*ngens) = gene;
4361 63 : gel(*hgens,*ngens) = utoi(h);
4362 63 : *curgcd = nextgcd;
4363 63 : return;
4364 : }
4365 :
4366 : static int
4367 112 : dividesmod(long d, long h, long n) { return !(h%cgcd(d,n)); }
4368 :
4369 : /* ramified prime with nontrivial Hasse invariant */
4370 : static GEN
4371 63 : localcomplete(GEN rnf, GEN pl, GEN cnd, GEN auts, long j, long n, long h, long* v)
4372 : {
4373 : GEN nf, gens, hgens, pr, modpr, T, p, sol, U, b, gene, randg, pu;
4374 : long ngens, i, d, np, d1, d2, hg, dnf, vcnd, curgcd;
4375 63 : nf = rnf_get_nf(rnf);
4376 63 : pr = gcoeff(cnd,j,1);
4377 63 : np = umodiu(pr_norm(pr), n);
4378 63 : dnf = nf_get_degree(nf);
4379 63 : vcnd = itos(gcoeff(cnd,j,2));
4380 63 : ngens = 13+dnf;
4381 63 : gens = zerovec(ngens);
4382 63 : hgens = zerovec(ngens);
4383 63 : *v = 0;
4384 63 : curgcd = 0;
4385 63 : ngens = 0;
4386 :
4387 63 : if (!uisprime(n)) {
4388 0 : gene = pr_get_gen(pr);
4389 0 : hg = localhasse(rnf, cnd, pl, auts, gene, j);
4390 0 : nextgen(gene, hg, &gens, &hgens, &ngens, &curgcd);
4391 : }
4392 :
4393 63 : if (ugcd(np,n) != 1) { /* GCD(Np,n) != 1 */
4394 63 : pu = idealprincipalunits(nf,pr,vcnd);
4395 63 : pu = abgrp_get_gen(pu);
4396 126 : for (i=1; i<lg(pu) && !dividesmod(curgcd,h,n); i++) {
4397 63 : gene = gel(pu,i);
4398 63 : hg = localhasse(rnf, cnd, pl, auts, gene, j);
4399 63 : nextgen(gene, hg, &gens, &hgens, &ngens, &curgcd);
4400 : }
4401 : }
4402 :
4403 63 : d = ugcd(np-1,n);
4404 63 : if (d != 1) { /* GCD(Np-1,n) != 1 */
4405 14 : modpr = nf_to_Fq_init(nf, &pr, &T, &p);
4406 14 : while (!dividesmod(curgcd,h,n)) { /* TODO gener_FpXQ_local */
4407 0 : if (T==NULL) randg = randomi(p);
4408 0 : else randg = random_FpX(degpol(T), varn(T),p);
4409 :
4410 0 : if (!gequal0(randg) && !gequal1(randg)) {
4411 0 : gene = Fq_to_nf(randg, modpr);
4412 0 : hg = localhasse(rnf, cnd, pl, auts, gene, j);
4413 0 : nextgen(gene, hg, &gens, &hgens, &ngens, &curgcd);
4414 : }
4415 : }
4416 : }
4417 :
4418 63 : setlg(gens,ngens+1);
4419 63 : setlg(hgens,ngens+1);
4420 :
4421 63 : sol = ZV_extgcd(hgens);
4422 63 : U = ZV_to_Flv(gmael(sol,2,ngens), n);
4423 63 : d = itou(gel(sol,1));
4424 63 : d1 = ugcd(d, n);
4425 63 : d2 = d / d1;
4426 63 : d = Fl_mul(h / d1, Fl_inv(d2,n), n);
4427 63 : if (d != 1) U = Flv_Fl_mul(U, d, n);
4428 126 : for (i = 1, b = gen_1; i <= ngens; i++)
4429 63 : if (U[i]) b = nfmul(nf, b, nfpow_u(nf, gel(gens,i), U[i]));
4430 63 : *v = U[1]; return b;
4431 : }
4432 :
4433 : static int
4434 905 : testsplits(GEN data, GEN fa)
4435 : {
4436 905 : GEN rnf = gel(data,1), forbid = gel(data,2), P = gel(fa,1), E = gel(fa,2);
4437 905 : long i, n, l = lg(P);
4438 :
4439 1286 : for (i = 1; i < l; i++)
4440 : {
4441 865 : GEN pr = gel(P,i);
4442 865 : if (tablesearch(forbid, pr, &cmp_prime_ideal)) return 0;
4443 : }
4444 421 : n = rnf_get_degree(rnf);
4445 608 : for (i = 1; i < l; i++)
4446 : {
4447 265 : long e = itos(gel(E,i)) % n;
4448 265 : if (e)
4449 : {
4450 251 : GEN L = rnfidealprimedec(rnf, gel(P,i));
4451 251 : long g = lg(L) - 1;
4452 251 : if ((e * g) % n) return 0;
4453 : }
4454 : }
4455 343 : return 1;
4456 : }
4457 :
4458 : /* remove entries with Hasse invariant 0 */
4459 : static GEN
4460 714 : hassereduce(GEN hf)
4461 : {
4462 714 : GEN pr,h, PR = gel(hf,1), H = gel(hf,2);
4463 714 : long i, j, l = lg(PR);
4464 :
4465 714 : pr= cgetg(l, t_VEC);
4466 714 : h = cgetg(l, t_VECSMALL);
4467 4431 : for (i = j = 1; i < l; i++)
4468 3717 : if (H[i]) {
4469 3388 : gel(pr,j) = gel(PR,i);
4470 3388 : h[j] = H[i]; j++;
4471 : }
4472 714 : setlg(pr,j);
4473 714 : setlg(h,j); return mkvec2(pr,h);
4474 : }
4475 :
4476 : /* rnf complete */
4477 : static GEN
4478 343 : alg_complete0(GEN rnf, GEN aut, GEN hf, GEN hi, long flag)
4479 : {
4480 343 : pari_sp av = avma;
4481 : GEN nf, pl, pl2, cnd, prcnd, cnds, y, Lpr, auts, b, fa, data, hfe;
4482 : GEN forbid, al, ind;
4483 : long D, n, d, i, j, l;
4484 343 : nf = rnf_get_nf(rnf);
4485 343 : n = rnf_get_degree(rnf);
4486 343 : d = nf_get_degree(nf);
4487 343 : D = d*n*n;
4488 343 : checkhasse(nf,hf,hi,n);
4489 343 : hf = hassereduce(hf);
4490 343 : Lpr = gel(hf,1);
4491 343 : hfe = gel(hf,2);
4492 :
4493 343 : auts = allauts(rnf,aut);
4494 :
4495 343 : pl = leafcopy(hi); /* conditions on the final b */
4496 343 : pl2 = leafcopy(hi); /* conditions for computing local Hasse invariants */
4497 343 : l = lg(pl); ind = cgetg(l, t_VECSMALL);
4498 840 : for (i = j = 1; i < l; i++)
4499 497 : if (hi[i]) { pl[i] = -1; pl2[i] = 1; } else ind[j++] = i;
4500 343 : setlg(ind, j);
4501 343 : y = nfpolsturm(nf, rnf_get_pol(rnf), ind);
4502 630 : for (i = 1; i < j; i++)
4503 287 : if (!signe(gel(y,i))) { pl[ind[i]] = 1; pl2[ind[i]] = 1; }
4504 :
4505 343 : cnds = computecnd(rnf,Lpr);
4506 343 : prcnd = gel(cnds,1);
4507 343 : cnd = gel(cnds,2);
4508 343 : y = cgetg(lgcols(prcnd),t_VEC);
4509 343 : forbid = vectrunc_init(lg(Lpr));
4510 2023 : for (i=j=1; i<lg(Lpr); i++)
4511 : {
4512 1680 : GEN pr = gcoeff(prcnd,i,1), yi;
4513 1680 : long v, e = itou( gcoeff(prcnd,i,2) );
4514 1680 : if (!e) {
4515 1617 : long frob = cyclicrelfrob(rnf,auts,pr), f1 = ugcd(frob,n);
4516 1617 : vectrunc_append(forbid, pr);
4517 1617 : yi = gen_0;
4518 1617 : v = ((hfe[i]/f1) * Fl_inv(frob/f1,n)) % n;
4519 : }
4520 : else
4521 63 : yi = localcomplete(rnf, pl2, cnd, auts, j++, n, hfe[i], &v);
4522 1680 : gel(y,i) = yi;
4523 1680 : gcoeff(prcnd,i,2) = stoi(e + v);
4524 : }
4525 890 : for (; i<lgcols(prcnd); i++) gel(y,i) = gen_1;
4526 343 : gen_sort_inplace(forbid, (void*)&cmp_prime_ideal, &cmp_nodata, NULL);
4527 343 : data = mkvec2(rnf,forbid);
4528 343 : b = factoredextchinesetest(nf,prcnd,y,pl,&fa,data,testsplits);
4529 :
4530 343 : al = cgetg(12, t_VEC);
4531 343 : gel(al,10)= gen_0; /* must be set first */
4532 343 : gel(al,1) = rnf;
4533 343 : gel(al,2) = auts;
4534 343 : gel(al,3) = basistoalg(nf,b);
4535 343 : gel(al,4) = hi;
4536 : /* add primes | disc or b with trivial Hasse invariant to hf */
4537 343 : Lpr = gel(prcnd,1); y = b;
4538 343 : (void)nfmakecoprime(nf, &y, Lpr);
4539 343 : Lpr = shallowconcat(Lpr, gel(idealfactor(nf,y), 1));
4540 343 : settyp(Lpr,t_VEC);
4541 343 : hf = mkvec2(Lpr, shallowconcat(hfe, const_vecsmall(lg(Lpr)-lg(hfe), 0)));
4542 343 : gel(al,5) = hf;
4543 343 : gel(al,6) = mkvec(gen_0);
4544 343 : gel(al,7) = matid(D);
4545 343 : gel(al,8) = matid(D); /* TODO modify 7, 8 et 9 once LLL added */
4546 343 : gel(al,9) = algnatmultable(al,D);
4547 343 : gel(al,11)= algtracebasis(al);
4548 343 : if (flag & al_MAXORD) al = alg_maximal_primes(al, prV_primes(Lpr));
4549 343 : return gerepilecopy(av, al);
4550 : }
4551 :
4552 : GEN
4553 0 : alg_complete(GEN rnf, GEN aut, GEN hf, GEN hi, long flag)
4554 : {
4555 0 : long n = rnf_get_degree(rnf);
4556 0 : rnfcomplete(rnf);
4557 0 : return alg_complete0(rnf, aut, hasseconvert(hf,n), hasseconvert(hi,n), flag);
4558 : }
4559 :
4560 : void
4561 1869 : checkhasse(GEN nf, GEN hf, GEN hi, long n)
4562 : {
4563 : GEN Lpr, Lh;
4564 : long i, sum;
4565 1869 : if (typ(hf) != t_VEC || lg(hf) != 3) pari_err_TYPE("checkhasse [hf]", hf);
4566 1862 : Lpr = gel(hf,1);
4567 1862 : Lh = gel(hf,2);
4568 1862 : if (typ(Lpr) != t_VEC) pari_err_TYPE("checkhasse [Lpr]", Lpr);
4569 1862 : if (typ(Lh) != t_VECSMALL) pari_err_TYPE("checkhasse [Lh]", Lh);
4570 1862 : if (typ(hi) != t_VECSMALL) pari_err_TYPE("checkhasse [hi]", hi);
4571 1862 : if ((nf && lg(hi) != nf_get_r1(nf)+1))
4572 7 : pari_err_DOMAIN("checkhasse [hi should have r1 components]","#hi","!=",stoi(nf_get_r1(nf)),stoi(lg(hi)-1));
4573 1855 : if (lg(Lpr) != lg(Lh))
4574 7 : pari_err_DIM("checkhasse [Lpr and Lh should have same length]");
4575 8610 : for (i=1; i<lg(Lpr); i++) checkprid(gel(Lpr,i));
4576 1848 : if (lg(gen_sort_uniq(Lpr, (void*)cmp_prime_ideal, cmp_nodata)) < lg(Lpr))
4577 7 : pari_err(e_MISC, "error in checkhasse [duplicate prime ideal]");
4578 1841 : sum = 0;
4579 8589 : for (i=1; i<lg(Lh); i++) sum = (sum+Lh[i])%n;
4580 4249 : for (i=1; i<lg(hi); i++) {
4581 2422 : if (hi[i] && 2*hi[i] != n) pari_err_DOMAIN("checkhasse", "Hasse invariant at real place [must be 0 or 1/2]", "!=", n%2? gen_0 : stoi(n/2), stoi(hi[i]));
4582 2408 : sum = (sum+hi[i])%n;
4583 : }
4584 1827 : if (sum<0) sum = n+sum;
4585 1827 : if (sum != 0)
4586 7 : pari_err_DOMAIN("checkhasse","sum(Hasse invariants)","!=",gen_0,Lh);
4587 1820 : }
4588 :
4589 : static GEN
4590 441 : hassecoprime(GEN hf, GEN hi, long n)
4591 : {
4592 441 : pari_sp av = avma;
4593 : long l, i, j, lk, inv;
4594 : GEN fa, P,E, res, hil, hfl;
4595 441 : hi = hasseconvert(hi, n);
4596 427 : hf = hasseconvert(hf, n);
4597 406 : checkhasse(NULL,hf,hi,n);
4598 364 : fa = factoru(n);
4599 364 : P = gel(fa,1); l = lg(P);
4600 364 : E = gel(fa,2);
4601 364 : res = cgetg(l,t_VEC);
4602 735 : for (i=1; i<l; i++) {
4603 371 : lk = upowuu(P[i],E[i]);
4604 371 : inv = Fl_invsafe((n/lk)%lk, lk);
4605 371 : hil = gcopy(hi);
4606 371 : hfl = gcopy(hf);
4607 :
4608 371 : if (P[i] == 2)
4609 749 : for (j=1; j<lg(hil); j++) hil[j] = hi[j]==0 ? 0 : lk/2;
4610 : else
4611 154 : for (j=1; j<lg(hil); j++) hil[j] = 0;
4612 2408 : for (j=1; j<lgcols(hfl); j++) gel(hfl,2)[j] = (gel(hf,2)[j]*inv)%lk;
4613 371 : hfl = hassereduce(hfl);
4614 371 : gel(res,i) = mkvec3(hfl,hil,utoi(lk));
4615 : }
4616 :
4617 364 : return gerepilecopy(av, res);
4618 : }
4619 :
4620 : /* no garbage collection */
4621 : static GEN
4622 112 : genefrob(GEN nf, GEN gal, GEN r)
4623 : {
4624 : long i;
4625 112 : GEN g = identity_perm(nf_get_degree(nf)), fa = Z_factor(r), p, pr, frob;
4626 168 : for (i=1; i<lgcols(fa); i++) {
4627 56 : p = gcoeff(fa,i,1);
4628 56 : pr = idealprimedec(nf, p);
4629 56 : pr = gel(pr,1);
4630 56 : frob = idealfrobenius(nf, gal, pr);
4631 56 : g = perm_mul(g, perm_pow(frob, gcoeff(fa,i,2)));
4632 : }
4633 112 : return g;
4634 : }
4635 :
4636 : static GEN
4637 343 : rnfcycaut(GEN rnf)
4638 : {
4639 343 : GEN nf2 = obj_check(rnf, rnf_NFABS);
4640 : GEN L, alpha, pol, salpha, s, sj, polabs, k, X, pol0, nf;
4641 : long i, d, j;
4642 343 : d = rnf_get_degree(rnf);
4643 343 : L = galoisconj(nf2,NULL);
4644 343 : alpha = lift_shallow(rnf_get_alpha(rnf));
4645 343 : pol = rnf_get_pol(rnf);
4646 343 : k = rnf_get_k(rnf);
4647 343 : polabs = rnf_get_polabs(rnf);
4648 343 : nf = rnf_get_nf(rnf);
4649 343 : pol0 = nf_get_pol(nf);
4650 343 : X = RgX_rem(pol_x(varn(pol0)), pol0);
4651 :
4652 : /* TODO check mod prime of degree 1 */
4653 505 : for (i=1; i<lg(L); i++) {
4654 505 : s = gel(L,i);
4655 505 : salpha = RgX_RgXQ_eval(alpha,s,polabs);
4656 505 : if (!gequal(alpha,salpha)) continue;
4657 :
4658 448 : s = lift_shallow(rnfeltabstorel(rnf,s));
4659 448 : sj = s = gsub(s, gmul(k,X));
4660 896 : for (j=1; !gequal0(gsub(sj,pol_x(varn(s)))); j++)
4661 448 : sj = RgX_RgXQ_eval(sj,s,pol);
4662 448 : if (j<d) continue;
4663 343 : return s;
4664 : }
4665 : return NULL; /*LCOV_EXCL_LINE*/
4666 : }
4667 :
4668 : /* returns the smallest prime not in P */
4669 : static GEN
4670 84 : extraprime(GEN P)
4671 : {
4672 : forprime_t T;
4673 : GEN p;
4674 84 : forprime_init(&T, gen_2, NULL);
4675 98 : while ((p = forprime_next(&T))) if (!ZV_search(P, p)) break;
4676 84 : return p;
4677 : }
4678 :
4679 : /* true nf */
4680 : GEN
4681 455 : alg_hasse(GEN nf, long n, GEN hf, GEN hi, long var, long flag)
4682 : {
4683 455 : pari_sp av = avma;
4684 455 : GEN primary, al = gen_0, al2, rnf, hil, hfl, Ld, pl, pol, Lpr, aut, Lpr2, Ld2;
4685 : long i, lk, j, maxdeg;
4686 455 : dbg_printf(1)("alg_hasse\n");
4687 455 : if (n<=1) pari_err_DOMAIN("alg_hasse", "degree", "<=", gen_1, stoi(n));
4688 441 : primary = hassecoprime(hf, hi, n);
4689 714 : for (i=1; i<lg(primary); i++) {
4690 371 : lk = itos(gmael(primary,i,3));
4691 371 : hfl = gmael(primary,i,1);
4692 371 : hil = gmael(primary,i,2);
4693 371 : checkhasse(nf, hfl, hil, lk);
4694 364 : dbg_printf(1)("alg_hasse: i=%d hf=%Ps hi=%Ps lk=%d\n", i, hfl, hil, lk);
4695 :
4696 364 : if (lg(gel(hfl,1))>1 || lk%2==0) {
4697 357 : maxdeg = 1;
4698 357 : Lpr = gel(hfl,1);
4699 357 : Ld = gcopy(gel(hfl,2));
4700 2051 : for (j=1; j<lg(Ld); j++)
4701 : {
4702 1694 : Ld[j] = lk/ugcd(lk,Ld[j]);
4703 1694 : maxdeg = maxss(Ld[j],maxdeg);
4704 : }
4705 357 : pl = leafcopy(hil);
4706 868 : for (j=1; j<lg(pl); j++) if(pl[j])
4707 : {
4708 210 : pl[j] = -1;
4709 210 : maxdeg = maxss(maxdeg,2);
4710 : }
4711 :
4712 357 : Lpr2 = Lpr;
4713 357 : Ld2 = Ld;
4714 357 : if (maxdeg<lk)
4715 : {
4716 154 : if (maxdeg==1 && lk==2 && lg(pl)>1) pl[1] = -1;
4717 : else
4718 : {
4719 84 : GEN p = extraprime(prV_primes(Lpr));
4720 84 : Lpr2 = vec_append(Lpr2, idealprimedec_galois(nf, p));
4721 84 : Ld2 = vecsmall_append(Ld2, lk);
4722 : }
4723 : }
4724 :
4725 357 : dbg_printf(2)("alg_hasse: calling nfgrunwaldwang Lpr=%Ps Pd=%Ps pl=%Ps\n",
4726 : Lpr, Ld, pl);
4727 357 : pol = nfgrunwaldwang(nf, Lpr2, Ld2, pl, var);
4728 343 : dbg_printf(2)("alg_hasse: calling rnfinit(%Ps)\n", pol);
4729 343 : rnf = rnfinit0(nf,pol,1);
4730 343 : dbg_printf(2)("alg_hasse: computing automorphism\n");
4731 343 : aut = rnfcycaut(rnf);
4732 343 : dbg_printf(2)("alg_hasse: calling alg_complete\n");
4733 343 : al2 = alg_complete0(rnf, aut, hfl, hil, flag);
4734 : }
4735 7 : else al2 = alg_matrix(nf, lk, var, flag);
4736 :
4737 350 : if (i==1) al = al2;
4738 7 : else al = algtensor(al,al2,flag);
4739 : }
4740 343 : return gerepilecopy(av,al);
4741 : }
4742 :
4743 : /** CYCLIC ALGEBRA WITH GIVEN HASSE INVARIANTS **/
4744 :
4745 : /* no garbage collection */
4746 : static GEN
4747 112 : subcycloindep(GEN nf, long n, long v, GEN *pr)
4748 : {
4749 : pari_sp av;
4750 : forprime_t S;
4751 : ulong p;
4752 112 : u_forprime_arith_init(&S, 1, ULONG_MAX, 1, n);
4753 112 : av = avma;
4754 119 : while ((p = u_forprime_next(&S)))
4755 : {
4756 119 : ulong r = pgener_Fl(p);
4757 119 : GEN pol = galoissubcyclo(utoipos(p), utoipos(Fl_powu(r,n,p)), 0, v);
4758 119 : GEN fa = nffactor(nf, pol);
4759 119 : if (lgcols(fa) == 2) { *pr = utoipos(r); return pol; }
4760 7 : set_avma(av);
4761 : }
4762 : pari_err_BUG("subcycloindep (no suitable prime = 1(mod n))"); /*LCOV_EXCL_LINE*/
4763 : *pr = NULL; return NULL; /*LCOV_EXCL_LINE*/
4764 : }
4765 :
4766 : GEN
4767 119 : alg_matrix(GEN nf, long n, long v, long flag)
4768 : {
4769 119 : pari_sp av = avma;
4770 : GEN pol, gal, rnf, cyclo, g, r, aut;
4771 119 : dbg_printf(1)("alg_matrix\n");
4772 119 : if (n<=0) pari_err_DOMAIN("alg_matrix", "n", "<=", gen_0, stoi(n));
4773 112 : pol = subcycloindep(nf, n, v, &r);
4774 112 : rnf = rnfinit(nf, pol);
4775 112 : cyclo = nfinit(pol, nf_get_prec(nf));
4776 112 : gal = galoisinit(cyclo, NULL);
4777 112 : g = genefrob(cyclo,gal,r);
4778 112 : aut = galoispermtopol(gal,g);
4779 112 : return gerepileupto(av, alg_cyclic(rnf, aut, gen_1, flag));
4780 : }
4781 :
4782 : static GEN
4783 21 : alg_hilbert_asquare(GEN nf, GEN a, GEN sa, GEN b, long v, long flag)
4784 : {
4785 : GEN mt, al, ord, z1, z2, den;
4786 21 : long d = nf_get_degree(nf), i;
4787 21 : mt = mkvec4(
4788 : matid(4),
4789 : mkmat4(
4790 : mkcol4(gen_0,gen_1,gen_0,gen_0),
4791 : mkcol4(a,gen_0,gen_0,gen_0),
4792 : mkcol4(gen_0,gen_0,gen_0,gen_1),
4793 : mkcol4(gen_0,gen_0,a,gen_0)
4794 : ),
4795 : mkmat4(
4796 : mkcol4(gen_0,gen_0,gen_1,gen_0),
4797 : mkcol4(gen_0,gen_0,gen_0,gen_m1),
4798 : mkcol4(b,gen_0,gen_0,gen_0),
4799 : mkcol4(gen_0,gneg(b),gen_0,gen_0)
4800 : ),
4801 : mkmat4(
4802 : mkcol4(gen_0,gen_0,gen_0,gen_1),
4803 : mkcol4(gen_0,gen_0,gneg(a),gen_0),
4804 : mkcol4(gen_0,b,gen_0,gen_0),
4805 : mkcol4(gneg(gmul(a,b)),gen_0,gen_0,gen_0)
4806 : )
4807 : );
4808 21 : al = alg_csa_table(nf, mt, v, al_NOSPLITTING);
4809 :
4810 : /* set trivial Hasse invariants */
4811 21 : gel(al,4) = zero_zv(nf_get_r1(nf));
4812 21 : gel(al,5) = mkvec2(cgetg(1,t_VEC),cgetg(1,t_VECSMALL));
4813 :
4814 : /* remember special case */
4815 21 : sa = basistoalg(nf,sa);
4816 21 : gmael(al,6,1) = mkvec3(a,b,sa);
4817 :
4818 21 : if (flag & al_MAXORD)
4819 : {
4820 21 : ord = cgetg(4,t_VEC);
4821 :
4822 21 : z1 = mkfracss(1,2); /* 1/2 */
4823 21 : z2 = gmul2n(ginv(sa),-1); /* 1/(2*sa) */
4824 : /* (1+i/sa)/2 */
4825 21 : gel(ord,1) = algleftmultable(al,mkcol4(z1,z2,gen_0,gen_0));
4826 : /* (j-ij/sa)/2 */
4827 21 : gel(ord,2) = algleftmultable(al,mkcol4(gen_0,gen_0,z1,gneg(z2)));
4828 21 : z1 = basistoalg(nf,nfdiv(nf,z1,b));
4829 21 : z2 = basistoalg(nf,nfdiv(nf,z2,b));
4830 : /* (j/b + ij/(b*sa))/2 */
4831 21 : gel(ord,3) = algleftmultable(al,mkcol4(gen_0,gen_0,z1,z2));
4832 :
4833 : /* multiply by nf.zk == d first vectors of natural basis */
4834 84 : for (i=1; i<=3; i++) gel(ord,i) = vecslice(gel(ord,i),1,d);
4835 :
4836 21 : ord = shallowmatconcat(ord);
4837 21 : ord = Q_remove_denom(ord, &den);
4838 21 : ord = hnfmodid(ord, den);
4839 21 : ord = ZM_Z_div(ord, den);
4840 21 : al = alg_change_overorder_shallow(al, ord);
4841 : }
4842 : /* could take splitting field == nf */
4843 21 : computesplitting(al, 2, v, flag);
4844 21 : return al;
4845 : }
4846 :
4847 : GEN
4848 539 : alg_hilbert(GEN nf, GEN a, GEN b, long v, long flag)
4849 : {
4850 539 : pari_sp av = avma;
4851 : GEN rnf, aut, rnfpol, sa;
4852 539 : dbg_printf(1)("alg_hilbert\n");
4853 539 : if (gequal0(a)) pari_err_DOMAIN("alg_hilbert", "a", "=", gen_0, a);
4854 532 : if (gequal0(b)) pari_err_DOMAIN("alg_hilbert", "b", "=", gen_0, b);
4855 525 : if (!isint1(Q_denom(algtobasis(nf,a))))
4856 7 : pari_err_DOMAIN("alg_hilbert", "denominator(a)", "!=", gen_1,a);
4857 518 : if (!isint1(Q_denom(algtobasis(nf,b))))
4858 7 : pari_err_DOMAIN("alg_hilbert", "denominator(b)", "!=", gen_1,b);
4859 511 : if (nfissquare(nf,a,&sa))
4860 21 : return gerepilecopy(av, alg_hilbert_asquare(nf,a,sa,b,v,flag));
4861 :
4862 490 : if (v < 0) v = 0;
4863 490 : rnfpol = deg2pol_shallow(gen_1, gen_0, gneg(a), v);
4864 490 : if (!(flag & al_FACTOR)) rnfpol = mkvec2(rnfpol, stoi(1<<20));
4865 490 : rnf = rnfinit(nf, rnfpol);
4866 490 : aut = gneg(pol_x(v));
4867 490 : return gerepileupto(av, alg_cyclic(rnf, aut, b, flag));
4868 : }
4869 :
4870 : /* shortcut for alg_hasse in quaternion case */
4871 : static GEN
4872 35 : alg_quatramif(GEN nf, GEN Lpr, GEN hi, long var, long flag)
4873 : {
4874 35 : pari_sp av = avma;
4875 35 : GEN hf = mkvec2(Lpr, const_vecsmall(lg(Lpr)-1,1));
4876 35 : return gerepileupto(av, alg_hasse(nf, 2, hf, hi, var, flag));
4877 : }
4878 :
4879 : /* return a structure representing the algebra of real numbers */
4880 : static GEN
4881 21 : mk_R()
4882 : {
4883 21 : pari_sp av = avma;
4884 : GEN al;
4885 21 : al = zerovec(11);
4886 21 : gel(al,1) = stor(1, LOWDEFAULTPREC);
4887 21 : gel(al,2) = mkvec(gel(al,1));
4888 21 : gel(al,3) = gen_1;
4889 21 : gel(al,4) = mkvecsmall(0);
4890 21 : gel(al,6) = mkvec(gen_0);
4891 21 : gel(al,8) = gel(al,7) = matid(1);
4892 21 : gel(al,9) = mkvec(matid(1));
4893 21 : return gerepilecopy(av,al);
4894 : }
4895 : /* return a structure representing the algebra of complex numbers */
4896 : static GEN
4897 14 : mk_C()
4898 : {
4899 14 : pari_sp av = avma;
4900 : GEN al, I;
4901 14 : al = zerovec(11);
4902 14 : I = gen_I();
4903 14 : gel(al,1) = I;
4904 14 : gel(al,2) = mkvec(I);
4905 14 : gel(al,3) = gen_1;
4906 14 : gel(al,4) = cgetg(1,t_VECSMALL);
4907 14 : gel(al,6) = mkvec(gen_0);
4908 14 : gel(al,8) = gel(al,7) = matid(2);
4909 14 : gel(al,9) = mkvec2(
4910 : matid(2),
4911 : mkmat22(gen_0,gen_m1,gen_1,gen_0)
4912 : );
4913 14 : return gerepilecopy(av,al);
4914 : }
4915 : /* return a structure representing the Hamilton quaternion algebra */
4916 : static GEN
4917 35 : mk_H()
4918 : {
4919 35 : pari_sp av = avma;
4920 : GEN al, I;
4921 35 : al = zerovec(11);
4922 35 : I = gen_I();
4923 35 : gel(al,1) = I;
4924 35 : gel(al,2) = mkvec(gconj(I));
4925 35 : gel(al,3) = gen_m1;
4926 35 : gel(al,4) = mkvecsmall(1);
4927 35 : gel(al,6) = mkvec(gen_0);
4928 35 : gel(al,8) = gel(al,7) = matid(4);
4929 35 : gel(al,9) = mkvec4(
4930 : matid(4),
4931 : H_tomatrix(I,1),
4932 : H_tomatrix(mkcol4(gen_0,gen_0,gen_1,gen_0),1),
4933 : H_tomatrix(mkcol4(gen_0,gen_0,gen_0,gen_1),1)
4934 : );
4935 35 : return gerepilecopy(av,al);
4936 : }
4937 :
4938 : GEN
4939 1652 : alginit(GEN A, GEN B, long v, long flag)
4940 : {
4941 : long w;
4942 1652 : if (typ(A) == t_COMPLEX) return mk_C();
4943 1638 : if (typ(A) == t_REAL)
4944 : {
4945 63 : if (is_scalar_t(typ(B)) && gequal0(B)) return mk_R();
4946 42 : if (typ(B) == t_FRAC && gequal(B, mkfrac(gen_1,gen_2))) return mk_H();
4947 7 : pari_err_DOMAIN("alginit", "real Hasse invariant [must be 0 or 1/2]", "", NULL, B);
4948 : }
4949 1575 : switch(nftyp(A))
4950 : {
4951 1365 : case typ_NF:
4952 1365 : if (v<0) v=0;
4953 1365 : w = gvar(nf_get_pol(A));
4954 1365 : if (varncmp(v,w)>=0) pari_err_PRIORITY("alginit", pol_x(v), ">=", w);
4955 1351 : switch(typ(B))
4956 : {
4957 : long nB;
4958 112 : case t_INT: return alg_matrix(A, itos(B), v, flag);
4959 1232 : case t_VEC:
4960 1232 : nB = lg(B)-1;
4961 1232 : if (nB && typ(gel(B,1)) == t_MAT) return alg_csa_table(A,B,v,flag);
4962 : switch(nB)
4963 : {
4964 574 : case 2:
4965 574 : if (typ(gel(B,1)) == t_VEC)
4966 35 : return alg_quatramif(A, gel(B,1), gel(B,2), v, flag);
4967 539 : return alg_hilbert(A, gel(B,1), gel(B,2), v, flag);
4968 427 : case 3:
4969 427 : if (typ(gel(B,1))!=t_INT)
4970 7 : pari_err_TYPE("alginit [degree should be an integer]", gel(B,1));
4971 420 : return alg_hasse(A, itos(gel(B,1)), gel(B,2), gel(B,3), v,
4972 : flag);
4973 : }
4974 : }
4975 14 : pari_err_TYPE("alginit", B); break;
4976 :
4977 196 : case typ_RNF:
4978 196 : if (typ(B) != t_VEC || lg(B) != 3) pari_err_TYPE("alginit", B);
4979 182 : return alg_cyclic(A, gel(B,1), gel(B,2), flag);
4980 : }
4981 14 : pari_err_TYPE("alginit", A);
4982 : return NULL;/*LCOV_EXCL_LINE*/
4983 : }
4984 :
4985 : /* assumes al CSA or CYCLIC */
4986 : static GEN
4987 1344 : algnatmultable(GEN al, long D)
4988 : {
4989 : GEN res, x;
4990 : long i;
4991 1344 : res = cgetg(D+1,t_VEC);
4992 14693 : for (i=1; i<=D; i++) {
4993 13349 : x = algnattoalg(al,col_ei(D,i));
4994 13349 : gel(res,i) = algZmultable(al,x);
4995 : }
4996 1344 : return res;
4997 : }
4998 :
4999 140 : static int normfact_is_partial(GEN nf, GEN x, GEN fax)
5000 : {
5001 : long i;
5002 : GEN nfx;
5003 140 : nfx = RgM_shallowcopy(fax);
5004 385 : for (i=1; i<lg(gel(nfx,1)); i++)
5005 245 : gcoeff(nfx,i,1) = idealnorm(nf, gcoeff(nfx,i,1));
5006 140 : nfx = factorback(nfx);
5007 140 : return !gequal(idealnorm(nf, x), nfx);
5008 : }
5009 : /* no garbage collection */
5010 : static void
5011 784 : algcomputehasse(GEN al, long flag)
5012 : {
5013 : int partialfact;
5014 : long r1, k, n, m, m1, m2, m3, i, m23, m123;
5015 : GEN rnf, nf, b, fab, disc2, cnd, fad, auts, pr, pl, perm, y, hi, PH, H, L;
5016 :
5017 784 : rnf = alg_get_splittingfield(al);
5018 784 : n = rnf_get_degree(rnf);
5019 784 : nf = rnf_get_nf(rnf);
5020 784 : b = alg_get_b(al);
5021 784 : r1 = nf_get_r1(nf);
5022 784 : auts = alg_get_auts(al);
5023 784 : (void)alg_get_abssplitting(al);
5024 :
5025 784 : y = nfpolsturm(nf, rnf_get_pol(rnf), NULL);
5026 784 : pl = cgetg(r1+1, t_VECSMALL);
5027 : /* real places where rnf/nf ramifies */
5028 1687 : for (k = 1; k <= r1; k++) pl[k] = !signe(gel(y,k));
5029 :
5030 : /* infinite Hasse invariants */
5031 784 : if (odd(n)) hi = const_vecsmall(r1, 0);
5032 : else
5033 : {
5034 665 : GEN s = nfsign(nf, b);
5035 665 : hi = cgetg(r1+1, t_VECSMALL);
5036 1477 : for (k = 1; k<=r1; k++) hi[k] = (s[k] && pl[k]) ? (n/2) : 0;
5037 : }
5038 784 : gel(al,4) = hi;
5039 :
5040 784 : partialfact = 0;
5041 784 : if (flag & al_FACTOR)
5042 700 : fab = idealfactor(nf, b);
5043 : else {
5044 84 : fab = idealfactor_limit(nf, b, 1<<20);
5045 : /* does not report whether factorisation was partial; check it */
5046 84 : partialfact = normfact_is_partial(nf, b, fab);
5047 : }
5048 :
5049 784 : disc2 = rnf_get_idealdisc(rnf);
5050 784 : L = nfmakecoprime(nf, &disc2, gel(fab,1));
5051 784 : m = lg(L)-1;
5052 : /* m1 = #{pr|b: pr \nmid disc}, m3 = #{pr|b: pr | disc} */
5053 784 : perm = cgetg(m+1, t_VECSMALL);
5054 1421 : for (i=1, m1=m, k=1; k<=m; k++)
5055 637 : if (signe(gel(L,k))) perm[m1--] = k; else perm[i++] = k;
5056 784 : m3 = m - m1;
5057 :
5058 : /* disc2 : factor of disc coprime to b */
5059 784 : if (flag & al_FACTOR)
5060 700 : fad = idealfactor(nf, disc2);
5061 : else {
5062 84 : fad = idealfactor_limit(nf, disc2, 1<<20);
5063 84 : partialfact = partialfact || normfact_is_partial(nf, disc2, fad);
5064 : }
5065 :
5066 : /* if factorisation is partial, do not compute Hasse invariants */
5067 : /* we could compute their sum at composite factors */
5068 784 : if (partialfact)
5069 : {
5070 35 : if (!(flag & al_MAXORD))
5071 : {
5072 28 : gel(al,5) = gen_0;
5073 35 : return;
5074 : }
5075 : /* but transmit list of factors found for computation of maximal order */
5076 7 : PH = prV_primes(shallowconcat(gel(fab,1), gel(fad,1)));
5077 7 : gel(al,5) = mkvec2(PH, gen_0);;
5078 7 : return;
5079 : }
5080 :
5081 : /* m2 : number of prime factors of disc not dividing b */
5082 749 : m2 = nbrows(fad);
5083 749 : m23 = m2+m3;
5084 749 : m123 = m1+m2+m3;
5085 :
5086 : /* initialize the possibly ramified primes (hasse) and the factored conductor of rnf/nf (cnd) */
5087 749 : cnd = zeromatcopy(m23,2);
5088 749 : PH = cgetg(m123+1, t_VEC); /* ramified primes */
5089 749 : H = cgetg(m123+1, t_VECSMALL); /* Hasse invariant */
5090 : /* compute Hasse invariant at primes that are unramified in rnf/nf */
5091 1253 : for (k=1; k<=m1; k++) {/* pr | b, pr \nmid disc */
5092 504 : long frob, e, j = perm[k];
5093 504 : pr = gcoeff(fab,j,1);
5094 504 : e = itos(gcoeff(fab,j,2));
5095 504 : frob = cyclicrelfrob(rnf, auts, pr);
5096 504 : gel(PH,k) = pr;
5097 504 : H[k] = Fl_mul(frob, e, n);
5098 : }
5099 : /* compute Hasse invariant at primes that are ramified in rnf/nf */
5100 1540 : for (k=1; k<=m2; k++) {/* pr \nmid b, pr | disc */
5101 791 : pr = gcoeff(fad,k,1);
5102 791 : gel(PH,k+m1) = pr;
5103 791 : gcoeff(cnd,k,1) = pr;
5104 791 : gcoeff(cnd,k,2) = gcoeff(fad,k,2);
5105 : }
5106 798 : for (k=1; k<=m3; k++) { /* pr | (b, disc) */
5107 49 : long j = perm[k+m1];
5108 49 : pr = gcoeff(fab,j,1);
5109 49 : gel(PH,k+m1+m2) = pr;
5110 49 : gcoeff(cnd,k+m2,1) = pr;
5111 49 : gcoeff(cnd,k+m2,2) = gel(L,j);
5112 : }
5113 749 : gel(cnd,2) = gdiventgs(gel(cnd,2), eulerphiu(n));
5114 1589 : for (k=1; k<=m23; k++) H[k+m1] = localhasse(rnf, cnd, pl, auts, b, k);
5115 749 : perm = gen_indexsort(PH, (void*)&cmp_prime_ideal, &cmp_nodata);
5116 749 : gel(al,5) = mkvec2(vecpermute(PH,perm),vecsmallpermute(H,perm));
5117 749 : checkhasse(nf, alg_get_hasse_f(al), alg_get_hasse_i(al), n);
5118 : }
5119 :
5120 : static GEN
5121 1162 : alg_maximal_primes(GEN al, GEN P)
5122 : {
5123 1162 : pari_sp av = avma;
5124 1162 : long l = lg(P), i;
5125 3856 : for (i=1; i<l; i++)
5126 : {
5127 2694 : if (i != 1) al = gerepilecopy(av, al);
5128 2694 : al = alg_pmaximal(al,gel(P,i));
5129 : }
5130 1162 : return al;
5131 : }
5132 :
5133 : GEN
5134 798 : alg_cyclic(GEN rnf, GEN aut, GEN b, long flag)
5135 : {
5136 798 : pari_sp av = avma;
5137 : GEN al, nf;
5138 : long D, n, d;
5139 798 : dbg_printf(1)("alg_cyclic\n");
5140 798 : checkrnf(rnf); nf = rnf_get_nf(rnf);
5141 798 : b = nf_to_scalar_or_basis(nf, b);
5142 791 : if (typ(b) == t_FRAC || (typ(b) == t_COL && !RgV_is_ZV(b)))
5143 7 : pari_err_DOMAIN("alg_cyclic", "denominator(b)", "!=", gen_1,b);
5144 :
5145 784 : n = rnf_get_degree(rnf);
5146 784 : d = nf_get_degree(nf);
5147 784 : D = d*n*n;
5148 :
5149 784 : al = cgetg(12,t_VEC);
5150 784 : gel(al,10)= gen_0; /* must be set first */
5151 784 : gel(al,1) = rnf;
5152 784 : gel(al,2) = allauts(rnf, aut);
5153 784 : gel(al,3) = basistoalg(nf,b);
5154 784 : rnf_build_nfabs(rnf, nf_get_prec(nf));
5155 784 : gel(al,6) = mkvec(gen_0);
5156 784 : gel(al,7) = matid(D);
5157 784 : gel(al,8) = matid(D); /* TODO modify 7, 8 et 9 once LLL added */
5158 784 : gel(al,9) = algnatmultable(al,D);
5159 784 : gel(al,11)= algtracebasis(al);
5160 :
5161 784 : algcomputehasse(al, flag);
5162 :
5163 784 : if (flag & al_MAXORD) {
5164 686 : GEN hf = alg_get_hasse_f(al), pr = gel(hf,1);
5165 686 : if (typ(gel(hf,2)) == t_INT) /* factorisation was partial */
5166 7 : gel(al,5) = gen_0;
5167 679 : else pr = prV_primes(pr);
5168 686 : al = alg_maximal_primes(al, pr);
5169 : }
5170 784 : return gerepilecopy(av, al);
5171 : }
5172 :
5173 : static int
5174 553 : ismaximalsubfield(GEN al, GEN x, GEN d, long v, GEN *pt_minpol)
5175 : {
5176 553 : GEN cp = algbasischarpoly(al, x, v), lead;
5177 553 : if (!ispower(cp, d, pt_minpol)) return 0;
5178 553 : lead = leading_coeff(*pt_minpol);
5179 553 : if (isintm1(lead)) *pt_minpol = gneg(*pt_minpol);
5180 553 : return ZX_is_irred(*pt_minpol);
5181 : }
5182 :
5183 : static GEN
5184 217 : findmaximalsubfield(GEN al, GEN d, long v)
5185 : {
5186 217 : long count, nb=2, i, N = alg_get_absdim(al), n = nf_get_degree(alg_get_center(al));
5187 217 : GEN x, minpol, maxc = gen_1;
5188 :
5189 329 : for (i=n+1; i<=N; i+=n) {
5190 532 : for (count=0; count<2 && i+count<=N; count++) {
5191 420 : x = col_ei(N,i+count);
5192 420 : if (ismaximalsubfield(al, x, d, v, &minpol)) return mkvec2(x,minpol);
5193 : }
5194 : }
5195 :
5196 : while(1) {
5197 133 : x = zerocol(N);
5198 546 : for (count=0; count<nb; count++)
5199 : {
5200 413 : i = random_Fl(N)+1;
5201 413 : gel(x,i) = addiu(randomi(maxc),1);
5202 413 : if (random_bits(1)) gel(x,i) = negi(gel(x,i));
5203 : }
5204 133 : if (ismaximalsubfield(al, x, d, v, &minpol)) return mkvec2(x,minpol);
5205 63 : if (!random_bits(3)) maxc = addiu(maxc,1);
5206 63 : if (nb<N) nb++;
5207 : }
5208 :
5209 : return NULL; /* LCOV_EXCL_LINE */
5210 : }
5211 :
5212 : static GEN
5213 217 : frobeniusform(GEN al, GEN x)
5214 : {
5215 : GEN M, FP, P, Pi;
5216 :
5217 : /* /!\ has to be the *right* multiplication table */
5218 217 : M = algbasisrightmultable(al, x);
5219 :
5220 217 : FP = matfrobenius(M,2,0); /* M = P^(-1)*F*P */
5221 217 : P = gel(FP,2);
5222 217 : Pi = RgM_inv(P);
5223 217 : return mkvec2(P, Pi);
5224 : }
5225 :
5226 : static void
5227 217 : computesplitting(GEN al, long d, long v, long flag)
5228 : {
5229 217 : GEN subf, x, pol, polabs, basis, P, Pi, nf = alg_get_center(al), rnf, Lbasis, Lbasisinv, Q, pows;
5230 217 : long i, n = nf_get_degree(nf), nd = n*d, N = alg_get_absdim(al), j, j2;
5231 :
5232 217 : subf = findmaximalsubfield(al, utoipos(d), v);
5233 217 : x = gel(subf, 1);
5234 217 : polabs = gel(subf, 2);
5235 :
5236 : /* Frobenius form to obtain L-vector space structure */
5237 217 : basis = frobeniusform(al, x);
5238 217 : P = gel(basis, 1);
5239 217 : Pi = gel(basis, 2);
5240 :
5241 : /* construct rnf of splitting field */
5242 217 : pol = gel(nffactor(nf,polabs),1);
5243 245 : for (i=1; i<lg(pol); i++)
5244 : /* select relative factor that vanishes on x */
5245 245 : if (gequal0(algpoleval(al, gel(pol,i), x)))
5246 : {
5247 217 : pol = gel(pol,i);
5248 217 : break;
5249 : }
5250 217 : if (typ(pol) != t_POL) pari_err_BUG("computesplitting (no valid factor)");
5251 217 : if (!(flag & al_FACTOR)) pol = mkvec2(pol, stoi(1<<20));
5252 217 : gel(al,1) = rnf = rnfinit(nf, pol);
5253 : /* since pol is irreducible over Q, we have k=0 in rnf. */
5254 217 : if (!gequal0(rnf_get_k(rnf)))
5255 : pari_err_BUG("computesplitting (k!=0)"); /*LCOV_EXCL_LINE*/
5256 217 : rnf_build_nfabs(rnf, nf_get_prec(nf));
5257 :
5258 : /* construct splitting data */
5259 217 : Lbasis = cgetg(d+1, t_MAT);
5260 602 : for (j=j2=1; j<=d; j++, j2+=nd)
5261 385 : gel(Lbasis,j) = gel(Pi,j2);
5262 :
5263 217 : Q = zeromatcopy(d,N);
5264 217 : pows = pol_x_powers(nd,v);
5265 602 : for (i=j=1; j<=N; j+=nd, i++)
5266 1764 : for (j2=0; j2<nd; j2++)
5267 1379 : gcoeff(Q,i,j+j2) = mkpolmod(gel(pows,j2+1),polabs);
5268 217 : Lbasisinv = RgM_mul(Q,P);
5269 :
5270 217 : gel(al,3) = mkvec3(x,Lbasis,Lbasisinv);
5271 217 : }
5272 :
5273 : /* assumes that mt defines a central simple algebra over nf */
5274 : GEN
5275 245 : alg_csa_table(GEN nf, GEN mt0, long v, long flag)
5276 : {
5277 245 : pari_sp av = avma;
5278 : GEN al, mt;
5279 245 : long n, D, d2 = lg(mt0)-1, d = usqrt(d2);
5280 245 : dbg_printf(1)("alg_csa_table\n");
5281 :
5282 245 : mt = check_relmt(nf,mt0);
5283 231 : if (!mt) pari_err_TYPE("alg_csa_table", mt0);
5284 224 : n = nf_get_degree(nf);
5285 224 : D = n*d2;
5286 224 : if (d*d != d2)
5287 7 : pari_err_DOMAIN("alg_csa_table","(nonsquare) dimension","!=",stoi(d*d),mt);
5288 :
5289 217 : al = cgetg(12, t_VEC);
5290 217 : gel(al,10) = gen_0; /* must be set first */
5291 217 : gel(al,1) = zerovec(12); gmael(al,1,10) = nf;
5292 217 : gmael(al,1,1) = gpowgs(pol_x(0), d); /* placeholder before splitting field */
5293 217 : gel(al,2) = mt;
5294 217 : gel(al,3) = gen_0; /* placeholder */
5295 217 : gel(al,4) = gel(al,5) = gen_0; /* TODO Hasse invariants if flag&al_FACTOR */
5296 217 : gel(al,6) = mkvec(gen_0);
5297 217 : gel(al,7) = matid(D);
5298 217 : gel(al,8) = matid(D);
5299 217 : gel(al,9) = algnatmultable(al,D);
5300 217 : gel(al,11)= algtracebasis(al);
5301 217 : if (flag & al_MAXORD) al = alg_maximal(al);
5302 217 : if (!(flag & al_NOSPLITTING)) computesplitting(al, d, v, flag);
5303 217 : return gerepilecopy(av, al);
5304 : }
5305 :
5306 : static GEN
5307 54999 : algtableinit_i(GEN mt0, GEN p)
5308 : {
5309 : GEN al, mt;
5310 : long i, n;
5311 :
5312 54999 : if (p && !signe(p)) p = NULL;
5313 54999 : mt = check_mt(mt0,p);
5314 54999 : if (!mt) pari_err_TYPE("algtableinit", mt0);
5315 54992 : if (!p && !isint1(Q_denom(mt0)))
5316 7 : pari_err_DOMAIN("algtableinit", "denominator(mt)", "!=", gen_1, mt0);
5317 54985 : n = lg(mt)-1;
5318 54985 : al = cgetg(12, t_VEC);
5319 329910 : for (i=1; i<=5; i++) gel(al,i) = gen_0;
5320 54985 : gel(al,6) = mkvec(gen_0);
5321 54985 : gel(al,7) = matid(n);
5322 54985 : gel(al,8) = matid(n);
5323 54985 : gel(al,9) = mt;
5324 54985 : gel(al,10) = p? p: gen_0;
5325 54985 : gel(al,11) = algtracebasis(al);
5326 54985 : return al;
5327 : }
5328 : GEN
5329 6202 : algtableinit(GEN mt0, GEN p)
5330 : {
5331 6202 : pari_sp av = avma;
5332 6202 : if (p)
5333 : {
5334 6041 : if (typ(p) != t_INT) pari_err_TYPE("algtableinit",p);
5335 6034 : if (signe(p) && !BPSW_psp(p)) pari_err_PRIME("algtableinit",p);
5336 : }
5337 6181 : return gerepilecopy(av, algtableinit_i(mt0, p));
5338 : }
5339 :
5340 : /** REPRESENTATIONS OF GROUPS **/
5341 :
5342 : static GEN
5343 294 : list_to_regular_rep(GEN elts, long n)
5344 : {
5345 : GEN reg, elts2, g;
5346 : long i,j;
5347 294 : elts = shallowcopy(elts);
5348 294 : gen_sort_inplace(elts, (void*)&vecsmall_lexcmp, &cmp_nodata, NULL);
5349 294 : reg = cgetg(n+1, t_VEC);
5350 294 : gel(reg,1) = identity_perm(n);
5351 3857 : for (i=2; i<=n; i++) {
5352 3563 : g = perm_inv(gel(elts,i));
5353 3563 : elts2 = cgetg(n+1, t_VEC);
5354 74543 : for (j=1; j<=n; j++) gel(elts2,j) = perm_mul(g,gel(elts,j));
5355 3563 : gen_sort_inplace(elts2, (void*)&vecsmall_lexcmp, &cmp_nodata, &gel(reg,i));
5356 : }
5357 294 : return reg;
5358 : }
5359 :
5360 : static GEN
5361 3857 : matrix_perm(GEN perm, long n)
5362 : {
5363 : GEN m;
5364 : long j;
5365 3857 : m = cgetg(n+1, t_MAT);
5366 78694 : for (j=1; j<=n; j++) {
5367 74837 : gel(m,j) = col_ei(n,perm[j]);
5368 : }
5369 3857 : return m;
5370 : }
5371 :
5372 : GEN
5373 847 : conjclasses_algcenter(GEN cc, GEN p)
5374 : {
5375 847 : GEN mt, elts = gel(cc,1), conjclass = gel(cc,2), rep = gel(cc,3), card;
5376 847 : long i, nbcl = lg(rep)-1, n = lg(elts)-1;
5377 : pari_sp av;
5378 :
5379 847 : card = zero_Flv(nbcl);
5380 14819 : for (i=1; i<=n; i++) card[conjclass[i]]++;
5381 :
5382 : /* multiplication table of the center of Z[G] (class functions) */
5383 847 : mt = cgetg(nbcl+1,t_VEC);
5384 7217 : for (i=1;i<=nbcl;i++) gel(mt,i) = zero_Flm_copy(nbcl,nbcl);
5385 847 : av = avma;
5386 7217 : for (i=1;i<=nbcl;i++)
5387 : {
5388 6370 : GEN xi = gel(elts,rep[i]), mi = gel(mt,i);
5389 : long j,k;
5390 132244 : for (j=1;j<=n;j++)
5391 : {
5392 125874 : GEN xj = gel(elts,j);
5393 125874 : k = vecsearch(elts, perm_mul(xi,xj), NULL);
5394 125874 : ucoeff(mi, conjclass[k], conjclass[j])++;
5395 : }
5396 70238 : for (k=1; k<=nbcl; k++)
5397 852362 : for (j=1; j<=nbcl; j++)
5398 : {
5399 788494 : ucoeff(mi,k,j) *= card[i];
5400 788494 : ucoeff(mi,k,j) /= card[k];
5401 : }
5402 6370 : set_avma(av);
5403 : }
5404 7217 : for (i=1;i<=nbcl;i++) gel(mt,i) = Flm_to_ZM(gel(mt,i));
5405 847 : return algtableinit_i(mt,p);
5406 : }
5407 :
5408 : GEN
5409 329 : alggroupcenter(GEN G, GEN p, GEN *pcc)
5410 : {
5411 329 : pari_sp av = avma;
5412 329 : GEN cc = group_to_cc(G), al = conjclasses_algcenter(cc, p);
5413 315 : if (!pcc) return gerepilecopy(av,al);
5414 7 : *pcc = cc; return gc_all(av, 2, &al, pcc);
5415 : }
5416 :
5417 : static GEN
5418 294 : groupelts_algebra(GEN elts, GEN p)
5419 : {
5420 294 : pari_sp av = avma;
5421 : GEN mt;
5422 294 : long i, n = lg(elts)-1;
5423 294 : elts = list_to_regular_rep(elts,n);
5424 294 : mt = cgetg(n+1, t_VEC);
5425 4151 : for (i=1; i<=n; i++) gel(mt,i) = matrix_perm(gel(elts,i),n);
5426 294 : return gerepilecopy(av, algtableinit_i(mt,p));
5427 : }
5428 :
5429 : GEN
5430 329 : alggroup(GEN gal, GEN p)
5431 : {
5432 329 : GEN elts = checkgroupelts(gal);
5433 294 : return groupelts_algebra(elts, p);
5434 : }
5435 :
5436 : /** MAXIMAL ORDER **/
5437 :
5438 : static GEN
5439 72342 : mattocol(GEN M, long n)
5440 : {
5441 72342 : GEN C = cgetg(n*n+1, t_COL);
5442 : long i,j,ic;
5443 72342 : ic = 1;
5444 1360218 : for (i=1; i<=n; i++)
5445 35951562 : for (j=1; j<=n; j++, ic++) gel(C,ic) = gcoeff(M,i,j);
5446 72342 : return C;
5447 : }
5448 :
5449 : /* Ip is a lift of a left O/pO-ideal where O is the integral basis of al */
5450 : static GEN
5451 6602 : algleftordermodp(GEN al, GEN Ip, GEN p)
5452 : {
5453 6602 : pari_sp av = avma;
5454 : GEN I, Ii, M, mt, K, imi, p2;
5455 : long n, i;
5456 6602 : n = alg_get_absdim(al);
5457 6602 : mt = alg_get_multable(al);
5458 6602 : p2 = sqri(p);
5459 :
5460 6602 : I = ZM_hnfmodid(Ip, p);
5461 6602 : Ii = ZM_inv(I,NULL);
5462 :
5463 6602 : M = cgetg(n+1, t_MAT);
5464 78944 : for (i=1; i<=n; i++) {
5465 72342 : imi = FpM_mul(Ii, FpM_mul(gel(mt,i), I, p2), p2);
5466 72342 : imi = ZM_Z_divexact(imi, p);
5467 72342 : gel(M,i) = mattocol(imi, n);
5468 : }
5469 6602 : K = FpM_ker(M, p);
5470 6602 : if (lg(K)==1) { set_avma(av); return matid(n); }
5471 2648 : K = ZM_hnfmodid(K,p);
5472 :
5473 2648 : return gerepileupto(av, ZM_Z_div(K,p));
5474 : }
5475 :
5476 : static GEN
5477 11997 : alg_ordermodp(GEN al, GEN p)
5478 : {
5479 : GEN alp;
5480 11997 : long i, N = alg_get_absdim(al);
5481 11997 : alp = cgetg(12, t_VEC);
5482 107973 : for (i=1; i<=8; i++) gel(alp,i) = gen_0;
5483 11997 : gel(alp,9) = cgetg(N+1, t_VEC);
5484 125176 : for (i=1; i<=N; i++) gmael(alp,9,i) = FpM_red(gmael(al,9,i), p);
5485 11997 : gel(alp,10) = p;
5486 11997 : gel(alp,11) = cgetg(N+1, t_VEC);
5487 125176 : for (i=1; i<=N; i++) gmael(alp,11,i) = Fp_red(gmael(al,11,i), p);
5488 :
5489 11997 : return alp;
5490 : }
5491 :
5492 : static GEN
5493 5342 : algpradical_i(GEN al, GEN p, GEN zprad, GEN projs)
5494 : {
5495 5342 : pari_sp av = avma;
5496 5342 : GEN alp = alg_ordermodp(al, p), liftrad, projrad, alq, alrad, res, Lalp, radq;
5497 : long i;
5498 5342 : if (lg(zprad)==1) {
5499 3834 : liftrad = NULL;
5500 3834 : projrad = NULL;
5501 : }
5502 : else {
5503 1508 : alq = alg_quotient(alp, zprad, 1);
5504 1508 : alp = gel(alq,1);
5505 1508 : projrad = gel(alq,2);
5506 1508 : liftrad = gel(alq,3);
5507 : }
5508 :
5509 5342 : if (projs) {
5510 845 : if (projrad) {
5511 28 : projs = gcopy(projs);
5512 84 : for (i=1; i<lg(projs); i++)
5513 56 : gel(projs,i) = FpM_FpC_mul(projrad, gel(projs,i), p);
5514 : }
5515 845 : Lalp = alg_centralproj(alp, projs, 1);
5516 :
5517 845 : alrad = cgetg(lg(Lalp),t_VEC);
5518 2907 : for (i=1; i<lg(Lalp); i++) {
5519 2062 : alq = gel(Lalp,i);
5520 2062 : radq = algradical(gel(alq,1));
5521 2062 : if (gequal0(radq))
5522 1188 : gel(alrad,i) = cgetg(1,t_MAT);
5523 : else {
5524 874 : radq = FpM_mul(gel(alq,3),radq,p);
5525 874 : gel(alrad,i) = radq;
5526 : }
5527 : }
5528 845 : alrad = shallowmatconcat(alrad);
5529 845 : alrad = FpM_image(alrad,p);
5530 : }
5531 4497 : else alrad = algradical(alp);
5532 :
5533 5342 : if (!gequal0(alrad)) {
5534 4272 : if (liftrad) alrad = FpM_mul(liftrad, alrad, p);
5535 4272 : res = shallowmatconcat(mkvec2(alrad, zprad));
5536 4272 : res = FpM_image(res,p);
5537 : }
5538 1070 : else res = lg(zprad)==1 ? gen_0 : zprad;
5539 5342 : return gerepilecopy(av, res);
5540 : }
5541 :
5542 : static GEN
5543 3897 : algpdecompose0(GEN al, GEN prad, GEN p, GEN projs)
5544 : {
5545 3897 : pari_sp av = avma;
5546 3897 : GEN alp, quo, ss, liftm = NULL, projm = NULL, dec, res, I, Lss, deci;
5547 : long i, j;
5548 :
5549 3897 : alp = alg_ordermodp(al, p);
5550 3897 : if (!gequal0(prad)) {
5551 3177 : quo = alg_quotient(alp, prad, 1);
5552 3177 : ss = gel(quo,1);
5553 3177 : projm = gel(quo,2);
5554 3177 : liftm = gel(quo,3);
5555 : }
5556 720 : else ss = alp;
5557 :
5558 3897 : if (projs) {
5559 733 : if (projm) {
5560 1767 : for (i=1; i<lg(projs); i++)
5561 1250 : gel(projs,i) = FpM_FpC_mul(projm, gel(projs,i), p);
5562 : }
5563 733 : Lss = alg_centralproj(ss, projs, 1);
5564 :
5565 733 : dec = cgetg(lg(Lss),t_VEC);
5566 2550 : for (i=1; i<lg(Lss); i++) {
5567 1817 : gel(dec,i) = algsimpledec_ss(gmael(Lss,i,1), 1);
5568 1817 : deci = gel(dec,i);
5569 4074 : for (j=1; j<lg(deci); j++)
5570 2257 : gmael(deci,j,3) = FpM_mul(gmael(Lss,i,3), gmael(deci,j,3), p);
5571 : }
5572 733 : dec = shallowconcat1(dec);
5573 : }
5574 3164 : else dec = algsimpledec_ss(ss,1);
5575 :
5576 3897 : res = cgetg(lg(dec),t_VEC);
5577 10438 : for (i=1; i<lg(dec); i++) {
5578 6541 : I = gmael(dec,i,3);
5579 6541 : if (liftm) I = FpM_mul(liftm,I,p);
5580 6541 : I = shallowmatconcat(mkvec2(I,prad));
5581 6541 : gel(res,i) = I;
5582 : }
5583 :
5584 3897 : return gerepilecopy(av, res);
5585 : }
5586 :
5587 : /* finds a nontrivial ideal of O/prad or gen_0 if there is none. */
5588 : static GEN
5589 1203 : algpdecompose_i(GEN al, GEN p, GEN zprad, GEN projs)
5590 : {
5591 1203 : pari_sp av = avma;
5592 1203 : GEN prad = algpradical_i(al,p,zprad,projs);
5593 1203 : return gerepileupto(av, algpdecompose0(al, prad, p, projs));
5594 : }
5595 :
5596 : /* ord is assumed to be in hnf wrt the integral basis of al. */
5597 : /* assumes that alg_get_invbasis(al) is integral. */
5598 : static GEN
5599 2669 : alg_change_overorder_shallow(GEN al, GEN ord)
5600 : {
5601 : GEN al2, mt, iord, mtx, den, den2, div;
5602 : long i, n;
5603 2669 : n = alg_get_absdim(al);
5604 :
5605 2669 : iord = QM_inv(ord);
5606 2669 : al2 = shallowcopy(al);
5607 2669 : ord = Q_remove_denom(ord,&den);
5608 :
5609 2669 : gel(al2,7) = Q_remove_denom(gel(al,7), &den2);
5610 2669 : if (den2) div = mulii(den,den2);
5611 1008 : else div = den;
5612 2669 : gel(al2,7) = ZM_Z_div(ZM_mul(gel(al2,7), ord), div);
5613 :
5614 2669 : gel(al2,8) = ZM_mul(iord, gel(al,8));
5615 :
5616 2669 : mt = cgetg(n+1,t_VEC);
5617 2669 : gel(mt,1) = matid(n);
5618 2669 : div = sqri(den);
5619 30745 : for (i=2; i<=n; i++) {
5620 28076 : mtx = algbasismultable(al,gel(ord,i));
5621 28076 : gel(mt,i) = ZM_mul(iord, ZM_mul(mtx, ord));
5622 28076 : gel(mt,i) = ZM_Z_divexact(gel(mt,i), div);
5623 : }
5624 2669 : gel(al2,9) = mt;
5625 :
5626 2669 : gel(al2,11) = algtracebasis(al2);
5627 :
5628 2669 : return al2;
5629 : }
5630 :
5631 : static GEN
5632 31690 : algeltfromnf_i(GEN al, GEN x)
5633 : {
5634 31690 : GEN nf = alg_get_center(al);
5635 : long n;
5636 31690 : switch(alg_type(al)) {
5637 26734 : case al_CYCLIC:
5638 26734 : n = alg_get_degree(al);
5639 26734 : break;
5640 4956 : case al_CSA:
5641 4956 : n = alg_get_dim(al);
5642 4956 : break;
5643 : default: return NULL; /*LCOV_EXCL_LINE*/
5644 : }
5645 31690 : return algalgtobasis(al, scalarcol(basistoalg(nf, x), n));
5646 : }
5647 :
5648 : GEN
5649 5061 : algeltfromnf(GEN al, GEN x)
5650 : {
5651 5061 : pari_sp av = avma;
5652 5061 : checkalg(al);
5653 5054 : return gerepileupto(av, algeltfromnf_i(al,x));
5654 : }
5655 :
5656 : /* x is an ideal of the center in hnf form */
5657 : static GEN
5658 5342 : algeltfromnf_hnf(GEN al, GEN x)
5659 : {
5660 : GEN res;
5661 : long i;
5662 5342 : res = cgetg(lg(x), t_MAT);
5663 15325 : for (i=1; i<lg(x); i++) gel(res,i) = algeltfromnf_i(al, gel(x,i));
5664 5342 : return res;
5665 : }
5666 :
5667 : /* assumes al is CSA or CYCLIC */
5668 : static GEN
5669 2694 : algcenter_precompute(GEN al, GEN p)
5670 : {
5671 2694 : GEN fa, pdec, nfprad, projs, nf = alg_get_center(al);
5672 : long i, np;
5673 :
5674 2694 : pdec = idealprimedec(nf, p);
5675 2694 : settyp(pdec, t_COL);
5676 2694 : np = lg(pdec)-1;
5677 2694 : fa = mkmat2(pdec, const_col(np, gen_1));
5678 2694 : if (dvdii(nf_get_disc(nf), p))
5679 483 : nfprad = idealprodprime(nf, pdec);
5680 : else
5681 2211 : nfprad = scalarmat_shallow(p, nf_get_degree(nf));
5682 2694 : fa = idealchineseinit(nf, fa);
5683 2694 : projs = cgetg(np+1, t_VEC);
5684 5977 : for (i=1; i<=np; i++) gel(projs, i) = idealchinese(nf, fa, vec_ei(np,i));
5685 2694 : return mkvec2(nfprad, projs);
5686 : }
5687 :
5688 : static GEN
5689 5342 : algcenter_prad(GEN al, GEN p, GEN pre)
5690 : {
5691 : GEN nfprad, zprad, mtprad;
5692 : long i;
5693 5342 : nfprad = gel(pre,1);
5694 5342 : zprad = algeltfromnf_hnf(al, nfprad);
5695 5342 : zprad = FpM_image(zprad, p);
5696 5342 : mtprad = cgetg(lg(zprad), t_VEC);
5697 7397 : for (i=1; i<lg(zprad); i++) gel(mtprad, i) = algbasismultable(al, gel(zprad,i));
5698 5342 : mtprad = shallowmatconcat(mtprad);
5699 5342 : zprad = FpM_image(mtprad, p);
5700 5342 : return zprad;
5701 : }
5702 :
5703 : static GEN
5704 5342 : algcenter_p_projs(GEN al, GEN p, GEN pre)
5705 : {
5706 : GEN projs, zprojs;
5707 : long i;
5708 5342 : projs = gel(pre,2);
5709 5342 : zprojs = cgetg(lg(projs), t_VEC);
5710 11901 : for (i=1; i<lg(projs); i++) gel(zprojs,i) = FpC_red(algeltfromnf_i(al, gel(projs,i)),p);
5711 5342 : return zprojs;
5712 : }
5713 :
5714 : /* al is assumed to be simple */
5715 : static GEN
5716 2694 : alg_pmaximal(GEN al, GEN p)
5717 : {
5718 : pari_sp av;
5719 2694 : long n = alg_get_absdim(al);
5720 2694 : GEN id = matid(n), al2 = al, prad, lord = gen_0, dec, zprad, projs, pre;
5721 :
5722 2694 : dbg_printf(0)("Round 2 (noncommutative) at p=%Ps, dim=%d\n", p, n);
5723 2694 : pre = algcenter_precompute(al,p); av = avma;
5724 : while (1) {
5725 4139 : zprad = algcenter_prad(al2, p, pre);
5726 4139 : projs = algcenter_p_projs(al2, p, pre);
5727 4139 : if (lg(projs) == 2) projs = NULL;
5728 4139 : prad = algpradical_i(al2,p,zprad,projs);
5729 4139 : if (typ(prad) == t_INT) break;
5730 4097 : lord = algleftordermodp(al2,prad,p);
5731 4097 : if (!cmp_universal(lord,id)) break;
5732 1445 : al2 = gerepilecopy(av, alg_change_overorder_shallow(al2,lord));
5733 : }
5734 :
5735 2694 : dec = algpdecompose0(al2,prad,p,projs); av = avma;
5736 3897 : while (lg(dec) > 2) {
5737 : long i;
5738 2945 : for (i = 1; i < lg(dec); i++) {
5739 2505 : GEN I = gel(dec,i);
5740 2505 : lord = algleftordermodp(al2,I,p);
5741 2505 : if (cmp_universal(lord,id)) break;
5742 : }
5743 1643 : if (i==lg(dec)) break;
5744 1203 : al2 = gerepilecopy(av, alg_change_overorder_shallow(al2,lord));
5745 1203 : zprad = algcenter_prad(al2, p, pre);
5746 1203 : projs = algcenter_p_projs(al2, p, pre);
5747 1203 : if (lg(projs) == 2) projs = NULL;
5748 1203 : dec = algpdecompose_i(al2,p,zprad,projs);
5749 : }
5750 2694 : return al2;
5751 : }
5752 :
5753 : static GEN
5754 13258 : algtracematrix(GEN al)
5755 : {
5756 : GEN M, mt;
5757 : long n, i, j;
5758 13258 : n = alg_get_absdim(al);
5759 13258 : mt = alg_get_multable(al);
5760 13258 : M = cgetg(n+1, t_MAT);
5761 99395 : for (i=1; i<=n; i++)
5762 : {
5763 86137 : gel(M,i) = cgetg(n+1,t_MAT);
5764 672778 : for (j=1; j<=i; j++)
5765 586641 : gcoeff(M,j,i) = gcoeff(M,i,j) = algabstrace(al,gmael(mt,i,j));
5766 : }
5767 13258 : return M;
5768 : }
5769 : static GEN
5770 525 : algdisc_i(GEN al) { return ZM_det(algtracematrix(al)); }
5771 : GEN
5772 364 : algdisc(GEN al)
5773 : {
5774 364 : pari_sp av = avma;
5775 364 : checkalg(al);
5776 364 : if (alg_type(al) == al_REAL) pari_err_TYPE("algdisc [real algebra]", al);
5777 343 : return gerepileuptoint(av, algdisc_i(al));
5778 : }
5779 : static GEN
5780 182 : alg_maximal(GEN al)
5781 : {
5782 182 : GEN fa = absZ_factor(algdisc_i(al));
5783 182 : return alg_maximal_primes(al, gel(fa,1));
5784 : }
5785 :
5786 : /** LATTICES **/
5787 :
5788 : /*
5789 : Convention: lattice = [I,t] representing t*I, where
5790 : - I integral nonsingular upper-triangular matrix representing a lattice over
5791 : the integral basis of the algebra, and
5792 : - t>0 either an integer or a rational number.
5793 :
5794 : Recommended and returned by the functions below:
5795 : - I HNF and primitive
5796 : */
5797 :
5798 : /* TODO use hnfmodid whenever possible using a*O <= I <= O
5799 : * for instance a = ZM_det_triangular(I) */
5800 :
5801 : static GEN
5802 64351 : primlat(GEN lat)
5803 : {
5804 : GEN m, t, c;
5805 64351 : m = alglat_get_primbasis(lat);
5806 64351 : t = alglat_get_scalar(lat);
5807 64351 : m = Q_primitive_part(m,&c);
5808 64351 : if (c) return mkvec2(m,gmul(t,c));
5809 54817 : return lat;
5810 : }
5811 :
5812 : /* assumes the lattice contains d * integral basis, d=0 allowed */
5813 : GEN
5814 53487 : alglathnf(GEN al, GEN m, GEN d)
5815 : {
5816 53487 : pari_sp av = avma;
5817 : long N,i,j;
5818 : GEN m2, c;
5819 53487 : if (!d) d = gen_0;
5820 53487 : checkalg(al);
5821 53487 : if (alg_type(al) == al_REAL) pari_err_TYPE("alglathnf [real algebra]", al);
5822 53480 : N = alg_get_absdim(al);
5823 53480 : if (!d) d = gen_0;
5824 53480 : if (typ(m) == t_VEC) m = matconcat(m);
5825 53480 : if (typ(m) == t_COL) m = algleftmultable(al,m);
5826 53480 : if (typ(m) != t_MAT) pari_err_TYPE("alglathnf",m);
5827 53473 : if (typ(d) != t_FRAC && typ(d) != t_INT) pari_err_TYPE("alglathnf",d);
5828 53473 : if (lg(m)-1 < N || lg(gel(m,1))-1 != N) pari_err_DIM("alglathnf");
5829 480935 : for (i=1; i<=N; i++)
5830 7185192 : for (j=1; j<lg(m); j++)
5831 6757702 : if (typ(gcoeff(m,i,j)) != t_FRAC && typ(gcoeff(m,i,j)) != t_INT)
5832 7 : pari_err_TYPE("alglathnf", gcoeff(m,i,j));
5833 53438 : m2 = Q_primitive_part(m,&c);
5834 53438 : if (!c) c = gen_1;
5835 53438 : if (!signe(d)) d = detint(m2);
5836 45593 : else d = gdiv(d,c); /* should be an integer */
5837 53438 : if (!signe(d)) pari_err_INV("alglathnf [m does not have full rank]", m2);
5838 53424 : m2 = ZM_hnfmodid(m2,d);
5839 53424 : return gerepilecopy(av, mkvec2(m2,c));
5840 : }
5841 :
5842 : static GEN
5843 11683 : prepare_multipliers(GEN *a, GEN *b)
5844 : {
5845 : GEN na, nb, da, db, d;
5846 11683 : na = numer_i(*a); da = denom_i(*a);
5847 11683 : nb = numer_i(*b); db = denom_i(*b);
5848 11683 : na = mulii(na,db);
5849 11683 : nb = mulii(nb,da);
5850 11683 : d = gcdii(na,nb);
5851 11683 : *a = diviiexact(na,d);
5852 11683 : *b = diviiexact(nb,d);
5853 11683 : return gdiv(d, mulii(da,db));
5854 : }
5855 :
5856 : static GEN
5857 11683 : prepare_lat(GEN m1, GEN t1, GEN m2, GEN t2)
5858 : {
5859 11683 : GEN d = prepare_multipliers(&t1, &t2);
5860 11683 : m1 = ZM_Z_mul(m1,t1);
5861 11683 : m2 = ZM_Z_mul(m2,t2);
5862 11683 : return mkvec3(m1,m2,d);
5863 : }
5864 :
5865 : static GEN
5866 11697 : alglataddinter(GEN al, GEN lat1, GEN lat2, GEN *sum, GEN *inter)
5867 : {
5868 : GEN d, m1, m2, t1, t2, M, prep, d1, d2, ds, di, K;
5869 11697 : checkalg(al);
5870 11697 : if (alg_type(al) == al_REAL)
5871 14 : pari_err_TYPE("alglataddinter [real algebra]", al);
5872 11683 : checklat(al,lat1);
5873 11683 : checklat(al,lat2);
5874 :
5875 11683 : m1 = alglat_get_primbasis(lat1);
5876 11683 : t1 = alglat_get_scalar(lat1);
5877 11683 : m2 = alglat_get_primbasis(lat2);
5878 11683 : t2 = alglat_get_scalar(lat2);
5879 11683 : prep = prepare_lat(m1, t1, m2, t2);
5880 11683 : m1 = gel(prep,1);
5881 11683 : m2 = gel(prep,2);
5882 11683 : d = gel(prep,3);
5883 11683 : M = matconcat(mkvec2(m1,m2));
5884 11683 : d1 = ZM_det_triangular(m1);
5885 11683 : d2 = ZM_det_triangular(m2);
5886 11683 : ds = gcdii(d1,d2);
5887 11683 : if (inter)
5888 : {
5889 7616 : di = diviiexact(mulii(d1,d2),ds);
5890 7616 : if (equali1(di))
5891 : {
5892 140 : *inter = matid(lg(m1)-1);
5893 140 : if (sum) *sum = matid(lg(m1)-1);
5894 : }
5895 : else
5896 : {
5897 7476 : K = matkermod(M,di,sum);
5898 7476 : K = rowslice(K,1,lg(m1));
5899 7476 : *inter = hnfmodid(FpM_mul(m1,K,di),di);
5900 7476 : if (sum) *sum = hnfmodid(*sum,ds);
5901 : }
5902 : }
5903 4067 : else *sum = hnfmodid(M,ds);
5904 11683 : return d;
5905 : }
5906 :
5907 : GEN
5908 4109 : alglatinter(GEN al, GEN lat1, GEN lat2, GEN* psum)
5909 : {
5910 4109 : pari_sp av = avma;
5911 : GEN inter, d;
5912 4109 : d = alglataddinter(al, lat1, lat2, psum, &inter);
5913 4102 : inter = primlat(mkvec2(inter, d));
5914 4102 : if (!psum) return gerepilecopy(av, inter);
5915 28 : *psum = primlat(mkvec2(*psum,d));
5916 28 : return gc_all(av, 2, &inter, psum);
5917 : }
5918 :
5919 : GEN
5920 7588 : alglatadd(GEN al, GEN lat1, GEN lat2, GEN* pinter)
5921 : {
5922 7588 : pari_sp av = avma;
5923 : GEN sum, d;
5924 7588 : d = alglataddinter(al, lat1, lat2, &sum, pinter);
5925 7581 : sum = primlat(mkvec2(sum, d));
5926 7581 : if (!pinter) return gerepilecopy(av, sum);
5927 3514 : *pinter = primlat(mkvec2(*pinter,d));
5928 3514 : return gc_all(av, 2, &sum, pinter);
5929 : }
5930 :
5931 : /* TODO version that returns the quotient as abelian group? */
5932 : /* return matrices to convert coordinates from one to other? */
5933 : int
5934 33495 : alglatsubset(GEN al, GEN lat1, GEN lat2, GEN* pindex)
5935 : {
5936 33495 : pari_sp av = avma;
5937 : int res;
5938 : GEN m1, m2, m2i, m, t;
5939 33495 : checkalg(al);
5940 33495 : if (alg_type(al) == al_REAL) pari_err_TYPE("alglatsubset [real algebra]", al);
5941 33488 : checklat(al,lat1);
5942 33488 : checklat(al,lat2);
5943 33488 : m1 = alglat_get_primbasis(lat1);
5944 33488 : m2 = alglat_get_primbasis(lat2);
5945 33488 : m2i = RgM_inv_upper(m2);
5946 33488 : t = gdiv(alglat_get_scalar(lat1), alglat_get_scalar(lat2));
5947 33488 : m = RgM_Rg_mul(RgM_mul(m2i,m1), t);
5948 33488 : res = RgM_is_ZM(m);
5949 33488 : if (!res || !pindex) return gc_int(av, res);
5950 1757 : *pindex = gerepileuptoint(av, mpabs(ZM_det_triangular(m)));
5951 1757 : return 1;
5952 : }
5953 :
5954 : GEN
5955 5271 : alglatindex(GEN al, GEN lat1, GEN lat2)
5956 : {
5957 5271 : pari_sp av = avma;
5958 : long N;
5959 : GEN res;
5960 5271 : checkalg(al);
5961 5271 : if (alg_type(al) == al_REAL) pari_err_TYPE("alglatindex [real algebra]", al);
5962 5264 : checklat(al,lat1);
5963 5264 : checklat(al,lat2);
5964 5264 : N = alg_get_absdim(al);
5965 5264 : res = alglat_get_scalar(lat1);
5966 5264 : res = gdiv(res, alglat_get_scalar(lat2));
5967 5264 : res = gpowgs(res, N);
5968 5264 : res = gmul(res,RgM_det_triangular(alglat_get_primbasis(lat1)));
5969 5264 : res = gdiv(res, RgM_det_triangular(alglat_get_primbasis(lat2)));
5970 5264 : res = gabs(res,0);
5971 5264 : return gerepilecopy(av, res);
5972 : }
5973 :
5974 : GEN
5975 45612 : alglatmul(GEN al, GEN lat1, GEN lat2)
5976 : {
5977 45612 : pari_sp av = avma;
5978 : long N,i;
5979 : GEN m1, m2, m, V, lat, t, d, dp;
5980 45612 : checkalg(al);
5981 45612 : if (alg_type(al) == al_REAL) pari_err_TYPE("alglatmul [real algebra]", al);
5982 45605 : if (typ(lat1)==t_COL)
5983 : {
5984 19292 : if (typ(lat2)==t_COL)
5985 7 : pari_err_TYPE("alglatmul [one of lat1, lat2 has to be a lattice]", lat2);
5986 19285 : checklat(al,lat2);
5987 19285 : lat1 = Q_remove_denom(lat1,&d);
5988 19285 : m = algbasismultable(al,lat1);
5989 19285 : m2 = alglat_get_primbasis(lat2);
5990 19285 : dp = mulii(detint(m),ZM_det_triangular(m2));
5991 19285 : m = ZM_mul(m,m2);
5992 19285 : t = alglat_get_scalar(lat2);
5993 19285 : if (d) t = gdiv(t,d);
5994 : }
5995 : else /* typ(lat1)!=t_COL */
5996 : {
5997 26313 : checklat(al,lat1);
5998 26313 : if (typ(lat2)==t_COL)
5999 : {
6000 19285 : lat2 = Q_remove_denom(lat2,&d);
6001 19285 : m = algbasisrightmultable(al,lat2);
6002 19285 : m1 = alglat_get_primbasis(lat1);
6003 19285 : dp = mulii(detint(m),ZM_det_triangular(m1));
6004 19285 : m = ZM_mul(m,m1);
6005 19285 : t = alglat_get_scalar(lat1);
6006 19285 : if (d) t = gdiv(t,d);
6007 : }
6008 : else /* typ(lat2)!=t_COL */
6009 : {
6010 7028 : checklat(al,lat2);
6011 7021 : N = alg_get_absdim(al);
6012 7021 : m1 = alglat_get_primbasis(lat1);
6013 7021 : m2 = alglat_get_primbasis(lat2);
6014 7021 : dp = mulii(ZM_det_triangular(m1), ZM_det_triangular(m2));
6015 7021 : V = cgetg(N+1,t_VEC);
6016 63189 : for (i=1; i<=N; i++) {
6017 56168 : gel(V,i) = algbasismultable(al,gel(m1,i));
6018 56168 : gel(V,i) = ZM_mul(gel(V,i),m2);
6019 : }
6020 7021 : m = matconcat(V);
6021 7021 : t = gmul(alglat_get_scalar(lat1), alglat_get_scalar(lat2));
6022 : }
6023 : }
6024 :
6025 45591 : lat = alglathnf(al,m,dp);
6026 45591 : gel(lat,2) = gmul(alglat_get_scalar(lat), t);
6027 45591 : lat = primlat(lat);
6028 45591 : return gerepilecopy(av, lat);
6029 : }
6030 :
6031 : int
6032 17528 : alglatcontains(GEN al, GEN lat, GEN x, GEN *ptc)
6033 : {
6034 17528 : pari_sp av = avma;
6035 : GEN m, t, sol;
6036 17528 : checkalg(al);
6037 17528 : if (alg_type(al) == al_REAL)
6038 7 : pari_err_TYPE("alglatcontains [real algebra]", al);
6039 17521 : checklat(al,lat);
6040 17521 : m = alglat_get_primbasis(lat);
6041 17521 : t = alglat_get_scalar(lat);
6042 17521 : x = RgC_Rg_div(x,t);
6043 17521 : if (!RgV_is_ZV(x)) return gc_bool(av,0);
6044 17521 : sol = hnf_solve(m,x);
6045 17521 : if (!sol) return gc_bool(av,0);
6046 8771 : if (!ptc) return gc_bool(av,1);
6047 8764 : *ptc = gerepilecopy(av, sol); return 1;
6048 : }
6049 :
6050 : GEN
6051 8778 : alglatelement(GEN al, GEN lat, GEN c)
6052 : {
6053 8778 : pari_sp av = avma;
6054 : GEN res;
6055 8778 : checkalg(al);
6056 8778 : if (alg_type(al) == al_REAL)
6057 7 : pari_err_TYPE("alglatelement [real algebra]", al);
6058 8771 : checklat(al,lat);
6059 8771 : if (typ(c)!=t_COL) pari_err_TYPE("alglatelement", c);
6060 8764 : res = ZM_ZC_mul(alglat_get_primbasis(lat),c);
6061 8764 : res = RgC_Rg_mul(res, alglat_get_scalar(lat));
6062 8764 : return gerepilecopy(av,res);
6063 : }
6064 :
6065 : /* idem QM_invimZ, knowing result is contained in 1/c*Z^n */
6066 : static GEN
6067 3535 : QM_invimZ_mod(GEN m, GEN c)
6068 : {
6069 : GEN d, m0, K;
6070 3535 : m0 = Q_remove_denom(m, &d);
6071 3535 : if (d) d = mulii(d,c);
6072 35 : else d = c;
6073 3535 : K = matkermod(m0, d, NULL);
6074 3535 : if (lg(K)==1) K = scalarmat(d, lg(m)-1);
6075 3493 : else K = hnfmodid(K, d);
6076 3535 : return RgM_Rg_div(K,c);
6077 : }
6078 :
6079 : /* If m is injective, computes a Z-basis of the submodule of elements whose
6080 : * image under m is integral */
6081 : static GEN
6082 14 : QM_invimZ(GEN m)
6083 : {
6084 14 : return RgM_invimage(m, QM_ImQ_hnf(m));
6085 : }
6086 :
6087 : /* An isomorphism of R-modules M_{m,n}(R) -> R^{m*n} */
6088 : static GEN
6089 28322 : mat2col(GEN M, long m, long n)
6090 : {
6091 : long i,j,k,p;
6092 : GEN C;
6093 28322 : p = m*n;
6094 28322 : C = cgetg(p+1,t_COL);
6095 254702 : for (i=1,k=1;i<=m;i++)
6096 2036804 : for (j=1;j<=n;j++,k++)
6097 1810424 : gel(C,k) = gcoeff(M,i,j);
6098 28322 : return C;
6099 : }
6100 :
6101 : static GEN
6102 3535 : alglattransporter_i(GEN al, GEN lat1, GEN lat2, long right)
6103 : {
6104 : GEN m1, m2, m2i, M, MT, mt, t1, t2, T, c;
6105 : long N, i;
6106 3535 : N = alg_get_absdim(al);
6107 3535 : m1 = alglat_get_primbasis(lat1);
6108 3535 : m2 = alglat_get_primbasis(lat2);
6109 3535 : m2i = RgM_inv_upper(m2);
6110 3535 : c = detint(m1);
6111 3535 : t1 = alglat_get_scalar(lat1);
6112 3535 : m1 = RgM_Rg_mul(m1,t1);
6113 3535 : t2 = alglat_get_scalar(lat2);
6114 3535 : m2i = RgM_Rg_div(m2i,t2);
6115 :
6116 3535 : MT = right? NULL: alg_get_multable(al);
6117 3535 : M = cgetg(N+1, t_MAT);
6118 31815 : for (i=1; i<=N; i++) {
6119 28280 : if (right) mt = algbasisrightmultable(al, vec_ei(N,i));
6120 14168 : else mt = gel(MT,i);
6121 28280 : mt = RgM_mul(m2i,mt);
6122 28280 : mt = RgM_mul(mt,m1);
6123 28280 : gel(M,i) = mat2col(mt, N, N);
6124 : }
6125 :
6126 3535 : c = gdiv(t2,gmul(c,t1));
6127 3535 : c = denom_i(c);
6128 3535 : T = QM_invimZ_mod(M,c);
6129 3535 : return primlat(mkvec2(T,gen_1));
6130 : }
6131 :
6132 : /*
6133 : { x in al | x*lat1 subset lat2}
6134 : */
6135 : GEN
6136 1778 : alglatlefttransporter(GEN al, GEN lat1, GEN lat2)
6137 : {
6138 1778 : pari_sp av = avma;
6139 1778 : checkalg(al);
6140 1778 : if (alg_type(al) == al_REAL)
6141 7 : pari_err_TYPE("alglatlefttransporter [real algebra]", al);
6142 1771 : checklat(al,lat1);
6143 1771 : checklat(al,lat2);
6144 1771 : return gerepilecopy(av, alglattransporter_i(al,lat1,lat2,0));
6145 : }
6146 :
6147 : /*
6148 : { x in al | lat1*x subset lat2}
6149 : */
6150 : GEN
6151 1771 : alglatrighttransporter(GEN al, GEN lat1, GEN lat2)
6152 : {
6153 1771 : pari_sp av = avma;
6154 1771 : checkalg(al);
6155 1771 : if (alg_type(al) == al_REAL)
6156 7 : pari_err_TYPE("alglatrighttransporter [real algebra]", al);
6157 1764 : checklat(al,lat1);
6158 1764 : checklat(al,lat2);
6159 1764 : return gerepilecopy(av, alglattransporter_i(al,lat1,lat2,1));
6160 : }
6161 :
6162 : GEN
6163 42 : algmakeintegral(GEN mt0, long maps)
6164 : {
6165 42 : pari_sp av = avma;
6166 : long n,i;
6167 : GEN m,P,Pi,mt2,mt;
6168 42 : n = lg(mt0)-1;
6169 42 : mt = check_mt(mt0,NULL);
6170 42 : if (!mt) pari_err_TYPE("algmakeintegral", mt0);
6171 21 : if (isint1(Q_denom(mt0))) {
6172 7 : if (maps) mt = mkvec3(mt,matid(n),matid(n));
6173 7 : return gerepilecopy(av,mt);
6174 : }
6175 14 : dbg_printf(2)(" algmakeintegral: dim=%d, denom=%Ps\n", n, Q_denom(mt0));
6176 14 : m = cgetg(n+1,t_MAT);
6177 56 : for (i=1;i<=n;i++)
6178 42 : gel(m,i) = mat2col(gel(mt,i),n,n);
6179 14 : dbg_printf(2)(" computing order, dims m = %d x %d...\n", nbrows(m), lg(m)-1);
6180 14 : P = QM_invimZ(m);
6181 14 : dbg_printf(2)(" ...done.\n");
6182 14 : P = shallowmatconcat(mkvec2(col_ei(n,1),P));
6183 14 : P = hnf(P);
6184 14 : Pi = RgM_inv(P);
6185 14 : mt2 = change_Rgmultable(mt,P,Pi);
6186 14 : if (maps) mt2 = mkvec3(mt2,Pi,P); /* mt2, mt->mt2, mt2->mt */
6187 14 : return gerepilecopy(av,mt2);
6188 : }
6189 :
6190 : /** ORDERS **/
6191 :
6192 : /*
6193 : * algmodpr data:
6194 : * 1. pr
6195 : * 2. Vecsmall([k,m]) s.t. target is M_k(F_p^m). /!\ m can differ from pr.f
6196 : * 3. t_FFELT 1 representing the finite field F_q
6197 : * 4. proj: O -> M_k(F_q)
6198 : * 5. lift: M_k(F_q) -> O
6199 : * 6. tau: anti uniformizer (left multiplication matrix)
6200 : * 7. T s.t. F_q = F_p[x]/T
6201 : */
6202 : GEN
6203 2793 : algmodprinit(GEN al, GEN pr, long v)
6204 : {
6205 2793 : pari_sp av = avma;
6206 : GEN p, alp, g, Q, pro, lif, map, mapi, alpr, spl, data, nf, T, J, tau;
6207 : long tal, k, m;
6208 2793 : checkalg(al); checkprid(pr);
6209 2779 : tal = alg_type(al);
6210 2779 : if (tal!=al_CYCLIC && tal!=al_CSA)
6211 21 : pari_err_TYPE("algmodprinit [use alginit]", al);
6212 2758 : nf = alg_get_center(al);
6213 2758 : p = pr_get_p(pr);
6214 2758 : alp = alg_ordermodp(al, p);
6215 2758 : g = algeltfromnf_i(al, pr_get_gen(pr));
6216 2758 : g = algbasismultable(alp, g);
6217 2758 : g = FpM_image(g, p);
6218 2758 : alpr = alg_quotient(alp, g, 1);
6219 2758 : Q = gel(alpr, 1);
6220 2758 : pro = gel(alpr, 2);
6221 2758 : lif = gel(alpr, 3);
6222 2758 : J = algradical(Q); /* could skip if we knew the order is maximal at unramified pr */
6223 2758 : if (!gequal0(J))
6224 : {
6225 21 : Q = alg_quotient(Q, J, 1);
6226 21 : pro = ZM_mul(gel(Q,2), pro);
6227 21 : lif = ZM_mul(lif, gel(Q,3));
6228 21 : Q = gel(Q,1);
6229 : }
6230 2758 : spl = alg_finite_csa_split(Q, v);
6231 2758 : T = gel(spl, 1); /* t_POL, possibly of degree 1 */
6232 2758 : mapi = gel(spl, 3);
6233 2758 : map = gel(spl, 4);
6234 2758 : tau = pr_anti_uniformizer(nf, pr);
6235 2758 : m = degpol(T);
6236 2758 : k = lg(gmael(spl,2,1)) - 1;
6237 2758 : if (typ(tau) != t_INT) tau = algbasismultable(al,algeltfromnf_i(al,tau));
6238 2758 : data = mkvecn(7,
6239 : pr,
6240 : mkvecsmall2(k, m),
6241 : Tp_to_FF(T,p),
6242 : FpM_mul(map, pro, p),
6243 : FpM_mul(lif, mapi, p),
6244 : tau,
6245 : T
6246 : );
6247 2758 : return gerepilecopy(av, data);
6248 : }
6249 :
6250 : static int
6251 2135 : checkalgmodpr_i(GEN data)
6252 : {
6253 : GEN compo;
6254 2135 : if (typ(data)!=t_VEC || lg(data)!=8) return 0;
6255 2121 : checkprid(gel(data,1));
6256 2114 : compo = gel(data,2);
6257 2114 : if (typ(compo)!=t_VECSMALL || lg(compo)!=3) return 0;
6258 2107 : if (typ(gel(data,3))!=t_FFELT) return 0;
6259 2100 : if (typ(gel(data,4))!=t_MAT) return 0;
6260 2093 : if (typ(gel(data,5))!=t_MAT) return 0;
6261 2086 : compo = gel(data,6);
6262 2086 : if (typ(compo)!=t_MAT && (typ(compo)!=t_INT || !equali1(compo))) return 0;
6263 2079 : if (typ(gel(data,7))!=t_POL) return 0;
6264 2072 : return 1;
6265 : }
6266 : static void
6267 2135 : checkalgmodpr(GEN data)
6268 : {
6269 2135 : if(!checkalgmodpr_i(data))
6270 56 : pari_err_TYPE("checkalgmodpr [use algmodprinit()]", data);
6271 2072 : }
6272 :
6273 : /* x belongs to the stored order of al, no GC */
6274 : static GEN
6275 1708 : algmodpr_integral(GEN x, GEN data, long reduce)
6276 : {
6277 : GEN res, T, p;
6278 1708 : long k, m, v = -1;
6279 1708 : T = algmodpr_get_T(data);
6280 1708 : if (T) v = varn(T);
6281 1708 : p = algmodpr_get_p(data);
6282 1708 : k = algmodpr_get_k(data);
6283 1708 : m = algmodpr_get_m(data);
6284 1708 : res = ZM_ZC_mul(algmodpr_get_proj(data), x);
6285 1708 : res = RgC_col2mat(res, k, m, v);
6286 1708 : return reduce? FqM_red(res, T, p) : res;
6287 : }
6288 :
6289 : /* x in basis form */
6290 : static GEN
6291 1729 : algmodpr_i(GEN x, GEN data)
6292 : {
6293 : GEN T, p, res, den, tau;
6294 : long v, i, j;
6295 1729 : x = Q_remove_denom(x, &den);
6296 1729 : T = algmodpr_get_T(data);
6297 1729 : p = algmodpr_get_p(data);
6298 1729 : tau = algmodpr_get_tau(data);
6299 1729 : if (den)
6300 : {
6301 35 : v = Z_pvalrem(den, p, &den);
6302 35 : if (v && typ(tau)!=t_INT)
6303 : {
6304 : /* TODO not always better to exponentiate the matrix */
6305 21 : x = ZM_ZC_mul(ZM_powu(tau, v), x);
6306 21 : v -= ZV_pvalrem(x, p, &x);
6307 : }
6308 35 : if (v>0) pari_err_INV("algmodpr", mkintmod(gen_0,p));
6309 21 : if (v<0)
6310 : {
6311 7 : long k = algmodpr_get_k(data);
6312 7 : return zeromatcopy(k,k);
6313 : }
6314 14 : if (equali1(den)) den = NULL;
6315 : }
6316 1708 : res = algmodpr_integral(x, data, 0);
6317 1708 : if (den)
6318 : {
6319 7 : GEN d = Fp_inv(den, p);
6320 21 : for (j=1; j<lg(res); j++)
6321 42 : for (i=1; i<lg(res); i++)
6322 28 : gcoeff(res,i,j) = Fq_Fp_mul(gcoeff(res,i,j), d, T, p);
6323 : }
6324 1701 : else res = FqM_red(res, T, p);
6325 1708 : return res;
6326 : }
6327 :
6328 : static GEN
6329 28 : algmodpr_mat(GEN al, GEN x, GEN data)
6330 : {
6331 : GEN res, cx, c;
6332 : long i, j;
6333 28 : res = cgetg(lg(x),t_MAT);
6334 133 : for (j=1; j<lg(x); j++)
6335 : {
6336 105 : cx = gel(x,j);
6337 105 : c = cgetg(lg(cx), t_COL);
6338 525 : for (i=1; i<lg(cx); i++) gel(c,i) = algmodpr(al, gel(cx,i), data);
6339 105 : gel(res, j) = c;
6340 : }
6341 28 : return shallowmatconcat(res);
6342 : }
6343 :
6344 : GEN
6345 1841 : algmodpr(GEN al, GEN x, GEN data)
6346 : {
6347 1841 : pari_sp av = avma;
6348 : GEN res, ff;
6349 1841 : checkalgmodpr(data);
6350 1785 : if (typ(x) == t_MAT) return gerepilecopy(av, algmodpr_mat(al,x,data));
6351 1757 : x = algalgtobasis(al, x);
6352 1729 : res = algmodpr_i(x, data);
6353 1715 : ff = algmodpr_get_ff(data);
6354 1715 : return gerepilecopy(av, FqM_to_FFM(res,ff));
6355 : }
6356 :
6357 : static GEN
6358 511 : algmodprlift_i(GEN x, GEN data)
6359 : {
6360 511 : GEN lift, C, p, c, T = NULL;
6361 : long i, j, k, m;
6362 511 : lift = algmodpr_get_lift(data);
6363 511 : p = algmodpr_get_p(data);
6364 511 : k = algmodpr_get_k(data);
6365 511 : m = algmodpr_get_m(data); /* M_k(F_p^m) */
6366 511 : if (m > 1) T = algmodpr_get_T(data);
6367 511 : x = gcopy(x);
6368 1561 : for (i=1; i<=k; i++)
6369 3689 : for (j=1; j<=k; j++)
6370 : {
6371 2639 : c = gcoeff(x,i,j);
6372 2639 : if (typ(c) == t_FFELT) gcoeff(x,i,j) = FF_to_FpXQ(c);
6373 119 : else if (m == 1) gcoeff(x,i,j) = scalarpol(Rg_to_Fp(c,p), -1);
6374 91 : else gcoeff(x,i,j) = Rg_to_FpXQ(c, T, p);
6375 : }
6376 504 : C = RgM_mat2col(x, k, m);
6377 504 : return FpM_FpC_mul(lift, C, p);
6378 : }
6379 :
6380 : GEN
6381 301 : algmodprlift(GEN al, GEN x, GEN data)
6382 : {
6383 301 : pari_sp av = avma;
6384 : GEN res, blk;
6385 : long k, nc, nr, i, j;
6386 301 : checkalg(al);
6387 294 : checkalgmodpr(data);
6388 287 : k = algmodpr_get_k(data); /* M_k(F_p^m) */
6389 287 : if (typ(x) != t_MAT) pari_err_TYPE("algmodprlift [matrix x]",x);
6390 280 : if ((lg(x)-1)%k) pari_err_DIM("algmodprlift [matrix x, nb cols]");
6391 273 : nc = (lg(x)-1)/k;
6392 273 : if (!nc) return gerepileupto(av, zeromat(0,0));
6393 266 : if ((lgcols(x)-1)%k) pari_err_DIM("algmodprlift [matrix x, nb rows]");
6394 259 : nr = nbrows(x)/k;
6395 259 : if (nr==1 && nc==1) res = algmodprlift_i(x, data);
6396 : else
6397 : {
6398 28 : res = zeromatcopy(nr, nc);
6399 119 : for (i=1; i<=nr; i++)
6400 371 : for(j=1; j<=nc; j++)
6401 : {
6402 280 : blk = matslice(x, (i-1)*k+1, i*k, (j-1)*k+1, j*k);
6403 280 : gcoeff(res,i,j) = algmodprlift_i(blk, data);
6404 : }
6405 : }
6406 252 : return gerepilecopy(av, res);
6407 : }
6408 :
6409 : /* e in al such that e mod pr is a non-invertible idempotent of maximal rank */
6410 : static GEN
6411 2499 : eichleridempotent(GEN al, GEN pr)
6412 : {
6413 : long i, k, n, nk, j;
6414 : GEN data, mapi, e;
6415 2499 : data = algmodprinit(al, pr, -1);
6416 2492 : mapi = algmodpr_get_lift(data);
6417 2492 : k = algmodpr_get_k(data);
6418 2492 : n = pr_get_f(pr);
6419 2492 : nk = n*(k+1);
6420 2492 : if (k==1) return zerocol(alg_get_absdim(al));
6421 1820 : e = gel(mapi,1+nk);
6422 2681 : for (i = 2, j = 1+2*nk; i < k; i++, j += nk) e = ZC_add(e,gel(mapi,j));
6423 1820 : return e;
6424 : }
6425 :
6426 : static GEN
6427 2492 : mat_algeltfromnf(GEN al, GEN x)
6428 : {
6429 6244 : pari_APPLY_type(t_MAT, algeltfromnf_i(al, gel(x,i)));
6430 : }
6431 : static GEN
6432 2499 : eichlerprimepower_i(GEN al, GEN pr, long m, GEN prm)
6433 : {
6434 : GEN p, e, polidem, Me, Mzk, nf, Mprm;
6435 : long ep, i;
6436 : ulong mask;
6437 2499 : polidem = mkpoln(4, gen_m2, utoi(3), gen_0, gen_0);
6438 2499 : p = pr_get_p(pr); ep = pr_get_e(pr);
6439 2499 : e = eichleridempotent(al, pr); /* ZC */
6440 2492 : mask = quadratic_prec_mask(m);
6441 2492 : i = 1;
6442 6769 : while (mask > 1)
6443 : {
6444 4277 : i *=2;
6445 4277 : if (mask & 1UL) i--;
6446 4277 : mask >>= 1;
6447 4277 : e = algpoleval(al, polidem, e);
6448 4277 : e = FpC_red(e, powiu(p,(i+ep-1)/ep));
6449 : }
6450 2492 : Me = algbasisrightmultable(al, e);
6451 2492 : nf = algcenter(al);
6452 2492 : Mzk = mat_algeltfromnf(al, nf_get_zk(nf));
6453 2492 : prm = idealtwoelt(nf, prm);
6454 2492 : Mprm = algbasismultable(al, algeltfromnf_i(al,gel(prm,2)));
6455 2492 : return hnfmodid(shallowmatconcat(mkvec3(Me,Mzk,Mprm)), gel(prm,1));
6456 : }
6457 : static GEN
6458 546 : eichlerprimepower(GEN al, GEN pr, long m, GEN prm)
6459 : {
6460 546 : pari_sp av = avma;
6461 546 : return gerepileupto(av, eichlerprimepower_i(al, pr, m, prm));
6462 : }
6463 :
6464 : GEN
6465 2100 : algeichlerbasis(GEN al, GEN N)
6466 : {
6467 2100 : pari_sp av = avma;
6468 2100 : GEN nf, faN, LH = NULL, Cpr = NULL, Cm = NULL, Lpp, M, H, pp, LH2;
6469 : long k, n, ih, lh, np;
6470 :
6471 2100 : checkalg(al);
6472 2093 : nf = alg_get_center(al);
6473 2086 : if (checkprid_i(N)) return eichlerprimepower(al,N,1,N);
6474 2065 : if (is_nf_factor(N))
6475 : {
6476 2037 : faN = sort_factor(shallowcopy(N), (void*)&cmp_prime_ideal, &cmp_nodata);
6477 2037 : N = factorbackprime(nf, gel(faN,1), gel(faN,2));
6478 : }
6479 28 : else faN = idealfactor(nf, N);
6480 2051 : n = nbrows(faN);
6481 2051 : if (!n) { set_avma(av); return matid(alg_get_absdim(al)); }
6482 2044 : if (n==1)
6483 : {
6484 1953 : GEN pr = gcoeff(faN,1,1), mZ = gcoeff(faN,1,2);
6485 1953 : long m = itos(mZ);
6486 1953 : return gerepileupto(av, eichlerprimepower_i(al, pr, m, N));
6487 : }
6488 :
6489 : /* collect prime power Eichler orders */
6490 91 : Lpp = cgetg(n+1,t_VEC);
6491 91 : LH2 = cgetg(n+1, t_VEC);
6492 91 : np = 0;
6493 91 : ih = 1;
6494 91 : lh = 1;
6495 616 : for (k = 1; k <= n; k++)
6496 : {
6497 525 : GEN pr = gcoeff(faN,k,1), mZ = gcoeff(faN,k,2), prm;
6498 525 : long m = itos(mZ);
6499 :
6500 525 : if (ih == lh) /* done with previous p, prepare next */
6501 : {
6502 462 : GEN p = pr_get_p(pr);
6503 462 : long k2 = k + 1;
6504 462 : np++;
6505 462 : gel(Lpp,np) = gen_0;
6506 462 : lh = 2;
6507 : /* count the pr|p in faN */
6508 525 : while (k2<=n && equalii(p,pr_get_p(gcoeff(faN,k2,1)))) { lh++; k2++; }
6509 462 : LH = cgetg(lh, t_VEC);
6510 462 : Cpr = cgetg(lh, t_VEC);
6511 462 : Cm = cgetg(lh, t_VEC);
6512 462 : ih = 1;
6513 : }
6514 525 : prm = idealpow(nf, pr, mZ);
6515 525 : H = eichlerprimepower(al, pr, m, prm);
6516 525 : pp = gcoeff(prm,1,1);
6517 525 : if (cmpii(pp,gel(Lpp,np)) > 0) gel(Lpp,np) = pp;
6518 525 : gel(LH,ih) = H;
6519 525 : gel(Cpr,ih) = pr;
6520 525 : gel(Cm,ih) = mZ;
6521 525 : ih++;
6522 :
6523 525 : if (ih == lh) /* done with this p */
6524 : {
6525 462 : if (lh == 2) gel(LH2,np) = gel(LH,1);
6526 : else
6527 : { /* put together the pr|p */
6528 63 : GEN U = gmael(idealchineseinit(nf, mkmat2(Cpr,Cm)),1,2);
6529 : long i;
6530 189 : for (i = 1; i < lh; i++)
6531 : {
6532 126 : GEN e = algeltfromnf_i(al, gel(U,i));
6533 126 : e = algbasismultable(al, e);
6534 126 : gel(LH,i) = ZM_mul(e, gel(LH,i));
6535 : }
6536 63 : gel(LH2,np) = hnfmodid(shallowmatconcat(LH), gel(Lpp,np));
6537 : }
6538 : }
6539 : }
6540 91 : if (np == 1) return gerepilecopy(av, gel(LH2,1));
6541 : /* put together all p */
6542 84 : setlg(Lpp,np+1);
6543 84 : setlg(LH2,np+1);
6544 84 : H = nmV_chinese_center(LH2, Lpp, &M);
6545 84 : return gerepileupto(av, hnfmodid(H, M));
6546 : }
6547 :
6548 : /** IDEALS **/
|
