Line data Source code
1 : /* Copyright (C) 2011 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
14 :
15 : #include "pari.h"
16 : #include "paripriv.h"
17 :
18 : #define DEBUGLEVEL DEBUGLEVEL_ms
19 :
20 : /* Adapted from shp_package/moments by Robert Pollack
21 : * http://www.math.mcgill.ca/darmon/programs/shp/shp.html */
22 : static GEN mskinit(ulong N, long k, long sign);
23 : static GEN mshecke_i(GEN W, ulong p);
24 : static GEN ZSl2_star(GEN v);
25 : static GEN getMorphism(GEN W1, GEN W2, GEN v);
26 : static GEN voo_act_Gl2Q(GEN g, long k);
27 :
28 : /* Input: P^1(Z/NZ) (formed by create_p1mod)
29 : Output: # P^1(Z/NZ) */
30 : static long
31 16912 : p1_size(GEN p1N) { return lg(gel(p1N,1)) - 1; }
32 : static ulong
33 58034571 : p1N_get_N(GEN p1N) { return gel(p1N,3)[2]; }
34 : static GEN
35 26970132 : p1N_get_hash(GEN p1N) { return gel(p1N,2); }
36 : static GEN
37 4368 : p1N_get_fa(GEN p1N) { return gel(p1N,4); }
38 : static GEN
39 4256 : p1N_get_div(GEN p1N) { return gel(p1N,5); }
40 : static GEN
41 24172918 : p1N_get_invsafe(GEN p1N) { return gel(p1N,6); }
42 : static GEN
43 8018752 : p1N_get_inverse(GEN p1N) { return gel(p1N,7); }
44 :
45 : /* ms-specific accessors */
46 : /* W = msinit, return the output of msinit_N */
47 : static GEN
48 5446287 : get_msN(GEN W) { return lg(W) == 4? gel(W,1): W; }
49 : static GEN
50 3257100 : msN_get_p1N(GEN W) { return gel(W,1); }
51 : static GEN
52 213969 : msN_get_genindex(GEN W) { return gel(W,5); }
53 : static GEN
54 42388682 : msN_get_E2fromE1(GEN W) { return gel(W,7); }
55 : static GEN
56 1393 : msN_get_annT2(GEN W) { return gel(W,8); }
57 : static GEN
58 1393 : msN_get_annT31(GEN W) { return gel(W,9); }
59 : static GEN
60 1358 : msN_get_singlerel(GEN W) { return gel(W,10); }
61 : static GEN
62 926352 : msN_get_section(GEN W) { return gel(W,12); }
63 :
64 : static GEN
65 122003 : ms_get_p1N(GEN W) { return msN_get_p1N(get_msN(W)); }
66 : static long
67 96523 : ms_get_N(GEN W) { return p1N_get_N(ms_get_p1N(W)); }
68 : static GEN
69 1680 : ms_get_hashcusps(GEN W) { W = get_msN(W); return gel(W,16); }
70 : static GEN
71 29953 : ms_get_section(GEN W) { return msN_get_section(get_msN(W)); }
72 : static GEN
73 204050 : ms_get_genindex(GEN W) { return msN_get_genindex(get_msN(W)); }
74 : static long
75 199444 : ms_get_nbgen(GEN W) { return lg(ms_get_genindex(W))-1; }
76 : static long
77 2618315 : ms_get_nbE1(GEN W)
78 : {
79 : GEN W11;
80 2618315 : W = get_msN(W); W11 = gel(W,11);
81 2618315 : return W11[4] - W11[3];
82 : }
83 :
84 : /* msk-specific accessors */
85 : static long
86 126 : msk_get_dim(GEN W) { return gmael(W,3,2)[2]; }
87 : static GEN
88 82516 : msk_get_basis(GEN W) { return gmael(W,3,1); }
89 : static long
90 130613 : msk_get_weight(GEN W) { return gmael(W,3,2)[1]; }
91 : static long
92 59724 : msk_get_sign(GEN W)
93 : {
94 59724 : GEN t = gel(W,2);
95 59724 : return typ(t)==t_INT? 0: itos(gel(t,1));
96 : }
97 : static GEN
98 3101 : msk_get_star(GEN W) { return gmael(W,2,2); }
99 : static GEN
100 3710 : msk_get_starproj(GEN W) { return gmael(W,2,3); }
101 :
102 : static int
103 2576 : is_Qevproj(GEN x)
104 2576 : { return typ(x) == t_VEC && lg(x) == 5 && typ(gel(x,1)) == t_MAT; }
105 : long
106 224 : msdim(GEN W)
107 : {
108 224 : if (is_Qevproj(W)) return lg(gel(W,1)) - 1;
109 210 : checkms(W);
110 203 : if (!msk_get_sign(W)) return msk_get_dim(W);
111 91 : return lg(gel(msk_get_starproj(W), 1)) - 1;
112 : }
113 : long
114 14 : msgetlevel(GEN W) { checkms(W); return ms_get_N(W); }
115 : long
116 14 : msgetweight(GEN W) { checkms(W); return msk_get_weight(W); }
117 : long
118 28 : msgetsign(GEN W) { checkms(W); return msk_get_sign(W); }
119 :
120 : void
121 79135 : checkms(GEN W)
122 : {
123 79135 : if (typ(W) != t_VEC || lg(W) != 4
124 79135 : || typ(gel(W,1)) != t_VEC || lg(gel(W,1)) != 17)
125 7 : pari_err_TYPE("checkms [please apply msinit]", W);
126 79128 : }
127 :
128 : /** MODULAR TO SYM **/
129 :
130 : /* q a t_FRAC or t_INT */
131 : static GEN
132 2246944 : Q_log_init(ulong N, GEN q)
133 : {
134 : long l, n;
135 : GEN Q;
136 :
137 2246944 : q = gboundcf(q, 0);
138 2246944 : l = lg(q);
139 2246944 : Q = cgetg(l, t_VECSMALL);
140 2246944 : Q[1] = 1;
141 21386904 : for (n=2; n <l; n++) Q[n] = umodiu(gel(q,n), N);
142 19145098 : for (n=3; n < l; n++)
143 16898154 : Q[n] = Fl_add(Fl_mul(Q[n], Q[n-1], N), Q[n-2], N);
144 2246944 : return Q;
145 : }
146 :
147 : /** INIT MODSYM STRUCTURE, WEIGHT 2 **/
148 :
149 : /* num = [Gamma : Gamma_0(N)] = N * Prod_{p|N} (1+p^-1) */
150 : static ulong
151 4256 : count_Manin_symbols(ulong N, GEN P)
152 : {
153 4256 : long i, l = lg(P);
154 4256 : ulong num = N;
155 12019 : for (i = 1; i < l; i++) { ulong p = P[i]; num *= p+1; num /= p; }
156 4256 : return num;
157 : }
158 : /* returns the list of "Manin symbols" (c,d) in (Z/NZ)^2, (c,d,N) = 1
159 : * generating H^1(X_0(N), Z) */
160 : static GEN
161 4256 : generatemsymbols(ulong N, ulong num, GEN divN)
162 : {
163 4256 : GEN ret = cgetg(num+1, t_VEC);
164 4256 : ulong c, d, curn = 0;
165 : long i, l;
166 : /* generate Manin-symbols in two lists: */
167 : /* list 1: (c:1) for 0 <= c < N */
168 358232 : for (c = 0; c < N; c++) gel(ret, ++curn) = mkvecsmall2(c, 1);
169 4256 : if (N == 1) return ret;
170 : /* list 2: (c:d) with 1 <= c < N, c | N, 0 <= d < N, gcd(d,N) > 1, gcd(c,d)=1.
171 : * Furthermore, d != d0 (mod N/c) with c,d0 already in the list */
172 4228 : l = lg(divN) - 1;
173 : /* c = 1 first */
174 4228 : gel(ret, ++curn) = mkvecsmall2(1,0);
175 349720 : for (d = 2; d < N; d++)
176 345492 : if (ugcd(d,N) != 1UL)
177 141806 : gel(ret, ++curn) = mkvecsmall2(1,d);
178 : /* omit c = 1 (first) and c = N (last) */
179 17969 : for (i=2; i < l; i++)
180 : {
181 : ulong Novc, d0;
182 13741 : c = divN[i];
183 13741 : Novc = N / c;
184 230118 : for (d0 = 2; d0 <= Novc; d0++)
185 : {
186 216377 : ulong k, d = d0;
187 216377 : if (ugcd(d, Novc) == 1UL) continue;
188 320397 : for (k = 0; k < c; k++, d += Novc)
189 286405 : if (ugcd(c,d) == 1UL)
190 : {
191 54320 : gel(ret, ++curn) = mkvecsmall2(c,d);
192 54320 : break;
193 : }
194 : }
195 : }
196 4228 : if (curn != num) pari_err_BUG("generatemsymbols [wrong number of symbols]");
197 4228 : return ret;
198 : }
199 :
200 : static GEN
201 4256 : inithashmsymbols(ulong N, GEN symbols)
202 : {
203 4256 : GEN H = zerovec(N);
204 4256 : long k, l = lg(symbols);
205 : /* skip the (c:1), 0 <= c < N and (1:0) */
206 200382 : for (k=N+2; k < l; k++)
207 : {
208 196126 : GEN s = gel(symbols, k);
209 196126 : ulong c = s[1], d = s[2], Novc = N/c;
210 196126 : if (gel(H,c) == gen_0) gel(H,c) = const_vecsmall(Novc+1,0);
211 196126 : if (c != 1) { d %= Novc; if (!d) d = Novc; }
212 196126 : mael(H, c, d) = k;
213 : }
214 4256 : return H;
215 : }
216 :
217 : /** Helper functions for Sl2(Z) / Gamma_0(N) **/
218 : /* M a 2x2 ZM in SL2(Z) */
219 : GEN
220 1275477 : SL2_inv_shallow(GEN M)
221 : {
222 1275477 : GEN a = gcoeff(M,1,1), b = gcoeff(M,1,2);
223 1275477 : GEN c = gcoeff(M,2,1), d = gcoeff(M,2,2);
224 1275477 : retmkmat22(d,negi(b), negi(c),a);
225 : }
226 : /* SL2_inv(M)[2] */
227 : static GEN
228 41804 : SL2_inv2(GEN M)
229 : {
230 41804 : GEN a = gcoeff(M,1,1), b = gcoeff(M,1,2);
231 41804 : return mkcol2(negi(b),a);
232 : }
233 : /* M a 2x2 mat2 in SL2(Z) */
234 : static GEN
235 886529 : sl2_inv(GEN M)
236 : {
237 886529 : long a=coeff(M,1,1), b=coeff(M,1,2), c=coeff(M,2,1), d=coeff(M,2,2);
238 886529 : return mkvec2(mkvecsmall2(d, -c), mkvecsmall2(-b, a));
239 : }
240 : /* Return the mat2 [a,b; c,d], not a zm to avoid GP problems */
241 : static GEN
242 3136735 : mat2(long a, long b, long c, long d)
243 3136735 : { return mkvec2(mkvecsmall2(a,c), mkvecsmall2(b,d)); }
244 : static GEN
245 633346 : mat2_to_ZM(GEN M)
246 : {
247 633346 : GEN A = gel(M,1), B = gel(M,2);
248 633346 : retmkmat2(mkcol2s(A[1],A[2]), mkcol2s(B[1],B[2]));
249 : }
250 :
251 : /* Input: a = 2-vector = path = {r/s,x/y}
252 : * Output: either [r,x;s,y] or [-r,x;-s,y], whichever has determinant > 0 */
253 : static GEN
254 194327 : path_to_ZM(GEN a)
255 : {
256 194327 : GEN v = gel(a,1), w = gel(a,2);
257 194327 : long r = v[1], s = v[2], x = w[1], y = w[2];
258 194327 : if (cmpii(mulss(r,y), mulss(x,s)) < 0) { r = -r; s = -s; }
259 194327 : return mkmat22s(r,x,s,y);
260 : }
261 : static GEN
262 1954169 : path_to_zm(GEN a)
263 : {
264 1954169 : GEN v = gel(a,1), w = gel(a,2);
265 1954169 : long r = v[1], s = v[2], x = w[1], y = w[2];
266 1954169 : if (cmpii(mulss(r,y), mulss(x,s)) < 0) { r = -r; s = -s; }
267 1954169 : return mat2(r,x,s,y);
268 : }
269 : /* path from c1 to c2 */
270 : static GEN
271 1124039 : mkpath(GEN c1, GEN c2) { return mat2(c1[1], c2[1], c1[2], c2[2]); }
272 : static long
273 1589847 : cc(GEN M) { GEN v = gel(M,1); return v[2]; }
274 : static long
275 1589847 : dd(GEN M) { GEN v = gel(M,2); return v[2]; }
276 :
277 : /*Input: a,b = 2 paths, N = integer
278 : *Output: 1 if the a,b are \Gamma_0(N)-equivalent; 0 otherwise */
279 : static int
280 182798 : gamma_equiv(GEN a, GEN b, ulong N)
281 : {
282 182798 : pari_sp av = avma;
283 182798 : GEN m = path_to_zm(a);
284 182798 : GEN n = path_to_zm(b);
285 182798 : GEN d = subii(mulss(cc(m),dd(n)), mulss(dd(m),cc(n)));
286 182798 : return gc_bool(av, umodiu(d, N) == 0);
287 : }
288 : /* Input: a,b = 2 paths that are \Gamma_0(N)-equivalent, N = integer
289 : * Output: M in \Gamma_0(N) such that Mb=a */
290 : static GEN
291 96425 : gamma_equiv_matrix(GEN a, GEN b)
292 : {
293 96425 : GEN m = path_to_ZM(a);
294 96425 : GEN n = path_to_ZM(b);
295 96425 : return ZM_mul(m, SL2_inv_shallow(n));
296 : }
297 :
298 : /*************/
299 : /* P^1(Z/NZ) */
300 : /*************/
301 : /* a != 0 in Z/NZ. Return v in (Z/NZ)^* such that av = gcd(a, N) (mod N)*/
302 : static ulong
303 551481 : Fl_inverse(ulong a, ulong N) { ulong g; return Fl_invgen(a,N,&g); }
304 :
305 : /* Input: N = integer
306 : * Output: creates P^1(Z/NZ) = [symbols, H, N]
307 : * symbols: list of vectors [x,y] that give a set of representatives
308 : * of P^1(Z/NZ)
309 : * H: an M by M grid whose value at the r,c-th place is the index of the
310 : * "standard representative" equivalent to [r,c] occurring in the first
311 : * list. If gcd(r,c,N) > 1 the grid has value 0. */
312 : static GEN
313 4256 : create_p1mod(ulong N)
314 : {
315 4256 : GEN fa = factoru(N), div = divisorsu_fact(fa);
316 4256 : ulong i, nsym = count_Manin_symbols(N, gel(fa,1));
317 4256 : GEN symbols = generatemsymbols(N, nsym, div);
318 4256 : GEN H = inithashmsymbols(N,symbols);
319 4256 : GEN invsafe = cgetg(N, t_VECSMALL), inverse = cgetg(N, t_VECSMALL);
320 353976 : for (i = 1; i < N; i++)
321 : {
322 349720 : invsafe[i] = Fl_invsafe(i,N);
323 349720 : inverse[i] = Fl_inverse(i,N);
324 : }
325 4256 : return mkvecn(7, symbols, H, utoipos(N), fa, div, invsafe, inverse);
326 : }
327 :
328 : /* Let (c : d) in P1(Z/NZ).
329 : * If c = 0 return (0:1). If d = 0 return (1:0).
330 : * Else replace by (cu : du), where u in (Z/NZ)^* such that C := cu = gcd(c,N).
331 : * In create_p1mod(), (c : d) is represented by (C:D) where D = du (mod N/c)
332 : * is smallest such that gcd(C,D) = 1. Return (C : du mod N/c), which need
333 : * not belong to P1(Z/NZ) ! A second component du mod N/c = 0 is replaced by
334 : * N/c in this case to avoid problems with array indices */
335 : static void
336 26970132 : p1_std_form(long *pc, long *pd, GEN p1N)
337 : {
338 26970132 : ulong N = p1N_get_N(p1N);
339 : ulong u;
340 26970132 : *pc = umodsu(*pc, N); if (!*pc) { *pd = 1; return; }
341 24448039 : *pd = umodsu(*pd, N); if (!*pd) { *pc = 1; return; }
342 24172918 : u = p1N_get_invsafe(p1N)[*pd];
343 24172918 : if (u) { *pc = Fl_mul(*pc,u,N); *pd = 1; return; } /* (d,N) = 1 */
344 :
345 8018752 : u = p1N_get_inverse(p1N)[*pc];
346 8018752 : if (u > 1) { *pc = Fl_mul(*pc,u,N); *pd = Fl_mul(*pd,u,N); }
347 : /* c | N */
348 8018752 : if (*pc != 1) *pd %= (N / *pc);
349 8018752 : if (!*pd) *pd = N / *pc;
350 : }
351 :
352 : /* Input: v = [x,y] = elt of P^1(Z/NZ) = class in Gamma_0(N) \ PSL2(Z)
353 : * Output: returns the index of the standard rep equivalent to v */
354 : static long
355 26970132 : p1_index(long x, long y, GEN p1N)
356 : {
357 26970132 : ulong N = p1N_get_N(p1N);
358 26970132 : GEN H = p1N_get_hash(p1N);
359 :
360 26970132 : p1_std_form(&x, &y, p1N);
361 26970132 : if (y == 1) return x+1;
362 8293873 : if (y == 0) return N+1;
363 8018752 : if (mael(H,x,y) == 0) pari_err_BUG("p1_index");
364 8018752 : return mael(H,x,y);
365 : }
366 :
367 : /* Cusps for \Gamma_0(N) */
368 :
369 : /* \sum_{d | N} \phi(gcd(d, N/d)), using multiplicativity. fa = factor(N) */
370 : ulong
371 4340 : mfnumcuspsu_fact(GEN fa)
372 : {
373 4340 : GEN P = gel(fa,1), E = gel(fa,2);
374 4340 : long i, l = lg(P);
375 4340 : ulong T = 1;
376 12201 : for (i = 1; i < l; i++)
377 : {
378 7861 : long e = E[i], e2 = e >> 1; /* floor(E[i] / 2) */
379 7861 : ulong p = P[i];
380 7861 : if (odd(e))
381 6559 : T *= 2 * upowuu(p, e2);
382 : else
383 1302 : T *= (p+1) * upowuu(p, e2-1);
384 : }
385 4340 : return T;
386 : }
387 : ulong
388 7 : mfnumcuspsu(ulong n)
389 7 : { pari_sp av = avma; return gc_ulong(av, mfnumcuspsu_fact( factoru(n) )); }
390 : /* \sum_{d | N} \phi(gcd(d, N/d)), using multiplicativity. fa = factor(N) */
391 : GEN
392 14 : mfnumcusps_fact(GEN fa)
393 : {
394 14 : GEN P = gel(fa,1), E = gel(fa,2), T = gen_1;
395 14 : long i, l = lg(P);
396 35 : for (i = 1; i < l; i++)
397 : {
398 21 : GEN p = gel(P,i), c;
399 21 : long e = itos(gel(E,i)), e2 = e >> 1; /* floor(E[i] / 2) */
400 21 : if (odd(e))
401 0 : c = shifti(powiu(p, e2), 1);
402 : else
403 21 : c = mulii(addiu(p,1), powiu(p, e2-1));
404 21 : T = T? mulii(T, c): c;
405 : }
406 14 : return T? T: gen_1;
407 : }
408 : GEN
409 21 : mfnumcusps(GEN n)
410 : {
411 21 : pari_sp av = avma;
412 21 : GEN F = check_arith_pos(n,"mfnumcusps");
413 21 : if (!F)
414 : {
415 14 : if (lgefint(n) == 3) return utoi( mfnumcuspsu(n[2]) );
416 7 : F = absZ_factor(n);
417 : }
418 14 : return gerepileuptoint(av, mfnumcusps_fact(F));
419 : }
420 :
421 : /* to each cusp in \Gamma_0(N) P1(Q), represented by p/q, we associate a
422 : * unique index. Canonical representative: (1:0) or (p:q) with q | N, q < N,
423 : * p defined modulo d := gcd(N/q,q), (p,d) = 1.
424 : * Return [[N, nbcusps], H, cusps]*/
425 : static GEN
426 4256 : inithashcusps(GEN p1N)
427 : {
428 4256 : ulong N = p1N_get_N(p1N);
429 4256 : GEN div = p1N_get_div(p1N), H = zerovec(N+1);
430 4256 : long k, ind, l = lg(div), ncusp = mfnumcuspsu_fact(p1N_get_fa(p1N));
431 4256 : GEN cusps = cgetg(ncusp+1, t_VEC);
432 :
433 4256 : gel(H,1) = mkvecsmall2(0/*empty*/, 1/* first cusp: (1:0) */);
434 4256 : gel(cusps, 1) = mkvecsmall2(1,0);
435 4256 : ind = 2;
436 22225 : for (k=1; k < l-1; k++) /* l-1: remove q = N */
437 : {
438 17969 : ulong p, q = div[k], d = ugcd(q, N/q);
439 17969 : GEN h = const_vecsmall(d+1,0);
440 17969 : gel(H,q+1) = h ;
441 48034 : for (p = 0; p < d; p++)
442 30065 : if (ugcd(p,d) == 1)
443 : {
444 22925 : h[p+1] = ind;
445 22925 : gel(cusps, ind) = mkvecsmall2(p,q);
446 22925 : ind++;
447 : }
448 : }
449 4256 : return mkvec3(mkvecsmall2(N,ind-1), H, cusps);
450 : }
451 : /* c = [p,q], (p,q) = 1, return a canonical representative for
452 : * \Gamma_0(N)(p/q) */
453 : static GEN
454 203469 : cusp_std_form(GEN c, GEN S)
455 : {
456 203469 : long p, N = gel(S,1)[1], q = umodsu(c[2], N);
457 : ulong u, d;
458 203469 : if (q == 0) return mkvecsmall2(1, 0);
459 201761 : p = umodsu(c[1], N);
460 201761 : u = Fl_inverse(q, N);
461 201761 : q = Fl_mul(q,u, N);
462 201761 : d = ugcd(q, N/q);
463 201761 : return mkvecsmall2(Fl_div(p % d,u % d, d), q);
464 : }
465 : /* c = [p,q], (p,q) = 1, return the index of the corresponding cusp.
466 : * S from inithashcusps */
467 : static ulong
468 203469 : cusp_index(GEN c, GEN S)
469 : {
470 : long p, q;
471 203469 : GEN H = gel(S,2);
472 203469 : c = cusp_std_form(c, S);
473 203469 : p = c[1]; q = c[2];
474 203469 : if (!mael(H,q+1,p+1)) pari_err_BUG("cusp_index");
475 203469 : return mael(H,q+1,p+1);
476 : }
477 :
478 : /* M a square invertible ZM, return a ZM iM such that iM M = M iM = d.Id */
479 : static GEN
480 3066 : ZM_inv_denom(GEN M)
481 : {
482 3066 : GEN diM, iM = ZM_inv(M, &diM);
483 3066 : return mkvec2(iM, diM);
484 : }
485 : /* return M^(-1) v, dinv = ZM_inv_denom(M) OR Qevproj_init(M) */
486 : static GEN
487 744023 : ZC_apply_dinv(GEN dinv, GEN v)
488 : {
489 : GEN x, c, iM;
490 744023 : if (lg(dinv) == 3)
491 : {
492 665917 : iM = gel(dinv,1);
493 665917 : c = gel(dinv,2);
494 : }
495 : else
496 : { /* Qevproj_init */
497 78106 : iM = gel(dinv,2);
498 78106 : c = gel(dinv,3);
499 78106 : v = typ(v) == t_MAT? rowpermute(v, gel(dinv,4))
500 78106 : : vecpermute(v, gel(dinv,4));
501 : }
502 744023 : x = RgM_RgC_mul(iM, v);
503 744023 : if (!isint1(c)) x = RgC_Rg_div(x, c);
504 744023 : return x;
505 : }
506 :
507 : /* M an n x d ZM of rank d (basis of a Q-subspace), n >= d.
508 : * Initialize a projector on M */
509 : GEN
510 8225 : Qevproj_init(GEN M)
511 : {
512 : GEN v, perm, MM, iM, diM;
513 8225 : v = ZM_indexrank(M); perm = gel(v,1);
514 8225 : MM = rowpermute(M, perm); /* square invertible */
515 8225 : iM = ZM_inv(MM, &diM);
516 8225 : return mkvec4(M, iM, diM, perm);
517 : }
518 :
519 : /* same with typechecks */
520 : static GEN
521 728 : Qevproj_init0(GEN M)
522 : {
523 728 : switch(typ(M))
524 : {
525 665 : case t_VEC:
526 665 : if (lg(M) == 5) return M;
527 0 : break;
528 49 : case t_COL:
529 49 : M = mkmat(M);/*fall through*/
530 56 : case t_MAT:
531 56 : M = Q_primpart(M);
532 56 : RgM_check_ZM(M,"Qevproj_init");
533 56 : return Qevproj_init(M);
534 : }
535 7 : pari_err_TYPE("Qevproj_init",M);
536 : return NULL;/*LCOV_EXCL_LINE*/
537 : }
538 :
539 : /* T an n x n QM, pro = Qevproj_init(M), pro2 = Qevproj_init(M2); TM \subset M2.
540 : * Express these column vectors on M2's basis */
541 : static GEN
542 3661 : Qevproj_apply2(GEN T, GEN pro, GEN pro2)
543 : {
544 3661 : GEN M = gel(pro,1), iM = gel(pro2,2), ciM = gel(pro2,3), perm = gel(pro2,4);
545 3661 : return RgM_Rg_div(RgM_mul(iM, RgM_mul(rowpermute(T,perm), M)), ciM);
546 : }
547 : /* T an n x n QM, stabilizing d-dimensional Q-vector space spanned by the
548 : * d columns of M, pro = Qevproj_init(M). Return dxd matrix of T acting on M */
549 : GEN
550 3031 : Qevproj_apply(GEN T, GEN pro) { return Qevproj_apply2(T, pro, pro); }
551 : /* Qevproj_apply(T,pro)[,k] */
552 : GEN
553 819 : Qevproj_apply_vecei(GEN T, GEN pro, long k)
554 : {
555 819 : GEN M = gel(pro,1), iM = gel(pro,2), ciM = gel(pro,3), perm = gel(pro,4);
556 819 : GEN v = RgM_RgC_mul(iM, RgM_RgC_mul(rowpermute(T,perm), gel(M,k)));
557 819 : return RgC_Rg_div(v, ciM);
558 : }
559 :
560 : static int
561 434 : cmp_dim(void *E, GEN a, GEN b)
562 : {
563 : long k;
564 : (void)E;
565 434 : a = gel(a,1);
566 434 : b = gel(b,1); k = lg(a)-lg(b);
567 434 : return k? ((k > 0)? 1: -1): 0;
568 : }
569 :
570 : /* FIXME: could use ZX_roots for deglim = 1 */
571 : static GEN
572 343 : ZX_factor_limit(GEN T, long deglim, long *pl)
573 : {
574 343 : GEN fa = ZX_factor(T), P, E;
575 : long i, l;
576 343 : P = gel(fa,1); *pl = l = lg(P);
577 343 : if (deglim <= 0) return fa;
578 224 : E = gel(fa,2);
579 567 : for (i = 1; i < l; i++)
580 406 : if (degpol(gel(P,i)) > deglim) break;
581 224 : setlg(P,i);
582 224 : setlg(E,i); return fa;
583 : }
584 :
585 : /* Decompose the subspace H (Qevproj format) in simple subspaces.
586 : * Eg for H = msnew */
587 : static GEN
588 266 : mssplit_i(GEN W, GEN H, long deglim)
589 : {
590 266 : ulong p, N = ms_get_N(W);
591 : long first, dim;
592 : forprime_t S;
593 266 : GEN T1 = NULL, T2 = NULL, V;
594 266 : dim = lg(gel(H,1))-1;
595 266 : V = vectrunc_init(dim+1);
596 266 : if (!dim) return V;
597 259 : (void)u_forprime_init(&S, 2, ULONG_MAX);
598 259 : vectrunc_append(V, H);
599 259 : first = 1; /* V[1..first-1] contains simple subspaces */
600 399 : while ((p = u_forprime_next(&S)))
601 : {
602 : GEN T;
603 : long j, lV;
604 399 : if (N % p == 0) continue;
605 336 : if (T1 && T2) {
606 21 : T = RgM_add(T1,T2);
607 21 : T2 = NULL;
608 : } else {
609 315 : T2 = T1;
610 315 : T1 = T = mshecke(W, p, NULL);
611 : }
612 336 : lV = lg(V);
613 679 : for (j = first; j < lV; j++)
614 : {
615 343 : pari_sp av = avma;
616 : long lP;
617 343 : GEN Vj = gel(V,j), P = gel(Vj,1);
618 343 : GEN TVj = Qevproj_apply(T, Vj); /* c T | V_j */
619 343 : GEN ch = QM_charpoly_ZX(TVj), fa = ZX_factor_limit(ch,deglim, &lP);
620 343 : GEN F = gel(fa, 1), E = gel(fa, 2);
621 343 : long k, lF = lg(F);
622 343 : if (lF == 2 && lP == 2)
623 : {
624 168 : if (equali1(gel(E,1)))
625 : { /* simple subspace */
626 168 : swap(gel(V,first), gel(V,j));
627 168 : first++;
628 : }
629 : else
630 0 : set_avma(av);
631 : }
632 175 : else if (lF == 1) /* discard V[j] */
633 7 : { swap(gel(V,j), gel(V,lg(V)-1)); setlg(V, lg(V)-1); }
634 : else
635 : { /* can split Vj */
636 : GEN pows;
637 168 : long D = 1;
638 658 : for (k = 1; k < lF; k++)
639 : {
640 490 : long d = degpol(gel(F,k));
641 490 : if (d > D) D = d;
642 : }
643 : /* remove V[j] */
644 168 : gel(V,j) = gel(V,lg(V)-1); setlg(V, lg(V)-1);
645 168 : pows = RgM_powers(TVj, minss((long)2*sqrt((double)D), D));
646 658 : for (k = 1; k < lF; k++)
647 : {
648 490 : GEN f = gel(F,k);
649 490 : GEN K = QM_ker( RgX_RgMV_eval(f, pows)) ; /* Ker f(TVj) */
650 490 : GEN p = vec_Q_primpart( RgM_mul(P, K) );
651 490 : vectrunc_append(V, Qevproj_init(p));
652 490 : if (lg(K) == 2 || isint1(gel(E,k)))
653 : { /* simple subspace */
654 406 : swap(gel(V,first), gel(V, lg(V)-1));
655 406 : first++;
656 : }
657 : }
658 168 : if (j < first) j = first;
659 : }
660 : }
661 336 : if (first >= lg(V)) {
662 259 : gen_sort_inplace(V, NULL, cmp_dim, NULL);
663 259 : return V;
664 : }
665 : }
666 0 : pari_err_BUG("subspaces not found");
667 : return NULL;/*LCOV_EXCL_LINE*/
668 : }
669 : GEN
670 266 : mssplit(GEN W, GEN H, long deglim)
671 : {
672 266 : pari_sp av = avma;
673 266 : checkms(W);
674 266 : if (!msk_get_sign(W))
675 0 : pari_err_DOMAIN("mssplit","abs(sign)","!=",gen_1,gen_0);
676 266 : if (!H) H = msnew(W);
677 266 : H = Qevproj_init0(H);
678 266 : return gerepilecopy(av, mssplit_i(W,H,deglim));
679 : }
680 :
681 : /* proV = Qevproj_init of a Hecke simple subspace, return [ a_n, n <= B ] */
682 : static GEN
683 245 : msqexpansion_i(GEN W, GEN proV, ulong B)
684 : {
685 245 : ulong p, N = ms_get_N(W), sqrtB;
686 245 : long i, d, k = msk_get_weight(W);
687 : forprime_t S;
688 245 : GEN T1=NULL, T2=NULL, TV=NULL, ch=NULL, v, dTiv, Tiv, diM, iM, L;
689 245 : switch(B)
690 : {
691 0 : case 0: return cgetg(1,t_VEC);
692 0 : case 1: return mkvec(gen_1);
693 : }
694 245 : (void)u_forprime_init(&S, 2, ULONG_MAX);
695 357 : while ((p = u_forprime_next(&S)))
696 : {
697 : GEN T;
698 357 : if (N % p == 0) continue;
699 266 : if (T1 && T2)
700 : {
701 0 : T = RgM_add(T1,T2);
702 0 : T2 = NULL;
703 : }
704 : else
705 : {
706 266 : T2 = T1;
707 266 : T1 = T = mshecke(W, p, NULL);
708 : }
709 266 : TV = Qevproj_apply(T, proV); /* T | V */
710 266 : ch = QM_charpoly_ZX(TV);
711 266 : if (ZX_is_irred(ch)) break;
712 21 : ch = NULL;
713 : }
714 245 : if (!ch) pari_err_BUG("q-Expansion not found");
715 : /* T generates the Hecke algebra (acting on V) */
716 245 : d = degpol(ch);
717 245 : v = vec_ei(d, 1); /* take v = e_1 */
718 245 : Tiv = cgetg(d+1, t_MAT); /* Tiv[i] = T^(i-1)v */
719 245 : gel(Tiv, 1) = v;
720 343 : for (i = 2; i <= d; i++) gel(Tiv, i) = RgM_RgC_mul(TV, gel(Tiv,i-1));
721 245 : Tiv = Q_remove_denom(Tiv, &dTiv);
722 245 : iM = ZM_inv(Tiv, &diM);
723 245 : if (dTiv) diM = gdiv(diM, dTiv);
724 245 : L = const_vec(B,NULL);
725 245 : sqrtB = usqrt(B);
726 245 : gel(L,1) = d > 1? mkpolmod(gen_1,ch): gen_1;
727 2471 : for (p = 2; p <= B; p++)
728 : {
729 2226 : pari_sp av = avma;
730 : GEN T, u, Tv, ap, P;
731 : ulong m;
732 2226 : if (gel(L,p)) continue; /* p not prime */
733 819 : T = mshecke(W, p, NULL);
734 819 : Tv = Qevproj_apply_vecei(T, proV, 1); /* Tp.v */
735 : /* Write Tp.v = \sum u_i T^i v */
736 819 : u = RgC_Rg_div(RgM_RgC_mul(iM, Tv), diM);
737 819 : ap = gerepilecopy(av, RgV_to_RgX(u, 0));
738 819 : if (d > 1)
739 399 : ap = mkpolmod(ap,ch);
740 : else
741 420 : ap = simplify_shallow(ap);
742 819 : gel(L,p) = ap;
743 819 : if (!(N % p))
744 147 : { /* p divides the level */
745 147 : ulong C = B/p;
746 546 : for (m=1; m<=C; m++)
747 399 : if (gel(L,m)) gel(L,m*p) = gmul(gel(L,m), ap);
748 147 : continue;
749 : }
750 672 : P = powuu(p,k-1);
751 672 : if (p <= sqrtB) {
752 119 : ulong pj, oldpj = 1;
753 546 : for (pj = p; pj <= B; oldpj=pj, pj *= p)
754 : {
755 427 : GEN apj = (pj==p)? ap
756 427 : : gsub(gmul(ap,gel(L,oldpj)), gmul(P,gel(L,oldpj/p)));
757 427 : gel(L,pj) = apj;
758 3136 : for (m = B/pj; m > 1; m--)
759 2709 : if (gel(L,m) && m%p) gel(L,m*pj) = gmul(gel(L,m), apj);
760 : }
761 : } else {
762 553 : gel(L,p) = ap;
763 1092 : for (m = B/p; m > 1; m--)
764 539 : if (gel(L,m)) gel(L,m*p) = gmul(gel(L,m), ap);
765 : }
766 : }
767 245 : return L;
768 : }
769 : GEN
770 259 : msqexpansion(GEN W, GEN proV, long B)
771 : {
772 259 : pari_sp av = avma;
773 259 : checkms(W);
774 259 : if (B < 0) pari_err_DOMAIN("msqexpansion", "B", "<", gen_0, stoi(B));
775 252 : proV = Qevproj_init0(proV);
776 245 : return gerepilecopy(av, msqexpansion_i(W,proV,(ulong)B));
777 : }
778 :
779 : static GEN
780 217 : Qevproj_apply0(GEN T, GEN pro)
781 : {
782 217 : GEN iM = gel(pro,2), perm = gel(pro,4);
783 217 : return vec_Q_primpart(ZM_mul(iM, rowpermute(T,perm)));
784 : }
785 : /* T a ZC or ZM */
786 : GEN
787 4186 : Qevproj_down(GEN T, GEN pro)
788 : {
789 4186 : GEN iM = gel(pro,2), ciM = gel(pro,3), perm = gel(pro,4);
790 4186 : if (typ(T) == t_COL)
791 4186 : return RgC_Rg_div(ZM_ZC_mul(iM, vecpermute(T,perm)), ciM);
792 : else
793 0 : return RgM_Rg_div(ZM_mul(iM, rowpermute(T,perm)), ciM);
794 : }
795 :
796 : static GEN
797 287 : Qevproj_star(GEN W, GEN H)
798 : {
799 287 : long s = msk_get_sign(W);
800 287 : if (s)
801 : { /* project on +/- component */
802 217 : GEN A = RgM_mul(msk_get_star(W), H);
803 217 : A = (s > 0)? gadd(A, H): gsub(A, H);
804 : /* Im(star + sign) = Ker(star - sign) */
805 217 : H = QM_image_shallow(A);
806 217 : H = Qevproj_apply0(H, msk_get_starproj(W));
807 : }
808 287 : return H;
809 : }
810 :
811 : static GEN
812 5824 : Tp_matrices(ulong p)
813 : {
814 5824 : GEN v = cgetg(p+2, t_VEC);
815 : ulong i;
816 44429 : for (i = 1; i <= p; i++) gel(v,i) = mat2(1, i-1, 0, p);
817 5824 : gel(v,i) = mat2(p, 0, 0, 1);
818 5824 : return v;
819 : }
820 : static GEN
821 987 : Up_matrices(ulong p)
822 : {
823 987 : GEN v = cgetg(p+1, t_VEC);
824 : ulong i;
825 6300 : for (i = 1; i <= p; i++) gel(v,i) = mat2(1, i-1, 0, p);
826 987 : return v;
827 : }
828 :
829 : /* M = N/p. Classes of Gamma_0(M) / Gamma_O(N) when p | M */
830 : static GEN
831 182 : NP_matrices(ulong M, ulong p)
832 : {
833 182 : GEN v = cgetg(p+1, t_VEC);
834 : ulong i;
835 1365 : for (i = 1; i <= p; i++) gel(v,i) = mat2(1, 0, (i-1)*M, 1);
836 182 : return v;
837 : }
838 : /* M = N/p. Extra class of Gamma_0(M) / Gamma_O(N) when p \nmid M */
839 : static GEN
840 98 : NP_matrix_extra(ulong M, ulong p)
841 : {
842 98 : long w,z, d = cbezout(p, -M, &w, &z);
843 98 : if (d != 1) return NULL;
844 98 : return mat2(w,z,M,p);
845 : }
846 : static GEN
847 112 : WQ_matrix(long N, long Q)
848 : {
849 112 : long w,z, d = cbezout(Q, N/Q, &w, &z);
850 112 : if (d != 1) return NULL;
851 112 : return mat2(Q,1,-N*z,Q*w);
852 : }
853 :
854 : GEN
855 287 : msnew(GEN W)
856 : {
857 287 : pari_sp av = avma;
858 287 : GEN S = mscuspidal(W, 0);
859 287 : ulong N = ms_get_N(W);
860 287 : long s = msk_get_sign(W), k = msk_get_weight(W);
861 287 : if (N > 1 && (!uisprime(N) || (k == 12 || k > 14)))
862 : {
863 112 : GEN p1N = ms_get_p1N(W), P = gel(p1N_get_fa(p1N), 1);
864 112 : long i, nP = lg(P)-1;
865 112 : GEN v = cgetg(2*nP + 1, t_COL);
866 112 : S = gel(S,1); /* Q basis */
867 294 : for (i = 1; i <= nP; i++)
868 : {
869 182 : pari_sp av = avma, av2;
870 182 : long M = N/P[i];
871 182 : GEN T1,Td, Wi = mskinit(M, k, s);
872 182 : GEN v1 = NP_matrices(M, P[i]);
873 182 : GEN vd = Up_matrices(P[i]);
874 : /* p^2 \nmid N */
875 182 : if (M % P[i])
876 : {
877 98 : v1 = vec_append(v1, NP_matrix_extra(M,P[i]));
878 98 : vd = vec_append(vd, WQ_matrix(N,P[i]));
879 : }
880 182 : T1 = getMorphism(W, Wi, v1);
881 182 : Td = getMorphism(W, Wi, vd);
882 182 : if (s)
883 : {
884 168 : T1 = Qevproj_apply2(T1, msk_get_starproj(W), msk_get_starproj(Wi));
885 168 : Td = Qevproj_apply2(Td, msk_get_starproj(W), msk_get_starproj(Wi));
886 : }
887 182 : av2 = avma;
888 182 : T1 = RgM_mul(T1,S);
889 182 : Td = RgM_mul(Td,S); /* multiply by S = restrict to mscusp */
890 182 : gerepileallsp(av, av2, 2, &T1, &Td);
891 182 : gel(v,2*i-1) = T1;
892 182 : gel(v,2*i) = Td;
893 : }
894 112 : S = ZM_mul(S, QM_ker(matconcat(v))); /* Snew */
895 112 : S = Qevproj_init(vec_Q_primpart(S));
896 : }
897 287 : return gerepilecopy(av, S);
898 : }
899 :
900 : /* Solve the Manin relations for a congruence subgroup \Gamma by constructing
901 : * a well-formed fundamental domain for the action of \Gamma on upper half
902 : * space. See
903 : * Pollack and Stevens, Overconvergent modular symbols and p-adic L-functions
904 : * Annales scientifiques de l'ENS 44, fascicule 1 (2011), 1-42
905 : * http://math.bu.edu/people/rpollack/Papers/Overconvergent_modular_symbols_and_padic_Lfunctions.pdf
906 : *
907 : * FIXME: Implemented for \Gamma = \Gamma_0(N) only. */
908 :
909 : /* linked lists */
910 : typedef struct list_t { GEN data; struct list_t *next; } list_t;
911 : static list_t *
912 188503 : list_new(GEN x)
913 : {
914 188503 : list_t *L = (list_t*)stack_malloc(sizeof(list_t));
915 188503 : L->data = x;
916 188503 : L->next = NULL; return L;
917 : }
918 : static void
919 184275 : list_insert(list_t *L, GEN x)
920 : {
921 184275 : list_t *l = list_new(x);
922 184275 : l->next = L->next;
923 184275 : L->next = l;
924 184275 : }
925 :
926 : /*Input: N > 1, p1N = P^1(Z/NZ)
927 : *Output: a connected fundamental domain for the action of \Gamma_0(N) on
928 : * upper half space. When \Gamma_0(N) is torsion free, the domain has the
929 : * property that all of its vertices are cusps. When \Gamma_0(N) has
930 : * three-torsion, 2 extra triangles need to be added.
931 : *
932 : * The domain is constructed by beginning with the triangle with vertices 0,1
933 : * and oo. Each adjacent triangle is successively tested to see if it contains
934 : * points not \Gamma_0(N) equivalent to some point in our region. If a
935 : * triangle contains new points, it is added to the region. This process is
936 : * continued until the region can no longer be extended (and still be a
937 : * fundamental domain) by added an adjacent triangle. The list of cusps
938 : * between 0 and 1 are then returned
939 : *
940 : * Precisely, the function returns a list such that the elements of the list
941 : * with odd index are the cusps in increasing order. The even elements of the
942 : * list are either an "x" or a "t". A "t" represents that there is an element
943 : * of order three such that its fixed point is in the triangle directly
944 : * adjacent to the our region with vertices given by the cusp before and after
945 : * the "t". The "x" represents that this is not the case. */
946 : enum { type_X, type_DO /* ? */, type_T };
947 : static GEN
948 4228 : form_list_of_cusps(ulong N, GEN p1N)
949 : {
950 4228 : pari_sp av = avma;
951 4228 : long i, position, nbC = 2;
952 : GEN v, L;
953 : list_t *C, *c;
954 : /* Let t be the index of a class in PSL2(Z) / \Gamma in our fixed enumeration
955 : * v[t] != 0 iff it is the class of z tau^r for z a previous alpha_i
956 : * or beta_i.
957 : * For \Gamma = \Gamma_0(N), the enumeration is given by p1_index.
958 : * We write cl(gamma) = the class of gamma mod \Gamma */
959 4228 : v = const_vecsmall(p1_size(p1N), 0);
960 4228 : i = p1_index( 0, 1, p1N); v[i] = 1;
961 4228 : i = p1_index( 1,-1, p1N); v[i] = 2;
962 4228 : i = p1_index(-1, 0, p1N); v[i] = 3;
963 : /* the value is unused [debugging]: what matters is whether it is != 0 */
964 4228 : position = 4;
965 : /* at this point, Fund = R, v contains the classes of Id, tau, tau^2 */
966 :
967 4228 : C = list_new(mkvecsmall3(0,1, type_X));
968 4228 : list_insert(C, mkvecsmall3(1,1,type_DO));
969 : /* C is a list of triples[a,b,t], where c = a/b is a cusp, and t is the type
970 : * of the path between c and the PREVIOUS cusp in the list, coded as
971 : * type_DO = "?", type_X = "x", type_T = "t"
972 : * Initially, C = [0/1,"?",1/1]; */
973 :
974 : /* loop through the current set of cusps C and check to see if more cusps
975 : * should be added */
976 : for (;;)
977 24633 : {
978 28861 : int done = 1;
979 824383 : for (c = C; c; c = c->next)
980 : {
981 : GEN cusp1, cusp2, gam;
982 : long pos, b1, b2, b;
983 :
984 824383 : if (!c->next) break;
985 795522 : cusp1 = c->data; /* = a1/b1 */
986 795522 : cusp2 = (c->next)->data; /* = a2/b2 */
987 795522 : if (cusp2[3] != type_DO) continue;
988 :
989 : /* gam (oo -> 0) = (cusp2 -> cusp1), gam in PSL2(Z) */
990 364322 : gam = path_to_zm(mkpath(cusp2, cusp1)); /* = [a2,a1;b2,b1] */
991 : /* we have normalized the cusp representation so that a1 b2 - a2 b1 = 1 */
992 364322 : b1 = coeff(gam,2,1); b2 = coeff(gam,2,2);
993 : /* gam.1 = (a1 + a2) / (b1 + b2) */
994 364322 : b = b1 + b2;
995 : /* Determine whether the adjacent triangle *below* (cusp1->cusp2)
996 : * should be added */
997 364322 : pos = p1_index(b1,b2, p1N); /* did we see cl(gam) before ? */
998 364322 : if (v[pos])
999 182798 : cusp2[3] = type_X; /* NO */
1000 : else
1001 : { /* YES */
1002 : ulong B1, B2;
1003 181524 : v[pos] = position;
1004 181524 : i = p1_index(-(b1+b2), b1, p1N); v[i] = position+1;
1005 181524 : i = p1_index(b2, -(b1+b2), p1N); v[i] = position+2;
1006 : /* add cl(gam), cl(gam*TAU), cl(gam*TAU^2) to v */
1007 181524 : position += 3;
1008 : /* gam tau gam^(-1) in \Gamma ? */
1009 181524 : B1 = umodsu(b1, N);
1010 181524 : B2 = umodsu(b2, N);
1011 181524 : if ((Fl_sqr(B2,N) + Fl_sqr(B1,N) + Fl_mul(B1,B2,N)) % N == 0)
1012 1477 : cusp2[3] = type_T;
1013 : else
1014 : {
1015 180047 : long a1 = coeff(gam, 1,1), a2 = coeff(gam, 1,2);
1016 180047 : long a = a1 + a2; /* gcd(a,b) = 1 */
1017 180047 : list_insert(c, mkvecsmall3(a,b,type_DO));
1018 180047 : c = c->next;
1019 180047 : nbC++;
1020 180047 : done = 0;
1021 : }
1022 : }
1023 : }
1024 28861 : if (done) break;
1025 : }
1026 4228 : L = cgetg(nbC+1, t_VEC); i = 1;
1027 192731 : for (c = C; c; c = c->next) gel(L,i++) = c->data;
1028 4228 : return gerepilecopy(av, L);
1029 : }
1030 :
1031 : /* W an msN. M in PSL2(Z). Return index of M in P1^(Z/NZ) = Gamma0(N) \ PSL2(Z),
1032 : * and M0 in Gamma_0(N) such that M = M0 * M', where M' = chosen
1033 : * section( PSL2(Z) -> P1^(Z/NZ) ). */
1034 : static GEN
1035 498463 : Gamma0N_decompose(GEN W, GEN M, long *index)
1036 : {
1037 498463 : GEN p1N = msN_get_p1N(W), W3 = gel(W,3), section = msN_get_section(W);
1038 : GEN A;
1039 498463 : ulong N = p1N_get_N(p1N);
1040 498463 : ulong c = umodiu(gcoeff(M,2,1), N);
1041 498463 : ulong d = umodiu(gcoeff(M,2,2), N);
1042 498463 : long s, ind = p1_index(c, d, p1N); /* as an elt of P1(Z/NZ) */
1043 498463 : *index = W3[ind]; /* as an elt of F, E2, ... */
1044 498463 : M = ZM_zm_mul(M, sl2_inv(gel(section,ind)));
1045 : /* normalize mod +/-Id */
1046 498463 : A = gcoeff(M,1,1);
1047 498463 : s = signe(A);
1048 498463 : if (s < 0)
1049 237125 : M = ZM_neg(M);
1050 261338 : else if (!s)
1051 : {
1052 378 : GEN C = gcoeff(M,2,1);
1053 378 : if (signe(C) < 0) M = ZM_neg(M);
1054 : }
1055 498463 : return M;
1056 : }
1057 : /* W an msN; as above for a path. Return [[ind], M] */
1058 : static GEN
1059 385462 : path_Gamma0N_decompose(GEN W, GEN path)
1060 : {
1061 385462 : GEN p1N = msN_get_p1N(W);
1062 385462 : GEN p1index_to_ind = gel(W,3);
1063 385462 : GEN section = msN_get_section(W);
1064 385462 : GEN M = path_to_zm(path);
1065 385462 : long p1index = p1_index(cc(M), dd(M), p1N);
1066 385462 : long ind = p1index_to_ind[p1index];
1067 385462 : GEN M0 = ZM_zm_mul(mat2_to_ZM(M), sl2_inv(gel(section,p1index)));
1068 385462 : return mkvec2(mkvecsmall(ind), M0);
1069 : }
1070 :
1071 : /*Form generators of H_1(X_0(N),{cusps},Z)
1072 : *
1073 : *Input: N = integer > 1, p1N = P^1(Z/NZ)
1074 : *Output: [cusp_list,E,F,T2,T3,E1] where
1075 : * cusps_list = list of cusps describing fundamental domain of
1076 : * \Gamma_0(N).
1077 : * E = list of paths in the boundary of the fundamental domains and oriented
1078 : * clockwise such that they do not contain a point
1079 : * fixed by an element of order 2 and they are not an edge of a
1080 : * triangle containing a fixed point of an element of order 3
1081 : * F = list of paths in the interior of the domain with each
1082 : * orientation appearing separately
1083 : * T2 = list of paths in the boundary of domain containing a point fixed
1084 : * by an element of order 2 (oriented clockwise)
1085 : * T3 = list of paths in the boundard of domain which are the edges of
1086 : * some triangle containing a fixed point of a matrix of order 3 (both
1087 : * orientations appear)
1088 : * E1 = a sublist of E such that every path in E is \Gamma_0(N)-equivalent to
1089 : * either an element of E1 or the flip (reversed orientation) of an element
1090 : * of E1.
1091 : * (Elements of T2 are \Gamma_0(N)-equivalent to their own flip.)
1092 : *
1093 : * sec = a list from 1..#p1N of matrices describing a section of the map
1094 : * SL_2(Z) to P^1(Z/NZ) given by [a,b;c,d]-->[c,d].
1095 : * Given our fixed enumeration of P^1(Z/NZ), the j-th element of the list
1096 : * represents the image of the j-th element of P^1(Z/NZ) under the section. */
1097 :
1098 : /* insert path in set T */
1099 : static void
1100 554302 : set_insert(hashtable *T, GEN path)
1101 554302 : { hash_insert(T, path, (void*)(T->nb + 1)); }
1102 :
1103 : static GEN
1104 38052 : hash_to_vec(hashtable *h)
1105 : {
1106 38052 : GEN v = cgetg(h->nb + 1, t_VEC);
1107 : ulong i;
1108 4186994 : for (i = 0; i < h->len; i++)
1109 : {
1110 4148942 : hashentry *e = h->table[i];
1111 5066411 : while (e)
1112 : {
1113 917469 : GEN key = (GEN)e->key;
1114 917469 : long index = (long)e->val;
1115 917469 : gel(v, index) = key;
1116 917469 : e = e->next;
1117 : }
1118 : }
1119 38052 : return v;
1120 : }
1121 :
1122 : static long
1123 284487 : path_to_p1_index(GEN path, GEN p1N)
1124 : {
1125 284487 : GEN M = path_to_zm(path);
1126 284487 : return p1_index(cc(M), dd(M), p1N);
1127 : }
1128 :
1129 : /* Pollack-Stevens sets */
1130 : typedef struct PS_sets_t {
1131 : hashtable *F, *T2, *T31, *T32, *E1, *E2;
1132 : GEN E2fromE1, stdE1;
1133 : } PS_sets_t;
1134 :
1135 : static hashtable *
1136 29036 : set_init(long max)
1137 29036 : { return hash_create(max, (ulong(*)(void*))&hash_GEN,
1138 : (int(*)(void*,void*))&gidentical, 1); }
1139 : /* T = E2fromE1[i] = [c, gamma] */
1140 : static ulong
1141 42523936 : E2fromE1_c(GEN T) { return itou(gel(T,1)); }
1142 : static GEN
1143 579957 : E2fromE1_Zgamma(GEN T) { return gel(T,2); }
1144 : static GEN
1145 94829 : E2fromE1_gamma(GEN T) { return gcoeff(gel(T,2),1,1); }
1146 :
1147 : static void
1148 189658 : insert_E(GEN path, PS_sets_t *S, GEN p1N)
1149 : {
1150 189658 : GEN rev = vecreverse(path);
1151 189658 : long std = path_to_p1_index(rev, p1N);
1152 189658 : GEN v = gel(S->stdE1, std);
1153 189658 : if (v)
1154 : { /* [s, p1], where E1[s] is the path p1 = vecreverse(path) mod \Gamma */
1155 94829 : GEN gamma, p1 = gel(v,2);
1156 94829 : long r, s = itou(gel(v,1));
1157 :
1158 94829 : set_insert(S->E2, path);
1159 94829 : r = S->E2->nb;
1160 94829 : if (gel(S->E2fromE1, r) != gen_0) pari_err_BUG("insert_E");
1161 :
1162 94829 : gamma = gamma_equiv_matrix(rev, p1);
1163 : /* reverse(E2[r]) = gamma * E1[s] */
1164 94829 : gel(S->E2fromE1, r) = mkvec2(utoipos(s), to_famat_shallow(gamma,gen_m1));
1165 : }
1166 : else
1167 : {
1168 94829 : set_insert(S->E1, path);
1169 94829 : std = path_to_p1_index(path, p1N);
1170 94829 : gel(S->stdE1, std) = mkvec2(utoipos(S->E1->nb), path);
1171 : }
1172 189658 : }
1173 :
1174 : static GEN
1175 16912 : cusp_infinity(void) { return mkvecsmall2(1,0); }
1176 :
1177 : static void
1178 4228 : form_E_F_T(ulong N, GEN p1N, GEN *pC, PS_sets_t *S)
1179 : {
1180 4228 : GEN C, cusp_list = form_list_of_cusps(N, p1N);
1181 4228 : long nbgen = lg(cusp_list)-1, nbmanin = p1_size(p1N), r, s, i;
1182 : hashtable *F, *T2, *T31, *T32, *E1, *E2;
1183 :
1184 4228 : *pC = C = cgetg(nbgen+1, t_VEC);
1185 192731 : for (i = 1; i <= nbgen; i++)
1186 : {
1187 188503 : GEN c = gel(cusp_list,i);
1188 188503 : gel(C,i) = mkvecsmall2(c[1], c[2]);
1189 : }
1190 4228 : S->F = F = set_init(nbmanin);
1191 4228 : S->E1 = E1 = set_init(nbgen);
1192 4228 : S->E2 = E2 = set_init(nbgen);
1193 4228 : S->T2 = T2 = set_init(nbgen);
1194 4228 : S->T31 = T31 = set_init(nbgen);
1195 4228 : S->T32 = T32 = set_init(nbgen);
1196 :
1197 : /* T31 represents the three torsion paths going from left to right */
1198 : /* T32 represents the three torsion paths going from right to left */
1199 188503 : for (r = 1; r < nbgen; r++)
1200 : {
1201 184275 : GEN c2 = gel(cusp_list,r+1);
1202 184275 : if (c2[3] == type_T)
1203 : {
1204 1477 : GEN c1 = gel(cusp_list,r), path = mkpath(c1,c2), path2 = vecreverse(path);
1205 1477 : set_insert(T31, path);
1206 1477 : set_insert(T32, path2);
1207 : }
1208 : }
1209 :
1210 : /* to record relations between E2 and E1 */
1211 4228 : S->E2fromE1 = zerovec(nbgen);
1212 4228 : S->stdE1 = const_vec(nbmanin, NULL);
1213 :
1214 : /* Assumption later: path [oo,0] is E1[1], path [1,oo] is E2[1] */
1215 : {
1216 4228 : GEN oo = cusp_infinity();
1217 4228 : GEN p1 = mkpath(oo, mkvecsmall2(0,1)); /* [oo, 0] */
1218 4228 : GEN p2 = mkpath(mkvecsmall2(1,1), oo); /* [1, oo] */
1219 4228 : insert_E(p1, S, p1N);
1220 4228 : insert_E(p2, S, p1N);
1221 : }
1222 :
1223 188503 : for (r = 1; r < nbgen; r++)
1224 : {
1225 184275 : GEN c1 = gel(cusp_list,r);
1226 23924719 : for (s = r+1; s <= nbgen; s++)
1227 : {
1228 23740444 : pari_sp av = avma;
1229 23740444 : GEN c2 = gel(cusp_list,s), path;
1230 23740444 : GEN d = subii(mulss(c1[1],c2[2]), mulss(c1[2],c2[1]));
1231 23740444 : set_avma(av);
1232 23740444 : if (!is_pm1(d)) continue;
1233 :
1234 364322 : path = mkpath(c1,c2);
1235 364322 : if (r+1 == s)
1236 : {
1237 184275 : GEN w = path;
1238 184275 : ulong hash = T31->hash(w); /* T31, T32 use the same hash function */
1239 184275 : if (!hash_search2(T31, w, hash) && !hash_search2(T32, w, hash))
1240 : {
1241 182798 : if (gamma_equiv(path, vecreverse(path), N))
1242 1596 : set_insert(T2, path);
1243 : else
1244 181202 : insert_E(path, S, p1N);
1245 : }
1246 : } else {
1247 180047 : set_insert(F, mkvec2(path, mkvecsmall2(r,s)));
1248 180047 : set_insert(F, mkvec2(vecreverse(path), mkvecsmall2(s,r)));
1249 : }
1250 : }
1251 : }
1252 4228 : setlg(S->E2fromE1, E2->nb+1);
1253 4228 : }
1254 :
1255 : /* v = \sum n_i g_i, g_i in Sl(2,Z), return \sum n_i g_i^(-1) */
1256 : static GEN
1257 845705 : ZSl2_star(GEN v)
1258 : {
1259 : long i, l;
1260 : GEN w, G;
1261 845705 : if (typ(v) == t_INT) return v;
1262 845705 : G = gel(v,1);
1263 845705 : w = cgetg_copy(G, &l);
1264 2015363 : for (i = 1; i < l; i++)
1265 : {
1266 1169658 : GEN g = gel(G,i);
1267 1169658 : if (typ(g) == t_MAT) g = SL2_inv_shallow(g);
1268 1169658 : gel(w,i) = g;
1269 : }
1270 845705 : return ZG_normalize(mkmat2(w, gel(v,2)));
1271 : }
1272 :
1273 : /* Input: h = set of unimodular paths, p1N = P^1(Z/NZ) = Gamma_0(N)\PSL2(Z)
1274 : * Output: Each path is converted to a matrix and then an element of P^1(Z/NZ)
1275 : * Append the matrix to W[12], append the index that represents
1276 : * these elements of P^1 (the classes mod Gamma_0(N) via our fixed
1277 : * enumeration to W[2]. */
1278 : static void
1279 25368 : paths_decompose(GEN W, hashtable *h, int flag)
1280 : {
1281 25368 : GEN p1N = ms_get_p1N(W), section = ms_get_section(W);
1282 25368 : GEN v = hash_to_vec(h);
1283 25368 : long i, l = lg(v);
1284 579670 : for (i = 1; i < l; i++)
1285 : {
1286 554302 : GEN e = gel(v,i);
1287 554302 : GEN M = path_to_zm(flag? gel(e,1): e);
1288 554302 : long index = p1_index(cc(M), dd(M), p1N);
1289 554302 : vecsmalltrunc_append(gel(W,2), index);
1290 554302 : gel(section, index) = M;
1291 : }
1292 25368 : }
1293 : static void
1294 4228 : fill_W2_W12(GEN W, PS_sets_t *S)
1295 : {
1296 4228 : GEN p1N = msN_get_p1N(W);
1297 4228 : long n = p1_size(p1N);
1298 4228 : gel(W, 2) = vecsmalltrunc_init(n+1);
1299 4228 : gel(W,12) = cgetg(n+1, t_VEC);
1300 : /* F contains [path, [index cusp1, index cusp2]]. Others contain paths only */
1301 4228 : paths_decompose(W, S->F, 1);
1302 4228 : paths_decompose(W, S->E2, 0);
1303 4228 : paths_decompose(W, S->T32, 0);
1304 4228 : paths_decompose(W, S->E1, 0);
1305 4228 : paths_decompose(W, S->T2, 0);
1306 4228 : paths_decompose(W, S->T31, 0);
1307 4228 : }
1308 :
1309 : /* x t_VECSMALL, corresponds to a map x(i) = j, where 1 <= j <= max for all i
1310 : * Return y s.t. y[j] = i or 0 (not in image) */
1311 : static GEN
1312 8456 : reverse_list(GEN x, long max)
1313 : {
1314 8456 : GEN y = const_vecsmall(max, 0);
1315 8456 : long r, lx = lg(x);
1316 660660 : for (r = 1; r < lx; r++) y[ x[r] ] = r;
1317 8456 : return y;
1318 : }
1319 :
1320 : /* go from C[a] to C[b]; return the indices of paths
1321 : * E.g. if a < b
1322 : * (C[a]->C[a+1], C[a+1]->C[a+2], ... C[b-1]->C[b])
1323 : * (else reverse direction)
1324 : * = b - a paths */
1325 : static GEN
1326 347228 : F_indices(GEN W, long a, long b)
1327 : {
1328 347228 : GEN v = cgetg(labs(b-a) + 1, t_VEC);
1329 347228 : long s, k = 1;
1330 347228 : if (a < b) {
1331 173614 : GEN index_forward = gel(W,13);
1332 1193969 : for (s = a; s < b; s++) gel(v,k++) = gel(index_forward,s);
1333 : } else {
1334 173614 : GEN index_backward = gel(W,14);
1335 1193969 : for (s = a; s > b; s--) gel(v,k++) = gel(index_backward,s);
1336 : }
1337 347228 : return v;
1338 : }
1339 : /* go from C[a] to C[b] via oo; return the indices of paths
1340 : * E.g. if a < b
1341 : * (C[a]->C[a-1], ... C[2]->C[1],
1342 : * C[1]->oo, oo-> C[end],
1343 : * C[end]->C[end-1], ... C[b+1]->C[b])
1344 : * a-1 + 2 + end-(b+1)+1 = end - b + a + 1 paths */
1345 : static GEN
1346 12866 : F_indices_oo(GEN W, long end, long a, long b)
1347 : {
1348 12866 : GEN index_oo = gel(W,15);
1349 12866 : GEN v = cgetg(end-labs(b-a)+1 + 1, t_VEC);
1350 12866 : long s, k = 1;
1351 :
1352 12866 : if (a < b) {
1353 6433 : GEN index_backward = gel(W,14);
1354 6433 : for (s = a; s > 1; s--) gel(v,k++) = gel(index_backward,s);
1355 6433 : gel(v,k++) = gel(index_backward,1); /* C[1] -> oo */
1356 6433 : gel(v,k++) = gel(index_oo,2); /* oo -> C[end] */
1357 75264 : for (s = end; s > b; s--) gel(v,k++) = gel(index_backward,s);
1358 : } else {
1359 6433 : GEN index_forward = gel(W,13);
1360 75264 : for (s = a; s < end; s++) gel(v,k++) = gel(index_forward,s);
1361 6433 : gel(v,k++) = gel(index_forward,end); /* C[end] -> oo */
1362 6433 : gel(v,k++) = gel(index_oo,1); /* oo -> C[1] */
1363 6433 : for (s = 1; s < b; s++) gel(v,k++) = gel(index_forward,s);
1364 : }
1365 12866 : return v;
1366 : }
1367 : /* index of oo -> C[1], oo -> C[end] */
1368 : static GEN
1369 4228 : indices_oo(GEN W, GEN C)
1370 : {
1371 4228 : long end = lg(C)-1;
1372 4228 : GEN w, v = cgetg(2+1, t_VEC), oo = cusp_infinity();
1373 4228 : w = mkpath(oo, gel(C,1)); /* oo -> C[1]=0 */
1374 4228 : gel(v,1) = path_Gamma0N_decompose(W, w);
1375 4228 : w = mkpath(oo, gel(C,end)); /* oo -> C[end]=1 */
1376 4228 : gel(v,2) = path_Gamma0N_decompose(W, w);
1377 4228 : return v;
1378 : }
1379 :
1380 : /* index of C[1]->C[2], C[2]->C[3], ... C[end-1]->C[end], C[end]->oo
1381 : * Recall that C[1] = 0, C[end] = 1 */
1382 : static GEN
1383 4228 : indices_forward(GEN W, GEN C)
1384 : {
1385 4228 : long s, k = 1, end = lg(C)-1;
1386 4228 : GEN v = cgetg(end+1, t_VEC);
1387 192731 : for (s = 1; s <= end; s++)
1388 : {
1389 188503 : GEN w = mkpath(gel(C,s), s == end? cusp_infinity(): gel(C,s+1));
1390 188503 : gel(v,k++) = path_Gamma0N_decompose(W, w);
1391 : }
1392 4228 : return v;
1393 : }
1394 : /* index of C[1]->oo, C[2]->C[1], ... C[end]->C[end-1] */
1395 : static GEN
1396 4228 : indices_backward(GEN W, GEN C)
1397 : {
1398 4228 : long s, k = 1, end = lg(C)-1;
1399 4228 : GEN v = cgetg(end+1, t_VEC);
1400 192731 : for (s = 1; s <= end; s++)
1401 : {
1402 188503 : GEN w = mkpath(gel(C,s), s == 1? cusp_infinity(): gel(C,s-1));
1403 188503 : gel(v,k++) = path_Gamma0N_decompose(W, w);
1404 : }
1405 4228 : return v;
1406 : }
1407 :
1408 : /*[0,-1;1,-1]*/
1409 : static GEN
1410 4312 : mkTAU()
1411 4312 : { retmkmat22(gen_0,gen_m1, gen_1,gen_m1); }
1412 : /* S */
1413 : static GEN
1414 84 : mkS()
1415 84 : { retmkmat22(gen_0,gen_1, gen_m1,gen_0); }
1416 : /* N = integer > 1. Returns data describing Delta_0 = Z[P^1(Q)]_0 seen as
1417 : * a Gamma_0(N) - module. */
1418 : static GEN
1419 4256 : msinit_N(ulong N)
1420 : {
1421 : GEN p1N, C, vecF, vecT2, vecT31, TAU, W, W2, singlerel, annT2, annT31;
1422 : GEN F_index;
1423 : ulong r, s, width;
1424 : long nball, nbgen, nbp1N;
1425 : hashtable *F, *T2, *T31, *T32, *E1, *E2;
1426 : PS_sets_t S;
1427 :
1428 4256 : W = zerovec(16);
1429 4256 : gel(W,1) = p1N = create_p1mod(N);
1430 4256 : gel(W,16)= inithashcusps(p1N);
1431 4256 : TAU = mkTAU();
1432 4256 : if (N == 1)
1433 : {
1434 28 : gel(W,5) = mkvecsmall(1);
1435 : /* cheat because sets are not disjoint if N=1 */
1436 28 : gel(W,11) = mkvecsmall5(0, 0, 1, 1, 2);
1437 28 : gel(W,12) = mkvec(mat2(1,0,0,1));
1438 28 : gel(W,8) = mkvec( mkmat22(gen_1,gen_1, mkS(),gen_1) );
1439 28 : gel(W,9) = mkvec( mkmat2(mkcol3(gen_1,TAU,ZM2_sqr(TAU)),
1440 : mkcol3(gen_1,gen_1,gen_1)) );
1441 28 : return W;
1442 : }
1443 4228 : nbp1N = p1_size(p1N);
1444 4228 : form_E_F_T(N,p1N, &C, &S);
1445 4228 : E1 = S.E1;
1446 4228 : E2 = S.E2;
1447 4228 : T31 = S.T31;
1448 4228 : T32 = S.T32;
1449 4228 : F = S.F;
1450 4228 : T2 = S.T2;
1451 4228 : nbgen = lg(C)-1;
1452 :
1453 : /* Put our paths in the order: F,E2,T32,E1,T2,T31
1454 : * W2[j] associates to the j-th element of this list its index in P1. */
1455 4228 : fill_W2_W12(W, &S);
1456 4228 : W2 = gel(W, 2);
1457 4228 : nball = lg(W2)-1;
1458 4228 : gel(W,3) = reverse_list(W2, nbp1N);
1459 4228 : gel(W,5) = vecslice(gel(W,2), F->nb + E2->nb + T32->nb + 1, nball);
1460 4228 : gel(W,4) = reverse_list(gel(W,5), nbp1N);
1461 4228 : gel(W,13) = indices_forward(W, C);
1462 4228 : gel(W,14) = indices_backward(W, C);
1463 4228 : gel(W,15) = indices_oo(W, C);
1464 8456 : gel(W,11) = mkvecsmall5(F->nb,
1465 4228 : F->nb + E2->nb,
1466 4228 : F->nb + E2->nb + T32->nb,
1467 4228 : F->nb + E2->nb + T32->nb + E1->nb,
1468 4228 : F->nb + E2->nb + T32->nb + E1->nb + T2->nb);
1469 : /* relations between T32 and T31 [not stored!]
1470 : * T32[i] = - T31[i] */
1471 :
1472 : /* relations of F */
1473 4228 : width = E1->nb + T2->nb + T31->nb;
1474 : /* F_index[r] = [index_1, ..., index_k], where index_i is the p1_index()
1475 : * of the elementary unimodular path between 2 consecutive cusps
1476 : * [in E1,E2,T2,T31 or T32] */
1477 4228 : F_index = cgetg(F->nb+1, t_VEC);
1478 4228 : vecF = hash_to_vec(F);
1479 364322 : for (r = 1; r <= F->nb; r++)
1480 : {
1481 360094 : GEN w = gel(gel(vecF,r), 2);
1482 360094 : long a = w[1], b = w[2], d = labs(b - a);
1483 : /* c1 = cusp_list[a], c2 = cusp_list[b], ci != oo */
1484 360094 : gel(F_index,r) = (nbgen-d >= d-1)? F_indices(W, a,b)
1485 360094 : : F_indices_oo(W, lg(C)-1,a,b);
1486 : }
1487 :
1488 4228 : singlerel = cgetg(width+1, t_VEC);
1489 : /* form the single boundary relation */
1490 99057 : for (s = 1; s <= E2->nb; s++)
1491 : { /* reverse(E2[s]) = gamma * E1[c] */
1492 94829 : GEN T = gel(S.E2fromE1,s), gamma = E2fromE1_gamma(T);
1493 94829 : gel(singlerel, E2fromE1_c(T)) = mkmat22(gen_1,gen_1, gamma,gen_m1);
1494 : }
1495 7301 : for (r = E1->nb + 1; r <= width; r++) gel(singlerel, r) = gen_1;
1496 :
1497 : /* form the 2-torsion relations */
1498 4228 : annT2 = cgetg(T2->nb+1, t_VEC);
1499 4228 : vecT2 = hash_to_vec(T2);
1500 5824 : for (r = 1; r <= T2->nb; r++)
1501 : {
1502 1596 : GEN w = gel(vecT2,r);
1503 1596 : GEN gamma = gamma_equiv_matrix(vecreverse(w), w);
1504 1596 : gel(annT2, r) = mkmat22(gen_1,gen_1, gamma,gen_1);
1505 : }
1506 :
1507 : /* form the 3-torsion relations */
1508 4228 : annT31 = cgetg(T31->nb+1, t_VEC);
1509 4228 : vecT31 = hash_to_vec(T31);
1510 5705 : for (r = 1; r <= T31->nb; r++)
1511 : {
1512 1477 : GEN M = path_to_ZM( vecreverse(gel(vecT31,r)) );
1513 1477 : GEN gamma = ZM_mul(ZM_mul(M, TAU), SL2_inv_shallow(M));
1514 1477 : gel(annT31, r) = mkmat2(mkcol3(gen_1,gamma,ZM2_sqr(gamma)),
1515 : mkcol3(gen_1,gen_1,gen_1));
1516 : }
1517 4228 : gel(W,6) = F_index;
1518 4228 : gel(W,7) = S.E2fromE1;
1519 4228 : gel(W,8) = annT2;
1520 4228 : gel(W,9) = annT31;
1521 4228 : gel(W,10)= singlerel;
1522 4228 : return W;
1523 : }
1524 : static GEN
1525 112 : cusp_to_P1Q(GEN c) { return c[2]? sstoQ(c[1], c[2]): mkoo(); }
1526 : static GEN
1527 21 : mspathgens_i(GEN W)
1528 : {
1529 : GEN R, r, g, section, gen, annT2, annT31;
1530 : long i, l;
1531 21 : checkms(W); W = get_msN(W);
1532 21 : section = msN_get_section(W);
1533 21 : gen = ms_get_genindex(W);
1534 21 : l = lg(gen);
1535 21 : g = cgetg(l,t_VEC);
1536 77 : for (i = 1; i < l; i++)
1537 : {
1538 56 : GEN p = gel(section,gen[i]);
1539 56 : gel(g,i) = mkvec2(cusp_to_P1Q(gel(p,1)), cusp_to_P1Q(gel(p,2)));
1540 : }
1541 21 : annT2 = msN_get_annT2(W);
1542 21 : annT31= msN_get_annT31(W);
1543 21 : if (ms_get_N(W) == 1)
1544 : {
1545 7 : R = cgetg(3, t_VEC);
1546 7 : gel(R,1) = mkvec( mkvec2(gel(annT2,1), gen_1) );
1547 7 : gel(R,2) = mkvec( mkvec2(gel(annT31,1), gen_1) );
1548 : }
1549 : else
1550 : {
1551 14 : GEN singlerel = msN_get_singlerel(W);
1552 14 : long j, nbT2 = lg(annT2)-1, nbT31 = lg(annT31)-1, nbE1 = ms_get_nbE1(W);
1553 14 : R = cgetg(nbT2+nbT31+2, t_VEC);
1554 14 : l = lg(singlerel);
1555 14 : r = cgetg(l, t_VEC);
1556 42 : for (i = 1; i <= nbE1; i++)
1557 28 : gel(r,i) = mkvec2(gel(singlerel, i), utoi(i));
1558 35 : for (; i < l; i++)
1559 21 : gel(r,i) = mkvec2(gen_1, utoi(i));
1560 14 : gel(R,1) = r; j = 2;
1561 35 : for (i = 1; i <= nbT2; i++,j++)
1562 21 : gel(R,j) = mkvec( mkvec2(gel(annT2,i), utoi(i + nbE1)) );
1563 14 : for (i = 1; i <= nbT31; i++,j++)
1564 0 : gel(R,j) = mkvec( mkvec2(gel(annT31,i), utoi(i + nbE1 + nbT2)) );
1565 : }
1566 21 : return mkvec2(g,R);
1567 : }
1568 : GEN
1569 21 : mspathgens(GEN W)
1570 : {
1571 21 : pari_sp av = avma;
1572 21 : return gerepilecopy(av, mspathgens_i(W));
1573 : }
1574 : /* Modular symbols in weight k: Hom_Gamma(Delta, Q[x,y]_{k-2}) */
1575 : /* A symbol phi is represented by the {phi(g_i)}, {phi(g'_i)}, {phi(g''_i)}
1576 : * where the {g_i, g'_i, g''_i} are the Z[\Gamma]-generators of Delta,
1577 : * g_i corresponds to E1, g'_i to T2, g''_i to T31.
1578 : */
1579 :
1580 : /* FIXME: export. T^1, ..., T^n */
1581 : static GEN
1582 701834 : RgX_powers(GEN T, long n)
1583 : {
1584 701834 : GEN v = cgetg(n+1, t_VEC);
1585 : long i;
1586 701834 : gel(v, 1) = T;
1587 1643600 : for (i = 1; i < n; i++) gel(v,i+1) = RgX_mul(gel(v,i), T);
1588 701834 : return v;
1589 : }
1590 :
1591 : /* g = [a,b;c,d] a mat2. Return (X^{k-2} | g)(X,Y)[X = 1]. */
1592 : static GEN
1593 2604 : voo_act_Gl2Q(GEN g, long k)
1594 : {
1595 2604 : GEN mc = stoi(-coeff(g,2,1)), d = stoi(coeff(g,2,2));
1596 2604 : return RgX_to_RgC(gpowgs(deg1pol_shallow(mc, d, 0), k-2), k-1);
1597 : }
1598 :
1599 : struct m_act {
1600 : long dim, k, p;
1601 : GEN q;
1602 : GEN(*act)(struct m_act *,GEN);
1603 : };
1604 :
1605 : /* g = [a,b;c,d]. Return (P | g)(X,Y)[X = 1] = P(dX - cY, -b X + aY)[X = 1],
1606 : * for P = X^{k-2}, X^{k-3}Y, ..., Y^{k-2} */
1607 : GEN
1608 350749 : RgX_act_Gl2Q(GEN g, long k)
1609 : {
1610 : GEN a,b,c,d, V1,V2,V;
1611 : long i;
1612 350749 : if (k == 2) return matid(1);
1613 350749 : a = gcoeff(g,1,1); b = gcoeff(g,1,2);
1614 350749 : c = gcoeff(g,2,1); d = gcoeff(g,2,2);
1615 350749 : V1 = RgX_powers(deg1pol_shallow(gneg(c), d, 0), k-2); /* d - c Y */
1616 350749 : V2 = RgX_powers(deg1pol_shallow(a, gneg(b), 0), k-2); /*-b + a Y */
1617 350749 : V = cgetg(k, t_MAT);
1618 350749 : gel(V,1) = RgX_to_RgC(gel(V1, k-2), k-1);
1619 819280 : for (i = 1; i < k-2; i++)
1620 : {
1621 468531 : GEN v1 = gel(V1, k-2-i); /* (d-cY)^(k-2-i) */
1622 468531 : GEN v2 = gel(V2, i); /* (-b+aY)^i */
1623 468531 : gel(V,i+1) = RgX_to_RgC(RgX_mul(v1,v2), k-1);
1624 : }
1625 350749 : gel(V,k-1) = RgX_to_RgC(gel(V2, k-2), k-1);
1626 350749 : return V; /* V[i+1] = X^i | g */
1627 : }
1628 : /* z in Z[Gl2(Q)], return the matrix of z acting on V */
1629 : static GEN
1630 600649 : act_ZGl2Q(GEN z, struct m_act *T, hashtable *H)
1631 : {
1632 600649 : GEN S = NULL, G, E;
1633 : pari_sp av;
1634 : long l, j;
1635 : /* paranoia: should not occur */
1636 600649 : if (typ(z) == t_INT) return scalarmat_shallow(z, T->dim);
1637 600649 : G = gel(z,1); l = lg(G);
1638 600649 : E = gel(z,2); av = avma;
1639 1770307 : for (j = 1; j < l; j++)
1640 : {
1641 1169658 : GEN M, g = gel(G,j), n = gel(E,j);
1642 1169658 : if (typ(g) == t_INT) /* = 1 */
1643 3948 : M = n; /* n*Id_dim */
1644 : else
1645 : { /*search in H succeeds because of preload*/
1646 1165710 : M = H? (GEN)hash_search(H,g)->val: T->act(T,g);
1647 1165710 : if (is_pm1(n))
1648 1158185 : { if (signe(n) < 0) M = RgM_neg(M); }
1649 : else
1650 7525 : M = RgM_Rg_mul(M, n);
1651 : }
1652 1169658 : if (!S) { S = M; continue; }
1653 569009 : S = gadd(S, M);
1654 569009 : if (gc_needed(av,1))
1655 : {
1656 0 : if(DEBUGMEM>1) pari_warn(warnmem,"act_ZGl2Q, j = %ld",j);
1657 0 : S = gerepileupto(av, S);
1658 : }
1659 : }
1660 600649 : return gerepilecopy(av, S);
1661 : }
1662 : static GEN
1663 350602 : _RgX_act_Gl2Q(struct m_act *S, GEN z) { return RgX_act_Gl2Q(z, S->k); }
1664 : /* acting on (X^{k-2},...,Y^{k-2}) */
1665 : GEN
1666 60907 : RgX_act_ZGl2Q(GEN z, long k)
1667 : {
1668 : struct m_act T;
1669 60907 : T.k = k;
1670 60907 : T.dim = k-1;
1671 60907 : T.act=&_RgX_act_Gl2Q;
1672 60907 : return act_ZGl2Q(z, &T, NULL);
1673 : }
1674 :
1675 : /* First pass, identify matrices in Sl_2 to convert to operators;
1676 : * insert operators in hashtable. This allows GC in act_ZGl2Q */
1677 : static void
1678 1069894 : hash_preload(GEN M, struct m_act *S, hashtable *H)
1679 : {
1680 1069894 : if (typ(M) != t_INT)
1681 : {
1682 1069894 : ulong h = H->hash(M);
1683 1069894 : hashentry *e = hash_search2(H, M, h);
1684 1069894 : if (!e) hash_insert2(H, M, S->act(S,M), h);
1685 : }
1686 1069894 : }
1687 : /* z a sparse operator */
1688 : static void
1689 539728 : hash_vecpreload(GEN z, struct m_act *S, hashtable *H)
1690 : {
1691 539728 : GEN G = gel(z,1);
1692 539728 : long i, l = lg(G);
1693 1609622 : for (i = 1; i < l; i++) hash_preload(gel(G,i), S, H);
1694 539728 : }
1695 : static void
1696 40677 : ZGl2QC_preload(struct m_act *S, GEN v, hashtable *H)
1697 : {
1698 40677 : GEN val = gel(v,2);
1699 40677 : long i, l = lg(val);
1700 580405 : for (i = 1; i < l; i++) hash_vecpreload(gel(val,i), S, H);
1701 40677 : }
1702 : /* Given a sparse vector of elements in Z[G], convert it to a (sparse) vector
1703 : * of operators on V (given by t_MAT) */
1704 : static void
1705 40691 : ZGl2QC_to_act(struct m_act *S, GEN v, hashtable *H)
1706 : {
1707 40691 : GEN val = gel(v,2);
1708 40691 : long i, l = lg(val);
1709 580433 : for (i = 1; i < l; i++) gel(val,i) = act_ZGl2Q(gel(val,i), S, H);
1710 40691 : }
1711 :
1712 : /* For all V[i] in Z[\Gamma], find the P such that P . V[i]^* = 0;
1713 : * write P in basis X^{k-2}, ..., Y^{k-2} */
1714 : static GEN
1715 1260 : ZGV_tors(GEN V, long k)
1716 : {
1717 1260 : long i, l = lg(V);
1718 1260 : GEN v = cgetg(l, t_VEC);
1719 1764 : for (i = 1; i < l; i++)
1720 : {
1721 504 : GEN a = ZSl2_star(gel(V,i));
1722 504 : gel(v,i) = ZM_ker(RgX_act_ZGl2Q(a,k));
1723 : }
1724 1260 : return v;
1725 : }
1726 :
1727 : static long
1728 116583264 : set_from_index(GEN W11, long i)
1729 : {
1730 116583264 : if (i <= W11[1]) return 1;
1731 101477495 : if (i <= W11[2]) return 2;
1732 59091340 : if (i <= W11[3]) return 3;
1733 58897720 : if (i <= W11[4]) return 4;
1734 2330510 : if (i <= W11[5]) return 5;
1735 261849 : return 6;
1736 : }
1737 :
1738 : /* det M = 1 */
1739 : static void
1740 1535667 : treat_index(GEN W, GEN M, long index, GEN v)
1741 : {
1742 1535667 : GEN W11 = gel(W,11);
1743 1535667 : long shift = W11[3]; /* #F + #E2 + T32 */
1744 1535667 : switch(set_from_index(W11, index))
1745 : {
1746 251167 : case 1: /*F*/
1747 : {
1748 251167 : GEN F_index = gel(W,6), ind = gel(F_index, index);
1749 251167 : long j, l = lg(ind);
1750 1288371 : for (j = 1; j < l; j++)
1751 : {
1752 1037204 : GEN IND = gel(ind,j), M0 = gel(IND,2);
1753 1037204 : long index = mael(IND,1,1);
1754 1037204 : treat_index(W, ZM_mul(M,M0), index, v);
1755 : }
1756 251167 : break;
1757 : }
1758 :
1759 579957 : case 2: /*E2, E2[r] + gamma * E1[s] = 0 */
1760 : {
1761 579957 : long r = index - W11[1];
1762 579957 : GEN z = gel(msN_get_E2fromE1(W), r);
1763 :
1764 579957 : index = E2fromE1_c(z);
1765 579957 : M = G_ZG_mul(M, E2fromE1_Zgamma(z)); /* M * (-gamma) */
1766 579957 : gel(v, index) = ZG_add(gel(v, index), M);
1767 579957 : break;
1768 : }
1769 :
1770 5922 : case 3: /*T32, T32[i] = -T31[i] */
1771 : {
1772 5922 : long T3shift = W11[5] - W11[2]; /* #T32 + #E1 + #T2 */
1773 5922 : index += T3shift;
1774 5922 : index -= shift;
1775 5922 : gel(v, index) = ZG_add(gel(v, index), to_famat_shallow(M,gen_m1));
1776 5922 : break;
1777 : }
1778 698621 : default: /*E1,T2,T31*/
1779 698621 : index -= shift;
1780 698621 : gel(v, index) = ZG_add(gel(v, index), to_famat_shallow(M,gen_1));
1781 698621 : break;
1782 : }
1783 1535667 : }
1784 : static void
1785 115047597 : treat_index_trivial(GEN v, GEN W, long index)
1786 : {
1787 115047597 : GEN W11 = gel(W,11);
1788 115047597 : long shift = W11[3]; /* #F + #E2 + T32 */
1789 115047597 : switch(set_from_index(W11, index))
1790 : {
1791 14854602 : case 1: /*F*/
1792 : {
1793 14854602 : GEN F_index = gel(W,6), ind = gel(F_index, index);
1794 14854602 : long j, l = lg(ind);
1795 105394835 : for (j = 1; j < l; j++)
1796 : {
1797 90540233 : GEN IND = gel(ind,j);
1798 90540233 : treat_index_trivial(v, W, mael(IND,1,1));
1799 : }
1800 14854602 : break;
1801 : }
1802 :
1803 41806198 : case 2: /*E2, E2[r] + gamma * E1[s] = 0 */
1804 : {
1805 41806198 : long r = index - W11[1];
1806 41806198 : long s = E2fromE1_c(gel(msN_get_E2fromE1(W), r));
1807 41806198 : v[s]--;
1808 41806198 : break;
1809 : }
1810 :
1811 2499672 : case 3: case 5: case 6: /*T32,T2,T31*/
1812 2499672 : break;
1813 :
1814 55887125 : case 4: /*E1*/
1815 55887125 : v[index-shift]++;
1816 55887125 : break;
1817 : }
1818 115047597 : }
1819 :
1820 : static GEN
1821 178213 : M2_log(GEN W, GEN M)
1822 : {
1823 178213 : GEN a = gcoeff(M,1,1), b = gcoeff(M,1,2);
1824 178213 : GEN c = gcoeff(M,2,1), d = gcoeff(M,2,2);
1825 : GEN u, v, D, V;
1826 : long index, s;
1827 :
1828 178213 : W = get_msN(W);
1829 178213 : V = zerovec(ms_get_nbgen(W));
1830 :
1831 178213 : D = subii(mulii(a,d), mulii(b,c));
1832 178213 : s = signe(D);
1833 178213 : if (!s) return V;
1834 176869 : if (is_pm1(D))
1835 : { /* shortcut, no need to apply Manin's trick */
1836 63399 : if (s < 0) { b = negi(b); d = negi(d); }
1837 63399 : M = Gamma0N_decompose(W, mkmat22(a,b, c,d), &index);
1838 63399 : treat_index(W, M, index, V);
1839 : }
1840 : else
1841 : {
1842 : GEN U, B, P, Q, PQ, C1,C2;
1843 : long i, l;
1844 113470 : (void)bezout(a,c,&u,&v);
1845 113470 : B = addii(mulii(b,u), mulii(d,v));
1846 : /* [u,v;-c,a] [a,b; c,d] = [1,B; 0,D], i.e. M = U [1,B;0,D] */
1847 113470 : U = mkmat22(a,negi(v), c,u);
1848 :
1849 : /* {1/0 -> B/D} as \sum g_i, g_i unimodular paths */
1850 113470 : PQ = ZV_allpnqn( gboundcf(gdiv(B,D), 0) );
1851 113470 : P = gel(PQ,1); l = lg(P);
1852 113470 : Q = gel(PQ,2);
1853 113470 : C1 = gel(U,1);
1854 548534 : for (i = 1; i < l; i++, C1 = C2)
1855 : {
1856 : GEN M;
1857 435064 : C2 = ZM_ZC_mul(U, mkcol2(gel(P,i), gel(Q,i)));
1858 435064 : if (!odd(i)) C1 = ZC_neg(C1);
1859 435064 : M = Gamma0N_decompose(W, mkmat2(C1,C2), &index);
1860 435064 : treat_index(W, M, index, V);
1861 : }
1862 : }
1863 176869 : return V;
1864 : }
1865 :
1866 : /* express +oo->q=a/b in terms of the Z[G]-generators, trivial action */
1867 : static void
1868 2246944 : Q_log_trivial(GEN v, GEN W, GEN q)
1869 : {
1870 2246944 : GEN Q, W3 = gel(W,3), p1N = msN_get_p1N(W);
1871 2246944 : ulong c,d, N = p1N_get_N(p1N);
1872 : long i, lx;
1873 :
1874 2246944 : Q = Q_log_init(N, q);
1875 2246944 : lx = lg(Q);
1876 2246944 : c = 0;
1877 23633848 : for (i = 1; i < lx; i++, c = d)
1878 : {
1879 : long index;
1880 21386904 : d = Q[i];
1881 21386904 : if (c && !odd(i)) c = N - c;
1882 21386904 : index = W3[ p1_index(c,d,p1N) ];
1883 21386904 : treat_index_trivial(v, W, index);
1884 : }
1885 2246944 : }
1886 : static void
1887 1248121 : M2_log_trivial(GEN V, GEN W, GEN M)
1888 : {
1889 1248121 : GEN p1N = gel(W,1), W3 = gel(W,3);
1890 1248121 : ulong N = p1N_get_N(p1N);
1891 1248121 : GEN a = gcoeff(M,1,1), b = gcoeff(M,1,2);
1892 1248121 : GEN c = gcoeff(M,2,1), d = gcoeff(M,2,2);
1893 : GEN u, v, D;
1894 : long index, s;
1895 :
1896 1248121 : D = subii(mulii(a,d), mulii(b,c));
1897 1248121 : s = signe(D);
1898 1265537 : if (!s) return;
1899 1248114 : if (is_pm1(D))
1900 : { /* shortcut, not need to apply Manin's trick */
1901 449386 : if (s < 0) d = negi(d);
1902 449386 : index = W3[ p1_index(umodiu(c,N),umodiu(d,N),p1N) ];
1903 449386 : treat_index_trivial(V, W, index);
1904 : }
1905 : else
1906 : {
1907 : GEN U, B, P, Q, PQ;
1908 : long i, l;
1909 798728 : if (!signe(c)) { Q_log_trivial(V,W,gdiv(b,d)); return; }
1910 781312 : (void)bezout(a,c,&u,&v);
1911 781312 : B = addii(mulii(b,u), mulii(d,v));
1912 : /* [u,v;-c,a] [a,b; c,d] = [1,B; 0,D], i.e. M = U [1,B;0,D] */
1913 781312 : U = mkvec2(c, u);
1914 :
1915 : /* {1/0 -> B/D} as \sum g_i, g_i unimodular paths */
1916 781312 : PQ = ZV_allpnqn( gboundcf(gdiv(B,D), 0) );
1917 781312 : P = gel(PQ,1); l = lg(P);
1918 781312 : Q = gel(PQ,2);
1919 3452386 : for (i = 1; i < l; i++, c = d)
1920 : {
1921 2671074 : d = addii(mulii(gel(U,1),gel(P,i)), mulii(gel(U,2),gel(Q,i)));
1922 2671074 : if (!odd(i)) c = negi(c);
1923 2671074 : index = W3[ p1_index(umodiu(c,N),umodiu(d,N),p1N) ];
1924 2671074 : treat_index_trivial(V, W, index);
1925 : }
1926 : }
1927 : }
1928 :
1929 : static GEN
1930 16772 : cusp_to_ZC(GEN c)
1931 : {
1932 16772 : switch(typ(c))
1933 : {
1934 35 : case t_INFINITY:
1935 35 : return mkcol2(gen_1,gen_0);
1936 91 : case t_INT:
1937 91 : return mkcol2(c,gen_1);
1938 140 : case t_FRAC:
1939 140 : return mkcol2(gel(c,1),gel(c,2));
1940 16506 : case t_VECSMALL:
1941 16506 : return mkcol2(stoi(c[1]), stoi(c[2]));
1942 0 : default:
1943 0 : pari_err_TYPE("mspathlog",c);
1944 : return NULL;/*LCOV_EXCL_LINE*/
1945 : }
1946 : }
1947 : static GEN
1948 8386 : path2_to_M2(GEN p)
1949 8386 : { return mkmat2(cusp_to_ZC(gel(p,1)), cusp_to_ZC(gel(p,2))); }
1950 : static GEN
1951 54439 : path_to_M2(GEN p)
1952 : {
1953 54439 : if (lg(p) != 3) pari_err_TYPE("mspathlog",p);
1954 54432 : switch(typ(p))
1955 : {
1956 48160 : case t_MAT:
1957 48160 : RgM_check_ZM(p,"mspathlog");
1958 48160 : break;
1959 6272 : case t_VEC:
1960 6272 : p = path2_to_M2(p);
1961 6272 : break;
1962 0 : default: pari_err_TYPE("mspathlog",p);
1963 : }
1964 54432 : return p;
1965 : }
1966 : /* Expresses path p as \sum x_i g_i, where the g_i are our distinguished
1967 : * generators and x_i \in Z[\Gamma]. Returns [x_1,...,x_n] */
1968 : GEN
1969 12691 : mspathlog(GEN W, GEN p)
1970 : {
1971 12691 : pari_sp av = avma;
1972 12691 : checkms(W);
1973 12691 : return gerepilecopy(av, M2_log(W, path_to_M2(p)));
1974 : }
1975 :
1976 : /** HECKE OPERATORS **/
1977 : /* [a,b;c,d] * cusp */
1978 : static GEN
1979 2733696 : cusp_mul(long a, long b, long c, long d, GEN cusp)
1980 : {
1981 2733696 : long x = cusp[1], y = cusp[2];
1982 2733696 : long A = a*x+b*y, B = c*x+d*y, u = cgcd(A,B);
1983 2733696 : if (u != 1) { A /= u; B /= u; }
1984 2733696 : return mkcol2s(A, B);
1985 : }
1986 : /* f in Gl2(Q), act on path (zm), return path_to_M2(f.path) */
1987 : static GEN
1988 1366848 : Gl2Q_act_path(GEN f, GEN path)
1989 : {
1990 1366848 : long a = coeff(f,1,1), b = coeff(f,1,2);
1991 1366848 : long c = coeff(f,2,1), d = coeff(f,2,2);
1992 1366848 : GEN c1 = cusp_mul(a,b,c,d, gel(path,1));
1993 1366848 : GEN c2 = cusp_mul(a,b,c,d, gel(path,2));
1994 1366848 : return mkmat2(c1,c2);
1995 : }
1996 :
1997 : static GEN
1998 2561678 : init_act_trivial(GEN W) { return const_vecsmall(ms_get_nbE1(W), 0); }
1999 : static GEN
2000 41734 : mspathlog_trivial(GEN W, GEN p)
2001 : {
2002 : GEN v;
2003 41734 : W = get_msN(W);
2004 41734 : v = init_act_trivial(W);
2005 41734 : M2_log_trivial(v, W, path_to_M2(p));
2006 41727 : return v;
2007 : }
2008 :
2009 : /* map from W1=Hom(Delta_0(N1),Q) -> W2=Hom(Delta_0(N2),Q), weight 2,
2010 : * trivial action. v a t_VEC of Gl2_Q (\sum v[i] in Z[Gl2(Q)]).
2011 : * Return the matrix attached to the action of v. */
2012 : static GEN
2013 8575 : getMorphism_trivial(GEN WW1, GEN WW2, GEN v)
2014 : {
2015 8575 : GEN T, section, gen, W1 = get_msN(WW1), W2 = get_msN(WW2);
2016 : long j, lv, d2;
2017 8575 : if (ms_get_N(W1) == 1) return cgetg(1,t_MAT);
2018 8575 : if (ms_get_N(W2) == 1) return zeromat(0, ms_get_nbE1(W1));
2019 8575 : section = msN_get_section(W2);
2020 8575 : gen = msN_get_genindex(W2);
2021 8575 : d2 = ms_get_nbE1(W2);
2022 8575 : T = cgetg(d2+1, t_MAT);
2023 8575 : lv = lg(v);
2024 298991 : for (j = 1; j <= d2; j++)
2025 : {
2026 290416 : GEN w = gel(section, gen[j]);
2027 290416 : GEN t = init_act_trivial(W1);
2028 290416 : pari_sp av = avma;
2029 : long l;
2030 1496810 : for (l = 1; l < lv; l++) M2_log_trivial(t, W1, Gl2Q_act_path(gel(v,l), w));
2031 290416 : gel(T,j) = t; set_avma(av);
2032 : }
2033 8575 : return shallowtrans(zm_to_ZM(T));
2034 : }
2035 :
2036 : static GEN
2037 165522 : RgV_sparse(GEN v, GEN *pind)
2038 : {
2039 : long i, l, k;
2040 165522 : GEN w = cgetg_copy(v,&l), ind = cgetg(l, t_VECSMALL);
2041 17143112 : for (i = k = 1; i < l; i++)
2042 : {
2043 16977590 : GEN c = gel(v,i);
2044 16977590 : if (typ(c) == t_INT) continue;
2045 784798 : gel(w,k) = c; ind[k] = i; k++;
2046 : }
2047 165522 : setlg(w,k); setlg(ind,k);
2048 165522 : *pind = ind; return w;
2049 : }
2050 :
2051 : static int
2052 162568 : mat2_isidentity(GEN M)
2053 : {
2054 162568 : GEN A = gel(M,1), B = gel(M,2);
2055 162568 : return A[1] == 1 && A[2] == 0 && B[1] == 0 && B[2] == 1;
2056 : }
2057 : /* path a mat22/mat22s, return log(f.path)^* . f in sparse form */
2058 : static GEN
2059 165522 : M2_logf(GEN Wp, GEN path, GEN f)
2060 : {
2061 165522 : pari_sp av = avma;
2062 : GEN ind, L;
2063 : long i, l;
2064 165522 : if (f)
2065 160454 : path = Gl2Q_act_path(f, path);
2066 5068 : else if (typ(gel(path,1)) == t_VECSMALL)
2067 2114 : path = path2_to_M2(path);
2068 165522 : L = M2_log(Wp, path);
2069 165522 : L = RgV_sparse(L,&ind); l = lg(L);
2070 950320 : for (i = 1; i < l; i++) gel(L,i) = ZSl2_star(gel(L,i));
2071 165522 : if (f) ZGC_G_mul_inplace(L, mat2_to_ZM(f));
2072 165522 : return gerepilecopy(av, mkvec2(ind,L));
2073 : }
2074 :
2075 : static hashtable *
2076 3668 : Gl2act_cache(long dim) { return set_init(dim*10); }
2077 :
2078 : /* f zm/ZM in Gl_2(Q), acts from the left on Delta, which is generated by
2079 : * (g_i) as Z[Gamma1]-module, and by (G_i) as Z[Gamma2]-module.
2080 : * We have f.G_j = \sum_i \lambda_{i,j} g_i, \lambda_{i,j} in Z[Gamma1]
2081 : * For phi in Hom_Gamma1(D,V), g in D, phi | f is in Hom_Gamma2(D,V) and
2082 : * (phi | f)(G_j) = phi(f.G_j) | f
2083 : * = phi( \sum_i \lambda_{i,j} g_i ) | f
2084 : * = \sum_i phi(g_i) | (\lambda_{i,j}^* f)
2085 : * = \sum_i phi(g_i) | \mu_{i,j}(f)
2086 : * More generally
2087 : * (\sum_k (phi |v_k))(G_j) = \sum_i phi(g_i) | \Mu_{i,j}
2088 : * with \Mu_{i,j} = \sum_k \mu{i,j}(v_k)
2089 : * Return the \Mu_{i,j} matrix as vector of sparse columns of operators on V */
2090 : static GEN
2091 3192 : init_dual_act(GEN v, GEN W1, GEN W2, struct m_act *S)
2092 : {
2093 3192 : GEN section = ms_get_section(W2), gen = ms_get_genindex(W2);
2094 : /* HACK: the actions we consider in dimension 1 are trivial and in
2095 : * characteristic != 2, 3 => torsion generators are 0
2096 : * [satisfy e.g. (1+gamma).g = 0 => \phi(g) | 1+gamma = 0 => \phi(g) = 0 */
2097 3192 : long j, lv = lg(v), dim = S->dim == 1? ms_get_nbE1(W2): lg(gen)-1;
2098 3192 : GEN T = cgetg(dim+1, t_VEC);
2099 3192 : hashtable *H = Gl2act_cache(dim);
2100 40929 : for (j = 1; j <= dim; j++)
2101 : {
2102 37737 : pari_sp av = avma;
2103 37737 : GEN w = gel(section, gen[j]); /* path_to_zm( E1/T2/T3 element ) */
2104 37737 : GEN t = NULL;
2105 : long k;
2106 200305 : for (k = 1; k < lv; k++)
2107 : {
2108 162568 : GEN tk, f = gel(v,k);
2109 162568 : if (typ(gel(f,1)) != t_VECSMALL) f = ZM_to_zm(f);
2110 162568 : if (mat2_isidentity(f)) f = NULL;
2111 162568 : tk = M2_logf(W1, w, f); /* mu_{.,j}(v[k]) as sparse vector */
2112 162568 : t = t? ZGCs_add(t, tk): tk;
2113 : }
2114 37737 : gel(T,j) = gerepilecopy(av, t);
2115 : }
2116 40929 : for (j = 1; j <= dim; j++)
2117 : {
2118 37737 : ZGl2QC_preload(S, gel(T,j), H);
2119 37737 : ZGl2QC_to_act(S, gel(T,j), H);
2120 : }
2121 3192 : return T;
2122 : }
2123 :
2124 : /* modular symbol given by phi[j] = \phi(G_j)
2125 : * \sum L[i]*phi[i], L a sparse column of operators */
2126 : static GEN
2127 354354 : dense_act_col(GEN col, GEN phi)
2128 : {
2129 354354 : GEN s = NULL, colind = gel(col,1), colval = gel(col,2);
2130 354354 : long i, l = lg(colind), lphi = lg(phi);
2131 5630121 : for (i = 1; i < l; i++)
2132 : {
2133 5278490 : long a = colind[i];
2134 : GEN t;
2135 5278490 : if (a >= lphi) break; /* happens if k=2: torsion generator t omitted */
2136 5275767 : t = gel(phi, a); /* phi(G_a) */
2137 5275767 : t = RgM_RgC_mul(gel(colval,i), t);
2138 5275767 : s = s? RgC_add(s, t): t;
2139 : }
2140 354354 : return s;
2141 : }
2142 : /* modular symbol given by \phi( G[ind[j]] ) = val[j]
2143 : * \sum L[i]*phi[i], L a sparse column of operators */
2144 : static GEN
2145 779093 : sparse_act_col(GEN col, GEN phi)
2146 : {
2147 779093 : GEN s = NULL, colind = gel(col,1), colval = gel(col,2);
2148 779093 : GEN ind = gel(phi,2), val = gel(phi,3);
2149 779093 : long a, l = lg(ind);
2150 779093 : if (lg(gel(phi,1)) == 1) return RgM_RgC_mul(gel(colval,1), gel(val,1));
2151 3033205 : for (a = 1; a < l; a++)
2152 : {
2153 2254413 : GEN t = gel(val, a); /* phi(G_i) */
2154 2254413 : long i = zv_search(colind, ind[a]);
2155 2254413 : if (!i) continue;
2156 540603 : t = RgM_RgC_mul(gel(colval,i), t);
2157 540603 : s = s? RgC_add(s, t): t;
2158 : }
2159 778792 : return s;
2160 : }
2161 : static int
2162 69139 : phi_sparse(GEN phi) { return typ(gel(phi,1)) == t_VECSMALL; }
2163 : /* phi in Hom_Gamma1(Delta, V), return the matrix whose colums are the
2164 : * \sum_i phi(g_i) | \mu_{i,j} = (phi|f)(G_j),
2165 : * see init_dual_act. */
2166 : static GEN
2167 69139 : dual_act(long dimV, GEN act, GEN phi)
2168 : {
2169 69139 : long l = lg(act), j;
2170 69139 : GEN v = cgetg(l, t_MAT);
2171 69139 : GEN (*ACT)(GEN,GEN) = phi_sparse(phi)? sparse_act_col: dense_act_col;
2172 1199254 : for (j = 1; j < l; j++)
2173 : {
2174 1130115 : pari_sp av = avma;
2175 1130115 : GEN s = ACT(gel(act,j), phi);
2176 1130115 : gel(v,j) = s? gerepileupto(av,s): zerocol(dimV);
2177 : }
2178 69139 : return v;
2179 : }
2180 :
2181 : /* in level N > 1 */
2182 : static void
2183 59087 : msk_get_st(GEN W, long *s, long *t)
2184 59087 : { GEN st = gmael(W,3,3); *s = st[1]; *t = st[2]; }
2185 : static GEN
2186 59087 : msk_get_link(GEN W) { return gmael(W,3,4); }
2187 : static GEN
2188 59402 : msk_get_inv(GEN W) { return gmael(W,3,5); }
2189 : /* \phi in Hom(Delta, V), \phi(G_k) = phi[k]. Write \phi as
2190 : * \sum_{i,j} mu_{i,j} phi_{i,j}, mu_{i,j} in Q */
2191 : static GEN
2192 59402 : getMorphism_basis(GEN W, GEN phi)
2193 : {
2194 59402 : GEN R, Q, Ls, T0, T1, Ts, link, basis, inv = msk_get_inv(W);
2195 : long i, j, r, s, t, dim, lvecT;
2196 :
2197 59402 : if (ms_get_N(W) == 1) return ZC_apply_dinv(inv, gel(phi,1));
2198 59087 : lvecT = lg(phi);
2199 59087 : basis = msk_get_basis(W);
2200 59087 : dim = lg(basis)-1;
2201 59087 : R = zerocol(dim);
2202 59087 : msk_get_st(W, &s, &t);
2203 59087 : link = msk_get_link(W);
2204 789922 : for (r = 2; r < lvecT; r++)
2205 : {
2206 : GEN Tr, L;
2207 730835 : if (r == s) continue;
2208 671748 : Tr = gel(phi,r); /* Phi(G_r), r != 1,s */
2209 671748 : L = gel(link, r);
2210 671748 : Q = ZC_apply_dinv(gel(inv,r), Tr);
2211 : /* write Phi(G_r) as sum_{a,b} mu_{a,b} Phi_{a,b}(G_r) */
2212 3510668 : for (j = 1; j < lg(L); j++) gel(R, L[j]) = gel(Q,j);
2213 : }
2214 59087 : Ls = gel(link, s);
2215 59087 : T1 = gel(phi,1); /* Phi(G_1) */
2216 59087 : gel(R, Ls[t]) = gel(T1, 1);
2217 :
2218 59087 : T0 = NULL;
2219 789922 : for (i = 2; i < lg(link); i++)
2220 : {
2221 : GEN L;
2222 730835 : if (i == s) continue;
2223 671748 : L = gel(link,i);
2224 3510668 : for (j =1 ; j < lg(L); j++)
2225 : {
2226 2838920 : long n = L[j]; /* phi_{i,j} = basis[n] */
2227 2838920 : GEN mu_ij = gel(R, n);
2228 2838920 : GEN phi_ij = gel(basis, n), pols = gel(phi_ij,3);
2229 2838920 : GEN z = RgC_Rg_mul(gel(pols, 3), mu_ij);
2230 2838920 : T0 = T0? RgC_add(T0, z): z; /* += mu_{i,j} Phi_{i,j} (G_s) */
2231 : }
2232 : }
2233 59087 : Ts = gel(phi,s); /* Phi(G_s) */
2234 59087 : if (T0) Ts = RgC_sub(Ts, T0);
2235 : /* solve \sum_{j!=t} mu_{s,j} Phi_{s,j}(G_s) = Ts */
2236 59087 : Q = ZC_apply_dinv(gel(inv,s), Ts);
2237 234080 : for (j = 1; j < t; j++) gel(R, Ls[j]) = gel(Q,j);
2238 : /* avoid mu_{s,t} */
2239 59906 : for (j = t; j < lg(Q); j++) gel(R, Ls[j+1]) = gel(Q,j);
2240 59087 : return R;
2241 : }
2242 :
2243 : /* a = s(g_i) for some modular symbol s; b in Z[G]
2244 : * return s(b.g_i) = b^* . s(g_i) */
2245 : static GEN
2246 115626 : ZGl2Q_act_s(GEN b, GEN a, long k)
2247 : {
2248 115626 : if (typ(b) == t_INT)
2249 : {
2250 58604 : if (!signe(b)) return gen_0;
2251 14 : switch(typ(a))
2252 : {
2253 14 : case t_POL:
2254 14 : a = RgX_to_RgC(a, k-1); /*fall through*/
2255 14 : case t_COL:
2256 14 : a = RgC_Rg_mul(a,b);
2257 14 : break;
2258 0 : default: a = scalarcol_shallow(b,k-1);
2259 : }
2260 : }
2261 : else
2262 : {
2263 57022 : b = RgX_act_ZGl2Q(ZSl2_star(b), k);
2264 57022 : switch(typ(a))
2265 : {
2266 63 : case t_POL:
2267 63 : a = RgX_to_RgC(a, k-1); /*fall through*/
2268 45262 : case t_COL:
2269 45262 : a = RgM_RgC_mul(b,a);
2270 45262 : break;
2271 11760 : default: a = RgC_Rg_mul(gel(b,1),a);
2272 : }
2273 : }
2274 57036 : return a;
2275 : }
2276 :
2277 : static int
2278 21 : checksymbol(GEN W, GEN s)
2279 : {
2280 : GEN t, annT2, annT31, singlerel;
2281 : long i, k, l, nbE1, nbT2, nbT31;
2282 21 : k = msk_get_weight(W);
2283 21 : W = get_msN(W);
2284 21 : nbE1 = ms_get_nbE1(W);
2285 21 : singlerel = gel(W,10);
2286 21 : l = lg(singlerel);
2287 21 : if (k == 2)
2288 : {
2289 0 : for (i = nbE1+1; i < l; i++)
2290 0 : if (!gequal0(gel(s,i))) return 0;
2291 0 : return 1;
2292 : }
2293 21 : annT2 = msN_get_annT2(W); nbT2 = lg(annT2)-1;
2294 21 : annT31 = msN_get_annT31(W);nbT31 = lg(annT31)-1;
2295 21 : t = NULL;
2296 84 : for (i = 1; i < l; i++)
2297 : {
2298 63 : GEN a = gel(s,i);
2299 63 : a = ZGl2Q_act_s(gel(singlerel,i), a, k);
2300 63 : t = t? gadd(t, a): a;
2301 : }
2302 21 : if (!gequal0(t)) return 0;
2303 14 : for (i = 1; i <= nbT2; i++)
2304 : {
2305 0 : GEN a = gel(s,i + nbE1);
2306 0 : a = ZGl2Q_act_s(gel(annT2,i), a, k);
2307 0 : if (!gequal0(a)) return 0;
2308 : }
2309 28 : for (i = 1; i <= nbT31; i++)
2310 : {
2311 14 : GEN a = gel(s,i + nbE1 + nbT2);
2312 14 : a = ZGl2Q_act_s(gel(annT31,i), a, k);
2313 14 : if (!gequal0(a)) return 0;
2314 : }
2315 14 : return 1;
2316 : }
2317 : GEN
2318 56 : msissymbol(GEN W, GEN s)
2319 : {
2320 : long k, nbgen;
2321 56 : checkms(W);
2322 56 : k = msk_get_weight(W);
2323 56 : nbgen = ms_get_nbgen(W);
2324 56 : switch(typ(s))
2325 : {
2326 21 : case t_VEC: /* values s(g_i) */
2327 21 : if (lg(s)-1 != nbgen) return gen_0;
2328 21 : break;
2329 28 : case t_COL:
2330 28 : if (msk_get_sign(W))
2331 : {
2332 0 : GEN star = gel(msk_get_starproj(W), 1);
2333 0 : if (lg(star) == lg(s)) return gen_1;
2334 : }
2335 28 : if (k == 2) /* on the dual basis of (g_i) */
2336 : {
2337 0 : if (lg(s)-1 != nbgen) return gen_0;
2338 : }
2339 : else
2340 : {
2341 28 : GEN basis = msk_get_basis(W);
2342 28 : return (lg(s) == lg(basis))? gen_1: gen_0;
2343 : }
2344 0 : break;
2345 7 : case t_MAT:
2346 : {
2347 7 : long i, l = lg(s);
2348 7 : GEN v = cgetg(l, t_VEC);
2349 21 : for (i = 1; i < l; i++) gel(v,i) = msissymbol(W,gel(s,i))? gen_1: gen_0;
2350 7 : return v;
2351 : }
2352 0 : default: return gen_0;
2353 : }
2354 21 : return checksymbol(W,s)? gen_1: gen_0;
2355 : }
2356 :
2357 : /* map op: W1 = Hom(Delta_0(N1),V) -> W2 = Hom(Delta_0(N2),V), given by
2358 : * \sum v[i], v[i] in Gl2(Q) */
2359 : static GEN
2360 11284 : getMorphism(GEN W1, GEN W2, GEN v)
2361 : {
2362 : struct m_act S;
2363 : GEN B1, M, act;
2364 11284 : long a, l, k = msk_get_weight(W1);
2365 11284 : if (k == 2) return getMorphism_trivial(W1,W2,v);
2366 2709 : S.k = k;
2367 2709 : S.dim = k-1;
2368 2709 : S.act = &_RgX_act_Gl2Q;
2369 2709 : act = init_dual_act(v,W1,W2,&S);
2370 2709 : B1 = msk_get_basis(W1);
2371 2709 : l = lg(B1); M = cgetg(l, t_MAT);
2372 61180 : for (a = 1; a < l; a++)
2373 : {
2374 58471 : pari_sp av = avma;
2375 58471 : GEN phi = dual_act(S.dim, act, gel(B1,a));
2376 58471 : GEN D = getMorphism_basis(W2, phi);
2377 58471 : gel(M,a) = gerepilecopy(av, D);
2378 : }
2379 2709 : return M;
2380 : }
2381 : static GEN
2382 10122 : msendo(GEN W, GEN v) { return getMorphism(W, W, v); }
2383 :
2384 : static GEN
2385 2527 : endo_project(GEN W, GEN e, GEN H)
2386 : {
2387 2527 : if (msk_get_sign(W)) e = Qevproj_apply(e, msk_get_starproj(W));
2388 2527 : if (H) e = Qevproj_apply(e, Qevproj_init0(H));
2389 2527 : return e;
2390 : }
2391 : static GEN
2392 6146 : mshecke_i(GEN W, ulong p)
2393 : {
2394 6146 : GEN v = ms_get_N(W) % p? Tp_matrices(p): Up_matrices(p);
2395 6146 : return msendo(W,v);
2396 : }
2397 : GEN
2398 2478 : mshecke(GEN W, long p, GEN H)
2399 : {
2400 2478 : pari_sp av = avma;
2401 : GEN T;
2402 2478 : checkms(W);
2403 2478 : if (p <= 1) pari_err_PRIME("mshecke",stoi(p));
2404 2478 : T = mshecke_i(W,p);
2405 2478 : T = endo_project(W,T,H);
2406 2478 : return gerepilecopy(av, T);
2407 : }
2408 :
2409 : static GEN
2410 42 : msatkinlehner_i(GEN W, long Q)
2411 : {
2412 42 : long N = ms_get_N(W);
2413 : GEN v;
2414 42 : if (Q == 1) return matid(msk_get_dim(W));
2415 28 : if (Q == N) return msendo(W, mkvec(mat2(0,1,-N,0)));
2416 21 : if (N % Q) pari_err_DOMAIN("msatkinlehner","N % Q","!=",gen_0,stoi(Q));
2417 14 : v = WQ_matrix(N, Q);
2418 14 : if (!v) pari_err_DOMAIN("msatkinlehner","gcd(Q,N/Q)","!=",gen_1,stoi(Q));
2419 14 : return msendo(W,mkvec(v));
2420 : }
2421 : GEN
2422 42 : msatkinlehner(GEN W, long Q, GEN H)
2423 : {
2424 42 : pari_sp av = avma;
2425 : GEN w;
2426 : long k;
2427 42 : checkms(W);
2428 42 : k = msk_get_weight(W);
2429 42 : if (Q <= 0) pari_err_DOMAIN("msatkinlehner","Q","<=",gen_0,stoi(Q));
2430 42 : w = msatkinlehner_i(W,Q);
2431 35 : w = endo_project(W,w,H);
2432 35 : if (k > 2 && Q != 1) w = RgM_Rg_div(w, powuu(Q,(k-2)>>1));
2433 35 : return gerepilecopy(av, w);
2434 : }
2435 :
2436 : static GEN
2437 3955 : msstar_i(GEN W) { return msendo(W, mkvec(mat2(-1,0,0,1))); }
2438 : GEN
2439 14 : msstar(GEN W, GEN H)
2440 : {
2441 14 : pari_sp av = avma;
2442 : GEN s;
2443 14 : checkms(W);
2444 14 : s = msstar_i(W);
2445 14 : s = endo_project(W,s,H);
2446 14 : return gerepilecopy(av, s);
2447 : }
2448 :
2449 : #if 0
2450 : /* is \Gamma_0(N) cusp1 = \Gamma_0(N) cusp2 ? */
2451 : static int
2452 : iscuspeq(ulong N, GEN cusp1, GEN cusp2)
2453 : {
2454 : long p1, q1, p2, q2, s1, s2, d;
2455 : p1 = cusp1[1]; p2 = cusp2[1];
2456 : q1 = cusp1[2]; q2 = cusp2[2];
2457 : d = Fl_mul(umodsu(q1,N),umodsu(q2,N), N);
2458 : d = ugcd(d, N);
2459 :
2460 : s1 = q1 > 2? Fl_inv(umodsu(p1,q1), q1): 1;
2461 : s2 = q2 > 2? Fl_inv(umodsu(p2,q2), q2): 1;
2462 : return Fl_mul(s1,q2,d) == Fl_mul(s2,q1,d);
2463 : }
2464 : #endif
2465 :
2466 : /* return E_c(r) */
2467 : static GEN
2468 2604 : get_Ec_r(GEN c, long k)
2469 : {
2470 2604 : long p = c[1], q = c[2], u, v;
2471 : GEN gr;
2472 2604 : (void)cbezout(p, q, &u, &v);
2473 2604 : gr = mat2(p, -v, q, u); /* g . (1:0) = (p:q) */
2474 2604 : return voo_act_Gl2Q(sl2_inv(gr), k);
2475 : }
2476 : /* N > 1; returns the modular symbol attached to the cusp c := p/q via the rule
2477 : * E_c(path from a to b in Delta_0) := E_c(b) - E_c(a), where
2478 : * E_c(r) := 0 if r != c mod Gamma
2479 : * v_oo | gamma_r^(-1)
2480 : * where v_oo is stable by T = [1,1;0,1] (i.e x^(k-2)) and
2481 : * gamma_r . (1:0) = r, for some gamma_r in SL_2(Z) * */
2482 : static GEN
2483 462 : msfromcusp_trivial(GEN W, GEN c)
2484 : {
2485 462 : GEN section = ms_get_section(W), gen = ms_get_genindex(W);
2486 462 : GEN S = ms_get_hashcusps(W);
2487 462 : long j, ic = cusp_index(c, S), l = ms_get_nbE1(W)+1;
2488 462 : GEN phi = cgetg(l, t_COL);
2489 90356 : for (j = 1; j < l; j++)
2490 : {
2491 89894 : GEN vj, g = gel(section, gen[j]); /* path_to_zm(generator) */
2492 89894 : GEN c1 = gel(g,1), c2 = gel(g,2);
2493 89894 : long i1 = cusp_index(c1, S);
2494 89894 : long i2 = cusp_index(c2, S);
2495 89894 : if (i1 == ic)
2496 3290 : vj = (i2 == ic)? gen_0: gen_1;
2497 : else
2498 86604 : vj = (i2 == ic)? gen_m1: gen_0;
2499 89894 : gel(phi, j) = vj;
2500 : }
2501 462 : return phi;
2502 : }
2503 : static GEN
2504 1393 : msfromcusp_i(GEN W, GEN c)
2505 : {
2506 : GEN section, gen, S, phi;
2507 1393 : long j, ic, l, k = msk_get_weight(W);
2508 1393 : if (k == 2)
2509 : {
2510 462 : long N = ms_get_N(W);
2511 462 : return N == 1? cgetg(1,t_COL): msfromcusp_trivial(W, c);
2512 : }
2513 931 : k = msk_get_weight(W);
2514 931 : section = ms_get_section(W);
2515 931 : gen = ms_get_genindex(W);
2516 931 : S = ms_get_hashcusps(W);
2517 931 : ic = cusp_index(c, S);
2518 931 : l = lg(gen);
2519 931 : phi = cgetg(l, t_COL);
2520 12075 : for (j = 1; j < l; j++)
2521 : {
2522 11144 : GEN vj = NULL, g = gel(section, gen[j]); /* path_to_zm(generator) */
2523 11144 : GEN c1 = gel(g,1), c2 = gel(g,2);
2524 11144 : long i1 = cusp_index(c1, S);
2525 11144 : long i2 = cusp_index(c2, S);
2526 11144 : if (i1 == ic) vj = get_Ec_r(c1, k);
2527 11144 : if (i2 == ic)
2528 : {
2529 1302 : GEN s = get_Ec_r(c2, k);
2530 1302 : vj = vj? gsub(vj, s): gneg(s);
2531 : }
2532 11144 : if (!vj) vj = zerocol(k-1);
2533 11144 : gel(phi, j) = vj;
2534 : }
2535 931 : return getMorphism_basis(W, phi);
2536 : }
2537 : GEN
2538 28 : msfromcusp(GEN W, GEN c)
2539 : {
2540 28 : pari_sp av = avma;
2541 : long N;
2542 28 : checkms(W);
2543 28 : N = ms_get_N(W);
2544 28 : switch(typ(c))
2545 : {
2546 7 : case t_INFINITY:
2547 7 : c = mkvecsmall2(1,0);
2548 7 : break;
2549 14 : case t_INT:
2550 14 : c = mkvecsmall2(smodis(c,N), 1);
2551 14 : break;
2552 7 : case t_FRAC:
2553 7 : c = mkvecsmall2(smodis(gel(c,1),N), smodis(gel(c,2),N));
2554 7 : break;
2555 0 : default:
2556 0 : pari_err_TYPE("msfromcusp",c);
2557 : }
2558 28 : return gerepilecopy(av, msfromcusp_i(W,c));
2559 : }
2560 :
2561 : static GEN
2562 287 : mseisenstein_i(GEN W)
2563 : {
2564 287 : GEN M, S = ms_get_hashcusps(W), cusps = gel(S,3);
2565 287 : long i, l = lg(cusps);
2566 287 : if (msk_get_weight(W)==2) l--;
2567 287 : M = cgetg(l, t_MAT);
2568 1652 : for (i = 1; i < l; i++) gel(M,i) = msfromcusp_i(W, gel(cusps,i));
2569 287 : return Qevproj_init(Qevproj_star(W, QM_image_shallow(M)));
2570 : }
2571 : GEN
2572 21 : mseisenstein(GEN W)
2573 : {
2574 21 : pari_sp av = avma;
2575 21 : checkms(W); return gerepilecopy(av, mseisenstein_i(W));
2576 : }
2577 :
2578 : /* upper bound for log_2 |charpoly(T_p|S)|, where S is a cuspidal subspace of
2579 : * dimension d, k is the weight */
2580 : #if 0
2581 : static long
2582 : TpS_char_bound(ulong p, long k, long d)
2583 : { /* |eigenvalue| <= 2 p^(k-1)/2 */
2584 : return d * (2 + (log2((double)p)*(k-1))/2);
2585 : }
2586 : #endif
2587 : static long
2588 266 : TpE_char_bound(ulong p, long k, long d)
2589 : { /* |eigenvalue| <= 2 p^(k-1) */
2590 266 : return d * (2 + log2((double)p)*(k-1));
2591 : }
2592 :
2593 : static GEN eisker(GEN M);
2594 : static int
2595 294 : use_Petersson(long N, long k, long s)
2596 : {
2597 294 : if (!s)
2598 : {
2599 70 : if (N == 1) return 1;
2600 49 : if (N <= 3) return k >= 42;
2601 42 : if (N == 4) return k >= 30;
2602 42 : if (N == 5) return k >= 20;
2603 42 : if (N <= 10) return k >= 14;
2604 35 : if (N <= 16) return k >= 10;
2605 7 : if (N <= 28) return k >= 8;
2606 7 : if (N <= 136 || N == 180 || N == 200 || N == 225) return k >= 6;
2607 0 : return k >= 4;
2608 : }
2609 224 : if (s < 0)
2610 : {
2611 0 : if (N <= 64 || N == 100 || N == 128 || N == 144 || N == 225
2612 0 : || N == 351 || N == 375) return k >= 8;
2613 0 : return k >= 6;
2614 : }
2615 224 : if (N == 1) return 1;
2616 217 : if (N == 2) return k >= 56;
2617 217 : if (N == 3) return k >= 68;
2618 182 : if (N == 4) return k >= 78;
2619 175 : if (N == 5) return k >= 38;
2620 147 : if (N == 6) return k >= 24;
2621 147 : if (N == 7) return k >= 44;
2622 140 : if (N <= 9) return k >= 28;
2623 133 : if (N <= 13) return k >= 20;
2624 98 : if (N <= 21 || N == 50) return k >= 14;
2625 70 : if (N == 24 || N == 25) return k >= 16;
2626 70 : if (N <= 58 || N == 63 || N == 72 || N == 84 || N == 208 || N == 224) return k >= 10;
2627 42 : if (N <= 128 || N == 144 || N == 145 || N == 160 || N == 168 || N == 175 ||
2628 21 : N == 180 || N == 252 || N == 253 || N == 273 || N == 320 || N == 335 ||
2629 42 : N == 336 || N == 345 || N == 360) return k >= 8;
2630 21 : return k >= 6;
2631 : }
2632 : /* eisspace^-(N) = 0 */
2633 : static int
2634 49 : isminustriv(GEN F)
2635 : {
2636 49 : GEN P = gel(F,1), E = gel(F,2);
2637 49 : long i = 1, l = lg(P);
2638 49 : if (l == 1) return 1;
2639 49 : if (P[1] == 2)
2640 : {
2641 7 : if (E[1] >= 4) return 0;
2642 7 : i++;
2643 : }
2644 98 : for (; i < l; i++)
2645 49 : if (E[i] > 1) return 0;
2646 49 : return 1;
2647 : }
2648 :
2649 : GEN
2650 343 : mscuspidal(GEN W, long flag)
2651 : {
2652 343 : pari_sp av = avma;
2653 : GEN M, E, S;
2654 : ulong p, N;
2655 : long k, s;
2656 :
2657 343 : checkms(W);
2658 343 : N = ms_get_N(W);
2659 343 : k = msk_get_weight(W);
2660 343 : s = msk_get_sign(W);
2661 343 : E = flag? mseisenstein_i(W): NULL;
2662 343 : if (s < 0 && isminustriv(factoru(N))) M = matid(msdim(W));
2663 294 : else if (use_Petersson(N, k, s)) M = eisker(W);
2664 : else
2665 : {
2666 : GEN dT, T, TE, chE;
2667 : forprime_t F;
2668 : long bit;
2669 : pari_timer ti;
2670 :
2671 266 : if (!E) E = mseisenstein_i(W);
2672 266 : (void)u_forprime_init(&F, 2, ULONG_MAX);
2673 392 : while ((p = u_forprime_next(&F)))
2674 392 : if (N % p) break;
2675 266 : if (DEBUGLEVEL) timer_start(&ti);
2676 266 : T = mshecke(W, p, NULL);
2677 266 : if (DEBUGLEVEL) timer_printf(&ti,"Tp, p = %ld", p);
2678 266 : TE = Qevproj_apply(T, E); /* T_p | E */
2679 266 : if (DEBUGLEVEL) timer_printf(&ti,"Qevproj_init(E)");
2680 266 : bit = TpE_char_bound(p, k, lg(TE)-1);
2681 266 : chE = QM_charpoly_ZX_bound(TE, bit);
2682 266 : chE = ZX_radical(chE);
2683 266 : T = Q_remove_denom(T, &dT);
2684 266 : if (dT) chE = ZX_rescale(chE, dT);
2685 266 : M = RgX_RgM_eval(chE, T);
2686 266 : M = QM_image_shallow(M); /* = Im chE(T / dT) */
2687 : }
2688 343 : S = Qevproj_init(M);
2689 343 : return gerepilecopy(av, flag? mkvec2(S,E): S);
2690 : }
2691 :
2692 : /** INIT ELLSYM STRUCTURE **/
2693 : /* V a vector of ZM. If all of them have 0 last row, return NULL.
2694 : * Otherwise return [m,i,j], where m = V[i][last,j] contains the value
2695 : * of smallest absolute value */
2696 : static GEN
2697 945 : RgMV_find_non_zero_last_row(long offset, GEN V)
2698 : {
2699 945 : long i, lasti = 0, lastj = 0, lV = lg(V);
2700 945 : GEN m = NULL;
2701 4109 : for (i = 1; i < lV; i++)
2702 : {
2703 3164 : GEN M = gel(V,i);
2704 3164 : long j, n, l = lg(M);
2705 3164 : if (l == 1) continue;
2706 2849 : n = nbrows(M);
2707 13860 : for (j = 1; j < l; j++)
2708 : {
2709 11011 : GEN a = gcoeff(M, n, j);
2710 11011 : if (!gequal0(a) && (!m || abscmpii(a, m) < 0))
2711 : {
2712 1596 : m = a; lasti = i; lastj = j;
2713 1596 : if (is_pm1(m)) goto END;
2714 : }
2715 : }
2716 : }
2717 945 : END:
2718 945 : if (!m) return NULL;
2719 630 : return mkvec2(m, mkvecsmall2(lasti+offset, lastj));
2720 : }
2721 : /* invert the d_oo := (\gamma_oo - 1) operator, acting on
2722 : * [x^(k-2), ..., y^(k-2)] */
2723 : static GEN
2724 630 : Delta_inv(GEN doo, long k)
2725 : {
2726 630 : GEN M = RgX_act_ZGl2Q(doo, k);
2727 630 : M = RgM_minor(M, k-1, 1); /* 1st column and last row are 0 */
2728 630 : return ZM_inv_denom(M);
2729 : }
2730 : /* The ZX P = \sum a_i x^i y^{k-2-i} is given by the ZV [a_0, ..., a_k-2]~,
2731 : * return Q and d such that P = doo Q + d y^k-2, where d in Z and Q */
2732 : static GEN
2733 12873 : doo_decompose(GEN dinv, GEN P, GEN *pd)
2734 : {
2735 12873 : long l = lg(P); *pd = gel(P, l-1);
2736 12873 : P = vecslice(P, 1, l-2);
2737 12873 : return vec_prepend(ZC_apply_dinv(dinv, P), gen_0);
2738 : }
2739 :
2740 : static GEN
2741 12873 : get_phi_ij(long i,long j,long n, long s,long t,GEN P_st,GEN Q_st,GEN d_st,
2742 : GEN P_ij, GEN lP_ij, GEN dinv)
2743 : {
2744 : GEN ind, pols;
2745 12873 : if (i == s && j == t)
2746 : {
2747 630 : ind = mkvecsmall(1);
2748 630 : pols = mkvec(scalarcol_shallow(gen_1, lg(P_st)-1)); /* x^{k-2} */
2749 : }
2750 : else
2751 : {
2752 12243 : GEN d_ij, Q_ij = doo_decompose(dinv, lP_ij, &d_ij);
2753 12243 : GEN a = ZC_Z_mul(P_ij, d_st);
2754 12243 : GEN b = ZC_Z_mul(P_st, negi(d_ij));
2755 12243 : GEN c = RgC_sub(RgC_Rg_mul(Q_ij, d_st), RgC_Rg_mul(Q_st, d_ij));
2756 12243 : if (i == s) { /* j != t */
2757 1659 : ind = mkvecsmall2(1, s);
2758 1659 : pols = mkvec2(c, ZC_add(a, b));
2759 : } else {
2760 10584 : ind = mkvecsmall3(1, i, s);
2761 10584 : pols = mkvec3(c, a, b); /* image of g_1, g_i, g_s */
2762 : }
2763 12243 : pols = Q_primpart(pols);
2764 : }
2765 12873 : return mkvec3(mkvecsmall3(i,j,n), ind, pols);
2766 : }
2767 :
2768 : static GEN
2769 3297 : mskinit_trivial(GEN WN)
2770 : {
2771 3297 : long dim = ms_get_nbE1(WN);
2772 3297 : return mkvec3(WN, gen_0, mkvec2(gen_0,mkvecsmall2(2, dim)));
2773 : }
2774 : /* sum of #cols of the matrices contained in V */
2775 : static long
2776 1260 : RgMV_dim(GEN V)
2777 : {
2778 1260 : long l = lg(V), d = 0, i;
2779 1764 : for (i = 1; i < l; i++) d += lg(gel(V,i)) - 1;
2780 1260 : return d;
2781 : }
2782 : static GEN
2783 630 : mskinit_nontrivial(GEN WN, long k)
2784 : {
2785 630 : GEN annT2 = gel(WN,8), annT31 = gel(WN,9), singlerel = gel(WN,10);
2786 : GEN link, basis, monomials, Inv;
2787 630 : long nbE1 = ms_get_nbE1(WN);
2788 630 : GEN dinv = Delta_inv(ZG_neg( ZSl2_star(gel(singlerel,1)) ), k);
2789 630 : GEN p1 = cgetg(nbE1+1, t_VEC), remove;
2790 630 : GEN p2 = ZGV_tors(annT2, k);
2791 630 : GEN p3 = ZGV_tors(annT31, k);
2792 630 : GEN gentor = shallowconcat(p2, p3);
2793 : GEN P_st, lP_st, Q_st, d_st;
2794 : long n, i, dim, s, t, u;
2795 630 : gel(p1, 1) = cgetg(1,t_MAT); /* dummy */
2796 3381 : for (i = 2; i <= nbE1; i++) /* skip 1st element = (\gamma_oo-1)g_oo */
2797 : {
2798 2751 : GEN z = gel(singlerel, i);
2799 2751 : gel(p1, i) = RgX_act_ZGl2Q(ZSl2_star(z), k);
2800 : }
2801 630 : remove = RgMV_find_non_zero_last_row(nbE1, gentor);
2802 630 : if (!remove) remove = RgMV_find_non_zero_last_row(0, p1);
2803 630 : if (!remove) pari_err_BUG("msinit [no y^k-2]");
2804 630 : remove = gel(remove,2); /* [s,t] */
2805 630 : s = remove[1];
2806 630 : t = remove[2];
2807 : /* +1 because of = x^(k-2), but -1 because of Manin relation */
2808 630 : dim = (k-1)*(nbE1-1) + RgMV_dim(p2) + RgMV_dim(p3);
2809 : /* Let (g_1,...,g_d) be the Gamma-generators of Delta, g_1 = g_oo.
2810 : * We describe modular symbols by the collection phi(g_1), ..., phi(g_d)
2811 : * \in V := Q[x,y]_{k-2}, with right Gamma action.
2812 : * For each i = 1, .., d, let V_i \subset V be the Q-vector space of
2813 : * allowed values for phi(g_i): with basis (P^{i,j}) given by the monomials
2814 : * x^(j-1) y^{k-2-(j-1)}, j = 1 .. k-1
2815 : * (g_i in E_1) or the solution of the torsion equations (1 + gamma)P = 0
2816 : * (g_i in T2) or (1 + gamma + gamma^2)P = 0 (g_i in T31). All such P
2817 : * are chosen in Z[x,y] with Q_content 1.
2818 : *
2819 : * The Manin relation (singlerel) is of the form \sum_i \lambda_i g_i = 0,
2820 : * where \lambda_i = 1 if g_i in T2 or T31, and \lambda_i = (1 - \gamma_i)
2821 : * for g_i in E1.
2822 : *
2823 : * If phi \in Hom_Gamma(Delta, V), it is defined by phi(g_i) := P_i in V
2824 : * with \sum_i P_i . \lambda_i^* = 0, where (\sum n_i g_i)^* :=
2825 : * \sum n_i \gamma_i^(-1).
2826 : *
2827 : * We single out gamma_1 / g_1 (g_oo in Pollack-Stevens paper) and
2828 : * write P_{i,j} \lambda_i^* = Q_{i,j} (\gamma_1 - 1)^* + d_{i,j} y^{k-2}
2829 : * where d_{i,j} is a scalar and Q_{i,j} in V; we normalize Q_{i,j} to
2830 : * that the coefficient of x^{k-2} is 0.
2831 : *
2832 : * There exist (s,t) such that d_{s,t} != 0.
2833 : * A Q-basis of the (dual) space of modular symbols is given by the
2834 : * functions phi_{i,j}, 2 <= i <= d, 1 <= j <= k-1, mapping
2835 : * g_1 -> d_{s,t} Q_{i,j} - d_{i,j} Q_{s,t} + [(i,j)=(s,t)] x^{k-2}
2836 : * If i != s
2837 : * g_i -> d_{s,t} P_{i,j}
2838 : * g_s -> - d_{i,j} P_{s,t}
2839 : * If i = s, j != t
2840 : * g_i -> d_{s,t} P_{i,j} - d_{i,j} P_{s,t}
2841 : * And everything else to 0. Again we normalize the phi_{i,j} such that
2842 : * their image has content 1. */
2843 630 : monomials = matid(k-1); /* represent the monomials x^{k-2}, ... , y^{k-2} */
2844 630 : if (s <= nbE1) /* in E1 */
2845 : {
2846 315 : P_st = gel(monomials, t);
2847 315 : lP_st = gmael(p1, s, t); /* P_{s,t} lambda_s^* */
2848 : }
2849 : else /* in T2, T31 */
2850 : {
2851 315 : P_st = gmael(gentor, s - nbE1, t);
2852 315 : lP_st = P_st;
2853 : }
2854 630 : Q_st = doo_decompose(dinv, lP_st, &d_st);
2855 630 : basis = cgetg(dim+1, t_VEC);
2856 630 : link = cgetg(nbE1 + lg(gentor), t_VEC);
2857 630 : gel(link,1) = cgetg(1,t_VECSMALL); /* dummy */
2858 630 : n = 1;
2859 3381 : for (i = 2; i <= nbE1; i++)
2860 : {
2861 2751 : GEN L = cgetg(k, t_VECSMALL);
2862 : long j;
2863 : /* link[i][j] = n gives correspondance between phi_{i,j} and basis[n] */
2864 2751 : gel(link,i) = L;
2865 14056 : for (j = 1; j < k; j++)
2866 : {
2867 11305 : GEN lP_ij = gmael(p1, i, j); /* P_{i,j} lambda_i^* */
2868 11305 : GEN P_ij = gel(monomials,j);
2869 11305 : L[j] = n;
2870 11305 : gel(basis, n) = get_phi_ij(i,j,n, s,t, P_st, Q_st, d_st, P_ij, lP_ij, dinv);
2871 11305 : n++;
2872 : }
2873 : }
2874 1134 : for (u = 1; u < lg(gentor); u++,i++)
2875 : {
2876 504 : GEN V = gel(gentor,u);
2877 504 : long j, lV = lg(V);
2878 504 : GEN L = cgetg(lV, t_VECSMALL);
2879 504 : gel(link,i) = L;
2880 2072 : for (j = 1; j < lV; j++)
2881 : {
2882 1568 : GEN lP_ij = gel(V, j); /* P_{i,j} lambda_i^* = P_{i,j} */
2883 1568 : GEN P_ij = lP_ij;
2884 1568 : L[j] = n;
2885 1568 : gel(basis, n) = get_phi_ij(i,j,n, s,t, P_st, Q_st, d_st, P_ij, lP_ij, dinv);
2886 1568 : n++;
2887 : }
2888 : }
2889 630 : Inv = cgetg(lg(link), t_VEC);
2890 630 : gel(Inv,1) = cgetg(1, t_MAT); /* dummy */
2891 3885 : for (i = 2; i < lg(link); i++)
2892 : {
2893 3255 : GEN M, inv, B = gel(link,i);
2894 3255 : long j, lB = lg(B);
2895 3255 : if (i == s) { B = vecsplice(B, t); lB--; } /* remove phi_st */
2896 3255 : M = cgetg(lB, t_MAT);
2897 15498 : for (j = 1; j < lB; j++)
2898 : {
2899 12243 : GEN phi_ij = gel(basis, B[j]), pols = gel(phi_ij,3);
2900 12243 : gel(M, j) = gel(pols, 2); /* phi_ij(g_i) */
2901 : }
2902 3255 : if (i <= nbE1 && i != s) /* maximal rank k-1 */
2903 2436 : inv = ZM_inv_denom(M);
2904 : else /* i = s (rank k-2) or from torsion: rank k/3 or k/2 */
2905 819 : inv = Qevproj_init(M);
2906 3255 : gel(Inv,i) = inv;
2907 : }
2908 630 : return mkvec3(WN, gen_0, mkvec5(basis, mkvecsmall2(k, dim), mkvecsmall2(s,t),
2909 : link, Inv));
2910 : }
2911 : static GEN
2912 3941 : add_star(GEN W, long sign)
2913 : {
2914 3941 : GEN s = msstar_i(W);
2915 3941 : GEN K = sign? QM_ker(gsubgs(s, sign)): cgetg(1,t_MAT);
2916 3941 : gel(W,2) = mkvec3(stoi(sign), s, Qevproj_init(K));
2917 3941 : return W;
2918 : }
2919 : /* WN = msinit_N(N) */
2920 : static GEN
2921 3941 : mskinit(ulong N, long k, long sign)
2922 : {
2923 3941 : GEN W, WN = msinit_N(N);
2924 3941 : if (N == 1)
2925 : {
2926 14 : GEN basis, M = RgXV_to_RgM(mfperiodpolbasis(k, 0), k-1);
2927 14 : GEN T = cgetg(1, t_VECSMALL), ind = mkvecsmall(1);
2928 14 : long i, l = lg(M);
2929 14 : basis = cgetg(l, t_VEC);
2930 70 : for (i = 1; i < l; i++) gel(basis,i) = mkvec3(T, ind, mkvec(gel(M,i)));
2931 14 : W = mkvec3(WN, gen_0, mkvec5(basis, mkvecsmall2(k, l-1), mkvecsmall2(0,0),
2932 : gen_0, Qevproj_init(M)));
2933 : }
2934 : else
2935 3927 : W = k == 2? mskinit_trivial(WN)
2936 3927 : : mskinit_nontrivial(WN, k);
2937 3941 : return add_star(W, sign);
2938 : }
2939 : GEN
2940 518 : msinit(GEN N, GEN K, long s)
2941 : {
2942 518 : pari_sp av = avma;
2943 : GEN W;
2944 : long k;
2945 518 : if (typ(N) != t_INT) pari_err_TYPE("msinit", N);
2946 511 : if (typ(K) != t_INT) pari_err_TYPE("msinit", K);
2947 504 : k = itos(K);
2948 504 : if (k < 2) pari_err_DOMAIN("msinit","k", "<", gen_2,K);
2949 497 : if (odd(k)) pari_err_IMPL("msinit [odd weight]");
2950 497 : if (signe(N) <= 0) pari_err_DOMAIN("msinit","N", "<=", gen_0,N);
2951 490 : if (labs(s) > 1) pari_err_DOMAIN("msinit", "|sign|", ">", gen_1, stoi(s));
2952 476 : W = mskinit(itou(N), k, s);
2953 476 : return gerepilecopy(av, W);
2954 : }
2955 :
2956 : /* W = msinit, xpm integral modular symbol of weight 2, c t_FRAC
2957 : * Return image of <oo->c> */
2958 : GEN
2959 2229528 : mseval2_ooQ(GEN W, GEN xpm, GEN c)
2960 : {
2961 2229528 : pari_sp av = avma;
2962 : GEN v;
2963 2229528 : W = get_msN(W);
2964 2229528 : v = init_act_trivial(W);
2965 2229528 : Q_log_trivial(v, W, c); /* oo -> (a:b), c = a/b */
2966 2229528 : return gerepileuptoint(av, ZV_zc_mul(xpm, v));
2967 : }
2968 :
2969 : static GEN
2970 20314 : eval_single(GEN s, long k, GEN B, long v)
2971 : {
2972 : long i, l;
2973 20314 : GEN A = cgetg_copy(s,&l);
2974 135863 : for (i=1; i<l; i++) gel(A,i) = ZGl2Q_act_s(gel(B,i), gel(s,i), k);
2975 20314 : A = RgV_sum(A);
2976 20314 : if (is_vec_t(typ(A))) A = RgV_to_RgX(A, v);
2977 20314 : return A;
2978 : }
2979 : /* Evaluate symbol s on mspathlog B (= sum p_i g_i, p_i in Z[G]). Allow
2980 : * s = t_MAT [ collection of symbols, return a vector ]*/
2981 : static GEN
2982 54362 : mseval_by_values(GEN W, GEN s, GEN p, long v)
2983 : {
2984 54362 : long i, l, k = msk_get_weight(W);
2985 : GEN A;
2986 54362 : if (k == 2)
2987 : { /* trivial represention: don't bother with Z[G] */
2988 41734 : GEN B = mspathlog_trivial(W,p);
2989 41727 : if (typ(s) != t_MAT) return RgV_zc_mul(s,B);
2990 41657 : l = lg(s); A = cgetg(l, t_VEC);
2991 124971 : for (i = 1; i < l; i++) gel(A,i) = RgV_zc_mul(gel(s,i), B);
2992 : }
2993 : else
2994 : {
2995 12628 : GEN B = mspathlog(W,p);
2996 12628 : if (typ(s) != t_MAT) return eval_single(s, k, B, v);
2997 812 : l = lg(s); A = cgetg(l, t_VEC);
2998 9310 : for (i = 1; i < l; i++) gel(A,i) = eval_single(gel(s,i), k, B, v);
2999 : }
3000 42469 : return A;
3001 : }
3002 :
3003 : /* express symbol on the basis phi_{i,j} */
3004 : static GEN
3005 20692 : symtophi(GEN W, GEN s)
3006 : {
3007 20692 : GEN e, basis = msk_get_basis(W);
3008 20692 : long i, l = lg(basis);
3009 20692 : if (lg(s) != l) pari_err_TYPE("mseval",s);
3010 20692 : e = zerovec(ms_get_nbgen(W));
3011 313670 : for (i=1; i<l; i++)
3012 : {
3013 292978 : GEN phi, ind, pols, c = gel(s,i);
3014 : long j, m;
3015 292978 : if (gequal0(c)) continue;
3016 122696 : phi = gel(basis,i);
3017 122696 : ind = gel(phi,2); m = lg(ind);
3018 122696 : pols = gel(phi,3);
3019 470806 : for (j=1; j<m; j++)
3020 : {
3021 348110 : long t = ind[j];
3022 348110 : gel(e,t) = gadd(gel(e,t), gmul(c, gel(pols,j)));
3023 : }
3024 : }
3025 20692 : return e;
3026 : }
3027 : /* evaluate symbol s on path p */
3028 : GEN
3029 55321 : mseval(GEN W, GEN s, GEN p)
3030 : {
3031 55321 : pari_sp av = avma;
3032 55321 : long i, k, l, v = 0;
3033 55321 : checkms(W);
3034 55321 : k = msk_get_weight(W);
3035 55321 : switch(typ(s))
3036 : {
3037 7 : case t_VEC: /* values s(g_i) */
3038 7 : if (lg(s)-1 != ms_get_nbgen(W)) pari_err_TYPE("mseval",s);
3039 7 : if (!p) return gcopy(s);
3040 0 : v = gvar(s);
3041 0 : break;
3042 12831 : case t_COL:
3043 12831 : if (msk_get_sign(W))
3044 : {
3045 399 : GEN star = gel(msk_get_starproj(W), 1);
3046 399 : if (lg(star) == lg(s)) s = RgM_RgC_mul(star, s);
3047 : }
3048 12831 : if (k == 2) /* on the dual basis of (g_i) */
3049 : {
3050 637 : if (lg(s)-1 != ms_get_nbE1(W)) pari_err_TYPE("mseval",s);
3051 637 : if (!p) return gtrans(s);
3052 : }
3053 : else
3054 12194 : s = symtophi(W,s);
3055 12271 : break;
3056 42483 : case t_MAT:
3057 42483 : l = lg(s);
3058 42483 : if (!p)
3059 : {
3060 7 : GEN v = cgetg(l, t_VEC);
3061 28 : for (i = 1; i < l; i++) gel(v,i) = mseval(W, gel(s,i), NULL);
3062 7 : return v;
3063 : }
3064 42476 : if (l == 1) return cgetg(1, t_VEC);
3065 42469 : if (msk_get_sign(W))
3066 : {
3067 84 : GEN star = gel(msk_get_starproj(W), 1);
3068 84 : if (lg(star) == lgcols(s)) s = RgM_mul(star, s);
3069 : }
3070 42469 : if (k == 2)
3071 41657 : { if (nbrows(s) != ms_get_nbE1(W)) pari_err_TYPE("mseval",s); }
3072 : else
3073 : {
3074 812 : GEN t = cgetg(l, t_MAT);
3075 9310 : for (i = 1; i < l; i++) gel(t,i) = symtophi(W,gel(s,i));
3076 812 : s = t;
3077 : }
3078 42469 : break;
3079 0 : default: pari_err_TYPE("mseval",s);
3080 : }
3081 54740 : if (p)
3082 54362 : s = mseval_by_values(W, s, p, v);
3083 : else
3084 : {
3085 378 : l = lg(s);
3086 3675 : for (i = 1; i < l; i++)
3087 : {
3088 3297 : GEN c = gel(s,i);
3089 3297 : if (!isintzero(c)) gel(s,i) = RgV_to_RgX(gel(s,i), v);
3090 : }
3091 : }
3092 54733 : return gerepilecopy(av, s);
3093 : }
3094 :
3095 : static GEN
3096 9464 : allxpm(GEN W, GEN xpm, long f)
3097 : {
3098 9464 : GEN v, L = coprimes_zv(f);
3099 9464 : long a, nonzero = 0;
3100 9464 : v = const_vec(f, NULL);
3101 33719 : for (a = 1; a <= f; a++)
3102 : {
3103 : GEN c;
3104 24255 : if (!L[a]) continue;
3105 18564 : c = mseval2_ooQ(W, xpm, sstoQ(a, f));
3106 18564 : if (!gequal0(c)) { gel(v,a) = c; nonzero = 1; }
3107 : }
3108 9464 : return nonzero? v: NULL;
3109 : }
3110 : /* \sum_{a mod f} chi(a) x(a/f) */
3111 : static GEN
3112 5138 : seval(GEN G, GEN chi, GEN vx)
3113 : {
3114 5138 : GEN vZ, T, s = gen_0, go = zncharorder(G,chi);
3115 5138 : long i, l = lg(vx), o = itou(go);
3116 5138 : T = polcyclo(o,0);
3117 5138 : vZ = mkvec2(RgXQ_powers(RgX_rem(pol_x(0), T), o-1, T), go);
3118 20643 : for (i = 1; i < l; i++)
3119 : {
3120 15505 : GEN x = gel(vx,i);
3121 15505 : if (x) s = gadd(s, gmul(x, znchareval(G, chi, utoi(i), vZ)));
3122 : }
3123 5138 : return gequal0(s)? NULL: poleval(s, rootsof1u_cx(o, DEFAULTPREC));
3124 : }
3125 :
3126 : /* Let W = msinit(conductor(E), 2), xpm an integral modular symbol with the same
3127 : * eigenvalues as L_E. There exist a unique C such that
3128 : * C*L(E,(D/.),1)_{xpm} = L(E,(D/.),1) / w1(E_D) != 0,
3129 : * for all D fundamental, sign(D) = s, and such that E_D has rank 0.
3130 : * Return C * ellQtwist_bsdperiod(E,s) */
3131 : static GEN
3132 5138 : ell_get_Cw(GEN LE, GEN W, GEN xpm, long s)
3133 : {
3134 5138 : long f, NE = ms_get_N(W);
3135 5138 : const long bit = 64;
3136 :
3137 5138 : for (f = 1;; f++)
3138 10367 : { /* look for chi with conductor f coprime to N(E) and parity s
3139 : * such that L(E,chi,1) != 0 */
3140 15505 : pari_sp av = avma;
3141 : GEN vchi, vx, G;
3142 : long l, i;
3143 15505 : if ((f & 3) == 2 || ugcd(NE,f) != 1) continue;
3144 9464 : vx = allxpm(W, xpm, f); if (!vx) continue;
3145 5138 : G = znstar0(utoipos(f),1);
3146 5138 : vchi = chargalois(G,NULL); l = lg(vchi);
3147 8204 : for (i = 1; i < l; i++)
3148 : {
3149 8204 : pari_sp av2 = avma;
3150 8204 : GEN tau, z, S, L, chi = gel(vchi,i);
3151 8204 : long o = zncharisodd(G,chi);
3152 8204 : if ((s > 0 && o) || (s < 0 && !o)
3153 8204 : || itos(zncharconductor(G, chi)) != f) continue;
3154 5138 : S = seval(G, chi, vx);
3155 5138 : if (!S) { set_avma(av2); continue; }
3156 :
3157 5138 : L = lfuntwist(LE, mkvec2(G, zncharconj(G,chi)), bit);
3158 5138 : z = lfun(L, gen_1, bit);
3159 5138 : tau = znchargauss(G, chi, gen_1, bit);
3160 5138 : return gdiv(gmul(z, tau), S); /* C * w */
3161 : }
3162 0 : set_avma(av);
3163 : }
3164 : }
3165 : static GEN
3166 2884 : ell_get_scale(GEN LE, GEN W, long sign, GEN x)
3167 : {
3168 2884 : if (sign)
3169 630 : return ell_get_Cw(LE, W, gel(x,1), sign);
3170 : else
3171 : {
3172 2254 : GEN Cwp = ell_get_Cw(LE, W, gel(x,1), 1);
3173 2254 : GEN Cwm = ell_get_Cw(LE, W, gel(x,2),-1);
3174 2254 : return mkvec2(Cwp, Cwm);
3175 : }
3176 : }
3177 : /* E minimal */
3178 : static GEN
3179 10101 : msfromell_scale(GEN x, GEN Cw, GEN E, long s)
3180 : {
3181 10101 : GEN B = int2n(32);
3182 10101 : if (s)
3183 : {
3184 630 : GEN C = gdiv(Cw, ellQtwist_bsdperiod(E,s));
3185 630 : return ZC_Q_mul(gel(x,1), bestappr(C,B));
3186 : }
3187 : else
3188 : {
3189 9471 : GEN xp = gel(x,1), Cp = gdiv(gel(Cw,1), ellQtwist_bsdperiod(E, 1)), L;
3190 9471 : GEN xm = gel(x,2), Cm = gdiv(gel(Cw,2), ellQtwist_bsdperiod(E,-1));
3191 9471 : xp = ZC_Q_mul(xp, bestappr(Cp,B));
3192 9471 : xm = ZC_Q_mul(xm, bestappr(Cm,B));
3193 9471 : if (signe(ell_get_disc(E)) > 0)
3194 5320 : L = mkmat2(xp, xm); /* E(R) has 2 connected components */
3195 : else
3196 4151 : L = mkmat2(gsub(xp,xm), gmul2n(xm,1));
3197 9471 : return mkvec3(xp, xm, L);
3198 : }
3199 : }
3200 : /* v != 0 */
3201 : static GEN
3202 5138 : Flc_normalize(GEN v, ulong p)
3203 : {
3204 5138 : long i, l = lg(v);
3205 9128 : for (i = 1; i < l; i++)
3206 9128 : if (v[i])
3207 : {
3208 5138 : if (v[i] != 1) v = Flv_Fl_div(v, v[i], p);
3209 5138 : return v;
3210 : }
3211 0 : return NULL;
3212 : }
3213 : /* K \cap Ker M [F_l vector spaces]. K = NULL means full space */
3214 : static GEN
3215 3668 : msfromell_ker(GEN K, GEN M, ulong l)
3216 : {
3217 3668 : GEN B, Ml = ZM_to_Flm(M, l);
3218 3668 : if (K) Ml = Flm_mul(Ml, K, l);
3219 3668 : B = Flm_ker(Ml, l);
3220 3668 : if (!K) K = B;
3221 784 : else if (lg(B) < lg(K))
3222 616 : K = Flm_mul(K, B, l);
3223 3668 : return K;
3224 : }
3225 : /* K = \cap_p Ker(T_p - a_p), 2-dimensional. Set *xl to the 1-dimensional
3226 : * Fl-basis such that star . xl = sign . xl if sign != 0 and
3227 : * star * xl[1] = xl[1]; star * xl[2] = -xl[2] if sign = 0 */
3228 : static void
3229 2884 : msfromell_l(GEN *pxl, GEN K, GEN star, long sign, ulong l)
3230 : {
3231 2884 : GEN s = ZM_to_Flm(star, l);
3232 2884 : GEN a = gel(K,1), Sa = Flm_Flc_mul(s,a,l);
3233 2884 : GEN b = gel(K,2);
3234 2884 : GEN t = Flv_add(a,Sa,l), xp, xm;
3235 2884 : if (zv_equal0(t))
3236 : {
3237 497 : xm = a;
3238 497 : xp = Flv_add(b,Flm_Flc_mul(s,b,l), l);
3239 : }
3240 : else
3241 : {
3242 2387 : xp = t; t = Flv_sub(a, Sa, l);
3243 2387 : xm = zv_equal0(t)? Flv_sub(b, Flm_Flc_mul(s,b,l), l): t;
3244 : }
3245 : /* xp = 0 on Im(S - 1), xm = 0 on Im(S + 1) */
3246 2884 : if (sign > 0)
3247 518 : *pxl = mkmat(Flc_normalize(xp, l));
3248 2366 : else if (sign < 0)
3249 112 : *pxl = mkmat(Flc_normalize(xm, l));
3250 : else
3251 2254 : *pxl = mkmat2(Flc_normalize(xp, l), Flc_normalize(xm, l));
3252 2884 : }
3253 : /* return a primitive symbol */
3254 : static GEN
3255 2884 : msfromell_ratlift(GEN x, GEN q)
3256 : {
3257 2884 : GEN B = sqrti(shifti(q,-1));
3258 2884 : GEN r = FpM_ratlift(x, q, B, B, NULL);
3259 2884 : if (r) r = Q_primpart(r);
3260 2884 : return r;
3261 : }
3262 : static int
3263 2884 : msfromell_check(GEN x, GEN vT, GEN star, long sign)
3264 : {
3265 : long i, l;
3266 : GEN sx;
3267 2884 : if (!x) return 0;
3268 2884 : l = lg(vT);
3269 6552 : for (i = 1; i < l; i++)
3270 : {
3271 3668 : GEN T = gel(vT,i);
3272 3668 : if (!gequal0(ZM_mul(T, x))) return 0; /* fail */
3273 : }
3274 2884 : sx = ZM_mul(star,x);
3275 2884 : if (sign)
3276 630 : return ZV_equal(gel(sx,1), sign > 0? gel(x,1): ZC_neg(gel(x,1)));
3277 : else
3278 2254 : return ZV_equal(gel(sx,1),gel(x,1)) && ZV_equal(gel(sx,2),ZC_neg(gel(x,2)));
3279 : }
3280 : GEN
3281 2884 : msfromell(GEN E0, long sign)
3282 : {
3283 2884 : pari_sp av = avma, av2;
3284 2884 : GEN T, Cw, E, NE, star, q, vT, xl, xr, W, x = NULL, K = NULL;
3285 : long lE, single;
3286 : ulong p, l, N;
3287 : forprime_t S, Sl;
3288 :
3289 2884 : if (typ(E0) != t_VEC) pari_err_TYPE("msfromell",E0);
3290 2884 : lE = lg(E0);
3291 2884 : if (lE == 1) return cgetg(1,t_VEC);
3292 2884 : single = (typ(gel(E0,1)) != t_VEC);
3293 2884 : E = single ? E0: gel(E0,1);
3294 2884 : NE = ellQ_get_N(E);
3295 : /* must make it integral for ellap; we have minimal model at hand */
3296 2884 : T = obj_check(E, Q_MINIMALMODEL); if (lg(T) != 2) E = gel(T,3);
3297 2884 : N = itou(NE); av2 = avma;
3298 2884 : W = gerepilecopy(av2, mskinit(N,2,0));
3299 2884 : star = msk_get_star(W);
3300 2884 : (void)u_forprime_init(&Sl, 1UL<<29, ULONG_MAX);
3301 : /* loop for p <= count_Manin_symbols(N) / 6 would be enough */
3302 2884 : (void)u_forprime_init(&S, 2, ULONG_MAX);
3303 2884 : vT = cgetg(1, t_VEC);
3304 2884 : l = u_forprime_next(&Sl);
3305 6265 : while( (p = u_forprime_next(&S)) )
3306 : {
3307 : GEN M;
3308 6265 : if (N % p == 0) continue;
3309 3668 : av2 = avma;
3310 3668 : M = RgM_Rg_sub_shallow(mshecke_i(W, p), ellap(E, utoipos(p)));
3311 3668 : M = gerepilecopy(av2, M);
3312 3668 : vT = vec_append(vT, M); /* for certification at the end */
3313 3668 : K = msfromell_ker(K, M, l);
3314 3668 : if (lg(K) == 3) break;
3315 : }
3316 2884 : if (!p) pari_err_BUG("msfromell: ran out of primes");
3317 :
3318 : /* mod one l should be enough */
3319 2884 : msfromell_l(&xl, K, star, sign, l);
3320 2884 : x = ZM_init_CRT(xl, l);
3321 2884 : q = utoipos(l);
3322 2884 : xr = msfromell_ratlift(x, q);
3323 : /* paranoia */
3324 2884 : while (!msfromell_check(xr, vT, star, sign) && (l = u_forprime_next(&Sl)) )
3325 : {
3326 0 : GEN K = NULL;
3327 0 : long i, lvT = lg(vT);
3328 0 : for (i = 1; i < lvT; i++)
3329 : {
3330 0 : K = msfromell_ker(K, gel(vT,i), l);
3331 0 : if (lg(K) == 3) break;
3332 : }
3333 0 : if (i >= lvT) { x = NULL; continue; }
3334 0 : msfromell_l(&xl, K, star, sign, l);
3335 0 : ZM_incremental_CRT(&x, xl, &q, l);
3336 0 : xr = msfromell_ratlift(x, q);
3337 : }
3338 : /* linear form = 0 on all Im(Tp - ap) and Im(S - sign) if sign != 0 */
3339 2884 : Cw = ell_get_scale(lfuncreate(E), W, sign, xr);
3340 2884 : if (single)
3341 693 : x = msfromell_scale(xr, Cw, E, sign);
3342 : else
3343 : { /* assume all E0[i] isogenous, given by minimal models */
3344 2191 : GEN v = cgetg(lE, t_VEC);
3345 : long i;
3346 11599 : for (i=1; i<lE; i++) gel(v,i) = msfromell_scale(xr, Cw, gel(E0,i), sign);
3347 2191 : x = v;
3348 : }
3349 2884 : return gerepilecopy(av, mkvec2(W, x));
3350 : }
3351 :
3352 : GEN
3353 21 : msfromhecke(GEN W, GEN v, GEN H)
3354 : {
3355 21 : pari_sp av = avma;
3356 21 : long i, l = lg(v);
3357 21 : GEN K = NULL;
3358 21 : checkms(W);
3359 21 : if (typ(v) != t_VEC) pari_err_TYPE("msfromhecke",v);
3360 49 : for (i = 1; i < l; i++)
3361 : {
3362 28 : GEN K2, T, p, P, c = gel(v,i);
3363 28 : if (typ(c) != t_VEC || lg(c) != 3) pari_err_TYPE("msfromhecke",v);
3364 28 : p = gel(c,1);
3365 28 : if (typ(p) != t_INT) pari_err_TYPE("msfromhecke",v);
3366 28 : P = gel(c,2);
3367 28 : switch(typ(P))
3368 : {
3369 21 : case t_INT:
3370 21 : P = deg1pol_shallow(gen_1, negi(P), 0);
3371 21 : break;
3372 7 : case t_POL:
3373 7 : if (RgX_is_ZX(P)) break;
3374 : default:
3375 0 : pari_err_TYPE("msfromhecke",v);
3376 : };
3377 28 : T = mshecke(W, itos(p), H);
3378 28 : T = Q_primpart(RgX_RgM_eval(P, T));
3379 28 : if (K) T = ZM_mul(T,K);
3380 28 : K2 = ZM_ker(T);
3381 28 : if (!K) K = K2;
3382 7 : else if (lg(K2) < lg(K)) K = ZM_mul(K,K2);
3383 : }
3384 21 : return gerepilecopy(av, K);
3385 : }
3386 :
3387 : /* OVERCONVERGENT MODULAR SYMBOLS */
3388 :
3389 : static GEN
3390 2933 : mspadic_get_Wp(GEN W) { return gel(W,1); }
3391 : static GEN
3392 483 : mspadic_get_Tp(GEN W) { return gel(W,2); }
3393 : static GEN
3394 483 : mspadic_get_bin(GEN W) { return gel(W,3); }
3395 : static GEN
3396 476 : mspadic_get_actUp(GEN W) { return gel(W,4); }
3397 : static GEN
3398 476 : mspadic_get_q(GEN W) { return gel(W,5); }
3399 : static long
3400 1456 : mspadic_get_p(GEN W) { return gel(W,6)[1]; }
3401 : static long
3402 1211 : mspadic_get_n(GEN W) { return gel(W,6)[2]; }
3403 : static long
3404 161 : mspadic_get_flag(GEN W) { return gel(W,6)[3]; }
3405 : static GEN
3406 483 : mspadic_get_M(GEN W) { return gel(W,7); }
3407 : static GEN
3408 483 : mspadic_get_C(GEN W) { return gel(W,8); }
3409 : static long
3410 973 : mspadic_get_weight(GEN W) { return msk_get_weight(mspadic_get_Wp(W)); }
3411 :
3412 : void
3413 980 : checkmspadic(GEN W)
3414 : {
3415 980 : if (typ(W) != t_VEC || lg(W) != 9) pari_err_TYPE("checkmspadic",W);
3416 980 : checkms(mspadic_get_Wp(W));
3417 980 : }
3418 :
3419 : /* f in M_2(Z) \cap GL_2(Q), p \nmid a [ and for the result to mean anything
3420 : * p | c, but not needed here]. Return the matrix M in M_D(Z), D = M+k-1
3421 : * such that, if v = \int x^i d mu, i < D, is a vector of D moments of mu,
3422 : * then M * v is the vector of moments of mu | f mod p^D */
3423 : static GEN
3424 276073 : moments_act_i(struct m_act *S, GEN f)
3425 : {
3426 276073 : long j, k = S->k, D = S->dim;
3427 276073 : GEN a = gcoeff(f,1,1), b = gcoeff(f,1,2);
3428 276073 : GEN c = gcoeff(f,2,1), d = gcoeff(f,2,2);
3429 276073 : GEN u, z, q = S->q, mat = cgetg(D+1, t_MAT);
3430 :
3431 276073 : a = modii(a,q);
3432 276073 : c = modii(c,q);
3433 276073 : z = FpX_powu(deg1pol(c,a,0), k-2, q); /* (a+cx)^(k-2) */
3434 : /* u := (b+dx) / (a+cx) mod (q,x^D) = (b/a +d/a*x) / (1 - (-c/a)*x) */
3435 276073 : if (!equali1(a))
3436 : {
3437 271229 : GEN ai = Fp_inv(a,q);
3438 271229 : b = Fp_mul(b,ai,q);
3439 271229 : c = Fp_mul(c,ai,q);
3440 271229 : d = Fp_mul(d,ai,q);
3441 : }
3442 276073 : u = deg1pol_shallow(d, b, 0);
3443 : /* multiply by 1 / (1 - (-c/a)*x) */
3444 276073 : if (signe(c))
3445 : {
3446 269640 : GEN C = Fp_neg(c,q), v = cgetg(D+2,t_POL);
3447 269640 : v[1] = evalsigne(1)|evalvarn(0);
3448 269640 : gel(v, 2) = gen_1; gel(v, 3) = C;
3449 1405138 : for (j = 4; j < D+2; j++)
3450 : {
3451 1329027 : GEN t = Fp_mul(gel(v,j-1), C, q);
3452 1329027 : if (!signe(t)) { setlg(v,j); break; }
3453 1135498 : gel(v,j) = t;
3454 : }
3455 269640 : u = FpXn_mul(u, v, D, q);
3456 : }
3457 2369024 : for (j = 1; j <= D; j++)
3458 : {
3459 2092951 : gel(mat,j) = RgX_to_RgC(z, D); /* (a+cx)^(k-2) * ((b+dx)/(a+cx))^(j-1) */
3460 2092951 : if (j != D) z = FpXn_mul(z, u, D, q);
3461 : }
3462 276073 : return shallowtrans(mat);
3463 : }
3464 : static GEN
3465 275611 : moments_act(struct m_act *S, GEN f)
3466 275611 : { pari_sp av = avma; return gerepilecopy(av, moments_act_i(S,f)); }
3467 : static GEN
3468 483 : init_moments_act(GEN W, long p, long n, GEN q, GEN v)
3469 : {
3470 : struct m_act S;
3471 483 : long k = msk_get_weight(W);
3472 483 : S.p = p;
3473 483 : S.k = k;
3474 483 : S.q = q;
3475 483 : S.dim = n+k-1;
3476 483 : S.act = &moments_act; return init_dual_act(v,W,W,&S);
3477 : }
3478 :
3479 : static void
3480 6762 : clean_tail(GEN phi, long c, GEN q)
3481 : {
3482 6762 : long a, l = lg(phi);
3483 214438 : for (a = 1; a < l; a++)
3484 : {
3485 207676 : GEN P = FpC_red(gel(phi,a), q); /* phi(G_a) = vector of moments */
3486 207676 : long j, lP = lg(P);
3487 1007825 : for (j = c; j < lP; j++) gel(P,j) = gen_0; /* reset garbage to 0 */
3488 207676 : gel(phi,a) = P;
3489 : }
3490 6762 : }
3491 : /* concat z to all x[i] */
3492 : static GEN
3493 630 : concat2(GEN x, GEN z)
3494 29022 : { pari_APPLY_same(shallowconcat(gel(x,i), z)); }
3495 : static GEN
3496 630 : red_mod_FilM(GEN phi, ulong p, long k, long flag)
3497 : {
3498 : long a, l;
3499 630 : GEN den = gen_1, v = cgetg_copy(phi, &l);
3500 630 : if (flag)
3501 : {
3502 343 : phi = Q_remove_denom(phi, &den);
3503 343 : if (!den) { den = gen_1; flag = 0; }
3504 : }
3505 29386 : for (a = 1; a < l; a++)
3506 : {
3507 28756 : GEN P = gel(phi,a), q = den;
3508 : long j;
3509 207676 : for (j = lg(P)-1; j >= k+1; j--)
3510 : {
3511 178920 : q = muliu(q,p);
3512 178920 : gel(P,j) = modii(gel(P,j),q);
3513 : }
3514 28756 : q = muliu(q,p);
3515 93380 : for ( ; j >= 1; j--)
3516 64624 : gel(P,j) = modii(gel(P,j),q);
3517 28756 : gel(v,a) = P;
3518 : }
3519 630 : if (flag) v = gdiv(v, den);
3520 630 : return v;
3521 : }
3522 :
3523 : /* denom(C) | p^(2(k-1) - v_p(ap)) */
3524 : static GEN
3525 154 : oms_dim2(GEN W, GEN phi, GEN C, GEN ap)
3526 : {
3527 154 : long t, i, k = mspadic_get_weight(W);
3528 154 : long p = mspadic_get_p(W), n = mspadic_get_n(W);
3529 154 : GEN phi1 = gel(phi,1), phi2 = gel(phi,2);
3530 154 : GEN v, q = mspadic_get_q(W);
3531 154 : GEN act = mspadic_get_actUp(W);
3532 :
3533 154 : t = signe(ap)? Z_lval(ap,p) : k-1;
3534 154 : phi1 = concat2(phi1, zerovec(n));
3535 154 : phi2 = concat2(phi2, zerovec(n));
3536 2107 : for (i = 1; i <= n; i++)
3537 : {
3538 1953 : phi1 = dual_act(k-1, act, phi1);
3539 1953 : phi1 = dual_act(k-1, act, phi1);
3540 1953 : clean_tail(phi1, k + i*t, q);
3541 :
3542 1953 : phi2 = dual_act(k-1, act, phi2);
3543 1953 : phi2 = dual_act(k-1, act, phi2);
3544 1953 : clean_tail(phi2, k + i*t, q);
3545 : }
3546 154 : C = gpowgs(C,n);
3547 154 : v = RgM_RgC_mul(C, mkcol2(phi1,phi2));
3548 154 : phi1 = red_mod_FilM(gel(v,1), p, k, 1);
3549 154 : phi2 = red_mod_FilM(gel(v,2), p, k, 1);
3550 154 : return mkvec2(phi1,phi2);
3551 : }
3552 :
3553 : /* flag = 0 iff alpha is a p-unit */
3554 : static GEN
3555 322 : oms_dim1(GEN W, GEN phi, GEN alpha, long flag)
3556 : {
3557 322 : long i, k = mspadic_get_weight(W);
3558 322 : long p = mspadic_get_p(W), n = mspadic_get_n(W);
3559 322 : GEN q = mspadic_get_q(W);
3560 322 : GEN act = mspadic_get_actUp(W);
3561 322 : phi = concat2(phi, zerovec(n));
3562 3178 : for (i = 1; i <= n; i++)
3563 : {
3564 2856 : phi = dual_act(k-1, act, phi);
3565 2856 : clean_tail(phi, k + i, q);
3566 : }
3567 322 : phi = gmul(lift_shallow(gpowgs(alpha,n)), phi);
3568 322 : phi = red_mod_FilM(phi, p, k, flag);
3569 322 : return mkvec(phi);
3570 : }
3571 :
3572 : /* lift polynomial P in RgX[X,Y]_{k-2} to a distribution \mu such that
3573 : * \int (Y - X z)^(k-2) d\mu(z) = P(X,Y)
3574 : * Return the t_VEC of k-1 first moments of \mu: \int z^i d\mu(z), 0<= i < k-1.
3575 : * \sum_j (-1)^(k-2-j) binomial(k-2,j) Y^j \int z^(k-2-j) d\mu(z) = P(1,Y)
3576 : * Input is P(1,Y), bin = vecbinomial(k-2): bin[j] = binomial(k-2,j-1) */
3577 : static GEN
3578 38626 : RgX_to_moments(GEN P, GEN bin)
3579 : {
3580 38626 : long j, k = lg(bin);
3581 : GEN Pd, Bd;
3582 38626 : if (typ(P) != t_POL) P = scalarpol(P,0);
3583 38626 : P = RgX_to_RgC(P, k-1); /* deg <= k-2 */
3584 38626 : settyp(P, t_VEC);
3585 38626 : Pd = P+1; /* Pd[i] = coeff(P,i) */
3586 38626 : Bd = bin+1;/* Bd[i] = binomial(k-2,i) */
3587 46249 : for (j = 1; j < k-2; j++)
3588 : {
3589 7623 : GEN c = gel(Pd,j);
3590 7623 : if (odd(j)) c = gneg(c);
3591 7623 : gel(Pd,j) = gdiv(c, gel(Bd,j));
3592 : }
3593 38626 : return vecreverse(P);
3594 : }
3595 : static GEN
3596 882 : RgXC_to_moments(GEN x, GEN bin)
3597 39508 : { pari_APPLY_same(RgX_to_moments(gel(x,i), bin)); }
3598 :
3599 : /* W an mspadic, assume O[2] is integral, den is the cancelled denominator
3600 : * or NULL, L = log(path)^* in sparse form */
3601 : static GEN
3602 2954 : omseval_int(struct m_act *S, GEN PHI, GEN L, hashtable *H)
3603 : {
3604 : long i, l;
3605 2954 : GEN v = cgetg_copy(PHI, &l);
3606 2954 : ZGl2QC_to_act(S, L, H); /* as operators on V */
3607 6286 : for (i = 1; i < l; i++)
3608 : {
3609 3332 : GEN T = dense_act_col(L, gel(PHI,i));
3610 3332 : gel(v,i) = T? FpC_red(T,S->q): zerocol(S->dim);
3611 : }
3612 2954 : return v;
3613 : }
3614 :
3615 : GEN
3616 14 : msomseval(GEN W, GEN phi, GEN path)
3617 : {
3618 : struct m_act S;
3619 14 : pari_sp av = avma;
3620 : GEN v, Wp;
3621 : long n, vden;
3622 14 : checkmspadic(W);
3623 14 : if (typ(phi) != t_COL || lg(phi) != 4) pari_err_TYPE("msomseval",phi);
3624 14 : vden = itos(gel(phi,2));
3625 14 : phi = gel(phi,1);
3626 14 : n = mspadic_get_n(W);
3627 14 : Wp= mspadic_get_Wp(W);
3628 14 : S.k = mspadic_get_weight(W);
3629 14 : S.p = mspadic_get_p(W);
3630 14 : S.q = powuu(S.p, n+vden);
3631 14 : S.dim = n + S.k - 1;
3632 14 : S.act = &moments_act;
3633 14 : path = path_to_M2(path);
3634 14 : v = omseval_int(&S, phi, M2_logf(Wp,path,NULL), NULL);
3635 14 : return gerepilecopy(av, v);
3636 : }
3637 : /* W = msinit(N,k,...); if flag < 0 or flag >= k-1, allow all symbols;
3638 : * else commit to v_p(a_p) <= flag (ordinary if flag = 0)*/
3639 : GEN
3640 490 : mspadicinit(GEN W, long p, long n, long flag)
3641 : {
3642 490 : pari_sp av = avma;
3643 : long a, N, k;
3644 : GEN P, C, M, bin, Wp, Tp, q, pn, actUp, teich, pas;
3645 :
3646 490 : checkms(W);
3647 490 : N = ms_get_N(W);
3648 490 : k = msk_get_weight(W);
3649 490 : if (flag < 0) flag = 1; /* worst case */
3650 357 : else if (flag >= k) flag = k-1;
3651 :
3652 490 : bin = vecbinomial(k-2);
3653 490 : Tp = mshecke(W, p, NULL);
3654 490 : if (N % p == 0)
3655 : {
3656 91 : if ((N/p) % p == 0) pari_err_IMPL("mspadicinit when p^2 | N");
3657 : /* a_p != 0 */
3658 84 : Wp = W;
3659 84 : M = gen_0;
3660 84 : flag = (k-2) / 2; /* exact valuation */
3661 : /* will multiply by matrix with denominator p^(k-2)/2 in mspadicint.
3662 : * Except if p = 2 (multiply by alpha^2) */
3663 84 : if (p == 2) n += k-2; else n += (k-2)/2;
3664 84 : pn = powuu(p,n);
3665 : /* For accuracy mod p^n, oms_dim1 require p^(k/2*n) */
3666 84 : q = powiu(pn, k/2);
3667 : }
3668 : else
3669 : { /* p-stabilize */
3670 399 : long s = msk_get_sign(W);
3671 : GEN M1, M2;
3672 :
3673 399 : Wp = mskinit(N*p, k, s);
3674 399 : M1 = getMorphism(W, Wp, mkvec(mat2(1,0,0,1)));
3675 399 : M2 = getMorphism(W, Wp, mkvec(mat2(p,0,0,1)));
3676 399 : if (s)
3677 : {
3678 147 : GEN SW = msk_get_starproj(W), SWp = msk_get_starproj(Wp);
3679 147 : M1 = Qevproj_apply2(M1, SW, SWp);
3680 147 : M2 = Qevproj_apply2(M2, SW, SWp);
3681 : }
3682 399 : M = mkvec2(M1,M2);
3683 399 : n += Z_lval(Q_denom(M), p); /*den. introduced by p-stabilization*/
3684 : /* in supersingular case: will multiply by matrix with denominator p^k
3685 : * in mspadicint. Except if p = 2 (multiply by alpha^2) */
3686 399 : if (flag) { if (p == 2) n += 2*k-2; else n += k; }
3687 399 : pn = powuu(p,n);
3688 : /* For accuracy mod p^n, supersingular require p^((2k-1-v_p(a_p))*n) */
3689 399 : if (flag) /* k-1 also takes care of a_p = 0. Worst case v_p(a_p) = flag */
3690 231 : q = powiu(pn, 2*k-1 - flag);
3691 : else
3692 168 : q = pn;
3693 : }
3694 483 : actUp = init_moments_act(Wp, p, n, q, Up_matrices(p));
3695 :
3696 483 : if (p == 2) C = gen_0;
3697 : else
3698 : {
3699 427 : pas = matpascal(n);
3700 427 : teich = teichmullerinit(p, n+1);
3701 427 : P = gpowers(utoipos(p), n);
3702 427 : C = cgetg(p, t_VEC);
3703 2317 : for (a = 1; a < p; a++)
3704 : { /* powb[j+1] = ((a - w(a)) / p)^j mod p^n */
3705 1890 : GEN powb = Fp_powers(diviuexact(subui(a, gel(teich,a)), p), n, pn);
3706 1890 : GEN Ca = cgetg(n+2, t_VEC);
3707 1890 : long j, r, ai = Fl_inv(a, p); /* a^(-1) */
3708 1890 : gel(C,a) = Ca;
3709 22134 : for (j = 0; j <= n; j++)
3710 : {
3711 20244 : GEN Caj = cgetg(j+2, t_VEC);
3712 20244 : GEN atij = gel(teich, Fl_powu(ai,j,p));/* w(a)^(-j) = w(a^(-j) mod p) */
3713 20244 : gel(Ca,j+1) = Caj;
3714 158200 : for (r = 0; r <= j; r++)
3715 : {
3716 137956 : GEN c = Fp_mul(gcoeff(pas,j+1,r+1), gel(powb, j-r+1), pn);
3717 137956 : c = Fp_mul(c,atij,pn); /* binomial(j,r)*b^(j-r)*w(a)^(-j) mod p^n */
3718 137956 : gel(Caj,r+1) = mulii(c, gel(P,j+1)); /* p^j * c mod p^(n+j) */
3719 : }
3720 : }
3721 : }
3722 : }
3723 483 : return gerepilecopy(av, mkvecn(8, Wp,Tp, bin, actUp, q,
3724 : mkvecsmall3(p,n,flag), M, C));
3725 : }
3726 :
3727 : #if 0
3728 : /* assume phi an ordinary OMS */
3729 : static GEN
3730 : omsactgl2(GEN W, GEN phi, GEN M)
3731 : {
3732 : GEN q, Wp, act;
3733 : long p, k, n;
3734 : checkmspadic(W);
3735 : Wp = mspadic_get_Wp(W);
3736 : p = mspadic_get_p(W);
3737 : k = mspadic_get_weight(W);
3738 : n = mspadic_get_n(W);
3739 : q = mspadic_get_q(W);
3740 : act = init_moments_act(Wp, p, n, q, M);
3741 : phi = gel(phi,1);
3742 : return dual_act(k-1, act, gel(phi,1));
3743 : }
3744 : #endif
3745 :
3746 : static GEN
3747 483 : eigenvalue(GEN T, GEN x)
3748 : {
3749 483 : long i, l = lg(x);
3750 637 : for (i = 1; i < l; i++)
3751 637 : if (!isintzero(gel(x,i))) break;
3752 483 : if (i == l) pari_err_DOMAIN("mstooms", "phi", "=", gen_0, x);
3753 483 : return gdiv(RgMrow_RgC_mul(T,x,i), gel(x,i));
3754 : }
3755 :
3756 : /* p coprime to ap, return unit root of x^2 - ap*x + p^(k-1), accuracy p^n */
3757 : GEN
3758 532 : mspadic_unit_eigenvalue(GEN ap, long k, GEN p, long n)
3759 : {
3760 532 : GEN sqrtD, D = subii(sqri(ap), shifti(powiu(p,k-1),2));
3761 532 : if (absequaliu(p,2))
3762 : {
3763 35 : n++; sqrtD = Zp_sqrt(D, p, n);
3764 35 : if (mod4(sqrtD) != mod4(ap)) sqrtD = negi(sqrtD);
3765 : }
3766 : else
3767 497 : sqrtD = Zp_sqrtlift(D, ap, p, n);
3768 : /* sqrtD = ap (mod p) */
3769 532 : return gmul2n(gadd(ap, cvtop(sqrtD,p,n)), -1);
3770 : }
3771 :
3772 : /* W = msinit(N,k,...); phi = T_p/U_p - eigensymbol */
3773 : GEN
3774 483 : mstooms(GEN W, GEN phi)
3775 : {
3776 483 : pari_sp av = avma;
3777 : GEN Wp, bin, Tp, c, alpha, ap, phi0, M;
3778 : long k, p, vden;
3779 :
3780 483 : checkmspadic(W);
3781 483 : if (typ(phi) != t_COL)
3782 : {
3783 161 : if (!is_Qevproj(phi)) pari_err_TYPE("mstooms",phi);
3784 161 : phi = gel(phi,1);
3785 161 : if (lg(phi) != 2) pari_err_TYPE("mstooms [dim_Q (eigenspace) > 1]",phi);
3786 161 : phi = gel(phi,1);
3787 : }
3788 :
3789 483 : Wp = mspadic_get_Wp(W);
3790 483 : Tp = mspadic_get_Tp(W);
3791 483 : bin = mspadic_get_bin(W);
3792 483 : k = msk_get_weight(Wp);
3793 483 : p = mspadic_get_p(W);
3794 483 : M = mspadic_get_M(W);
3795 :
3796 483 : phi = Q_remove_denom(phi, &c);
3797 483 : ap = eigenvalue(Tp, phi);
3798 483 : vden = c? Z_lvalrem(c, p, &c): 0;
3799 :
3800 483 : if (typ(M) == t_INT)
3801 : { /* p | N */
3802 : GEN c1;
3803 84 : alpha = ap;
3804 84 : alpha = ginv(alpha);
3805 84 : phi0 = mseval(Wp, phi, NULL);
3806 84 : phi0 = RgXC_to_moments(phi0, bin);
3807 84 : phi0 = Q_remove_denom(phi0, &c1);
3808 84 : if (c1) { vden += Z_lvalrem(c1, p, &c1); c = mul_denom(c,c1); }
3809 84 : if (umodiu(ap,p)) /* p \nmid a_p */
3810 49 : phi = oms_dim1(W, phi0, alpha, 0);
3811 : else
3812 : {
3813 35 : phi = oms_dim1(W, phi0, alpha, 1);
3814 35 : phi = Q_remove_denom(phi, &c1);
3815 35 : if (c1) { vden += Z_lvalrem(c1, p, &c1); c = mul_denom(c,c1); }
3816 : }
3817 : }
3818 : else
3819 : { /* p-stabilize */
3820 : GEN M1, M2, phi1, phi2, c1;
3821 399 : if (typ(M) != t_VEC || lg(M) != 3) pari_err_TYPE("mstooms",W);
3822 399 : M1 = gel(M,1);
3823 399 : M2 = gel(M,2);
3824 :
3825 399 : phi1 = RgM_RgC_mul(M1, phi);
3826 399 : phi2 = RgM_RgC_mul(M2, phi);
3827 399 : phi1 = mseval(Wp, phi1, NULL);
3828 399 : phi2 = mseval(Wp, phi2, NULL);
3829 :
3830 399 : phi1 = RgXC_to_moments(phi1, bin);
3831 399 : phi2 = RgXC_to_moments(phi2, bin);
3832 399 : phi = Q_remove_denom(mkvec2(phi1,phi2), &c1);
3833 399 : phi1 = gel(phi,1);
3834 399 : phi2 = gel(phi,2);
3835 399 : if (c1) { vden += Z_lvalrem(c1, p, &c1); c = mul_denom(c,c1); }
3836 : /* all polynomials multiplied by c p^vden */
3837 399 : if (umodiu(ap, p))
3838 : {
3839 238 : alpha = mspadic_unit_eigenvalue(ap, k, utoipos(p), mspadic_get_n(W));
3840 238 : alpha = ginv(alpha);
3841 238 : phi0 = gsub(phi1, gmul(lift_shallow(alpha),phi2));
3842 238 : phi = oms_dim1(W, phi0, alpha, 0);
3843 : }
3844 : else
3845 : { /* p | ap, alpha = [a_p, -1; p^(k-1), 0] */
3846 161 : long flag = mspadic_get_flag(W);
3847 161 : if (!flag || (signe(ap) && Z_lval(ap,p) < flag))
3848 7 : pari_err_TYPE("mstooms [v_p(ap) > mspadicinit flag]", phi);
3849 154 : alpha = mkmat22(ap,gen_m1, powuu(p, k-1),gen_0);
3850 154 : alpha = ginv(alpha);
3851 154 : phi = oms_dim2(W, mkvec2(phi1,phi2), gsqr(alpha), ap);
3852 154 : phi = Q_remove_denom(phi, &c1);
3853 154 : if (c1) { vden += Z_lvalrem(c1, p, &c1); c = mul_denom(c,c1); }
3854 : }
3855 : }
3856 476 : if (vden) c = mul_denom(c, powuu(p,vden));
3857 476 : if (p == 2) alpha = gsqr(alpha);
3858 476 : if (c) alpha = gdiv(alpha,c);
3859 476 : if (typ(alpha) == t_MAT)
3860 : { /* express in basis (omega,-p phi(omega)) */
3861 154 : gcoeff(alpha,2,1) = gdivgs(gcoeff(alpha,2,1), -p);
3862 154 : gcoeff(alpha,2,2) = gdivgs(gcoeff(alpha,2,2), -p);
3863 : /* at the end of mspadicint we shall multiply result by [1,0;0,-1/p]*alpha
3864 : * vden + k is the denominator of this matrix */
3865 : }
3866 : /* phi is integral-valued */
3867 476 : return gerepilecopy(av, mkcol3(phi, stoi(vden), alpha));
3868 : }
3869 :
3870 : /* HACK: the v[j] have different lengths */
3871 : static GEN
3872 2156 : FpVV_dotproduct(GEN v, GEN w, GEN p)
3873 : {
3874 2156 : long j, l = lg(v);
3875 2156 : GEN T = cgetg(l, t_VEC);
3876 26026 : for (j = 1; j < l; j++) gel(T,j) = FpV_dotproduct(gel(v,j),w,p);
3877 2156 : return T;
3878 : }
3879 :
3880 : /* 4^(i-1) x */
3881 : static GEN
3882 3822 : _4i(GEN x, long i)
3883 : {
3884 3822 : if (i > 1) x = gmul2n(x, (i-1)<<1);
3885 3822 : return x;
3886 : }
3887 : /* (-1)^i 4^(i-1) x */
3888 : static GEN
3889 1911 : _m4i(GEN x, long i)
3890 1911 : { x = _4i(x, i); return odd(i)? x: gneg(x); }
3891 : /* \int (-4z)^j given \int z^j */
3892 : static GEN
3893 98 : twistmoment_m4(GEN x)
3894 2009 : { pari_APPLY_same(_m4i(gel(x,i), i)); }
3895 : /* \int (4z)^j given \int z^j */
3896 : static GEN
3897 98 : twistmoment_4(GEN x)
3898 2009 : { pari_APPLY_same(_4i(gel(x,i), i)); }
3899 :
3900 : /* W an mspadic, phi eigensymbol, p \nmid D. Return C(x) mod FilM */
3901 : GEN
3902 483 : mspadicmoments(GEN W, GEN PHI, long D)
3903 : {
3904 483 : pari_sp av = avma;
3905 483 : long na, ia, b, lphi, aD = labs(D), pp, p, k, n, vden;
3906 : GEN Wp, Dact, vL, v, C, pn, phi;
3907 : struct m_act S;
3908 : hashtable *H;
3909 :
3910 483 : checkmspadic(W);
3911 483 : Wp = mspadic_get_Wp(W);
3912 483 : p = mspadic_get_p(W);
3913 483 : k = mspadic_get_weight(W);
3914 483 : n = mspadic_get_n(W);
3915 483 : C = mspadic_get_C(W);
3916 483 : if (typ(PHI) != t_COL || lg(PHI) != 4 || typ(gel(PHI,1)) != t_VEC)
3917 476 : PHI = mstooms(W, PHI);
3918 476 : vden = itos( gel(PHI,2) );
3919 476 : phi = gel(PHI,1); lphi = lg(phi);
3920 476 : if (p == 2) { na = 2; pp = 4; }
3921 420 : else { na = p-1; pp = p; }
3922 476 : pn = powuu(p, n + vden);
3923 :
3924 476 : S.p = p;
3925 476 : S.k = k;
3926 476 : S.q = pn;
3927 476 : S.dim = n+k-1;
3928 476 : S.act = &moments_act;
3929 476 : H = Gl2act_cache(ms_get_nbgen(Wp));
3930 476 : if (D == 1) Dact = NULL;
3931 : else
3932 : {
3933 63 : GEN gaD = utoi(aD), Dk = Fp_pows(stoi(D), 2-k, pn);
3934 63 : if (!sisfundamental(D)) pari_err_TYPE("mspadicmoments", stoi(D));
3935 63 : if (D % p == 0) pari_err_DOMAIN("mspadicmoments","p","|", stoi(D), utoi(p));
3936 63 : Dact = cgetg(aD, t_VEC);
3937 532 : for (b = 1; b < aD; b++)
3938 : {
3939 469 : GEN z = NULL;
3940 469 : long s = kross(D, b);
3941 469 : if (s)
3942 : {
3943 462 : pari_sp av2 = avma;
3944 : GEN d;
3945 462 : z = moments_act_i(&S, mkmat22(gaD,utoipos(b), gen_0,gaD));
3946 462 : d = s > 0? Dk: Fp_neg(Dk, pn);
3947 924 : z = equali1(d)? gerepilecopy(av2, z)
3948 462 : : gerepileupto(av2, FpM_Fp_mul(z, d, pn));
3949 : }
3950 469 : gel(Dact,b) = z;
3951 : }
3952 : }
3953 476 : vL = cgetg(na+1,t_VEC);
3954 : /* first pass to precompute log(paths), preload matrices and allow GC later */
3955 2464 : for (ia = 1; ia <= na; ia++)
3956 : {
3957 : GEN path, La;
3958 1988 : long a = (p == 2 && ia == 2)? -1: ia;
3959 1988 : if (Dact)
3960 : { /* twist by D */
3961 224 : La = cgetg(aD, t_VEC);
3962 1442 : for (b = 1; b < aD; b++)
3963 : {
3964 1218 : GEN Actb = gel(Dact,b);
3965 1218 : if (!Actb) continue;
3966 : /* oo -> a/pp + b/|D|*/
3967 1176 : path = mkmat22(gen_1, addii(mulss(a, aD), muluu(pp, b)),
3968 : gen_0, muluu(pp, aD));
3969 1176 : gel(La,b) = M2_logf(Wp,path,NULL);
3970 1176 : ZGl2QC_preload(&S, gel(La,b), H);
3971 : }
3972 : }
3973 : else
3974 : {
3975 1764 : path = mkmat22(gen_1,stoi(a), gen_0, utoipos(pp));
3976 1764 : La = M2_logf(Wp,path,NULL);
3977 1764 : ZGl2QC_preload(&S, La, H);
3978 : }
3979 1988 : gel(vL,ia) = La;
3980 : }
3981 476 : v = cgetg(na+1,t_VEC);
3982 : /* second pass, with GC */
3983 2464 : for (ia = 1; ia <= na; ia++)
3984 : {
3985 1988 : pari_sp av2 = avma;
3986 1988 : GEN vca, Ca = gel(C,ia), La = gel(vL,ia), va = cgetg(lphi, t_VEC);
3987 : long i;
3988 1988 : if (!Dact) vca = omseval_int(&S, phi, La, H);
3989 : else
3990 : { /* twist by D */
3991 224 : vca = cgetg(lphi,t_VEC);
3992 1442 : for (b = 1; b < aD; b++)
3993 : {
3994 1218 : GEN T, Actb = gel(Dact,b);
3995 1218 : if (!Actb) continue;
3996 1176 : T = omseval_int(&S, phi, gel(La,b), H);
3997 2352 : for (i = 1; i < lphi; i++)
3998 : {
3999 1176 : GEN z = FpM_FpC_mul(Actb, gel(T,i), pn);
4000 1176 : gel(vca,i) = b==1? z: ZC_add(gel(vca,i), z);
4001 : }
4002 : }
4003 : }
4004 1988 : if (p != 2)
4005 4032 : { for (i=1; i<lphi; i++) gel(va,i) = FpVV_dotproduct(Ca,gel(vca,i),pn); }
4006 112 : else if (ia == 1) /* \tilde{a} = 1 */
4007 154 : { for (i=1; i<lphi; i++) gel(va,i) = twistmoment_4(gel(vca,i)); }
4008 : else /* \tilde{a} = -1 */
4009 154 : { for (i=1; i<lphi; i++) gel(va,i) = twistmoment_m4(gel(vca,i)); }
4010 1988 : gel(v,ia) = gerepilecopy(av2, va);
4011 : }
4012 476 : return gerepilecopy(av, mkvec3(v, gel(PHI,3), mkvecsmall4(p,n+vden,n,D)));
4013 : }
4014 : static void
4015 1918 : checkoms(GEN v)
4016 : {
4017 1918 : if (typ(v) != t_VEC || lg(v) != 4 || typ(gel(v,1)) != t_VEC
4018 1918 : || typ(gel(v,3))!=t_VECSMALL)
4019 0 : pari_err_TYPE("checkoms [apply mspadicmoments]", v);
4020 1918 : }
4021 : static long
4022 4284 : oms_get_p(GEN oms) { return gel(oms,3)[1]; }
4023 : static long
4024 4186 : oms_get_n(GEN oms) { return gel(oms,3)[2]; }
4025 : static long
4026 2464 : oms_get_n0(GEN oms) { return gel(oms,3)[3]; }
4027 : static long
4028 1918 : oms_get_D(GEN oms) { return gel(oms,3)[4]; }
4029 : static int
4030 98 : oms_is_supersingular(GEN oms) { GEN v = gel(oms,1); return lg(gel(v,1)) == 3; }
4031 :
4032 : /* sum(j = 1, n, (-1)^(j+1)/j * x^j) */
4033 : static GEN
4034 784 : log1x(long n)
4035 : {
4036 784 : long i, l = n+3;
4037 784 : GEN v = cgetg(l, t_POL);
4038 784 : v[1] = evalvarn(0)|evalsigne(1); gel(v,2) = gen_0;
4039 8904 : for (i = 3; i < l; i++)
4040 8120 : gel(v,i) = mkfrac(odd(i)? gen_1: gen_m1, utoipos(i-2));
4041 784 : return v;
4042 : }
4043 :
4044 : /* S = (1+x)^zk log(1+x)^logj (mod x^(n+1)) */
4045 : static GEN
4046 1820 : xlog1x(long n, long zk, long logj, long *pteich)
4047 : {
4048 1820 : GEN S = logj? RgXn_powu_i(log1x(n), logj, n+1): NULL;
4049 1820 : if (zk)
4050 : {
4051 1183 : GEN L = deg1pol_shallow(gen_1, gen_1, 0); /* x+1 */
4052 1183 : *pteich += zk;
4053 1183 : if (zk < 0) { L = RgXn_inv(L,n+1); zk = -zk; }
4054 1183 : if (zk != 1) L = RgXn_powu_i(L, zk, n+1);
4055 1183 : S = S? RgXn_mul(S, L, n+1): L;
4056 : }
4057 1820 : return S;
4058 : }
4059 :
4060 : /* oms from mspadicmoments; integrate teichmuller^i * S(x) [S = NULL: 1]*/
4061 : static GEN
4062 2366 : mspadicint(GEN oms, long teichi, GEN S)
4063 : {
4064 2366 : pari_sp av = avma;
4065 2366 : long p = oms_get_p(oms), n = oms_get_n(oms), n0 = oms_get_n0(oms);
4066 2366 : GEN vT = gel(oms,1), alpha = gel(oms,2), gp = utoipos(p);
4067 2366 : long loss = S? Z_lval(Q_denom(S), p): 0;
4068 2366 : long nfinal = minss(n-loss, n0);
4069 2366 : long i, la, l = lg(gel(vT,1));
4070 2366 : GEN res = cgetg(l, t_COL), teich = NULL;
4071 :
4072 2366 : if (S) S = RgX_to_RgC(S,lg(gmael(vT,1,1))-1);
4073 2366 : if (p == 2)
4074 : {
4075 448 : la = 3; /* corresponds to [1,-1] */
4076 448 : teichi &= 1;
4077 : }
4078 : else
4079 : {
4080 1918 : la = p; /* corresponds to [1,2,...,p-1] */
4081 1918 : teichi = umodsu(teichi, p-1);
4082 1918 : if (teichi) teich = teichmullerinit(p, n);
4083 : }
4084 5446 : for (i=1; i<l; i++)
4085 : {
4086 3080 : pari_sp av2 = avma;
4087 3080 : GEN s = gen_0;
4088 : long ia;
4089 14756 : for (ia = 1; ia < la; ia++)
4090 : { /* Ta[j+1] correct mod p^n */
4091 11676 : GEN Ta = gmael(vT,ia,i), v = S? RgV_dotproduct(Ta, S): gel(Ta,1);
4092 11676 : if (teichi && ia != 1)
4093 : {
4094 3843 : if (p != 2)
4095 3626 : v = gmul(v, gel(teich, Fl_powu(ia,teichi,p)));
4096 : else
4097 217 : if (teichi) v = gneg(v);
4098 : }
4099 11676 : s = gadd(s, v);
4100 : }
4101 3080 : s = gadd(s, zeropadic_shallow(gp,nfinal));
4102 3080 : gel(res,i) = gerepileupto(av2, s);
4103 : }
4104 2366 : return gerepileupto(av, gmul(alpha, res));
4105 : }
4106 : /* integrate P = polynomial in log(x); vlog[j+1] = mspadicint(0,log(1+x)^j) */
4107 : static GEN
4108 539 : mspadicint_RgXlog(GEN P, GEN vlog)
4109 : {
4110 539 : long i, d = degpol(P);
4111 539 : GEN s = gmul(gel(P,2), gel(vlog,1));
4112 1848 : for (i = 1; i <= d; i++) s = gadd(s, gmul(gel(P,i+2), gel(vlog,i+1)));
4113 539 : return s;
4114 : };
4115 :
4116 : /* oms from mspadicmoments */
4117 : GEN
4118 98 : mspadicseries(GEN oms, long teichi)
4119 : {
4120 98 : pari_sp av = avma;
4121 : GEN S, L, X, vlog, s, s2, u, logu, bin;
4122 : long j, p, m, n, step, stop;
4123 98 : checkoms(oms);
4124 98 : n = oms_get_n0(oms);
4125 98 : if (n < 1)
4126 : {
4127 0 : s = zeroser(0,0);
4128 0 : if (oms_is_supersingular(oms)) s = mkvec2(s,s);
4129 0 : return gerepilecopy(av, s);
4130 : }
4131 98 : p = oms_get_p(oms);
4132 98 : vlog = cgetg(n+1, t_VEC);
4133 98 : step = p == 2? 2: 1;
4134 98 : stop = 0;
4135 98 : S = NULL;
4136 98 : L = log1x(n);
4137 644 : for (j = 0; j < n; j++)
4138 : {
4139 616 : if (j) stop += step + u_lval(j,p); /* = step*j + v_p(j!) */
4140 616 : if (stop >= n) break;
4141 : /* S = log(1+x)^j */
4142 546 : gel(vlog,j+1) = mspadicint(oms,teichi,S);
4143 546 : S = S? RgXn_mul(S, L, n+1): L;
4144 : }
4145 98 : m = j;
4146 98 : u = utoipos(p == 2? 5: 1+p);
4147 98 : logu = glog(cvtop(u, utoipos(p), 4*m), 0);
4148 98 : X = gdiv(pol_x(0), logu);
4149 98 : s = cgetg(m+1, t_VEC);
4150 98 : s2 = oms_is_supersingular(oms)? cgetg(m+1, t_VEC): NULL;
4151 98 : bin = pol_1(0);
4152 539 : for (j = 0; j < m; j++)
4153 : { /* bin = binomial(x/log(1+p+O(p^(4*n))), j) mod x^m */
4154 539 : GEN a, v = mspadicint_RgXlog(bin, vlog);
4155 539 : int done = 1;
4156 539 : gel(s,j+1) = a = gel(v,1);
4157 539 : if (!gequal0(a) || valp(a) > 0) done = 0; else setlg(s,j+1);
4158 539 : if (s2)
4159 : {
4160 119 : gel(s2,j+1) = a = gel(v,2);
4161 119 : if (!gequal0(a) || valp(a) > 0) done = 0; else setlg(s2,j+1);
4162 : }
4163 539 : if (done || j == m-1) break;
4164 441 : bin = RgXn_mul(bin, gdivgu(gsubgs(X, j), j+1), m);
4165 : }
4166 98 : s = RgV_to_ser(s,0,lg(s)+1);
4167 98 : if (s2) { s2 = RgV_to_ser(s2,0,lg(s2)+1); s = mkvec2(s, s2); }
4168 98 : if (kross(oms_get_D(oms), p) >= 0) return gerepilecopy(av, s);
4169 7 : return gerepileupto(av, gneg(s));
4170 : }
4171 : void
4172 1911 : mspadic_parse_chi(GEN s, GEN *s1, GEN *s2)
4173 : {
4174 1911 : if (!s) *s1 = *s2 = gen_0;
4175 1778 : else switch(typ(s))
4176 : {
4177 1274 : case t_INT: *s1 = *s2 = s; break;
4178 504 : case t_VEC:
4179 504 : if (lg(s) == 3)
4180 : {
4181 504 : *s1 = gel(s,1);
4182 504 : *s2 = gel(s,2);
4183 504 : if (typ(*s1) == t_INT && typ(*s2) == t_INT) break;
4184 : }
4185 0 : default: pari_err_TYPE("mspadicL",s);
4186 0 : *s1 = *s2 = NULL;
4187 : }
4188 1911 : }
4189 : /* oms from mspadicmoments
4190 : * r-th derivative of L(f,chi^s,psi) in direction <chi>
4191 : - s \in Z_p \times \Z/(p-1)\Z, s-> chi^s=<\chi>^s_1 omega^s_2)
4192 : - Z -> Z_p \times \Z/(p-1)\Z par s-> (s, s mod p-1).
4193 : */
4194 : GEN
4195 1820 : mspadicL(GEN oms, GEN s, long r)
4196 : {
4197 1820 : pari_sp av = avma;
4198 : GEN s1, s2, z, S;
4199 : long p, n, teich;
4200 1820 : checkoms(oms);
4201 1820 : p = oms_get_p(oms);
4202 1820 : n = oms_get_n(oms);
4203 1820 : mspadic_parse_chi(s, &s1,&s2);
4204 1820 : teich = umodiu(subii(s2,s1), p==2? 2: p-1);
4205 1820 : S = xlog1x(n, itos(s1), r, &teich);
4206 1820 : z = mspadicint(oms, teich, S);
4207 1820 : if (lg(z) == 2) z = gel(z,1);
4208 1820 : if (kross(oms_get_D(oms), p) < 0) z = gneg(z);
4209 1820 : return gerepilecopy(av, z);
4210 : }
4211 :
4212 : /****************************************************************************/
4213 :
4214 : struct siegel
4215 : {
4216 : GEN V, Ast;
4217 : long N; /* level */
4218 : long oo; /* index of the [oo,0] path */
4219 : long k1, k2; /* two distinguished indices */
4220 : long n; /* #W, W = initial segment [in siegelstepC] already normalized */
4221 : };
4222 :
4223 : static void
4224 2527 : siegel_init(struct siegel *C, GEN M)
4225 : {
4226 : GEN CPI, CP, MM, V, W, Ast;
4227 2527 : GEN m = gel(M,11), M2 = gel(M,2), S = msN_get_section(M);
4228 2527 : GEN E2fromE1 = msN_get_E2fromE1(M);
4229 2527 : long m0 = lg(M2)-1;
4230 2527 : GEN E2 = vecslice(M2, m[1]+1, m[2]);/* E2 */
4231 2527 : GEN E1T = vecslice(M2, m[3]+1, m0); /* E1,T2,T31 */
4232 2527 : GEN L = shallowconcat(E1T, E2);
4233 2527 : long i, l = lg(L), n = lg(E1T)-1, lE = lg(E2);
4234 :
4235 2527 : Ast = cgetg(l, t_VECSMALL);
4236 45479 : for (i = 1; i < lE; ++i)
4237 : {
4238 42952 : long j = E2fromE1_c(gel(E2fromE1,i));
4239 42952 : Ast[n+i] = j;
4240 42952 : Ast[j] = n+i;
4241 : }
4242 4053 : for (; i<=n; ++i) Ast[i] = i;
4243 2527 : MM = cgetg (l,t_VEC);
4244 :
4245 89957 : for (i = 1; i < l; i++)
4246 : {
4247 87430 : GEN c = gel(S, L[i]);
4248 87430 : long c12, c22, c21 = ucoeff(c,2,1);
4249 87430 : if (!c21) { gel(MM,i) = gen_0; continue; }
4250 84903 : c22 = ucoeff(c,2,2);
4251 84903 : if (!c22) { gel(MM,i) = gen_m1; continue; }
4252 82376 : c12 = ucoeff(c,1,2);
4253 82376 : gel(MM,i) = sstoQ(c12, c22); /* right extremity > 0 */
4254 : }
4255 2527 : CP = indexsort(MM);
4256 2527 : CPI = cgetg(l, t_VECSMALL);
4257 2527 : V = cgetg(l, t_VEC);
4258 2527 : W = cgetg(l, t_VECSMALL);
4259 89957 : for (i = 1; i < l; ++i)
4260 : {
4261 87430 : gel(V,i) = mat2_to_ZM(gel(S, L[CP[i]]));
4262 87430 : CPI[CP[i]] = i;
4263 : }
4264 89957 : for (i = 1; i < l; ++i) W[CPI[i]] = CPI[Ast[i]];
4265 2527 : C->V = V;
4266 2527 : C->Ast = W;
4267 2527 : C->n = 0;
4268 2527 : C->oo = 2;
4269 2527 : C->N = ms_get_N(M);
4270 2527 : }
4271 :
4272 : static double
4273 0 : ZMV_size(GEN v)
4274 : {
4275 0 : long i, l = lg(v);
4276 0 : GEN z = cgetg(l, t_VECSMALL);
4277 0 : for (i = 1; i < l; i++) z[i] = gexpo(gel(v,i));
4278 0 : return ((double)zv_sum(z)) / (4*(l-1));
4279 : }
4280 :
4281 : /* apply permutation perm to struct S. Don't follow k1,k2 */
4282 : static void
4283 5558 : siegel_perm0(struct siegel *S, GEN perm)
4284 : {
4285 5558 : pari_sp av = avma;
4286 5558 : long i, l = lg(S->V);
4287 5558 : GEN V2 = cgetg(l, t_VEC), Ast2 = cgetg(l, t_VECSMALL);
4288 5558 : GEN V = S->V, Ast = S->Ast;
4289 :
4290 267078 : for (i = 1; i < l; i++) gel(V2,perm[i]) = gel(V,i);
4291 267078 : for (i = 1; i < l; i++) Ast2[perm[i]] = perm[Ast[i]];
4292 267078 : for (i = 1; i < l; i++) { S->Ast[i] = Ast2[i]; gel(V,i) = gel(V2,i); }
4293 5558 : set_avma(av); S->oo = perm[S->oo];
4294 5558 : }
4295 : /* apply permutation perm to full struct S */
4296 : static void
4297 5194 : siegel_perm(struct siegel *S, GEN perm)
4298 : {
4299 5194 : siegel_perm0(S, perm);
4300 5194 : S->k1 = perm[S->k1];
4301 5194 : S->k2 = perm[S->k2];
4302 5194 : }
4303 : /* cyclic permutation of lg = l-1 moving a -> 1, a+1 -> 2, etc. */
4304 : static GEN
4305 2884 : rotate_perm(long l, long a)
4306 : {
4307 2884 : GEN p = cgetg(l, t_VECSMALL);
4308 2884 : long i, j = 1;
4309 86905 : for (i = a; i < l; i++) p[i] = j++;
4310 49329 : for (i = 1; i < a; i++) p[i] = j++;
4311 2884 : return p;
4312 : }
4313 :
4314 : /* a1 < c1 <= a2 < c2*/
4315 : static GEN
4316 2520 : basic_op_perm(long l, long a1, long a2, long c1, long c2)
4317 : {
4318 2520 : GEN p = cgetg(l, t_VECSMALL);
4319 2520 : long i, j = 1;
4320 2520 : p[a1] = j++;
4321 22568 : for (i = c1; i < a2; i++) p[i] = j++;
4322 32284 : for (i = a1+1; i < c1; i++) p[i] = j++;
4323 2520 : p[a2] = j++;
4324 44891 : for (i = c2; i < l; i++) p[i] = j++;
4325 2520 : for (i = 1; i < a1; i++) p[i] = j++;
4326 29855 : for (i = a2+1; i < c2; i++) p[i] = j++;
4327 2520 : return p;
4328 : }
4329 : static GEN
4330 154 : basic_op_perm_elliptic(long l, long a1)
4331 : {
4332 154 : GEN p = cgetg(l, t_VECSMALL);
4333 154 : long i, j = 1;
4334 154 : p[a1] = j++;
4335 2660 : for (i = 1; i < a1; i++) p[i] = j++;
4336 3990 : for (i = a1+1; i < l; i++) p[i] = j++;
4337 154 : return p;
4338 : }
4339 : static GEN
4340 90104 : ZM2_rev(GEN T) { return mkmat2(gel(T,2), ZC_neg(gel(T,1))); }
4341 :
4342 : /* In place, V = vector of consecutive paths, between x <= y.
4343 : * V[x..y-1] <- g*V[x..y-1] */
4344 : static void
4345 5733 : path_vec_mul(GEN V, long x, long y, GEN g)
4346 : {
4347 : long j;
4348 : GEN M;
4349 5733 : if (x == y) return;
4350 3360 : M = gel(V,x); gel(V,x) = ZM_mul(g,M);
4351 37709 : for (j = x+1; j < y; j++) /* V[j] <- g*V[j], optimized */
4352 : {
4353 34349 : GEN Mnext = gel(V,j); /* Mnext[,1] = M[,2] */
4354 34349 : GEN gM = gel(V,j-1), u = gel(gM,2);
4355 34349 : if (!ZV_equal(gel(M,2), gel(Mnext,1))) u = ZC_neg(u);
4356 34349 : gel(V,j) = mkmat2(u, ZM_ZC_mul(g,gel(Mnext,2)));
4357 34349 : M = Mnext;
4358 : }
4359 : }
4360 :
4361 4830 : static long prev(GEN V, long i) { return (i == 1)? lg(V)-1: i-1; }
4362 4830 : static long next(GEN V, long i) { return (i == lg(V)-1)? 1: i+1; }
4363 : static GEN
4364 95298 : ZM_det2(GEN u, GEN v)
4365 : {
4366 95298 : GEN a = gel(u,1), c = gel(u,2);
4367 95298 : GEN b = gel(v,1), d = gel(v,2); return subii(mulii(a,d), mulii(b,c));
4368 : }
4369 : static GEN
4370 90104 : ZM2_det(GEN T) { return ZM_det2(gel(T,1),gel(T,2)); }
4371 : static long
4372 5194 : ZM_det2_sign(GEN u, GEN v)
4373 : {
4374 5194 : pari_sp av = avma;
4375 5194 : long s = signe(ZM_det2(u, v));
4376 5194 : return gc_long(av, s);
4377 : }
4378 : static void
4379 4466 : fill1(GEN V, long a)
4380 : {
4381 4466 : long p = prev(V,a), n = next(V,a);
4382 4466 : GEN u = gmael(V,p,2), v = gmael(V,n,1);
4383 4466 : if (ZM_det2_sign(u,v) < 0) v = ZC_neg(v);
4384 4466 : gel(V,a) = mkmat2(u, v);
4385 4466 : }
4386 : /* a1 < a2 */
4387 : static void
4388 2520 : fill2(GEN V, long a1, long a2)
4389 : {
4390 2520 : if (a2 != a1+1) { fill1(V,a1); fill1(V,a2); } /* non adjacent, reconnect */
4391 : else
4392 : { /* parabolic */
4393 364 : long p = prev(V,a1), n = next(V,a2);
4394 364 : GEN u, v, C = gmael(V,a1,2), mC = NULL; /* = \pm V[a2][1] */
4395 364 : u = gmael(V,p,2); v = C;
4396 364 : if (ZM_det2_sign(u,v) < 0) v = mC = ZC_neg(C);
4397 364 : gel(V,a1) = mkmat2(u,v);
4398 364 : v = gmael(V,n,1); u = C;
4399 364 : if (ZM_det2_sign(u,v) < 0) u = mC? mC: ZC_neg(C);
4400 364 : gel(V,a2) = mkmat2(u,v);
4401 : }
4402 2520 : }
4403 :
4404 : /* DU = det(U), return g = T*U^(-1) or NULL if not in Gamma0(N); if N = 0,
4405 : * only test whether g is integral */
4406 : static GEN
4407 90979 : ZM2_div(GEN T, GEN U, GEN DU, long N)
4408 : {
4409 90979 : GEN a=gcoeff(U,1,1), b=gcoeff(U,1,2), c=gcoeff(U,2,1), d=gcoeff(U,2,2);
4410 90979 : GEN e=gcoeff(T,1,1), f=gcoeff(T,1,2), g=gcoeff(T,2,1), h=gcoeff(T,2,2);
4411 : GEN A, B, C, D, r;
4412 :
4413 90979 : C = dvmdii(subii(mulii(d,g), mulii(c,h)), DU, &r);
4414 90979 : if (r != gen_0 || (N && smodis(C,N))) return NULL;
4415 90104 : A = dvmdii(subii(mulii(d,e), mulii(c,f)), DU, &r);
4416 90104 : if (r != gen_0) return NULL;
4417 90104 : B = dvmdii(subii(mulii(a,f), mulii(b,e)), DU, &r);
4418 90104 : if (r != gen_0) return NULL;
4419 90104 : D = dvmdii(subii(mulii(a,h), mulii(g,b)), DU, &r);
4420 90104 : if (r != gen_0) return NULL;
4421 90104 : retmkmat22(A,B,C,D);
4422 : }
4423 :
4424 : static GEN
4425 90104 : get_g(struct siegel *S, long a1)
4426 : {
4427 90104 : pari_sp av = avma;
4428 90104 : long a2 = S->Ast[a1];
4429 90104 : GEN a = gel(S->V,a1), ar = ZM2_rev(gel(S->V,a2)), Dar = ZM2_det(ar);
4430 90104 : GEN g = ZM2_div(a, ar, Dar, S->N);
4431 90104 : if (!g)
4432 : {
4433 875 : GEN tau = mkmat22(gen_0,gen_m1, gen_1,gen_m1); /*[0,-1;1,-1]*/
4434 875 : g = ZM2_div(ZM_mul(ar, tau), ar, Dar, 0);
4435 : }
4436 90104 : return gerepilecopy(av, g);
4437 : }
4438 : /* input V = (X1 a X2 | X3 a^* X4) + Ast
4439 : * a1 = index of a
4440 : * a2 = index of a^*, inferred from a1. We must have a != a^*
4441 : * c1 = first cut [ index of first path in X3 ]
4442 : * c2 = second cut [ either in X4 or X1, index of first path ]
4443 : * Assume a < a^* (cf Paranoia below): c1 or c2 must be in
4444 : * ]a,a^*], and the other in the "complement" ]a^*,a] */
4445 : static void
4446 2520 : basic_op(struct siegel *S, long a1, long c1, long c2)
4447 : {
4448 : pari_sp av;
4449 2520 : long l = lg(S->V), a2 = S->Ast[a1];
4450 : GEN g;
4451 :
4452 2520 : if (a1 == a2)
4453 : { /* a = a^* */
4454 0 : g = get_g(S, a1);
4455 0 : path_vec_mul(S->V, a1+1, l, g);
4456 0 : av = avma;
4457 0 : siegel_perm(S, basic_op_perm_elliptic(l, a1));
4458 : /* fill the hole left at a1, reconnect the path */
4459 0 : set_avma(av); fill1(S->V, a1); return;
4460 : }
4461 :
4462 : /* Paranoia: (a,a^*) conjugate, call 'a' the first one */
4463 2520 : if (a2 < a1) lswap(a1,a2);
4464 : /* Now a1 < a2 */
4465 2520 : if (c1 <= a1 || c1 > a2) lswap(c1,c2); /* ensure a1 < c1 <= a2 */
4466 2520 : if (c2 < a1)
4467 : { /* if cut c2 is in X1 = X11|X12, rotate to obtain
4468 : (a X2 | X3 a^* X4 X11|X12): then a1 = 1 */
4469 : GEN p;
4470 2520 : av = avma; p = rotate_perm(l, a1);
4471 2520 : siegel_perm(S, p);
4472 2520 : a1 = 1; /* = p[a1] */
4473 2520 : a2 = S->Ast[1]; /* > a1 */
4474 2520 : c1 = p[c1];
4475 2520 : c2 = p[c2]; set_avma(av);
4476 : }
4477 : /* Now a1 < c1 <= a2 < c2; a != a^* */
4478 2520 : g = get_g(S, a1);
4479 2520 : if (S->oo >= c1 && S->oo < c2) /* W inside [c1..c2[ */
4480 539 : { /* c2 -> c1 excluding a1 */
4481 539 : GEN gi = SL2_inv_shallow(g); /* g a^* = a; gi a = a^* */
4482 539 : path_vec_mul(S->V, 1, a1, gi);
4483 539 : path_vec_mul(S->V, a1+1, c1, gi);
4484 539 : path_vec_mul(S->V, c2, l, gi);
4485 : }
4486 : else
4487 : { /* c1 -> c2 excluding a2 */
4488 1981 : path_vec_mul(S->V, c1, a2, g);
4489 1981 : path_vec_mul(S->V, a2+1, c2, g);
4490 : }
4491 2520 : av = avma;
4492 2520 : siegel_perm(S, basic_op_perm(l, a1,a2, c1,c2));
4493 2520 : set_avma(av);
4494 : /* fill the holes left at a1,a2, reconnect the path */
4495 2520 : fill2(S->V, a1, a2);
4496 : }
4497 : /* a = a^* (elliptic case) */
4498 : static void
4499 154 : basic_op_elliptic(struct siegel *S, long a1)
4500 : {
4501 : pari_sp av;
4502 154 : long l = lg(S->V);
4503 154 : GEN g = get_g(S, a1);
4504 154 : path_vec_mul(S->V, a1+1, l, g);
4505 154 : av = avma; siegel_perm(S, basic_op_perm_elliptic(l, a1));
4506 : /* fill the hole left at a1 (now at 1), reconnect the path */
4507 154 : set_avma(av); fill1(S->V, 1);
4508 154 : }
4509 :
4510 : /* input V = W X a b Y a^* Z b^* T, W already normalized
4511 : * X = [n+1, k1-1], Y = [k2+1, Ast[k1]-1],
4512 : * Z = [Ast[k1]+1, Ast[k2]-1], T = [Ast[k2]+1, oo].
4513 : * Assume that X doesn't start by c c^* or a b a^* b^*. */
4514 : static void
4515 1057 : siegelstep(struct siegel *S)
4516 : {
4517 1057 : if (S->Ast[S->k1] == S->k1)
4518 : {
4519 154 : basic_op_elliptic(S, S->k1);
4520 154 : S->n++;
4521 : }
4522 903 : else if (S->Ast[S->k1] == S->k1+1)
4523 : {
4524 364 : basic_op(S, S->k1, S->Ast[S->k1], 1); /* 1: W starts there */
4525 364 : S->n += 2;
4526 : }
4527 : else
4528 : {
4529 539 : basic_op(S, S->k2, S->Ast[S->k1], 1); /* 1: W starts there */
4530 539 : basic_op(S, S->k1, S->k2, S->Ast[S->k2]);
4531 539 : basic_op(S, S->Ast[S->k2], S->k2, S->Ast[S->k1]);
4532 539 : basic_op(S, S->k1, S->Ast[S->k1], S->Ast[S->k2]);
4533 539 : S->n += 4;
4534 : }
4535 1057 : }
4536 :
4537 : /* normalize hyperbolic polygon */
4538 : static void
4539 301 : mssiegel(struct siegel *S)
4540 : {
4541 301 : pari_sp av = avma;
4542 : long k, t, nv;
4543 : #ifdef COUNT
4544 : long countset[16];
4545 : for (k = 0; k < 16; k++) countset[k] = 0;
4546 : #endif
4547 :
4548 301 : nv = lg(S->V)-1;
4549 301 : if (DEBUGLEVEL>1) err_printf("nv = %ld, expo = %.2f\n", nv,ZMV_size(S->V));
4550 301 : t = 0;
4551 2205 : while (S->n < nv)
4552 : {
4553 1904 : if (S->Ast[S->n+1] == S->n+1) { S->n++; continue; }
4554 1778 : if (S->Ast[S->n+1] == S->n+2) { S->n += 2; continue; }
4555 1134 : if (S->Ast[S->n+1] == S->n+3 && S->Ast[S->n+2] == S->n+4) { S->n += 4; continue; }
4556 1057 : k = nv;
4557 1127 : while (k > S->n)
4558 : {
4559 1127 : if (S->Ast[k] == k) { k--; continue; }
4560 1099 : if (S->Ast[k] == k-1) { k -= 2; continue; }
4561 1057 : if (S->Ast[k] == k-2 && S->Ast[k-1] == k-3) { k -= 4; continue; }
4562 1057 : break;
4563 : }
4564 1057 : if (k != nv)
4565 : {
4566 63 : pari_sp av2 = avma;
4567 63 : siegel_perm0(S, rotate_perm(nv+1, k+1));
4568 63 : set_avma(av2); S->n += nv-k;
4569 : }
4570 :
4571 6223 : for (k = S->n+1; k <= nv; k++)
4572 6223 : if (S->Ast[k] <= k) { t = S->Ast[k]; break; }
4573 1057 : S->k1 = t;
4574 1057 : S->k2 = t+1;
4575 : #ifdef COUNT
4576 : countset[ ((S->k1-1 == S->n)
4577 : | ((S->k2 == S->Ast[S->k1]-1) << 1)
4578 : | ((S->Ast[S->k1] == S->Ast[S->k2]-1) << 2)
4579 : | ((S->Ast[S->k2] == nv) << 3)) ]++;
4580 : #endif
4581 1057 : siegelstep(S);
4582 1057 : if (gc_needed(av,2))
4583 : {
4584 0 : if(DEBUGMEM>1) pari_warn(warnmem,"mspolygon, n = %ld",S->n);
4585 0 : gerepileall(av, 2, &S->V, &S->Ast);
4586 : }
4587 : }
4588 301 : if (DEBUGLEVEL>1) err_printf("expo = %.2f\n", ZMV_size(S->V));
4589 : #ifdef COUNT
4590 : for (k = 0; k < 16; k++)
4591 : err_printf("%3ld: %6ld\n", k, countset[k]);
4592 : #endif
4593 301 : }
4594 :
4595 : /* return a vector of char* */
4596 : static GEN
4597 0 : Ast2v(GEN Ast)
4598 : {
4599 0 : long j = 0, k, l = lg(Ast);
4600 0 : GEN v = const_vec(l-1, NULL);
4601 0 : for (k=1; k < l; k++)
4602 : {
4603 : char *sj;
4604 0 : if (gel(v,k)) continue;
4605 0 : j++;
4606 0 : sj = stack_sprintf("$%ld$", j);
4607 0 : gel(v,k) = (GEN)sj;
4608 0 : if (Ast[k] != k) gel(v,Ast[k]) = (GEN)stack_sprintf("$%ld^*$", j);
4609 : }
4610 0 : return v;
4611 : };
4612 :
4613 : static void
4614 0 : decorate(pari_str *s, GEN g, GEN arc, double high)
4615 : {
4616 0 : double a = gtodouble(gcoeff(g,1,1)), c = gtodouble(gcoeff(g,2,1));
4617 0 : double d = gtodouble(gcoeff(g,2,2));
4618 0 : if (a + d)
4619 : {
4620 0 : double t, u, C = 360/(2*M_PI), x = (a-d) / (2*c), y = 0.8660254/fabs(c);
4621 0 : long D1 = itos(gcoeff(arc,2,1));
4622 0 : long D2 = itos(gcoeff(arc,2,2));
4623 0 : str_printf(s, "\\coordinate (ellpt) at (%.4f,%.4f);\n\\draw (ellpt) node {$\\bullet$}\n", x, y);
4624 0 : if (D1)
4625 : {
4626 0 : t = gtodouble(gcoeff(arc,1,1)) / D1;
4627 0 : u = (x*x + y*y - t*t)/(x-t)/2;
4628 0 : str_printf(s, "arc (%.4f:180:%.4f)\n", C*atan2(y,x-u), fabs(t-u));
4629 : }
4630 : else
4631 0 : str_printf(s, "-- (%.4f,%.4f)\n", x, high);
4632 0 : if (D2)
4633 : {
4634 0 : t = gtodouble(gcoeff(arc,1,2)) / D2;
4635 0 : u = (x*x + y*y - t*t)/(x-t)/2;
4636 0 : str_printf(s, "(ellpt) arc (%.4f:0:%.4f);\n", C*atan2(y,x-u), fabs(t-u));
4637 : }
4638 : else
4639 0 : str_printf(s, "(ellpt) -- (%.4f,%.4f);\n", x, high);
4640 : }
4641 : else
4642 0 : str_printf(s, "\\draw (%.4f,%.4f) node {$\\circ$};\n",a/c,fabs(1/c));
4643 0 : }
4644 :
4645 : static GEN
4646 0 : polygon2tex(GEN V, GEN Ast, GEN G)
4647 : {
4648 0 : pari_sp av = avma;
4649 : pari_str s;
4650 0 : long j, l = lg(V), flag = (l <= 16);
4651 0 : double d, high = (l < 4)? 1.2: 0.5;
4652 0 : GEN v = Ast2v(Ast), r1 = NULL, r2 = NULL;
4653 :
4654 0 : for (j = 1; j < l; j++)
4655 : {
4656 0 : GEN arc = gel(V,j);
4657 0 : if (!signe(gcoeff(arc,2,1)))
4658 0 : r1 = gdiv(gcoeff(arc,1,2), gcoeff(arc,2,2));
4659 0 : else if (!signe(gcoeff(arc,2,2)))
4660 0 : r2 = gdiv(gcoeff(arc,1,1), gcoeff(arc,2,1));
4661 : }
4662 0 : if (!r1 || !r2) pari_err_BUG("polgon2tex");
4663 0 : str_init(&s, 1); d = fabs(gtodouble(gsub(r1,r2)));
4664 0 : str_printf(&s, "\n\\begin{tikzpicture}[scale=%.2f]\n",
4665 : d? (10 / d): 10);
4666 0 : for (j = 1; j < l; j++)
4667 : {
4668 0 : GEN arc = gel(V,j);
4669 0 : if (itos(gcoeff(arc,2,1)))
4670 : {
4671 0 : GEN a = gdiv(gcoeff(arc,1,1), gcoeff(arc,2,1));
4672 0 : double aa = gtodouble(a);
4673 0 : str_printf(&s, "\\draw (%.4f,0) ", aa);
4674 0 : if (flag || j == 2 || j == l-1)
4675 : {
4676 : long n, d;
4677 0 : Qtoss(a, &n, &d);
4678 0 : if (d == 1)
4679 0 : str_printf(&s, "node [below] {$%ld$}\n", n);
4680 : else
4681 0 : str_printf(&s, "node [below] {$\\frac{%ld}{%ld}$}\n", n, d);
4682 : }
4683 0 : if (itos(gcoeff(arc,2,2)))
4684 : {
4685 0 : GEN b = gdiv(gcoeff(arc,1,2),gcoeff(arc,2,2));
4686 0 : str_printf(&s, "arc (%s:%.4f) ", (gcmp(a,b)<0)?"180:0":"0:180",
4687 0 : fabs((gtodouble(b)-aa)/2));
4688 0 : if (flag)
4689 0 : str_printf(&s, "node [midway, above] {%s} ", (char*)gel(v,j));
4690 : }
4691 : else
4692 : {
4693 0 : str_printf(&s, "-- (%.4f,%.4f) ", aa, high);
4694 0 : if (flag)
4695 0 : str_printf(&s, "node [very near end, right] {%s}",(char*)gel(v,j));
4696 : }
4697 : }
4698 : else
4699 : {
4700 0 : GEN b = gdiv(gcoeff(arc,1,2), gcoeff(arc,2,2));
4701 0 : double bb = gtodouble(b);
4702 0 : str_printf(&s, "\\draw (%.4f,%.4f)--(%.4f,0)\n", bb, high, bb);
4703 0 : if (flag)
4704 0 : str_printf(&s,"node [very near start, left] {%s}\n", (char*)gel(v,j));
4705 : }
4706 0 : str_printf(&s,";\n");
4707 0 : if (Ast[j] == j) decorate(&s, gel(G,j), arc, high);
4708 : }
4709 0 : str_printf(&s, "\n\\end{tikzpicture}");
4710 0 : return gerepileuptoleaf(av, strtoGENstr(s.string));
4711 : }
4712 :
4713 : static GEN
4714 0 : circle2tex(GEN Ast, GEN G)
4715 : {
4716 0 : pari_sp av = avma;
4717 0 : GEN v = Ast2v(Ast);
4718 : pari_str s;
4719 0 : long u, n = lg(Ast)-1;
4720 0 : const double ang = 360./n;
4721 :
4722 0 : if (n > 30)
4723 : {
4724 0 : v = const_vec(n, (GEN)"");
4725 0 : gel(v,1) = (GEN)"$(1,\\infty)$";
4726 : }
4727 0 : str_init(&s, 1);
4728 0 : str_puts(&s, "\n\\begingroup\n\
4729 : \\def\\geo#1#2{(#2:1) arc (90+#2:270+#1:{tan((#2-#1)/2)})}\n\
4730 : \\def\\sgeo#1#2{(#2:1) -- (#1:1)}\n\
4731 : \\def\\unarc#1#2#3{({#1 * #3}:1.2) node {#2}}\n\
4732 : \\def\\cell#1#2{({#1 * #2}:0.95) circle(0.05)}\n\
4733 : \\def\\link#1#2#3#4#5{\\unarc{#1}{#2}{#5}\\geo{#1*#5}{#3*#5}\\unarc{#3}{#4}{#5}}\n\
4734 : \\def\\slink#1#2#3#4#5{\\unarc{#1}{#2}{#5}\\sgeo{#1*#5}{#3*#5}\\unarc{#3}{#4}{#5}}");
4735 :
4736 0 : str_puts(&s, "\n\\begin{tikzpicture}[scale=4]\n");
4737 0 : str_puts(&s, "\\draw (0, 0) circle(1);\n");
4738 0 : for (u=1; u <= n; u++)
4739 : {
4740 0 : if (Ast[u] == u)
4741 : {
4742 0 : str_printf(&s,"\\draw\\unarc{%ld}{%s}{%.4f}; \\draw\\cell{%ld}{%.4f};\n",
4743 0 : u, v[u], ang, u, ang);
4744 0 : if (ZM_isscalar(gpowgs(gel(G,u),3), NULL))
4745 0 : str_printf(&s,"\\fill \\cell{%ld}{%.4f};\n", u, ang);
4746 : }
4747 0 : else if(Ast[u] > u)
4748 0 : str_printf(&s, "\\draw \\%slink {%ld}{%s}{%ld}{%s}{%.4f};\n",
4749 0 : (Ast[u] - u)*ang > 179? "s": "", u, v[u], Ast[u], v[Ast[u]], ang);
4750 : }
4751 0 : str_printf(&s, "\\end{tikzpicture}\\endgroup");
4752 0 : return gerepileuptoleaf(av, strtoGENstr(s.string));
4753 : }
4754 :
4755 : GEN
4756 2583 : mspolygon(GEN M, long flag)
4757 : {
4758 2583 : pari_sp av = avma;
4759 : struct siegel T;
4760 2583 : GEN v, msN = NULL, G = NULL;
4761 2583 : if (typ(M) == t_INT)
4762 : {
4763 315 : long N = itos(M);
4764 315 : if (N <= 0) pari_err_DOMAIN("msinit","N", "<=", gen_0,M);
4765 315 : msN = msinit_N(N);
4766 : }
4767 2268 : else if (checkfarey_i(M))
4768 : {
4769 0 : T.V = gel(M,1);
4770 0 : T.Ast = gel(M,2);
4771 0 : G = gel(M,3);
4772 : }
4773 : else
4774 2268 : { checkms(M); msN = get_msN(M); }
4775 2583 : if (flag < 0 || flag > 3) pari_err_FLAG("mspolygon");
4776 2583 : if (!G)
4777 : {
4778 2583 : if (ms_get_N(msN) == 1)
4779 : {
4780 56 : GEN S = mkS();
4781 56 : T.V = mkvec2(matid(2), S);
4782 56 : T.Ast = mkvecsmall2(1,2);
4783 56 : G = mkvec2(S, mkTAU());
4784 : }
4785 : else
4786 : {
4787 : long i, l;
4788 2527 : siegel_init(&T, msN);
4789 2527 : l = lg(T.V);
4790 2527 : if (flag & 1)
4791 : {
4792 301 : long oo2 = 0;
4793 : pari_sp av;
4794 301 : mssiegel(&T);
4795 3451 : for (i = 1; i < l; i++)
4796 : {
4797 3451 : GEN c = gel(T.V, i);
4798 3451 : GEN c22 = gcoeff(c,2,2); if (!signe(c22)) { oo2 = i; break; }
4799 : }
4800 301 : if (!oo2) pari_err_BUG("mspolygon");
4801 301 : av = avma; siegel_perm0(&T, rotate_perm(l, oo2));
4802 301 : set_avma(av);
4803 : }
4804 2527 : G = cgetg(l, t_VEC);
4805 89957 : for (i = 1; i < l; i++) gel(G,i) = get_g(&T, i);
4806 : }
4807 : }
4808 2583 : if (flag & 2)
4809 0 : v = mkvec5(T.V, T.Ast, G, polygon2tex(T.V,T.Ast,G), circle2tex(T.Ast,G));
4810 : else
4811 2583 : v = mkvec3(T.V, T.Ast, G);
4812 2583 : return gerepilecopy(av, v);
4813 : }
4814 :
4815 : #if 0
4816 : static int
4817 : iselliptic(GEN Ast, long i) { return i == Ast[i]; }
4818 : static int
4819 : isparabolic(GEN Ast, long i)
4820 : { long i2 = Ast[i]; return (i2 == i+1 || i2 == i-1); }
4821 : #endif
4822 :
4823 : /* M from msinit, F QM maximal rank */
4824 : GEN
4825 2219 : mslattice(GEN M, GEN F)
4826 : {
4827 2219 : pari_sp av = avma;
4828 : long i, ivB, j, k, l, lF;
4829 : GEN D, U, G, A, vB, m, d;
4830 :
4831 2219 : checkms(M);
4832 2219 : if (!F) F = gel(mscuspidal(M, 0), 1);
4833 : else
4834 : {
4835 2191 : if (is_Qevproj(F)) F = gel(F,1);
4836 2191 : if (typ(F) != t_MAT) pari_err_TYPE("mslattice",F);
4837 : }
4838 2219 : lF = lg(F); if (lF == 1) return cgetg(1, t_MAT);
4839 2219 : D = mspolygon(M,0);
4840 2219 : k = msk_get_weight(M);
4841 2219 : F = vec_Q_primpart(F);
4842 2219 : if (typ(F)!=t_MAT || !RgM_is_ZM(F)) pari_err_TYPE("mslattice",F);
4843 2219 : G = gel(D,3); l = lg(G);
4844 2219 : A = gel(D,2);
4845 2219 : vB = cgetg(l, t_COL);
4846 2219 : d = mkcol2(gen_0,gen_1);
4847 2219 : m = mkmat2(d, d);
4848 84595 : for (i = ivB = 1; i < l; i++)
4849 : {
4850 82376 : GEN B, vb, g = gel(G,i);
4851 82376 : if (A[i] < i) continue;
4852 41804 : gel(m,2) = SL2_inv2(g);
4853 41804 : vb = mseval(M, F, m);
4854 41804 : if (k == 2) B = vb;
4855 : else
4856 : {
4857 : long lB;
4858 147 : B = RgXV_to_RgM(vb, k-1);
4859 : /* add coboundaries */
4860 147 : B = shallowconcat(B, RgM_Rg_sub_shallow(RgX_act_Gl2Q(g, k), gen_1));
4861 : /* beware: the basis for RgX_act_Gl2Q is (X^(k-2),...,Y^(k-2)) */
4862 147 : lB = lg(B);
4863 3444 : for (j = 1; j < lB; j++) gel(B,j) = vecreverse(gel(B,j));
4864 : }
4865 41804 : gel(vB, ivB++) = B;
4866 : }
4867 2219 : setlg(vB, ivB);
4868 2219 : vB = shallowmatconcat(vB);
4869 2219 : if (ZM_equal0(vB)) return gerepilecopy(av, F);
4870 :
4871 2219 : (void)QM_ImQ_hnfall(vB, &U, 0);
4872 2219 : if (k > 2) U = rowslice(U, 1, lgcols(U)-k); /* remove coboundary part */
4873 2219 : U = Q_remove_denom(U, &d);
4874 2219 : F = ZM_hnf(ZM_mul(F, U));
4875 2219 : if (d) F = RgM_Rg_div(F, d);
4876 2219 : return gerepileupto(av, F);
4877 : }
4878 :
4879 : /**** Petersson scalar product ****/
4880 : /* TODO:
4881 : * Eisspace: represent functions by coordinates of nonzero entries in matrix */
4882 :
4883 : /* oo -> g^(-1) oo */
4884 : static GEN
4885 6181 : cocycle(GEN g)
4886 6181 : { retmkmat22(gen_1, gcoeff(g,2,2), gen_0, negi(gcoeff(g,2,1))); }
4887 :
4888 : /* CD = binomial_init(k-2); return <P,Q> * D (integral) */
4889 : static GEN
4890 18151 : bil(GEN P, GEN Q, GEN CD)
4891 : {
4892 18151 : GEN s, C = gel(CD,1);
4893 18151 : long i, n = lg(C)-2; /* k - 2 */
4894 18151 : if (!n) return gmul(P,Q);
4895 18130 : if (typ(P) != t_POL) P = scalarpol_shallow(P,0);
4896 18130 : if (typ(Q) != t_POL) Q = scalarpol_shallow(Q,0);
4897 18130 : s = gen_0;
4898 37282 : for (i = n - degpol(Q); i <= degpol(P); i++)
4899 : {
4900 19152 : GEN t = gmul(gmul(RgX_coeff(P,i), RgX_coeff(Q, n-i)), gel(C,i+1));
4901 19152 : s = odd(i)? gsub(s, t): gadd(s, t);
4902 : }
4903 18130 : return s;
4904 : }
4905 :
4906 : /* Let D = lcm {binomial(n,k), k = 0..n} = lcm([1..n+1]) / (n+1)
4907 : * Return [C, D] where C[i] = D / binomial(n,i+1), i = 0..n */
4908 : static GEN
4909 1379 : binomial_init(long n, GEN vC)
4910 : {
4911 1379 : GEN C = vC? shallowcopy(vC): vecbinomial(n), c = C + 1;
4912 1379 : GEN D = diviuexact(ZV_lcm(identity_ZV(n+1)), n+1);
4913 1379 : long k, d = (n + 1) >> 1;
4914 :
4915 1379 : gel(c,0) = D;
4916 2961 : for (k = 1; k <= d; k++) gel(c, k) = diviiexact(D, gel(c, k));
4917 2961 : for ( ; k <= n; k++) gel(c, k) = gel(c, n-k);
4918 1379 : return mkvec2(C, D);
4919 : }
4920 :
4921 : static void
4922 1351 : mspetersson_i(GEN W, GEN F, GEN G, GEN *pvf, GEN *pvg, GEN *pC)
4923 : {
4924 1351 : GEN WN = get_msN(W), annT2, annT31, section, c, vf, vg;
4925 : long i, n1, n2, n3;
4926 :
4927 1351 : annT2 = msN_get_annT2(WN);
4928 1351 : annT31 = msN_get_annT31(WN);
4929 1351 : section = msN_get_section(WN);
4930 :
4931 1351 : if (ms_get_N(WN) == 1)
4932 : {
4933 7 : vf = cgetg(3, t_VEC);
4934 7 : vg = cgetg(3, t_VEC);
4935 7 : gel(vf,1) = mseval(W, F, gel(section,1));
4936 7 : gel(vf,2) = gneg(gel(vf,1));
4937 7 : n1 = 0;
4938 : }
4939 : else
4940 : {
4941 1344 : GEN singlerel = msN_get_singlerel(WN);
4942 1344 : GEN gen = msN_get_genindex(WN);
4943 1344 : long l = lg(gen);
4944 1344 : vf = cgetg(l, t_VEC);
4945 1344 : vg = cgetg(l, t_VEC); /* generators of Delta ordered as E1,T2,T31 */
4946 7476 : for (i = 1; i < l; i++) gel(vf, i) = mseval(W, F, gel(section,gen[i]));
4947 1344 : n1 = ms_get_nbE1(WN); /* E1 */
4948 7420 : for (i = 1; i <= n1; i++)
4949 : {
4950 6076 : c = cocycle(gcoeff(gel(singlerel,i),2,1));
4951 6076 : gel(vg, i) = mseval(W, G, c);
4952 : }
4953 : }
4954 1351 : n2 = lg(annT2)-1; /* T2 */
4955 1386 : for (i = 1; i <= n2; i++)
4956 : {
4957 35 : c = cocycle(gcoeff(gel(annT2,i), 2,1));
4958 35 : gel(vg, i+n1) = gmul2n(mseval(W, G, c), -1);
4959 : }
4960 1351 : n3 = lg(annT31)-1; /* T31 */
4961 1386 : for (i = 1; i <= n3; i++)
4962 : {
4963 : GEN f;
4964 35 : c = cocycle(gcoeff(gel(annT31,i), 2,1));
4965 35 : f = mseval(W, G, c);
4966 35 : c = cocycle(gcoeff(gel(annT31,i), 3,1));
4967 35 : gel(vg, i+n1+n2) = gdivgu(gadd(f, mseval(W, G, c)), 3);
4968 : }
4969 1351 : *pC = binomial_init(msk_get_weight(W) - 2, NULL);
4970 1351 : *pvf = vf;
4971 1351 : *pvg = vg;
4972 1351 : }
4973 :
4974 : /* Petersson product on Hom_G(Delta_0, V_k) */
4975 : GEN
4976 1351 : mspetersson(GEN W, GEN F, GEN G)
4977 : {
4978 1351 : pari_sp av = avma;
4979 : GEN vf, vg, CD, cf, cg, A;
4980 : long k, l, tG, tF;
4981 1351 : checkms(W);
4982 1351 : if (!F) F = matid(msdim(W));
4983 1351 : if (!G) G = F;
4984 1351 : tF = typ(F);
4985 1351 : tG = typ(G);
4986 1351 : if (tF == t_MAT && tG != t_MAT) pari_err_TYPE("mspetersson",G);
4987 1351 : if (tG == t_MAT && tF != t_MAT) pari_err_TYPE("mspetersson",F);
4988 1351 : mspetersson_i(W, F, G, &vf, &vg, &CD);
4989 1351 : vf = Q_primitive_part(vf, &cf);
4990 1351 : vg = Q_primitive_part(vg, &cg);
4991 1351 : A = div_content(mul_content(cf, cg), gel(CD,2));
4992 1351 : l = lg(vf);
4993 1351 : if (tF != t_MAT)
4994 : { /* <F,G>, two symbols */
4995 1274 : GEN s = gen_0;
4996 7105 : for (k = 1; k < l; k++) s = gadd(s, bil(gel(vf,k), gel(vg,k), CD));
4997 1274 : return gerepileupto(av, gmul(s, A));
4998 : }
4999 77 : else if (F != G)
5000 : { /* <(f_1,...,f_m), (g_1,...,g_n)> */
5001 0 : long iF, iG, lF = lg(F), lG = lg(G);
5002 0 : GEN M = cgetg(lG, t_MAT);
5003 0 : for (iG = 1; iG < lG; iG++)
5004 : {
5005 0 : GEN c = cgetg(lF, t_COL);
5006 0 : gel(M,iG) = c;
5007 0 : for (iF = 1; iF < lF; iF++)
5008 : {
5009 0 : GEN s = gen_0;
5010 0 : for (k = 1; k < l; k++)
5011 0 : s = gadd(s, bil(gmael(vf,k,iF), gmael(vg,k,iG), CD));
5012 0 : gel(c,iF) = s; /* M[iF,iG] = <F[iF], G[iG] > */
5013 : }
5014 : }
5015 0 : return gerepileupto(av, RgM_Rg_mul(M, A));
5016 : }
5017 : else
5018 : { /* <(f_1,...,f_n), (f_1,...,f_n)> */
5019 77 : long iF, iG, n = lg(F)-1;
5020 77 : GEN M = zeromatcopy(n,n);
5021 693 : for (iG = 1; iG <= n; iG++)
5022 3192 : for (iF = iG+1; iF <= n; iF++)
5023 : {
5024 2576 : GEN s = gen_0;
5025 14728 : for (k = 1; k < l; k++)
5026 12152 : s = gadd(s, bil(gmael(vf,k,iF), gmael(vg,k,iG), CD));
5027 2576 : gcoeff(M,iF,iG) = s; /* <F[iF], F[iG] > */
5028 2576 : gcoeff(M,iG,iF) = gneg(s);
5029 : }
5030 77 : return gerepileupto(av, RgM_Rg_mul(M, A));
5031 : }
5032 : }
5033 :
5034 : static GEN
5035 0 : act_ij(GEN v, ulong a, ulong b, ulong c, ulong d, ulong N)
5036 : {
5037 0 : long I, J, i = v[1], j = v[2];
5038 0 : I = Fl_add(Fl_mul(a,i,N), Fl_mul(c,j,N), N); if (!I) I = N;
5039 0 : J = Fl_add(Fl_mul(b,i,N), Fl_mul(d,j,N), N); if (!J) J = N;
5040 0 : return mkvecsmall2(I,J);
5041 : }
5042 : /* action of g in SL_2(Z/NZ) on functions f: (Z/NZ)^2 -> Q given by sparse
5043 : * matrix x. */
5044 : static GEN
5045 168 : actf(long N, GEN x, GEN g)
5046 : {
5047 : long a, b, c, d;
5048 168 : c = umodiu(gcoeff(g,2,1), N); if (!c) return x;
5049 0 : d = umodiu(gcoeff(g,2,2), N);
5050 0 : a = umodiu(gcoeff(g,1,1), N);
5051 0 : b = umodiu(gcoeff(g,1,2), N);
5052 0 : pari_APPLY_same(act_ij(gel(x,i), a, b, c, d, N));
5053 : }
5054 :
5055 : /* q1 = N/a, q2 = q1/d, (u,a) = 1. Gamma_0(N)-orbit attached to [q1,q2,u]
5056 : * in (Z/N)^2; set of [q1 v, q2 w], v in (Z/a)^*, w in Z/a*d,
5057 : * w mod a = u / v [invertible]; w mod d in (Z/d)^*; c1+c2= q2, d2|c1, d1|c2
5058 : * The orbit has cardinal C = a phi(d) <= N */
5059 : static GEN
5060 28 : eisf(long N, long C, long a, long d1, GEN Z2, long c1, long c2,
5061 : long q1, long u)
5062 : {
5063 28 : GEN m = cgetg(C+1, t_VEC);
5064 28 : long v, n = 1, l = lg(Z2);
5065 56 : for (v = 1; v <= a; v++)
5066 28 : if (ugcd(v,a)==1)
5067 : {
5068 28 : long w1 = Fl_div(u, v, a), vq1 = v * q1, i, j;
5069 56 : for (i = 0; i < d1; i++, w1 += a)
5070 : { /* w1 defined mod a*d1, lifts u/v (mod a) */
5071 56 : for (j = 1; j < l; j++)
5072 28 : if (Z2[j])
5073 : {
5074 28 : long wq2 = (c1 * w1 + c2 * j) % N;
5075 28 : if (wq2 <= 0) wq2 += N;
5076 28 : gel(m, n++) = mkvecsmall2(vq1, wq2);
5077 : }
5078 : }
5079 : }
5080 28 : return m;
5081 : }
5082 :
5083 : /* basis for Gamma_0(N)-invariant functions attached to cusps */
5084 : static GEN
5085 28 : eisspace(long N, long k, long s)
5086 : {
5087 28 : GEN v, D, F = factoru(N);
5088 : long l, n, i, j;
5089 28 : D = divisorsu_fact(F); l = lg(D);
5090 28 : n = mfnumcuspsu_fact(F);
5091 28 : v = cgetg((k==2)? n: n+1, t_VEC);
5092 56 : for (i = (k==2)? 2: 1, j = 1; i < l; i++) /* remove d = 1 if k = 2 */
5093 : {
5094 28 : long d = D[i], Nd = D[l-i], a = ugcd(d, Nd), q1, q2, d1, d2, C, c1, c2, u;
5095 : GEN Z2;
5096 :
5097 56 : if (s < 0 && a <= 2) continue;
5098 28 : q1 = N / a;
5099 28 : q2 = q1 / d;
5100 28 : d2 = u_ppo(d/a, a);
5101 28 : d1 = d / d2;
5102 28 : C = eulerphiu(d) * a;
5103 28 : Z2 = coprimes_zv(d2);
5104 : /* d = d1d2, (d2,a) = 1; d1 and a have same prime divisors */
5105 28 : (void)cbezout(d1, d2, &c2, &c1);
5106 28 : c2 *= d1 * q2;
5107 28 : c1 *= d2 * q2;
5108 28 : if (a <= 2)
5109 : { /* sigma.(C cusp attached to [q1,q2,u]) = C */
5110 28 : gel(v, j++) = eisf(N,C,a,d1,Z2,c1,c2, N/a, 1);
5111 28 : continue;
5112 : }
5113 0 : for (u = 1; 2*u < a; u++)
5114 : {
5115 0 : if (ugcd(u,a) != 1) continue;
5116 0 : gel(v, j++) = eisf(N,C,a,d1,Z2,c1,c2, q1, u);
5117 0 : if (!s) gel(v, j++) = eisf(N,C,a,d1,Z2,c1,c2, q1, a-u);
5118 : }
5119 : }
5120 28 : if (s) setlg(v, j);
5121 28 : return v;
5122 : }
5123 :
5124 : /* action of g on V_k */
5125 : static GEN
5126 168 : act(GEN P, GEN g, long k)
5127 : {
5128 168 : GEN a = gcoeff(g,1,1), b = gcoeff(g,1,2), V1, V2, Q;
5129 168 : GEN c = gcoeff(g,2,1), d = gcoeff(g,2,2);
5130 : long i;
5131 168 : if (k == 2) return P;
5132 168 : V1 = RgX_powers(deg1pol_shallow(c, a, 0), k-2); /* V1[i] = (a + c Y)^i */
5133 168 : V2 = RgX_powers(deg1pol_shallow(d, b, 0), k-2); /* V2[j] = (b + d Y)^j */
5134 168 : Q = gmul(RgX_coeff(P,0), gel(V1, k-2));
5135 2520 : for (i = 1; i < k-2; i++)
5136 : {
5137 2352 : GEN v1 = gel(V1, k-2-i);
5138 2352 : GEN v2 = gel(V2, i);
5139 2352 : Q = gadd(Q, gmul(RgX_coeff(P,i), RgX_mul(v1,v2)));
5140 : }
5141 168 : return gadd(Q, gmul(RgX_coeff(P,k-2), gel(V2,k-2)));
5142 : }
5143 :
5144 : static long
5145 420 : co_get_N(GEN co) { return gel(co,1)[1]; }
5146 : static long
5147 504 : co_get_k(GEN co) { return gel(co,1)[2]; }
5148 : static GEN
5149 140 : co_get_B(GEN co) { return gel(co,2); }
5150 : static GEN
5151 112 : co_get_BD(GEN co) { return gel(co,3); }
5152 : static GEN
5153 84 : co_get_C(GEN co) { return gel(co,4); }
5154 :
5155 : /* N g^(-1) . eval on g([0,a]_oo)=g([pi_oo(0),pi_oo(a)]), fg = f|g */
5156 : static GEN
5157 252 : evalcap(GEN co, GEN fg, GEN a)
5158 : {
5159 252 : long n, t, l = lg(fg), N = co_get_N(co), k = co_get_k(co);
5160 : GEN P, B, z, T;
5161 : pari_sp av;
5162 252 : if (isintzero(a)) return gen_0;
5163 : /* (a+y)^(k-1) - y^(k-1) */
5164 56 : P = gsub(gpowgs(deg1pol_shallow(gen_1, a, 0), k-1), pol_xn(k-1, 0));
5165 56 : B = co_get_B(co); z = gen_0;
5166 56 : av = avma; T = zero_zv(N);
5167 112 : for (n = 1; n < l; n++)
5168 : {
5169 56 : GEN v = gel(fg, n);
5170 56 : t = v[1]; T[t]++;
5171 : }
5172 112 : for (t = 1; t <= N; t++)
5173 : {
5174 56 : long c = T[t];
5175 56 : if (c)
5176 : {
5177 56 : GEN u = gmael(B, k, t);
5178 56 : if (c != 1) u = gmulsg(c, u);
5179 56 : z = gadd(z, u);
5180 : }
5181 : }
5182 56 : if (co_get_BD(co)) z = gmul(co_get_BD(co),z);
5183 56 : z = gerepileupto(av, gdivgs(z, -k * (k-1)));
5184 56 : return RgX_Rg_mul(P, z);
5185 : };
5186 :
5187 : /* eval N g^(-1) * Psi(f) on g{oo,0}, fg = f|g */
5188 : static GEN
5189 84 : evalcup(GEN co, GEN fg)
5190 : {
5191 84 : long j, n, k = co_get_k(co), l = lg(fg);
5192 84 : GEN B = co_get_B(co), C = co_get_C(co), P = cgetg(k+1, t_POL);
5193 84 : P[1] = evalvarn(0);
5194 1428 : for (j = 2; j <= k; j++) gel(P,j) = gen_0;
5195 168 : for (n = 1; n < l; n++)
5196 : {
5197 84 : GEN v = gel(fg,n);
5198 84 : long t = v[1], s = v[2];
5199 1428 : for (j = 1; j < k; j++)
5200 : {
5201 1344 : long j1 = k-j;
5202 1344 : GEN u = gmael(B, j1, t);
5203 1344 : GEN v = gmael(B, j, s);
5204 1344 : gel(P, j1+1) = gadd(gel(P, j1+1), gmul(u,v));
5205 : }
5206 : }
5207 1428 : for (j = 1; j < k; j++) gel(P, j+1) = gmul(gel(C,j), gel(P, j+1));
5208 84 : return normalizepol(P);
5209 : }
5210 :
5211 : /* Manin-Stevens algorithm, prepare for [pi_0(oo),pi_r(oo)] */
5212 : static GEN
5213 84 : evalmanin(GEN r)
5214 : {
5215 84 : GEN fr = gboundcf(r, 0), pq, V;
5216 84 : long j, n = lg(fr)-1; /* > 0 */
5217 84 : V = cgetg(n+2, t_VEC);
5218 84 : gel(V,1) = gel(fr,1); /* a_0; tau_{-1} = id */
5219 84 : if (n == 1)
5220 : { /* r integer, can happen iff N = 1 */
5221 84 : gel(V,2) = mkvec2(gen_0, mkmat22(negi(r), gen_1, gen_m1, gen_0));
5222 84 : return V;
5223 : }
5224 0 : pq = contfracpnqn(fr,n-1);
5225 0 : fr = vec_append(fr, gdiv(negi(gcoeff(pq,2,n-1)), gcoeff(pq,2,n)));
5226 0 : for (j = 0; j < n; j++)
5227 : {
5228 0 : GEN v1 = gel(pq, j+1), v2 = (j == 0)? col_ei(2,1): gel(pq, j);
5229 0 : GEN z = gel(fr,j+2);
5230 0 : if (!odd(j)) { v1 = ZC_neg(v1); z = gneg(z); }
5231 0 : gel(V,j+2) = mkvec2(z, mkmat2(v1,v2)); /* [a_{j+1}, tau_j] */
5232 : }
5233 0 : return V;
5234 : }
5235 :
5236 : /* evaluate N * Psi(f) on
5237 : g[pi_oo(0),pi_r(oo)]=g[pi_oo(0),pi_0(oo)] + g[pi_0(oo),pi_r(oo)] */
5238 : static GEN
5239 84 : evalhull(GEN co, GEN f, GEN r)
5240 : {
5241 84 : GEN V = evalmanin(r), res = evalcap(co,f,gel(V,1));
5242 84 : long j, l = lg(V), N = co_get_N(co);
5243 168 : for (j = 2; j < l; j++)
5244 : {
5245 84 : GEN v = gel(V,j), t = gel(v,2); /* in SL_2(Z) */
5246 84 : GEN ft = actf(N, f, t), a = gel(v,1); /* in Q */
5247 : /* t([pi_0(oo),pi_oo(a)]) */
5248 84 : res = gsub(res, act(gsub(evalcup(co,ft), evalcap(co,ft,a)), t, co_get_k(co)));
5249 : }
5250 84 : return res;
5251 : };
5252 :
5253 : /* evaluate N * cocycle at g in Gamma_0(N), f Gamma_0(N)-invariant */
5254 : static GEN
5255 84 : eiscocycle(GEN co, GEN f, GEN g)
5256 : {
5257 84 : pari_sp av = avma;
5258 84 : GEN a = gcoeff(g,1,1), b = gcoeff(g,1,2);
5259 84 : GEN c = gcoeff(g,2,1), d = gcoeff(g,2,2), P;
5260 84 : long N = co_get_N(co);
5261 84 : if (!signe(c))
5262 0 : P = evalcap(co,f, gdiv(negi(b),a));
5263 : else
5264 : {
5265 84 : GEN gi = SL2_inv_shallow(g);
5266 84 : P = gsub(evalhull(co, f, gdiv(negi(d),c)),
5267 : act(evalcap(co, actf(N,f,gi), gdiv(a,c)), gi, co_get_k(co)));
5268 : }
5269 84 : return gerepileupto(av, P);
5270 : }
5271 :
5272 : static GEN
5273 28 : eisCocycle(GEN co, GEN D, GEN f)
5274 : {
5275 28 : GEN V = gel(D,1), Ast = gel(D,2), G = gel(D,3);
5276 28 : long i, j, n = lg(G)-1;
5277 28 : GEN VG = cgetg(n+1, t_VEC);
5278 84 : for (i = j = 1; i <= n; i++)
5279 : {
5280 56 : GEN c, g, d, s = gel(V,i);
5281 56 : if (i > Ast[i]) continue;
5282 56 : g = SL2_inv_shallow(gel(G,i));
5283 56 : c = eiscocycle(co,f,g);
5284 56 : if (i < Ast[i]) /* non elliptic */
5285 0 : d = gen_1;
5286 : else
5287 : { /* i = Ast[i] */
5288 56 : GEN g2 = ZM2_sqr(g);
5289 56 : if (ZM_isdiagonal(g2)) d = gen_2; /* \pm Id */
5290 : else
5291 : {
5292 28 : c = gadd(c, eiscocycle(co,f,g2));
5293 28 : d = utoipos(3);
5294 : }
5295 : }
5296 56 : gel(VG, j++) = mkvec3(d, s, c);
5297 : }
5298 28 : setlg(VG, j); return VG;
5299 : };
5300 :
5301 : /* F=modular symbol, Eis = cocycle attached to f invariant function
5302 : * by Gamma_0(N); CD = binomial_init(k-2) */
5303 : static GEN
5304 84 : eispetersson(GEN M, GEN F, GEN Eis, GEN CD)
5305 : {
5306 84 : pari_sp av = avma;
5307 84 : long i, l = lg(Eis);
5308 84 : GEN res = gen_0;
5309 252 : for (i = 1; i < l; i++)
5310 : {
5311 168 : GEN e = gel(Eis,i), Q = mseval(M, F, gel(e,2)), z = bil(gel(e,3), Q, CD);
5312 168 : long d = itou(gel(e,1));
5313 168 : res = gadd(res, d == 1? z: gdivgu(z,d));
5314 : }
5315 84 : return gerepileupto(av, gdiv(simplify_shallow(res), gel(CD,2)));
5316 : };
5317 :
5318 : /*vB[j][i] = {i/N} */
5319 : static GEN
5320 28 : get_bern(long N, long k)
5321 : {
5322 28 : GEN vB = cgetg(k+1, t_VEC), gN = utoipos(N);
5323 : long i, j; /* no need for j = 0 */
5324 504 : for (j = 1; j <= k; j++)
5325 : {
5326 476 : GEN c, B = RgX_rescale(bernpol(j, 0), gN);
5327 476 : gel(vB, j) = c = cgetg(N+1, t_VEC);
5328 476 : for (i = 1; i < N; i++) gel(c,i) = poleval(B, utoipos(i));
5329 476 : gel(c,N) = gel(B,2); /* B(0) */
5330 : }
5331 28 : return vB;
5332 : }
5333 : GEN
5334 28 : eisker_worker(GEN Ei, GEN M, GEN D, GEN co, GEN CD)
5335 : {
5336 28 : pari_sp av = avma;
5337 28 : long j, n = msdim(M), s = msk_get_sign(M);
5338 28 : GEN V, Eis = eisCocycle(co, D, Ei), v = cgetg(n+1, t_VEC);
5339 :
5340 28 : V = s? gel(msk_get_starproj(M), 1): matid(n);
5341 : /* T is multiplied by N * BD^2: same Ker */
5342 112 : for (j = 1; j <= n; j++) gel(v,j) = eispetersson(M, gel(V,j), Eis, CD);
5343 28 : return gerepileupto(av, v);
5344 : }
5345 : /* vC = vecbinomial(k-2); vC[j] = binom(k-2,j-1) = vC[k-j], j = 1..k-1, k even.
5346 : * C[k-j+1] = (-1)^(j-1) binom(k-2, j-1) / (j(k-j)) = C[j+1] */
5347 : static GEN
5348 28 : get_C(GEN vC, long k)
5349 : {
5350 28 : GEN C = cgetg(k, t_VEC);
5351 28 : long j, k2 = k/2;
5352 266 : for (j = 1; j <= k2; j++)
5353 : {
5354 238 : GEN c = gel(vC, j);
5355 238 : if (!odd(j)) c = negi(c);
5356 238 : gel(C,k-j) = gel(C, j) = gdivgu(c, j*(k-j));
5357 : }
5358 28 : return C;
5359 : }
5360 : static GEN
5361 28 : eisker(GEN M)
5362 : {
5363 28 : long N = ms_get_N(M), k = msk_get_weight(M), s = msk_get_sign(M);
5364 28 : GEN worker, vC, co, CD, D, B, BD, T, E = eisspace(N, k, s);
5365 28 : long i, j, m = lg(E)-1, n = msdim(M), pending = 0;
5366 : struct pari_mt pt;
5367 :
5368 28 : if (m == 0) return matid(n);
5369 28 : vC = vecbinomial(k-2);
5370 28 : T = zeromatcopy(m, n);
5371 28 : D = mspolygon(M, 0);
5372 28 : B = Q_remove_denom(get_bern(N,k), &BD);
5373 28 : co = mkvec4(mkvecsmall2(N,k), B, BD, get_C(vC, k));
5374 28 : CD = binomial_init(k-2, vC);
5375 28 : worker = snm_closure(is_entry("_eisker_worker"), mkvec4(M, D, co, CD));
5376 28 : mt_queue_start_lim(&pt, worker, m);
5377 56 : for (i = 1; i <= m || pending; i++)
5378 : {
5379 : long workid;
5380 : GEN done;
5381 28 : mt_queue_submit(&pt, i, i<=m? mkvec(gel(E,i)): NULL);
5382 28 : done = mt_queue_get(&pt, &workid, &pending);
5383 112 : if (done) for (j = 1; j <= n; j++) gcoeff(T,workid,j) = gel(done,j);
5384 : }
5385 28 : mt_queue_end(&pt); return QM_ker(T);
5386 : }
|
