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