read AllPrograms: MinPolyOverQ := proc(a,x) sqrfree(evala(Norm(x-a)),x)[2][1][1] end: read "AppendData.m": if lasterror[1..14] = "could not open" then lprint("Computing invariants with the file ComputeInvariants..."); read ComputeInvariants; # = www.math.fsu.edu/~hoeij/FiveSing/ComputeInvariants lprint("The invariants are saved in AppendData.m and need not be computed again.") fi: # Check if two polynomials in Q[x] are the same up to a constant SamePolynomialOverQ := proc(f, g, x) if lcoeff(f,x)=lcoeff(g,x) then evalb(f=g) elif degree(f,x)<>degree(g,x) then false else evalb(lcoeff(f,x)*g - lcoeff(g,x)*f = 0) fi end: # The following algorithm takes a degree 4 or 5 polynomial P as # input, representing 5 points S = {q1..q5} in P^1, where S contains # the roots of P, as well as infinity if degree(P)=4. # It also takes as input a field k, given by a set BaseField. # It returns a list of all f in k(x) whose (infinity,2,3)-exceptional points are S. # This version covers only (infinity,2,3). The implementation for Section 8 covers (infinity,2,m) with m in {3,4,6}. FindF := proc(P, x, BaseField::set) local R, A, i5, i5tilde, MP_i5, i, j, f, s_value, CandF; global count5Belyi, count5B1; if not member(degree(P,x),{4,5}) then error "Degree P should be 4 or 5" elif nargs = 2 then return procname(args, indets([args], {RootOf, radical, nonreal})) elif indets(BaseField, {radical, nonreal}) <> {} then # Rewrite input in terms of RootOfs only: R := radfield(BaseField); return evala( eval(procname(eval(P,R[1]), x, R[3]), R[2]) ) fi; # lprint("Enter at time", time()); # Step 1: Find Belyi-(2) maps (if any) and five point invariants of P. A := FindBelyi2(P, x, BaseField); i5 := I5(P,x); i5tilde := I5tilde(P,x); MP_i5 := MinPolyOverQ(i5, x); # lprint("Step 1 finished at time", time()); # Step 2: Find Belyi maps: CandF := {}; for i in count5Belyi[infinity,2,3] do if SamePolynomialOverQ(i[4], MP_i5, x) then if not has(i[1], RootOf) then CandF := CandF union {i} else # i = [Belyi map f, its Five Point Polynomial, I5, minpoly of I5, Number of automorphisms of f] R := op(indets(i[1],RootOf)); # R is the RootOf in the f from the table, we have to rewrite R in terms of BaseField RootOfs: for j in roots(MinPolyOverQ(R,x), BaseField) do if evala(eval(i[3], R=j[1]) - i5) = 0 then CandF := CandF union {[op(evala(eval(i[1..2], R=j[1]))), i[-1]]} fi od fi fi od; A := A union {seq(seq(SimpF(eval(i[1], x=j),i[-1]), j = MobiusTR5(i[2], P, i[-1], BaseField)), i=CandF)}; # lprint("Step 2 finished at time", time()); # Step 3: Find Belyi-(1) maps: for i in count5B1[infinity,2,3] do for s_value in SolveOverK({gcd(numer(i5 - i[3]), numer(i5tilde - i[4]))}, {s}, BaseField) do f := traperror( evala(eval(i[1], s_value))); # traperror catches division by 0 if f <> lasterror and DegF(f,x) = DegF(i[1],x) then A := A union {seq(SimpF(eval(f, x=j),i[-1]), j=MobiusTR5(eval(i[2], s_value), P, i[-1], BaseField))} fi od od; # lprint("Step 3 finished at time", time()); A end: SimpF := proc(f,n) factor(`if`(n=1,evala(f),evala(Normal(f,expanded)))) end: # Program to compute Mobius transformations between two sets of 5 points, represented by FivePointPolynomials. # The Mobius transformation may be defined over an extension of BaseField of degree | n. # This extension is cyclic when n = 1, 2, 3, or 4, and is a Gal \subseteq S3 extension when n = 6. MobiusTR5 := proc(P, Q, n, BaseField::set) local A, a, i, Q1, Mbs; global x; if {degree(P,x), degree(Q,x)} minus {4,5} <> {} then error "input polynomials must have degree 4 or 5" elif {lcoeff(P,x),lcoeff(Q,x)}<>{1} then return procname(seq(collect(a/lcoeff(a,x),x,evala),a=[P,Q]), n, BaseField) elif n = 1 then return MobiusTR5_over_BaseField(P, Q, BaseField) elif degree(P,x)=5 then error "When Aut(table-entry) is non-trivial, the code assumes infinity to be among its 5 points" fi; Mbs := {}; if degree(Q,x) = 4 then Mbs := MobiusTR5Deg4(P, Q, n, BaseField) fi; A := {seq(`if`(degree(i[1],x)=1 or (degree(i[1],x)=2 and n=6), RootOf(i[1],x), NULL), i=factors(Q, BaseField)[2])}; for a in A do # send a to infinity: Q1 := `if`(degree(Q,x)=4,x,1) * numer(evala(eval(Q, x = 1/x + a))); Q1 := collect(Q1/lcoeff(Q1,x),x,evala); Mbs := Mbs union eval(MobiusTR5Deg4(P, Q1, n, BaseField union {a}), x = 1/(x-a)) od; Mbs end: # Find roots over K SolveOverK1 := proc(f,x,K) [seq(eval(x,i),i=SolveOverK({f},{x},K))] end: MobiusTR5Deg4:= proc(P, Q, n, BaseField) local i, Q2, a; global x; if n=6 then # Reducing 6 -> 3 was done with a quadratic extension in MobiusTR5 return procname(P, Q, 3, BaseField) elif {degree(P,x),degree(Q,x)}<>{4} or {lcoeff(P,x),lcoeff(Q,x)}<>{1} then error "Input is expected to be monic of degree 4" fi; a := coeff(Q,x,3)/4; Q2 := collect(eval(Q, x = x - a),x,evala); if [seq(evalb(coeff(P,x,i)=0),i=0..3)] <> [seq(evalb(coeff(Q2,x,i)=0),i=0..3)] then {} elif n=3 or n=4 then {(coeff(P,x,4-n)/coeff(Q2,x,4-n))^(1/n)*(x + a)} elif n=2 then if coeff(P,x,2)<>0 then i := coeff(P,x,2)/coeff(Q2,x,2); if evala(coeff(P,x,0)/coeff(Q2,x,0)-i^2)<>0 then {} else {i^(1/n)*(x + a)} fi else {seq(i^(1/n)*(x+a), i=SolveOverK1(x^2-coeff(P,x,0)/coeff(Q2,x,0), x, BaseField))} fi else error "n should be 2, 3, 4, or 6" fi end: # This program finds a set of Mobius transformations (a*x+b)/(c*x+d) with a,b,c,d in the BaseField. # These Mobius transformations map the points defined by the 5-point polynomial P to those of Q. # We have the following cases (degrees of irreducible factors) (the point infinity has degree 1). # # Case 1: 5 <----> 5. # Case 2: 4,1 <-----> 4,1. # Case 3: 3,2 <-----> 3,2. # Case 4: 3,1,1 <-----> 3,1,1. # Case 5: 2,2,1 <-----> 2,2,1. # Case 6: 2,1,1,1 <-----> 2,1,1,1. # Case 7: 1,1,1,1,1 <-----> 1,1,1,1,1. # MobiusTR5_over_BaseField := proc(P, Q, BaseField) local i,S1,S2,n2,deg3; global x; S1 := seq(`if`(has(i[1],x), i[1], NULL), i=factors(P,BaseField)[2]); S2 := seq(`if`(has(i[1],x), i[1], NULL), i=factors(Q,BaseField)[2]); if sort(subs(1=NULL,map(degree,[S1],x))) <> sort(subs(1=NULL,map(degree,[S2],x))) then return {} fi; n2 := add(`if`(degree(i,x) = 2, 1, 0), i=[S2]); deg3 := seq(`if`(degree(i,x) > 2, i, NULL), i=[S1,S2]); if deg3 <> NULL then Cases_1234(P,Q,deg3,BaseField) elif n2 = 2 then Case_5(P,Q,{S1},{S2},BaseField) elif n2 = 1 then Case_6(P,Q,{S1},{S2},BaseField) else Case_7(P,Q,{S1},{S2},BaseField) fi end: # Case 1: 5 <------> 5. # Case 2: 4,1 <------> 4,1. # Case 3: 3,2 <------> 3,2. # Case 4: 3,1,1 <------> 3,1,1. # Cases_1234:=proc(f,g, F,G, k::set) local a,b,c,d,m,ms,p,q,eqn,Sol,S; global x; m := a,b,c,d; p := RootOf(G,x); S :={}; for q in SolveOverK1(F, x, k union {p}) do # Now we need (a*p+b)/(c*p+d)=q. eqn := Eqn_mp_is_q(m,p,q); Sol := SolveTools:-Linear( {coeffs(evala(Expand(eqn)),p)}, {a,b,c,d}); ms := traperror(evala(eval((a*x+b)/(c*x+d),Sol))); if ms <> lasterror and has(ms,x) and IsMobiusTr(f,g,ms) then S := S union {ms} fi od; S end: # Case 5: 2,2,1 <-----> 2,2,1. # Case_5:=proc(f,g, S1, S2, k::set) local f_deg2,g_deg2,a,b,c,d,m,p,p1,q,q1,eqn1,eqns,i,Sol,M,ms; global x; f_deg2 := {seq(`if`(degree(i,x)=2, i, NULL), i=S1)}; g_deg2 := {seq(`if`(degree(i,x)=2, i, NULL), i=S2)}; if nops(f_deg2) <> 2 or nops(g_deg2) <> 2 then error "wrong input" fi; p1 := S2 minus g_deg2; if p1 = {} then p1 := infinity else p1 := -evala(coeff(p1[1],x,0)/coeff(p1[1],x,1)); fi; q1 := S1 minus f_deg2; if q1 = {} then q1 := infinity else q1 := -evala(coeff(q1[1],x,0)/coeff(q1[1],x,1)); fi; p := RootOf(g_deg2[1],x); m := a,b,c,d; M := {}; eqn1 := Eqn_mp_is_q(m,p1,q1); for q in SolveOverK1(convert(f_deg2,`*`), x, k union {p}) do eqns := {eqn1, coeffs( evala(Expand(Eqn_mp_is_q(m,p,q))), p)}; Sol := SolveTools:-Linear(eqns, {a,b,c,d}); ms := evala(eval((a*x+b)/(c*x+d), Sol)); if IsMobiusTr(f,g,ms) then M := M union {ms} fi od; M end: # Case 6: 2,1,1,1 <-----> 2,1,1,1. # Case_6:= proc(f,g,S1,S2, k::set) local a,b,c,d,f2,g2,i,m,p,p1,p2,q,q1,M,eqn1,Eqns,Sol,ms; global x; g2 := {seq(`if`(degree(i,x)=2, i, NULL), i=S2)}; f2 := {seq(`if`(degree(i,x)=2, i, NULL), i=S1)}; if nops(g2)*nops(f2) <> 1 then error "Wrong input" fi; p1 := {seq(-evala(coeff(i,x,0)/coeff(i,x,1)),i=S2 minus g2)}; q1 := {seq(-evala(coeff(i,x,0)/coeff(i,x,1)),i=S1 minus f2)}; if nops(p1)=2 then p1 := p1 union {infinity} fi; if nops(q1)=2 then q1 := q1 union {infinity} fi; p := RootOf(g2[1], x); p2 := p1[1]; m := a,b,c,d; M := {}; for q in SolveOverK1(f2[1], x, k union {p}) do eqn1 := coeffs(evala(Expand(Eqn_mp_is_q(m,p,q))),p); for i in q1 do Eqns := {eqn1, Eqn_mp_is_q(m,p2,i)}; Sol := SolveTools:-Linear(Eqns, {a,b,c,d}); ms := evala(eval((a*x+b)/(c*x+d), Sol)); if IsMobiusTr(f,g,ms) then M := M union {ms} fi od od; M end: # Case 7: 1,1,1,1,1 <-----> 1,1,1,1,1. # Case_7 := proc(f,g,S1,S2,k::set) local a,b,c,d,i,i1,j,j1,j2,j3,p1,p2,p3,m,M,P,Q,eqn1,eqn2,eqns,sol,ms; global x; P := {seq(-evala(coeff(i,x,0)/coeff(i,x,1)),i=S2)}; Q := {seq(-evala(coeff(i,x,0)/coeff(i,x,1)),i=S1)}; if nops(P)=4 then P := P union {infinity} fi; if nops(Q)=4 then Q := Q union {infinity} fi; m := a,b,c,d; M := {}; p1,p2,p3 := op(P[1..3]); # Find all Mobius transformations that map p1,p2,p3 to elements of Q. # Then check with IsMobiusTr if it maps all 5 elements of P to elements of Q. for j1 in Q do eqn1 := Eqn_mp_is_q(m,p1,j1); for j2 in Q minus {j1} do eqn2 := Eqn_mp_is_q(m,p2,j2); for j3 in Q minus {j1,j2} do eqns := {eqn1,eqn2, Eqn_mp_is_q(m,p3,j3)}; sol := SolveTools:-Linear(eqns,{a,b,c,d}); ms := evala(eval((a*x+b)/(c*x+d), sol)); if IsMobiusTr(f,g,ms) then M := M union {ms} fi od od od; M end: # This program checks if m sends the 5-point-polynomial f to g. # IsMobiusTr:= proc(f,g,m) global x; not has(evala(denom(m)^5*eval(f,x=m)/g),x) end: # Let m := (a*x+b)/(c*x+d) # This program rewrites the equation: eval(m,x=p) = q # into a linear equation in terms of a,b,c,d: Eqn_mp_is_q := proc(a,b,c,d, p,q) global x; if p = infinity then if q = infinity then c # means c = 0 else a-q*c # means a = q*c fi else if q = infinity then c*p+d else (a*p+b) - (c*p+d)*q fi fi end: