two_neighbor_step without computing intersection numbers (#4185)

* improve horizontal_decomposition to not compute intersection numbers, sort basepoints of reducible fibers of elliptic surfaces

experimental/Schemes/src/elliptic_surface.jl

@@ -291,7 +291,7 @@ function _algebraic_lattice(X::EllipticSurface, mwl_basis::Vector{<:EllipticCurv
   tors = [section(X, h) for h in mordell_weil_torsion(X)]
   torsV = QQMatrix[]
   for T in tors
-    @vprint :EllipticSurface 2 "computing basis representation of $(T)\n"
+    @vprint :EllipticSurface 2 "computing basis representation of torsion point $(T)\n"
     vT = zero_matrix(QQ, 1, n)
     for i in 1:r
       if i== 2
@@ -851,32 +851,13 @@ function weierstrass_contraction_iterative(Y::EllipticSurface)
   return piY
 end
 
-#  global divisors0 = [strict_transform(pr_X1, e) for e in divisors0]
-#exceptionals_res = [pullback(inc_Y0)(e) for e in exceptionals]
-@doc raw"""
-    _trivial_lattice(S::EllipticSurface)
-
-Internal function. Returns a list consisting of:
-- basis of the trivial lattice
-- gram matrix
-- fiber_components without multiplicities
-"""
-@attr Any function _trivial_lattice(S::EllipticSurface)
-  #=
-  inc_Y = S.inc_Y
-  X = codomain(inc_Y)
-  exceptionals_res = [pullback(inc_Y0)(e) for e in exceptionals]
-  ExWeil = WeilDivisor.(exceptional_res)
-  tmp = []
-  ExWeil = reduce(append!, [components(i) for i in ExWeil], init= tmp)
-  =#
-  W = weierstrass_model(S)
-  d = numerator(discriminant(generic_fiber(S)))
-  j = j_invariant(generic_fiber(S))
+function _reducible_fibers_disc(X::EllipticSurface; sort::Bool=true)
+  E = generic_fiber(X)
+  j = j_invariant(E)
+  d = numerator(discriminant(E))
   kt = parent(d)
   k = coefficient_ring(kt)
-  # find the reducible fibers
-  sing = elem_type(k)[]
+  sing = Vector{elem_type(k)}[]
   for (p,v) in factor(d)
     if v == 1
       continue
@@ -890,48 +871,76 @@ Internal function. Returns a list consisting of:
     if v == 2
       # not a type II fiber
       if j!=0
-        push!(sing, rt)
+        push!(sing, [rt,k(1)])
       end
     end
     if v > 2
-      push!(sing, rt)
+      push!(sing, [rt,k(1)])
     end
   end
-  # the reducible fibers are over the points in sing
-  # and possibly the point at infinity
-  f = [[k.([i,1]), fiber_components(S,[i,k(1)])] for  i in sing]
-  if degree(d) <= 12*euler_characteristic(S) - 2
-    pt = k.([1, 0])
-    push!(f, [pt, fiber_components(S, pt)])
-  end
-
-  O = zero_section(S)
-  pt0, F = fiber(S)
-  set_attribute!(components(O)[1], :_self_intersection, -euler_characteristic(S))
-
-
-  basisT = [F, O]
-
-  grams = [ZZ[0 1;1 -euler_characteristic(S)]]
-  fiber_componentsS = []
-  for (pt, ft) in f
-    @vprint :EllipticSurface 2 "normalizing fiber: over $pt \n"
-    Ft0 = standardize_fiber(S, ft)
-    @vprint :EllipticSurface 2 "$(Ft0[1]) \n"
-    append!(basisT , Ft0[3][2:end])
-    push!(grams,Ft0[4][2:end,2:end])
-    push!(fiber_componentsS, vcat([pt], collect(Ft0)))
-  end
-  G = block_diagonal_matrix(grams)
-  # make way for some more pretty printing
-  for (pt,root_type,_,comp) in fiber_componentsS
-    for (i,I) in enumerate(comp)
-      name = string(root_type[1], root_type[2])
-      set_attribute!(components(I)[1], :name, string("Component ", name, "_", i-1," of fiber over ", Tuple(pt)))
-      set_attribute!(components(I)[1], :_self_intersection, -2)
+  if sort
+    sort!(sing, by=x->by_total_order(x[1]))
+  end
+  # fiber over infinity is always last (if it is there)
+  if degree(d) <= 12*euler_characteristic(X) - 2
+    push!(sing, k.([1, 0]))
+  end
+  return sing
+end
+
+function by_total_order(x::FqFieldElem) 
+  return [lift(ZZ, i) for i in absolute_coordinates(x)]
+end
+
+by_total_order(x::QQFieldElem) = x
+
+function by_total_order(x::NumFieldElem)
+  return absolute_coordinates(x)
+end 
+
+# global divisors0 = [strict_transform(pr_X1, e) for e in divisors0]
+# exceptionals_res = [pullback(inc_Y0)(e) for e in exceptionals]
+@doc raw"""
+    _trivial_lattice(S::EllipticSurface; reducible_singular_fibers_in_PP1=_reducible_fibers_disc(S))
+  
+Internal function. Returns a list consisting of:
+- basis of the trivial lattice
+- gram matrix
+- fiber_components without multiplicities
+
+The keyword argument `reducible_singular_fibers_in_PP1` must be a list of vectors of length `2` over 
+the base field representing the points in projective space over which there are reducible fibers.
+Specify it to force this ordering of the basis vectors of the ambient space of the `algebraic_lattice`
+"""
+function _trivial_lattice(S::EllipticSurface; reducible_singular_fibers_in_PP1=_reducible_fibers_disc(S))
+  get_attribute!(S, :_trivial_lattice) do
+    O = zero_section(S)
+    pt0, F = fiber(S)
+    set_attribute!(components(O)[1], :_self_intersection, -euler_characteristic(S))
+    basisT = [F, O]
+    grams = [ZZ[0 1;1 -euler_characteristic(S)]]
+    sing = reducible_singular_fibers_in_PP1
+    f = [[pt, fiber_components(S,pt)] for  pt in sing]
+    fiber_componentsS = []
+    for (pt, ft) in f
+      @vprint :EllipticSurface 2 "normalizing fiber: over $pt \n"
+      Ft0 = standardize_fiber(S, ft)
+      @vprint :EllipticSurface 2 "$(Ft0[1]) \n"
+      append!(basisT , Ft0[3][2:end])
+      push!(grams,Ft0[4][2:end,2:end])
+      push!(fiber_componentsS, vcat([pt], collect(Ft0)))
     end
+    G = block_diagonal_matrix(grams)
+    # make way for some more pretty printing
+    for (pt,root_type,_,comp) in fiber_componentsS
+      for (i,I) in enumerate(comp)
+        name = string(root_type[1], root_type[2])
+        set_attribute!(components(I)[1], :name, string("Component ", name, "_", i-1," of fiber over ", Tuple(pt)))
+        set_attribute!(components(I)[1], :_self_intersection, -2)
+      end
+    end
+    return basisT, G, fiber_componentsS
   end
-  return basisT, G, fiber_componentsS
 end
 
 @doc raw"""
@@ -1230,6 +1239,7 @@ function _section(X::EllipticSurface, P::EllipticCurvePoint)
   set_attribute!(W, :is_prime=>true)
   I = first(components(W))
   set_attribute!(I, :is_prime=>true)
+  set_attribute!(W, :point=>P)
   return W
 end
 
@@ -1491,35 +1501,10 @@ function horizontal_decomposition(X::EllipticSurface, F::Vector{QQFieldElem})
   rk_triv = nrows(trivial_lattice(X)[2])
   n = rank(NS)
   @assert degree(NS) == rank(NS)
-  P0 = sum([ZZ(F[i])*X.MWL[i-rk_triv] for i in (rk_triv+1):n], init = E([0,1,0]))
-  P0_div = section(X, P0)
-  @vprint :EllipticSurface 2 "Computing basis representation of $(P0)\n"
-  p0 = basis_representation(X, P0_div) # this could be done from theory alone
-  F1 = F - p0  # should be contained in the QQ-trivial-lattice
-  if all(isone(denominator(i)) for i in F1)
-    # no torsion
-    P = P0
-    P_div = P0_div
-    F2 = F1
-  else
-    found = false
-    for (i,(T, tor)) in enumerate(tors)
-      d = F1 - _vec(tor)
-      if all(isone(denominator(i)) for i in d)
-        found = true
-        T0 = mordell_weil_torsion(X)[i]
-        P = P0 + T0
-        break
-      end
-    end
-    @assert found
-    P_div = section(X, P)
-    p = basis_representation(X, P_div)
-    F2 = F - p
-    @assert all( isone(denominator(i)) for i in F2)
-  end
+  p, P = _vertical_part(X,F)
+  D = section(X, P)
+  F2 = F - p
   @vprint :EllipticSurface 4 "F2 = $(F2)\n"
-  D = P_div
   D = D + ZZ(F2[2])*zero_section(X)
   D1 = D
   F2 = ZZ.(F2); F2[2] = 0
@@ -2905,4 +2890,95 @@ function _prepare_section(D::AbsWeilDivisor{<:EllipticSurface})
   return weil_divisor(I)
 end
 
-
+# internal method used for two neighbor steps
+# in the horizontal_decomposition
+function _vertical_part(X::EllipticSurface, v::QQMatrix)
+  @req nrows(v)==1 "not a row vector"
+  _,tors, NS = algebraic_lattice(X)
+  E = generic_fiber(X)
+  @req ncols(v)==degree(NS) "vector of wrong size $(ncols(v))"
+  @req v in NS "not an element of the lattice"
+  mwl_rank = length(X.MWL)
+  rk_triv = rank(NS)-mwl_rank
+  n = rank(NS)
+  P = sum([ZZ(v[1,i])*X.MWL[i-rk_triv] for i in (rk_triv+1):n], init = E([0,1,0]))
+  p = zero_matrix(QQ, 1, rank(NS)) # the section part
+  p[1,end-mwl_rank+1:end] = v[1,end-mwl_rank+1:end]
+  p[1,2] = 1 - sum(p)  # assert p.F = 1 by adding a multiple of the zero section O
+
+  # P meets exactly one fiber component per fiber 
+  # and that one must be simple, it can be the one meeting O or not
+  # assert this by adding fiber components under the additional condition that p stays in the algebraic lattice
+  simples = []
+  E = identity_matrix(QQ,rank(NS))
+  z = zero_matrix(QQ,1, rank(NS))
+  r = 2
+  for fiber in _trivial_lattice(X)[3]
+    fiber_type = fiber[2]
+    fiber_rk = fiber_type[2]
+    h = highest_root(fiber_type...)
+    simple_indices = [r+i for i in 1:ncols(h) if isone(h[1,i])]
+    simple_or_zero = [E[i:i,:] for i in simple_indices]
+    push!(simple_or_zero, z)
+    push!(simples,simple_or_zero)
+    r += fiber_rk
+  end
+  G = gram_matrix(ambient_space(NS))
+  pG = (p*G)[1:1,3:r]
+  T = Tuple(simples)
+  GF = G[3:r,3:r]
+  candidates = QQMatrix[]
+  for s in Base.Iterators.ProductIterator(T)
+    g = sum(s)[:,3:r]
+    y = (g - pG)
+    xx = solve(GF,y;side=:left)
+    x = zero_matrix(QQ,1, rank(NS))
+    x[:,3:r] = xx
+    if x in NS
+      push!(candidates,p+x)
+    end 
+  end
+  @assert length(candidates)>0
+  # Select the candidate congruent to v modulo Triv 
+  mwg = _mordell_weil_group(X)
+  vmwg = mwg(vec(collect(v)))
+  candidates2 = [mwg(vec(collect(x))) for x in candidates]
+  i = findfirst(==(vmwg), candidates2)
+  t = mwg(vec(collect(p - candidates[i])))
+  mwl_tors_gens = [mwg(vec(collect(i[2]))) for i in tors]
+  ag = abelian_group(zeros(ZZ,length(tors)))
+  mwlAb = abelian_group(mwg)
+  phi = hom(ag, mwlAb, mwlAb.(mwl_tors_gens))
+  a = preimage(phi, mwlAb(t))
+  for i in 1:ngens(ag)
+    P += a[i]*get_attribute(tors[i][1],:point)
+  end 
+
+  p = candidates[i]
+  k = (p*G*transpose(p))[1,1]
+  # assert p^2 = -2
+  p[1,1] = -k/2-1
+  V = ambient_space(NS)
+  @hassert :EllipticSurface 1 inner_product(V, p, p)[1,1]== -2
+  @hassert :EllipticSurface 1 mwg(vec(collect(p))) == mwg(vec(collect(p)))
+  @hassert :EllipticSurface 3 basis_representation(X,section(X,P))==vec(collect(p))
+  return p, P
+end
+
+function _vertical_part(X::EllipticSurface, v::Vector{QQFieldElem}) 
+  vv = matrix(QQ,1,length(v),v)
+  p, P = _vertical_part(X,vv)
+  pp = vec(collect(p))
+  return pp, P
+end
+
+# TODO: Instead return an abelian group A and two maps. 
+# algebraic_lattice -> A 
+# A -> MWL= E(k(t))
+function _mordell_weil_group(X)
+  N = algebraic_lattice(X)[3]
+  V = ambient_space(N)
+  t = nrows(trivial_lattice(X)[2])
+  Triv = lattice(V, identity_matrix(QQ,dim(V))[1:t,:])
+  return torsion_quadratic_module(N, Triv;modulus=1, modulus_qf=1, check=false)
+end 

src/AlgebraicGeometry/Surfaces/K3Auto.jl

@@ -625,9 +625,11 @@ function separating_hyperplanes(gram::QQMatrix, v::QQMatrix, h::QQMatrix, d)
   gramW = gram_matrix(W)
   s = solve(bW, v*prW; side = :left) * gramW
   Q = gramW + transpose(s)*s*ch*cv^-2
+
 
   @vprint :K3Auto 5 Q
   LQ = integer_lattice(gram=-Q*denominator(Q))
+
 
   S = QQMatrix[]
   h = change_base_ring(QQ, h)

test/AlgebraicGeometry/Schemes/elliptic_surface.jl

@@ -121,8 +121,6 @@ end
 end
 
 
-#=
-# These tests are disabled, because they are dependent on factorisation order...
 @testset "two neighbor steps" begin
   K = GF(7)
   Kt, t = polynomial_ring(K, :t)
@@ -144,11 +142,18 @@ end
                                                  [2   1   -1   -2   -3   -2   -1   0   -2   -1   -1   -2   -2   -2   -2   -2   -2   -1   0   1],
                                                  [2   1   0   0   0   0   0   0   0   -2   -2   -4   -4   -4   -4   -3   -2   -1   0   1]
                                                 ]]
+  NS = algebraic_lattice(X2)[3]
+  if !(fibers_in_X2[4] in NS)
+    # account for the order of the basis not being unique 
+    f = fibers_in_X2[4]
+    f[10:11] = reverse(f[10:11])
+    fibers_in_X2[4] = f 
+  end
   g4,_ = two_neighbor_step(X2, fibers_in_X2[4])  # this should be the 2-torsion case
   g5,_ = two_neighbor_step(X2, fibers_in_X2[5])  # the non-torsion case
   g6,_ = two_neighbor_step(X2, fibers_in_X2[6])  # the non-torsion case
 end
-=#
+
 
 #=
 # The following tests take roughly 10 minutes which is too much for the CI testsuite.

test/book/specialized/brandhorst-zach-fibration-hopping/vinberg_2.jlcon

@@ -75,8 +75,8 @@ julia> basisNSY1, gramTriv = trivial_lattice(Y1);
 
 julia> [(i[1],i[2]) for i in reducible_fibers(Y1)]
 3-element Vector{Tuple{Vector{QQFieldElem}, Tuple{Symbol, Int64}}}:
- ([1, 1], (:A, 2))
  ([0, 1], (:E, 8))
+ ([1, 1], (:A, 2))
  ([1, 0], (:E, 8))
 
 julia> basisNSY1, _, NSY1 = algebraic_lattice(Y1);
@@ -85,8 +85,6 @@ julia> basisNSY1
 20-element Vector{Any}:
  Fiber over (2, 1)
  section: (0 : 1 : 0)
- component A2_1 of fiber over (1, 1)
- component A2_2 of fiber over (1, 1)
  component E8_1 of fiber over (0, 1)
  component E8_2 of fiber over (0, 1)
  component E8_3 of fiber over (0, 1)
@@ -95,6 +93,8 @@ julia> basisNSY1
  component E8_6 of fiber over (0, 1)
  component E8_7 of fiber over (0, 1)
  component E8_8 of fiber over (0, 1)
+ component A2_1 of fiber over (1, 1)
+ component A2_2 of fiber over (1, 1)
  component E8_1 of fiber over (1, 0)
  component E8_2 of fiber over (1, 0)
  component E8_3 of fiber over (1, 0)
@@ -112,7 +112,7 @@ given as the formal sum of
   1 * sheaf of ideals
 
 julia> b, I = Oscar._is_equal_up_to_permutation_with_permutation(gram_matrix(NS), gram_matrix(NSY1))
-(true, [1, 2, 19, 20, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18])
+(true, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 19, 20, 11, 12, 13, 14, 15, 16, 17, 18])
 
 julia> @assert gram_matrix(NSY1) == gram_matrix(NS)[I,I]