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