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