/* VERSION: 3 August 2004. This file contains MAGMA routines that are convenient to have in order to investigate the genus-2 curves discussed in the paper Everett W. Howe: Infinite families of pairs of curves over Q with isomorphic Jacobians, arXiv: math.AG/0304471 If you have questions or comments about the routines in this file, contact me at however@alumni.caltech.edu The functions included in this file are: RichelotDual IsAbsolutelyIrreducible GeneralCurve MightHaveGoodSubgroups HasGoodSubgroups RMWM IsomorphicJacobians SpecialIsomorphicJacobians VERSION: 3 August 2004. In some of the functions, I had been (in effect) writing the Richelot dual as y^2 / d = g1*g2*g3 instead of d*y^2 = g1*g2*g3. Of course, these curves are isomorphic to one another, but this inconsistency led to some problems in parts of the paper where intermediate results were presented. VERSION: 11 May 2003. First version made available on web. */ /* A function to compute Richelot duals. Given three quadratic polynomials g1, g2, g3, the function will return a constant d and three polynomials h1, h2, h3 so that: if d = 0 then the Richelot dual of y^2 = g1*g2*g3 is singular; if d != 0 then the Richelot dual of y^2 = g1*g2*g3 is the curve d*y^2 = h1*h2*h3. */ function RichelotDual(g1,g2,g3) h1 := Derivative(g2)*g3 - g2*Derivative(g3); h2 := Derivative(g3)*g1 - g3*Derivative(g1); h3 := Derivative(g1)*g2 - g1*Derivative(g2); m := Matrix(3,3,Coefficients(g1) cat Coefficients(g2) cat Coefficients(g3)); return [Determinant(m),h1,h2,h3]; end function; /* A function to determine whether the Jacobian of a genus-2 curve y^2 = f is an absolutely simple. The curve must be defined over either the rational numbers or a finite field. The output of the function is boolean1, boolean2, q, polynomial boolean1 indicates whether the Jacobian is *probably* absolutely simple. boolean2 indicates whether or not the answer given by boolean1 is definite. q will be the prime modulo which the curve has simple Jacobian (if the base field is Q) or the size of the base field (if the base field is finite). polynomial will be the characteristic polynomial of the curve mod p. Note that boolean2 can only be "false" if boolean1 is "false" and the base field is the rational numbers. If the curve is defined over the rational numbers, the program will try reducing the curve modulo the first B primes of nonsingular reduction until it finds one for which the reduced curve has simple Jacobian. The value of B defaults to 20. */ function IsAbsolutelyIrreducible(f : B := 20); Z:=PolynomialRing(Rationals()); R := Parent(f); x := R.1; K := BaseRing(R); if Characteristic(K) gt 0 then q := #K; C := HyperellipticCurve(f); error if not (Genus(C) eq 2), "The polynomial must define a curve of genus 2."; charpol := Numerator(Evaluate(Numerator(ZetaFunction(C)),1/t)); a := Coefficient(charpol,3); b := Coefficient(charpol,2); if (b eq 0) or (a^2 in {0, q+b, 2*b, 3*b - 3*q}) or not IsIrreducible(charpol) then return false, true, _, _; else return true, true, q, charpol; end if; else error if not (K eq Rationals()), "The base ring of the polynomial ring must either be finite or Q."; den := LCM([Denominator(a) : a in Coefficients(f)]); f := den*f; disc := Integers()!Discriminant(f); p := 2; count := 0; repeat repeat p := NextPrime(p); until (disc mod p) ne 0; count +:=1; bool1, bool2, q, charpol := IsAbsolutelyIrreducible(PolynomialRing(GF(p))!f); if bool1 then return bool1, bool2, q, charpol; end if; until count eq B; return false, false, _, _; end if; end function; /* Function that returns the curve of Theorem 6 of the paper cited above, given values of r, s, t in a field. */ function GeneralCurve(r,s,t); R:=PolynomialRing(Parent(r/1)); d0 := -16 * t^3 * (s-1)^4 * (4*r^2*s^2 - 3*r^2*s*t - 4*r^2*s - r^2*t + 32*r*s^3 - 16*r*s^2*t - 32*r*s^2 - 16*r*s*t + 16*s^5*t - 28*s^4*t^2 - 16*s^4*t + 64*s^4 + 12*s^3*t^3 + 20*s^3*t^2 - 16*s^3*t - 64*s^3 - 8*s^2*t^3 + 12*s^2*t^2 - 48*s^2*t - 4*s*t^3 - 4*s*t^2); d1 := 32 * t^2 * (s-1)^3 * (2*r^2*s^2 - 2*r^2*s*t - 2*r^2*s - r^2*t + 8*r*s^3 - 4*r*s^2*t - 8*r*s^2 - 3*r*s*t^2 - 16*r*s*t - r*t^2 + 8*s^5*t - 16*s^4*t^2 - 8*s^4*t + 8*s^3*t^3 + 12*s^3*t^2 + 8*s^3*t - 4*s^2*t^3 - 40*s^2*t - 4*s*t^3 - 12*s*t^2); d2 := -8 * t * (s-1)^2 * (2*r^2*s^2 - 3*r^2*s*t - 2*r^2*s - 3*r^2*t + 8*r*s^2*t - 16*r*s*t^2 - 40*r*s*t - 8*r*t^2 + 8*s^5*t - 20*s^4*t^2 - 8*s^4*t + 12*s^3*t^3 + 4*s^3*t^2 + 24*s^3*t + 6*s^2*t^3 - 12*s^2*t^2 - 56*s^2*t - 16*s*t^3 - 68*s*t^2 - 2*t^3); d3 := -8 * t * (s-1) * (r^2 - 4*r*s^2 + 6*r*s*t + 8*r*s + 6*r*t + 12*s^3*t - 12*s^2*t^2 + 8*s*t^2 + 36*s*t + 4*t^2); d4 := -(r^2*s - r^2 - 16*r*t + 4*s^4*t - 4*s^3*t^2 - 28*s^3*t + 32*s^2*t^2 + 12*s^2*t - 4*s*t^2 - 52*s*t - 24*t^2); d5 := 2*(r + 4*t); return x^6 - d5*x^5 + d4*x^4 - d3*x^3 + d2*x^2 - d1*x + d0; end function; /* A quick initial test to see whether a given r, s, t give rise to a curve with the right kind of Galois stable subgroups (see the paper). If a triple fails this test, then it doesn't give a good curve. If a triple passes this test, it might give a good curve. */ function MightHaveGoodSubgroups(r,s,t) c2 := r + 4*t; c1 := 4*t*(r + s^3 - s^2*t - 2*s^2 + 5*s + t); c0 := 4*t*(s-1)*(r*s^2 - r*s*t - r*s - r*t - 8*s*t); Delta := -27*c0^2 + 18*c0*c1*c2 - 4*c0*c2^3 - 4*c1^3 + c1^2*c2^2; if 0 eq Delta then return false; end if; NormDeltaPrime := s*(s-1)*(r^2*s - r^2 + 16*r*s*t + 4*s^4*t - 4*s^3*t^2 + 16*s^3*t - 20*s^2*t^2 + 24*s^2*t + 20*s*t^2 + 16*s*t + 4*t^2 + 4*t); if 0 eq NormDeltaPrime then return false; end if; return IsSquare(Delta*NormDeltaPrime); end function; /* The full test to see whether a given r, s, t give rise to a curve with the right kind of Galois stable subgroups. We assume that r, s, and t are rational numbers. If the result is "true", also returns a number describing the Galois group of the polynomial: 1 --> trivial 2 --> C_2 3 --> C_3 6 --> S_3 */ function HasGoodSubgroups(r,s,t) r := r/1; s := s/1; t := t/1; check := (Parent(r) eq Rationals()) and (Parent(s) eq Rationals()) and (Parent(t) eq Rationals()); error if not check, "The variables must be rational numbers."; R:=PolynomialRing(Rationals()); c2 := r + 4*t; c1 := 4*t*(r + s^3 - s^2*t - 2*s^2 + 5*s + t); c0 := 4*t*(s-1)*(r*s^2 - r*s*t - r*s - r*t - 8*s*t); h := T^3 - c2*T^2 + c1*T - c0; Delta := -27*c0^2 + 18*c0*c1*c2 - 4*c0*c2^3 - 4*c1^3 + c1^2*c2^2; if 0 eq Delta then return false; end if; factors := Factorization(h); case #factors: when 1: d := LCM([Denominator(c2), Denominator(c1), Denominator(c0)]); newh := T^3 - d*c2*T^2 + d^2*c1*T - d^3*c0; L:=NumberField(newh); beta := alpha/d; cc1 := 2*beta; cc0 := (1-s)*beta^2 - 4*s*(s-1)^2*t*(s-t-1); DeltaPrime := cc1^2 - 4*cc0; if 0 eq DeltaPrime then return false; end if; if not IsSquare(Delta*DeltaPrime) then return false, 0; end if; if IsSquare(Delta) then type := 3; else type := 6; end if; return true, type; when 2: h1 := factors[1][1]; h2 := factors[2][1]; if Degree(h1) eq 2 then temp := h2; h2 := h1; h1 := temp; end if; beta := Roots(h1)[1][1]; cc1 := 2*beta; cc0 := (1-s)*beta^2 - 4*s*(s-1)^2*t*(s-t-1); DeltaPrime := cc1^2 - 4*cc0; if 0 eq DeltaPrime then return false; end if; if not IsSquare(Delta*DeltaPrime) then return false, 0; end if; d := LCM([Denominator(Coefficient(h2,0)), Denominator(Coefficient(h2,1))]); newh2 := d^2*Evaluate(h2,T/d); L:=NumberField(newh2); beta := alpha/d; cc1 := 2*beta; cc0 := (1-s)*beta^2 - 4*s*(s-1)^2*t*(s-t-1); DeltaPrime := cc1^2 - 4*cc0; if 0 eq DeltaPrime then return false; end if; if not IsSquare(Delta*DeltaPrime) then return false, 0; end if; return true, 2; when 3: for r in Roots(h) do beta := r[1]; cc1 := 2*beta; cc0 := (1-s)*beta^2 - 4*s*(s-1)^2*t*(s-t-1); DeltaPrime := cc1^2 - 4*cc0; if 0 eq DeltaPrime then return false; end if; if not IsSquare(DeltaPrime) then return false, 0; end if; end for; return true, 1; end case; end function; /* Given a polynomial f such that y^2 = f has genus 2, returns a pair , where C is the reduced minimal Weierstrass model of the twist t*y^2 = f of the given curve. The value of t is chosen in a way that we naively hope will produce a C with small coefficients. */ function RMWM(f) d := LCM([Denominator(a) : a in Coefficients(f)]); newf := HyperellipticPolynomials(SimplifiedModel( ReducedMinimalWeierstrassModel(HyperellipticCurve(d*f)))); newd := GCD([Integers()!a : a in Eltseq(newf)]); C := ReducedMinimalWeierstrassModel(HyperellipticCurve(newf/newd)); d := d*newd; fd := Factorization(d); d := &*[f[1]^(f[2] mod 2) : f in fd]; return ; end function; /* Given an r, s, t over Q that satisfy HasGoodSubgroups, construct the two associated curves with isomorphic Jacobians. If the "Reduced" flag is set, reduce the curves as above. */ function IsomorphicJacobians(r,s,t : Reduced := false) r := r/1; s := s/1; t := t/1; check := (Parent(r) eq Rationals()) and (Parent(s) eq Rationals()) and (Parent(t) eq Rationals()); error if not check, "The variables must be rational numbers."; R:=PolynomialRing(Rationals()); c2 := r + 4*t; c1 := 4*t*(r + s^3 - s^2*t - 2*s^2 + 5*s + t); c0 := 4*t*(s-1)*(r*s^2 - r*s*t - r*s - r*t - 8*s*t); h := x^3 - c2*x^2 + c1*x - c0; Delta := -27*c0^2 + 18*c0*c1*c2 - 4*c0*c2^3 - 4*c1^3 + c1^2*c2^2; error if 0 eq Delta, "Bad choice of inputs."; factors := Factorization(h); case #factors: when 1: d := LCM([Denominator(c2), Denominator(c1), Denominator(c0)]); newh := x^3 - d*c2*x^2 + d^2*c1*x - d^3*c0; L:=NumberField(newh); beta := alpha/d; cc1 := 2*beta; cc0 := (1-s)*beta^2 - 4*s*(s-1)^2*t*(s-t-1); DeltaPrime := cc1^2 - 4*cc0; error if 0 eq DeltaPrime, "Bad choice of inputs."; // error if not IsSquare(Delta*DeltaPrime), "Bad choice of inputs."; if IsSquare(Delta) then betas := Roots(h,L); beta1 := betas[1][1]; beta2 := betas[2][1]; beta3 := betas[3][1]; S:=PolynomialRing(L); g1 := U^2 - 2*beta1*U + (1-s)*beta1^2 - 4*s*(s-1)^2*t*(s-t-1); g2 := U^2 - 2*beta2*U + (1-s)*beta2^2 - 4*s*(s-1)^2*t*(s-t-1); g3 := U^2 - 2*beta3*U + (1-s)*beta3^2 - 4*s*(s-1)^2*t*(s-t-1); rs1 := Roots(g1); rs2 := Roots(g2); rs3 := Roots(g3); r1 := rs1[1][1]; r2 := rs1[2][1]; r3 := rs2[1][1]; r4 := rs2[2][1]; r5 := rs3[1][1]; r6 := rs3[2][1]; // The Galois group of the polynomial is cyclic of // order 3; so if we label the r_i according to the // numbering in the proof of Theorem 7, r1, r4 and r6 // are conjugate to one another. pol1 := MinimalPolynomial(r1,Rationals()); pol3 := MinimalPolynomial(r3,Rationals()); pol4 := MinimalPolynomial(r4,Rationals()); pol5 := MinimalPolynomial(r5,Rationals()); pol6 := MinimalPolynomial(r6,Rationals()); if pol4 ne pol1 then temp := r3; r3 := r4; r4 := temp; end if; if pol6 ne pol1 then temp := r5; r5 := r6; r6 := temp; end if; list := [ [r1,r2,r3,r4,r5,r6] ]; else NewDelta := Discriminant(newh); // What is minimal polynomial square root of NewDelta*alpha^2 ? defpol := Evaluate(MinimalPolynomial(NewDelta*alpha^2,Rationals()),x^2); M:=NumberField(defpol); betas := Roots(h,M); beta1 := betas[1][1]; beta2 := betas[2][1]; beta3 := betas[3][1]; S:=PolynomialRing(M); g1 := U^2 - 2*beta1*U + (1-s)*beta1^2 - 4*s*(s-1)^2*t*(s-t-1); g2 := U^2 - 2*beta2*U + (1-s)*beta2^2 - 4*s*(s-1)^2*t*(s-t-1); g3 := U^2 - 2*beta3*U + (1-s)*beta3^2 - 4*s*(s-1)^2*t*(s-t-1); rs1 := Roots(g1); rs2 := Roots(g2); rs3 := Roots(g3); r1 := rs1[1][1]; r2 := rs1[2][1]; r3 := rs2[1][1]; r4 := rs2[2][1]; r5 := rs3[1][1]; r6 := rs3[2][1]; // The Galois group of the polynomial is S3. If we label // the r_i according to the numbering in the proof of Theorem 7, // then r1 --> r4 generates an element of order 3, as does // r1 --> r6. images := [s[1] : s in Roots(defpol,M)]; ii := 0; repeat ii+:=1; im := images[ii]; auto := hom< M->M | im>; until auto(auto(gamma)) ne gamma; cycle := [r1, auto(r1), auto(auto(r1))]; if not (r4 in cycle) then temp := r3; r3 := r4; r4 := temp; end if; if not (r6 in cycle) then temp := r5; r5 := r6; r6 := temp; end if; list := [ [r1,r2,r3,r4,r5,r6] ]; end if; when 2: h1 := factors[1][1]; h2 := factors[2][1]; if Degree(h1) eq 2 then temp := h2; h2 := h1; h1 := temp; end if; d := LCM([Denominator(Coefficient(h2,0)), Denominator(Coefficient(h2,1))]); newh2 := d^2*Evaluate(h2,x/d); L:=NumberField(newh2); alphaprime := Trace(alpha,Rationals()) - alpha; beta1 := Roots(h1,L)[1][1]; betas2 := Roots(h2,L); beta2 := betas2[1][1]; beta3 := betas2[2][1]; S:=PolynomialRing(L); g1 := U^2 - 2*beta1*U + (1-s)*beta1^2 - 4*s*(s-1)^2*t*(s-t-1); g2 := U^2 - 2*beta2*U + (1-s)*beta2^2 - 4*s*(s-1)^2*t*(s-t-1); g3 := U^2 - 2*beta3*U + (1-s)*beta3^2 - 4*s*(s-1)^2*t*(s-t-1); rs1 := Roots(g1); rs2 := Roots(g2); rs3 := Roots(g3); error if #rs1 + #rs2 + #rs3 lt 6, "Bad choice of inputs."; r1 := rs1[1][1]; r2 := rs1[2][1]; r3 := rs2[1][1]; r4 := rs2[2][1]; r5 := rs3[1][1]; r6 := rs3[2][1]; auto := homL | alphaprime>; // All we need to check is that the automorphism // takes r3 to r6 (and therefore r4 to r5). if auto(r3) ne r6 then temp := r5; r5 := r6; r6 := temp; end if; list := [ [r1,r2,r3,r4,r5,r6], [r1,r2,r4,r3,r6,r5] ]; when 3: betas := Roots(h); beta1 := betas[1][1]; beta2 := betas[2][1]; beta3 := betas[3][1]; U := x; g1 := U^2 - 2*beta1*U + (1-s)*beta1^2 - 4*s*(s-1)^2*t*(s-t-1); g2 := U^2 - 2*beta2*U + (1-s)*beta2^2 - 4*s*(s-1)^2*t*(s-t-1); g3 := U^2 - 2*beta3*U + (1-s)*beta3^2 - 4*s*(s-1)^2*t*(s-t-1); rs1 := Roots(g1); rs2 := Roots(g2); rs3 := Roots(g3); r1 := rs1[1][1]; r2 := rs1[2][1]; r3 := rs2[1][1]; r4 := rs2[2][1]; r5 := rs3[1][1]; r6 := rs3[2][1]; list := [ [r1,r2,r3,r4,r5,r6], [r1,r2,r4,r3,r5,r6], [r1,r2,r3,r4,r6,r5], [r1,r2,r4,r3,r6,r5] ]; end case; outlist := []; for rv in list do r1 := rv[1]; r2 := rv[2]; r3 := rv[3]; r4 := rv[4]; r5 := rv[5]; r6 := rv[6]; g1 := (U-r1)*(U-r5); g2 := (U-r2)*(U-r4); g3 := (U-r3)*(U-r6); g1p := (U-r1)*(U-r3); g2p := (U-r2)*(U-r6); g3p := (U-r4)*(U-r5); RD := RichelotDual(g1,g2,g3); RDp := RichelotDual(g1p,g2p,g3p); if not ((RD[1] eq 0) or (RDp[1] eq 0)) then f := R!Numerator(RD[2]*RD[3]*RD[4]/RD[1]); fp := R!Numerator(RDp[2]*RDp[3]*RDp[4]/RDp[1]); if Reduced then outlist cat:= [ [RMWM(f), RMWM(fp)] ]; else outlist cat:= [[f,fp]]; end if; end if; end for; return outlist; end function; /* Theorem 2 of the paper gives, for every value of v, a pair of curves with isomorphic Jacobians. This function computes them. If the "Reduced" flag is set to true, the curves will be reduced as described above. */ function SpecialIsomorphicJacobians(v : Reduced:=false); v := v/1; error if 0 eq ( v * (v-1) * (v-4) * (v^2 - v + 4) * (v^2 + v + 2) * (v^2 + 3*v + 4) * (v^3 - 6*v^2 - 7*v - 4) * (v^3 - 4*v^2 + 7*v + 4) ), "Bad value."; K := Parent(v); R:=PolynomialRing(K); bool, w := IsSquare(v); if not bool then L:=ext; end if; rho1 := (-2+w)*(1+w)/2/w^2; rho2 := (-2-w)*(1-w)/2/w^2; rho3 := -2*(2+w)/(-2+w)/(1+w); rho4 := (-2-w)*(1-w)/(-w)/(-1-w); rho5 := (-2+w)*(1+w)/( w)/(-1+w); rho6 := -2*(2-w)/(-2-w)/(1-w); S:=PolynomialRing(Parent(rho1)); g1 := (y-rho1)*(y-rho5); g2 := (y-rho2)*(y-rho4); g3 := (y-rho3)*(y-rho6); g1p := (y-rho1)*(y-rho3); g2p := (y-rho2)*(y-rho6); g3p := (y-rho4)*(y-rho5); RD := RichelotDual(g1,g2,g3); f := R!Numerator(RD[2]*RD[3]*RD[4]/RD[1]); RDp := RichelotDual(g1p,g2p,g3p); fp:= R!Numerator(RDp[2]*RDp[3]*RDp[4]/RDp[1]); if Reduced then return [RMWM(f), RMWM(fp)]; else return [f, fp]; end if; end function;