# ComputeBelyi - The program for computing (almost regular) Belyi maps. # Raimundas Vidunas and Mark van Hoeij, 2013 # Version 3.1 # Date: March 19, 2013 # The core application is described in the paper # "Belyi functions for hyperbolic hypergeometric-to-Heun transformations" # by Mark van Hoeij and Raimundas Vidunas # Available at http://arxiv.org/abs/1212.3803 # Input interface: # ComputeBelyi:= proc(d, EE, B, x ) # # d is the degree. # # E=[k,l,m] is a list of 3 natural numbers for regular branchings. #:: Preferably, E is in decreasing order; #:: Strongly preferably, 2 must be the last. #:: For unrestricted fibers, use 0 (preferably at the beginning). # # S=[Bk,Bl,Bm] is (generally) a list of 3 branching posterns for #:: the three Belyi fibers. The regular branchings k, l or m #:: may be skipped (are ignored) in the respective fiber. #:: To force an assignment to infinity, multiply #:: its branching order by -1. # # x is the variable # # Options (with default values): # FieldVariable = xi # ConivVariables = [U, V] # # INPUT SIMPLIFICATIONS on S=[Bk,Bl,Bm]: One non-regular #:: branching order in each fiber may be skipped. #:: The last list Bm may be skipped; #:: after that the 2nd list Bl may be skipped as well. #:: The first list Bk can be written as a sequence of numbers #:: rather than a list. (Generally, a non-empty list Bk, Bl or Bm #:: may be turned into a sequence of its lelements #:: if neighboring list arguments are still lists or absent. # # THE OUTPUT is a list [G_j] of Galois orbits. # Each G_j is a list, where the first element # gives a rational function in x. # If the second element is a list, then # the moduli field is not a realization field. # The second element then is [ C, U, V, SX ] # where C is the obstruction conic, # U, V are the variables of C, and # SX is the substitution oif x in terms of U, V. # If the left-side of SX is a degree 2 function in x, # the Galois orbit has no Galois cocycle. # The remaining elements of G_j gives a sequence of field # extensions leading to the realization field. # # WARNING MESSAGES: If an interesting warning message comes up, # you may email your example to rvidunas@gmail.com # Extra information about intermediate computations # can be obtained by increasing FieldVariable infolevel[ComputeBelyi] # from 0 to 5 (or less). # ##################################################################### with(Groebner): ##################################################################### CGenPolyN := -1: # Setting up the coefficient numbering FiberStr:= ["in the 1st fiber","in the 2nd fiber","in the 3rd fiber"]: SortFiberPolys:= proc(A,B) # for sorting polynomial orbits if A[1]<>B[1] then evalb(A[1]B[2] then evalb(A[2]>B[2]) elif A[4]<>B[4] then evalb(A[4]>B[4]) else evalb(A[3]>B[3]) fi end: ##################################################################### # CGeneralPoly - Defines a generic polynomial of given degree # Output: A generic monic polynomial in x of degree d, # and a list of its coefficients starting from a[CGenPolyN+1]; # Adjusts CGenPolyN for the next input # Optional parameter: the leading coefficient CGeneralPoly:= proc( d, a, x, lc:=1 ) global CGenPolyN; # asumed initial value is -1 local i, F, k:= CGenPolyN; CGenPolyN:= k+d; F:= lc*x^d+add(a[k+i]*x^(d-i),i=1..d); if k<0 then F:= subs(a[k+1]=0,F) fi; # a[0]=0, affine shift simplification if k=0 and d=1 then x-1 # output with x=1 elif d<0 then 0 else F fi; end: # Dehomogenizes a weighted-homogeneous bivariate polynomial; # the polynomial must irreducible or with both extreme terms BelyiCompDehomogenize:= proc(F,t) local p, q, EQ, V:= convert(indets(F),list); igcdex(degree(F,V[1]),degree(F,V[2]),'p','q'); p:= abs(p); q:= abs(q); EQ:= expand(subs(V[1]=t^p,V[2]=t^q,F)); EQ:= normal(EQ/t^ldegree(EQ,t)); EQ,V[1]-t^p,V[2]-t^q; end: # shall we assume here N positive? BelyiCompSquareRoot:= proc(N) local k:= sqrt(abs(N)); if type(k,sqrt) then [ op(1,k), 1 ] # elif type(k,rational) then [ -1, k ] else [ sign(N)*op(1,select(type,k,sqrt)), remove(type,k,sqrt) ] fi end: # A special "height" for sorting rational integers BelyiCompRatHeight:= proc(N) if type(N,integer) then N else 1/N fi end: # Simplifies a polynomial or rational expression # by the simplest transformations x -> const * x, # by integer const (in future: in quadratic Euclidean domains # We use this for 2 purposes: to simplify number field polynomials # (with integer leading coefficient) and for simplifying Belyi maps # (then H must be given, a polynomial involved in the rational Belyi map). # In our application, the purposes would be mixed up only when # simplifying a Belyi map that is a monic power-free polynomial. BelyiCompMultSimplify:= proc(F,x,H:=F) local FF, G, NormPP, N, M, le, K:= 1, d:=degree(H,x); if F=H then NormPP:= primpart else NormPP:= normal fi; N:= ifactor(lcoeff(H,x),easyfunc); M:= ifactor(icontent(subs(x=0,H)),easyfunc); N:= select(T->type(T,`^`) and 2*op(2,T)>=d, convert(N,list)); M:= select(T->type(T,`^`) and 2*op(2,T)>=d, convert(M,list)); M:= [op(map(T->1/op(op(1,T)),N)),op(map(T->op(op(1,T)),M))]; M:= sort(M,(a,b)->BelyiCompRatHeight(a)>BelyiCompRatHeight(b)); FF:= NormPP(F); le:= length(FF); for N in M do do G:= NormPP(subs(x=N*x,FF)); if length(G)>le then break; else FF:= G; le:= length(G); K:= K*N fi; od; od; [ FF, K ] end: # Sets up a field extension # F is an ireducible polynomial in ev # Return a "simple" field polynomial in fv, and elimination for ev BelyiCompFieldExtension:= proc(F,ev,fv) local FF, G, L, N, C, d:= degree(F,ev); # if d=1 then exit fi; if d=2 then N:= evala(discrim(F,ev)); C:= icontent(N); N:= N/C; C:= BelyiCompSquareRoot(C); G:= fv^2-N*C[1]; return [ G, 2*lcoeff(F,ev)*ev+coeff(F,ev)-C[2]*RootOf(G) ] elif d=3 then # D = -3*discrim(P,x); # E = 1/2*(2*coeff(P,x,2)^3-9*lcoeff(P,x)*coeff(P,x,2)*coeff(P,x) # +27*lcoeff(P,x)^2*subs(x=0,P)+3*lcoeff(P,x)*sqrt(D) # a+b*sqrt(d) ===> x^3-3*sqrt[3](a^2-b^2*d)*x-2*a elif d=4 then fi; FF:= BelyiCompMultSimplify(F,ev); if type(FF[1],polynom(rational)) and d<=nops(BelyiCompFExtensions) then ## this check may go higher for G in BelyiCompFExtensions[d] do L:= roots(FF[1],RootOf(G)); if L<>[] then userinfo(3,ComputeBelyi,"Data base number field used, degree",d); return [ subs(_Z=fv,G), ev-FF[2]*L[1][1] ] fi od; fi; userinfo(3,ComputeBelyi,"Unknown large number field encountered, degree",d); userinfo(4,ComputeBelyi,"The field polynomial has length",length(FF[1])); userinfo(4,ComputeBelyi, FF[1]); userinfo(3,ComputeBelyi, "You may interrupt the computation and append a better field poly"); [ subs(ev=fv,FF[1]), ev-FF[2]*RootOf(FF[1]) ] end: # Transforms equations EQ into Field Extensions # Output: [ Extra field extensions from the equations, linear equations ] BelyiCompEq2Ext:= proc(EQ, ext) local Q, V, SF, L:=[], Ext:=ext; for Q in EQ do Q:= subs(L, Q); V:= indets(Q); if nops(V)>1 then userinfo(4,ComputeBelyi,"A family of degenerate solutions discarded",op(EQ)); return [] elif degree(Q)=1 then L:= [op(L), op(V)=solve(Q)] else SF:= BelyiCompFieldExtension(Q,op(V),Ext[1][nops(Ext)]); Ext:= [op(Ext),SF[1]]; L:= [op(L), op(V)=solve(SF[2])] fi od; [ Ext, L ] end: ##################################################################### # ComputeBelyi - The routine to compute a Belyi map # using Fuchsian equations # d is the degree. # E=[k,l,m] is 3 natural numbers for local exp. differences; #:: Preferably, E is in decreasing order; #:: Strongly preferably, 2 must be the last. #:: For unrestricted fibers, use 0 (preferably at the beginning). # S is (generally) a list of 3 lists of branching numbers #:: in the three fibers. The "nonsingular" branching numbers #:: k, l or m may be skipped (are ignored) in the respective fiber. #:: To force an assignment to infinity, use a negative number #:: for its branching number. # INPUT SIMPLIFICATIONS: One "singular" branching number #:: in each fiber may be skipped as well. #:: The later (of the three) lists may be skipped. #:: A non-empty list argument may be turned into a sequence #:: if neighboring list arguments are still lists or absent. # x is the variable. ComputeBelyi:= proc(d, EE, B, x, {FieldVariable::name:=xi, ConicVariables::[name,name]:=[U,V]} ) global CGenPolyN; local E:=EE, f, fa, fb, k, kk, ke, L, LL, dd, JM, FB, # [ multipl. degree, branching order, fiber no, fiber branching ] edf:= [0,0], # [ infinity fiber, branching order ]; inf:=false, SL, SF, EQ, EQ1, EX, V, a, q, t, Co, in0, in1, es, ns, cc, T0:=time(), P:=Array(1..3), # Irred main ramification polynomials Q:=Array(1..3), # Powered singularity polynomials R:=Array(1..3), # Fully powered ramification polynomials R1:=Array(1..3), # Reduced power(ed) ramification polynomials # V:=Array(1..5, fill=[]), # The coefficient variables QQ, # The auxiliary polynomial, with the coeffs list Ext, S, # Product of singularity polynomials in power 1 Exto:=proc() if Ext=[] then xi else RootOf(Ext[1]) fi end, GB, VV, TO, So, Su, Zu, Sc, c; # Input check if not type(d,integer) or d<1 then error "wrong degree", d elif not type(E,[integer$3]) and min(E)<0 then error "wrong basic local exponent differences" elif member(1,E,'k') then L:= subsop(k=NULL,E); if member(0,L,'k') then L:= subsop(k=NULL,E); E:= subs(0=L[1],E) elif L[1]<>L[2] then error "logarithmic hypergeometric equation indicated" fi; elif not type(x,name) then error "wrong variable name" fi: ## Now we decode the branching information k:= 1; FB:= []; for f to 3 do if k>nops(B) then L:= [] else L:= B[k] fi; if not type(L,list) then kk:= k; while k[] then if edf[1]<>0 or nops(LL)>1 then error "multiple assignment to the infinity %1", FiberStr[f] fi; L:= subs(LL[1]=NULL,L); edf:= [f,-LL[1]]; # FB virtually increased by [1,-LL[1],f] dd:= dd+LL[1] fi; if not type(L,list(positive)) then error "ramification order cannot be zero %1", FiberStr[f] fi; L:= subs(E[f]=NULL,L); dd:= dd-convert(L,`+`); if dd<0 then error "the sum of branching orders exceeds the degree %1", FiberStr[f] fi; if E[f]=0 then kk:= dd; ke:= 0 else kk:= dd mod E[f]; ke:= (dd-kk)/E[f] fi; if kk<>0 then L:= [op(L),kk] fi; if ke<>0 then FB:= [op(FB),[ke,E[f],f,E[f]]] fi; L:= sort(L); kk:= 1; while kk<=nops(L) do ke:= kk; kk:= kk+1; while kk<=nops(L) and L[kk]=L[ke] do kk:= kk+1 od; FB:= [op(FB),[kk-ke,L[ke],f,E[f]]] od; k:= k+1; od; ## FB is now the list of [ multiplicity degree, branch order, fiber no ] ## adjust FB with the infinite fiber kk:= convert(map2(op,1,FB),`+`); if edf[1]<>0 then kk:= kk+1 fi; if kk<>d+2 then error "not a Belyi map from P1 requested, %1 points in the 3 fibers instead of %2", kk, d+2 fi; FB:= sort(FB,SortFiberPolys); if edf[1]=0 then edf:= [ FB[1][3], FB[1][2] ]; if FB[1][1]=1 then FB:= subsop(1=NULL,FB) else ## modf:= true; FB[1][1]:= FB[1][1]-1 fi; fi; ## the list FB of ramification data is settled ## append the list FB with polynomials (but no coefficient list) ## ignore in FB the fiber branching order CGenPolyN:= -1; FB:= map(T->[op(1..3,T),CGeneralPoly(T[1],a,x)],FB); ## sort the fibers ## are z=0 and z=1 assigned? L:= sort(subs(0=infinity,[seq([E[f],f],f=1..3)])); in0:= evalb(FB[1][1]=1); in1:= evalb(FB[2][1]=1); # homogeneous = not in1 printf("The branching pattern is "); S:= 1; es:= 0; ns:= 0; for k to 3 do f:= L[k][2]; LL:= select(T->T[3]=f,FB); SF:= select(T->T[2]=E[f],LL); if SF=[] then P[k]:= 1 else P[k]:= SF[1][4] fi; LL:= map(T->if T[2]=E[f] then NULL else T fi, LL); Q[k]:= convert(map(T->T[4]^T[2],LL),`*`); R[k]:= Q[k]*P[k]^E[f]; S:= S*convert(map2(op,4,LL),`*`); ns:= ns+convert(map2(op,1,LL),`+`); if E[f]<>0 then es:= es+convert(map(T->T[1]*T[2],LL),`+`)/E[f] fi; cc:= " "; ## Lprint output if degree(P[k],x)>0 then if degree(P[k],x)>1 then printf("%d*",degree(P[k])) fi; printf("[%d]",E[f]); cc:= "+" fi; if f=edf[1] then if E[f]=edf[2] then printf("%c[%d]",cc,E[f]) else printf("%c%d",cc,edf[2]) fi; ns:= ns+1; cc:= "+" fi; LL:= map(T->T[2]$T[1],LL); while LL<>[] do printf("%c%d",cc,LL[1]); LL:= subsop(1=NULL,LL); cc:= "+" od; if k<3 then printf("=") fi; od; printf(".\n"); ## computing a j-invariant of 4 points if in0 then if in1 then JM:= [ 256*(a[2]^2+a[2]+1)^3/a[2]^2/(a[2]+1)^2, 0 ] elif FB[2][1]=2 then JM:= [ 256*(a[1]^2-3*a[2])^3/a[2]^2/(a[1]^2-4*a[2]), 1, x=a[2]/x ] elif FB[2][1]=3 then JM:= [ 256*(a[1]^2-3*a[2])^3/discrim(FB[2][4],x), a[2], x=a[1]*a[3]/a[2]/x ] elif FB[2][1]=4 then JM:= [ 256*(a[2]^2-3*a[1]*a[3]+12*a[4])^3/discrim(FB[2][4],x), a[3], x=a[1]*a[4]/a[3]/x ] else WARNING("The j-invariant is not assigned.") fi elif FB[1][1]=2 then if FB[2][1]=2 then JM:= [ 64*(3*a[1]*a[2]^2-a[1]^2-14*a[1]*a[3]-a[3]^2)^3 /a[1]/(a[2]^2-4*a[3])*(a[1]*a[2]^2+(a[1]-a[3])^2)^2, 1, x=(a[1]*(x+a[2])-a[3]*x)/(a[2]*x+a[3]-a[1]) ]: elif FB[2][1]=3 then JM:= [ 256*(a[2]^2-3*a[3])^3/discrim(FB[2][4],x), FB[2][4], x=(t*x+B)/(x-t) ] # not clear yet elif FB[2][1]=4 then JM:= [ 256*(a[3]^2-3*a[2]*a[4]+12*a[5])^3/discrim(FB[2][4],x), 1 ] else WARNING("The j-invariant is not assigned.") fi elif FB[1][1]=3 then JM:= [ 1728*a[1]^3/(4*a[1]^3+27*a[2]^2), 1 ] elif FB[1][1]=4 then JM:= [ 256*(a[1]^2+12*a[3])^3/discrim(FB[2][4],x), 1 ] else WARNING("The j-invariant is not assigned.") fi: ## Include the roots of the accessory polynomial??? ## Still a problem when x=infty is forced. ## Setting up the accessory polynomial if edf[1]=0 then kk:= 1; ns:= ns+1; elif E[edf[1]]=0 then ## need to worke out else kk:= edf[2]/E[edf[1]] fi; es:= (ns-es+kk)/2-1; QQ:= CGeneralPoly(ns-3,a,x,es*(es-kk)); userinfo(2,ComputeBelyi,"The number of singularities is",ns); ## Now the real computation starts E:= map(T->E[T[2]],L); userinfo(4,ComputeBelyi,"Fiber polynomials",R[3]); userinfo(4,ComputeBelyi,R[2]); userinfo(4,ComputeBelyi,R[1]); ## Segregate the fiber with infinity kk:= edf[2]; if L[1][2]=edf[1] then f:= 1 elif L[2][2]=edf[1] then f:= 2 else f:= 3; if edf[1]=0 then kk:= 1 fi fi; fa:= 1; if f=1 then fa:=fa+1 fi; fb:= fa+1; if f=fb then fb:=fb+1 fi; ## The logarithmic derivative ansatz SF:= gcd(Q[fa],S); EQ:= E[fb]*diff(P[fb],x)/P[fb]+diff(Q[fb],x)/Q[fb] -E[f]*diff(P[f],x)/P[f]-diff(Q[f],x)/Q[f]; EQ:= normal(P[fb]*P[f]*S/SF*EQ); EQ1:= expand(kk*Q[fa]/SF*P[fa]^(E[fa]-1)-EQ); SF:= gcd(Q[fb],S); EQ:= E[fa]*diff(P[fa],x)/P[fa]+diff(Q[fa],x)/Q[fa] -E[f]*diff(P[f],x)/P[f]-diff(Q[f],x)/Q[f]; EQ:= normal(P[fa]*P[f]*S/SF*EQ); if edf[1]<>0 then es:= kk^2 else kk:= a[0]; es:= kk fi; EX:= expand(kk*Q[fb]/SF*P[fb]^(E[fb]-1)-EQ); ## The transformation of Fuchsian equations EQ:= (1-1/E[fa]-1/E[fb]+1/E[f])* (es*P[fa]^(E[fa]-2)*P[fb]^(E[fb]-2)*Q[fa]*Q[fb]/P[f]^2/S^2 -E[f]^2*diff(P[f],x)^2/P[f]^2-diff(Q[f],x)^2/Q[f]^2) +2*E[f]*diff(P[f],x$2)/P[f]+2*diff(Q[f],x$2)/Q[f] +2*E[f]*(1/E[fa]+1/E[fb])*diff(P[f],x)*diff(Q[f],x)/P[f]/Q[f] +(2*E[f]*diff(P[f],x)/P[f]+2*diff(Q[f],x)/Q[f])* (diff(S,x)/S-diff(Q[f],x)/Q[f]-diff(Q[fa],x)/E[fa]/Q[fa] -diff(Q[fb],x)/E[fb]/Q[fb] ); EQ:= 1/4*(1-1/E[fa]-1/E[fb]-1/E[f])*normal(EQ); if EQ=0 then QQ:= 0 else EQ:= numer(normal(EQ-QQ/S)) fi; EQ1:= [ EQ1, EQ, EX ]; ## Reversing the polynomials for easier coefficient access ## We assume no zero coefficients after the (previously) leading terms, ## so that the weighting would be correct. dd:= max(map(degree,EQ1,x))+1; ## +1 because we multiply by x next line EQ1:= map(T->expand(subs(x=1/x,T)*x*x^degree(T,x)), EQ1); ## Re-sorting polynomials (and their undetermined variables) ## in yet other way, to eliminate largest degree polynomials first LL:= map(T->if type(T,`*`) then op(T) else T fi, convert(Q,list)); LL:= map(T->if type(T,`^`) then op(1,T) else T fi, LL); LL:= map(T->[dd+1,T], LL); LL:= [ [E[1],P[1]], [E[2],P[2]], [E[3],P[3]], op(LL)]; LL:= map(T->[-degree(T[2],x),op(T)], LL); LL:= [ [-degree(QQ,x),0,QQ], op(sort(LL)) ]; LL:= map(T->expand(subs(x=1/x,T[3]*x^T[1])), LL); LL:= remove(T->type(T,rational) or T=1-x, LL); EQ:= []; VV:= []; Su:= []; for k to dd do EX:= subs(Su, map(coeff,EQ1,x,k) ); EX:= remove(T->T=0,expand(EX)); V:= map(coeff,LL,x,k); V:= remove(T->T=0,V); if V=[] then kk:= 0 else kk:= min(nops(EX),nops(V)); So:= solve( {op(EX[1..kk])}, {op(V[1..kk])} ); while So=NULL do userinfo(5,ComputeBelyi,"A rare configuration of equations",k,kk,V,EX); kk:= kk-1; if kk<=0 then print(k,kk,EX,V,EQ,VV,EQ1,LL); WARNING("Unexpected configuration of equations") fi; So:= solve( {op(EX[1..kk])}, {op(V[1..kk])} ); od; SL:= select(T->op(1,T)=op(2,T), So); if SL<>{} then SL:= map2(op,1,SL); V:= [ op(V), op(SL) ]; # print(V,SL); if k<>edf[2] then # We know this dependent equation userinfo(5,ComputeBelyi,"Unexpectedly superflous equations",k,kk,V,EX) fi; fi; fi; if kk`if`(type(T,`^`),[op(1,T)],[T]), EQ); #@ print(EQ); # By-hand factorization is a crude branch splitting # We call Groebner Solve specifically for branch refinement if not in1 then # dehomogenize EX:= Basis([VV[-1]*VV[-2],op(GB)], tdeg(op(VV))); # check the case of visible variables = 0 EX:= Solve(EX,VV); EX:= map2(op,1,convert(EX,list)); # copy a multi-term equation to the beginning EX:= map(T->[remove(type,T,name)[1],op(T)], EX); EQ:= map(op, [remove(type,EQ,[name]), EX]); EQ:= map(T->subsop(1=BelyiCompDehomogenize(T[1],t),T), EQ); VV:= [op(VV),t] fi; userinfo(4,ComputeBelyi,"Preliminary number of solutions",nops(EQ)); SL:= []; for LL in EQ do userinfo(5,ComputeBelyi,"Considering a candidate solution;",time()-T0); Ext:= BelyiCompEq2Ext(LL[1..1], [FieldVariable]); if Ext=[] then next fi; V:= remove(T->T=op(1,Ext[2][1]),VV); LL:= evala( subs(Ext[2],[op(LL),op(GB)]) ); es:= convert(map(degree,Ext[1]),`*`); # print(subs(Exto()=xi,LL)); userinfo(5,ComputeBelyi,"Degree", es, "field extension considered;",time()-T0); LL:= Basis(LL,tdeg(op(V))); LL:= Solve(LL,V); LL:= map2(op,1,convert(LL,list)); if nops(LL)>1 then userinfo(5,ComputeBelyi,"A rare case of splitting solutions",LL); fi; for L in LL do EX:= BelyiCompEq2Ext(L, Ext[1]); if EX=[] then next fi; So:= evala( solve({op(EX[2])},{op(V)}) ); So:= map(op, {Ext[2],So}); So:= convert(evala(expand(subs(So,Su))),set) union So; EX:= EX[1]; es:= convert(map(degree,EX),`*`); #print(subs(Exto()=xi,So)); userinfo(5,ComputeBelyi,"Possible degree",es,"solution constructed;",time()-T0); SF:= evala( subs(So,[P[f],Q[f],P[fb],Q[fb]]) ); SF:= map(collect,SF,x); QQ:= evala( [ Resultant(SF[1],SF[3],x), Resultant(SF[1],SF[4],x), Resultant(SF[2],SF[3],x), Resultant(SF[2],SF[4],x) ] ); if member(0,QQ) then userinfo(5,ComputeBelyi,"Possible solution rejected",time()-T0); else Co:=[]; userinfo(5,ComputeBelyi,"A solution confirmed;",time()-T0); if degree(P[fa],x)=0 then QQ:= Q[fa] elif degree(Q[fa],x)=0 or degree(P[fa],x)degree(T[1])>1,[SF]): if nops(SF)>1 then # We expect a quadratic extension, or by one generator WARNING("Strange extension of the moduli field", SF) fi; kk:= SF[1][2]; SF:= SF[1][1]; EQ1:= Basis( EQ1, plex(V[kk],op(subsop(kk=t,V))) ): if degree(EQ1[-1],V[kk])=1 then WARNING("Lost Field Extension for the conjugation") fi: EX:= BelyiCompEq2Ext(subs(EX[1]=a,EQ1), EX[1..1]); QQ:= factor(subs(Zu,FieldVariable=a,EX[2],QQ)); EX:= EX[1]; Zu:= seq(RootOf(EX[-k])=EX[1][nops(EX)-k],k=1..nops(EX)-1); if degree(EQ1[-1],V[kk])>2 then # Later we allow cyclic conjugations WARNING("We consider only quadratic extra conjugations") elif degree(EX[-1])<>2 then WARNING("Lost quadratic extension", EX) else userinfo(5,ComputeBelyi,"Checking for an obstruction conic",time()-T0); SF:= factor(subs(RootOf(EX[-1])=-RootOf(EX[-1]),x=t,QQ)-QQ); SF:= select(T->degree(T,t)<=2, numer(SF)); SF:= primpart(SF); if type(SF,`*`) then EQ1:= select(T->degree(T,t)=1, SF); if EQ1<>1 then SF:= EQ1 fi; fi: if type(SF,`*`) then SF:= op(1,SF) fi; if type(SF,`^`) then SF:= op(1,SF) fi: if degree(SF,t)=1 then # non-scaling assumed SF:= solve(SF,t); Co:= ConicVariables[1]^2-evala(RootOf(EX[-1])^2)*ConicVariables[2]^2 -evala(subs(solve({denom(SF)},x),numer(SF))/coeff(denom(SF),x)); Co:= [Co, op(ConicVariables), x=ConicVariables[1]+RootOf(EX[-1])*ConicVariables[2] -evala(coeff(numer(SF),x)/coeff(denom(SF),x))]; elif degree(SF,t)>2 then WARNING("The covering has many symmetries", SF) elif degree(SF,t)=2 then EQ1:= factor(subs(x=t,QQ)-QQ); EQ1:= select(T->degree(T,t)=1, numer(EQ1)); EQ1:= normal(EQ1/(t-x)); if degree(EQ1,t)<>1 then WARNING("Inconstintency of Mobius transformations, no cocycle", EQ1) fi; EQ1:= (x+solve(EQ1,t))/2; Co:= resultant(SF,numer(-q+EQ1),x): Co:= select(type,factor(Co),`^`); if not type(Co,`^`) then WARNING("Wrong elimination with no cocycle", Co) fi; Co:= resultant(op(1,Co), numer(-x+subs(x=t,RootOf(EX[-1])=-RootOf(EX[-1]),EQ1)),t): Co:= select(type,factor(Co),`^`); if not type(Co,`^`) then WARNING("Wrong elimination 2 with no cocycle", Co) fi; SF:= solve(op(1,Co),q); Co:= ConicVariables[1]^2-evala(RootOf(EX[-1])^2)*ConicVariables[2]^2 -evala(subs(solve({denom(SF)},x),numer(SF))/coeff(denom(SF),x)); Co:= [Co, op(ConicVariables), factor(EQ1)=ConicVariables[1]+RootOf(EX[-1])*ConicVariables[2] -evala(coeff(numer(SF),x)/coeff(denom(SF),x))]; fi; fi: fi; fi; if nops(EX)=1 then QQ:= [factor(QQ)] elif nops(EX)=2 then QQ:= [op( subs(RootOf(EX[2])=EX[1],[QQ,op(Co)]) ), # May need to simplify this subs(EX[1][1]=EX[1],EX[2]) ]; else QQ:= subs(Zu, [QQ, op(Co), subsop(1=NULL,EX)]) fi; userinfo(2,ComputeBelyi,"Degree ", es, " solution fully constructed; ",time()-T0); SL:= [op(SL),QQ]; fi; od; od; printf("The number of solution orbits is %d.\n", nops(SL)); userinfo(2,ComputeBelyi,"Time",time()-T0); SL end: BelyiCompFExtensions:= [ []$4, [_Z^5-2*_Z^3-4*_Z^2-5*_Z-4, _Z^5-_Z^4-6*_Z^3+10*_Z^2-5*_Z+5, _Z^5-2*_Z^3-4*_Z^2-6*_Z-4, _Z^5-2*_Z^4+2*_Z^3-4*_Z^2+_Z+8, _Z^5-2*_Z^4+2*_Z^2-3*_Z-6, _Z^5-_Z^4-2*_Z^3+5*_Z^2-2*_Z+2, _Z^5-2*_Z^4+2*_Z^3-3*_Z^2+3, _Z^5-_Z^4+2*_Z^3-2*_Z^2-_Z-1, _Z^5-2*_Z^4+2*_Z^3-4*_Z^2-2*_Z-2], [_Z^6-2*_Z^5+5*_Z^2+5, _Z^6-3*_Z^5-6*_Z^4+4*_Z^3+45*_Z^2+27*_Z+4, _Z^6-8*_Z^3+9*_Z^2+18, _Z^6-3*_Z^5+6*_Z^4-3*_Z^3+3*_Z^2-3*_Z+2, _Z^6-2*_Z^5-_Z^4+2*_Z^2+4*_Z+2, _Z^6-_Z^5+7*_Z^4-5*_Z^3+14*_Z^2-2*_Z+6, _Z^6-3*_Z^5+5*_Z^4-5*_Z^3+_Z+2, _Z^6-_Z^5+3*_Z^4-3*_Z^3-2*_Z^2+4*_Z+2, _Z^6+_Z^4-3*_Z^3+6*_Z^2-4*_Z+2, _Z^6-2*_Z^5+3*_Z^4+_Z^2+4*_Z+2, _Z^6-3*_Z^5+9*_Z^4-11*_Z^3+30*_Z^2-18*_Z+46], [_Z^7-_Z^6-2*_Z^4-_Z^3+2*_Z^2+2*_Z+2, _Z^7-2*_Z^6-4*_Z^5-3*_Z^4+5*_Z^3-4*_Z^2+2*_Z-2, _Z^7-_Z^6+_Z^5+5*_Z^4+_Z^3+6*_Z^2+9*_Z+3, _Z^7-_Z^6-_Z^5+5*_Z^4+5*_Z^3-4*_Z^2-6*_Z-2, _Z^7-3*_Z^6+2*_Z^5+6*_Z^4-6*_Z^3-4*_Z^2+4*_Z+4], [_Z^8-2*_Z^7+6*_Z^6-8*_Z^5+18*_Z^4-20*_Z^3+16*_Z^2-20*_Z+10], [_Z^9-_Z^8-4*_Z^6+4*_Z^4+8*_Z^3+8*_Z^2+2*_Z-2, _Z^9-2*_Z^8+13*_Z^7-30*_Z^6+81*_Z^5-118*_Z^4+171*_Z^3-114*_Z^2+70*_Z-8], [_Z^10-4*_Z^9+4*_Z^8+8*_Z^7-12*_Z^6-32*_Z^5+80*_Z^4-16*_Z^3-60*_Z^2+16*_Z+16, _Z^10-3*_Z^9+14*_Z^8-39*_Z^7+110*_Z^6-217*_Z^5+381*_Z^4-478*_Z^3+518*_Z^2-370*_Z+200], [_Z^11-_Z^10-6*_Z^9+11*_Z^8+2*_Z^7-28*_Z^6+26*_Z^5+44*_Z^4-104*_Z^3+112*_Z^2-64*_Z+32], [], [_Z^13-3*_Z^12+8*_Z^11-6*_Z^10+6*_Z^9-8*_Z^8+14*_Z^7+8*_Z^6 +8*_Z^5-6*_Z^4+6*_Z^3+7*_Z^2+7*_Z+14, _Z^13-2*_Z^12-6*_Z^11+2*_Z^10+37*_Z^9-4*_Z^8-50*_Z^7-46*_Z^6 +6*_Z^5+54*_Z^4+70*_Z^3+40*_Z^2+8*_Z-2], [_Z^14-_Z^13-4*_Z^12-3*_Z^11+8*_Z^10+41*_Z^9-30*_Z^8-88*_Z^7 +78*_Z^6+8*_Z^5-8*_Z^4-36*_Z^3+64*_Z^2-4*_Z+4], [_Z^15-5*_Z^14+15*_Z^13-21*_Z^12+19*_Z^11+17*_Z^10-31*_Z^9-3*_Z^8 +411*_Z^7-1027*_Z^6+1661*_Z^5-1515*_Z^4+1137*_Z^3-553*_Z^2+307*_Z-29] ]: