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