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