Introduce various methods to handle Moebius transformations.

experimental/Schemes/elliptic_surface.jl

@@ -2074,41 +2074,54 @@ function _pushforward_lattice_along_isomorphism(step::MorphismFromRationalFuncti
 
       # fiber over some point ≂̸ ∞.
       t = first(gens(OO(UBY)))
-      match = -1
+
+      codomain_charts = copy(affine_charts(Y))
+
+      # Restrict the codomain charts if applicable
       for (i, (p, _, F, E, _)) in enumerate(reducible_fibers(Y))
         p[2] == 0 && continue # Fiber over infinity already caught above
         t0 = p[1]//p[2]
         ideal(OO(UBY), t - t0) == Q(UBY) || continue
 
         # Collect all patches
         codomain_charts = AbsAffineScheme[V for V in affine_charts(Y) if any(I->!isone(I(V)), components(F))]
-        if i > n - mwr # If D is a section
-          pt = X.MWL[i-(n-mwr)]
-          res = _pushforward_section(step, pt; divisor=D, codomain_charts)
-          result[D] = WeilDivisor(Y, co_ring, IdDict{AbsIdealSheaf, elem_type(co_ring)}(res::AbsIdealSheaf => one(co_ring)); check=false)
-        else
-          loc_map, dom_chart, cod_chart = _prepare_pushforward_prime_divisor(step, I; codomain_charts)
-          loc_map === nothing && error("preparation for pushforward did not succeed")
-          match = i
+        break
+      end
 
-          K = _local_pushforward(loc_map, I(domain(loc_map)))
-          JJ = ideal(OO(cod_chart), gens(K))
-          res = PrimeIdealSheafFromChart(Y, cod_chart, JJ)
+      if i > n - mwr # If D is a section
+        pt = X.MWL[i-(n-mwr)]
+        res = _pushforward_section(step, pt; divisor=D, codomain_charts)
+        result[D] = WeilDivisor(Y, co_ring, IdDict{AbsIdealSheaf, elem_type(co_ring)}(res::AbsIdealSheaf => one(co_ring)); check=false)
+      else
+        loc_map, dom_chart, cod_chart = _prepare_pushforward_prime_divisor(step, I; codomain_charts)
+        loc_map === nothing && error("preparation for pushforward did not succeed")
 
-          result[D] = WeilDivisor(Y, co_ring, IdDict{AbsIdealSheaf, elem_type(co_ring)}(res::AbsIdealSheaf => one(co_ring)); check=false)
-        end
-        break
+        K = _local_pushforward(loc_map, I(domain(loc_map)))
+        JJ = ideal(OO(cod_chart), gens(K))
+        res = PrimeIdealSheafFromChart(Y, cod_chart, JJ)
+
+        result[D] = WeilDivisor(Y, co_ring, IdDict{AbsIdealSheaf, elem_type(co_ring)}(res::AbsIdealSheaf => one(co_ring)); check=false)
       end
-      match == -1 && error("no fiber found")
     else
       # "pushforward will be a section"
       if i > n - mwr # If D is a section
         pt = X.MWL[i-(n-mwr)]
         res = _pushforward_section(step, pt; divisor=D, codomain_charts=[weierstrass_chart_on_minimal_model(Y)])
+        if res === nothing
+          # The only section not visible in the weierstrass chart is the zero section
+          result[D] = zero_section(Y)
+          continue
+        end
+
         result[D] = WeilDivisor(Y, co_ring, IdDict{AbsIdealSheaf, elem_type(co_ring)}(res::AbsIdealSheaf => one(co_ring)); check=false)
       else
         loc_map, dom_chart, cod_chart = _prepare_pushforward_prime_divisor(step, I, domain_chart = dom_chart, codomain_charts = [weierstrass_chart_on_minimal_model(Y)])
-        loc_map === nothing && error("preparation for pushforward did not succeed")
+
+        if loc_map === nothing 
+          # The only section not visible in the weierstrass chart is the zero section
+          result[D] = zero_section(Y)
+          continue
+        end
 
         K = _local_pushforward(loc_map, I(domain(loc_map)))
         JJ = ideal(OO(cod_chart), gens(K))
@@ -2216,7 +2229,7 @@ function _pushforward_section(
   inc_loc = first(maps_with_given_codomain(inc, U))
   U_C = domain(inc_loc)
   phi_loc, _, V = _prepare_pushforward_prime_divisor(phi, I; domain_chart=U, codomain_charts)
-  phi_loc === nothing && error("pushforward preparation did not succeed")
+  phi_loc === nothing && return nothing # Indicate that the given selection of codomain charts did not lead to a result
   W = codomain(fibration(X)[U])
   iso_loc = _restrict_properly(cheap_realization(iso, W, U_C), U_C)
   inc_dom_phi_loc = inclusion_morphism(domain(phi_loc)) 
@@ -2229,6 +2242,8 @@ function _pushforward_section(
   return JJ
 end
 
+# Find a moebius transformation which sends a given set of three points in ℙ¹ to another set 
+# of three points.
 function find_moebius_transformation(
     orig_pts::Vector{<:Vector{<:FieldElem}}, 
     new_pts::Vector{<:Vector{<:FieldElem}}
@@ -2261,20 +2276,168 @@ function find_moebius_transformation(
   return x->(C[1,1]*x + C[1, 2], C[2,1]*x + C[2,2])
 end
 
-function lift_moebius_transformation(X::EllipticSurface, trafo::Any)
-  kkt = base_field(generic_fiber(X))
-  WX = weierstrass_chart_on_minimal_model(X)
-  R = ambient_coordinate_ring(WX)
+# Given a bivariate polynomial over a univariate function field, 
+# normalize the associated elliptic curve so that the usual constructor 
+# for elliptic surfaces digests it, and then return it, together with the 
+# transformation on the algebraic side. 
+function _elliptic_surface_with_trafo(g::MPolyRingElem{<:AbstractAlgebra.Generic.FracFieldElem})
+  x, y = gens(parent(g))
+  E = elliptic_curve(g, x, y)
+  kkt = base_field(E)
+  kk = coefficient_ring(base_ring(kkt))
+
+  FFt, t = rational_function_field(kk, :t)
+
+  # The following three commands won't work unless we convert to a rational_function_field
+  EE = base_change(x->evaluate(x, t), E)
+
+  EE = tates_algorithm_global(EE)
+  EE, _ = short_weierstrass_model(EE)
+  EE, _ = integral_model(EE)
+
+  # ...and back.
+  E2 = base_change(x->evaluate(x, gen(kkt)), EE)
+
+  @assert is_isomorphic(E, E2)
+  a, b, _ = rational_maps(isomorphism(E, E2))
+
+  R = parent(g)
   F = fraction_field(R)
-  (x, y, t) = gens(R)
-  p, q = trafo(t)
-  img_gens = F.([x, y, p//q])
-  return morphism_from_rational_functions(X, X, WX, WX, img_gens, check=true) 
+
+  phi = hom(R, parent(a), [a, b])
+  Phi = extend_domain_to_fraction_field(phi)
+  return elliptic_surface(E2, 2), Phi
 end
 
+# Given two abstractly isomorphic elliptic surfaces X and Y over ℙ¹, 
+# find all moebius transformation of the base which preserve the critical 
+# values of the projections, try to lift them to morphisms X -> Y and 
+# return the list of such morphisms for which the lift was successful.
+function admissible_moebius_transformations(
+    X::EllipticSurface,
+    Y::EllipticSurface
+  )
+  EX = generic_fiber(X)
+  EY = generic_fiber(Y)
+
+#  kkt = base_field(EX)
+#  @assert kkt === base_field(EY) "base fields of the generic fibers must coincide"
+  kk = base_ring(X)
+  @assert kk === base_ring(Y) "elliptic surfaces must be defined over the same field"
+
+  dX = numerator(discriminant(EX))::PolyRingElem
+  dY = numerator(discriminant(EY))::PolyRingElem
+
+  vX = roots(dX)
+  @assert all(is_one(degree(a)) for (a, k) in factor(dX))  "not all critical values are rational over the given ground field"
+
+  vY = roots(dY)
+  @assert all(is_one(degree(a)) for (a, k) in factor(dY))  "not all critical values are rational over the given ground field"
+
+  for (c, _) in reducible_fibers(X)
+    @assert !is_zero(c[2]) "the case of reducible fibers over the point at infinity is not implemented"
+  end
+  for (c, _) in reducible_fibers(Y)
+    @assert !is_zero(c[2]) "the case of reducible fibers over the point at infinity is not implemented"
+  end
+
+  # Use the first three elements of vX and map them to three elements of vY.
+  # Then check whether the resulting transformation preserves everything.
+
+  candidates = Function[]
+
+  @assert length(vX) >= 3 "at least three reducible fibers are needed"
+  length(vX) == length(vY) || return candidates # No moebius transformation is possible in this case
+
+  p1 = vX[1:3]
+  for i in vY
+    for j in vY
+      i == j && continue
+      for k in vY
+        (i == k || j == k) && continue
+        p2 = [i, j, k]
+        mt = find_moebius_transformation(p1, p2)
+        any(is_zero(mt(x)[2]) for x in vX) && continue # reducible fibers over ∞ are not implemented at the moment.
+        any(!(mt(x)[1]//mt(x)[2] in vY) for x in vX) && continue # the transformation does not preserve all admissible fibers in this case
+        push!(candidates, mt)
+      end
+    end
+  end
+
+  result = MorphismFromRationalFunctions[]
+
+  # Set up some variables
+  kkt = base_field(EX)
+  t = gen(kkt)
+  WX = weierstrass_chart_on_minimal_model(X)
+  RX = ambient_coordinate_ring(WX)
+  FRX = fraction_field(RX)
+  WY = weierstrass_chart_on_minimal_model(Y)
+  RY = ambient_coordinate_ring(WY)
+  FRY = fraction_field(RY)
+
+  # Go through the candidates again and for those which do indeed lead to isomorphic 
+  # surfaces, construct the isomorphism.
+  for mt in candidates
+    p, q = mt(t)
+    img_t = (p//q)::typeof(t)
+    EYbc = base_change(f->evaluate(f, img_t), EY)
+    is_isomorphic(EYbc, EX) || continue
+    # Construct the isomorphism of elliptic surfaces explicitly
+    iso_ell = isomorphism(EX, EYbc)
+
+    a, b, _ = rational_maps(iso_ell)
+    kkTxy = parent(a)
+    to_FRX = hom(kkTxy, FRX, x->evaluate(x, FRX(RX[3])), FRX.([RX[1], RX[2]]))
+    A = to_FRX(a)
+    B = to_FRX(b)
+    P, Q = mt(FRX(RX[3]))
+    img_T = (P//Q)::elem_type(FRX)
+    img_gens = [A, B, img_T]
+    loc_res = morphism_from_rational_functions(X, Y, WX, WY, img_gens; check=true)
+    set_attribute!(loc_res, :is_isomorphism=>true)
+    push!(result, loc_res)
+  end
+
+  return result
+end
+
+# An internal helper routine to verify that a given isomorphism of elliptic surfaces 
+# does indeed give an isomorphism on their generic fibers.
+function check_isomorphism_on_generic_fibers(phi::MorphismFromRationalFunctions{<:EllipticSurface, <:EllipticSurface})
+  X = domain(phi)
+  Y = codomain(phi)
+  @assert domain_chart(phi) === weierstrass_chart_on_minimal_model(X)
+  @assert codomain_chart(phi) === weierstrass_chart_on_minimal_model(Y)
+  EX = generic_fiber(X)
+  EY = generic_fiber(Y)
+  a, b, c = coordinate_images(phi)
+
+  hX = equation(EX)
+  RX = parent(hX)
+  FX = fraction_field(RX)
+  kktX = coefficient_ring(RX)
+
+  hY = equation(EY)
+  RY = parent(hY)
+  FY = fraction_field(RY)
+  kktY = coefficient_ring(RY)
+
+  A = evaluate(a, [RX[1], RX[2], RX(gen(kktX))])
+  B = evaluate(b, [RX[1], RX[2], RX(gen(kktX))])
+  C = evaluate(c, [RX[1], RX[2], RX(gen(kktX))])
+
+  help_map = hom(RY, FX, t->evaluate(t, C), [A, B])
+
+  hh = help_map(hY)
+
+  return divides(hX, numerator(hh))[1]
+end
+
+# Given two elliptic surfaces X and Y with abstractly isomorphic generic 
+# fibers, construct the corresponding isomorphism X -> Y.
 function isomorphism_from_generic_fibers(
-    X::EllipticSurface, Y::EllipticSurface;
-    base_change=x->x
+    X::EllipticSurface, Y::EllipticSurface
   )
   EX = generic_fiber(X)
   EY = generic_fiber(Y)
@@ -2300,6 +2463,7 @@ function isomorphism_from_generic_fibers(
   to_FRX = hom(kkTxy, FRX, x->evaluate(x, FRX(RX[3])), FRX.([RX[1], RX[2]]))
   A = to_FRX(a)
   B = to_FRX(b)
-  img_gens = [A, B, base_change(FRX(RX[3]))]
+  img_gens = [A, B, FRX(RX[3])]
   return morphism_from_rational_functions(X, Y, WX, WY, FRX.(img_gens); check=true)
 end
+

test/AlgebraicGeometry/Schemes/elliptic_surface.jl

@@ -211,3 +211,51 @@ end
   @test res_mat*A*transpose(res_mat) == A
 end
 =#
+
+@testset "moebius transformations" begin
+  k = GF(113)
+  kt,t = polynomial_ring(k,:t)
+  Ft = fraction_field(kt)
+
+  E = elliptic_curve(Ft, Ft.([0,0,0,(56*t^8 + 56),0]));
+  basis_mwl = [[112*t^4 + 112*t^3 + 56*t^2 + 15*t + 1, 100*t^6 + 24*t^5 + 56*t^4 + 13*t^3 + 64*t^2 + 89*t + 31],
+               [31*t^4 + 15*t^2 + 82, 44*t^5 + 14*t^3 + 69*t],
+               [82*t^4 + 13, 37*t^4 + 10],
+               [91*t^4 + 16*t^3 + 25*t^2 + 14*t + 22, 18*t^6 + 55*t^5 + 45*t^4 + 44*t^3 + 110*t^2 + 58*t + 69],
+               [32*t^4 + 72*t^2 + 81, 78*t^6 + 79*t^4 + 58*t^2 + 40],
+               [56*t^4 + 49*t^3 + 85*t^2 + 57*t + 57, 72*t^6 + 25*t^5 + 22*t^4 + 101*t^3 + 104*t^2 + 88*t + 50],
+               [22*t^4 + 87*t^3 + 77*t^2 + 26*t + 22, 44*t^6 + 27*t^5 + 68*t^4 + 98*t^3 + 45*t^2 + 27*t + 69],
+               [112*t^4 + 44*t^3 + 49*t^2 + 44*t + 112, 100*t^6 + 74*t^5 + 49*t^4 + 8*t^3 + 49*t^2 + 74*t + 100]]
+  basis_mwl = [E(i) for i in basis_mwl];
+
+  X = elliptic_surface(E, 2, basis_mwl)
+
+  moeb = Oscar.admissible_moebius_transformations(X, X)
+
+  @test length(moeb) == 16 # This must really be the number for this particular surface.
+
+  for phi in moeb
+    @test Oscar.check_isomorphism_on_generic_fibers(phi)
+  end
+
+  phi = moeb[5] # Just pick one which is not the identity
+
+  W = weierstrass_chart_on_minimal_model(X)
+
+  for (i, U) in enumerate(affine_charts(X))
+    phi_loc = Oscar.cheap_realization(phi, W, U)
+    @test all(iszero(pullback(phi_loc)(lifted_numerator(g))) for g in gens(modulus(OO(U))))
+  end
+
+  # Do something reasonable to see whether this is really working
+  lat, _, L = algebraic_lattice(X)
+  A = gram_matrix(ambient_space(L))
+
+  ll = Oscar._pushforward_lattice_along_isomorphism(phi)
+  res_mat = [Oscar.basis_representation(X, d) for d in ll]
+
+  res_mat = matrix(QQ, res_mat)
+  # Check that the base change matrix is indeed orthogonal for the given lattice
+  @test res_mat*A*transpose(res_mat) == A
+end
+