From 1821a80aab8710f5384003124c9fd5cad4d9e7ae Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Thu, 5 Nov 2026 08:28:14 -0800 Subject: [PATCH 1/4] Split over-long proofs in AndersonConjecture Refactor every proof over 200 lines (as measured by the syntax-aware long-proof linter in #712) into named helper lemmas. Proof carriers disguised as PLift-valued defs or private abbrevs become theorems. Statements and public declarations are unchanged. Refs #723 Co-Authored-By: Claude Opus 5.5 --- .../AndersonConjecture/AdicNoetherian.lean | 571 +++++------- .../Jensen/Adjoin/Adjoin.lean | 428 ++++----- .../Jensen/Adjoin/FromPrime.lean | 427 +++++---- .../Jensen/CloseUp/AvoidanceStep.lean | 826 +++++++++-------- .../Jensen/CloseUp/CoprimeSplit.lean | 401 ++++---- .../Jensen/CloseUp/Factor.lean | 425 ++++----- .../Jensen/CloseUp/NoCommonFactor.lean | 874 +++++++++--------- .../Jensen/CombinedStep.lean | 184 ++-- .../Jensen/Construction/Transfinite.lean | 594 ++++++------ .../Jensen/KrullDomain/HeightBound.lean | 734 +++++++-------- .../Jensen/KrullDomain/KrullDomain.lean | 622 ++++--------- .../Jensen/KrullDomain/UFDConstruction.lean | 472 +++++----- 12 files changed, 3061 insertions(+), 3497 deletions(-) diff --git a/LeanPool/AndersonConjecture/AdicNoetherian.lean b/LeanPool/AndersonConjecture/AdicNoetherian.lean index 748b34e852..96a579ae25 100644 --- a/LeanPool/AndersonConjecture/AdicNoetherian.lean +++ b/LeanPool/AndersonConjecture/AdicNoetherian.lean @@ -326,9 +326,170 @@ omit [IsLocalRing R] [IsNoetherianRing R] in lemma extract_filtration_rep refine ⟨r, ?_, hr_eq.symm⟩ simpa only [hn0_pow] using hr_FN +omit [IsLocalRing R] [IsNoetherianRing R] in +/-- Membership in `M̂ᴷ` is membership in `Mᴷ • ⊤` for the adic completion. -/ +private theorem mem_map_pow_iff_mem_pow_smul_top (Mi : Ideal R) (K : ℕ) + (z : AdicCompletion Mi R) : + z ∈ Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ K ↔ + z ∈ Mi ^ K • (⊤ : Submodule R (AdicCompletion Mi R)) := by + rw [Ideal.smul_top_eq_map, ← Ideal.map_pow, Submodule.restrictScalars_mem] + +omit [IsLocalRing R] [IsNoetherianRing R] in +/-- A sequence whose consecutive differences lie in `M̂ᴷ` is adically Cauchy. -/ +private theorem smodEq_of_consecutive_differences (Mi : Ideal R) + (f : ℕ → AdicCompletion Mi R) + (hf : ∀ K, f (K + 1) - f K ∈ Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ K) + {m n : ℕ} (hmn : m ≤ n) : + f m ≡ f n [SMOD (Mi ^ m • (⊤ : Submodule R (AdicCompletion Mi R)))] := by + rw [SModEq.sub_mem, ← mem_map_pow_iff_mem_pow_smul_top R Mi] + set Mhat := Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hmn + induction d with + | zero => simp [sub_self, (Mhat ^ m).zero_mem] + | succ d ih => + rw [show m + (d + 1) = (m + d) + 1 from by omega] + have hsplit : f m - f ((m + d) + 1) = + (f m - f (m + d)) + -(f ((m + d) + 1) - f (m + d)) := by abel + rw [hsplit] + exact (Mhat ^ m).add_mem (ih (Nat.le_add_right m d)) + ((Mhat ^ m).neg_mem (Ideal.pow_le_pow_right (Nat.le_add_right m d) (hf (m + d)))) + +omit [IsLocalRing R] [IsNoetherianRing R] in +/-- Lifts to `I₀` of the generators of `span S` give lifts of every element of `span S`. -/ +private theorem lift_span_of_generators (Mi : Ideal R) (n : ℕ) (S : Finset R) + (I₀ : Ideal (AdicCompletion Mi R)) + (hgen : ∀ r ∈ S, ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ + evalₐ Mi n δ = Ideal.Quotient.mk (Mi ^ n) r) + (t : R) (ht : t ∈ (Ideal.span ↑S : Ideal R)) : + ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ evalₐ Mi n δ = Ideal.Quotient.mk (Mi ^ n) t := by + refine Submodule.closure_induction + (p := fun t _ => ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ + evalₐ Mi n δ = Ideal.Quotient.mk (Mi ^ n) t) + ?_ ?_ ?_ ht + · exact ⟨0, I₀.zero_mem, by simp⟩ + · intro _ _ _ _ ⟨δ1, hδ1I, hδ1eq⟩ ⟨δ2, hδ2I, hδ2eq⟩ + exact ⟨δ1 + δ2, I₀.add_mem hδ1I hδ2I, by rw [map_add, hδ1eq, hδ2eq, map_add]⟩ + · intro c s hs_mem + obtain ⟨δ, hδI, hδeq⟩ := hgen s (Finset.mem_coe.mp hs_mem) + exact ⟨of Mi R c * δ, I₀.mul_mem_left _ hδI, by + simp only [map_mul, evalₐ_of, hδeq, smul_eq_mul]⟩ + +omit [IsLocalRing R] [IsNoetherianRing R] in +/-- If `I₀` has the same image as `J` modulo `M̂ⁿ`, then `J ≤ I₀ ⊔ M̂ⁿ`. -/ +private theorem mem_sup_pow_of_map_evalₐ_le (Mi : Ideal R) + (J I₀ : Ideal (AdicCompletion Mi R)) (n : ℕ) + (hker : RingHom.ker (evalₐ Mi n).toRingHom = + Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ n) + (hle : Ideal.map (evalₐ Mi n).toRingHom J ≤ Ideal.map (evalₐ Mi n).toRingHom I₀) + (x : AdicCompletion Mi R) (hx : x ∈ J) : + x ∈ I₀ ⊔ Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ n := by + obtain ⟨y, hy, hyx⟩ := (Ideal.mem_map_iff_of_surjective _ + (surjective_evalₐ Mi n)).mp (hle (Ideal.mem_map_of_mem _ hx)) + refine Submodule.mem_sup.mpr ⟨y, hy, x - y, ?_, by abel⟩ + rw [← hker, RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, + map_sub, sub_eq_zero] + exact hyx.symm + +omit [IsLocalRing R] [IsNoetherianRing R] in +/-- Successive approximation (Atiyah–Macdonald Prop. 10.11 / Matsumura Thm. 8.1): if every +`e ∈ J ∩ M̂^(n0 + K)` can be corrected modulo `M̂^(n0 + K + 1)` by a combination of `genS` +with coefficients in `M̂ᴷ`, then every `z ∈ J ∩ M̂^n0` is a combination of `genS`. -/ +private theorem exists_coefficients_of_successive_approximation (Mi : Ideal R) + (hprec : IsPrecomplete Mi (AdicCompletion Mi R)) + (J : Ideal (AdicCompletion Mi R)) (genS : Finset (AdicCompletion Mi R)) (n0 : ℕ) + (hstep_coeff : ∀ K (e : AdicCompletion Mi R), + e ∈ Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ (n0 + K) → e ∈ J → + ∃ c : AdicCompletion Mi R → AdicCompletion Mi R, + (∀ g, g ∈ genS → c g ∈ Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ K) ∧ + e - Finset.sum genS (fun g => c g * g) ∈ + Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ (n0 + (K + 1))) + (hsum_J : ∀ d : AdicCompletion Mi R → AdicCompletion Mi R, + Finset.sum genS (fun g => d g * g) ∈ J) + (z : AdicCompletion Mi R) + (hz : z ∈ Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi ^ n0) (hzJ : z ∈ J) : + ∃ c : AdicCompletion Mi R → AdicCompletion Mi R, + z = Finset.sum genS (fun g => c g * g) := by + classical + set Mhat := Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi + let sumG (f : AdicCompletion Mi R → AdicCompletion Mi R) := + Finset.sum genS (fun g => f g * g) + -- Build the recursive coefficient sequence via `buildAdicSeq`. + let CSDPred (K : ℕ) (c : AdicCompletion Mi R → AdicCompletion Mi R) := + (z - sumG c) ∈ Mhat ^ (n0 + K) ∧ (z - sumG c) ∈ J + have hsum_zero : sumG (fun _ => (0 : AdicCompletion Mi R)) = 0 := by + simp only [sumG, zero_mul, Finset.sum_const_zero] + have csd0 : { c // CSDPred 0 c } := ⟨fun _ => 0, by + constructor + · simpa only [hsum_zero, sub_zero, Nat.add_zero] using hz + · show z - sumG (fun _ => 0) ∈ _ + rw [hsum_zero, sub_zero] + exact hzJ⟩ + let csdS : ∀ K, { c // CSDPred K c } → { c // CSDPred (K + 1) c } := + fun K ⟨c_K, hMK, hJK⟩ => + let d := (hstep_coeff K _ hMK hJK).choose + let hd := (hstep_coeff K _ hMK hJK).choose_spec + ⟨fun g => c_K g + d g, by + have hsplit : Finset.sum genS (fun g => (c_K g + d g) * g) = + sumG c_K + sumG d := by + simp only [sumG, add_mul, Finset.sum_add_distrib] + have hrw : z - Finset.sum genS (fun g => (c_K g + d g) * g) = + (z - sumG c_K) - sumG d := by + rw [hsplit] + abel + exact ⟨by rw [hrw] + exact hd.2, + by rw [hrw] + exact J.sub_mem hJK (hsum_J d)⟩⟩ + let csdAll := buildAdicSeq csd0 csdS + let pc : ℕ → AdicCompletion Mi R → AdicCompletion Mi R := fun K => (csdAll K).1 + -- Per-step bound: pc(K+1)(g) - pc(K)(g) ∈ Mhat^K + have hpc_diff : ∀ K g, g ∈ genS → + pc (K + 1) g - pc K g ∈ Mhat ^ K := by + intro K g hg + have hcs := hstep_coeff K _ (csdAll K).2.1 (csdAll K).2.2 + have hcsBound : ∀ g, g ∈ genS → hcs.choose g ∈ Mhat ^ K := hcs.choose_spec.1 + change (csdS K (csdAll K)).val g - (csdAll K).val g ∈ Mhat ^ K + have key : ∀ (dat : { c // CSDPred K c }), + (csdS K dat).val g - dat.val g = + (hstep_coeff K _ dat.2.1 dat.2.2).choose g := by + intro ⟨c_K, _, _⟩ + simp only [csdS, add_sub_cancel_left] + rw [key] + exact hcsBound g hg + -- Per-generator limits via IsPrecomplete + have hpc_lim : ∀ g, g ∈ genS → + ∃ cg, ∀ n, + pc n g ≡ cg [SMOD (Mi ^ n • ⊤ : + Submodule R (AdicCompletion Mi R))] := + fun g hg => IsPrecomplete.prec hprec + (smodEq_of_consecutive_differences R Mi (fun K => pc K g) (fun K => hpc_diff K g hg)) + let cLim : AdicCompletion Mi R → AdicCompletion Mi R := + fun g => if hg : g ∈ genS then (hpc_lim g hg).choose else 0 + have hcLim_spec : ∀ g, g ∈ genS → ∀ n, + pc n g ≡ cLim g [SMOD (Mi ^ n • ⊤ : Submodule R (AdicCompletion Mi R))] := by + intro g hg n + simpa only [cLim, dite_eq_left hg] using (hpc_lim g hg).choose_spec n + -- z = ∑ cLim(g) * g by Hausdorff + refine ⟨cLim, ?_⟩ + apply (IsHausdorff.eq_iff_smodEq (I := Mi) (M := AdicCompletion Mi R)).mpr + intro n + rw [SModEq.sub_mem, ← mem_map_pow_iff_mem_pow_smul_top R Mi] + have hsplit : z - Finset.sum genS (fun g => cLim g * g) = + (z - Finset.sum genS (fun g => pc n g * g)) + + Finset.sum genS (fun g => (pc n g - cLim g) * g) := by + simp only [sub_mul, Finset.sum_sub_distrib] + abel + rw [hsplit] + apply (Mhat ^ n).add_mem + · exact Ideal.pow_le_pow_right (Nat.le_add_left n n0) (csdAll n).2.1 + · exact Ideal.sum_mem _ (fun g hg => Ideal.mul_mem_right _ _ + (by + rw [mem_map_pow_iff_mem_pow_smul_top R Mi] + exact SModEq.sub_mem.mp (hcLim_spec g hg n))) + /-- Every ideal of the adic completion of a Noetherian local ring is finitely generated. -/ -private def adicCompletion_ideal_fg_proof : PLift ( - ∀ J : Ideal (AdicCompletion (IsLocalRing.maximalIdeal R) R), J.FG ) := ⟨by +private theorem adicCompletion_ideal_fg : + ∀ J : Ideal (AdicCompletion (IsLocalRing.maximalIdeal R) R), J.FG := by set Mi := IsLocalRing.maximalIdeal R intro J have hJ_img_fg : forall n, (Ideal.map (evalₐ Mi n).toRingHom J).FG := fun n => @@ -399,333 +560,87 @@ private def adicCompletion_ideal_fg_proof : PLift ( obtain ⟨r, hr, rfl⟩ := hz simpa only [dite_eq_left hr, SetLike.mem_coe] using hlF_mem r hr refine ⟨genJ ∪ genF, le_antisymm hI0_le_J ?_⟩ - · -- HARD DIRECTION: J ≤ Ideal.span ↑(genJ ∪ genF) - -- It suffices to show ∀ x ∈ J, ∀ N, x ∈ I₀ + M̂^N, then conclude by Hausdorff. - -- Successive approximation (Atiyah-Macdonald Prop 10.11 / Matsumura Thm 8.1). - set Mhat := Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi - have hker_eq : ∀ N, RingHom.ker (evalₐ Mi N).toRingHom = Mhat ^ N := - fun N => ker_evalₐ_eq N - have hgenJ_sub : ∀ a ∈ S_J, (if h : a ∈ S_J then lJ a h else 0) ∈ I₀ := by + -- HARD DIRECTION: J ≤ Ideal.span ↑(genJ ∪ genF), by successive approximation + -- (Atiyah-Macdonald Prop 10.11 / Matsumura Thm 8.1) and Hausdorffness. + set Mhat := Ideal.map (algebraMap R (AdicCompletion Mi R)) Mi + have hker_eq : ∀ N, RingHom.ker (evalₐ Mi N).toRingHom = Mhat ^ N := + fun N => ker_evalₐ_eq N + have hgenJ_sub : ∀ a ∈ S_J, (if h : a ∈ S_J then lJ a h else 0) ∈ I₀ := by + intro a ha + exact Ideal.subset_span (Finset.mem_coe.mpr + (Finset.mem_union_left _ (Finset.mem_image.mpr ⟨a, ha, rfl⟩))) + have hgenF_sub : ∀ r ∈ S_F, (if h : r ∈ S_F then lF r h else 0) ∈ I₀ := by + intro r hr + exact Ideal.subset_span (Finset.mem_coe.mpr + (Finset.mem_union_right _ (Finset.mem_image.mpr ⟨r, hr, rfl⟩))) + have hlift_span : ∀ t : R, t ∈ (Ideal.span ↑S_F : Ideal R) → + ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ + evalₐ Mi (n0 + 1) δ = Ideal.Quotient.mk (Mi ^ (n0 + 1)) t := + lift_span_of_generators R Mi (n0 + 1) S_F I₀ fun r hr => + ⟨_, hgenF_sub r hr, by simpa only [dite_eq_left hr] using hlF_eq r hr⟩ + -- Base approximation: J ≤ I₀ ⊔ Mhat^n0, since I₀ and J have the same image mod Mhat^n0. + have hI0_surj : Ideal.map (evalₐ Mi n0).toRingHom I₀ = Ideal.span ↑S_J := by + apply le_antisymm + · rw [Ideal.map_span] + apply Ideal.span_le.mpr intro a ha - exact Ideal.subset_span (Finset.mem_coe.mpr - (Finset.mem_union_left _ (Finset.mem_image.mpr ⟨a, ha, rfl⟩))) - have hgenF_sub : ∀ r ∈ S_F, (if h : r ∈ S_F then lF r h else 0) ∈ I₀ := by - intro r hr - exact Ideal.subset_span (Finset.mem_coe.mpr - (Finset.mem_union_right _ (Finset.mem_image.mpr ⟨r, hr, rfl⟩))) - have hlift_span : ∀ t : R, t ∈ (Ideal.span ↑S_F : Ideal R) → - ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ - evalₐ Mi (n0 + 1) δ = Ideal.Quotient.mk (Mi ^ (n0 + 1)) t := by - intro t ht - refine Submodule.closure_induction - (p := fun t _ => ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ - evalₐ Mi (n0 + 1) δ = Ideal.Quotient.mk (Mi ^ (n0 + 1)) t) - ?_ ?_ ?_ ht - · -- zero - exact ⟨0, I₀.zero_mem, by simp⟩ - · -- add - intro _ _ _ _ ⟨δ1, hδ1I, hδ1eq⟩ ⟨δ2, hδ2I, hδ2eq⟩ - exact ⟨δ1 + δ2, I₀.add_mem hδ1I hδ2I, by rw [map_add, hδ1eq, hδ2eq, map_add]⟩ - · -- smul_mem: r • t with t ∈ S_F - intro c t ht_mem - have ht_fin : t ∈ S_F := Finset.mem_coe.mp ht_mem - refine ⟨of Mi R c * (if h : t ∈ S_F then lF t h else 0), - I₀.mul_mem_left _ (hgenF_sub t ht_fin), ?_⟩ - simp only [map_mul, evalₐ_of, dite_eq_left ht_fin, hlF_eq, smul_eq_mul] - -- Phase 1: ∀ K x ∈ J, x ∈ I₀ ⊔ Mhat^(n0 + K) - suffices hphase1 : ∀ (K : ℕ) (x : AdicCompletion Mi R), x ∈ J → - x ∈ I₀ ⊔ Mhat ^ (n0 + K) by - -- Phase 2: Conclude J ≤ I₀ - intro x hx - have happrox : ∀ N, x ∈ I₀ ⊔ Mhat ^ N := by - intro N - by_cases hN : n0 ≤ N - · obtain ⟨K, rfl⟩ := Nat.exists_eq_add_of_le hN - exact hphase1 K x hx - · push Not at hN - have h0 := hphase1 0 x hx - rw [Nat.add_zero] at h0 - exact sup_le_sup_left (Ideal.pow_le_pow_right (by omega)) I₀ h0 - -- Phase 2: show x ∈ I₀ via coefficient tracking + IsPrecomplete + IsHausdorff. - have hstep : ∀ K (e : AdicCompletion Mi R), - e ∈ Mhat ^ (n0 + K) → e ∈ J → - ∃ (δ : AdicCompletion Mi R), δ ∈ I₀ ∧ δ ∈ Mhat ^ K ∧ - e - δ ∈ Mhat ^ (n0 + (K + 1)) := by - intro K e he heJ - obtain ⟨r, hr_in_smul, hr_eq⟩ := extract_filtration_rep R Mi J FN n0 K - hFN_def (F_filt.N n0) (fun K => (hn0_pow K).symm) Mhat hker_eq e he heJ - obtain ⟨δ, hδI, hδeq⟩ := smul_lift_of_filtration R Mi n0 K - (FN n0) S_F hS_F I₀ hlift_span r hr_in_smul - refine ⟨δ, hδI, ?_, ?_⟩ - · have he_K : e ∈ Mhat ^ K := Ideal.pow_le_pow_right (Nat.le_add_left K n0) he - have herr : e - δ ∈ Mhat ^ (n0 + (K + 1)) := by - rw [show n0 + (K + 1) = n0 + K + 1 from by omega, ← hker_eq, - RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, - map_sub, hδeq, ← hr_eq, sub_self] - have : δ = e - (e - δ) := by abel - rw [this] - exact (Mhat ^ K).sub_mem he_K (Ideal.pow_le_pow_right (by omega) herr) - · rw [show n0 + (K + 1) = n0 + K + 1 from by omega, ← hker_eq, - RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, - map_sub, hδeq, ← hr_eq, sub_self] - -- Step 2: Build approximation sequence via Nat.rec on Sigma type. - obtain ⟨y₀, hy₀, e₀, he₀, hxye₀⟩ := Submodule.mem_sup.mp (hphase1 0 x hx) - rw [Nat.add_zero] at he₀ - have he₀sub : x - y₀ ∈ Mhat ^ n0 := by - rwa [eq_sub_of_add_eq' hxye₀] at he₀ - let SeqPred (K : ℕ) (y : AdicCompletion Mi R) := - y ∈ I₀ ∧ x - y ∈ Mhat ^ (n0 + K) ∧ x - y ∈ J - have baseData : { y // SeqPred 0 y } := - ⟨y₀, hy₀, by rwa [Nat.add_zero], J.sub_mem hx (hI0_le_J hy₀)⟩ - have stepData : ∀ K, { y // SeqPred K y } → { y // SeqPred (K + 1) y } := - fun K ⟨y_K, hy_K_I, hy_K_err, hy_K_J⟩ => - let hexists := hstep K (x - y_K) hy_K_err hy_K_J - let δ := hexists.choose - let hδ := hexists.choose_spec - ⟨y_K + δ, I₀.add_mem hy_K_I hδ.1, - by rw [show x - (y_K + δ) = (x - y_K) - δ from by abel] - exact hδ.2.2, - J.sub_mem hx (hI0_le_J (I₀.add_mem hy_K_I hδ.1))⟩ - let seqAll := buildAdicSeq baseData stepData - set ySeq : ℕ → AdicCompletion Mi R := fun K => (seqAll K).1 - have hySeq_I₀ : ∀ K, ySeq K ∈ I₀ := fun K => (seqAll K).2.1 - have hySeq_err : ∀ K, x - ySeq K ∈ Mhat ^ (n0 + K) := fun K => (seqAll K).2.2.1 - have hySeq_diff : ∀ K, ySeq (K + 1) - ySeq K ∈ Mhat ^ K := by - intro K - have h1 := hySeq_err K - have h2 := hySeq_err (K + 1) - have hsub : ySeq (K + 1) - ySeq K = (x - ySeq K) - (x - ySeq (K + 1)) := by abel - rw [hsub] - apply (Mhat ^ K).sub_mem - · exact Ideal.pow_le_pow_right (Nat.le_add_left K n0) h1 - · exact Ideal.pow_le_pow_right (by omega) h2 - have hMhat_mem_smul : ∀ K (z : AdicCompletion Mi R), - z ∈ Mhat ^ K ↔ z ∈ Mi ^ K • (⊤ : Submodule R (AdicCompletion Mi R)) := by - intro K z - rw [Ideal.smul_top_eq_map, ← Ideal.map_pow, Submodule.restrictScalars_mem] - -- Step 3: ySeq is Cauchy in the Mi-adic topology - have hySeq_cauchy : ∀ {m n : ℕ}, m ≤ n → - ySeq m ≡ ySeq n [SMOD (Mi ^ m • (⊤ : Submodule R (AdicCompletion Mi R)))] := by - intro m n hmn - rw [SModEq.sub_mem, ← hMhat_mem_smul] - obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hmn - induction d with - | zero => simp [sub_self, (Mhat ^ m).zero_mem] - | succ d ih => - rw [show m + (d + 1) = (m + d) + 1 from by omega] - have hsplit : ySeq m - ySeq ((m + d) + 1) = - (ySeq m - ySeq (m + d)) + -(ySeq ((m + d) + 1) - ySeq (m + d)) := by abel - rw [hsplit] - exact (Mhat ^ m).add_mem (ih (Nat.le_add_right m d)) - ((Mhat ^ m).neg_mem - (Ideal.pow_le_pow_right (Nat.le_add_right m d) (hySeq_diff (m + d)))) - -- Step 4: By IsPrecomplete, get limit L - obtain ⟨L, hL⟩ := IsPrecomplete.prec (adicCompletion_isPrecomplete (R := R)) hySeq_cauchy - -- Step 5: Show x = L by IsHausdorff - have hxL : x = L := by - apply (IsHausdorff.eq_iff_smodEq (I := Mi) (M := AdicCompletion Mi R)).mpr - intro n - rw [SModEq.sub_mem, ← hMhat_mem_smul] - have h1 : x - ySeq n ∈ Mhat ^ n := - Ideal.pow_le_pow_right (Nat.le_add_left n n0) (hySeq_err n) - have h2 : ySeq n - L ∈ Mhat ^ n := by - rw [hMhat_mem_smul] - exact SModEq.sub_mem.mp (hL n) - rw [show x - L = (x - ySeq n) + (ySeq n - L) from by abel] - exact (Mhat ^ n).add_mem h1 h2 - -- Step 6: Show L ∈ I₀ via per-generator Cauchy coefficient sequences. - rw [hxL] - have hySeq_diff_I₀ : ∀ K, ySeq (K + 1) - ySeq K ∈ I₀ := - fun K => I₀.sub_mem (hySeq_I₀ (K + 1)) (hySeq_I₀ K) - let genS := genJ ∪ genF - let sumG (f : AdicCompletion Mi R → AdicCompletion Mi R) := - Finset.sum genS (fun g => f g * g) - have hstep_coeff : ∀ K (e : AdicCompletion Mi R), - e ∈ Mhat ^ (n0 + K) → e ∈ J → - ∃ (c : AdicCompletion Mi R → AdicCompletion Mi R), - (∀ g, g ∈ genS → c g ∈ Mhat ^ K) ∧ - (e - sumG c) ∈ Mhat ^ (n0 + (K + 1)) := by - intro K e he heJ - obtain ⟨r, hr_in_smul, hr_eq⟩ := extract_filtration_rep R Mi J FN n0 K - hFN_def (F_filt.N n0) (fun K => (hn0_pow K).symm) Mhat hker_eq e he heJ - obtain ⟨c, hcM, hceq⟩ := coeff_decomp_of_smul R Mi n0 K (FN n0) S_F hS_F - genS I₀ rfl hlift_span r hr_in_smul - exact ⟨c, hcM, by - rw [show n0 + (K + 1) = n0 + K + 1 from by omega, ← hker_eq, - RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, - map_sub, hceq, ← hr_eq, sub_self]⟩ - -- Step 2: Auxiliary — sum of coeff * gen ∈ I₀ - have hsum_in_I₀ : ∀ (d : AdicCompletion Mi R → AdicCompletion Mi R), - sumG d ∈ I₀ := - fun d => Ideal.sum_mem _ (fun g hg => - I₀.mul_mem_left (d g) (Ideal.subset_span (Finset.mem_coe.mpr hg))) - -- Step 3: Build recursive coefficient sequence via buildAdicSeq - let CSDPred (K : ℕ) (c : AdicCompletion Mi R → AdicCompletion Mi R) := - (x - y₀ - sumG c) ∈ Mhat ^ (n0 + K) ∧ (x - y₀ - sumG c) ∈ J - have hsum_zero : sumG (fun _ => (0 : AdicCompletion Mi R)) = 0 := by - simp only [sumG, zero_mul, Finset.sum_const_zero] - have csd0 : { c // CSDPred 0 c } := ⟨fun _ => 0, by - constructor - · simpa only [hsum_zero, sub_zero, Nat.add_zero] using he₀sub - · show x - y₀ - sumG (fun _ => 0) ∈ _ - rw [hsum_zero, sub_zero] - exact J.sub_mem hx (hI0_le_J hy₀)⟩ - let csdS : ∀ K, { c // CSDPred K c } → { c // CSDPred (K + 1) c } := - fun K ⟨c_K, hMK, hJK⟩ => - let d := (hstep_coeff K _ hMK hJK).choose - let hd := (hstep_coeff K _ hMK hJK).choose_spec - ⟨fun g => c_K g + d g, by - have hsplit : Finset.sum genS (fun g => (c_K g + d g) * g) = - sumG c_K + sumG d := by - simp only [sumG, add_mul, Finset.sum_add_distrib] - have hrw : x - y₀ - Finset.sum genS (fun g => (c_K g + d g) * g) = - (x - y₀ - sumG c_K) - sumG d := by rw [hsplit] - abel - exact ⟨by rw [hrw] - exact hd.2, - by rw [hrw] - exact J.sub_mem hJK (hI0_le_J (hsum_in_I₀ d))⟩⟩ - let csdAll := buildAdicSeq csd0 csdS - let pc : ℕ → AdicCompletion Mi R → AdicCompletion Mi R := fun K => (csdAll K).1 - -- Step 4: Per-step bound: pc(K+1)(g) - pc(K)(g) ∈ Mhat^K - have hpc_diff : ∀ K g, g ∈ genS → - pc (K + 1) g - pc K g ∈ Mhat ^ K := by - intro K g hg - have hcs := hstep_coeff K _ (csdAll K).2.1 (csdAll K).2.2 - have hcsBound : ∀ g, g ∈ genS → hcs.choose g ∈ Mhat ^ K := hcs.choose_spec.1 - change (csdS K (csdAll K)).val g - (csdAll K).val g ∈ Mhat ^ K - have key : ∀ (dat : { c // CSDPred K c }), - (csdS K dat).val g - dat.val g = - (hstep_coeff K _ dat.2.1 dat.2.2).choose g := by - intro ⟨c_K, _, _⟩ - simp only [csdS, add_sub_cancel_left] - rw [key] - exact hcsBound g hg - -- Step 5: Per-generator Cauchy - have hpc_cauchy : ∀ g, g ∈ genS → - ∀ {m n : ℕ}, m ≤ n → - pc m g ≡ pc n g [SMOD (Mi ^ m • ⊤ : Submodule R (AdicCompletion Mi R))] := by - intro g hg m n hmn - rw [SModEq.sub_mem, ← hMhat_mem_smul] - obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le hmn - induction d with - | zero => simp [sub_self, (Mhat ^ m).zero_mem] - | succ d ih => - rw [show m + (d + 1) = (m + d) + 1 from by omega] - have : pc m g - pc ((m + d) + 1) g = - (pc m g - pc (m + d) g) + -(pc ((m + d) + 1) g - pc (m + d) g) := by abel - rw [this] - exact (Mhat ^ m).add_mem (ih (Nat.le_add_right m d)) - ((Mhat ^ m).neg_mem - (Ideal.pow_le_pow_right (Nat.le_add_right m d) (hpc_diff (m + d) g hg))) - -- Step 6: Get per-generator limits via IsPrecomplete - have hpc_lim : ∀ g, g ∈ genS → - ∃ cg, ∀ n, - pc n g ≡ cg [SMOD (Mi ^ n • ⊤ : - Submodule R (AdicCompletion Mi R))] := - fun g hg => IsPrecomplete.prec - (adicCompletion_isPrecomplete (R := R)) - (hpc_cauchy g hg) - let cLim : AdicCompletion Mi R → AdicCompletion Mi R := - fun g => if hg : g ∈ genS then (hpc_lim g hg).choose else 0 - have hcLim_spec : ∀ g, g ∈ genS → ∀ n, - pc n g ≡ cLim g [SMOD (Mi ^ n • ⊤ : Submodule R (AdicCompletion Mi R))] := by - intro g hg n - simpa only [cLim, dite_eq_left hg] using (hpc_lim g hg).choose_spec n - -- Step 7: L = y₀ + ∑ cLim(g) * g by Hausdorff, hence L ∈ I₀ - suffices hL_eq : L = y₀ + sumG cLim from - hL_eq ▸ I₀.add_mem hy₀ (hsum_in_I₀ cLim) - apply (IsHausdorff.eq_iff_smodEq (I := Mi) (M := AdicCompletion Mi R)).mpr - intro n - rw [SModEq.sub_mem, ← hMhat_mem_smul, ← hxL] - have hsplit : x - (y₀ + sumG cLim) = - (x - y₀ - sumG (pc n)) + Finset.sum genS (fun g => (pc n g - cLim g) * g) := by - change x - (y₀ + Finset.sum genS (fun g => cLim g * g)) = - (x - y₀ - Finset.sum genS (fun g => pc n g * g)) + - Finset.sum genS (fun g => (pc n g - cLim g) * g) - simp only [sub_mul, Finset.sum_sub_distrib] - abel - rw [hsplit] - apply (Mhat ^ n).add_mem - · exact Ideal.pow_le_pow_right (Nat.le_add_left n n0) (csdAll n).2.1 - · exact Ideal.sum_mem _ (fun g hg => Ideal.mul_mem_right _ _ - (by - rw [hMhat_mem_smul] - exact SModEq.sub_mem.mp (hcLim_spec g hg n))) - -- Phase 1: induction on K - intro K - induction K with - | zero => - intro x hx - rw [Nat.add_zero] - have heval_x : (evalₐ Mi n0).toRingHom x ∈ Ideal.map (evalₐ Mi n0).toRingHom J := - Ideal.mem_map_of_mem _ hx - rw [← hS_J] at heval_x - suffices hI0_surj : Ideal.map (evalₐ Mi n0).toRingHom I₀ = Ideal.span ↑S_J by - have heval_in : (evalₐ Mi n0).toRingHom x ∈ Ideal.map (evalₐ Mi n0).toRingHom I₀ := - hI0_surj ▸ heval_x - obtain ⟨y, hy, hyx⟩ := (Ideal.mem_map_iff_of_surjective _ - (surjective_evalₐ Mi n0)).mp heval_in - refine Submodule.mem_sup.mpr ⟨y, hy, x - y, ?_, by abel⟩ - rw [← hker_eq, RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, - map_sub, sub_eq_zero] - exact hyx.symm - apply le_antisymm - · rw [Ideal.map_span] - apply Ideal.span_le.mpr - intro a ha - simp only [Set.mem_image, Finset.coe_union, Set.mem_union, Finset.mem_coe] at ha - obtain ⟨g, hg, rfl⟩ := ha - rcases hg with hg | hg - · rw [Finset.mem_image] at hg - obtain ⟨a, ha, rfl⟩ := hg - rw [dite_eq_left ha, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom] - rw [hlJ_eq a ha] - exact Ideal.subset_span ha - · rw [Finset.mem_image] at hg - obtain ⟨r, hr, rfl⟩ := hg - rw [dite_eq_left hr, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom] - have hr_pow : r ∈ Mi ^ n0 := hFN_le n0 (hS_F ▸ Ideal.subset_span hr) - have : (evalₐ Mi n0) (lF r hr) = - Ideal.Quotient.factorPow Mi (Nat.le_succ n0) (evalₐ Mi (n0 + 1) (lF r hr)) := - (factorPow_comp_evalₐ_noeth Mi (Nat.le_succ n0) (lF r hr)).symm - rw [this, hlF_eq r hr] - have hfp_eq : Ideal.Quotient.factorPow Mi (Nat.le_succ n0) = - Ideal.Quotient.factor (Ideal.pow_le_pow_right (Nat.le_succ n0)) := rfl - rw [hfp_eq, Ideal.Quotient.factor_mk, - Ideal.Quotient.eq_zero_iff_mem.mpr hr_pow] - exact Ideal.zero_mem _ - · apply Ideal.span_le.mpr - intro a ha - have ha_fin : a ∈ S_J := ha - exact (Ideal.mem_map_iff_of_surjective _ (surjective_evalₐ Mi n0)).mpr - ⟨if h : a ∈ S_J then lJ a h else 0, hgenJ_sub a ha_fin, by - simpa only [dite_eq_left ha_fin] using hlJ_eq a ha_fin⟩ - | succ K ih => - intro x hx - obtain ⟨y, hy, e, he, hxye⟩ := Submodule.mem_sup.mp (ih x hx) - have he_sub : e = x - y := by rw [← hxye, add_sub_cancel_left] - have heJ : e ∈ J := he_sub ▸ J.sub_mem hx (hI0_le_J hy) - obtain ⟨r, hr_in_smul, hr_eq⟩ := extract_filtration_rep R Mi J FN n0 K - hFN_def (F_filt.N n0) (fun K => (hn0_pow K).symm) Mhat hker_eq e he heJ - obtain ⟨δ, hδI, hδeq⟩ := smul_lift_of_filtration R Mi n0 K (FN n0) S_F - hS_F I₀ hlift_span r hr_in_smul - have hsum : (y + δ) + (e - δ) = x := by - rw [← hxye] - abel - have hmem_ker : e - δ ∈ Mhat ^ (n0 + (K + 1)) := by - rw [show n0 + (K + 1) = n0 + K + 1 from by omega, ← hker_eq, - RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, - map_sub, hδeq, ← hr_eq, sub_self] - exact Submodule.mem_sup.mpr ⟨y + δ, I₀.add_mem hy hδI, e - δ, hmem_ker, hsum⟩ -⟩ - -private lemma adicCompletion_ideal_fg : - ∀ J : Ideal (AdicCompletion (IsLocalRing.maximalIdeal R) R), J.FG := by - exact - (adicCompletion_ideal_fg_proof - R - ).down + simp only [Set.mem_image, Finset.coe_union, Set.mem_union, Finset.mem_coe] at ha + obtain ⟨g, hg, rfl⟩ := ha + rcases hg with hg | hg + · rw [Finset.mem_image] at hg + obtain ⟨a, ha, rfl⟩ := hg + rw [dite_eq_left ha, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom] + rw [hlJ_eq a ha] + exact Ideal.subset_span ha + · rw [Finset.mem_image] at hg + obtain ⟨r, hr, rfl⟩ := hg + rw [dite_eq_left hr, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom] + have hr_pow : r ∈ Mi ^ n0 := hFN_le n0 (hS_F ▸ Ideal.subset_span hr) + have : (evalₐ Mi n0) (lF r hr) = + Ideal.Quotient.factorPow Mi (Nat.le_succ n0) (evalₐ Mi (n0 + 1) (lF r hr)) := + (factorPow_comp_evalₐ_noeth Mi (Nat.le_succ n0) (lF r hr)).symm + rw [this, hlF_eq r hr] + have hfp_eq : Ideal.Quotient.factorPow Mi (Nat.le_succ n0) = + Ideal.Quotient.factor (Ideal.pow_le_pow_right (Nat.le_succ n0)) := rfl + rw [hfp_eq, Ideal.Quotient.factor_mk, + Ideal.Quotient.eq_zero_iff_mem.mpr hr_pow] + exact Ideal.zero_mem _ + · apply Ideal.span_le.mpr + intro a ha + have ha_fin : a ∈ S_J := ha + exact (Ideal.mem_map_iff_of_surjective _ (surjective_evalₐ Mi n0)).mpr + ⟨if h : a ∈ S_J then lJ a h else 0, hgenJ_sub a ha_fin, by + simpa only [dite_eq_left ha_fin] using hlJ_eq a ha_fin⟩ + have hzero : ∀ x ∈ J, x ∈ I₀ ⊔ Mhat ^ n0 := + mem_sup_pow_of_map_evalₐ_le R Mi J I₀ n0 (hker_eq n0) (hI0_surj.trans hS_J).ge + -- Correction step: errors in J ∩ Mhat^(n0+K) are fixed by generator combinations. + have hstep_coeff : ∀ K (e : AdicCompletion Mi R), e ∈ Mhat ^ (n0 + K) → e ∈ J → + ∃ (c : AdicCompletion Mi R → AdicCompletion Mi R), + (∀ g, g ∈ genJ ∪ genF → c g ∈ Mhat ^ K) ∧ + e - Finset.sum (genJ ∪ genF) (fun g => c g * g) ∈ Mhat ^ (n0 + (K + 1)) := by + intro K e he heJ + obtain ⟨r, hr_in_smul, hr_eq⟩ := extract_filtration_rep R Mi J FN n0 K + hFN_def (F_filt.N n0) (fun K => (hn0_pow K).symm) Mhat hker_eq e he heJ + obtain ⟨c, hcM, hceq⟩ := coeff_decomp_of_smul R Mi n0 K (FN n0) S_F hS_F + (genJ ∪ genF) I₀ rfl hlift_span r hr_in_smul + exact ⟨c, hcM, by + rw [show n0 + (K + 1) = n0 + K + 1 from by omega, ← hker_eq, + RingHom.mem_ker, AlgHom.toRingHom_eq_coe, AlgHom.coe_toRingHom, + map_sub, hceq, ← hr_eq, sub_self]⟩ + have hsum_in_I₀ : ∀ (d : AdicCompletion Mi R → AdicCompletion Mi R), + Finset.sum (genJ ∪ genF) (fun g => d g * g) ∈ I₀ := + fun d => Ideal.sum_mem _ (fun g hg => + I₀.mul_mem_left (d g) (Ideal.subset_span (Finset.mem_coe.mpr hg))) + intro x hx + obtain ⟨y₀, hy₀, e₀, he₀, hxye₀⟩ := Submodule.mem_sup.mp (hzero x hx) + have he₀sub : x - y₀ ∈ Mhat ^ n0 := by + rwa [eq_sub_of_add_eq' hxye₀] at he₀ + obtain ⟨c, hc⟩ := exists_coefficients_of_successive_approximation R Mi + (adicCompletion_isPrecomplete (R := R)) J (genJ ∪ genF) n0 hstep_coeff + (fun d => hI0_le_J (hsum_in_I₀ d)) (x - y₀) he₀sub (J.sub_mem hx (hI0_le_J hy₀)) + rw [← sub_add_cancel x y₀, hc] + exact I₀.add_mem (hsum_in_I₀ c) hy₀ + /-- The adic completion of a Noetherian local ring is Noetherian. -/ instance adicCompletion_isNoetherianRing : IsNoetherianRing (AdicCompletion (IsLocalRing.maximalIdeal R) R) := diff --git a/LeanPool/AndersonConjecture/Jensen/Adjoin/Adjoin.lean b/LeanPool/AndersonConjecture/Jensen/Adjoin/Adjoin.lean index 6c3687550c..ba9f01cac7 100644 --- a/LeanPool/AndersonConjecture/Jensen/Adjoin/Adjoin.lean +++ b/LeanPool/AndersonConjecture/Jensen/Adjoin/Adjoin.lean @@ -43,12 +43,227 @@ Given N-subring R and u ∈ T, find an A-extension S containing some c with u - c ∈ M². -/ +/-- A prime of height at most one meeting `R` nontrivially is an associated prime of the +principal ideal generated by some nonzero element of `R`. -/ +private theorem exists_associatedPrime_of_height_le_one (R : NSubring T) (P : Ideal T) + (hP_prime : P.IsPrime) (hP_ht : P.height ≤ 1) + (hPR_ne : P.comap R.carrier.subtype ≠ ⊥) : + ∃ (r₀ : R.carrier), (r₀ : T) ≠ 0 ∧ + P ∈ associatedPrimes T (T ⧸ Ideal.span {(r₀ : T)}) := by + obtain ⟨r₀, hr₀_mem, hr₀_ne⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hPR_ne + have hr₀T_ne : (r₀ : T) ≠ 0 := fun h => hr₀_ne (Subtype.val_injective h) + have hr₀_in_P : (r₀ : T) ∈ P := Ideal.mem_comap.mp hr₀_mem + have hP_minimal : + P ∈ (Ideal.span {(r₀ : T)}).minimalPrimes := by + refine ⟨⟨hP_prime, + Ideal.span_le.mpr + (Set.singleton_subset_iff.mpr hr₀_in_P)⟩, ?_⟩ + intro Q ⟨hQ_prime, hQ_le_span⟩ hQ_le_P + by_contra hPQ + have hQ_ne_P : Q ≠ P := fun h => hPQ (h ▸ le_refl _) + have hQ_ne_bot : Q ≠ ⊥ := fun h => hr₀T_ne + (Ideal.span_singleton_eq_bot.mp (bot_unique (hQ_le_span.trans_eq h))) + have hQ_lt_P : Q < P := lt_of_le_of_ne hQ_le_P hQ_ne_P + have h_bot_lt_Q : (⊥ : Ideal T) < Q := bot_lt_iff_ne_bot.mpr hQ_ne_bot + have h1 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ ⊥ Q + Ideal.isPrime_bot hQ_prime h_bot_lt_Q + have h2 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ Q P hQ_prime hP_prime hQ_lt_P + have h4 : (2 : ℕ∞) ≤ P.height := by + simpa only [Ideal.height_bot, zero_add, one_add_one_eq_two] using + (add_le_add_left h1 1).trans h2 + exact (by norm_num : ¬(2 : ℕ∞) ≤ 1) (h4.trans hP_ht) + have hP_assoc : P ∈ associatedPrimes T (T ⧸ Ideal.span {(r₀ : T)}) := by + have hsub := Module.associatedPrimes.minimalPrimes_annihilator_subset_associatedPrimes + T (T ⧸ Ideal.span {(r₀ : T)}) + rw [Ideal.annihilator_quotient] at hsub + exact hsub hP_minimal + exact ⟨r₀, hr₀T_ne, hP_assoc⟩ + +/-- Cardinality bound for the avoidance step of `adjoin_surjectivity`: the primes and the +shifts to avoid are either fewer than the residue field or countable. -/ +private theorem adjoin_surjectivity_avoidance_bound (R : NSubring T) (u : T) + (φ : (P : Ideal T) → R.carrier →+* T ⧸ P) (liftQ : (P : Ideal T) → T ⧸ P → T) + (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : + let C : Set (Ideal T) := ⋃ (r : R.carrier) (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ Ideal.span {(r : T)}) + let C' : Set (Ideal T) := C ∪ {⊥} + let AlgLocus : Set T := {y : T | ∃ (f : Polynomial R.carrier), + f ≠ 0 ∧ (Polynomial.aeval y f : T) = 0} + let D'_base : Set T := {-u} ∪ ((fun y => y - u) '' AlgLocus) + let D_mod_shifted : Set T := ⋃ P ∈ C, + ⋃ (f : (R.carrier)[X]) (_ : f.map (φ P) ≠ 0), + (fun α => liftQ P α - u) '' { α : T ⧸ P | (f.map (φ P)).IsRoot α } + let D' : Set T := D'_base ∪ D_mod_shifted + Cardinal.mk (C' × D') < Cardinal.mk (IsLocalRing.ResidueField T) ∨ + (C'.Countable ∧ D'.Countable) := by + intro C C' AlgLocus D'_base D_mod_shifted D' + have hC_prime : ∀ P ∈ C, P.IsPrime := by + intro P hP + obtain ⟨r, hr⟩ := mem_iUnion.mp hP + obtain ⟨_, hP_assoc⟩ := mem_iUnion.mp hr + exact hP_assoc.isPrime + by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 + · have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le + have hC_countable : C.Countable := by + apply Set.countable_iUnion + intro r + apply Set.countable_iUnion + intro _ + exact (associatedPrimes.finite T _).countable + have : Countable (Polynomial R.carrier) := + Countable.of_equiv _ ((Polynomial.toFinsuppIso R.carrier).toEquiv.trans + AddMonoidAlgebra.coeffEquiv).symm + have hD'_countable : D'.Countable := by + apply Set.Countable.union + · apply Set.Countable.union (Set.countable_singleton _) + apply Set.Countable.image + apply Set.Countable.mono + (show AlgLocus ⊆ + ⋃ (f : Polynomial R.carrier), f.rootSet T from + fun _ ⟨f, hf, hy⟩ => + mem_iUnion.mpr + ⟨f, Polynomial.mem_rootSet.mpr ⟨hf, hy⟩⟩) + apply Set.countable_iUnion + intro f + exact (Polynomial.rootSet_finite f T).countable + · apply Set.Countable.biUnion hC_countable + intro P hPC + apply Set.countable_iUnion + intro f + apply Set.countable_iUnion + intro hfne + apply Set.Finite.countable + apply Set.Finite.image + have : P.IsPrime := hC_prime P hPC + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + let : DecidableEq (T ⧸ P) := Classical.decEq _ + apply Set.Finite.subset (f.map (φ P)).roots.toFinset.finite_toSet + intro α hα + exact Multiset.mem_toFinset.mpr ((Polynomial.mem_roots hfne).mpr hα) + right + exact ⟨Set.Countable.union hC_countable (Set.countable_singleton _), hD'_countable⟩ + · left + push Not at hR_le + have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le + have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk C + ≤ Cardinal.mk R.carrier * + ⨆ (r : R.carrier), Cardinal.mk ↑(⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ Ideal.span {(r : T)})) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + apply ciSup_le' + intro r + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hr : (r : T) = 0 + · exact Set.Countable.to_subtype (by simp [hr]) + · exact (Set.Finite.subset (associatedPrimes.finite T _) + (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + have hC'_le : Cardinal.mk C' ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk C' + ≤ Cardinal.mk C + Cardinal.mk ↑({⊥} : Set (Ideal T)) := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by + gcongr + exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + have hD'_base_le : Cardinal.mk D'_base ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk D'_base + ≤ Cardinal.mk ↑({-u} : Set T) + + Cardinal.mk ↑((fun y => y - u) '' AlgLocus) := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by + gcongr + · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + · calc Cardinal.mk ↑((fun y => y - u) '' AlgLocus) + ≤ Cardinal.mk AlgLocus := Cardinal.mk_image_le + _ ≤ Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), f.rootSet T) := + Cardinal.mk_le_mk_of_subset (fun _ ⟨f, hf, hy⟩ => + mem_iUnion.mpr ⟨f, Polynomial.mem_rootSet.mpr ⟨hf, hy⟩⟩) + _ ≤ Cardinal.mk (Polynomial R.carrier) * + ⨆ (f : Polynomial R.carrier), Cardinal.mk ↑(f.rootSet T) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) + · apply ciSup_le' + intro f + exact Cardinal.mk_le_aleph0_iff.mpr + (Polynomial.rootSet_finite f T).countable.to_subtype + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + have hD_mod_shifted_le : Cardinal.mk D_mod_shifted ≤ Cardinal.mk R.carrier := by + have h_biUnion : Cardinal.mk ↑(⋃ P ∈ C, ⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ P) f ≠ 0), + (fun α => liftQ P α - u) '' {α | (Polynomial.map (φ P) f).IsRoot α}) ≤ + Cardinal.mk R.carrier := by + apply (Cardinal.mk_biUnion_le _ _).trans + have h_inner : ∀ (x : ↑C), Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), + (fun α => liftQ x.1 α - u) '' {α | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ + Cardinal.mk R.carrier := by + intro ⟨P, hP⟩ + calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ P) f ≠ 0), + (fun α => liftQ P α - u) '' {α | (Polynomial.map (φ P) f).IsRoot α}) + ≤ Cardinal.mk (Polynomial R.carrier) * + ⨆ (f : Polynomial R.carrier), + Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), + (fun α => liftQ P α - u) '' + {α | (Polynomial.map (φ P) f).IsRoot α}) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) + · apply ciSup_le' + intro f + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hfne : Polynomial.map (φ P) f = 0 + · exact Set.Countable.to_subtype (by simp [hfne]) + · have : P.IsPrime := hC_prime P hP + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + apply Set.Countable.to_subtype + apply Set.Finite.countable + apply Set.Finite.subset + (((Polynomial.rootSet_finite + (Polynomial.map (φ P) f) + (T ⧸ P)).image + (liftQ P)).image + (fun x => x - u)) + apply Set.iUnion_subset + intro _ x hx + obtain ⟨α, hα, rfl⟩ := hx + exact ⟨liftQ P α, + ⟨α, Polynomial.mem_rootSet.mpr + ⟨hfne, hα⟩, rfl⟩, rfl⟩ + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + exact (mul_le_mul' hC_le (ciSup_le' h_inner)).trans (Cardinal.mul_eq_self hR_inf).le + exact h_biUnion + have hD'_le : Cardinal.mk D' ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk D' + ≤ Cardinal.mk D'_base + Cardinal.mk D_mod_shifted := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := + add_le_add hD'_base_le hD_mod_shifted_le + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + calc Cardinal.mk (↑C' × ↑D') + = Cardinal.mk C' * Cardinal.mk D' := (Cardinal.mul_def _ _).symm + _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC'_le hD'_le + _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf + _ < Cardinal.mk T := hR_card + _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + /-- Heitmann Lemma 5: Given an N-subring R and u ∈ T, there exists an A-extension S of R with some c ∈ S satisfying u - c ∈ M². Proof: Choose t ∈ M² via avoidance so that u + t is transcendental over R modulo relevant primes. Set S = R[u + t] ∩ M. Then c = u + t. -/ -private def adjoin_surjectivity_proof +theorem adjoin_surjectivity [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (R : NSubring T) (u : T) @@ -58,10 +273,10 @@ private def adjoin_surjectivity_proof ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) : PLift ( + (hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) : ∃ S : NSubring T, IsAExtension R S ∧ - ∃ (c : S.carrier), (u - (c : T)) ∈ IsLocalRing.maximalIdeal T ^ 2 ) := ⟨by + ∃ (c : S.carrier), (u - (c : T)) ∈ IsLocalRing.maximalIdeal T ^ 2 := by have hfind : ∃ (t : T), t ∈ IsLocalRing.maximalIdeal T ^ 2 ∧ Transcendental R.carrier (u + t) ∧ (∀ (P : Ideal T), P.IsPrime → P.height ≤ 1 → @@ -95,7 +310,6 @@ private def adjoin_surjectivity_proof exact Ideal.mul_mem_mul hx hx exact (hP_prime.mem_or_mem (hle hx2)).elim id id exact hC_ne_max P hP (le_antisymm (IsLocalRing.le_maximalIdeal hP_prime.ne_top) hM_le_P) - have hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥ := hM_ne_bot let C' : Set (Ideal T) := C ∪ {⊥} have hC'_prime : ∀ P ∈ C', P.IsPrime := by intro P hP @@ -136,161 +350,8 @@ private def adjoin_surjectivity_proof let D' : Set T := D'_base ∪ D_mod_shifted have hC'D'_bound : Cardinal.mk (C' × D') < Cardinal.mk (IsLocalRing.ResidueField T) ∨ - (C'.Countable ∧ D'.Countable) := by - by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 - · have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le - have hC_countable : C.Countable := by - apply Set.countable_iUnion - intro r - apply Set.countable_iUnion - intro _ - exact (associatedPrimes.finite T _).countable - have : Countable (Polynomial R.carrier) := - Countable.of_equiv _ ((Polynomial.toFinsuppIso R.carrier).toEquiv.trans - AddMonoidAlgebra.coeffEquiv).symm - have hD'_countable : D'.Countable := by - apply Set.Countable.union - · apply Set.Countable.union (Set.countable_singleton _) - apply Set.Countable.image - apply Set.Countable.mono - (show AlgLocus ⊆ - ⋃ (f : Polynomial R.carrier), f.rootSet T from - fun _ ⟨f, hf, hy⟩ => - mem_iUnion.mpr - ⟨f, Polynomial.mem_rootSet.mpr ⟨hf, hy⟩⟩) - apply Set.countable_iUnion - intro f - exact (Polynomial.rootSet_finite f T).countable - · apply Set.Countable.biUnion hC_countable - intro P hPC - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hfne - apply Set.Finite.countable - apply Set.Finite.image - have : P.IsPrime := hC_prime P hPC - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - let : DecidableEq (T ⧸ P) := Classical.decEq _ - apply Set.Finite.subset (f.map (φ P)).roots.toFinset.finite_toSet - intro α hα - exact Multiset.mem_toFinset.mpr ((Polynomial.mem_roots hfne).mpr hα) - right - exact ⟨Set.Countable.union hC_countable (Set.countable_singleton _), hD'_countable⟩ - · left - push Not at hR_le - have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le - have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C - ≤ Cardinal.mk R.carrier * - ⨆ (r : R.carrier), Cardinal.mk ↑(⋃ (_ : (r : T) ≠ 0), - associatedPrimes T (T ⧸ Ideal.span {(r : T)})) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - apply ciSup_le' - intro r - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hr : (r : T) = 0 - · exact Set.Countable.to_subtype (by simp [hr]) - · exact (Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - have hC'_le : Cardinal.mk C' ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C' - ≤ Cardinal.mk C + Cardinal.mk ↑({⊥} : Set (Ideal T)) := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by - gcongr - exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - have hD'_base_le : Cardinal.mk D'_base ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D'_base - ≤ Cardinal.mk ↑({-u} : Set T) + - Cardinal.mk ↑((fun y => y - u) '' AlgLocus) := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - · calc Cardinal.mk ↑((fun y => y - u) '' AlgLocus) - ≤ Cardinal.mk AlgLocus := Cardinal.mk_image_le - _ ≤ Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), f.rootSet T) := - Cardinal.mk_le_mk_of_subset (fun _ ⟨f, hf, hy⟩ => - mem_iUnion.mpr ⟨f, Polynomial.mem_rootSet.mpr ⟨hf, hy⟩⟩) - _ ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), Cardinal.mk ↑(f.rootSet T) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - exact Cardinal.mk_le_aleph0_iff.mpr - (Polynomial.rootSet_finite f T).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - have hD_mod_shifted_le : Cardinal.mk D_mod_shifted ≤ Cardinal.mk R.carrier := by - have h_biUnion : Cardinal.mk ↑(⋃ P ∈ C, ⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - u) '' {α | (Polynomial.map (φ P) f).IsRoot α}) ≤ - Cardinal.mk R.carrier := by - apply (Cardinal.mk_biUnion_le _ _).trans - have h_inner : ∀ (x : ↑C), Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), - (fun α => liftQ x.1 α - u) '' {α | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ - Cardinal.mk R.carrier := by - intro ⟨P, hP⟩ - calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - u) '' {α | (Polynomial.map (φ P) f).IsRoot α}) - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), - Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - u) '' - {α | (Polynomial.map (φ P) f).IsRoot α}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hfne : Polynomial.map (φ P) f = 0 - · exact Set.Countable.to_subtype (by simp [hfne]) - · have : P.IsPrime := hC_prime P hP - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - apply Set.Countable.to_subtype - apply Set.Finite.countable - apply Set.Finite.subset - (((Polynomial.rootSet_finite - (Polynomial.map (φ P) f) - (T ⧸ P)).image - (liftQ P)).image - (fun x => x - u)) - apply Set.iUnion_subset - intro _ x hx - obtain ⟨α, hα, rfl⟩ := hx - exact ⟨liftQ P α, - ⟨α, Polynomial.mem_rootSet.mpr - ⟨hfne, hα⟩, rfl⟩, rfl⟩ - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - exact (mul_le_mul' hC_le (ciSup_le' h_inner)).trans (Cardinal.mul_eq_self hR_inf).le - exact h_biUnion - have hD'_le : Cardinal.mk D' ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D' - ≤ Cardinal.mk D'_base + Cardinal.mk D_mod_shifted := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := - add_le_add hD'_base_le hD_mod_shifted_le - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - calc Cardinal.mk (↑C' × ↑D') - = Cardinal.mk C' * Cardinal.mk D' := (Cardinal.mul_def _ _).symm - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC'_le hD'_le - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - _ < Cardinal.mk T := hR_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + (C'.Countable ∧ D'.Countable) := + adjoin_surjectivity_avoidance_bound R u φ liftQ hR_card hT_card obtain ⟨t, ht_M2, ht_avoid⟩ := avoidance hC'_prime hC'_ne_max hC'D'_bound hM2_not_le' have hut_avoid : ∀ (r : R.carrier), (r : T) ≠ 0 → ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {(r : T)}), @@ -322,33 +383,8 @@ private def adjoin_surjectivity_proof simp only [Polynomial.coeff_map, Polynomial.coeff_zero] at h exact Ideal.mem_comap.mpr (Ideal.Quotient.eq_zero_iff_mem.mp h) have hP_in_C : P ∈ C := by - obtain ⟨r₀, hr₀_mem, hr₀_ne⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hPR_ne - have hr₀T_ne : (r₀ : T) ≠ 0 := fun h => hr₀_ne (Subtype.val_injective h) - have hr₀_in_P : (r₀ : T) ∈ P := Ideal.mem_comap.mp hr₀_mem - have hP_minimal : - P ∈ (Ideal.span {(r₀ : T)}).minimalPrimes := by - refine ⟨⟨hP_prime, - Ideal.span_le.mpr - (Set.singleton_subset_iff.mpr hr₀_in_P)⟩, ?_⟩ - intro Q ⟨hQ_prime, hQ_le_span⟩ hQ_le_P - by_contra hPQ - have hQ_ne_P : Q ≠ P := fun h => hPQ (h ▸ le_refl _) - have hQ_ne_bot : Q ≠ ⊥ := fun h => hr₀T_ne - (Ideal.span_singleton_eq_bot.mp (bot_unique (hQ_le_span.trans_eq h))) - have hQ_lt_P : Q < P := lt_of_le_of_ne hQ_le_P hQ_ne_P - have h_bot_lt_Q : (⊥ : Ideal T) < Q := bot_lt_iff_ne_bot.mpr hQ_ne_bot - have h1 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ ⊥ Q - Ideal.isPrime_bot hQ_prime h_bot_lt_Q - have h2 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ Q P hQ_prime hP_prime hQ_lt_P - have h4 : (2 : ℕ∞) ≤ P.height := by - simpa only [Ideal.height_bot, zero_add, one_add_one_eq_two] using - (add_le_add_left h1 1).trans h2 - exact (by norm_num : ¬(2 : ℕ∞) ≤ 1) (h4.trans hP_ht) - have hP_assoc : P ∈ associatedPrimes T (T ⧸ Ideal.span {(r₀ : T)}) := by - have hsub := Module.associatedPrimes.minimalPrimes_annihilator_subset_associatedPrimes - T (T ⧸ Ideal.span {(r₀ : T)}) - rw [Ideal.annihilator_quotient] at hsub - exact hsub hP_minimal + obtain ⟨r₀, hr₀T_ne, hP_assoc⟩ := + exists_associatedPrime_of_height_le_one R P hP_prime hP_ht hPR_ne exact mem_iUnion.mpr ⟨r₀, mem_iUnion.mpr ⟨hr₀T_ne, hP_assoc⟩⟩ have := hP_prime have ht_root : (f.map (φ P)).IsRoot (Ideal.Quotient.mk P (u + t)) := by @@ -376,24 +412,4 @@ private def adjoin_surjectivity_proof refine ⟨S, hext, ⟨⟨u + t, hut_mem⟩, ?_⟩⟩ simpa only [sub_add_eq_sub_sub, sub_self, zero_sub] using ((IsLocalRing.maximalIdeal T ^ 2).neg_mem ht_M2) -⟩ - -theorem adjoin_surjectivity - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (R : NSubring T) - (u : T) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) : - ∃ S : NSubring T, - IsAExtension R S ∧ - ∃ (c : S.carrier), (u - (c : T)) ∈ IsLocalRing.maximalIdeal T ^ 2 := by - exact - (adjoin_surjectivity_proof - R u hM_not_assoc hAss_ht hR_card hT_card hM_ne_bot - ).down end diff --git a/LeanPool/AndersonConjecture/Jensen/Adjoin/FromPrime.lean b/LeanPool/AndersonConjecture/Jensen/Adjoin/FromPrime.lean index 41612a8eaa..02d1df7f76 100644 --- a/LeanPool/AndersonConjecture/Jensen/Adjoin/FromPrime.lean +++ b/LeanPool/AndersonConjecture/Jensen/Adjoin/FromPrime.lean @@ -45,6 +45,221 @@ Given N-subring R and nonzero prime q of T, find an N-subring S ⊇ R with q ∩ S ≠ (0). This uses avoidance to find a transcendental element in q. -/ +/-- A prime of height at most one meeting `R` nontrivially is an associated prime of the +principal ideal generated by some nonzero element of `R`. -/ +private theorem exists_associatedPrime_of_height_le_one (R : NSubring T) (P : Ideal T) + (hP_prime : P.IsPrime) (hP_ht : P.height ≤ 1) + (hPR_ne : P.comap R.carrier.subtype ≠ ⊥) : + ∃ (r₀ : R.carrier), (r₀ : T) ≠ 0 ∧ + P ∈ associatedPrimes T (T ⧸ Ideal.span {(r₀ : T)}) := by + obtain ⟨r₀, hr₀_mem, hr₀_ne⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hPR_ne + have hr₀T_ne : (r₀ : T) ≠ 0 := fun h => hr₀_ne (Subtype.val_injective h) + have hr₀_in_P : (r₀ : T) ∈ P := Ideal.mem_comap.mp hr₀_mem + -- P minimal over (r₀): ht ≤ 1 prevents strictly smaller primes + have hP_minimal : P ∈ (Ideal.span {(r₀ : T)}).minimalPrimes := by + refine ⟨⟨hP_prime, + Ideal.span_le.mpr + (Set.singleton_subset_iff.mpr hr₀_in_P)⟩, ?_⟩ + intro Q ⟨hQ_prime, hQ_le_span⟩ hQ_le_P + by_contra hPQ + have hQ_ne_P : Q ≠ P := fun h => hPQ (h ▸ le_refl _) + have hQ_ne_bot : Q ≠ ⊥ := by + intro h + exact hr₀T_ne (by simpa only [h, Ideal.mem_bot] using + (hQ_le_span (Ideal.mem_span_singleton_self _))) + have hQ_lt_P : Q < P := lt_of_le_of_ne hQ_le_P hQ_ne_P + have h_bot_lt_Q : (⊥ : Ideal T) < Q := bot_lt_iff_ne_bot.mpr hQ_ne_bot + have h1 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ ⊥ Q + Ideal.isPrime_bot hQ_prime h_bot_lt_Q + have h2 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ Q P + hQ_prime hP_prime hQ_lt_P + have h4 : (2 : ℕ∞) ≤ P.height := by + simpa only [Ideal.height_bot, zero_add, one_add_one_eq_two] using + (add_le_add_left h1 1).trans h2 + exact (by norm_num : ¬(2 : ℕ∞) ≤ 1) (h4.trans hP_ht) + -- Minimal primes of principal ⊆ associated primes of quotient + have hP_assoc : P ∈ associatedPrimes T (T ⧸ Ideal.span {(r₀ : T)}) := by + have hsub := Module.associatedPrimes.minimalPrimes_annihilator_subset_associatedPrimes + T (T ⧸ Ideal.span {(r₀ : T)}) + rw [Ideal.annihilator_quotient] at hsub + exact hsub hP_minimal + exact ⟨r₀, hr₀T_ne, hP_assoc⟩ + +/-- A nonzero element of a prime `q` with `q ∩ R = (0)` is transcendental over `R`: the +constant coefficient of a relation lies in `q ∩ R = (0)`, so the relation is divisible by `X`. -/ +private theorem transcendental_of_mem_of_comap_eq_bot (R : NSubring T) (q : Ideal T) + (hqR : q.comap R.carrier.subtype = ⊥) (t : T) (ht_q : t ∈ q) (ht_ne : t ≠ 0) : + Transcendental R.carrier t := by + rw [Transcendental] + intro ⟨p, hp_ne, hp_eval⟩ + apply hp_ne + clear hp_ne + suffices hinj : ∀ n, ∀ f : (R.carrier)[X], + f.natDegree ≤ n → aeval t f = 0 → f = 0 from + hinj p.natDegree p le_rfl hp_eval + intro n + induction n with + | zero => + intro f hf_deg hf_eval + rw [Polynomial.eq_C_of_natDegree_le_zero hf_deg] at hf_eval ⊢ + apply Polynomial.C_eq_zero.mpr + exact (FaithfulSMul.algebraMap_injective R.carrier T) + (by simpa only [aeval_C, map_zero] using hf_eval) + | succ n ih => + intro f hf_deg hf_eval + -- f.coeff 0 ∈ q ∩ R = ⊥, then f = X * f.divX, apply IH + have hc0 : f.coeff 0 = 0 := by + have hdecomp := Polynomial.X_mul_divX_add f + have heval_decomp : aeval t f = + t * aeval t f.divX + algebraMap R.carrier T (f.coeff 0) := by + conv_lhs => rw [← hdecomp, map_add, map_mul, aeval_X, aeval_C] + have hc_in_q : algebraMap R.carrier T (f.coeff 0) ∈ q := by + have heq : algebraMap R.carrier T (f.coeff 0) = -(t * aeval t f.divX) := by + have h0 := hf_eval + rw [heval_decomp] at h0 + exact eq_neg_of_add_eq_zero_right h0 + rw [heq] + exact q.neg_mem (q.mul_mem_right _ ht_q) + have hc_comap : f.coeff 0 ∈ q.comap R.carrier.subtype := + Ideal.mem_comap.mpr hc_in_q + simpa only [hqR, Ideal.mem_bot] using hc_comap + have hf_eq : f = X * f.divX := by + simpa only [hc0, map_zero, add_zero] using (Polynomial.X_mul_divX_add f).symm + have hdivX_eval : aeval t f.divX = 0 := by + have : aeval t f = t * aeval t f.divX := by + conv_lhs => rw [hf_eq] + rw [map_mul, aeval_X] + rw [hf_eval] at this + exact (mul_eq_zero.mp this.symm).resolve_left ht_ne + have hdivX_deg : f.divX.natDegree ≤ n := by + have := @Polynomial.natDegree_divX_eq_natDegree_tsub_one _ _ f + omega + rw [hf_eq, ih f.divX hdivX_deg hdivX_eval, mul_zero] + +/-- Cardinality bound for the avoidance step of `adjoin_from_prime`: the primes and the +residues to avoid are either fewer than the residue field or countable. -/ +private theorem adjoin_from_prime_avoidance_bound (R : NSubring T) + (φ : (P : Ideal T) → R.carrier →+* T ⧸ P) (liftQ : (P : Ideal T) → T ⧸ P → T) + (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : + let C : Set (Ideal T) := ⋃ (r : R.carrier) (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ Ideal.span {(r : T)}) + let C' : Set (Ideal T) := C ∪ {⊥} + let D_mod : Set T := {0} ∪ + ⋃ (P : Ideal T) (_ : P ∈ C) (f : (R.carrier)[X]) (_ : f.map (φ P) ≠ 0), + liftQ P '' { α : T ⧸ P | (f.map (φ P)).IsRoot α } + Cardinal.mk (C' × D_mod) < Cardinal.mk (IsLocalRing.ResidueField T) ∨ + (C'.Countable ∧ D_mod.Countable) := by + intro C C' D_mod + have hC_prime : ∀ P ∈ C, P.IsPrime := by + intro P hP + obtain ⟨r, hr⟩ := mem_iUnion.mp hP + obtain ⟨_, hP_assoc⟩ := mem_iUnion.mp hr + exact hP_assoc.isPrime + by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 + · -- R countable: use countable avoidance + have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le + have hC_countable : C.Countable := by + apply Set.countable_iUnion + intro r + apply Set.countable_iUnion + intro _ + exact (associatedPrimes.finite T _).countable + have : Countable (Polynomial R.carrier) := + Countable.of_equiv _ ((Polynomial.toFinsuppIso R.carrier).toEquiv.trans + AddMonoidAlgebra.coeffEquiv).symm + right + exact ⟨Set.Countable.union hC_countable (Set.countable_singleton _), + Set.Countable.union (Set.countable_singleton _) + (Set.Countable.biUnion hC_countable fun P hPC => by + apply Set.countable_iUnion + intro f + apply Set.countable_iUnion + intro hfne + apply Set.Finite.countable + apply Set.Finite.image + have : P.IsPrime := hC_prime P hPC + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + let : DecidableEq (T ⧸ P) := Classical.decEq _ + apply Set.Finite.subset (f.map (φ P)).roots.toFinset.finite_toSet + intro α hα + exact Multiset.mem_toFinset.mpr ((Polynomial.mem_roots hfne).mpr hα))⟩ + · -- R uncountable: use cardinality bound + left + push Not at hR_le + have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le + have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk C + ≤ Cardinal.mk R.carrier * + ⨆ (r : R.carrier), Cardinal.mk ↑(⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ Ideal.span {(r : T)})) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + apply ciSup_le' + intro r + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hr : (r : T) = 0 + · exact Set.Countable.to_subtype (by simp [hr]) + · exact (Set.Finite.subset (associatedPrimes.finite T _) + (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + have hC'_le : Cardinal.mk C' ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk C' + ≤ Cardinal.mk C + Cardinal.mk ↑({⊥} : Set (Ideal T)) := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by + gcongr + exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + have hD_le : Cardinal.mk D_mod ≤ Cardinal.mk R.carrier := by + have h_biUnion : Cardinal.mk ↑(⋃ P ∈ C, ⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ P) f ≠ 0), + liftQ P '' {α | (Polynomial.map (φ P) f).IsRoot α}) ≤ + Cardinal.mk R.carrier := by + apply (Cardinal.mk_biUnion_le _ _).trans + have h_inner : ∀ (x : ↑C), Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), + liftQ x.1 '' {α | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ + Cardinal.mk R.carrier := by + intro ⟨P, hP⟩ + calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ P) f ≠ 0), + liftQ P '' {α | (Polynomial.map (φ P) f).IsRoot α}) + ≤ Cardinal.mk (Polynomial R.carrier) * + ⨆ (f : Polynomial R.carrier), + Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), + liftQ P '' {α | (Polynomial.map (φ P) f).IsRoot α}) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) + · apply ciSup_le' + intro f + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hfne : Polynomial.map (φ P) f = 0 + · exact Set.Countable.to_subtype (by simp [hfne]) + · have : P.IsPrime := hC_prime P hP + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + exact (Set.Finite.subset + ((Polynomial.rootSet_finite (Polynomial.map (φ P) f) (T ⧸ P)).image + (liftQ P)) + (Set.iUnion_subset fun _ => Set.image_mono fun α hα => + Polynomial.mem_rootSet.mpr ⟨hfne, hα⟩)).countable.to_subtype + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + exact (mul_le_mul' hC_le (ciSup_le' h_inner)).trans (Cardinal.mul_eq_self hR_inf).le + exact (Cardinal.mk_union_le _ _).trans (le_trans (add_le_add + ((Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf)) + h_biUnion) (Cardinal.add_eq_left hR_inf le_rfl).le) + calc Cardinal.mk (↑C' × ↑D_mod) + = Cardinal.mk C' * Cardinal.mk D_mod := (Cardinal.mul_def _ _).symm + _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC'_le hD_le + _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf + _ < Cardinal.mk T := hR_card + _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + /-- Jensen Lemma 2.1 (P = (0) case): Given an N-subring R and a nonzero prime ideal q of T, there exists an N-subring S ⊇ R with q ∩ S ≠ {0}, @@ -52,7 +267,7 @@ there exists an N-subring S ⊇ R with q ∩ S ≠ {0}, Proof idea: Use avoidance (Lemma 3) to find t ∈ q that is transcendental over R modulo all relevant primes. Then S = R[t]_{R[t] ∩ M}. -/ -private def adjoin_from_prime_proof +theorem adjoin_from_prime [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (R : NSubring T) (q : Ideal T) (hq_prime : q.IsPrime) (hq_ne_bot : q ≠ ⊥) @@ -61,10 +276,10 @@ private def adjoin_from_prime_proof (hAss_ht : ∀ (r : T), r ≠ 0 → ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : PLift ( + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : ∃ S : NSubring T, IsAExtension R S ∧ - ∃ (t : S.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0 ) := ⟨by + ∃ (t : S.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0 := by -- Case split on q ∩ R by_cases hqR : q.comap R.carrier.subtype = ⊥ swap @@ -163,110 +378,8 @@ private def adjoin_from_prime_proof have h0_in_D : (0 : T) ∈ D_mod := Set.mem_union_left _ rfl have hCD'_bound : Cardinal.mk (C' × D_mod) < Cardinal.mk (IsLocalRing.ResidueField T) ∨ - (C'.Countable ∧ D_mod.Countable) := by - by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 - · -- R countable: use countable avoidance - have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le - have hC_countable : C.Countable := by - apply Set.countable_iUnion - intro r - apply Set.countable_iUnion - intro _ - exact (associatedPrimes.finite T _).countable - have : Countable (Polynomial R.carrier) := - Countable.of_equiv _ ((Polynomial.toFinsuppIso R.carrier).toEquiv.trans - AddMonoidAlgebra.coeffEquiv).symm - right - exact ⟨Set.Countable.union hC_countable (Set.countable_singleton _), - Set.Countable.union (Set.countable_singleton _) - (Set.Countable.biUnion hC_countable fun P hPC => by - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hfne - apply Set.Finite.countable - apply Set.Finite.image - have : P.IsPrime := hC_prime P hPC - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - let : DecidableEq (T ⧸ P) := Classical.decEq _ - apply Set.Finite.subset (f.map (φ P)).roots.toFinset.finite_toSet - intro α hα - exact Multiset.mem_toFinset.mpr ((Polynomial.mem_roots hfne).mpr hα))⟩ - · -- R uncountable: use cardinality bound - left - push Not at hR_le - have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le - have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C - ≤ Cardinal.mk R.carrier * - ⨆ (r : R.carrier), Cardinal.mk ↑(⋃ (_ : (r : T) ≠ 0), - associatedPrimes T (T ⧸ Ideal.span {(r : T)})) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - apply ciSup_le' - intro r - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hr : (r : T) = 0 - · exact Set.Countable.to_subtype (by simp [hr]) - · exact (Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - have hC'_le : Cardinal.mk C' ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C' - ≤ Cardinal.mk C + Cardinal.mk ↑({⊥} : Set (Ideal T)) := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by - gcongr - exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - have hD_le : Cardinal.mk D_mod ≤ Cardinal.mk R.carrier := by - have h_biUnion : Cardinal.mk ↑(⋃ P ∈ C, ⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - liftQ P '' {α | (Polynomial.map (φ P) f).IsRoot α}) ≤ - Cardinal.mk R.carrier := by - apply (Cardinal.mk_biUnion_le _ _).trans - have h_inner : ∀ (x : ↑C), Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), - liftQ x.1 '' {α | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ - Cardinal.mk R.carrier := by - intro ⟨P, hP⟩ - calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - liftQ P '' {α | (Polynomial.map (φ P) f).IsRoot α}) - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), - Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), - liftQ P '' {α | (Polynomial.map (φ P) f).IsRoot α}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hfne : Polynomial.map (φ P) f = 0 - · exact Set.Countable.to_subtype (by simp [hfne]) - · have : P.IsPrime := hC_prime P hP - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - exact (Set.Finite.subset - ((Polynomial.rootSet_finite (Polynomial.map (φ P) f) (T ⧸ P)).image - (liftQ P)) - (Set.iUnion_subset fun _ => Set.image_mono fun α hα => - Polynomial.mem_rootSet.mpr ⟨hfne, hα⟩)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - exact (mul_le_mul' hC_le (ciSup_le' h_inner)).trans (Cardinal.mul_eq_self hR_inf).le - exact (Cardinal.mk_union_le _ _).trans (le_trans (add_le_add - ((Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf)) - h_biUnion) (Cardinal.add_eq_left hR_inf le_rfl).le) - calc Cardinal.mk (↑C' × ↑D_mod) - = Cardinal.mk C' * Cardinal.mk D_mod := (Cardinal.mul_def _ _).symm - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC'_le hD_le - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - _ < Cardinal.mk T := hR_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + (C'.Countable ∧ D_mod.Countable) := + adjoin_from_prime_avoidance_bound R φ liftQ hR_card hT_card -- Apply avoidance to get t ∈ q avoiding all P + d for P ∈ C', d ∈ D_mod obtain ⟨t, ht_q, ht_avoid⟩ := avoidance hC'_prime hC'_ne_max hCD'_bound hq_not_le' have ht_ne : t ≠ 0 := by @@ -282,52 +395,8 @@ private def adjoin_from_prime_proof exact ht_avoid P hP_in_C' 0 h0_in_D ⟨t, ht_in_P, 0, rfl, by simp⟩ -- Transcendence by induction on natDegree: f.coeff 0 ∈ q ∩ R = ⊥, then divide by X - have ht_trans : Transcendental R.carrier t := by - rw [Transcendental] - intro ⟨p, hp_ne, hp_eval⟩ - apply hp_ne - clear hp_ne - suffices hinj : ∀ n, ∀ f : (R.carrier)[X], - f.natDegree ≤ n → aeval t f = 0 → f = 0 from - hinj p.natDegree p le_rfl hp_eval - intro n - induction n with - | zero => - intro f hf_deg hf_eval - rw [Polynomial.eq_C_of_natDegree_le_zero hf_deg] at hf_eval ⊢ - apply Polynomial.C_eq_zero.mpr - exact (FaithfulSMul.algebraMap_injective R.carrier T) - (by simpa only [aeval_C, map_zero] using hf_eval) - | succ n ih => - intro f hf_deg hf_eval - -- f.coeff 0 ∈ q ∩ R = ⊥, then f = X * f.divX, apply IH - have hc0 : f.coeff 0 = 0 := by - have hdecomp := Polynomial.X_mul_divX_add f - have heval_decomp : aeval t f = - t * aeval t f.divX + algebraMap R.carrier T (f.coeff 0) := by - conv_lhs => rw [← hdecomp, map_add, map_mul, aeval_X, aeval_C] - have hc_in_q : algebraMap R.carrier T (f.coeff 0) ∈ q := by - have heq : algebraMap R.carrier T (f.coeff 0) = -(t * aeval t f.divX) := by - have h0 := hf_eval - rw [heval_decomp] at h0 - exact eq_neg_of_add_eq_zero_right h0 - rw [heq] - exact q.neg_mem (q.mul_mem_right _ ht_q) - have hc_comap : f.coeff 0 ∈ q.comap R.carrier.subtype := - Ideal.mem_comap.mpr hc_in_q - simpa only [hqR, Ideal.mem_bot] using hc_comap - have hf_eq : f = X * f.divX := by - simpa only [hc0, map_zero, add_zero] using (Polynomial.X_mul_divX_add f).symm - have hdivX_eval : aeval t f.divX = 0 := by - have : aeval t f = t * aeval t f.divX := by - conv_lhs => rw [hf_eq] - rw [map_mul, aeval_X] - rw [hf_eval] at this - exact (mul_eq_zero.mp this.symm).resolve_left ht_ne - have hdivX_deg : f.divX.natDegree ≤ n := by - have := @Polynomial.natDegree_divX_eq_natDegree_tsub_one _ _ f - omega - rw [hf_eq, ih f.divX hdivX_deg hdivX_eval, mul_zero] + have ht_trans : Transcendental R.carrier t := + transcendental_of_mem_of_comap_eq_bot R q hqR t ht_q ht_ne -- Modular transcendence: f(t) ∈ P implies all coefficients in P ∩ R have ht_mod_trans : ∀ (P : Ideal T), P.IsPrime → P.height ≤ 1 → P.comap R.carrier.subtype ≠ ⊥ → @@ -344,37 +413,8 @@ private def adjoin_from_prime_proof exact Ideal.mem_comap.mpr (Ideal.Quotient.eq_zero_iff_mem.mp h) -- P ∈ C: find nonzero r₀ ∈ P ∩ R, show P is minimal over (r₀) have hP_in_C : P ∈ C := by - obtain ⟨r₀, hr₀_mem, hr₀_ne⟩ := Submodule.exists_mem_ne_zero_of_ne_bot hPR_ne - have hr₀T_ne : (r₀ : T) ≠ 0 := fun h => hr₀_ne (Subtype.val_injective h) - have hr₀_in_P : (r₀ : T) ∈ P := Ideal.mem_comap.mp hr₀_mem - -- P minimal over (r₀): ht ≤ 1 prevents strictly smaller primes - have hP_minimal : P ∈ (Ideal.span {(r₀ : T)}).minimalPrimes := by - refine ⟨⟨hP_prime, - Ideal.span_le.mpr - (Set.singleton_subset_iff.mpr hr₀_in_P)⟩, ?_⟩ - intro Q ⟨hQ_prime, hQ_le_span⟩ hQ_le_P - by_contra hPQ - have hQ_ne_P : Q ≠ P := fun h => hPQ (h ▸ le_refl _) - have hQ_ne_bot : Q ≠ ⊥ := by - intro h - exact hr₀T_ne (by simpa only [h, Ideal.mem_bot] using - (hQ_le_span (Ideal.mem_span_singleton_self _))) - have hQ_lt_P : Q < P := lt_of_le_of_ne hQ_le_P hQ_ne_P - have h_bot_lt_Q : (⊥ : Ideal T) < Q := bot_lt_iff_ne_bot.mpr hQ_ne_bot - have h1 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ ⊥ Q - Ideal.isPrime_bot hQ_prime h_bot_lt_Q - have h2 := @Ideal.height_add_one_le_of_lt_of_isPrime T _ Q P - hQ_prime hP_prime hQ_lt_P - have h4 : (2 : ℕ∞) ≤ P.height := by - simpa only [Ideal.height_bot, zero_add, one_add_one_eq_two] using - (add_le_add_left h1 1).trans h2 - exact (by norm_num : ¬(2 : ℕ∞) ≤ 1) (h4.trans hP_ht) - -- Minimal primes of principal ⊆ associated primes of quotient - have hP_assoc : P ∈ associatedPrimes T (T ⧸ Ideal.span {(r₀ : T)}) := by - have hsub := Module.associatedPrimes.minimalPrimes_annihilator_subset_associatedPrimes - T (T ⧸ Ideal.span {(r₀ : T)}) - rw [Ideal.annihilator_quotient] at hsub - exact hsub hP_minimal + obtain ⟨r₀, hr₀T_ne, hP_assoc⟩ := + exists_associatedPrime_of_height_le_one R P hP_prime hP_ht hPR_ne exact mem_iUnion.mpr ⟨r₀, mem_iUnion.mpr ⟨hr₀T_ne, hP_assoc⟩⟩ have := hP_prime have ht_root : (f.map (φ P)).IsRoot (Ideal.Quotient.mk P t) := by @@ -399,23 +439,4 @@ private def adjoin_from_prime_proof obtain ⟨S, hext, ht_mem⟩ := adjoin_transcendental_isNSubring R t ht_trans hAss_ht ht_mod_trans exact ⟨S, hext, ⟨⟨t, ht_mem⟩, ht_q, ht_ne⟩⟩ -⟩ - -theorem adjoin_from_prime - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (R : NSubring T) - (q : Ideal T) (hq_prime : q.IsPrime) (hq_ne_bot : q ≠ ⊥) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : - ∃ S : NSubring T, - IsAExtension R S ∧ - ∃ (t : S.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0 := by - exact - (adjoin_from_prime_proof - R q hq_prime hq_ne_bot hM_not_assoc hAss_ht hR_card hT_card - ).down end diff --git a/LeanPool/AndersonConjecture/Jensen/CloseUp/AvoidanceStep.lean b/LeanPool/AndersonConjecture/Jensen/CloseUp/AvoidanceStep.lean index 29956e12c5..f1917d63a4 100644 --- a/LeanPool/AndersonConjecture/Jensen/CloseUp/AvoidanceStep.lean +++ b/LeanPool/AndersonConjecture/Jensen/CloseUp/AvoidanceStep.lean @@ -38,7 +38,415 @@ open Cardinal Ideal variable {T : Type*} [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] -private def close_up_avoidance_step_proof +omit [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] in +/-- A chosen lift to `T` of an element of `T ⧸ P`. -/ +private def quotientLift (P : Ideal T) (α : T ⧸ P) : T := + (Ideal.Quotient.mk_surjective α).choose + +omit [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] in +private lemma quotientLift_spec (P : Ideal T) (α : T ⧸ P) : + Ideal.Quotient.mk P (quotientLift P α) = α := + (Ideal.Quotient.mk_surjective α).choose_spec + +/-- The primes to avoid: associated primes of nonzero principal ideals generated by elements of +`R` that do not contain `I`, together with `⊥`. -/ +private def avoidanceGoodPrimes (R : NSubring T) (I : Ideal T) : Set (Ideal T) := + (⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + {P ∈ associatedPrimes T (T ⧸ span {(r : T)}) | ¬(I ≤ P)}) ∪ {⊥} + +/-- Absolute transcendence obstacles: `-t` and the roots of nonzero polynomials over `R`, +shifted by `-t`. -/ +private def avoidanceBaseObstacles (R : NSubring T) (t : T) : Set T := + {-t} ∪ ⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), + (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0} + +/-- Modular transcendence obstacles at a prime `P`: lifts of roots of nonzero reductions of +polynomials over `R` modulo `P`, shifted by `-t`. -/ +private def avoidanceModFiber (R : NSubring T) (t : T) (P : Ideal T) : Set T := + ⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f ≠ 0), + (fun α => quotientLift P α - t) '' + {α : T ⧸ P | (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).IsRoot α} + +/-- All the elements `δ` must avoid modulo the good primes. -/ +private def avoidanceObstacles (R : NSubring T) (I : Ideal T) (t : T) : Set T := + avoidanceBaseObstacles R t ∪ ⋃ P ∈ avoidanceGoodPrimes R I, avoidanceModFiber R t P + +private lemma avoidanceGoodPrimes_isPrime {R : NSubring T} {I P : Ideal T} + (hP : P ∈ avoidanceGoodPrimes R I) : P.IsPrime := by + unfold avoidanceGoodPrimes at hP + rcases (Set.mem_union _ _ _).mp hP with h | h + · rw [Set.mem_iUnion] at h + obtain ⟨r, h⟩ := h + rw [Set.mem_iUnion] at h + obtain ⟨_, hPmem⟩ := h + exact hPmem.1.isPrime + · exact Set.mem_singleton_iff.mp h ▸ Ideal.isPrime_bot + +private lemma avoidanceGoodPrimes_ne_maximalIdeal {R : NSubring T} {I P : Ideal T} + (hM_not_assoc : ∀ (r : T), r ≠ 0 → + IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) + (hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) + (hP : P ∈ avoidanceGoodPrimes R I) : P ≠ IsLocalRing.maximalIdeal T := by + unfold avoidanceGoodPrimes at hP + rcases (Set.mem_union _ _ _).mp hP with h | h + · rw [Set.mem_iUnion] at h + obtain ⟨r, h⟩ := h + rw [Set.mem_iUnion] at h + obtain ⟨hr, hPmem⟩ := h + exact fun heq => hM_not_assoc (r : T) hr (heq ▸ hPmem.1) + · rw [Set.mem_singleton_iff.mp h] + exact fun h => hM_ne_bot h.symm + +private lemma avoidanceGoodPrimes_not_le {R : NSubring T} {I P : Ideal T} (hI_bot : I ≠ ⊥) + (hP : P ∈ avoidanceGoodPrimes R I) : ¬(I ≤ P) := by + intro hle + unfold avoidanceGoodPrimes at hP + rcases (Set.mem_union _ _ _).mp hP with h | h + · rw [Set.mem_iUnion] at h + obtain ⟨r, h⟩ := h + rw [Set.mem_iUnion] at h + obtain ⟨_, hPmem⟩ := h + exact hPmem.2 hle + · rw [Set.mem_singleton_iff.mp h] at hle + exact hI_bot (le_antisymm hle bot_le) + +private lemma avoidance_root_shift_countable (R : NSubring T) (t : T) + (f : Polynomial R.carrier) (hf : f ≠ 0) : + ((fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}).Countable := by + apply Set.Countable.image + have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by + rw [Ne, ← Polynomial.map_zero R.carrier.subtype] + exact (Polynomial.map_injective R.carrier.subtype + Subtype.val_injective).ne hf + have h_eq : {x : T | Polynomial.aeval x f = 0} = + {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} := by + ext x + simp [Polynomial.IsRoot, Polynomial.aeval_def, Polynomial.eval_map, + show algebraMap R.carrier T = R.carrier.subtype from rfl] + rw [h_eq] + exact (Polynomial.finite_setOfPred_isRoot hmap_ne).countable + +/-- When `R` is countable, the good primes and all obstacles are countable. -/ +private lemma avoidance_countable_of_countable (R : NSubring T) (I : Ideal T) (t : T) + (hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0) : + (avoidanceGoodPrimes R I).Countable ∧ (avoidanceObstacles R I t).Countable := by + have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le + have : Countable (Polynomial R.carrier) := by + let : Countable (AddMonoidAlgebra R.carrier ℕ) := + Countable.of_equiv _ AddMonoidAlgebra.coeffEquiv.symm + exact Polynomial.toFinsupp_injective.countable + have hC_good_countable : (avoidanceGoodPrimes R I).Countable := by + unfold avoidanceGoodPrimes + exact Set.Countable.union (Set.countable_iUnion fun r => + Set.countable_iUnion fun _ => + ((associatedPrimes.finite T (T ⧸ span {(r : T)})).subset + fun P hP => hP.1).countable) (Set.countable_singleton _) + have hD_base_countable : (avoidanceBaseObstacles R t).Countable := + Set.Countable.union (Set.countable_singleton _) + (Set.countable_iUnion fun f => Set.countable_iUnion fun hf => + avoidance_root_shift_countable R t f hf) + have hD_mod_countable : + (⋃ P ∈ avoidanceGoodPrimes R I, avoidanceModFiber R t P).Countable := by + apply Set.Countable.biUnion hC_good_countable + intro P hP + apply Set.countable_iUnion + intro f + apply Set.countable_iUnion + intro hfne + apply Set.Countable.image + have : P.IsPrime := avoidanceGoodPrimes_isPrime hP + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + exact (Polynomial.finite_setOfPred_isRoot hfne).countable + exact ⟨hC_good_countable, Set.Countable.union hD_base_countable hD_mod_countable⟩ + +private lemma avoidanceGoodPrimes_card_le (R : NSubring T) (I : Ideal T) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) : + Cardinal.mk (avoidanceGoodPrimes R I) ≤ Cardinal.mk R.carrier := by + unfold avoidanceGoodPrimes + calc _ ≤ Cardinal.mk ↑(⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + {P ∈ associatedPrimes T (T ⧸ span {(r : T)}) | ¬(I ≤ P)}) + + Cardinal.mk ↑({⊥} : Set (Ideal T)) := Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 + Cardinal.mk R.carrier := by + gcongr + · exact (Cardinal.mk_iUnion_le _).trans + (mul_le_mul_right (ciSup_le' fun r => by + exact Cardinal.mk_le_aleph0_iff.mpr + ((Set.Finite.subset (associatedPrimes.finite T _) + (Set.iUnion_subset fun _ => fun P hP => hP.1)).countable.to_subtype)) _) + · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + _ = Cardinal.mk R.carrier := by + rw [Cardinal.mul_aleph0_eq hR_inf, Cardinal.add_eq_left hR_inf le_rfl] + +private lemma avoidanceBaseObstacles_card_le (R : NSubring T) (t : T) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) : + Cardinal.mk (avoidanceBaseObstacles R t) ≤ Cardinal.mk R.carrier := by + unfold avoidanceBaseObstacles + calc _ ≤ Cardinal.mk ↑({-t} : Set T) + + Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), + (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by + gcongr + · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + · exact (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' + (Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf)) + (ciSup_le' fun f => Cardinal.mk_le_aleph0_iff.mpr (by + by_cases hf : f = 0 + · exact Set.Countable.to_subtype (by simp [hf]) + · exact (Set.countable_iUnion fun _ => + avoidance_root_shift_countable R t f hf).to_subtype))).trans + (Cardinal.mul_aleph0_eq hR_inf).le) + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + +private lemma avoidanceModFiber_card_le (R : NSubring T) (t : T) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) (P : Ideal T) [P.IsPrime] : + Cardinal.mk (avoidanceModFiber R t P) ≤ Cardinal.mk R.carrier := by + unfold avoidanceModFiber + refine (Cardinal.mk_iUnion_le _).trans ?_ + calc _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) + · apply ciSup_le' + intro f + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hfne : Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f = 0 + · exact Set.Countable.to_subtype (by simp [hfne]) + · have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + apply Set.Countable.to_subtype + apply Set.Finite.countable + apply Set.Finite.subset + (((Polynomial.rootSet_finite + (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f) + (T ⧸ P)).image (quotientLift P)).image (fun x => x - t)) + apply Set.iUnion_subset + intro _ x hx + obtain ⟨α, hα, rfl⟩ := hx + exact ⟨quotientLift P α, ⟨α, Polynomial.mem_rootSet.mpr ⟨hfne, hα⟩, rfl⟩, rfl⟩ + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + +private lemma avoidanceObstacles_card_le (R : NSubring T) (I : Ideal T) (t : T) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) : + Cardinal.mk (avoidanceObstacles R I t) ≤ Cardinal.mk R.carrier := by + have hD_mod_le : Cardinal.mk ↑(⋃ P ∈ avoidanceGoodPrimes R I, avoidanceModFiber R t P) ≤ + Cardinal.mk R.carrier := by + apply (Cardinal.mk_biUnion_le _ _).trans + refine (mul_le_mul' (avoidanceGoodPrimes_card_le R I hR_inf) (ciSup_le' fun x => ?_)).trans + (Cardinal.mul_eq_self hR_inf).le + have : x.1.IsPrime := avoidanceGoodPrimes_isPrime x.2 + exact avoidanceModFiber_card_le R t hR_inf x.1 + unfold avoidanceObstacles + calc _ ≤ Cardinal.mk (avoidanceBaseObstacles R t) + + Cardinal.mk ↑(⋃ P ∈ avoidanceGoodPrimes R I, avoidanceModFiber R t P) := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := + add_le_add (avoidanceBaseObstacles_card_le R t hR_inf) hD_mod_le + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + +/-- The cardinality hypothesis of `avoidance` for the good primes and obstacles. -/ +private lemma avoidance_cardinal_bound (R : NSubring T) (I : Ideal T) (t : T) + (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : + Cardinal.mk (↑(avoidanceGoodPrimes R I) × ↑(avoidanceObstacles R I t)) < + Cardinal.mk (IsLocalRing.ResidueField T) ∨ + ((avoidanceGoodPrimes R I).Countable ∧ (avoidanceObstacles R I t).Countable) := by + by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 + · exact Or.inr (avoidance_countable_of_countable R I t hR_le) + · left + push Not at hR_le + have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le + calc Cardinal.mk (↑(avoidanceGoodPrimes R I) × ↑(avoidanceObstacles R I t)) + = Cardinal.mk (avoidanceGoodPrimes R I) * Cardinal.mk (avoidanceObstacles R I t) := + (Cardinal.mul_def _ _).symm + _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := + mul_le_mul' (avoidanceGoodPrimes_card_le R I hR_inf) + (avoidanceObstacles_card_le R I t hR_inf) + _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf + _ < Cardinal.mk T := hR_card + _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + +/-- If no prime of `R` divides every element of `s'`, then the extension of the ideal +generated by `s'` is contained in no associated prime of a nonzero principal ideal. -/ +private lemma span_not_le_associatedPrime (R : NSubring T) (s' : Finset R.carrier) + (hI_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) + (h_no_common : ∀ (q : R.carrier), Prime q → ¬(∀ x ∈ s', q ∣ x)) + (r : R.carrier) (hr : (r : T) ≠ 0) (P : Ideal T) + (hP_mem : P ∈ associatedPrimes T (T ⧸ span {(r : T)})) : + ¬(Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≤ P) := by + have : UniqueFactorizationMonoid R.carrier := R.isUFD + intro hle + have hht := R.height_bound (r : T) hr P hP_mem + by_cases hcomap : P.comap R.carrier.subtype = ⊥ + · -- P ∩ R = ⊥: all s' zero, I_s' = ⊥ + exact hI_bot (le_antisymm (by + apply Ideal.map_le_iff_le_comap.mpr + apply Ideal.span_le.mpr + intro x hx + have h1 : x ∈ P.comap R.carrier.subtype := + Ideal.mem_comap.mpr (hle (Ideal.mem_map_of_mem _ + (Ideal.subset_span (Finset.mem_coe.mpr hx)))) + have h1' : x ∈ (⊥ : Ideal R.carrier) := hcomap ▸ h1 + have hx_zero : x = 0 := (Submodule.mem_bot _).mp h1' + change R.carrier.subtype x ∈ (⊥ : Ideal T) + rw [hx_zero, map_zero] + exact (Submodule.mem_bot T).mpr rfl) bot_le) + · -- P ∩ R ≠ ⊥: find q_P, contradiction from h_no_common + have : (P.comap R.carrier.subtype).IsPrime := hP_mem.isPrime.comap _ + obtain ⟨q_P, hqP_prime, hqP_in⟩ := + exists_prime_mem_of_ne_bot_closeup (P.comap R.carrier.subtype) hcomap + have hQ_eq : Ideal.span {q_P} = P.comap R.carrier.subtype := + @eq_of_prime_le_prime_height_le_one R.carrier _ (NSubring.isDomain R) _ _ + ((Ideal.span_singleton_prime hqP_prime.ne_zero).mpr hqP_prime) + (hP_mem.isPrime.comap _) + (Ideal.span_le.mpr (Set.singleton_subset_iff.mpr hqP_in)) + (mt (Ideal.span_singleton_eq_bot (α := R.carrier)).mp hqP_prime.ne_zero) hht + have hqP_dvd_s' : ∀ x ∈ s', q_P ∣ x := fun x hx => + (Ideal.mem_span_singleton (α := R.carrier)).mp + (hQ_eq ▸ Ideal.mem_comap.mpr (hle (Ideal.mem_map_of_mem _ + (Ideal.subset_span (Finset.mem_coe.mpr hx))))) + exact h_no_common q_P hqP_prime hqP_dvd_s' + +open scoped Pointwise in +/-- An element avoiding all obstacles modulo `⊥` makes `t + δ` transcendental over `R`. -/ +private lemma avoidance_shift_transcendental (R : NSubring T) (I : Ideal T) (t δ : T) + (hδ_avoid : ∀ P ∈ avoidanceGoodPrimes R I, ∀ r ∈ avoidanceObstacles R I t, + δ ∉ (P : Set T) + ({r} : Set T)) : + Transcendental R.carrier (t + δ) := by + rw [Transcendental] + intro ⟨p, hp_ne, hp_eval⟩ + have hδ_in_D : δ ∈ avoidanceObstacles R I t := by + unfold avoidanceObstacles avoidanceBaseObstacles + exact Set.mem_union_left _ (Set.mem_union_right _ + (Set.mem_iUnion.mpr ⟨p, Set.mem_iUnion.mpr ⟨hp_ne, ⟨t + δ, hp_eval, by ring⟩⟩⟩)) + have h_absurd : δ ∈ ((⊥ : Ideal T) : Set T) + ({δ} : Set T) := by + have := Set.add_mem_add (⊥ : Ideal T).zero_mem + (show δ ∈ ({δ} : Set T) from rfl) + rwa [zero_add] at this + have h_bot : (⊥ : Ideal T) ∈ avoidanceGoodPrimes R I := by + unfold avoidanceGoodPrimes + exact Set.mem_union_right _ rfl + exact absurd h_absurd (hδ_avoid ⊥ h_bot δ hδ_in_D) + +open scoped Pointwise in +/-- Modular transcendence of `t + δ`: the kernel condition of +`adjoin_transcendental_isNSubring`. -/ +private lemma avoidance_shift_mod_transcendental (R : NSubring T) {I : Ideal T} (t δ : T) + (hI_assoc : ∀ (r : R.carrier), (r : T) ≠ 0 → + ∀ P ∈ associatedPrimes T (T ⧸ span {(r : T)}), ¬(I ≤ P)) + (hδ_avoid : ∀ P ∈ avoidanceGoodPrimes R I, ∀ r ∈ avoidanceObstacles R I t, + δ ∉ (P : Set T) + ({r} : Set T)) + (P : Ideal T) (hP_prime : P.IsPrime) (hP_ht : P.height ≤ 1) + (hPR_ne : P.comap R.carrier.subtype ≠ ⊥) (f : Polynomial R.carrier) + (hf_in : (Polynomial.aeval (t + δ) f : T) ∈ (P : Set T)) (i : ℕ) : + f.coeff i ∈ P.comap R.carrier.subtype := by + by_contra h_neg + -- f.map (φ P) ≠ 0 (some coefficient doesn't vanish mod P) + have hf_bar_ne : f.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) ≠ 0 := by + intro h_eq + apply h_neg + have h := congr_arg (fun p => Polynomial.coeff p i) h_eq + simp only [Polynomial.coeff_map, Polynomial.coeff_zero] at h + exact Ideal.mem_comap.mpr (Ideal.Quotient.eq_zero_iff_mem.mp h) + -- P is an associated prime of some T/(r₀), hence a good prime + obtain ⟨r₀, hr₀T_ne, hP_assoc⟩ := + prime_height_le_one_mem_assoc P hP_prime hP_ht hPR_ne + have hP_in_C_good : P ∈ avoidanceGoodPrimes R I := by + unfold avoidanceGoodPrimes + exact Set.mem_union_left _ (Set.mem_iUnion.mpr ⟨r₀, Set.mem_iUnion.mpr + ⟨hr₀T_ne, hP_assoc, hI_assoc r₀ hr₀T_ne P hP_assoc⟩⟩) + -- mk P (t+δ) is a root of f.map (φ P) in T/P + have ht_root : (f.map ((Ideal.Quotient.mk P).comp R.carrier.subtype)).IsRoot + (Ideal.Quotient.mk P (t + δ)) := by + rw [Polynomial.IsRoot, Polynomial.eval_map, + ← Polynomial.hom_eval₂ f R.carrier.subtype (Ideal.Quotient.mk P) (t + δ)] + exact Ideal.Quotient.eq_zero_iff_mem.mpr hf_in + -- liftQ P (mk P (t+δ)) - t is an obstacle + have hlift_shifted_in_D : + quotientLift P (Ideal.Quotient.mk P (t + δ)) - t ∈ avoidanceObstacles R I t := by + unfold avoidanceObstacles avoidanceModFiber + exact Set.mem_union_right _ + (Set.mem_iUnion.mpr ⟨P, Set.mem_iUnion.mpr + ⟨hP_in_C_good, Set.mem_iUnion.mpr ⟨f, + Set.mem_iUnion.mpr ⟨hf_bar_ne, + ⟨Ideal.Quotient.mk P (t + δ), ht_root, rfl⟩⟩⟩⟩⟩) + -- δ - (liftQ - t) = (t + δ) - liftQ ∈ P + have hlift_in_P : δ - (quotientLift P (Ideal.Quotient.mk P (t + δ)) - t) ∈ P := by + have hmem : (t + δ) - quotientLift P (Ideal.Quotient.mk P (t + δ)) ∈ P := by + rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, quotientLift_spec] + exact sub_self _ + convert hmem using 1 + ring + -- δ ∈ P + {liftQ - t}, contradicting avoidance + exact absurd + ⟨δ - (quotientLift P (Ideal.Quotient.mk P (t + δ)) - t), hlift_in_P, + quotientLift P (Ideal.Quotient.mk P (t + δ)) - t, rfl, by ring⟩ + (hδ_avoid P hP_in_C_good + (quotientLift P (Ideal.Quotient.mk P (t + δ)) - t) hlift_shifted_in_D) + +/-- Final step: after adjoining `x` with `c - x a ∈ (s')T`, the induction hypothesis on `s'` +yields the required extension. -/ +private lemma close_up_avoidance_step_of_adjoin {m : ℕ} + (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) + (s : Finset R.carrier) (_ : s.card ≤ m) (c : R.carrier) + (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) + (R : NSubring T) (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) + (a : R.carrier) (s' : Finset R.carrier) (hs'_card : s'.card ≤ m) (c : R.carrier) + (x : T) (S₁ : NSubring T) (hAext₁ : IsAExtension R S₁) (hx_S₁ : x ∈ (S₁.carrier : Set T)) + (hrem_T : ((c : T) - x * (a : T)) ∈ + Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier))) : + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) + (span (insert (a : R.carrier) (↑s' : Set R.carrier))) := by + have : DecidableEq R.carrier := Classical.decEq _ + have hle₁ := hAext₁.le + have hrem_in_S₁ : (c : T) - x * (a : T) ∈ S₁.carrier := + S₁.carrier.sub_mem (hle₁ c.2) (S₁.carrier.mul_mem hx_S₁ (hle₁ a.2)) + let rem₁ : S₁.carrier := ⟨(c : T) - x * (a : T), hrem_in_S₁⟩ + have : DecidableEq S₁.carrier := Classical.decEq _ + let liftR₁ := Subring.inclusion hle₁ + let s₁ : Finset S₁.carrier := s'.image liftR₁ + have hs₁_card : s₁.card ≤ m := Finset.card_image_le.trans hs'_card + have hcomp : S₁.carrier.subtype.comp liftR₁ = R.carrier.subtype := + RingHom.ext fun _ => rfl + have hrem₁_span : (rem₁ : T) ∈ + Ideal.map S₁.carrier.subtype (span (↑s₁ : Set S₁.carrier)) := by + change (c : T) - x * (a : T) ∈ _ + change _ ∈ Ideal.map S₁.carrier.subtype + (span (↑(s'.image liftR₁) : Set S₁.carrier)) + rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, hcomp] + exact hrem_T + have hS₁_card : Cardinal.mk S₁.carrier < Cardinal.mk T := + lt_of_le_of_lt hAext₁.card_le (max_lt hT_aleph0 hR_card) + obtain ⟨S₂, hAext₂, hle₂, hrem₂⟩ := + ih S₁ hS₁_card s₁ hs₁_card rem₁ hrem₁_span + refine ⟨S₂, isAExtension_trans' hAext₁ hAext₂, + le_trans hle₁ hle₂, ?_⟩ + rw [Ideal.span_insert, Ideal.map_sup] + refine Submodule.mem_sup.mpr + ⟨⟨x, hle₂ hx_S₁⟩ * ⟨(a : T), (le_trans hle₁ hle₂) a.2⟩, ?_, + ⟨(c : T) - x * (a : T), hle₂ hrem_in_S₁⟩, ?_, ?_⟩ + · rw [Ideal.map_span, Set.image_singleton] + exact Ideal.mul_mem_left _ _ (Ideal.subset_span rfl) + · have hcomp₂ : (Subring.inclusion hle₂).comp liftR₁ = + Subring.inclusion (le_trans hle₁ hle₂) := + RingHom.ext fun _ => rfl + change ⟨(rem₁ : T), hle₂ rem₁.2⟩ ∈ + Ideal.map (Subring.inclusion hle₂) + (span (↑(s'.image liftR₁) : Set S₁.carrier)) at hrem₂ + rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, hcomp₂] at hrem₂ + exact hrem₂ + · exact Subtype.ext (by + simp only [Subring.coe_add, Subring.coe_mul] + ring) + +lemma close_up_avoidance_step [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -58,11 +466,11 @@ private def close_up_avoidance_step_proof (c : R.carrier) (hc : (c : T) ∈ Ideal.map R.carrier.subtype (span (insert (a : R.carrier) (↑s' : Set R.carrier)))) - (h_no_common : ∀ (q : R.carrier), Prime q → ¬(∀ x ∈ s', q ∣ x)) : PLift ( + (h_no_common : ∀ (q : R.carrier), Prime q → ¬(∀ x ∈ s', q ∣ x)) : ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), (⟨(c : T), hle c.2⟩ : S.carrier) ∈ Ideal.map (Subring.inclusion hle) - (span (insert (a : R.carrier) (↑s' : Set R.carrier))) ) := ⟨by + (span (insert (a : R.carrier) (↑s' : Set R.carrier))) := by have : DecidableEq R.carrier := Classical.decEq _ have : IsDomain R.carrier := NSubring.isDomain R have : UniqueFactorizationMonoid R.carrier := R.isUFD @@ -115,278 +523,14 @@ private def close_up_avoidance_step_proof (Ideal.subset_span (Set.mem_insert a _)) ha_unit] exact Submodule.mem_top · -- M ≠ ⊥: main avoidance argument - have hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥ := hM_bot set I_s' := Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) - -- C_good: associated primes where I_s' ⊄ P, plus ⊥ - set C_good : Set (Ideal T) := - (⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), - {P ∈ associatedPrimes T (T ⧸ span {(r : T)}) | ¬(I_s' ≤ P)}) ∪ {⊥} - let φ : (P : Ideal T) → R.carrier →+* T ⧸ P := - fun P => (Ideal.Quotient.mk P).comp R.carrier.subtype - let liftQ : (P : Ideal T) → T ⧸ P → T := - fun P α => (Ideal.Quotient.mk_surjective α).choose - have hliftQ : ∀ (P : Ideal T) (α : T ⧸ P), - Ideal.Quotient.mk P (liftQ P α) = α := - fun P α => (Ideal.Quotient.mk_surjective α).choose_spec - -- D_base: absolute transcendence obstacles - let D_base : Set T := - {-t} ∪ ⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), - (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0} - -- D_mod: modular transcendence obstacles (lifts of roots of f mod P) - let D_mod : Set T := - ⋃ P ∈ C_good, ⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α : T ⧸ P | (Polynomial.map (φ P) f).IsRoot α} - set D : Set T := D_base ∪ D_mod - have hC_good_prime : ∀ P ∈ C_good, P.IsPrime := by - intro P hP - rcases (Set.mem_union _ _ _).mp hP with h | h - · rw [Set.mem_iUnion] at h - obtain ⟨r, h⟩ := h - rw [Set.mem_iUnion] at h - obtain ⟨_, hPmem⟩ := h - exact hPmem.1.isPrime - · exact Set.mem_singleton_iff.mp h ▸ Ideal.isPrime_bot - have hC_good_ne_max : ∀ P ∈ C_good, P ≠ IsLocalRing.maximalIdeal T := by - intro P hP - rcases (Set.mem_union _ _ _).mp hP with h | h - · rw [Set.mem_iUnion] at h - obtain ⟨r, h⟩ := h - rw [Set.mem_iUnion] at h - obtain ⟨hr, hPmem⟩ := h - exact fun heq => hM_not_assoc (r : T) hr (heq ▸ hPmem.1) - · rw [Set.mem_singleton_iff.mp h] - exact fun h => hM_ne_bot h.symm - have hD_root_countable : ∀ (f : Polynomial R.carrier), f ≠ 0 → - ((fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}).Countable := by - intro f hf - apply Set.Countable.image - have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by - rw [Ne, ← Polynomial.map_zero R.carrier.subtype] - exact (Polynomial.map_injective R.carrier.subtype - Subtype.val_injective).ne hf - have h_eq : {x : T | Polynomial.aeval x f = 0} = - {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} := by - ext x - simp [Polynomial.IsRoot, Polynomial.aeval_def, Polynomial.eval_map, - show algebraMap R.carrier T = R.carrier.subtype from rfl] - rw [h_eq] - exact (Polynomial.finite_setOfPred_isRoot hmap_ne).countable - -- Avoidance bound: countable or cardinal bound (Adjoin.lean pattern) - have hCD_good_bound : Cardinal.mk (↑C_good × ↑D) < - Cardinal.mk (IsLocalRing.ResidueField T) ∨ - (C_good.Countable ∧ D.Countable) := by - by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 - · -- R countable: both C_good and D are countable - have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le - have : Countable (Polynomial R.carrier) := by - let : Countable (AddMonoidAlgebra R.carrier ℕ) := - Countable.of_equiv _ AddMonoidAlgebra.coeffEquiv.symm - exact Polynomial.toFinsupp_injective.countable - have hC_good_countable : C_good.Countable := - Set.Countable.union (Set.countable_iUnion fun r => - Set.countable_iUnion fun _ => - ((associatedPrimes.finite T (T ⧸ span {(r : T)})).subset - fun P hP => hP.1).countable) (Set.countable_singleton _) - have hD_base_countable : D_base.Countable := - Set.Countable.union (Set.countable_singleton _) - (Set.countable_iUnion fun f => Set.countable_iUnion fun hf => - hD_root_countable f hf) - have hD_mod_countable : D_mod.Countable := by - apply Set.Countable.biUnion hC_good_countable - intro P hP - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hfne - apply Set.Countable.image - have : P.IsPrime := hC_good_prime P hP - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - exact (Polynomial.finite_setOfPred_isRoot hfne).countable - right - exact ⟨hC_good_countable, - Set.Countable.union hD_base_countable hD_mod_countable⟩ - · -- R uncountable: use cardinal bound #(C_good × D) < #(ResidueField T) - left - push Not at hR_le - have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le - -- #C_good ≤ #R - have hC_le : Cardinal.mk C_good ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C_good - ≤ Cardinal.mk ↑(⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), - {P ∈ associatedPrimes T (T ⧸ span {(r : T)}) | ¬(I_s' ≤ P)}) + - Cardinal.mk ↑({⊥} : Set (Ideal T)) := Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 + - Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_iUnion_le _).trans - (mul_le_mul_right (ciSup_le' fun r => by - exact Cardinal.mk_le_aleph0_iff.mpr - ((Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => fun P hP => hP.1)).countable.to_subtype)) _) - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - _ = Cardinal.mk R.carrier := by - rw [Cardinal.mul_aleph0_eq hR_inf, Cardinal.add_eq_left hR_inf le_rfl] - -- #D_base ≤ #R - have hD_base_le : Cardinal.mk D_base ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D_base - ≤ Cardinal.mk ↑({-t} : Set T) + - Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), - (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - · exact (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' - (Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf)) - (ciSup_le' fun f => Cardinal.mk_le_aleph0_iff.mpr (by - by_cases hf : f = 0 - · exact Set.Countable.to_subtype (by simp [hf]) - · exact (Set.countable_iUnion fun _ => - hD_root_countable f hf).to_subtype))).trans - (Cardinal.mul_aleph0_eq hR_inf).le) - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - -- #D_mod ≤ #R (following Adjoin.lean D_mod_shifted pattern) - have hD_mod_le : Cardinal.mk D_mod ≤ Cardinal.mk R.carrier := by - apply (Cardinal.mk_biUnion_le _ _).trans - have h_inner : ∀ (x : ↑C_good), Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), - (fun α => liftQ x.1 α - t) '' - {α : T ⧸ x.1 | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ - Cardinal.mk R.carrier := by - intro ⟨P, hP⟩ - calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α : T ⧸ P | (Polynomial.map (φ P) f).IsRoot α}) - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), - Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α : T ⧸ P | (Polynomial.map (φ P) f).IsRoot α}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hfne : Polynomial.map (φ P) f = 0 - · exact Set.Countable.to_subtype (by simp [hfne]) - · have : P.IsPrime := hC_good_prime P hP - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - apply Set.Countable.to_subtype - apply Set.Finite.countable - apply Set.Finite.subset - (((Polynomial.rootSet_finite - (Polynomial.map (φ P) f) (T ⧸ P)).image - (liftQ P)).image (fun x => x - t)) - apply Set.iUnion_subset - intro _ x hx - obtain ⟨α, hα, rfl⟩ := hx - exact ⟨liftQ P α, - ⟨α, Polynomial.mem_rootSet.mpr ⟨hfne, hα⟩, rfl⟩, rfl⟩ - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - exact (mul_le_mul' hC_le (ciSup_le' h_inner)).trans (Cardinal.mul_eq_self hR_inf).le - -- #D ≤ #R - have hD_le : Cardinal.mk D ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D - ≤ Cardinal.mk D_base + Cardinal.mk D_mod := Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := - add_le_add hD_base_le hD_mod_le - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - calc Cardinal.mk (↑C_good × ↑D) - = Cardinal.mk C_good * Cardinal.mk D := (Cardinal.mul_def _ _).symm - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC_le hD_le - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - _ < Cardinal.mk T := hR_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card - have hI_not_le_good : ∀ P ∈ C_good, ¬(I_s' ≤ P) := by - intro P hP hle - rcases (Set.mem_union _ _ _).mp hP with h | h - · rw [Set.mem_iUnion] at h - obtain ⟨r, h⟩ := h - rw [Set.mem_iUnion] at h - obtain ⟨_, hPmem⟩ := h - exact hPmem.2 hle - · rw [Set.mem_singleton_iff.mp h] at hle - exact hI_bot (le_antisymm hle bot_le) - -- I_s' ⊄ P for ALL associated primes (not just C_good ones). - -- This follows from h_no_common: if I_s' ≤ P with P∩R ≠ ⊥, - -- then P∩R = span{q_P} for some prime q_P, so q_P | all of s', - -- contradicting h_no_common. - have hI_s'_not_le_assoc : ∀ (r : R.carrier) (_ : (r : T) ≠ 0) - (P : Ideal T) (_ : P ∈ associatedPrimes T (T ⧸ span {(r : T)})), - ¬(I_s' ≤ P) := by - intro r hr P hP_mem hle - have hht := R.height_bound (r : T) hr P hP_mem - by_cases hcomap : P.comap R.carrier.subtype = ⊥ - · -- P ∩ R = ⊥: all s' zero, I_s' = ⊥ - exact hI_bot (le_antisymm (by - apply Ideal.map_le_iff_le_comap.mpr - apply Ideal.span_le.mpr - intro x hx - have h1 : x ∈ P.comap R.carrier.subtype := - Ideal.mem_comap.mpr (hle (Ideal.mem_map_of_mem _ - (Ideal.subset_span (Finset.mem_coe.mpr hx)))) - have h1' : x ∈ (⊥ : Ideal R.carrier) := hcomap ▸ h1 - have hx_zero : x = 0 := (Submodule.mem_bot _).mp h1' - change R.carrier.subtype x ∈ (⊥ : Ideal T) - rw [hx_zero, map_zero] - exact (Submodule.mem_bot T).mpr rfl) bot_le) - · -- P ∩ R ≠ ⊥: find q_P, contradiction from h_no_common - have : (P.comap R.carrier.subtype).IsPrime := hP_mem.isPrime.comap _ - obtain ⟨q_P, hqP_prime, hqP_in⟩ := - exists_prime_mem_of_ne_bot_closeup (P.comap R.carrier.subtype) hcomap - have hQ_eq : Ideal.span {q_P} = P.comap R.carrier.subtype := - @eq_of_prime_le_prime_height_le_one R.carrier _ (NSubring.isDomain R) _ _ - ((Ideal.span_singleton_prime hqP_prime.ne_zero).mpr hqP_prime) - (hP_mem.isPrime.comap _) - (Ideal.span_le.mpr (Set.singleton_subset_iff.mpr hqP_in)) - (mt (Ideal.span_singleton_eq_bot (α := R.carrier)).mp hqP_prime.ne_zero) hht - have hqP_dvd_s' : ∀ x ∈ s', q_P ∣ x := fun x hx => - (Ideal.mem_span_singleton (α := R.carrier)).mp - (hQ_eq ▸ Ideal.mem_comap.mpr (hle (Ideal.mem_map_of_mem _ - (Ideal.subset_span (Finset.mem_coe.mpr hx))))) - exact h_no_common q_P hqP_prime hqP_dvd_s' -- Apply unified avoidance (handles both countable and uncountable R) obtain ⟨δ, hδ_mem, hδ_avoid⟩ := - avoidance hC_good_prime hC_good_ne_max hCD_good_bound hI_not_le_good - -- t' = t + δ satisfies transcendence, avoidance, remainder - have ht'_trans : Transcendental R.carrier (t + δ) := by - rw [Transcendental] - intro ⟨p, hp_ne, hp_eval⟩ - have hδ_in_D : δ ∈ D := Set.mem_union_left _ - (Set.mem_union_right _ - (Set.mem_iUnion.mpr - ⟨p, Set.mem_iUnion.mpr - ⟨hp_ne, ⟨t + δ, hp_eval, by ring⟩⟩⟩)) - open scoped Pointwise in - have h_absurd : δ ∈ ((⊥ : Ideal T) : Set T) + ({δ} : Set T) := by - have := Set.add_mem_add (⊥ : Ideal T).zero_mem - (show δ ∈ ({δ} : Set T) from rfl) - rwa [zero_add] at this - exact absurd h_absurd - (hδ_avoid ⊥ (Set.mem_union_right _ rfl) δ hδ_in_D) - have ht'_avoid : ∀ (r : R.carrier), (r : T) ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ span {(r : T)}), - (t + δ) ∉ (P : Set T) := by - intro r hr P hP hmem - by_cases hle_P : I_s' ≤ P - · -- Bad prime: impossible by h_no_common - exact absurd hle_P (hI_s'_not_le_assoc r hr P hP) - · -- Good prime: use avoidance result - open scoped Pointwise in - have h_in_sum : δ ∈ (P : Set T) + ({-t} : Set T) := by - have := Set.add_mem_add hmem (show -t ∈ ({-t} : Set T) from rfl) - rwa [show (t + δ) + -t = δ from by ring] at this - exact absurd h_in_sum - (hδ_avoid P (Set.mem_union_left _ - (Set.mem_iUnion.mpr ⟨r, Set.mem_iUnion.mpr ⟨hr, ⟨hP, hle_P⟩⟩⟩)) - (-t) (Set.mem_union_left _ (Set.mem_union_left _ rfl))) + avoidance (fun P hP => avoidanceGoodPrimes_isPrime hP) + (fun P hP => avoidanceGoodPrimes_ne_maximalIdeal hM_not_assoc hM_bot hP) + (avoidance_cardinal_bound R I_s' t hR_card hT_card) + (fun P hP => avoidanceGoodPrimes_not_le hI_bot hP) + -- t' = t + δ satisfies transcendence and the remainder condition have hrem_T : ((c : T) - (t + δ) * (a : T)) ∈ I_s' := by suffices hrw : (↑c : T) - (t + δ) * (↑a : T) = v - δ * (↑a : T) by rw [hrw] @@ -398,136 +542,10 @@ private def close_up_avoidance_step_proof ring -- Adjoin t+δ to R → S₁ obtain ⟨S₁, hAext₁, ht'_S₁⟩ := - adjoin_transcendental_isNSubring R (t + δ) ht'_trans - hAss_ht (fun P hP_prime hP_ht hPR_ne f hf_in i => by - -- Modular transcendence: show coeff f i ∈ P∩R. - -- By contradiction, show P ∈ C_good, use modular avoidance from D_mod. - by_contra h_neg - -- f.map (φ P) ≠ 0 (some coefficient doesn't vanish mod P) - have hf_bar_ne : f.map (φ P) ≠ 0 := by - intro h_eq - apply h_neg - have h := congr_arg (fun p => Polynomial.coeff p i) h_eq - simp only [Polynomial.coeff_map, Polynomial.coeff_zero] at h - exact Ideal.mem_comap.mpr (Ideal.Quotient.eq_zero_iff_mem.mp h) - -- P is an associated prime of some T/(r₀) - obtain ⟨r₀, hr₀T_ne, hP_assoc⟩ := - prime_height_le_one_mem_assoc P hP_prime hP_ht hPR_ne - -- Show P ∈ C_good: need ¬(I_s' ≤ P). - -- By hI_s'_not_le_assoc (from h_no_common): I_s' ⊄ P for all - -- associated primes P with P ∩ R ≠ ⊥. - have hP_in_C_good : P ∈ C_good := by - apply Set.mem_union_left - exact Set.mem_iUnion.mpr ⟨r₀, Set.mem_iUnion.mpr - ⟨hr₀T_ne, hP_assoc, hI_s'_not_le_assoc r₀ hr₀T_ne P hP_assoc⟩⟩ - -- mk P (t+δ) is a root of f.map (φ P) in T/P - have := hP_prime - have ht_root : (f.map (φ P)).IsRoot - (Ideal.Quotient.mk P (t + δ)) := by - rw [Polynomial.IsRoot, Polynomial.eval_map, - show φ P = (Ideal.Quotient.mk P).comp R.carrier.subtype - from rfl, - ← Polynomial.hom_eval₂ f R.carrier.subtype - (Ideal.Quotient.mk P) (t + δ)] - exact Ideal.Quotient.eq_zero_iff_mem.mpr hf_in - -- liftQ P (mk P (t+δ)) - t ∈ D_mod ⊆ D - have hlift_shifted_in_D : - liftQ P (Ideal.Quotient.mk P (t + δ)) - t ∈ D := - Set.mem_union_right _ - (Set.mem_iUnion.mpr ⟨P, Set.mem_iUnion.mpr - ⟨hP_in_C_good, Set.mem_iUnion.mpr ⟨f, - Set.mem_iUnion.mpr ⟨hf_bar_ne, - ⟨Ideal.Quotient.mk P (t + δ), ht_root, - rfl⟩⟩⟩⟩⟩) - -- δ - (liftQ - t) = (t + δ) - liftQ ∈ P - have hlift_in_P : δ - - (liftQ P (Ideal.Quotient.mk P (t + δ)) - t) ∈ P := by - have hmem : (t + δ) - - liftQ P (Ideal.Quotient.mk P (t + δ)) ∈ P := by - rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, hliftQ] - exact sub_self _ - convert hmem using 1 - ring - -- δ ∈ P + {liftQ - t}, contradicting avoidance - open scoped Pointwise in - exact absurd - ⟨δ - (liftQ P (Ideal.Quotient.mk P (t + δ)) - t), - hlift_in_P, - liftQ P (Ideal.Quotient.mk P (t + δ)) - t, rfl, - by ring⟩ - (hδ_avoid P hP_in_C_good - (liftQ P (Ideal.Quotient.mk P (t + δ)) - t) - hlift_shifted_in_D)) - have hle₁ := hAext₁.le - have hrem_in_S₁ : (c : T) - (t + δ) * (a : T) ∈ S₁.carrier := - S₁.carrier.sub_mem (hle₁ c.2) (S₁.carrier.mul_mem ht'_S₁ (hle₁ a.2)) - let rem₁ : S₁.carrier := ⟨(c : T) - (t + δ) * (a : T), hrem_in_S₁⟩ - have : DecidableEq S₁.carrier := Classical.decEq _ - let liftR₁ := Subring.inclusion hle₁ - let s₁ : Finset S₁.carrier := s'.image liftR₁ - have hs₁_card : s₁.card ≤ m := Finset.card_image_le.trans hs'_card - have hcomp : S₁.carrier.subtype.comp liftR₁ = R.carrier.subtype := - RingHom.ext fun _ => rfl - have hrem₁_span : (rem₁ : T) ∈ - Ideal.map S₁.carrier.subtype (span (↑s₁ : Set S₁.carrier)) := by - change (c : T) - (t + δ) * (a : T) ∈ _ - change _ ∈ Ideal.map S₁.carrier.subtype - (span (↑(s'.image liftR₁) : Set S₁.carrier)) - rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, hcomp] - exact hrem_T - have hS₁_card : Cardinal.mk S₁.carrier < Cardinal.mk T := - lt_of_le_of_lt hAext₁.card_le (max_lt hT_aleph0 hR_card) - obtain ⟨S₂, hAext₂, hle₂, hrem₂⟩ := - ih S₁ hS₁_card s₁ hs₁_card rem₁ hrem₁_span - refine ⟨S₂, isAExtension_trans' hAext₁ hAext₂, - le_trans hle₁ hle₂, ?_⟩ - rw [Ideal.span_insert, Ideal.map_sup] - refine Submodule.mem_sup.mpr - ⟨⟨t + δ, hle₂ ht'_S₁⟩ * ⟨(a : T), (le_trans hle₁ hle₂) a.2⟩, ?_, - ⟨(c : T) - (t + δ) * (a : T), hle₂ hrem_in_S₁⟩, ?_, ?_⟩ - · rw [Ideal.map_span, Set.image_singleton] - exact Ideal.mul_mem_left _ _ (Ideal.subset_span rfl) - · have hcomp₂ : (Subring.inclusion hle₂).comp liftR₁ = - Subring.inclusion (le_trans hle₁ hle₂) := - RingHom.ext fun _ => rfl - change ⟨(rem₁ : T), hle₂ rem₁.2⟩ ∈ - Ideal.map (Subring.inclusion hle₂) - (span (↑(s'.image liftR₁) : Set S₁.carrier)) at hrem₂ - rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, hcomp₂] at hrem₂ - exact hrem₂ - · exact Subtype.ext (by - simp only [Subring.coe_add, Subring.coe_mul] - ring) -⟩ - -lemma close_up_avoidance_step - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - {m : ℕ} - (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) - (s : Finset R.carrier) (_ : s.card ≤ m) (c : R.carrier) - (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - (R : NSubring T) (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) - (a : R.carrier) (s' : Finset R.carrier) (hs'_card : s'.card ≤ m) - (c : R.carrier) - (hc : (c : T) ∈ Ideal.map R.carrier.subtype - (span (insert (a : R.carrier) (↑s' : Set R.carrier)))) - (h_no_common : ∀ (q : R.carrier), Prime q → ¬(∀ x ∈ s', q ∣ x)) : - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) - (span (insert (a : R.carrier) (↑s' : Set R.carrier))) := by - exact - (close_up_avoidance_step_proof - (m := m) hM_not_assoc hAss_ht ih R hR_card hT_card hT_aleph0 a s' hs'_card c hc - h_no_common - ).down + adjoin_transcendental_isNSubring R (t + δ) + (avoidance_shift_transcendental R I_s' t δ hδ_avoid) hAss_ht + (avoidance_shift_mod_transcendental R t δ + (span_not_le_associatedPrime R s' hI_bot h_no_common) hδ_avoid) + exact close_up_avoidance_step_of_adjoin ih R hR_card hT_aleph0 a s' hs'_card c + (t + δ) S₁ hAext₁ ht'_S₁ hrem_T end diff --git a/LeanPool/AndersonConjecture/Jensen/CloseUp/CoprimeSplit.lean b/LeanPool/AndersonConjecture/Jensen/CloseUp/CoprimeSplit.lean index 187c82fdfc..da73e1dba9 100644 --- a/LeanPool/AndersonConjecture/Jensen/CloseUp/CoprimeSplit.lean +++ b/LeanPool/AndersonConjecture/Jensen/CloseUp/CoprimeSplit.lean @@ -36,7 +36,204 @@ open Cardinal Ideal variable {T : Type*} [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] -private def close_up_aux_b2_nonzero_proof +/-- Recombination for the B2 sub-case: from `c - x₁ * a = p * w` in `S₁` and +`w ∈ (insert a s'_div)·S₂`, deduce `c ∈ s·S₂`. -/ +private theorem close_up_b2_recombine + {R S₁ S₂ : NSubring T} [DecidableEq R.carrier] + (hAext₁ : IsAExtension R S₁) (hAext₂ : IsAExtension S₁ S₂) + (hle₁ : R.carrier ≤ S₁.carrier) (hle₂ : S₁.carrier ≤ S₂.carrier) + {a p c : R.carrier} {s s' s'_div : Finset R.carrier} + (hs_insert : s = insert a s') + (h_ml : span {p} * span (↑(insert a s'_div) : Set R.carrier) ≤ + span (↑(insert a s') : Set R.carrier)) + (x₁ w : S₁.carrier) + (hw_eq : (⟨(c : T), hle₁ c.2⟩ : S₁.carrier) - x₁ * ⟨(a : T), hle₁ a.2⟩ = + ⟨(p : T), hle₁ p.2⟩ * w) + (hw_S₂ : (⟨(↑w : T), hle₂ w.2⟩ : S₂.carrier) ∈ + Ideal.map (Subring.inclusion hle₂) + (Ideal.map (Subring.inclusion hle₁) (span (↑(insert a s'_div) : Set R.carrier)))) : + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by + have hle_comp : R.carrier ≤ S₂.carrier := le_trans hle₁ hle₂ + refine ⟨S₂, isAExtension_trans' hAext₁ hAext₂, hle_comp, ?_⟩ + have hc_val : (c : T) = (↑x₁ : T) * (a : T) + (p : T) * (↑w : T) := by + have := congr_arg Subtype.val hw_eq + simp only [Subring.coe_mul, AddSubgroupClass.coe_sub] at this + linear_combination this + change (⟨(c : T), hle_comp c.2⟩ : S₂.carrier) ∈ + Ideal.map (Subring.inclusion hle_comp) + (span (↑s : Set R.carrier)) + rw [hs_insert] + have hc_eq : (⟨(c : T), hle_comp c.2⟩ : S₂.carrier) = + ⟨(↑x₁ : T), hle₂ x₁.2⟩ * ⟨(a : T), hle_comp a.2⟩ + + ⟨(p : T), hle_comp p.2⟩ * ⟨(↑w : T), hle₂ w.2⟩ := by + ext + simpa only [Subring.coe_mul, Subring.coe_add] using hc_val + rw [hc_eq] + apply add_mem + · apply Ideal.mul_mem_left + exact Ideal.map_mono + (Ideal.span_mono + (Set.singleton_subset_iff.mpr (Finset.mem_coe.mpr (Finset.mem_insert_self a s')))) + (Ideal.mem_map_of_mem _ (Ideal.subset_span rfl)) + · have hw_comp : (⟨(↑w : T), hle₂ w.2⟩ : S₂.carrier) ∈ + Ideal.map (Subring.inclusion hle_comp) + (span (↑(insert a s'_div) : Set R.carrier)) := by + rw [show Subring.inclusion hle_comp = + (Subring.inclusion hle₂).comp (Subring.inclusion hle₁) from + RingHom.ext fun _ => rfl, ← Ideal.map_map] + exact hw_S₂ + have hmul := Ideal.mul_mem_mul + (show (⟨(p : T), hle_comp p.2⟩ : S₂.carrier) ∈ + Ideal.map (Subring.inclusion hle_comp) + (span {p}) from + Ideal.mem_map_of_mem _ + (Ideal.subset_span rfl)) + hw_comp + rw [← Ideal.map_mul] at hmul + exact Ideal.map_mono h_ml hmul + +/-- Inductive step for the B2 sub-case: having divided the generators `s'` by the +common prime `p`, close up `w` against `insert a (s'/p)` over `S₁`, using either the +cardinality induction hypothesis or the GCD-complexity induction hypothesis. -/ +private theorem close_up_b2_divided_step + (n'' : ℕ) + (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) + (s : Finset R.carrier) (_ : s.card ≤ n'' + 1 + 1) (c : R.carrier) + (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) + (m : ℕ) + (ih_m : ∀ m_1, m_1 < m → + ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T), + letI : IsDomain R.carrier := NSubring.isDomain R + letI : UniqueFactorizationMonoid R.carrier := R.isUFD + ∀ (a : R.carrier) (s : Finset R.carrier), + gcdComplexity s ≤ m_1 → + s.card = n'' + 1 + 1 + 1 → a ∈ s → ∀ (c : R.carrier), + (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier)) → + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) + {R S₁ : NSubring T} [DecidableEq R.carrier] + (hAext₁ : IsAExtension R S₁) (hle₁ : R.carrier ≤ S₁.carrier) + (hS₁_card : Cardinal.mk S₁.carrier < Cardinal.mk T) + {a : R.carrier} {s : Finset R.carrier} + (hs_gcd : gcdComplexity s ≤ m) + (hs_eq : s.card = n'' + 1 + 1 + 1) (ha_mem : a ∈ s) + (s' : Finset R.carrier) (hs'_def : s' = s.erase a) + (hs_insert : s = insert a s') + (hs'_card : s'.card ≤ n'' + 1 + 1) + {p : R.carrier} (hp : Prime p) + (div_p : R.carrier → R.carrier) (hdiv : ∀ x ∈ s', x = p * div_p x) + (w : S₁.carrier) + (hw_mem_T : (↑w : T) ∈ + Ideal.map R.carrier.subtype (span (↑(insert a (s'.image div_p)) : Set R.carrier))) : + ∃ S₂ : NSubring T, IsAExtension S₁ S₂ ∧ + ∃ (hle₂ : S₁.carrier ≤ S₂.carrier), (⟨(↑w : T), hle₂ w.2⟩ : S₂.carrier) ∈ + Ideal.map (Subring.inclusion hle₂) + (Ideal.map (Subring.inclusion hle₁) + (span (↑(insert a (s'.image div_p)) : Set R.carrier))) := by + classical + set s'_div := s'.image div_p with hs'_div_def + by_cases ha_s'_div : a ∈ s'_div + · -- a ∈ s'_div: insert = s'_div + have h_eq2 : insert a s'_div = s'_div := Finset.insert_eq_of_mem ha_s'_div + rw [h_eq2] at hw_mem_T ⊢ + have hs'_div_card : s'_div.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans hs'_card + let liftR₁ := Subring.inclusion hle₁ + let s₁ := s'_div.image liftR₁ + have hs₁_card : s₁.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans hs'_div_card + have hw_s₁ : (↑w : T) ∈ + Ideal.map S₁.carrier.subtype (span (↑s₁ : Set S₁.carrier)) := by + change (↑w : T) ∈ Ideal.map S₁.carrier.subtype + (span (↑(s'_div.image liftR₁) : Set S₁.carrier)) + rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, + show S₁.carrier.subtype.comp liftR₁ = R.carrier.subtype from + RingHom.ext fun _ => rfl] + exact hw_mem_T + obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := ih S₁ hS₁_card s₁ hs₁_card w hw_s₁ + refine ⟨S₂, hAext₂, hle₂, ?_⟩ + convert hw_S₂ using 1 + congr 1 + rw [Ideal.map_span, ← Finset.coe_image] + · -- a ∉ s'_div + by_cases hs'_div_card : s'_div.card ≤ n'' + 1 + · -- |insert a s'_div| ≤ n''+2 + have h_ins_card3 : (insert a s'_div).card ≤ n'' + 1 + 1 := by + rw [Finset.card_insert_of_notMem ha_s'_div] + omega + let liftR₁ := Subring.inclusion hle₁ + let s₁ := (insert a s'_div).image liftR₁ + have hs₁_card : s₁.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans h_ins_card3 + have hw_s₁ : (↑w : T) ∈ + Ideal.map S₁.carrier.subtype (span (↑s₁ : Set S₁.carrier)) := by + change (↑w : T) ∈ Ideal.map S₁.carrier.subtype + (span (↑((insert a s'_div).image liftR₁) : Set S₁.carrier)) + rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, + show S₁.carrier.subtype.comp liftR₁ = R.carrier.subtype from + RingHom.ext fun _ => rfl] + exact hw_mem_T + obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := ih S₁ hS₁_card s₁ hs₁_card w hw_s₁ + refine ⟨S₂, hAext₂, hle₂, ?_⟩ + convert hw_S₂ using 1 + congr 1 + rw [Ideal.map_span, ← Finset.coe_image] + · -- s'_div.card = n''+2, need WF on GCD complexity + push Not at hs'_div_card + have hs'_div_card_eq : s'_div.card = n'' + 1 + 1 := by + have h_le : s'_div.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans hs'_card + omega + let liftR₁' := Subring.inclusion hle₁ + let s₁' := (insert a s'_div).image liftR₁' + have hw_s₁' : (↑w : T) ∈ + Ideal.map S₁.carrier.subtype (span (↑s₁' : Set S₁.carrier)) := by + change (↑w : T) ∈ Ideal.map S₁.carrier.subtype + (span (↑((insert a s'_div).image liftR₁') : Set S₁.carrier)) + rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, + show S₁.carrier.subtype.comp liftR₁' = R.carrier.subtype from + RingHom.ext fun _ => rfl] + exact hw_mem_T + have hs₁'_card : s₁'.card = n'' + 1 + 1 + 1 := by + rw [show s₁' = (insert a s'_div).image liftR₁' from rfl, + Finset.card_image_of_injective _ (Subring.inclusion_injective hle₁), + Finset.card_insert_of_notMem ha_s'_div, hs'_div_card_eq] + have ha_s₁' : liftR₁' a ∈ s₁' := + Finset.mem_image.mpr ⟨a, Finset.mem_insert_self a s'_div, rfl⟩ + -- GCD complexity drops: gcdComplexity s₁' < m + have hgcd_s₁' : gcdComplexity s₁' < m := by + have hcross : gcdComplexity s₁' = gcdComplexity (insert a s'_div) := by + unfold gcdComplexity + have hinj₁ : Set.InjOn liftR₁' ↑(insert a s'_div) := + fun x _ y _ h => (Subring.inclusion_injective hle₁) h + rw [show s₁' = (insert a s'_div).image liftR₁' from rfl, + Finset.sum_image hinj₁] + apply Finset.sum_congr rfl + intro x _ + exact normalizedFactors_card_inclusion R S₁ + ⟨hAext₁.le, hAext₁.primes_preserved, hAext₁.card_le⟩ + hle₁ x + have hstrict : gcdComplexity (insert a s'_div) < gcdComplexity s := + gcdComplexity_div_prime_strict hs_insert hs'_def + (by + rw [hs'_def, Finset.card_erase_of_mem ha_mem, hs_eq] + omega) + hp div_p hdiv ha_s'_div + calc gcdComplexity s₁' = gcdComplexity (insert a s'_div) := hcross + _ < gcdComplexity s := hstrict + _ ≤ m := hs_gcd + obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := + ih_m (gcdComplexity s₁') hgcd_s₁' S₁ hS₁_card (liftR₁' a) s₁' le_rfl hs₁'_card + ha_s₁' w hw_s₁' + refine ⟨S₂, hAext₂, hle₂, ?_⟩ + convert hw_S₂ using 1 + congr 1 + rw [Ideal.map_span, ← Finset.coe_image] + +-- Extracted: Sub-case B2 of close_up_aux_wf (p∤a, no common prime divides both a and c). +theorem close_up_aux_b2_nonzero [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -80,10 +277,10 @@ private def close_up_aux_b2_nonzero_proof (ht_eq : u = R.carrier.subtype a * t) (huv : u + v = (c : T)) (ha_zero : (a : T) ≠ 0) - (_hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : PLift ( + (_hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) ) := ⟨by + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by by_cases hM_bot : IsLocalRing.maximalIdeal T = ⊥ · -- M = ⊥: T is a field, a is a unit, trivial refine ⟨R, ⟨le_refl _, fun r hr => hr, le_max_right _ _⟩, @@ -203,201 +400,11 @@ private def close_up_aux_b2_nonzero_proof (Set.singleton_subset_iff.mpr (Finset.mem_coe.mpr (Finset.mem_insert_self a s'_div)))) (by rw [Ideal.map_span, Set.image_singleton] exact Ideal.mem_span_singleton.mpr ⟨t'_b2, rfl⟩) - -- Suffices: find S₂ with w ∈ span(insert a s'_div)·S₂, then compose back - suffices h_suff_main : ∃ S₂ : NSubring T, IsAExtension S₁ S₂ ∧ - ∃ (hle₂ : S₁.carrier ≤ S₂.carrier), (⟨(↑w : T), hle₂ w.2⟩ : S₂.carrier) ∈ - Ideal.map (Subring.inclusion hle₂) - (Ideal.map (Subring.inclusion hle₁) (span (↑(insert a s'_div) : Set R.carrier))) by - obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := h_suff_main - have hle_comp : R.carrier ≤ S₂.carrier := le_trans hle₁ hle₂ - refine ⟨S₂, isAExtension_trans' hAext₁ hAext₂, hle_comp, ?_⟩ - have hc_val : (c : T) = (↑x₁ : T) * (a : T) + (p : T) * (↑w : T) := by - have := congr_arg Subtype.val hw_eq - simp only [Subring.coe_mul, AddSubgroupClass.coe_sub] at this - linear_combination this - change (⟨(c : T), hle_comp c.2⟩ : S₂.carrier) ∈ - Ideal.map (Subring.inclusion hle_comp) - (span (↑s : Set R.carrier)) - rw [hs_insert] - have hc_eq : (⟨(c : T), hle_comp c.2⟩ : S₂.carrier) = - ⟨(↑x₁ : T), hle₂ x₁.2⟩ * ⟨(a : T), hle_comp a.2⟩ + - ⟨(p : T), hle_comp p.2⟩ * ⟨(↑w : T), hle₂ w.2⟩ := by - ext - simpa only [Subring.coe_mul, Subring.coe_add] using hc_val - rw [hc_eq] - apply add_mem - · apply Ideal.mul_mem_left - exact Ideal.map_mono - (Ideal.span_mono - (Set.singleton_subset_iff.mpr (Finset.mem_coe.mpr (Finset.mem_insert_self a s')))) - (Ideal.mem_map_of_mem _ (Ideal.subset_span rfl)) - · have hw_comp : (⟨(↑w : T), hle₂ w.2⟩ : S₂.carrier) ∈ - Ideal.map (Subring.inclusion hle_comp) - (span (↑(insert a s'_div) : Set R.carrier)) := by - rw [show Subring.inclusion hle_comp = - (Subring.inclusion hle₂).comp (Subring.inclusion hle₁) from - RingHom.ext fun _ => rfl, ← Ideal.map_map] - exact hw_S₂ - have hmul := Ideal.mul_mem_mul - (show (⟨(p : T), hle_comp p.2⟩ : S₂.carrier) ∈ - Ideal.map (Subring.inclusion hle_comp) - (span {p}) from - Ideal.mem_map_of_mem _ - (Ideal.subset_span rfl)) - hw_comp - rw [← Ideal.map_mul] at hmul - exact Ideal.map_mono h_ml_b2 hmul - -- Now apply IH to S₁ with w and insert a s'_div - by_cases ha_s'_div : a ∈ s'_div - · -- a ∈ s'_div: insert = s'_div - have h_eq2 : insert a s'_div = s'_div := Finset.insert_eq_of_mem ha_s'_div - rw [h_eq2] at hw_mem_T ⊢ - have hs'_div_card : s'_div.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans hs'_card - let liftR₁ := Subring.inclusion hle₁ - let s₁ := s'_div.image liftR₁ - have hs₁_card : s₁.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans hs'_div_card - have hw_s₁ : (↑w : T) ∈ - Ideal.map S₁.carrier.subtype (span (↑s₁ : Set S₁.carrier)) := by - change (↑w : T) ∈ Ideal.map S₁.carrier.subtype - (span (↑(s'_div.image liftR₁) : Set S₁.carrier)) - rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, - show S₁.carrier.subtype.comp liftR₁ = R.carrier.subtype from - RingHom.ext fun _ => rfl] - exact hw_mem_T - obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := ih S₁ hS₁_card s₁ hs₁_card w hw_s₁ - refine ⟨S₂, hAext₂, hle₂, ?_⟩ - convert hw_S₂ using 1 - congr 1 - rw [Ideal.map_span, ← Finset.coe_image] - · -- a ∉ s'_div - by_cases hs'_div_card : s'_div.card ≤ n'' + 1 - · -- |insert a s'_div| ≤ n''+2 - have h_ins_card3 : (insert a s'_div).card ≤ n'' + 1 + 1 := by - rw [Finset.card_insert_of_notMem ha_s'_div] - omega - let liftR₁ := Subring.inclusion hle₁ - let s₁ := (insert a s'_div).image liftR₁ - have hs₁_card : s₁.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans h_ins_card3 - have hw_s₁ : (↑w : T) ∈ - Ideal.map S₁.carrier.subtype (span (↑s₁ : Set S₁.carrier)) := by - change (↑w : T) ∈ Ideal.map S₁.carrier.subtype - (span (↑((insert a s'_div).image liftR₁) : Set S₁.carrier)) - rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, - show S₁.carrier.subtype.comp liftR₁ = R.carrier.subtype from - RingHom.ext fun _ => rfl] - exact hw_mem_T - obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := ih S₁ hS₁_card s₁ hs₁_card w hw_s₁ - refine ⟨S₂, hAext₂, hle₂, ?_⟩ - convert hw_S₂ using 1 - congr 1 - rw [Ideal.map_span, ← Finset.coe_image] - · -- s'_div.card = n''+2, need WF on GCD complexity - push Not at hs'_div_card - have hs'_div_card_eq : s'_div.card = n'' + 1 + 1 := by - have h_le : s'_div.card ≤ n'' + 1 + 1 := Finset.card_image_le.trans hs'_card - omega - let liftR₁' := Subring.inclusion hle₁ - let s₁' := (insert a s'_div).image liftR₁' - have hw_s₁' : (↑w : T) ∈ - Ideal.map S₁.carrier.subtype (span (↑s₁' : Set S₁.carrier)) := by - change (↑w : T) ∈ Ideal.map S₁.carrier.subtype - (span (↑((insert a s'_div).image liftR₁') : Set S₁.carrier)) - rw [Finset.coe_image, ← Ideal.map_span, Ideal.map_map, - show S₁.carrier.subtype.comp liftR₁' = R.carrier.subtype from - RingHom.ext fun _ => rfl] - exact hw_mem_T - have hs₁'_card : s₁'.card = n'' + 1 + 1 + 1 := by - rw [show s₁' = (insert a s'_div).image liftR₁' from rfl, - Finset.card_image_of_injective _ (Subring.inclusion_injective hle₁), - Finset.card_insert_of_notMem ha_s'_div, hs'_div_card_eq] - have ha_s₁' : liftR₁' a ∈ s₁' := - Finset.mem_image.mpr ⟨a, Finset.mem_insert_self a s'_div, rfl⟩ - -- GCD complexity drops: gcdComplexity s₁' < m - have hgcd_s₁' : gcdComplexity s₁' < m := by - have hcross : gcdComplexity s₁' = gcdComplexity (insert a s'_div) := by - unfold gcdComplexity - have hinj₁ : Set.InjOn liftR₁' ↑(insert a s'_div) := - fun x _ y _ h => (Subring.inclusion_injective hle₁) h - rw [show s₁' = (insert a s'_div).image liftR₁' from rfl, - Finset.sum_image hinj₁] - apply Finset.sum_congr rfl - intro x _ - exact normalizedFactors_card_inclusion R S₁ - ⟨hAext₁.le, hAext₁.primes_preserved, hAext₁.card_le⟩ - hle₁ x - have hstrict : gcdComplexity (insert a s'_div) < gcdComplexity s := - gcdComplexity_div_prime_strict hs_insert hs'_def - (by - rw [hs'_def, Finset.card_erase_of_mem ha_mem, hs_eq] - omega) - hp div_p_b2 hdiv_b2 ha_s'_div - calc gcdComplexity s₁' = gcdComplexity (insert a s'_div) := hcross - _ < gcdComplexity s := hstrict - _ ≤ m := hs_gcd - obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := - ih_m (gcdComplexity s₁') hgcd_s₁' S₁ hS₁_card (liftR₁' a) s₁' le_rfl hs₁'_card - ha_s₁' w hw_s₁' - refine ⟨S₂, hAext₂, hle₂, ?_⟩ - convert hw_S₂ using 1 - congr 1 - rw [Ideal.map_span, ← Finset.coe_image] -⟩ + obtain ⟨S₂, hAext₂, hle₂, hw_S₂⟩ := + close_up_b2_divided_step n'' ih m ih_m hAext₁ hle₁ hS₁_card hs_gcd hs_eq ha_mem + s' hs'_def hs_insert hs'_card hp div_p_b2 hdiv_b2 w hw_mem_T + exact close_up_b2_recombine hAext₁ hAext₂ hle₁ hle₂ hs_insert h_ml_b2 x₁ w hw_eq hw_S₂ --- Extracted: Sub-case B2 of close_up_aux_wf (p∤a, no common prime divides both a and c). -theorem close_up_aux_b2_nonzero - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) - (n'' : ℕ) - (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) - (s : Finset R.carrier) (_ : s.card ≤ n'' + 1 + 1) (c : R.carrier) - (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - (m : ℕ) - (ih_m : ∀ m_1, m_1 < m → - ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T), - letI : IsDomain R.carrier := NSubring.isDomain R - letI : UniqueFactorizationMonoid R.carrier := R.isUFD - ∀ (a : R.carrier) (s : Finset R.carrier), - gcdComplexity s ≤ m_1 → - s.card = n'' + 1 + 1 + 1 → a ∈ s → ∀ (c : R.carrier), - (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier)) → - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - {R : NSubring T} (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - [DecidableEq R.carrier] - {a : R.carrier} {s : Finset R.carrier} - (hs_gcd : gcdComplexity s ≤ m) - (hs_eq : s.card = n'' + 1 + 1 + 1) (ha_mem : a ∈ s) - {c : R.carrier} - (s' : Finset R.carrier) (hs'_def : s' = s.erase a) - (hs_insert : s = insert a s') - (hs'_card : s'.card ≤ n'' + 1 + 1) - {p : R.carrier} (hp : Prime p) (hp_dvd : ∀ x ∈ s', p ∣ x) - (hpa : ¬p ∣ a) - (_hgcd_factor : ∀ (q : R.carrier), Prime q → (∀ x ∈ s', q ∣ x) → ¬q ∣ a ∧ ¬q ∣ c) - (t : T) (u : T) (v : T) - (hv : v ∈ Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier))) - (ht_eq : u = R.carrier.subtype a * t) - (huv : u + v = (c : T)) - (ha_zero : (a : T) ≠ 0) - (_hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by - exact - (close_up_aux_b2_nonzero_proof - (R := R) (a := a) (s := s) (c := c) (p := p) hM_not_assoc hAss_ht hT_card hT_aleph0 - n'' ih m ih_m hR_card hs_gcd hs_eq ha_mem s' hs'_def hs_insert hs'_card hp hp_dvd hpa - _hgcd_factor t u v hv ht_eq huv ha_zero _hI_s'_bot - ).down theorem close_up_aux_b2 [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → diff --git a/LeanPool/AndersonConjecture/Jensen/CloseUp/Factor.lean b/LeanPool/AndersonConjecture/Jensen/CloseUp/Factor.lean index c65db1edb6..f13452fc01 100644 --- a/LeanPool/AndersonConjecture/Jensen/CloseUp/Factor.lean +++ b/LeanPool/AndersonConjecture/Jensen/CloseUp/Factor.lean @@ -33,7 +33,201 @@ open Cardinal Ideal variable {T : Type*} [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] -private def close_up_aux_factor_proof +/-- Sub-case A of the factor theorem: a prime `q` divides every generator in `s` +(including `a`). Factor `q` out of `s` and `c`, then use the divisibility induction +hypothesis on `a / q`. -/ +private theorem close_up_aux_factor_divides_a + (n'' : ℕ) + (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) + (s : Finset R.carrier) (_ : s.card ≤ n'' + 1 + 1) (c : R.carrier) + (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) + (m : ℕ) + {R : NSubring T} (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + [DecidableEq R.carrier] + {a : R.carrier} + (ih_a : ∀ (y : R.carrier), DvdNotUnit y a → + ∀ (s : Finset R.carrier), + gcdComplexity s ≤ m → + s.card = n'' + 1 + 1 + 1 → y ∈ s → ∀ (c : R.carrier), + (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier)) → + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) + {s : Finset R.carrier} + (hs_gcd : gcdComplexity s ≤ m) + (hs_eq : s.card = n'' + 1 + 1 + 1) (ha_mem : a ∈ s) + {c : R.carrier} + (hc : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))) + (s' : Finset R.carrier) (hs_insert : s = insert a s') + {q : R.carrier} (hq : Prime q) (hq_dvd_s' : ∀ x ∈ s', q ∣ x) (hqa : q ∣ a) : + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by + have hq_dvd_all : ∀ x ∈ s, q ∣ x := by + intro x hx + rw [hs_insert, Finset.mem_insert] at hx + rcases hx with rfl | hx' + · exact hqa + · exact hq_dvd_s' x hx' + have h_span_le : span (↑s : Set R.carrier) ≤ span {q} := + Ideal.span_le.mpr fun x hx => + Ideal.mem_span_singleton.mpr (hq_dvd_all x (Finset.mem_coe.mp hx)) + have hc_qT : (c : T) ∈ span {(q : T)} := by + have := Ideal.map_mono h_span_le hc + rwa [Ideal.map_span, Set.image_singleton] at this + have hcR := close_up_dvd R q c hc_qT + obtain ⟨c', hcc'⟩ := Ideal.mem_span_singleton.mp hcR + classical + -- Build divided set t_set = {x/q | x ∈ s} + let div_q : R.carrier → R.carrier := fun x => + if h : q ∣ x then Classical.choose h else x + have hdiv_spec : ∀ x ∈ s, x = q * div_q x := by + intro x hx + simpa only [div_q, dite_eq_left (hq_dvd_all x hx)] using + Classical.choose_spec (hq_dvd_all x hx) + let t_set := s.image div_q + have h_ideal_eq : span (↑s : Set R.carrier) = + span {q} * span (↑t_set : Set R.carrier) := + span_eq_mul_span_image_div q s hq_dvd_all div_q hdiv_spec + rw [h_ideal_eq, Ideal.map_mul, Ideal.map_span, Set.image_singleton] at hc + rw [Ideal.mem_span_singleton_mul] at hc + obtain ⟨z, hz, hqz⟩ := hc + have hq_ne : (q : T) ≠ 0 := fun h => hq.ne_zero (Subtype.val_injective h) + have hqc_val : (q : T) * (c' : T) = (c : T) := by + have := congr_arg R.carrier.subtype hcc' + simp only [map_mul] at this + exact this.symm + have hz_eq : z = (c' : T) := mul_left_cancel₀ hq_ne (hqz.trans hqc_val.symm) + have hc'_mem : (c' : T) ∈ Ideal.map R.carrier.subtype + (span (↑t_set : Set R.carrier)) := hz_eq ▸ hz + -- Reduce: find S with c' ∈ span(t_set) in S, then convert back + suffices hsuff : ∃ S : NSubring T, IsAExtension R S ∧ + ∃ (hle : R.carrier ≤ S.carrier), + (⟨(c' : T), hle c'.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) + (span (↑t_set : Set R.carrier)) by + obtain ⟨S, hAext, hle, hc'_S⟩ := hsuff + refine ⟨S, hAext, hle, ?_⟩ + rw [h_ideal_eq, Ideal.map_mul] + have hc_eq : (⟨(c : T), hle c.2⟩ : S.carrier) = + ⟨(q : T), hle q.2⟩ * ⟨(c' : T), hle c'.2⟩ := by + ext + simpa only [Subring.coe_mul] using hqc_val.symm + rw [hc_eq] + exact Ideal.mul_mem_mul + (Ideal.mem_map_of_mem _ (Ideal.subset_span rfl)) hc'_S + -- Handle sub-cases for div_q(a) + have ha'_mem : div_q a ∈ t_set := + Finset.mem_image.mpr ⟨a, ha_mem, rfl⟩ + by_cases ha'_zero : div_q a = 0 + · have ha_zero : a = 0 := by + rw [hdiv_spec a ha_mem, ha'_zero, mul_zero] + set t₀ := t_set.erase (div_q a) with ht₀_def + have ht₀_card : t₀.card ≤ n'' + 1 + 1 := by + have h1 : t_set.card ≤ n'' + 1 + 1 + 1 := + (Finset.card_image_le (f := div_q) (s := s)).trans (le_of_eq hs_eq) + simp only [ht₀_def, Finset.card_erase_of_mem ha'_mem] + omega + have hspan_eq : span (↑t_set : Set R.carrier) = + span (↑t₀ : Set R.carrier) := by + apply le_antisymm + · apply Ideal.span_le.mpr + intro x hx + rcases eq_or_ne x (div_q a) with rfl | hne + · rw [ha'_zero] + exact zero_mem _ + · exact Ideal.subset_span (Finset.mem_coe.mpr + (Finset.mem_erase.mpr ⟨hne, Finset.mem_coe.mp hx⟩)) + · exact Ideal.span_mono (Finset.coe_subset.mpr + (Finset.erase_subset _ _)) + have hc'_t₀ : (c' : T) ∈ Ideal.map R.carrier.subtype + (span (↑t₀ : Set R.carrier)) := hspan_eq ▸ hc'_mem + obtain ⟨S, hAext, hle, hmem⟩ := ih R hR_card t₀ ht₀_card c' hc'_t₀ + exact ⟨S, hAext, hle, Ideal.map_mono + (Ideal.span_mono (Finset.coe_subset.mpr + (Finset.erase_subset _ _))) hmem⟩ + · by_cases ha'_unit : IsUnit (div_q a) + · refine ⟨R, ⟨le_refl _, fun r hr => hr, le_max_right _ _⟩, + le_refl _, ?_⟩ + have h_id : Subring.inclusion (le_refl R.carrier) = + RingHom.id R.carrier := + RingHom.ext fun x => Subtype.ext rfl + change (⟨(c' : T), le_refl R.carrier c'.2⟩ : R.carrier) ∈ + Ideal.map (Subring.inclusion (le_refl R.carrier)) + (span (↑t_set : Set R.carrier)) + rw [h_id, Ideal.map_id, + Ideal.eq_top_of_isUnit_mem _ + (Ideal.subset_span (Finset.mem_coe.mpr ha'_mem)) ha'_unit] + exact Submodule.mem_top + · have hdvd : DvdNotUnit (div_q a) a := + ⟨ha'_zero, ⟨q, hq.not_isUnit, + (hdiv_spec a ha_mem).trans (mul_comm q (div_q a))⟩⟩ + have ht_card : t_set.card = n'' + 1 + 1 + 1 := by + have hinj : Set.InjOn div_q ↑s := fun x hx y hy hxy => by + have hx_eq := hdiv_spec x (Finset.mem_coe.mp hx) + have hy_eq := hdiv_spec y (Finset.mem_coe.mp hy) + calc x = q * div_q x := hx_eq + _ = q * div_q y := by rw [hxy] + _ = y := hy_eq.symm + rw [show t_set = s.image div_q from rfl, + Finset.card_image_of_injOn hinj, hs_eq] + have ht_gcd : gcdComplexity t_set ≤ m := le_trans (by + change gcdComplexity t_set ≤ gcdComplexity s + have hinj : Set.InjOn div_q ↑s := fun x hx y hy hxy => by + have hx_eq := hdiv_spec x (Finset.mem_coe.mp hx) + have hy_eq := hdiv_spec y (Finset.mem_coe.mp hy) + calc x = q * div_q x := hx_eq + _ = q * div_q y := by rw [hxy] + _ = y := hy_eq.symm + exact gcdComplexity_div_le q hq s hq_dvd_all div_q hdiv_spec hinj) hs_gcd + exact ih_a (div_q a) hdvd t_set + ht_gcd ht_card ha'_mem c' hc'_mem + +/-- Dividing the generators `s'` by a prime `q` does not increase the GCD complexity +of `insert a s'`. -/ +private theorem gcdComplexity_insert_image_div_le + {R : NSubring T} [DecidableEq R.carrier] + {a q : R.carrier} (hq : Prime q) {s s' : Finset R.carrier} + (hs'_def : s' = s.erase a) (hs_insert : s = insert a s') + (div_q : R.carrier → R.carrier) (hdiv_spec : ∀ x ∈ s', x = q * div_q x) + (ha_t : a ∉ s'.image div_q) : + gcdComplexity (insert a (s'.image div_q)) ≤ gcdComplexity s := by + let : NormalizationMonoid R.carrier := + UniqueFactorizationMonoid.strongNormalizationMonoid.toNormalizationMonoid + have ha_not_s' : a ∉ s' := by + rw [hs'_def] + simp [Finset.mem_erase] + unfold gcdComplexity + rw [hs_insert, Finset.sum_insert ha_not_s', + Finset.sum_insert ha_t] + apply Nat.add_le_add_left + have hinj_q : Set.InjOn div_q ↑s' := fun x hx y hy hxy => by + have hx_eq := hdiv_spec x (Finset.mem_coe.mp hx) + have hy_eq := hdiv_spec y (Finset.mem_coe.mp hy) + calc x = q * div_q x := hx_eq + _ = q * div_q y := by rw [hxy] + _ = y := hy_eq.symm + rw [Finset.sum_image hinj_q] + apply Finset.sum_le_sum + intro x hx + by_cases hx0 : x = 0 + · subst hx0 + have : div_q 0 = 0 := by + have h := hdiv_spec 0 hx + exact (mul_eq_zero.mp h.symm).resolve_left hq.ne_zero + simp [this] + · have hdvd_x : div_q x ∣ x := + ⟨q, (hdiv_spec x hx).trans (mul_comm q (div_q x))⟩ + by_cases hfx : div_q x = 0 + · simp [hfx, UniqueFactorizationMonoid.normalizedFactors_zero] + · exact Multiset.card_le_card + ((UniqueFactorizationMonoid.dvd_iff_normalizedFactors_le_normalizedFactors + hfx hx0).mp hdvd_x) + +theorem close_up_aux_factor [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -81,133 +275,15 @@ private def close_up_aux_factor_proof (hs'_card : s'.card ≤ n'' + 1 + 1) (_hgcd : ∃ p : R.carrier, Prime p ∧ ∀ x ∈ s', p ∣ x) {p : R.carrier} (_hp : Prime p) (_hp_dvd : ∀ x ∈ s', p ∣ x) - (hpa : ¬p ∣ a) - (hgcd_factor : ∃ q : R.carrier, Prime q ∧ (∀ x ∈ s', q ∣ x) ∧ (q ∣ a ∨ q ∣ c)) : PLift ( + (_hpa : ¬p ∣ a) + (hgcd_factor : ∃ q : R.carrier, Prime q ∧ (∀ x ∈ s', q ∣ x) ∧ (q ∣ a ∨ q ∣ c)) : ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) ) := ⟨by + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by obtain ⟨q, hq, hq_dvd_s', hq_ac⟩ := hgcd_factor by_cases hqa : q ∣ a - · -- Sub-case A: q | a. Factor out q from ALL of s, use ih_a. - have hq_dvd_all : ∀ x ∈ s, q ∣ x := by - intro x hx - rw [hs_insert, Finset.mem_insert] at hx - rcases hx with rfl | hx' - · exact hqa - · exact hq_dvd_s' x hx' - have h_span_le : span (↑s : Set R.carrier) ≤ span {q} := - Ideal.span_le.mpr fun x hx => - Ideal.mem_span_singleton.mpr (hq_dvd_all x (Finset.mem_coe.mp hx)) - have hc_qT : (c : T) ∈ span {(q : T)} := by - have := Ideal.map_mono h_span_le hc - rwa [Ideal.map_span, Set.image_singleton] at this - have hcR := close_up_dvd R q c hc_qT - obtain ⟨c', hcc'⟩ := Ideal.mem_span_singleton.mp hcR - classical - -- Build divided set t_set = {x/q | x ∈ s} - let div_q : R.carrier → R.carrier := fun x => - if h : q ∣ x then Classical.choose h else x - have hdiv_spec : ∀ x ∈ s, x = q * div_q x := by - intro x hx - simpa only [div_q, dite_eq_left (hq_dvd_all x hx)] using - Classical.choose_spec (hq_dvd_all x hx) - let t_set := s.image div_q - have h_ideal_eq : span (↑s : Set R.carrier) = - span {q} * span (↑t_set : Set R.carrier) := - span_eq_mul_span_image_div q s hq_dvd_all div_q hdiv_spec - rw [h_ideal_eq, Ideal.map_mul, Ideal.map_span, Set.image_singleton] at hc - rw [Ideal.mem_span_singleton_mul] at hc - obtain ⟨z, hz, hqz⟩ := hc - have hq_ne : (q : T) ≠ 0 := fun h => hq.ne_zero (Subtype.val_injective h) - have hqc_val : (q : T) * (c' : T) = (c : T) := by - have := congr_arg R.carrier.subtype hcc' - simp only [map_mul] at this - exact this.symm - have hz_eq : z = (c' : T) := mul_left_cancel₀ hq_ne (hqz.trans hqc_val.symm) - have hc'_mem : (c' : T) ∈ Ideal.map R.carrier.subtype - (span (↑t_set : Set R.carrier)) := hz_eq ▸ hz - -- Reduce: find S with c' ∈ span(t_set) in S, then convert back - suffices hsuff : ∃ S : NSubring T, IsAExtension R S ∧ - ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c' : T), hle c'.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) - (span (↑t_set : Set R.carrier)) by - obtain ⟨S, hAext, hle, hc'_S⟩ := hsuff - refine ⟨S, hAext, hle, ?_⟩ - rw [h_ideal_eq, Ideal.map_mul] - have hc_eq : (⟨(c : T), hle c.2⟩ : S.carrier) = - ⟨(q : T), hle q.2⟩ * ⟨(c' : T), hle c'.2⟩ := by - ext - simpa only [Subring.coe_mul] using hqc_val.symm - rw [hc_eq] - exact Ideal.mul_mem_mul - (Ideal.mem_map_of_mem _ (Ideal.subset_span rfl)) hc'_S - -- Handle sub-cases for div_q(a) - have ha'_mem : div_q a ∈ t_set := - Finset.mem_image.mpr ⟨a, ha_mem, rfl⟩ - by_cases ha'_zero : div_q a = 0 - · have ha_zero : a = 0 := by - rw [hdiv_spec a ha_mem, ha'_zero, mul_zero] - set t₀ := t_set.erase (div_q a) with ht₀_def - have ht₀_card : t₀.card ≤ n'' + 1 + 1 := by - have h1 : t_set.card ≤ n'' + 1 + 1 + 1 := - (Finset.card_image_le (f := div_q) (s := s)).trans (le_of_eq hs_eq) - simp only [ht₀_def, Finset.card_erase_of_mem ha'_mem] - omega - have hspan_eq : span (↑t_set : Set R.carrier) = - span (↑t₀ : Set R.carrier) := by - apply le_antisymm - · apply Ideal.span_le.mpr - intro x hx - rcases eq_or_ne x (div_q a) with rfl | hne - · rw [ha'_zero] - exact zero_mem _ - · exact Ideal.subset_span (Finset.mem_coe.mpr - (Finset.mem_erase.mpr ⟨hne, Finset.mem_coe.mp hx⟩)) - · exact Ideal.span_mono (Finset.coe_subset.mpr - (Finset.erase_subset _ _)) - have hc'_t₀ : (c' : T) ∈ Ideal.map R.carrier.subtype - (span (↑t₀ : Set R.carrier)) := hspan_eq ▸ hc'_mem - obtain ⟨S, hAext, hle, hmem⟩ := ih R hR_card t₀ ht₀_card c' hc'_t₀ - exact ⟨S, hAext, hle, Ideal.map_mono - (Ideal.span_mono (Finset.coe_subset.mpr - (Finset.erase_subset _ _))) hmem⟩ - · by_cases ha'_unit : IsUnit (div_q a) - · refine ⟨R, ⟨le_refl _, fun r hr => hr, le_max_right _ _⟩, - le_refl _, ?_⟩ - have h_id : Subring.inclusion (le_refl R.carrier) = - RingHom.id R.carrier := - RingHom.ext fun x => Subtype.ext rfl - change (⟨(c' : T), le_refl R.carrier c'.2⟩ : R.carrier) ∈ - Ideal.map (Subring.inclusion (le_refl R.carrier)) - (span (↑t_set : Set R.carrier)) - rw [h_id, Ideal.map_id, - Ideal.eq_top_of_isUnit_mem _ - (Ideal.subset_span (Finset.mem_coe.mpr ha'_mem)) ha'_unit] - exact Submodule.mem_top - · have hdvd : DvdNotUnit (div_q a) a := - ⟨ha'_zero, ⟨q, hq.not_isUnit, - (hdiv_spec a ha_mem).trans (mul_comm q (div_q a))⟩⟩ - have ht_card : t_set.card = n'' + 1 + 1 + 1 := by - have hinj : Set.InjOn div_q ↑s := fun x hx y hy hxy => by - have hx_eq := hdiv_spec x (Finset.mem_coe.mp hx) - have hy_eq := hdiv_spec y (Finset.mem_coe.mp hy) - calc x = q * div_q x := hx_eq - _ = q * div_q y := by rw [hxy] - _ = y := hy_eq.symm - rw [show t_set = s.image div_q from rfl, - Finset.card_image_of_injOn hinj, hs_eq] - have ht_gcd : gcdComplexity t_set ≤ m := le_trans (by - change gcdComplexity t_set ≤ gcdComplexity s - have hinj : Set.InjOn div_q ↑s := fun x hx y hy hxy => by - have hx_eq := hdiv_spec x (Finset.mem_coe.mp hx) - have hy_eq := hdiv_spec y (Finset.mem_coe.mp hy) - calc x = q * div_q x := hx_eq - _ = q * div_q y := by rw [hxy] - _ = y := hy_eq.symm - exact gcdComplexity_div_le q hq s hq_dvd_all div_q hdiv_spec hinj) hs_gcd - exact ih_a (div_q a) hdvd t_set - ht_gcd ht_card ha'_mem c' hc'_mem + · exact close_up_aux_factor_divides_a n'' ih m hR_card ih_a hs_gcd hs_eq ha_mem hc s' + hs_insert hq hq_dvd_s' hqa · -- Sub-case B1: q does not divide a, q | c. Factor out q from s' and c. have hqc : q ∣ c := by rcases hq_ac with h | h @@ -322,42 +398,10 @@ private def close_up_aux_factor_proof (span (↑(insert a rest) : Set R.carrier)) → ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), (⟨(c_n : T), hle c_n.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑(insert a rest) : Set R.carrier)) from by - refine h_nested b₀ t_set' (Finset.card_image_le.trans hs'_card) ha_t hb₀ ?_ c' hc'_mem - -- gcdComplexity (insert a t_set') ≤ gcdComplexity s - show gcdComplexity (insert a t_set') ≤ gcdComplexity s - let : NormalizationMonoid R.carrier := - UniqueFactorizationMonoid.strongNormalizationMonoid.toNormalizationMonoid - have ha_not_s' : a ∉ s' := by - rw [hs'_def] - simp [Finset.mem_erase] - unfold gcdComplexity - rw [hs_insert, Finset.sum_insert ha_not_s', - Finset.sum_insert ha_t] - apply Nat.add_le_add_left - rw [show t_set' = s'.image div_q' from rfl] - have hinj_q' : Set.InjOn div_q' ↑s' := fun x hx y hy hxy => by - have hx_eq := hdiv_spec' x (Finset.mem_coe.mp hx) - have hy_eq := hdiv_spec' y (Finset.mem_coe.mp hy) - calc x = q * div_q' x := hx_eq - _ = q * div_q' y := by rw [hxy] - _ = y := hy_eq.symm - rw [Finset.sum_image hinj_q'] - apply Finset.sum_le_sum - intro x hx - by_cases hx0 : x = 0 - · subst hx0 - have : div_q' 0 = 0 := by - have h := hdiv_spec' 0 hx - exact (mul_eq_zero.mp h.symm).resolve_left hq.ne_zero - simp [this] - · have hdvd_x : div_q' x ∣ x := - ⟨q, (hdiv_spec' x hx).trans (mul_comm q (div_q' x))⟩ - by_cases hfx : div_q' x = 0 - · simp [hfx, UniqueFactorizationMonoid.normalizedFactors_zero] - · exact Multiset.card_le_card - ((UniqueFactorizationMonoid.dvd_iff_normalizedFactors_le_normalizedFactors - hfx hx0).mp hdvd_x) + Ideal.map (Subring.inclusion hle) (span (↑(insert a rest) : Set R.carrier)) from + h_nested b₀ t_set' (Finset.card_image_le.trans hs'_card) ha_t hb₀ + (gcdComplexity_insert_image_div_le hq hs'_def hs_insert div_q' hdiv_spec' ha_t) + c' hc'_mem -- Proof by WF on b intro b apply wellFounded_dvdNotUnit.induction b @@ -379,65 +423,4 @@ private def close_up_aux_factor_proof hM_not_assoc hAss_ht hT_card hT_aleph0 n'' ih m ih_m hR_card ih_a hs_gcd rest hrest_card ha_rest hb_rest hgcd_rest h_factor hc_n -⟩ - -theorem close_up_aux_factor - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) - (n'' : ℕ) - (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) - (s : Finset R.carrier) (_ : s.card ≤ n'' + 1 + 1) (c : R.carrier) - (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - (m : ℕ) - (ih_m : ∀ m_1, m_1 < m → - ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T), - letI : IsDomain R.carrier := NSubring.isDomain R - letI : UniqueFactorizationMonoid R.carrier := R.isUFD - ∀ (a : R.carrier) (s : Finset R.carrier), - gcdComplexity s ≤ m_1 → - s.card = n'' + 1 + 1 + 1 → a ∈ s → ∀ (c : R.carrier), - (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier)) → - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - {R : NSubring T} (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - [DecidableEq R.carrier] - {a : R.carrier} - (ih_a : ∀ (y : R.carrier), DvdNotUnit y a → - ∀ (s : Finset R.carrier), - gcdComplexity s ≤ m → - s.card = n'' + 1 + 1 + 1 → y ∈ s → ∀ (c : R.carrier), - (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier)) → - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - {s : Finset R.carrier} - (hs_gcd : gcdComplexity s ≤ m) - (hs_eq : s.card = n'' + 1 + 1 + 1) (ha_mem : a ∈ s) - {c : R.carrier} - (hc : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))) - (s' : Finset R.carrier) (hs'_def : s' = s.erase a) - (hs_insert : s = insert a s') - (hs'_card : s'.card ≤ n'' + 1 + 1) - (_hgcd : ∃ p : R.carrier, Prime p ∧ ∀ x ∈ s', p ∣ x) - {p : R.carrier} (_hp : Prime p) (_hp_dvd : ∀ x ∈ s', p ∣ x) - (hpa : ¬p ∣ a) - (hgcd_factor : ∃ q : R.carrier, Prime q ∧ (∀ x ∈ s', q ∣ x) ∧ (q ∣ a ∨ q ∣ c)) : - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by - exact - (close_up_aux_factor_proof - (R := R) (a := a) (s := s) (c := c) (p := p) hM_not_assoc hAss_ht hT_card hT_aleph0 - n'' ih m ih_m hR_card ih_a hs_gcd hs_eq ha_mem hc s' hs'_def hs_insert hs'_card _hgcd - _hp _hp_dvd hpa hgcd_factor - ).down end diff --git a/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean b/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean index 54fbbd7564..a9b49f2a63 100644 --- a/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean +++ b/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean @@ -113,7 +113,432 @@ include T in theorem no_common_I_not_le_assoc exact (Ideal.mem_span_singleton (α := R.carrier)).mp hx_Q exact hno_common_prime q hq_prime hdvd_all -private def close_up_aux_no_common_nonzero_proof +/-- The shifted root set `{x - t | f(x) = 0}` of a nonzero polynomial over `R` is +countable. -/ +private theorem shifted_aeval_roots_countable (R : NSubring T) (t : T) + (f : Polynomial R.carrier) (hf : f ≠ 0) : + ((fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}).Countable := by + apply Set.Countable.image + have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by + rw [Ne, ← Polynomial.map_zero R.carrier.subtype] + exact (Polynomial.map_injective R.carrier.subtype + Subtype.val_injective).ne hf + have h_eq : {x : T | Polynomial.aeval x f = 0} = + {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} := by + ext x + simp [Polynomial.IsRoot, Polynomial.aeval_def, + Polynomial.eval_map, + show algebraMap R.carrier T = R.carrier.subtype from rfl] + rw [h_eq] + exact (Polynomial.finite_setOfPred_isRoot hmap_ne).countable + +/-- For infinite `R`, there are at most `|R|` associated primes of principal ideals +generated by nonzero elements of `R` (together with `⊥`). -/ +private theorem card_assoc_primes_union_bot_le (R : NSubring T) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) : + Cardinal.mk ↑((⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ span {(r : T)})) ∪ ({⊥} : Set (Ideal T))) ≤ + Cardinal.mk R.carrier := by + calc _ + ≤ Cardinal.mk ↑(⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ span {(r : T)})) + + Cardinal.mk ↑({⊥} : Set (Ideal T)) := Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 + + Cardinal.mk R.carrier := by + gcongr + · exact (Cardinal.mk_iUnion_le _).trans + (mul_le_mul_right (ciSup_le' fun r => + Cardinal.mk_le_aleph0_iff.mpr + ((Set.Finite.subset (associatedPrimes.finite T _) + (Set.iUnion_subset fun _ => + le_refl _)).countable.to_subtype)) _) + · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + _ = Cardinal.mk R.carrier := by + rw [Cardinal.mul_aleph0_eq hR_inf, Cardinal.add_eq_left hR_inf le_rfl] + +/-- For infinite `R`, the set of shifted roots of nonzero polynomials over `R` +(together with `-t`) has cardinality at most `|R|`. -/ +private theorem card_shifted_roots_le (R : NSubring T) (t : T) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) : + Cardinal.mk ↑(({-t} : Set T) ∪ ⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), + (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) ≤ Cardinal.mk R.carrier := by + calc _ + ≤ Cardinal.mk ↑({-t} : Set T) + + Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), + (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) := + Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by + gcongr + · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr + Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) + · exact (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' + (Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf)) + (ciSup_le' fun f => Cardinal.mk_le_aleph0_iff.mpr (by + by_cases hf : f = 0 + · exact Set.Countable.to_subtype (by simp [hf]) + · exact (Set.countable_iUnion fun _ => + shifted_aeval_roots_countable R t f hf).to_subtype))).trans + (Cardinal.mul_aleph0_eq hR_inf).le) + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + +/-- For infinite `R`, the set of lifted, shifted roots of the reductions of +polynomials over `R` modulo the associated primes in `C_main` has cardinality at +most `|R|`. -/ +private theorem card_mod_roots_le (R : NSubring T) (t : T) + (φ : (P : Ideal T) → R.carrier →+* T ⧸ P) (liftQ : (P : Ideal T) → T ⧸ P → T) + (C_main : Set (Ideal T)) + (hC_main : C_main = ⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ span {(r : T)})) + (hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier) : + Cardinal.mk ↑(⋃ (P : Ideal T) (_ : P ∈ C_main) (f : Polynomial R.carrier) + (_ : f.map (φ P) ≠ 0), + (fun α => liftQ P α - t) '' { α : T ⧸ P | (f.map (φ P)).IsRoot α }) ≤ + Cardinal.mk R.carrier := by + have hCmain_le : Cardinal.mk C_main ≤ Cardinal.mk R.carrier := by + rw [hC_main] + calc _ + ≤ Cardinal.mk R.carrier * + ⨆ (r : R.carrier), Cardinal.mk ↑(⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ Ideal.span {(r : T)})) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + apply ciSup_le' + intro r + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hr : (r : T) = 0 + · exact Set.Countable.to_subtype (by simp [hr]) + · exact (Set.Finite.subset (associatedPrimes.finite T _) + (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + have h_biUnion : + Cardinal.mk ↑(⋃ P ∈ C_main, + ⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ P) f ≠ 0), + (fun α => liftQ P α - t) '' + {α | (Polynomial.map (φ P) f).IsRoot α}) + ≤ Cardinal.mk R.carrier := by + apply (Cardinal.mk_biUnion_le _ _).trans + have h_inner : + ∀ (x : ↑C_main), + Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), + (fun α => liftQ x.1 α - t) '' + {α | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ + Cardinal.mk R.carrier := by + intro ⟨P, hP⟩ + calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), + ⋃ (_ : Polynomial.map (φ P) f ≠ 0), + (fun α => liftQ P α - t) '' + {α | (Polynomial.map (φ P) f).IsRoot α}) + ≤ Cardinal.mk (Polynomial R.carrier) * + ⨆ (f : Polynomial R.carrier), + Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), + (fun α => liftQ P α - t) '' + {α | (Polynomial.map (φ P) f).IsRoot α}) := + Cardinal.mk_iUnion_le _ + _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by + gcongr + · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) + · apply ciSup_le' + intro f + apply Cardinal.mk_le_aleph0_iff.mpr + by_cases hfne : Polynomial.map (φ P) f = 0 + · exact Set.Countable.to_subtype (by simp [hfne]) + · have : P.IsPrime := by + rw [hC_main, Set.mem_iUnion] at hP + obtain ⟨r, hP'⟩ := hP + rw [Set.mem_iUnion] at hP' + obtain ⟨_, hPmem⟩ := hP' + exact hPmem.isPrime + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + exact (Set.Finite.subset + ((Polynomial.rootSet_finite + (Polynomial.map (φ P) f) + (T ⧸ P)).image + (fun α => liftQ P α - t)) + (Set.iUnion_subset fun _ => + Set.image_mono fun α hα => + Polynomial.mem_rootSet.mpr + ⟨hfne, hα⟩)).countable.to_subtype + _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf + exact (mul_le_mul' hCmain_le (ciSup_le' h_inner)).trans + (Cardinal.mul_eq_self hR_inf).le + exact (Cardinal.mk_le_mk_of_subset fun x hx => hx).trans h_biUnion + +/-- Cardinality bound needed to apply `avoidance` in the no-common-factor case: either +`C × (D ∪ D_mod)` is smaller than the residue field, or both sets are countable. -/ +private theorem no_common_avoidance_bound (R : NSubring T) (t : T) + (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) + (φ : (P : Ideal T) → R.carrier →+* T ⧸ P) (liftQ : (P : Ideal T) → T ⧸ P → T) + (C_main C : Set (Ideal T)) (D D_mod : Set T) + (hC_main : C_main = ⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ span {(r : T)})) + (hC : C = C_main ∪ {⊥}) + (hD : D = {-t} ∪ ⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), + (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) + (hD_mod : D_mod = ⋃ (P : Ideal T) (_ : P ∈ C_main) (f : Polynomial R.carrier) + (_ : f.map (φ P) ≠ 0), + (fun α => liftQ P α - t) '' { α : T ⧸ P | (f.map (φ P)).IsRoot α }) : + Cardinal.mk (↑C × ↑(D ∪ D_mod)) < Cardinal.mk (IsLocalRing.ResidueField T) ∨ + (C.Countable ∧ (D ∪ D_mod).Countable) := by + by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 + · have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le + have : Countable (Polynomial R.carrier) := by + let : Countable (AddMonoidAlgebra R.carrier ℕ) := + Countable.of_equiv _ AddMonoidAlgebra.coeffEquiv.symm + exact Polynomial.toFinsupp_injective.countable + right + have hCmain_countable : C_main.Countable := by + rw [hC_main] + exact Set.countable_iUnion fun r => + Set.countable_iUnion fun _ => + (associatedPrimes.finite T (T ⧸ span {(r : T)})).countable + have hD_countable : D.Countable := by + rw [hD] + exact Set.Countable.union (Set.countable_singleton _) + (Set.countable_iUnion fun f => Set.countable_iUnion fun hf => + shifted_aeval_roots_countable R t f hf) + have hD_mod_countable : D_mod.Countable := by + rw [hD_mod] + exact Set.Countable.biUnion hCmain_countable fun P hPC => by + apply Set.countable_iUnion + intro f + apply Set.countable_iUnion + intro hfne + apply Set.Finite.countable + apply Set.Finite.image + have : P.IsPrime := by + rw [hC_main, Set.mem_iUnion] at hPC + obtain ⟨r, hPC'⟩ := hPC + rw [Set.mem_iUnion] at hPC' + obtain ⟨_, hPmem⟩ := hPC' + exact hPmem.isPrime + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + let : DecidableEq (T ⧸ P) := Classical.decEq _ + apply Set.Finite.subset (f.map (φ P)).roots.toFinset.finite_toSet + intro α hα + exact Multiset.mem_toFinset.mpr ((Polynomial.mem_roots hfne).mpr hα) + rw [hC] + exact ⟨hCmain_countable.union (Set.countable_singleton _), + hD_countable.union hD_mod_countable⟩ + · left + push Not at hR_le + have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le + have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by + rw [hC, hC_main] + exact card_assoc_primes_union_bot_le R hR_inf + have hD_le : Cardinal.mk D ≤ Cardinal.mk R.carrier := by + rw [hD] + exact card_shifted_roots_le R t hR_inf + have hD_mod_le : Cardinal.mk D_mod ≤ Cardinal.mk R.carrier := by + rw [hD_mod] + exact card_mod_roots_le R t φ liftQ C_main hC_main hR_inf + have hD_union_le : Cardinal.mk (D ∪ D_mod : Set T) ≤ Cardinal.mk R.carrier := by + calc Cardinal.mk (D ∪ D_mod : Set T) + ≤ Cardinal.mk D + Cardinal.mk D_mod := Cardinal.mk_union_le _ _ + _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := + add_le_add hD_le hD_mod_le + _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl + calc Cardinal.mk (↑C × ↑(D ∪ D_mod : Set T)) + = Cardinal.mk C * Cardinal.mk (D ∪ D_mod : Set T) := (Cardinal.mul_def _ _).symm + _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := + mul_le_mul' hC_le hD_union_le + _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf + _ < Cardinal.mk T := hR_card + _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + +open scoped Pointwise in +/-- Modular transcendence of `t + δ`: if `δ` avoids every coset `P + (liftQ P α - t)` +for lifted roots `α` of reductions modulo associated primes, then a polynomial over `R` +vanishing at `t + δ` modulo a height-one prime `P` has all coefficients in `P ∩ R`. -/ +private theorem no_common_modular_transcendence + {R : NSubring T} (t δ : T) (C_main C : Set (Ideal T)) (D' : Set T) + (hC_main : C_main = ⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + associatedPrimes T (T ⧸ span {(r : T)})) + (hC_main_le : C_main ⊆ C) + (liftQ : (P : Ideal T) → T ⧸ P → T) + (hliftQ : ∀ (P : Ideal T) (α : T ⧸ P), Ideal.Quotient.mk P (liftQ P α) = α) + (hD_mod_le : ∀ P ∈ C_main, ∀ f : Polynomial R.carrier, + f.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) ≠ 0 → ∀ α : T ⧸ P, + (f.map ((Ideal.Quotient.mk P).comp R.carrier.subtype)).IsRoot α → + liftQ P α - t ∈ D') + (hδ_avoid : ∀ P ∈ C, ∀ r ∈ D', δ ∉ (P : Set T) + ({r} : Set T)) : + ∀ (P : Ideal T), P.IsPrime → P.height ≤ 1 → + P.comap R.carrier.subtype ≠ ⊥ → + ∀ (f : Polynomial R.carrier), + (Polynomial.aeval (t + δ) f : T) ∈ (P : Set T) → + ∀ i, f.coeff i ∈ P.comap R.carrier.subtype := by + intro P hP_prime hP_ht hPR_ne f hf_in i + by_contra h_neg + have hf_bar_ne : f.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) ≠ 0 := by + intro h_eq + apply h_neg + have h := congr_arg (fun p => Polynomial.coeff p i) h_eq + simp only [Polynomial.coeff_map, Polynomial.coeff_zero] at h + exact Ideal.mem_comap.mpr (Ideal.Quotient.eq_zero_iff_mem.mp h) + have hP_in_C_main : P ∈ C_main := by + obtain ⟨r₀, hr₀T_ne, hP_assoc⟩ := + prime_height_le_one_mem_assoc P hP_prime hP_ht hPR_ne + rw [hC_main] + exact Set.mem_iUnion.mpr ⟨r₀, Set.mem_iUnion.mpr ⟨hr₀T_ne, hP_assoc⟩⟩ + -- mk P (t+δ) is a root of the reduction of f in T/P + have := hP_prime + have ht_root : (f.map ((Ideal.Quotient.mk P).comp R.carrier.subtype)).IsRoot + (Ideal.Quotient.mk P (t + δ)) := by + rw [Polynomial.IsRoot, Polynomial.eval_map, + ← Polynomial.hom_eval₂ f R.carrier.subtype (Ideal.Quotient.mk P) (t + δ)] + exact Ideal.Quotient.eq_zero_iff_mem.mpr hf_in + have hlift_in_D' : liftQ P (Ideal.Quotient.mk P (t + δ)) - t ∈ D' := + hD_mod_le P hP_in_C_main f hf_bar_ne _ ht_root + -- δ - (liftQ P (mk P (t+δ)) - t) = (t+δ) - liftQ P (mk P (t+δ)) ∈ P + have hlift_in_P : (t + δ) - liftQ P (Ideal.Quotient.mk P (t + δ)) ∈ P := by + rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, hliftQ] + exact sub_self _ + -- So δ ∈ P + {liftQ P (mk P (t+δ)) - t}, contradicting avoidance + have h_in_sum : δ ∈ (P : Set T) + + ({liftQ P (Ideal.Quotient.mk P (t + δ)) - t} : Set T) := by + refine ⟨(t + δ) - liftQ P (Ideal.Quotient.mk P (t + δ)), hlift_in_P, + liftQ P (Ideal.Quotient.mk P (t + δ)) - t, rfl, ?_⟩ + ring + exact absurd h_in_sum (hδ_avoid P (hC_main_le hP_in_C_main) _ hlift_in_D') + +open scoped Pointwise in +/-- Heitmann reparametrization in the no-common-factor case: find `t'` transcendental +over `R`, avoiding all associated primes, modularly transcendental, and with +`c - t' * a ∈ s'·T`. -/ +private theorem no_common_exists_transcendental + [IsAdicComplete (IsLocalRing.maximalIdeal T) T] + (hM_bot : ¬IsLocalRing.maximalIdeal T = ⊥) + (hM_not_assoc : ∀ (r : T), r ≠ 0 → + IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) + {n'' : ℕ} + {R : NSubring T} (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + [DecidableEq R.carrier] + {a : R.carrier} {s : Finset R.carrier} + (hs_eq : s.card = n'' + 1 + 1 + 1) (ha_mem : a ∈ s) + {c : R.carrier} + (s' : Finset R.carrier) (hs'_def : s' = s.erase a) + (hno_common_prime : ∀ (p : R.carrier), Prime p → ¬(∀ x ∈ s', p ∣ x)) + (t : T) (u : T) (v : T) + (hv : v ∈ Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier))) + (ht_eq : u = R.carrier.subtype a * t) + (huv : u + v = (c : T)) + (hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : + ∃ (t' : T), + Transcendental R.carrier t' ∧ + (∀ (r : R.carrier), (r : T) ≠ 0 → + ∀ P ∈ associatedPrimes T (T ⧸ span {(r : T)}), t' ∉ (P : Set T)) ∧ + ((c : T) - t' * (a : T)) ∈ + Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ∧ + (∀ (P : Ideal T), P.IsPrime → P.height ≤ 1 → + P.comap R.carrier.subtype ≠ ⊥ → + ∀ (f : Polynomial R.carrier), + (Polynomial.aeval t' f : T) ∈ (P : Set T) → + ∀ i, f.coeff i ∈ P.comap R.carrier.subtype) := by + set I_s' := Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) + set C : Set (Ideal T) := + (⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + (associatedPrimes T (T ⧸ span {(r : T)}))) ∪ {⊥} + set D : Set T := + {-t} ∪ ⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), + (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0} + have hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥ := hM_bot + have hC_prime : ∀ P ∈ C, P.IsPrime := by + intro P hP + rcases (Set.mem_union _ _ _).mp hP with h | h + · rw [Set.mem_iUnion] at h + obtain ⟨r, h⟩ := h + rw [Set.mem_iUnion] at h + obtain ⟨_, hPmem⟩ := h + exact hPmem.isPrime + · exact Set.mem_singleton_iff.mp h ▸ Ideal.isPrime_bot + have hC_ne_max : ∀ P ∈ C, P ≠ IsLocalRing.maximalIdeal T := by + intro P hP + rcases (Set.mem_union _ _ _).mp hP with h | h + · rw [Set.mem_iUnion] at h + obtain ⟨r, h⟩ := h + rw [Set.mem_iUnion] at h + obtain ⟨hr, hPmem⟩ := h + exact fun heq => hM_not_assoc (r : T) hr (heq ▸ hPmem) + · rw [Set.mem_singleton_iff.mp h] + exact fun h => hM_ne_bot h.symm + have hI_not_le : ∀ P ∈ C, ¬(I_s' ≤ P) := by + intro P hP hle + rcases (Set.mem_union _ _ _).mp hP with h | h + · rw [Set.mem_iUnion] at h + obtain ⟨r, h⟩ := h + rw [Set.mem_iUnion] at h + obtain ⟨hr_ne, hP_mem⟩ := h + exact no_common_I_not_le_assoc hs_eq ha_mem s' hs'_def + hno_common_prime hI_s'_bot r hr_ne P hP_mem hle + · rw [Set.mem_singleton_iff.mp h] at hle + exact hI_s'_bot (le_antisymm hle bot_le) + let C_main : Set (Ideal T) := ⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), + (associatedPrimes T (T ⧸ span {(r : T)})) + have hC_eq_main : C = C_main ∪ {⊥} := rfl + let φ : (P : Ideal T) → R.carrier →+* T ⧸ P := + fun P => (Ideal.Quotient.mk P).comp R.carrier.subtype + let liftQ : (P : Ideal T) → T ⧸ P → T := + fun P α => (Ideal.Quotient.mk_surjective α).choose + have hliftQ : ∀ (P : Ideal T) (α : T ⧸ P), + Ideal.Quotient.mk P (liftQ P α) = α := + fun P α => (Ideal.Quotient.mk_surjective α).choose_spec + let D_mod : Set T := + ⋃ (P : Ideal T) (_ : P ∈ C_main) (f : Polynomial R.carrier) + (_ : f.map (φ P) ≠ 0), + (fun α => liftQ P α - t) '' { α : T ⧸ P | (f.map (φ P)).IsRoot α } + let D' : Set T := D ∪ D_mod + have hCD'_bound : Cardinal.mk (↑C × ↑D') < + Cardinal.mk (IsLocalRing.ResidueField T) ∨ + (C.Countable ∧ D'.Countable) := + no_common_avoidance_bound R t hR_card hT_card φ liftQ C_main C D D_mod rfl rfl rfl rfl + obtain ⟨δ, hδ_mem, hδ_avoid⟩ := + avoidance hC_prime hC_ne_max hCD'_bound hI_not_le + refine ⟨t + δ, ?_, ?_, ?_, ?_⟩ + · -- Transcendence: δ is a shifted root in D', contradicting avoidance of ⊥ ∈ C + rw [Transcendental] + intro ⟨p, hp_ne, hp_eval⟩ + have hδ_in_D : δ ∈ D := Set.mem_union_right _ + (Set.mem_iUnion.mpr ⟨p, Set.mem_iUnion.mpr ⟨hp_ne, + ⟨t + δ, hp_eval, by ring⟩⟩⟩) + have hδ_in_D' : δ ∈ D' := Set.mem_union_left _ hδ_in_D + have hbot_in_C : (⊥ : Ideal T) ∈ C := Set.mem_union_right _ rfl + have h_absurd : δ ∈ ((⊥ : Ideal T) : Set T) + ({δ} : Set T) := by + have := Set.add_mem_add ((⊥ : Ideal T).zero_mem) + (show δ ∈ ({δ} : Set T) from rfl) + rwa [zero_add] at this + exact absurd h_absurd (hδ_avoid ⊥ hbot_in_C δ hδ_in_D') + · -- Prime avoidance: δ ∉ P + {-t} implies t + δ ∉ P + intro r hr P hP hmem + have hP_in_C : P ∈ C := Set.mem_union_left _ + (Set.mem_iUnion.mpr ⟨r, Set.mem_iUnion.mpr ⟨hr, hP⟩⟩) + have h_neg_t_in_D : -t ∈ D := Set.mem_union_left _ rfl + have h_neg_t_in_D' : -t ∈ D' := Set.mem_union_left _ h_neg_t_in_D + have h_in_sum : δ ∈ (P : Set T) + ({-t} : Set T) := by + have := Set.add_mem_add hmem (show -t ∈ ({-t} : Set T) from rfl) + rwa [show (t + δ) + -t = δ from by ring] at this + exact absurd h_in_sum (hδ_avoid P hP_in_C (-t) h_neg_t_in_D') + · -- Remainder: c - (t+δ)*a = v - δ*a ∈ I_s' + suffices hrw : (↑c : T) - (t + δ) * (↑a : T) = v - δ * (↑a : T) by + rw [hrw] + exact Submodule.sub_mem _ hv (Ideal.mul_mem_right _ _ hδ_mem) + have hsub : R.carrier.subtype a = (↑a : T) := rfl + rw [hsub] at ht_eq + have h_c_eq : (↑c : T) = (↑a : T) * t + v := by rw [← huv, ht_eq] + rw [h_c_eq] + ring + · exact no_common_modular_transcendence t δ C_main C D' rfl Set.subset_union_left liftQ + hliftQ (fun P hP f hf α hα => Set.mem_union_right _ + (Set.mem_iUnion.mpr ⟨P, Set.mem_iUnion.mpr ⟨hP, + Set.mem_iUnion.mpr ⟨f, Set.mem_iUnion.mpr ⟨hf, ⟨α, hα, rfl⟩⟩⟩⟩⟩)) hδ_avoid + +-- Extracted: no-common-factor branch of close_up_aux_wf. +-- When no prime divides all generators in s', use Heitmann reparametrization. +include T in theorem close_up_aux_no_common_nonzero [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -143,10 +568,10 @@ private def close_up_aux_no_common_nonzero_proof (ht_eq : u = R.carrier.subtype a * t) (huv : u + v = (c : T)) (ha_zero : (a : T) ≠ 0) - (hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : PLift ( + (hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) ) := ⟨by + Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by by_cases hM_bot : IsLocalRing.maximalIdeal T = ⊥ · refine ⟨R, ⟨le_refl _, fun r hr => hr, le_max_right _ _⟩, le_refl _, ?_⟩ have h_id : Subring.inclusion (le_refl R.carrier) = RingHom.id R.carrier := @@ -162,403 +587,9 @@ private def close_up_aux_no_common_nonzero_proof rw [Ideal.eq_top_of_isUnit_mem _ (Ideal.subset_span (Finset.mem_coe.mpr ha_mem)) ha_unit] exact Submodule.mem_top - open scoped Pointwise in - have hexists_t : ∃ (t' : T), - Transcendental R.carrier t' ∧ - (∀ (r : R.carrier), (r : T) ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ span {(r : T)}), t' ∉ (P : Set T)) ∧ - ((c : T) - t' * (a : T)) ∈ - Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ∧ - (∀ (P : Ideal T), P.IsPrime → P.height ≤ 1 → - P.comap R.carrier.subtype ≠ ⊥ → - ∀ (f : Polynomial R.carrier), - (Polynomial.aeval t' f : T) ∈ (P : Set T) → - ∀ i, f.coeff i ∈ P.comap R.carrier.subtype) := by - set I_s' := Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) - set C : Set (Ideal T) := - (⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), - (associatedPrimes T (T ⧸ span {(r : T)}))) ∪ {⊥} - set D : Set T := - {-t} ∪ ⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), - (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0} - have hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥ := hM_bot - have hD_root_countable'' : ∀ (f : Polynomial R.carrier), f ≠ 0 → - ((fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}).Countable := by - intro f hf - apply Set.Countable.image - have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by - rw [Ne, ← Polynomial.map_zero R.carrier.subtype] - exact (Polynomial.map_injective R.carrier.subtype - Subtype.val_injective).ne hf - have h_eq : {x : T | Polynomial.aeval x f = 0} = - {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} := by - ext x - simp [Polynomial.IsRoot, Polynomial.aeval_def, - Polynomial.eval_map, - show algebraMap R.carrier T = R.carrier.subtype from rfl] - rw [h_eq] - exact (Polynomial.finite_setOfPred_isRoot hmap_ne).countable - have hC_prime : ∀ P ∈ C, P.IsPrime := by - intro P hP - rcases (Set.mem_union _ _ _).mp hP with h | h - · rw [Set.mem_iUnion] at h - obtain ⟨r, h⟩ := h - rw [Set.mem_iUnion] at h - obtain ⟨_, hPmem⟩ := h - exact hPmem.isPrime - · exact Set.mem_singleton_iff.mp h ▸ Ideal.isPrime_bot - have hC_ne_max : ∀ P ∈ C, P ≠ IsLocalRing.maximalIdeal T := by - intro P hP - rcases (Set.mem_union _ _ _).mp hP with h | h - · rw [Set.mem_iUnion] at h - obtain ⟨r, h⟩ := h - rw [Set.mem_iUnion] at h - obtain ⟨hr, hPmem⟩ := h - exact fun heq => hM_not_assoc (r : T) hr (heq ▸ hPmem) - · rw [Set.mem_singleton_iff.mp h] - exact fun h => hM_ne_bot h.symm - have hCD_bound'' : Cardinal.mk (↑C × ↑D) < - Cardinal.mk (IsLocalRing.ResidueField T) ∨ - (C.Countable ∧ D.Countable) := by - by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 - · have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le - have : Countable (Polynomial R.carrier) := by - let : Countable (AddMonoidAlgebra R.carrier ℕ) := - Countable.of_equiv _ AddMonoidAlgebra.coeffEquiv.symm - exact Polynomial.toFinsupp_injective.countable - right - exact ⟨Set.Countable.union (Set.countable_iUnion fun r => - Set.countable_iUnion fun _ => - (associatedPrimes.finite T (T ⧸ span {(r : T)})).countable) - (Set.countable_singleton _), - Set.Countable.union (Set.countable_singleton _) - (Set.countable_iUnion fun f => Set.countable_iUnion fun hf => - hD_root_countable'' f hf)⟩ - · left - push Not at hR_le - have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le - have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C - ≤ Cardinal.mk ↑(⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), - associatedPrimes T (T ⧸ span {(r : T)})) + - Cardinal.mk ↑({⊥} : Set (Ideal T)) := Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 + - Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_iUnion_le _).trans - (mul_le_mul_right (ciSup_le' fun r => - Cardinal.mk_le_aleph0_iff.mpr - ((Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => - le_refl _)).countable.to_subtype)) _) - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - _ = Cardinal.mk R.carrier := by - rw [Cardinal.mul_aleph0_eq hR_inf, Cardinal.add_eq_left hR_inf le_rfl] - have hD_le : Cardinal.mk D ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D - ≤ Cardinal.mk ↑({-t} : Set T) + - Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), - (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - · exact (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' - (Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf)) - (ciSup_le' fun f => Cardinal.mk_le_aleph0_iff.mpr (by - by_cases hf : f = 0 - · exact Set.Countable.to_subtype (by simp [hf]) - · exact (Set.countable_iUnion fun _ => - hD_root_countable'' f hf).to_subtype))).trans - (Cardinal.mul_aleph0_eq hR_inf).le) - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - calc Cardinal.mk (↑C × ↑D) - = Cardinal.mk C * Cardinal.mk D := (Cardinal.mul_def _ _).symm - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := - mul_le_mul' hC_le hD_le - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - _ < Cardinal.mk T := hR_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card - -- Precondition: I_s' ⊄ P for all P ∈ C (via helper) - have hI_not_le : ∀ P ∈ C, ¬(I_s' ≤ P) := by - intro P hP hle - rcases (Set.mem_union _ _ _).mp hP with h | h - · rw [Set.mem_iUnion] at h - obtain ⟨r, h⟩ := h - rw [Set.mem_iUnion] at h - obtain ⟨hr_ne, hP_mem⟩ := h - exact no_common_I_not_le_assoc hs_eq ha_mem s' hs'_def - hno_common_prime hI_s'_bot r hr_ne P hP_mem hle - · rw [Set.mem_singleton_iff.mp h] at hle - exact hI_s'_bot (le_antisymm hle bot_le) - let C_main : Set (Ideal T) := ⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), - (associatedPrimes T (T ⧸ span {(r : T)})) - have hC_eq_main : C = C_main ∪ {⊥} := rfl - let φ : (P : Ideal T) → R.carrier →+* T ⧸ P := - fun P => (Ideal.Quotient.mk P).comp R.carrier.subtype - let liftQ : (P : Ideal T) → T ⧸ P → T := - fun P α => (Ideal.Quotient.mk_surjective α).choose - have hliftQ : ∀ (P : Ideal T) (α : T ⧸ P), - Ideal.Quotient.mk P (liftQ P α) = α := - fun P α => (Ideal.Quotient.mk_surjective α).choose_spec - let D_mod : Set T := - ⋃ (P : Ideal T) (_ : P ∈ C_main) (f : Polynomial R.carrier) - (_ : f.map (φ P) ≠ 0), - (fun α => liftQ P α - t) '' { α : T ⧸ P | (f.map (φ P)).IsRoot α } - let D' : Set T := D ∪ D_mod - have hCD'_bound : Cardinal.mk (↑C × ↑D') < - Cardinal.mk (IsLocalRing.ResidueField T) ∨ - (C.Countable ∧ D'.Countable) := by - by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 - · have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le - have : Countable (Polynomial R.carrier) := by - let : Countable (AddMonoidAlgebra R.carrier ℕ) := - Countable.of_equiv _ AddMonoidAlgebra.coeffEquiv.symm - exact Polynomial.toFinsupp_injective.countable - right - have hC_countable : C.Countable := - Set.Countable.union (Set.countable_iUnion fun r => - Set.countable_iUnion fun _ => - (associatedPrimes.finite T (T ⧸ span {(r : T)})).countable) - (Set.countable_singleton _) - have hD_countable : D.Countable := - Set.Countable.union (Set.countable_singleton _) - (Set.countable_iUnion fun f => Set.countable_iUnion fun hf => - hD_root_countable'' f hf) - have hD_mod_countable : D_mod.Countable := by - have hCmain_countable : C_main.Countable := - Set.countable_iUnion fun r => - Set.countable_iUnion fun _ => - (associatedPrimes.finite T (T ⧸ span {(r : T)})).countable - exact Set.Countable.biUnion hCmain_countable fun P hPC => by - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hfne - apply Set.Finite.countable - apply Set.Finite.image - have : P.IsPrime := by - rw [Set.mem_iUnion] at hPC - obtain ⟨r, hPC'⟩ := hPC - rw [Set.mem_iUnion] at hPC' - obtain ⟨_, hPmem⟩ := hPC' - exact hPmem.isPrime - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - let : DecidableEq (T ⧸ P) := Classical.decEq _ - apply Set.Finite.subset (f.map (φ P)).roots.toFinset.finite_toSet - intro α hα - exact Multiset.mem_toFinset.mpr ((Polynomial.mem_roots hfne).mpr hα) - exact ⟨hC_countable, Set.Countable.union hD_countable hD_mod_countable⟩ - · left - push Not at hR_le - have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le - have hC_le : Cardinal.mk C ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C - ≤ Cardinal.mk ↑(⋃ (r : R.carrier), ⋃ (_ : (r : T) ≠ 0), - associatedPrimes T (T ⧸ span {(r : T)})) + - Cardinal.mk ↑({⊥} : Set (Ideal T)) := Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 + - Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_iUnion_le _).trans - (mul_le_mul_right (ciSup_le' fun r => - Cardinal.mk_le_aleph0_iff.mpr - ((Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => - le_refl _)).countable.to_subtype)) _) - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - _ = Cardinal.mk R.carrier := by - rw [Cardinal.mul_aleph0_eq hR_inf, Cardinal.add_eq_left hR_inf le_rfl] - have hD_le : Cardinal.mk D ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D - ≤ Cardinal.mk ↑({-t} : Set T) + - Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), ⋃ (_ : f ≠ 0), - (fun x => x - t) '' {x : T | Polynomial.aeval x f = 0}) := - Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := by - gcongr - · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr - Set.subsingleton_singleton).trans (one_le_aleph0.trans hR_inf) - · exact (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' - (Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf)) - (ciSup_le' fun f => Cardinal.mk_le_aleph0_iff.mpr (by - by_cases hf : f = 0 - · exact Set.Countable.to_subtype (by simp [hf]) - · exact (Set.countable_iUnion fun _ => - hD_root_countable'' f hf).to_subtype))).trans - (Cardinal.mul_aleph0_eq hR_inf).le) - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - have hD_mod_le : Cardinal.mk D_mod ≤ Cardinal.mk R.carrier := by - have hCmain_le : Cardinal.mk C_main ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C_main - ≤ Cardinal.mk R.carrier * - ⨆ (r : R.carrier), Cardinal.mk ↑(⋃ (_ : (r : T) ≠ 0), - associatedPrimes T (T ⧸ Ideal.span {(r : T)})) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - apply ciSup_le' - intro r - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hr : (r : T) = 0 - · exact Set.Countable.to_subtype (by simp [hr]) - · exact (Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - have h_biUnion : - Cardinal.mk ↑(⋃ P ∈ C_main, - ⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α | (Polynomial.map (φ P) f).IsRoot α}) - ≤ Cardinal.mk R.carrier := by - apply (Cardinal.mk_biUnion_le _ _).trans - have h_inner : - ∀ (x : ↑C_main), - Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ x.1) f ≠ 0), - (fun α => liftQ x.1 α - t) '' - {α | (Polynomial.map (φ x.1) f).IsRoot α}) ≤ - Cardinal.mk R.carrier := by - intro ⟨P, hP⟩ - calc Cardinal.mk ↑(⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α | (Polynomial.map (φ P) f).IsRoot α}) - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), - Cardinal.mk ↑(⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α | (Polynomial.map (φ P) f).IsRoot α}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hfne : Polynomial.map (φ P) f = 0 - · exact Set.Countable.to_subtype (by simp [hfne]) - · have : P.IsPrime := by - rw [Set.mem_iUnion] at hP - obtain ⟨r, hP'⟩ := hP - rw [Set.mem_iUnion] at hP' - obtain ⟨_, hPmem⟩ := hP' - exact hPmem.isPrime - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - exact (Set.Finite.subset - ((Polynomial.rootSet_finite - (Polynomial.map (φ P) f) - (T ⧸ P)).image - (fun α => liftQ P α - t)) - (Set.iUnion_subset fun _ => - Set.image_mono fun α hα => - Polynomial.mem_rootSet.mpr - ⟨hfne, hα⟩)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - exact (mul_le_mul' hCmain_le (ciSup_le' h_inner)).trans - (Cardinal.mul_eq_self hR_inf).le - calc Cardinal.mk D_mod - ≤ Cardinal.mk ↑(⋃ P ∈ C_main, ⋃ (f : Polynomial R.carrier), - ⋃ (_ : Polynomial.map (φ P) f ≠ 0), - (fun α => liftQ P α - t) '' - {α | (Polynomial.map (φ P) f).IsRoot α}) := by - apply Cardinal.mk_le_mk_of_subset - intro x hx - exact hx - _ ≤ Cardinal.mk R.carrier := h_biUnion - have hD'_le : Cardinal.mk D' ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D' - ≤ Cardinal.mk D + Cardinal.mk D_mod := Cardinal.mk_union_le _ _ - _ ≤ Cardinal.mk R.carrier + Cardinal.mk R.carrier := - add_le_add hD_le hD_mod_le - _ = Cardinal.mk R.carrier := Cardinal.add_eq_left hR_inf le_rfl - calc Cardinal.mk (↑C × ↑D') - = Cardinal.mk C * Cardinal.mk D' := (Cardinal.mul_def _ _).symm - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := - mul_le_mul' hC_le hD'_le - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - _ < Cardinal.mk T := hR_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card - obtain ⟨δ, hδ_mem, hδ_avoid⟩ := - avoidance hC_prime hC_ne_max hCD'_bound hI_not_le - refine ⟨t + δ, ?_, ?_, ?_, ?_⟩ - · -- Transcendence: δ is a shifted root in D', contradicting avoidance of ⊥ ∈ C - rw [Transcendental] - intro ⟨p, hp_ne, hp_eval⟩ - have hδ_in_D : δ ∈ D := Set.mem_union_right _ - (Set.mem_iUnion.mpr ⟨p, Set.mem_iUnion.mpr ⟨hp_ne, - ⟨t + δ, hp_eval, by ring⟩⟩⟩) - have hδ_in_D' : δ ∈ D' := Set.mem_union_left _ hδ_in_D - have hbot_in_C : (⊥ : Ideal T) ∈ C := Set.mem_union_right _ rfl - have h_absurd : δ ∈ ((⊥ : Ideal T) : Set T) + ({δ} : Set T) := by - have := Set.add_mem_add ((⊥ : Ideal T).zero_mem) - (show δ ∈ ({δ} : Set T) from rfl) - rwa [zero_add] at this - exact absurd h_absurd (hδ_avoid ⊥ hbot_in_C δ hδ_in_D') - · -- Prime avoidance: δ ∉ P + {-t} implies t + δ ∉ P - intro r hr P hP hmem - have hP_in_C : P ∈ C := Set.mem_union_left _ - (Set.mem_iUnion.mpr ⟨r, Set.mem_iUnion.mpr ⟨hr, hP⟩⟩) - have h_neg_t_in_D : -t ∈ D := Set.mem_union_left _ rfl - have h_neg_t_in_D' : -t ∈ D' := Set.mem_union_left _ h_neg_t_in_D - have h_in_sum : δ ∈ (P : Set T) + ({-t} : Set T) := by - have := Set.add_mem_add hmem (show -t ∈ ({-t} : Set T) from rfl) - rwa [show (t + δ) + -t = δ from by ring] at this - exact absurd h_in_sum (hδ_avoid P hP_in_C (-t) h_neg_t_in_D') - · -- Remainder: c - (t+δ)*a = v - δ*a ∈ I_s' - suffices hrw : (↑c : T) - (t + δ) * (↑a : T) = v - δ * (↑a : T) by - rw [hrw] - exact Submodule.sub_mem _ hv (Ideal.mul_mem_right _ _ hδ_mem) - have hsub : R.carrier.subtype a = (↑a : T) := rfl - rw [hsub] at ht_eq - have h_c_eq : (↑c : T) = (↑a : T) * t + v := by rw [← huv, ht_eq] - rw [h_c_eq] - ring - · -- Modular transcendence: f(t+δ) ∈ P implies all coefficients lie in P∩R - intro P hP_prime hP_ht hPR_ne f hf_in i - by_contra h_neg - have hf_bar_ne : f.map (φ P) ≠ 0 := by - intro h_eq - apply h_neg - have h := congr_arg (fun p => Polynomial.coeff p i) h_eq - simp only [Polynomial.coeff_map, Polynomial.coeff_zero] at h - exact Ideal.mem_comap.mpr (Ideal.Quotient.eq_zero_iff_mem.mp h) - have hP_in_C_main : P ∈ C_main := by - obtain ⟨r₀, hr₀T_ne, hP_assoc⟩ := - prime_height_le_one_mem_assoc P hP_prime hP_ht hPR_ne - exact Set.mem_iUnion.mpr ⟨r₀, Set.mem_iUnion.mpr ⟨hr₀T_ne, hP_assoc⟩⟩ - -- mk P (t+δ) is a root of f.map (φ P) in T/P - have := hP_prime - have ht_root : (f.map (φ P)).IsRoot (Ideal.Quotient.mk P (t + δ)) := by - rw [Polynomial.IsRoot, Polynomial.eval_map] - rw [show φ P = (Ideal.Quotient.mk P).comp R.carrier.subtype from rfl, - ← Polynomial.hom_eval₂ f R.carrier.subtype (Ideal.Quotient.mk P) (t + δ)] - exact Ideal.Quotient.eq_zero_iff_mem.mpr hf_in - -- liftQ P (mk P (t+δ)) - t ∈ D_mod ⊆ D' - have hlift_in_D_mod : liftQ P (Ideal.Quotient.mk P (t + δ)) - t ∈ D_mod := - Set.mem_iUnion.mpr ⟨P, Set.mem_iUnion.mpr ⟨hP_in_C_main, - Set.mem_iUnion.mpr ⟨f, Set.mem_iUnion.mpr ⟨hf_bar_ne, - ⟨Ideal.Quotient.mk P (t + δ), ht_root, rfl⟩⟩⟩⟩⟩ - have hlift_in_D' : liftQ P (Ideal.Quotient.mk P (t + δ)) - t ∈ D' := - Set.mem_union_right _ hlift_in_D_mod - have hP_in_C : P ∈ C := - Set.mem_union_left _ hP_in_C_main - -- δ - (liftQ P (mk P (t+δ)) - t) = (t+δ) - liftQ P (mk P (t+δ)) ∈ P - have hlift_in_P : (t + δ) - liftQ P (Ideal.Quotient.mk P (t + δ)) ∈ P := by - rw [← Ideal.Quotient.eq_zero_iff_mem, map_sub, hliftQ] - exact sub_self _ - -- So δ ∈ P + {liftQ P (mk P (t+δ)) - t}, contradicting avoidance - have h_in_sum : δ ∈ (P : Set T) + - ({liftQ P (Ideal.Quotient.mk P (t + δ)) - t} : Set T) := by - refine ⟨(t + δ) - liftQ P (Ideal.Quotient.mk P (t + δ)), hlift_in_P, - liftQ P (Ideal.Quotient.mk P (t + δ)) - t, rfl, ?_⟩ - ring - exact absurd h_in_sum (hδ_avoid P hP_in_C _ hlift_in_D') - obtain ⟨t', ht'_trans, ht'_avoid, hrem_T, ht'_mod_trans⟩ := hexists_t + obtain ⟨t', ht'_trans, ht'_avoid, hrem_T, ht'_mod_trans⟩ := + no_common_exists_transcendental hM_bot hM_not_assoc hT_card hR_card hs_eq ha_mem s' + hs'_def hno_common_prime t u v hv ht_eq huv hI_s'_bot -- Step 4: Adjoin t' to R → S₁ (NSubring, A-extension of R) obtain ⟨S₁, hAext₁, ht'_S₁⟩ := adjoin_transcendental_isNSubring R t' ht'_trans @@ -612,50 +643,7 @@ private def close_up_aux_no_common_nonzero_proof · exact Subtype.ext (by simp only [Subring.coe_add, Subring.coe_mul] ring) -⟩ --- Extracted: no-common-factor branch of close_up_aux_wf. --- When no prime divides all generators in s', use Heitmann reparametrization. -include T in theorem close_up_aux_no_common_nonzero - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) - (n'' : ℕ) - (ih : ∀ (R : NSubring T) (_ : Cardinal.mk R.carrier < Cardinal.mk T) - (s : Finset R.carrier) (_ : s.card ≤ n'' + 1 + 1) (c : R.carrier) - (_ : (c : T) ∈ Ideal.map R.carrier.subtype (span (↑s : Set R.carrier))), - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier))) - {R : NSubring T} (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - [DecidableEq R.carrier] - {a : R.carrier} {s : Finset R.carrier} - (hs_eq : s.card = n'' + 1 + 1 + 1) (ha_mem : a ∈ s) - {c : R.carrier} - (s' : Finset R.carrier) (hs'_def : s' = s.erase a) - (hs_insert : s = insert a s') - (hs'_card : s'.card ≤ n'' + 1 + 1) - (_hgcd : ¬∃ p : R.carrier, Prime p ∧ ∀ x ∈ s', p ∣ x) - (hno_common_prime : ∀ (p : R.carrier), Prime p → ¬(∀ x ∈ s', p ∣ x)) - (t : T) (u : T) (v : T) - (hv : v ∈ Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier))) - (ht_eq : u = R.carrier.subtype a * t) - (huv : u + v = (c : T)) - (ha_zero : (a : T) ≠ 0) - (hI_s'_bot : Ideal.map R.carrier.subtype (span (↑s' : Set R.carrier)) ≠ ⊥) : - ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) (span (↑s : Set R.carrier)) := by - exact - (close_up_aux_no_common_nonzero_proof - (R := R) (a := a) (s := s) (c := c) hM_not_assoc hAss_ht hT_card hT_aleph0 n'' ih - hR_card hs_eq ha_mem s' hs'_def hs_insert hs'_card _hgcd hno_common_prime t u v hv - ht_eq huv ha_zero hI_s'_bot - ).down include T in theorem close_up_aux_no_common [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → diff --git a/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean b/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean index 0fde43c393..770e785948 100644 --- a/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean +++ b/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean @@ -149,8 +149,97 @@ include T in private theorem union_card_le_max _ ≤ κ * κ := mul_le_mul' hι_card (ciSup_le fun α => hfq_card α) _ ≤ κ := (Cardinal.mul_le_max_of_aleph0_le_left (le_max_left ..)).trans_eq (max_self κ) -/-- Build the transfinite recursion and prove its invariant for close_up_all. -/ -private def close_up_all_one_pass_aux_proof + +/- `#(Finset R × R) ≤ max(ℵ₀, #R)`: for infinite `R`, `#(Finset R × R) = #R`. -/ +include T in private theorem card_finset_prod_le (R' : NSubring T) : + Cardinal.mk (Finset R'.carrier × R'.carrier) ≤ + max Cardinal.aleph0 (Cardinal.mk R'.carrier) := by + by_cases hfin : Finite R'.carrier + · exact le_trans Cardinal.mk_le_aleph0 (le_max_left ..) + · have : Infinite R'.carrier := not_finite_iff_infinite.mp hfin + simpa only [Cardinal.mk_prod, Cardinal.lift_id, + Cardinal.mk_finset_of_infinite, Cardinal.mul_eq_self (Cardinal.aleph0_le_mk R'.carrier)] + using (le_max_right Cardinal.aleph0 (Cardinal.mk R'.carrier)) + +/- Assembly of the one-pass close-up: the union of a chain `f` of A-extensions of `R'` +is an A-extension of `R'` of small cardinality in which every pair `(I, c)` closed at +some stage stays closed. -/ +include T in private theorem close_up_all_one_pass_union + {ι : Type u} [LinearOrder ι] [Nonempty ι] + (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) + (R' : NSubring T) (hR' : Cardinal.mk R'.carrier < Cardinal.mk T) (f : ι → NSubring T) + (hι_card : Cardinal.mk ι ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier)) + (hR'_le : ∀ p, ∃ (hle : R'.carrier ≤ (f p).carrier), + ∀ (r : R'.carrier), Prime r → Prime (⟨r.1, hle r.2⟩ : (f p).carrier)) + (hcard : ∀ p, Cardinal.mk (f p).carrier ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier)) + (hchain : ∀ p q, q < p → ∃ (hle : (f q).carrier ≤ (f p).carrier), + ∀ (r : (f q).carrier), Prime r → Prime (⟨r.1, hle r.2⟩ : (f p).carrier)) + (hclose : ∀ (gens : Finset R'.carrier) (c : R'.carrier), + (c : T) ∈ Ideal.map R'.carrier.subtype (Ideal.span ↑gens) → + ∃ p, ∃ (hle : R'.carrier ≤ (f p).carrier), + (⟨(c : T), hle c.2⟩ : (f p).carrier) ∈ + Ideal.map (Subring.inclusion hle) (Ideal.span ↑gens)) : + ∃ S : NSubring T, IsAExtension R' S ∧ Cardinal.mk S.carrier < Cardinal.mk T ∧ + (∀ (I : Ideal R'.carrier) (_ : I.FG) (c : R'.carrier), + (c : T) ∈ Ideal.map R'.carrier.subtype I → + ∃ (hle : R'.carrier ≤ S.carrier), + (⟨(c : T), hle c.2⟩ : S.carrier) ∈ + Ideal.map (Subring.inclusion hle) I) := by + have hf_mono : ∀ ⦃a b : ι⦄, a ≤ b → (f a).carrier ≤ (f b).carrier := by + intro a b hab + rcases eq_or_lt_of_le hab with rfl | hlt + · exact le_refl _ + · exact (hchain b a hlt).choose + have hf_primes : ∀ ⦃a b : ι⦄ (h : a ≤ b) (r : (f a).carrier), + Prime r → Prime (⟨r.1, hf_mono h r.2⟩ : (f b).carrier) := by + intro a b hab r hr + rcases eq_or_lt_of_le hab with rfl | hlt + · exact hr + · exact (hchain b a hlt).choose_spec r hr + -- The family f forms an NSubringChain; its union S is the desired one-pass output + let fchain : NSubringChain T ι := + { ring := f, mono := hf_mono, primes_preserved := hf_primes } + obtain ⟨S, hS_carrier, hS_le⟩ := build_union_isNSubring fchain + (fun p => le_trans (hcard p) (max_le (le_max_left ..) R'.card_le)) + (le_trans hι_card (max_le (le_max_left ..) R'.card_le)) + have hS_mem : ∀ (x : S.carrier), ∃ (α : ι), (x : T) ∈ (f α).carrier := by + intro x + exact fchain.mem_union_iff.mp (hS_carrier ▸ x.2) + -- R' ≤ f(p₀) ≤ S for any base index p₀ + let p₀ : ι := Classical.arbitrary ι + have hR'_le_S : R'.carrier ≤ S.carrier := le_trans (hR'_le p₀).choose (hS_le p₀) + refine ⟨S, ?_, ?_, ?_⟩ + · -- S is an A-extension of R': primes preserved via transfinite union lemma + exact { + le := hR'_le_S + primes_preserved := by + intro r hr + exact transfinite_union_primes_preserved fchain S.carrier (fun α => hS_le α) + hS_mem p₀ ⟨(r : T), (hR'_le p₀).choose r.2⟩ ((hR'_le p₀).choose_spec r hr) + card_le := by + rw [hS_carrier] + exact union_card_le_max R' fchain hι_card hcard } + · calc Cardinal.mk S.carrier + ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier) := by + rw [hS_carrier] + exact union_card_le_max R' fchain hι_card hcard + _ < Cardinal.mk T := max_lt hT_aleph0 hR' + · -- Each (I, c) pair was closed at some stage; lift into S via inclusion + intro I hI c hc + obtain ⟨gens, hgens⟩ := hI + subst hgens + obtain ⟨p, hle_fp, hc_fp⟩ := hclose gens c hc + refine ⟨le_trans hle_fp (hS_le p), ?_⟩ + rw [show Ideal.map (Subring.inclusion (le_trans hle_fp (hS_le p))) + (Ideal.span ↑gens) = + Ideal.map (Subring.inclusion (hS_le p)) + (Ideal.map (Subring.inclusion hle_fp) (Ideal.span ↑gens)) from by + rw [Ideal.map_map] + congr 1] + exact Ideal.mem_map_of_mem _ hc_fp + +/- Build the transfinite recursion and prove its invariant for close_up_all. -/ +include T in private theorem close_up_all_one_pass_aux [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -158,13 +247,13 @@ private def close_up_all_one_pass_aux_proof ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) - (R' : NSubring T) (hR' : Cardinal.mk R'.carrier < Cardinal.mk T) : PLift ( + (R' : NSubring T) (hR' : Cardinal.mk R'.carrier < Cardinal.mk T) : ∃ S : NSubring T, IsAExtension R' S ∧ Cardinal.mk S.carrier < Cardinal.mk T ∧ (∀ (I : Ideal R'.carrier) (_ : I.FG) (c : R'.carrier), (c : T) ∈ Ideal.map R'.carrier.subtype I → ∃ (hle : R'.carrier ≤ S.carrier), (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) I) ) := ⟨by + Ideal.map (Subring.inclusion hle) I) := by -- Instantiate the one-step close-up lemma for R' have mk_next := close_up_all_mk_next hM_not_assoc hAss_ht hT_card hT_aleph0 R' -- Index the transfinite recursion by pairs (generators, element) from R' @@ -173,13 +262,8 @@ private def close_up_all_one_pass_aux_proof let pairLO : LinearOrder Pairs := IsWellOrder.linearOrder WellOrderingRel let pairWF : WellFoundedLT Pairs := WellOrderingRel.isWellOrder.wf -- #Pairs ≤ max(ℵ₀, #R'): for infinite R', #(Finset R' × R') = #R' - have hPairs_card : Cardinal.mk Pairs ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier) := by - by_cases hfin : Finite R'.carrier - · exact le_trans Cardinal.mk_le_aleph0 (le_max_left ..) - · have : Infinite R'.carrier := not_finite_iff_infinite.mp hfin - simpa only [Pairs_def, Cardinal.mk_prod, Cardinal.lift_id, - Cardinal.mk_finset_of_infinite, Cardinal.mul_eq_self (Cardinal.aleph0_le_mk R'.carrier)] - using (le_max_right Cardinal.aleph0 (Cardinal.mk R'.carrier)) + have hPairs_card : Cardinal.mk Pairs ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier) := + card_finset_prod_le R' have hPairs_card_res : Cardinal.mk Pairs ≤ max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T)) := le_trans hPairs_card (max_le (le_max_left ..) R'.card_le) @@ -350,81 +434,11 @@ private def close_up_all_one_pass_aux_proof have hAext : IsAExtension R' mk_res.choose := mk_res.choose_spec.1 refine ⟨⟨mk_res.choose_spec.2.2.1, fun r hr => hAext.primes_preserved r hr⟩, hAext.card_le, fun q hq => absurd ⟨q, hq⟩ hne, mk_res.choose_spec.2.2.2⟩ - -- Assembly: form the full chain {f(p)} indexed by Pairs and take its union + -- Assembly: the union of the chain {f(p)} indexed by Pairs have : Nonempty Pairs := ⟨⟨∅, ⟨0, R'.carrier.zero_mem⟩⟩⟩ - have hf_mono : ∀ ⦃a b : Pairs⦄, a ≤ b → (f a).carrier ≤ (f b).carrier := by - intro a b hab - rcases eq_or_lt_of_le hab with rfl | hlt - · exact le_refl _ - · exact ((hGood b).2.2.1 a hlt).choose - have hf_primes : ∀ ⦃a b : Pairs⦄ (h : a ≤ b) (r : (f a).carrier), - Prime r → Prime (⟨r.1, hf_mono h r.2⟩ : (f b).carrier) := by - intro a b hab r hr - rcases eq_or_lt_of_le hab with rfl | hlt - · exact hr - · exact ((hGood b).2.2.1 a hlt).choose_spec r hr - -- The family f forms an NSubringChain; its union S is the desired one-pass output - let fchain : NSubringChain T Pairs := - { ring := f, mono := hf_mono, primes_preserved := hf_primes } - obtain ⟨S, hS_carrier, hS_le⟩ := build_union fchain - (fun p => le_trans (hGood p).2.1 (max_le (le_max_left ..) R'.card_le)) - hPairs_card_res - have hS_mem : ∀ (x : S.carrier), ∃ (α : Pairs), (x : T) ∈ (f α).carrier := by - intro x - exact fchain.mem_union_iff.mp (hS_carrier ▸ x.2) - -- R' ≤ f(p₀) ≤ S for any base pair p₀ - let p₀ : Pairs := ⟨∅, ⟨0, R'.carrier.zero_mem⟩⟩ - have hR'_le_S : R'.carrier ≤ S.carrier := le_trans (hGood p₀).1.choose (hS_le p₀) - refine ⟨S, ?_, ?_, ?_⟩ - · -- S is an A-extension of R': primes preserved via transfinite union lemma - exact { - le := hR'_le_S - primes_preserved := by - intro r hr - exact transfinite_union_primes_preserved fchain S.carrier (fun α => hS_le α) - hS_mem p₀ ⟨(r : T), (hGood p₀).1.choose r.2⟩ ((hGood p₀).1.choose_spec r hr) - card_le := by - rw [hS_carrier] - exact union_card_le_max R' fchain hPairs_card (fun α => (hGood α).2.1) } - · calc Cardinal.mk S.carrier - ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier) := by - rw [hS_carrier] - exact union_card_le_max R' fchain hPairs_card (fun α => (hGood α).2.1) - _ < Cardinal.mk T := max_lt hT_aleph0 hR' - · -- Each (I, c) pair was closed at stage f(gens, c); lift into S via inclusion - intro I hI c hc - obtain ⟨gens, hgens⟩ := hI - subst hgens - obtain ⟨hle_fp, hc_fp⟩ := (hGood (gens, c)).2.2.2 hc - refine ⟨le_trans hle_fp (hS_le (gens, c)), ?_⟩ - rw [show Ideal.map (Subring.inclusion (le_trans hle_fp (hS_le (gens, c)))) - (Ideal.span ↑gens) = - Ideal.map (Subring.inclusion (hS_le (gens, c))) - (Ideal.map (Subring.inclusion hle_fp) (Ideal.span ↑gens)) from by - rw [Ideal.map_map] - congr 1] - exact Ideal.mem_map_of_mem _ hc_fp -⟩ - -include T in private theorem close_up_all_one_pass_aux - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) - (R' : NSubring T) (hR' : Cardinal.mk R'.carrier < Cardinal.mk T) : - ∃ S : NSubring T, IsAExtension R' S ∧ Cardinal.mk S.carrier < Cardinal.mk T ∧ - (∀ (I : Ideal R'.carrier) (_ : I.FG) (c : R'.carrier), - (c : T) ∈ Ideal.map R'.carrier.subtype I → - ∃ (hle : R'.carrier ≤ S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) ∈ - Ideal.map (Subring.inclusion hle) I) := by - exact - (close_up_all_one_pass_aux_proof - hM_not_assoc hAss_ht hT_card hT_aleph0 R' hR' - ).down + exact close_up_all_one_pass_union hT_aleph0 R' hR' f hPairs_card (fun p => (hGood p).1) + (fun p => (hGood p).2.1) (fun p => (hGood p).2.2.1) + (fun gens c hc => ⟨(gens, c), (hGood (gens, c)).2.2.2 hc⟩) /- One-pass transfinite close-up: given NSubring R' with #R' < #T, produce an A-extension S such that every (I, c) pair from R' with c ∈ IT is closed in S. -/ include T in theorem close_up_all_one_pass diff --git a/LeanPool/AndersonConjecture/Jensen/Construction/Transfinite.lean b/LeanPool/AndersonConjecture/Jensen/Construction/Transfinite.lean index 69ed1c3df0..c09f450274 100644 --- a/LeanPool/AndersonConjecture/Jensen/Construction/Transfinite.lean +++ b/LeanPool/AndersonConjecture/Jensen/Construction/Transfinite.lean @@ -36,11 +36,10 @@ open Cardinal Ideal /-- For `i : (Cardinal.ord c).ToType`, the cardinality of the initial segment below `i` is strictly less than `c`. -/ -private def mk_Iio_ord_lt_proof {c : Cardinal} (i : c.ord.ToType) : - PLift ( #(Set.Iio i) < c ) := ⟨by +private theorem mk_Iio_ord_lt {c : Cardinal} (i : c.ord.ToType) : #(Set.Iio i) < c := by have hlt := mk_Iio_lt i (h := by rw [mk_ord_toType, Ordinal.type_toType]) rwa [mk_ord_toType] at hlt -⟩ + variable {T : Type u} [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] /-! ## Ordinal-indexed transfinite construction @@ -137,6 +136,246 @@ private noncomputable def mk_union_nsub_aux intro β hβ r hr hmem exact transfinite_union_primes_preserved lc U hU_le hU_mem ⟨β, hβ⟩ r hr + +omit [IsNoetherianRing T] [IsDomain T] in +/-- A regular sequence of length two in the maximal ideal forces it to be nonzero. -/ +private lemma maximalIdeal_ne_bot_of_depth + (hdepth : ∃ (a b : T), a ∈ IsLocalRing.maximalIdeal T ∧ + b ∈ IsLocalRing.maximalIdeal T ∧ + RingTheory.Sequence.IsRegular T [a, b]) : + IsLocalRing.maximalIdeal T ≠ ⊥ := by + intro h + obtain ⟨a, _, ha_mem, _, hreg⟩ := hdepth + rw [h] at ha_mem + simp only [Ideal.mem_bot] at ha_mem + rw [RingTheory.Sequence.isRegular_cons_iff] at hreg + have hreg0 : IsSMulRegular T (0 : T) := ha_mem ▸ hreg.1 + exact one_ne_zero (hreg0 (show (0 : T) • (0 : T) = 0 • 1 by simp)).symm + +omit [IsDomain T] in +/-- The index set of the construction has cardinality at most `#T`. -/ +private lemma card_index_le (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) : + Cardinal.mk ({q : Ideal T // q.IsPrime ∧ q ≠ ⊥} × (T ⧸ IsLocalRing.maximalIdeal T ^ 2)) ≤ + Cardinal.mk T := by + have hT_inf : Infinite T := Cardinal.infinite_iff.mpr (le_of_lt hT_aleph0) + have h_primes_le : Cardinal.mk {q : Ideal T // q.IsPrime ∧ q ≠ ⊥} ≤ Cardinal.mk T := by + calc Cardinal.mk {q : Ideal T // q.IsPrime ∧ q ≠ ⊥} + ≤ Cardinal.mk (Ideal T) := Cardinal.mk_subtype_le _ + _ ≤ Cardinal.mk (Finset T) := + Cardinal.mk_le_of_surjective fun I => + IsNoetherian.noetherian (I : Ideal T) + _ = Cardinal.mk T := Cardinal.mk_finset_of_infinite T + have h_quot_le : Cardinal.mk (T ⧸ IsLocalRing.maximalIdeal T ^ 2) ≤ Cardinal.mk T := + Cardinal.mk_quotient_le + rw [Cardinal.mk_prod, Cardinal.lift_id, Cardinal.lift_id] + calc _ ≤ Cardinal.mk T * Cardinal.mk T := mul_le_mul' h_primes_le h_quot_le + _ = Cardinal.mk T := Cardinal.mul_eq_self (le_of_lt hT_aleph0) + +/-- Joint well-founded induction for the transfinite chain: every earlier ring lies in the +predecessor ring `prev α`, and primes are preserved along the chain up to `α`. -/ +private lemma chain_le_prev_and_primes {ι : Type u} [LinearOrder ι] [WellFoundedLT ι] + (ring prev : ι → NSubring T) (hext : ∀ α, IsAExtension (prev α) (ring α)) + (hprev_limit : ∀ α, ¬IsMin α → Order.IsSuccLimit α → + (∀ ⦃β₁ β₂ : ι⦄, β₁ < α → β₂ < α → β₁ ≤ β₂ → + (ring β₁).carrier ≤ (ring β₂).carrier) → + (∀ ⦃β₁ β₂ : ι⦄, β₁ < α → β₂ < α → β₁ ≤ β₂ → + ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), + Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier)) → + (∀ β, β < α → (ring β).carrier ≤ (prev α).carrier) ∧ + (∀ β, β < α → ∀ (r : (ring β).carrier), Prime r → + ∀ (hmem : (r : T) ∈ (prev α).carrier), Prime (⟨(r : T), hmem⟩ : (prev α).carrier))) + (hprev_succ : ∀ α, ¬IsMin α → ¬Order.IsSuccLimit α → + ∃ γ, γ < α ∧ (∀ β, β < α → β ≤ γ) ∧ prev α = ring γ) + (α : ι) : + (∀ β, β < α → (ring β).carrier ≤ (prev α).carrier) ∧ + (∀ ⦃β₁ β₂ : ι⦄, β₁ ≤ β₂ → β₂ ≤ α → + ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), + Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier)) := by + induction α using WellFoundedLT.induction with + | ind α IH_wf => + have hmono_lt : ∀ ⦃β₁ β₂ : ι⦄, β₁ ≤ β₂ → β₂ < α → + (ring β₁).carrier ≤ (ring β₂).carrier := by + intro β₁ β₂ hle hβ₂ + rcases eq_or_lt_of_le hle with rfl | hlt + · exact le_refl _ + · exact ((IH_wf β₂ hβ₂).1 β₁ hlt).trans (hext β₂).le + have hprimes_lt : ∀ ⦃β₁ β₂ : ι⦄, β₁ ≤ β₂ → β₂ < α → + ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), + Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier) := + fun β₁ β₂ hle hβ₂ r hmem hr => (IH_wf β₂ hβ₂).2 hle (le_refl _) r hmem hr + -- Earlier rings lie in `prev α`, and their primes stay prime there + have hprev : (∀ β, β < α → (ring β).carrier ≤ (prev α).carrier) ∧ + (∀ β, β < α → ∀ (r : (ring β).carrier), Prime r → + ∀ (hmem : (r : T) ∈ (prev α).carrier), + Prime (⟨(r : T), hmem⟩ : (prev α).carrier)) := by + by_cases hmin : IsMin α + · exact ⟨fun β hβ => absurd (hmin (le_of_lt hβ)) (not_le.mpr hβ), + fun β hβ => absurd (hmin (le_of_lt hβ)) (not_le.mpr hβ)⟩ + by_cases hlim : Order.IsSuccLimit α + · exact hprev_limit α hmin hlim (fun β₁ β₂ _ hβ₂ hle => hmono_lt hle hβ₂) + (fun β₁ β₂ _ hβ₂ hle r hmem hr => hprimes_lt hle hβ₂ r hmem hr) + obtain ⟨γ, hγ_lt, hγ_max, hprev_eq⟩ := hprev_succ α hmin hlim + rw [hprev_eq] + exact ⟨fun β hβ => hmono_lt (hγ_max β hβ) hγ_lt, + fun β hβ r hr hmem => hprimes_lt (hγ_max β hβ) hγ_lt r hmem hr⟩ + refine ⟨hprev.1, ?_⟩ + -- Prime transfer: β₁ ≤ β₂ ≤ α, key case is β₂ = α via prev(α) + intro β₁ β₂ hle hle_α r hmem hr + rcases eq_or_lt_of_le hle with rfl | hlt + · convert hr using 1 + · rcases eq_or_lt_of_le hle_α with heq_α | hlt_α + · have hβ₁_lt_α : β₁ < α := heq_α ▸ hlt + have hmem_prev : (r : T) ∈ (prev α).carrier := hprev.1 β₁ hβ₁_lt_α r.2 + have hprime_ring := (hext α).primes_preserved ⟨(r : T), hmem_prev⟩ + (hprev.2 β₁ hβ₁_lt_α r hr hmem_prev) + cases heq_α + convert hprime_ring using 1 + · exact hprimes_lt hle hlt_α r hmem hr + +/-- Closedness `IT ∩ A = I` for finitely generated `I` passes to the union of a chain. -/ +private lemma chain_union_closed {ι : Type u} [LinearOrder ι] [Nonempty ι] + (chain : NSubringChain T ι) (A : NSubring T) + (hA_le : ∀ α : ι, (chain.ring α).carrier ≤ A.carrier) + (hA_mem : ∀ x : A.carrier, ∃ α : ι, (x : T) ∈ (chain.ring α).carrier) + (hclosed : ∀ α : ι, ∀ (I : Ideal (chain.ring α).carrier), I.FG → + ∀ (c : (chain.ring α).carrier), + (c : T) ∈ Ideal.map (chain.ring α).carrier.subtype I → c ∈ I) + (I : Ideal A.carrier) (hI_fg : I.FG) (c : A.carrier) + (hc_mem : (c : T) ∈ Ideal.map A.carrier.subtype I) : c ∈ I := by + classical + have hfin_cover : ∀ (F : Finset A.carrier), ∃ α : ι, + ∀ x ∈ F, (x : T) ∈ (chain.ring α).carrier := by + intro F + induction F using Finset.induction with + | empty => + exact ⟨Classical.arbitrary _, fun _ h => absurd h (by simp)⟩ + | @insert a F' _ha ih => + obtain ⟨α₁, hα₁⟩ := ih + obtain ⟨α₂, hα₂⟩ := hA_mem a + exact ⟨max α₁ α₂, fun x hx => by + rw [Finset.mem_insert] at hx + rcases hx with rfl | hx + · exact chain.mono (le_max_right α₁ α₂) hα₂ + · exact chain.mono (le_max_left α₁ α₂) (hα₁ x hx)⟩ + obtain ⟨s, hs⟩ := hI_fg + obtain ⟨γ, hγ⟩ := hfin_cover (insert c s) + have hgens_γ : ∀ g ∈ s, (g : T) ∈ (chain.ring γ).carrier := + fun g hg => hγ g (Finset.mem_insert_of_mem hg) + have hc_γ : (c : T) ∈ (chain.ring γ).carrier := + hγ c (Finset.mem_insert_self c s) + set c_γ : (chain.ring γ).carrier := ⟨(c : T), hc_γ⟩ + let s_γ : Finset (chain.ring γ).carrier := + s.attach.image (fun ⟨g, hg⟩ => + (⟨(g : T), hgens_γ g hg⟩ : (chain.ring γ).carrier)) + let J := Ideal.span (↑s_γ : Set (chain.ring γ).carrier) + have hc_in_JT : + (c_γ : T) ∈ Ideal.map (chain.ring γ).carrier.subtype J := by + suffices h : Ideal.map A.carrier.subtype I ≤ + Ideal.map (chain.ring γ).carrier.subtype J by + exact h hc_mem + rw [← hs, Ideal.map_span, Ideal.map_span] + apply Ideal.span_mono + rintro t ⟨g, hg_mem, rfl⟩ + have hg := Finset.mem_coe.mp hg_mem + exact ⟨⟨(g : T), hgens_γ g hg⟩, + Finset.mem_coe.mpr (Finset.mem_image.mpr + ⟨⟨g, hg⟩, Finset.mem_attach _ _, rfl⟩), rfl⟩ + have hc_in_J : c_γ ∈ J := + hclosed γ J ⟨s_γ, rfl⟩ c_γ hc_in_JT + let incl := Subring.inclusion (hA_le γ) + have hJ_le_I : Ideal.map incl J ≤ I := by + rw [← hs, Ideal.map_span] + apply Ideal.span_mono + rintro t ⟨x, hx_mem, rfl⟩ + simp only [Finset.mem_coe] at hx_mem + rw [Finset.mem_image] at hx_mem + obtain ⟨⟨g, hg⟩, _, rfl⟩ := hx_mem + change (Subring.inclusion (hA_le γ) + ⟨(g : T), hgens_γ g hg⟩ : A.carrier) ∈ (↑s : Set _) + rw [show (Subring.inclusion (hA_le γ) + ⟨(g : T), hgens_γ g hg⟩ : A.carrier) = g + from Subtype.ext rfl] + exact Finset.mem_coe.mpr hg + have h_mem := hJ_le_I (Ideal.mem_map_of_mem incl hc_in_J) + rwa [show incl c_γ = c from Subtype.ext rfl] at h_mem + +/-- Cardinality bound for the union of a chain indexed by a small enough type. -/ +private lemma chain_union_card_le {ι : Type u} [LinearOrder ι] [Nonempty ι] + (chain : NSubringChain T ι) + (hι_card : Cardinal.mk ι ≤ + max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T))) : + Cardinal.mk ↥chain.unionSubring ≤ + max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T)) := by + set U := chain.unionSubring with hU_def + have hU_eq : (U : Set T) = ⋃ α, ↑(chain.ring α).carrier := by + rw [hU_def, NSubringChain.unionSubring] + exact Subring.coe_iSup_of_directed chain.directed_carriers + set κ' := max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T)) + have h1 : Cardinal.mk ↥U ≤ Cardinal.mk ι * + ⨆ (α : ι), Cardinal.mk ↑((chain.ring α).carrier : Set T) := by + have := Cardinal.mk_iUnion_le (fun α => ((chain.ring α).carrier : Set T)) + rwa [← hU_eq] at this + have h2 : ⨆ (α : ι), Cardinal.mk ↑((chain.ring α).carrier : Set T) ≤ κ' := + ciSup_le fun α => (chain.ring α).card_le + calc Cardinal.mk ↥U + ≤ Cardinal.mk ι * + ⨆ (α : ι), Cardinal.mk ↑((chain.ring α).carrier : Set T) := h1 + _ ≤ Cardinal.mk ι * κ' := mul_le_mul_right h2 _ + _ ≤ κ' * κ' := mul_le_mul_left hι_card κ' + _ ≤ max κ' κ' := Cardinal.mul_le_max_of_aleph0_le_left (le_max_left ..) + _ = κ' := max_self κ' + +/-- Assemble the union `A` of the transfinite chain and transfer surjectivity onto `T/M²`, +closedness and prime catching from the rings of the chain to `A`. -/ +private lemma transfinite_result_of_family {ι : Type u} [LinearOrder ι] [Nonempty ι] + (ring prev : ι → NSubring T) (hext : ∀ α, IsAExtension (prev α) (ring α)) + (hcombined : ∀ α, (∀ β, β < α → (ring β).carrier ≤ (prev α).carrier) ∧ + (∀ ⦃β₁ β₂ : ι⦄, β₁ ≤ β₂ → β₂ ≤ α → + ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), + Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier))) + (hclosed : ∀ α : ι, ∀ (I : Ideal (ring α).carrier), I.FG → + ∀ (c : (ring α).carrier), (c : T) ∈ Ideal.map (ring α).carrier.subtype I → c ∈ I) + (hsurj : ∀ ℓ : T ⧸ IsLocalRing.maximalIdeal T ^ 2, ∃ α : ι, + ∃ (c : (ring α).carrier), Ideal.Quotient.mk (IsLocalRing.maximalIdeal T ^ 2) (c : T) = ℓ) + (hcatch : ∀ (q : Ideal T), q.IsPrime → q ≠ ⊥ → ∃ α : ι, + ∃ (t : (ring α).carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) + (hι_card : Cardinal.mk ι ≤ + max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T))) : + ∃ (A : NSubring T), + (Function.Surjective (fun r : A.carrier => + Ideal.Quotient.mk (IsLocalRing.maximalIdeal T ^ 2) (r : T))) ∧ + (∀ (I : Ideal A.carrier), I.FG → + ∀ (c : A.carrier), (c : T) ∈ Ideal.map A.carrier.subtype I → c ∈ I) ∧ + (∀ (q : Ideal T), q.IsPrime → q ≠ ⊥ → + ∃ (t : A.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) := by + have hmono : ∀ ⦃β₁ β₂ : ι⦄, β₁ ≤ β₂ → + (ring β₁).carrier ≤ (ring β₂).carrier := by + intro β₁ β₂ hle + rcases eq_or_lt_of_le hle with rfl | hlt + · exact le_refl _ + · exact ((hcombined β₂).1 β₁ hlt).trans (hext β₂).le + have hprimes_pres : ∀ ⦃β₁ β₂ : ι⦄ (h : β₁ ≤ β₂) + (r : (ring β₁).carrier), Prime r → + Prime (⟨r.1, hmono h r.2⟩ : (ring β₂).carrier) := by + intro β₁ β₂ hle r hr + rcases eq_or_lt_of_le hle with rfl | hlt + · convert hr using 1 + · exact (hcombined β₂).2 hle (le_refl β₂) r (hmono hle r.2) hr + let chain : NSubringChain T ι := + { ring := ring + mono := hmono + primes_preserved := hprimes_pres } + let A : NSubring T := chain.unionNSubring (chain_union_card_le chain hι_card) + refine ⟨A, ?_, chain_union_closed chain A chain.le_union + (fun x => chain.mem_union_iff.mp x.2) hclosed, ?_⟩ + · intro ℓ + obtain ⟨α, c, hc⟩ := hsurj ℓ + exact ⟨⟨(c : T), chain.le_union α c.2⟩, hc⟩ + · intro q hq hq_ne + obtain ⟨α, t, ht_q, ht_ne⟩ := hcatch q hq hq_ne + exact ⟨⟨(t : T), chain.le_union α t.2⟩, ht_q, ht_ne⟩ + +include T in /-- The transfinite construction via ordinal recursion: iterate `combined_step` over all (prime, residue) pairs indexed by ordinals, building an N-subring A of T that is surjective onto T/M², has every nonzero prime of T meeting A @@ -145,7 +384,7 @@ nontrivially, and satisfies the closedness condition IT ∩ A = I. This replaces the Zorn-based `transfinite_construction_zorn` which required `hk_countable : #k ≤ ℵ₀` (false for our T). Instead takes `hT_aleph0 : ℵ₀ < #T` and propagates cardinal bounds `#R < #T` through the chain. -/ -private def transfinite_construction_proof +theorem transfinite_construction [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hdepth : ∃ (a b : T), a ∈ IsLocalRing.maximalIdeal T ∧ b ∈ IsLocalRing.maximalIdeal T ∧ @@ -156,58 +395,23 @@ private def transfinite_construction_proof IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) (hAss_ht : ∀ (r : T), r ≠ 0 → ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) : PLift ( + (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) : ∃ (A : NSubring T), (Function.Surjective (fun r : A.carrier => Ideal.Quotient.mk (IsLocalRing.maximalIdeal T ^ 2) (r : T))) ∧ (∀ (I : Ideal A.carrier), I.FG → ∀ (c : A.carrier), (c : T) ∈ Ideal.map A.carrier.subtype I → c ∈ I) ∧ (∀ (q : Ideal T), q.IsPrime → q ≠ ⊥ → - ∃ (t : A.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) ) := ⟨by + ∃ (t : A.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) := by obtain ⟨R₀, hR₀_count⟩ := initial_NSubring hchar have hR₀_card : Cardinal.mk R₀.carrier < Cardinal.mk T := lt_of_le_of_lt hR₀_count hT_aleph0 - have hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥ := by - intro h - obtain ⟨a, _, ha_mem, _, hreg⟩ := hdepth - rw [h] at ha_mem - simp only [Ideal.mem_bot] at ha_mem - rw [RingTheory.Sequence.isRegular_cons_iff] at hreg - have hreg0 : IsSMulRegular T (0 : T) := ha_mem ▸ hreg.1 - exact one_ne_zero (hreg0 (show (0 : T) • (0 : T) = 0 • 1 by simp)).symm + have hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥ := maximalIdeal_ne_bot_of_depth hdepth obtain ⟨S₀, hS₀_ext, hS₀_closed⟩ := combined_step_surj_card R₀ 0 hM_not_assoc hAss_ht hR₀_card hT_aleph0 hcard hM_ne_bot obtain ⟨_, hS₀_closed, hS₀_card⟩ := hS₀_closed let V := {q : Ideal T // q.IsPrime ∧ q ≠ ⊥} × (T ⧸ IsLocalRing.maximalIdeal T ^ 2) - -- #V ≤ #T: product of two sets each bounded by #T - have hV_card : Cardinal.mk V ≤ Cardinal.mk T := by - have hT_inf : Infinite T := Cardinal.infinite_iff.mpr (le_of_lt hT_aleph0) - have h_primes_le : Cardinal.mk {q : Ideal T // q.IsPrime ∧ q ≠ ⊥} ≤ Cardinal.mk T := by - calc Cardinal.mk {q : Ideal T // q.IsPrime ∧ q ≠ ⊥} - ≤ Cardinal.mk (Ideal T) := Cardinal.mk_subtype_le _ - _ ≤ Cardinal.mk (Finset T) := - Cardinal.mk_le_of_surjective fun I => - IsNoetherian.noetherian (I : Ideal T) - _ = Cardinal.mk T := Cardinal.mk_finset_of_infinite T - have h_quot_le : Cardinal.mk (T ⧸ IsLocalRing.maximalIdeal T ^ 2) ≤ Cardinal.mk T := - Cardinal.mk_quotient_le - have : Cardinal.mk V = Cardinal.mk {q : Ideal T // q.IsPrime ∧ q ≠ ⊥} * - Cardinal.mk (T ⧸ IsLocalRing.maximalIdeal T ^ 2) := by - show Cardinal.mk V = _ - simp only [V, Cardinal.mk_prod, Cardinal.lift_id] - calc Cardinal.mk V - = _ := this - _ ≤ Cardinal.mk T * Cardinal.mk T := mul_le_mul' h_primes_le h_quot_le - _ = Cardinal.mk T := Cardinal.mul_eq_self (le_of_lt hT_aleph0) - suffices ∃ (A : NSubring T), - (∀ ℓ : T ⧸ IsLocalRing.maximalIdeal T ^ 2, - ∃ a : A.carrier, Ideal.Quotient.mk (IsLocalRing.maximalIdeal T ^ 2) (a : T) = ℓ) ∧ - (∀ (I : Ideal A.carrier), I.FG → - ∀ (c : A.carrier), (c : T) ∈ Ideal.map A.carrier.subtype I → c ∈ I) ∧ - (∀ (q : Ideal T), q.IsPrime → q ≠ ⊥ → - ∃ (t : A.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) by - obtain ⟨A, hA_surj, hA_closed, hA_primes⟩ := this - exact ⟨A, fun ℓ => hA_surj ℓ, hA_closed, hA_primes⟩ + have hV_card : Cardinal.mk V ≤ Cardinal.mk T := card_index_le hT_aleph0 let κ := Cardinal.ord (Cardinal.mk V) have : Nonempty V := ⟨⟨⟨IsLocalRing.maximalIdeal T, @@ -216,83 +420,6 @@ private def transfinite_construction_proof rw [← Cardinal.mk_ne_zero_iff, Cardinal.mk_ord_toType] exact Cardinal.mk_ne_zero V obtain ⟨enum⟩ := Cardinal.eq.mp (Cardinal.mk_ord_toType (Cardinal.mk V)) - suffices h_chain : ∃ (chain : NSubringChain T κ.ToType) (A : NSubring T), - (∀ α : κ.ToType, (chain.ring α).carrier ≤ A.carrier) ∧ - (∀ x : A.carrier, ∃ α : κ.ToType, (x : T) ∈ (chain.ring α).carrier) ∧ - (∀ α : κ.ToType, ∀ (I : Ideal (chain.ring α).carrier), I.FG → - ∀ (c : (chain.ring α).carrier), - (c : T) ∈ Ideal.map (chain.ring α).carrier.subtype I → c ∈ I) ∧ - (∀ ℓ : T ⧸ IsLocalRing.maximalIdeal T ^ 2, ∃ α : κ.ToType, - ∃ (c : (chain.ring α).carrier), - Ideal.Quotient.mk (IsLocalRing.maximalIdeal T ^ 2) (c : T) = ℓ) ∧ - (∀ (q : Ideal T), q.IsPrime → q ≠ ⊥ → ∃ α : κ.ToType, - ∃ (t : (chain.ring α).carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) by - obtain ⟨chain, A, hA_le, hA_mem, hclosed, hsurj, hcatch⟩ := h_chain - refine ⟨A, ?_, ?_, ?_⟩ - · intro ℓ - obtain ⟨α, c, hc⟩ := hsurj ℓ - exact ⟨⟨(c : T), hA_le α c.2⟩, hc⟩ - · -- Closedness: lift f.g. ideal membership from A to some chain.ring(γ) - intro I hI_fg c hc_mem - classical - have hfin_cover : ∀ (F : Finset A.carrier), ∃ α : κ.ToType, - ∀ x ∈ F, (x : T) ∈ (chain.ring α).carrier := by - intro F - induction F using Finset.induction with - | empty => - exact ⟨Classical.arbitrary _, fun _ h => absurd h (by simp)⟩ - | @insert a F' _ha ih => - obtain ⟨α₁, hα₁⟩ := ih - obtain ⟨α₂, hα₂⟩ := hA_mem a - exact ⟨max α₁ α₂, fun x hx => by - rw [Finset.mem_insert] at hx - rcases hx with rfl | hx - · exact chain.mono (le_max_right α₁ α₂) hα₂ - · exact chain.mono (le_max_left α₁ α₂) (hα₁ x hx)⟩ - obtain ⟨s, hs⟩ := hI_fg - obtain ⟨γ, hγ⟩ := hfin_cover (insert c s) - have hgens_γ : ∀ g ∈ s, (g : T) ∈ (chain.ring γ).carrier := - fun g hg => hγ g (Finset.mem_insert_of_mem hg) - have hc_γ : (c : T) ∈ (chain.ring γ).carrier := - hγ c (Finset.mem_insert_self c s) - set c_γ : (chain.ring γ).carrier := ⟨(c : T), hc_γ⟩ - let s_γ : Finset (chain.ring γ).carrier := - s.attach.image (fun ⟨g, hg⟩ => - (⟨(g : T), hgens_γ g hg⟩ : (chain.ring γ).carrier)) - let J := Ideal.span (↑s_γ : Set (chain.ring γ).carrier) - have hc_in_JT : - (c_γ : T) ∈ Ideal.map (chain.ring γ).carrier.subtype J := by - suffices h : Ideal.map A.carrier.subtype I ≤ - Ideal.map (chain.ring γ).carrier.subtype J by - exact h hc_mem - rw [← hs, Ideal.map_span, Ideal.map_span] - apply Ideal.span_mono - rintro t ⟨g, hg_mem, rfl⟩ - have hg := Finset.mem_coe.mp hg_mem - exact ⟨⟨(g : T), hgens_γ g hg⟩, - Finset.mem_coe.mpr (Finset.mem_image.mpr - ⟨⟨g, hg⟩, Finset.mem_attach _ _, rfl⟩), rfl⟩ - have hc_in_J : c_γ ∈ J := - hclosed γ J ⟨s_γ, rfl⟩ c_γ hc_in_JT - let incl := Subring.inclusion (hA_le γ) - have hJ_le_I : Ideal.map incl J ≤ I := by - rw [← hs, Ideal.map_span] - apply Ideal.span_mono - rintro t ⟨x, hx_mem, rfl⟩ - simp only [Finset.mem_coe] at hx_mem - rw [Finset.mem_image] at hx_mem - obtain ⟨⟨g, hg⟩, _, rfl⟩ := hx_mem - change (Subring.inclusion (hA_le γ) - ⟨(g : T), hgens_γ g hg⟩ : A.carrier) ∈ (↑s : Set _) - rw [show (Subring.inclusion (hA_le γ) - ⟨(g : T), hgens_γ g hg⟩ : A.carrier) = g - from Subtype.ext rfl] - exact Finset.mem_coe.mpr hg - have h_mem := hJ_le_I (Ideal.mem_map_of_mem incl hc_in_J) - rwa [show incl c_γ = c from Subtype.ext rfl] at h_mem - · intro q hq hq_ne - obtain ⟨α, t, ht_q, ht_ne⟩ := hcatch q hq hq_ne - exact ⟨⟨(t : T), hA_le α t.2⟩, ht_q, ht_ne⟩ -- Bundled return type for WellFounded.fix: ring + predecessor + properties let RD := fun (α : κ.ToType) => Σ' (R : NSubring T) (prev : NSubring T), IsAExtension prev R ∧ @@ -326,7 +453,7 @@ private def transfinite_construction_proof intro α IH hne hgood hIH_cb exact mk_union_nsub_aux α (fun β hβ => (IH β hβ).1) hne hgood.1 hgood.2 hIH_cb hcard hT_aleph0 - (lt_of_lt_of_le ((mk_Iio_ord_lt_proof (c := Cardinal.mk V) α).down) hV_card) + (lt_of_lt_of_le (mk_Iio_ord_lt (c := Cardinal.mk V) α) hV_card) -- prevF: predecessor ring (min→S₀, limit→union, successor→ring(γ)) let prevF : (α : κ.ToType) → (∀ β, β < α → RD β) → NSubring T := fun α IH => @@ -394,168 +521,46 @@ private def transfinite_construction_proof have hprevF_eq : ∀ (α : κ.ToType), (data α).2.1 = prevF α (fun γ hγ => data γ) := fun α => congrArg (fun d => d.2.1) (WellFounded.fix_eq wellFounded_lt hbuildF α) - -- Joint WF induction: monotonicity + prime preservation avoids circularity - have hcombined : ∀ (α : κ.ToType), - (∀ β, β < α → (ring β).carrier ≤ (data α).2.1.carrier) ∧ - (∀ ⦃β₁ β₂⦄, β₁ ≤ β₂ → β₂ ≤ α → + -- At limits, `prev α` is the union of the earlier rings + have hprev_limit : ∀ α : κ.ToType, ¬IsMin α → Order.IsSuccLimit α → + (∀ ⦃β₁ β₂ : κ.ToType⦄, β₁ < α → β₂ < α → β₁ ≤ β₂ → + (ring β₁).carrier ≤ (ring β₂).carrier) → + (∀ ⦃β₁ β₂ : κ.ToType⦄, β₁ < α → β₂ < α → β₁ ≤ β₂ → ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), - Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier)) := by - refine fun α => WellFounded.induction wellFounded_lt α (C := fun α => + Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier)) → (∀ β, β < α → (ring β).carrier ≤ (data α).2.1.carrier) ∧ - (∀ ⦃β₁ β₂⦄, β₁ ≤ β₂ → β₂ ≤ α → - ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), - Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier))) ?_ - intro α IH_wf - have hmono_lt : ∀ ⦃β₁ β₂ : κ.ToType⦄, β₁ ≤ β₂ → β₂ < α → - (ring β₁).carrier ≤ (ring β₂).carrier := by - intro β₁ β₂ hle hβ₂ - rcases eq_or_lt_of_le hle with rfl | hlt - · exact le_refl _ - · exact ((IH_wf β₂ hβ₂).1 β₁ hlt).trans (data β₂).2.2.1.le - have hprimes_lt : ∀ ⦃β₁ β₂ : κ.ToType⦄, β₁ ≤ β₂ → β₂ < α → - ∀ (r : (ring β₁).carrier) (hmem : (r : T) ∈ (ring β₂).carrier), - Prime r → Prime (⟨(r : T), hmem⟩ : (ring β₂).carrier) := by - intro β₁ β₂ hle hβ₂ r hmem hr - exact (IH_wf β₂ hβ₂).2 hle (le_refl _) r hmem hr - have hgood_α : IH_good α (fun γ hγ => data γ) := by - constructor - · intro β₁ β₂ hβ₁ hβ₂ hle - exact hmono_lt hle hβ₂ - · intro β₁ β₂ hβ₁ hβ₂ hle r hmem hr - exact hprimes_lt hle hβ₂ r hmem hr - have hring_le_prev_α : ∀ β, β < α → - (ring β).carrier ≤ (data α).2.1.carrier := by - intro β hβ + (∀ β, β < α → ∀ (r : (ring β).carrier), Prime r → + ∀ (hmem : (r : T) ∈ (data α).2.1.carrier), + Prime (⟨(r : T), hmem⟩ : (data α).2.1.carrier)) := by + intro α hmin hlim hmono hprimes + have hgood_α : IH_good α (fun γ hγ => data γ) := ⟨hmono, hprimes⟩ + have h_eq : (data α).2.1 = + (mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α + (fun β hβ => (data β).2.2.2.2.2.2.2)).1 := by rw [hprevF_eq α] - by_cases hmin : IsMin α - · exact absurd (hmin (le_of_lt hβ)) (not_le.mpr hβ) - · simp only [prevF, dite_eq_right hmin] - by_cases hlim : Order.IsSuccLimit α - · simp only [dite_eq_left hlim, dite_eq_left hgood_α] - exact (mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α - (fun β hβ => (data β).2.2.2.2.2.2.2)).2.2.2.1 β hβ - · simp only [dite_eq_right hlim] - let hprelim := (Order.not_isSuccLimit_iff.mp hlim).resolve_left hmin - let hγ_ex := Order.not_isSuccPrelimit_iff_succ_eq.mp hprelim - let hγ_lt := lt_of_lt_of_eq - (Order.lt_succ_of_not_isMax hγ_ex.choose_spec.1) hγ_ex.choose_spec.2 - rcases eq_or_lt_of_le (Order.lt_succ_iff_of_not_isMax - hγ_ex.choose_spec.1 |>.mp (hγ_ex.choose_spec.2 ▸ hβ)) with rfl | hlt - · exact le_refl _ - · exact ((IH_wf hγ_ex.choose hγ_lt).1 β hlt).trans - (data hγ_ex.choose).2.2.1.le - refine ⟨hring_le_prev_α, ?_⟩ - -- Prime transfer: β₁ ≤ β₂ ≤ α, key case is β₂ = α via prev(α) - intro β₁ β₂ hle hle_α r hmem hr - rcases eq_or_lt_of_le hle with rfl | hlt - · convert hr using 1 - · rcases eq_or_lt_of_le hle_α with heq_α | hlt_α - · have hβ₁_lt_α : β₁ < α := heq_α ▸ hlt - have hmem_prev : (r : T) ∈ (data α).2.1.carrier := - hring_le_prev_α β₁ hβ₁_lt_α r.2 - have h_nsub_eq := hprevF_eq α - have prime_transport : ∀ (S₁ S₂ : NSubring T) (h : S₁ = S₂) (x : T) (hx : x ∈ S₁.carrier), - Prime (⟨x, hx⟩ : S₁.carrier) → Prime (⟨x, h ▸ hx⟩ : S₂.carrier) := by - intro S₁ S₂ h x hx hp - cases h - exact hp - have hmem_prevF_carrier : (r : T) ∈ (prevF α (fun γ hγ => data γ)).carrier := by - rwa [← h_nsub_eq] - have hprime_prevF : Prime (⟨(r : T), hmem_prevF_carrier⟩ : - (prevF α (fun γ hγ => data γ)).carrier) := by - by_cases hmin : IsMin α - · exact absurd (hmin (le_of_lt hβ₁_lt_α)) (not_le.mpr hβ₁_lt_α) - · by_cases hlim : Order.IsSuccLimit α - · have h_prevF_eq : prevF α (fun γ hγ => data γ) = - (mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α - (fun β hβ => (data β).2.2.2.2.2.2.2)).1 := by - simp only [prevF, dite_eq_right hmin, dite_eq_left hlim, dite_eq_left hgood_α] - have hmem_u : (r : T) ∈ - (mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α - (fun β hβ => (data β).2.2.2.2.2.2.2)).1.carrier := by - rwa [← h_prevF_eq] - exact prime_transport _ _ h_prevF_eq.symm _ hmem_u - ((mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α - (fun β hβ => (data β).2.2.2.2.2.2.2)).2.2.2.2 - β₁ hβ₁_lt_α r hr hmem_u) - · have h_prevF_eq : prevF α (fun γ hγ => data γ) = ring - ((Order.not_isSuccPrelimit_iff_succ_eq.mp - ((Order.not_isSuccLimit_iff.mp hlim).resolve_left hmin)).choose) := by - simp only [prevF, dite_eq_right hmin, dite_eq_right hlim] - rfl - let hprelim := (Order.not_isSuccLimit_iff.mp hlim).resolve_left hmin - let hγ_ex := Order.not_isSuccPrelimit_iff_succ_eq.mp hprelim - let hγ_lt := lt_of_lt_of_eq - (Order.lt_succ_of_not_isMax hγ_ex.choose_spec.1) hγ_ex.choose_spec.2 - have hmem_ring_γ : (r : T) ∈ (ring hγ_ex.choose).carrier := by - rwa [← h_prevF_eq] - rcases eq_or_lt_of_le (Order.lt_succ_iff_of_not_isMax - hγ_ex.choose_spec.1 |>.mp (hγ_ex.choose_spec.2 ▸ hβ₁_lt_α)) with rfl | hlt' - · exact prime_transport _ _ h_prevF_eq.symm _ hmem_ring_γ hr - · exact prime_transport _ _ h_prevF_eq.symm _ hmem_ring_γ - (hprimes_lt (le_of_lt hlt') hγ_lt r - (((IH_wf hγ_ex.choose hγ_lt).1 β₁ hlt').trans - (data hγ_ex.choose).2.2.1.le r.2) hr) - have prime_of_eq : ∀ (S : NSubring T), S = prevF α (fun γ hγ => data γ) → - ∀ (hx : (r : T) ∈ S.carrier), Prime (⟨(r : T), hx⟩ : S.carrier) := by - rintro S rfl hx - exact hprime_prevF - have hprime_prev : Prime (⟨(r : T), hmem_prev⟩ : (data α).2.1.carrier) := - prime_of_eq _ h_nsub_eq hmem_prev - have hext := (data α).2.2.1 - have hprime_ring := hext.primes_preserved ⟨(r : T), hmem_prev⟩ hprime_prev - cases heq_α - convert hprime_ring using 1 - · exact hprimes_lt hle hlt_α r hmem hr - have hring_le_prev : ∀ (α β : κ.ToType), β < α → - (ring β).carrier ≤ (data α).2.1.carrier := - fun α => (hcombined α).1 - have hmono : ∀ ⦃β₁ β₂ : κ.ToType⦄, β₁ ≤ β₂ → - (ring β₁).carrier ≤ (ring β₂).carrier := by - intro β₁ β₂ hle - rcases eq_or_lt_of_le hle with rfl | hlt - · exact le_refl _ - · exact (hring_le_prev β₂ β₁ hlt).trans (data β₂).2.2.1.le - have hprimes_pres : ∀ ⦃β₁ β₂ : κ.ToType⦄ (h : β₁ ≤ β₂) - (r : (ring β₁).carrier), Prime r → - Prime (⟨r.1, hmono h r.2⟩ : (ring β₂).carrier) := by - intro β₁ β₂ hle r hr - rcases eq_or_lt_of_le hle with rfl | hlt - · convert hr using 1 - · exact (hcombined β₂).2 hle (le_refl β₂) r (hmono hle r.2) hr - let chain : NSubringChain T κ.ToType := - { ring := ring - mono := hmono - primes_preserved := hprimes_pres } - set U := chain.unionSubring with hU_def - have hU_card_le : Cardinal.mk ↥U ≤ - max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T)) := by - have hU_eq : (U : Set T) = ⋃ α, ↑(chain.ring α).carrier := by - rw [hU_def, NSubringChain.unionSubring] - exact Subring.coe_iSup_of_directed chain.directed_carriers - set κ' := max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T)) - have h1 : Cardinal.mk ↥U ≤ Cardinal.mk κ.ToType * - ⨆ (α : κ.ToType), Cardinal.mk ↑((chain.ring α).carrier : Set T) := by - have := Cardinal.mk_iUnion_le (fun α => ((chain.ring α).carrier : Set T)) - rwa [← hU_eq] at this - have h2 : ⨆ (α : κ.ToType), Cardinal.mk ↑((chain.ring α).carrier : Set T) ≤ κ' := - ciSup_le fun α => (chain.ring α).card_le - have h3 : Cardinal.mk κ.ToType ≤ κ' := by - rw [Cardinal.mk_ord_toType] - calc Cardinal.mk V ≤ Cardinal.mk T := hV_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hcard - _ ≤ max Cardinal.aleph0 _ := le_max_right _ _ - calc Cardinal.mk ↥U - ≤ Cardinal.mk κ.ToType * - ⨆ (α : κ.ToType), Cardinal.mk ↑((chain.ring α).carrier : Set T) := h1 - _ ≤ Cardinal.mk κ.ToType * κ' := mul_le_mul_right h2 _ - _ ≤ κ' * κ' := mul_le_mul_left h3 κ' - _ ≤ max κ' κ' := Cardinal.mul_le_max_of_aleph0_le_left (le_max_left ..) - _ = κ' := max_self κ' - let A : NSubring T := chain.unionNSubring hU_card_le - refine ⟨chain, A, chain.le_union, fun x => chain.mem_union_iff.mp x.2, ?_, ?_, ?_⟩ - · intro α I hI c hc - exact (data α).2.2.2.2.1 I hI c hc + simp only [prevF, dite_eq_right hmin, dite_eq_left hlim, dite_eq_left hgood_α] + rw [h_eq] + exact ⟨(mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α + (fun β hβ => (data β).2.2.2.2.2.2.2)).2.2.2.1, + (mk_union_nsub α (fun γ hγ => data γ) (not_isMin_iff.mp hmin) hgood_α + (fun β hβ => (data β).2.2.2.2.2.2.2)).2.2.2.2⟩ + -- At successors `succ γ`, `prev α` is the ring at `γ` + have hprev_succ : ∀ α : κ.ToType, ¬IsMin α → ¬Order.IsSuccLimit α → + ∃ γ, γ < α ∧ (∀ β, β < α → β ≤ γ) ∧ (data α).2.1 = ring γ := by + intro α hmin hlim + let hprelim := (Order.not_isSuccLimit_iff.mp hlim).resolve_left hmin + let hγ_ex := Order.not_isSuccPrelimit_iff_succ_eq.mp hprelim + refine ⟨hγ_ex.choose, + lt_of_lt_of_eq (Order.lt_succ_of_not_isMax hγ_ex.choose_spec.1) hγ_ex.choose_spec.2, + fun β hβ => (Order.lt_succ_iff_of_not_isMax hγ_ex.choose_spec.1).mp + (by rw [hγ_ex.choose_spec.2]; exact hβ), ?_⟩ + rw [hprevF_eq α] + simp only [prevF, dite_eq_right hmin, dite_eq_right hlim] + rfl + refine transfinite_result_of_family ring (fun α => (data α).2.1) (fun α => (data α).2.2.1) + (chain_le_prev_and_primes ring (fun α => (data α).2.1) (fun α => (data α).2.2.1) + hprev_limit hprev_succ) + (fun α => (data α).2.2.2.2.1) ?_ ?_ ?_ · -- Surjectivity: use enum to find α covering each residue class ℓ intro ℓ have hq₀ : (IsLocalRing.maximalIdeal T).IsPrime := @@ -572,29 +577,8 @@ private def transfinite_construction_proof obtain ⟨t, ht_q, ht_ne⟩ := (data α).2.2.2.2.2.2.1 have : (enum α).1.1 = q := by simp [α, v] exact ⟨α, t, this ▸ ht_q, ht_ne⟩ -⟩ - -include T in theorem transfinite_construction - [IsAdicComplete (IsLocalRing.maximalIdeal T) T] - (hdepth : ∃ (a b : T), a ∈ IsLocalRing.maximalIdeal T ∧ - b ∈ IsLocalRing.maximalIdeal T ∧ - RingTheory.Sequence.IsRegular T [a, b]) - (hcard : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hchar : ∀ (n : ℤ), n ≠ 0 → (algebraMap ℤ T n) ≠ 0) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) : - ∃ (A : NSubring T), - (Function.Surjective (fun r : A.carrier => - Ideal.Quotient.mk (IsLocalRing.maximalIdeal T ^ 2) (r : T))) ∧ - (∀ (I : Ideal A.carrier), I.FG → - ∀ (c : A.carrier), (c : T) ∈ Ideal.map A.carrier.subtype I → c ∈ I) ∧ - (∀ (q : Ideal T), q.IsPrime → q ≠ ⊥ → - ∃ (t : A.carrier), (t : T) ∈ q ∧ (t : T) ≠ 0) := by - exact - (transfinite_construction_proof - hdepth hcard hchar hM_not_assoc hAss_ht hT_aleph0 - ).down + · rw [Cardinal.mk_ord_toType] + calc Cardinal.mk V ≤ Cardinal.mk T := hV_card + _ = Cardinal.mk (IsLocalRing.ResidueField T) := hcard + _ ≤ max Cardinal.aleph0 _ := le_max_right _ _ end diff --git a/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean b/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean index 2f92aa192d..eac7511c34 100644 --- a/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean +++ b/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean @@ -319,10 +319,84 @@ include T in theorem height_bound_wf_descent simp [hb_eq, congrArg Subtype.val hb0])) omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Polynomial evaluations at an element of Rbar stay in Rbar. -/ +private theorem aeval_mem_intersectionSet + (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (x : T) + (hx : x ∈ intersectionSet R x₁ x₂ y₁ y₂) (f : Polynomial R.carrier) : + (aeval x f : T) ∈ intersectionSet R x₁ x₂ y₁ y₂ := by + change (aeval x f : T) ∈ intersectionLocalizationSubring R x₁ x₂ y₁ y₂ + induction f using Polynomial.induction_on' with + | add f g hf hg => + rw [map_add] + exact Subring.add_mem _ hf hg + | monomial n r => + rw [Polynomial.aeval_monomial] + exact Subring.mul_mem _ (R_le_intersectionSet R x₁ x₂ y₁ y₂ r) (Subring.pow_mem _ hx n) + +/- In `A[X]` for a domain `A`, a nonzero prime `J_q` contained in a prime `J` that meets the +constants only in `0` must equal `J`: both extend to nonzero primes of the PID `K[X]`. -/ +private theorem polynomial_prime_eq_of_le_of_constants_trivial + {A : Type*} [CommRing A] [IsDomain A] (J J_q : Ideal (Polynomial A)) + (hJ_prime : J.IsPrime) (hJ_q_prime : J_q.IsPrime) (hJJ_q : J_q ≤ J) (hJ_q_ne : J_q ≠ ⊥) + (hJ_const_zero : ∀ (c : A), Polynomial.C c ∈ J → c = 0) : + J_q = J := by + have hJ_q_const_zero : ∀ (c : A), Polynomial.C c ∈ J_q → c = 0 := + fun c hc => hJ_const_zero c (hJJ_q hc) + -- Localize A[X] → K[X]; K[X] is a PID so dim ≤ 1 + set K := FractionRing A + set ψ := Polynomial.mapRingHom (algebraMap A K) + have hψ_inj : Function.Injective ψ := + Polynomial.map_injective _ (IsFractionRing.injective A K) + set M' := Submonoid.map (Polynomial.C : A →+* _) (nonZeroDivisors A) + have hJ_disj : Disjoint (M' : Set (Polynomial A)) (J : Set _) := by + rw [Set.disjoint_left] + intro f hfM hfJ + obtain ⟨c, hc_nzd, rfl⟩ := hfM + exact (nonZeroDivisors.ne_zero hc_nzd) (hJ_const_zero c hfJ) + have hJ_q_disj : Disjoint (M' : Set (Polynomial A)) (J_q : Set _) := by + rw [Set.disjoint_left] + intro f hfM hfJ + obtain ⟨c, hc_nzd, rfl⟩ := hfM + exact (nonZeroDivisors.ne_zero hc_nzd) (hJ_q_const_zero c hfJ) + let : Algebra (Polynomial A) (Polynomial K) := ψ.toAlgebra + have : IsLocalization M' (Polynomial K) := + Polynomial.isLocalization (nonZeroDivisors A) K + have : (Ideal.map (algebraMap _ (Polynomial K)) J).IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint M' (Polynomial K) J hJ_prime hJ_disj + have : (Ideal.map (algebraMap _ (Polynomial K)) J_q).IsPrime := + IsLocalization.isPrime_of_isPrime_disjoint + M' (Polynomial K) J_q hJ_q_prime hJ_q_disj + have hJ_q_map_ne : + Ideal.map (algebraMap _ (Polynomial K)) J_q ≠ ⊥ := by + intro h + have hsat := IsLocalization.under_map_of_isPrime_disjoint + M' (Polynomial K) hJ_q_prime hJ_q_disj + rw [h] at hsat + have hbot : Ideal.under (Polynomial A) (⊥ : Ideal (Polynomial K)) = ⊥ := by + simpa [Ideal.under_def] using + Ideal.comap_bot_of_injective (algebraMap (Polynomial A) (Polynomial K)) hψ_inj + rw [hbot] at hsat + exact hJ_q_ne hsat.symm + have : Ring.DimensionLEOne (Polynomial K) := + Ring.DimensionLEOne.principal_ideal_ring _ + -- In the PID K[X], two nonzero primes with J_q ≤ J forces J_q = J + have hmap_eq : Ideal.map (algebraMap _ (Polynomial K)) J_q = + Ideal.map (algebraMap _ (Polynomial K)) J := + (Ring.DimensionLeOne.prime_le_prime_iff_eq hJ_q_map_ne).mp + (Ideal.map_mono hJJ_q) + -- Saturating back gives J_q = J + have hJ_sat := IsLocalization.under_map_of_isPrime_disjoint + M' (Polynomial K) hJ_prime hJ_disj + have hJ_q_sat := IsLocalization.under_map_of_isPrime_disjoint + M' (Polynomial K) hJ_q_prime hJ_q_disj + exact hJ_q_sat.symm.trans (hmap_eq ▸ hJ_sat) + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +include T in /-- Height bound for primes of S_sub: every associated prime P of T/(t) contracts to an ideal of height ≤ 1 in S_sub. Uses the K[X] PID argument for the P∩R = ⊥ case and well-founded descent for P∩R ≠ ⊥. -/ -private def build_height_bound_proof +theorem build_height_bound (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) (hR_le : R.carrier ≤ S_sub) @@ -353,10 +427,10 @@ private def build_height_bound_proof b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) (hRbar_le_S : ∀ t, t ∈ intersectionSet R x₁ x₂ y₁ y₂ → t ∈ (S_sub : Set T)) (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) - (hx₂_Rbar : x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂) : PLift ( + (hx₂_Rbar : x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂) : ∀ (t : T), t ≠ 0 → ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {t}), - Ideal.height (P.comap S_sub.subtype) ≤ 1 ) := ⟨by + Ideal.height (P.comap S_sub.subtype) ≤ 1 := by have : IsDomain R.carrier := NSubring.isDomain R have : UniqueFactorizationMonoid R.carrier := R.isUFD -- Set up Rbar = R[x₁,y₂⁻¹] ∩ R[x₂,y₁⁻¹] and its localization S = Rbar[units⁻¹] @@ -365,12 +439,6 @@ private def build_height_bound_proof {t : T | ∃ (a : T) (b : T), a ∈ Rbar ∧ b ∈ Rbar ∧ b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a} have hS_sub_eq' : (S_sub : Set T) = S_carrier := hS_sub_eq - have hRbar_one : (1 : T) ∈ Rbar := - (intersectionLocalizationSubring R x₁ x₂ y₁ y₂).one_mem - have hRbar_add : ∀ t₁ t₂, t₁ ∈ Rbar → t₂ ∈ Rbar → t₁ + t₂ ∈ Rbar := - fun _ _ => (intersectionLocalizationSubring R x₁ x₂ y₁ y₂).add_mem - have hRbar_mul : ∀ t₁ t₂, t₁ ∈ Rbar → t₂ ∈ Rbar → t₁ * t₂ ∈ Rbar := - fun _ _ => (intersectionLocalizationSubring R x₁ x₂ y₁ y₂).mul_mem have hS_mem_rep : ∀ s : S_sub, ∃ (a b : T), a ∈ Rbar ∧ b ∈ Rbar ∧ b ∉ IsLocalRing.maximalIdeal T ∧ (s : T) * b = a := by @@ -407,36 +475,10 @@ private def build_height_bound_proof intro x hx by_contra hxnM exact hP_prime.ne_top (P.eq_top_of_isUnit_mem hx (IsLocalRing.notMem_maximalIdeal.mp hxnM)) - have heval_x₁_Rbar : ∀ f : Polynomial R.carrier, (aeval x₁ f : T) ∈ Rbar := by - intro f - induction f using Polynomial.induction_on' with - | add f g hf hg => rw [map_add] - exact hRbar_add _ _ hf hg - | monomial n r => - rw [Polynomial.aeval_monomial] - exact hRbar_mul _ _ (R_le_intersectionSet R x₁ x₂ y₁ y₂ r) (by - induction n with - | zero => simp only [pow_zero] - exact hRbar_one - | succ n ih => rw [pow_succ] - exact hRbar_mul _ _ ih hx₁_Rbar) have heval_x₁_S : ∀ f : Polynomial R.carrier, (aeval x₁ f : T) ∈ S_sub := - fun f => hRbar_le_S _ (heval_x₁_Rbar f) - have heval_x₂_Rbar : ∀ f : Polynomial R.carrier, (aeval x₂ f : T) ∈ Rbar := by - intro f - induction f using Polynomial.induction_on' with - | add f g hf hg => rw [map_add] - exact hRbar_add _ _ hf hg - | monomial n r => - rw [Polynomial.aeval_monomial] - exact hRbar_mul _ _ (R_le_intersectionSet R x₁ x₂ y₁ y₂ r) (by - induction n with - | zero => simp only [pow_zero] - exact hRbar_one - | succ n ih => rw [pow_succ] - exact hRbar_mul _ _ ih hx₂_Rbar) + fun f => hRbar_le_S _ (aeval_mem_intersectionSet R x₁ x₂ y₁ y₂ x₁ hx₁_Rbar f) have heval_x₂_S : ∀ f : Polynomial R.carrier, (aeval x₂ f : T) ∈ S_sub := - fun f => hRbar_le_S _ (heval_x₂_Rbar f) + fun f => hRbar_le_S _ (aeval_mem_intersectionSet R x₁ x₂ y₁ y₂ x₂ hx₂_Rbar f) -- Coprimality of y₁, y₂: at least one of them avoids P have hy_or : (↑y₁ : T) ∉ P ∨ (↑y₂ : T) ∉ P := by by_cases hPR : Ideal.comap R.carrier.subtype P = ⊥ @@ -551,135 +593,23 @@ private def build_height_bound_proof have : c ∈ Ideal.comap R.carrier.subtype P := hcP rw [hPR_bot] at this exact Ideal.mem_bot.mp this - have hJ_q_const_zero : ∀ (c : R.carrier), Polynomial.C c ∈ J_q → c = 0 := - fun c hc => hJ_const_zero c (hJJ_q hc) - -- Localize R[X] → K[X]; K[X] is a PID so dim ≤ 1 - set K := FractionRing R.carrier - set ψ := Polynomial.mapRingHom (algebraMap R.carrier K) - have hψ_inj : Function.Injective ψ := - Polynomial.map_injective _ (IsFractionRing.injective R.carrier K) - set M' := Submonoid.map (Polynomial.C : R.carrier →+* _) (nonZeroDivisors R.carrier) - have hJ_disj : Disjoint (M' : Set (Polynomial R.carrier)) (J : Set _) := by - rw [Set.disjoint_left] - intro f hfM hfJ - obtain ⟨c, hc_nzd, rfl⟩ := hfM - exact (nonZeroDivisors.ne_zero hc_nzd) (hJ_const_zero c hfJ) - have hJ_q_disj : Disjoint (M' : Set (Polynomial R.carrier)) (J_q : Set _) := by - rw [Set.disjoint_left] - intro f hfM hfJ - obtain ⟨c, hc_nzd, rfl⟩ := hfM - exact (nonZeroDivisors.ne_zero hc_nzd) (hJ_q_const_zero c hfJ) - let : Algebra (Polynomial R.carrier) (Polynomial K) := ψ.toAlgebra - have : IsLocalization M' (Polynomial K) := - Polynomial.isLocalization (nonZeroDivisors R.carrier) K - have : (Ideal.map (algebraMap _ (Polynomial K)) J).IsPrime := - IsLocalization.isPrime_of_isPrime_disjoint M' (Polynomial K) J hJ_prime hJ_disj - have : (Ideal.map (algebraMap _ (Polynomial K)) J_q).IsPrime := - IsLocalization.isPrime_of_isPrime_disjoint - M' (Polynomial K) J_q hJ_q_prime hJ_q_disj - have hJ_q_map_ne : - Ideal.map (algebraMap _ (Polynomial K)) J_q ≠ ⊥ := by - intro h - have hsat := IsLocalization.under_map_of_isPrime_disjoint - M' (Polynomial K) hJ_q_prime hJ_q_disj - rw [h] at hsat - have hbot : Ideal.under (Polynomial R.carrier) (⊥ : Ideal (Polynomial K)) = ⊥ := by - simpa [Ideal.under_def] using - Ideal.comap_bot_of_injective (algebraMap (Polynomial R.carrier) (Polynomial K)) hψ_inj - rw [hbot] at hsat - exact hJ_q_ne hsat.symm - have : Ring.DimensionLEOne (Polynomial K) := - Ring.DimensionLEOne.principal_ideal_ring _ - -- In the PID K[X], two nonzero primes with J_q ≤ J forces J_q = J - have hmap_eq : Ideal.map (algebraMap _ (Polynomial K)) J_q = - Ideal.map (algebraMap _ (Polynomial K)) J := - (Ring.DimensionLeOne.prime_le_prime_iff_eq hJ_q_map_ne).mp - (Ideal.map_mono hJJ_q) - -- Saturating back gives J_q = J, contradicting J_q ⊊ J - have hJ_sat := IsLocalization.under_map_of_isPrime_disjoint - M' (Polynomial K) hJ_prime hJ_disj - have hJ_q_sat := IsLocalization.under_map_of_isPrime_disjoint - M' (Polynomial K) hJ_q_prime hJ_q_disj - exact absurd (hJ_q_sat.symm.trans (hmap_eq ▸ hJ_sat)) - (ne_of_lt hJJ_strict) + exact absurd (polynomial_prime_eq_of_le_of_constants_trivial J J_q hJ_prime hJ_q_prime + hJJ_q hJ_q_ne hJ_const_zero) (ne_of_lt hJJ_strict) -- P∩R ≠ ⊥ case: apply the well-founded descent to get a contradiction · exact absurd hs_ne (height_bound_wf_descent R x₁ x₂ y₁ y₂ S_sub hR_le hRbar_le_S hinv hR_prime_in_S (fun s => hS_mem_rep s) P hP_ht hR_bound hPR_bot hP_le_M x_eval y_elem hy_nP hx_ker_branch heval_S get_witness_Rbar q hq_lt s hs_ne hs_q).elim -⟩ omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -include T in theorem build_height_bound - (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) - (S_sub : Subring T) - (hR_le : R.carrier ≤ S_sub) - (hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) - (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hx₁_trans : Transcendental R.carrier x₁) - (hx₂_trans : Transcendental R.carrier x₂) - (hx₁_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₂ : T) ∉ P → - ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → - ∀ (f : Polynomial R.carrier), - aeval x₁ f ∈ P → (C p : Polynomial R.carrier) ∣ f) - (hx₂_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₁ : T) ∉ P → - ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → - ∀ (f : Polynomial R.carrier), - aeval x₂ f ∈ P → (C p : Polynomial R.carrier) ∣ f) - (hinv : ∀ (s : S_sub), (s : T) ∉ IsLocalRing.maximalIdeal T → IsUnit s) - (hR_prime_in_S : ∀ (p : R.carrier), Prime p → - (↑p : T) ∈ IsLocalRing.maximalIdeal T → - Prime (⟨(↑p : T), hR_le p.2⟩ : S_sub)) - (hS_sub_eq : (S_sub : Set T) = +/- The fractions `a / b` with `a, b ∈ Rbar` and `b ∉ M` form a subring of `T`. -/ +private theorem exists_subring_eq_fractionCarrier + (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) : + ∃ S_sub : Subring T, (S_sub : Set T) = {t : T | ∃ (a : T) (b : T), a ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ b ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ - b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) - (hRbar_le_S : ∀ t, t ∈ intersectionSet R x₁ x₂ y₁ y₂ → t ∈ (S_sub : Set T)) - (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) - (hx₂_Rbar : x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂) : - ∀ (t : T), t ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {t}), - Ideal.height (P.comap S_sub.subtype) ≤ 1 := by - exact - (build_height_bound_proof - R x₁ x₂ y₁ y₂ S_sub hR_le hcoprime hy₁ hy₂ hAss_ht hM_not_assoc hx₁_trans hx₂_trans - hx₁_ker hx₂_ker hinv hR_prime_in_S hS_sub_eq hRbar_le_S hx₁_Rbar hx₂_Rbar - ).down -/-- Helper: the Krull domain intersection construction produces an NSubring -containing both x₁ and x₂. Core algebraic construction from Heitmann (1993) Lemma 4. -/ -private def build_intersection_nsubring_proof - (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (c : R.carrier) - (hc_eq : (↑c : T) = x₁ * ↑y₁ + x₂ * ↑y₂) - (hx₁_trans : Transcendental R.carrier x₁) - (hx₂_trans : Transcendental R.carrier x₂) - (hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) - (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) - (_hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (_hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (_hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hx₁_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₂ : T) ∉ P → - ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → - ∀ (f : Polynomial R.carrier), - aeval x₁ f ∈ P → (C p : Polynomial R.carrier) ∣ f) - (hx₂_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₁ : T) ∉ P → - ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → - ∀ (f : Polynomial R.carrier), - aeval x₂ f ∈ P → (C p : Polynomial R.carrier) ∣ f) : PLift ( - ∃ S : NSubring T, IsAExtension R S ∧ x₁ ∈ S.carrier ∧ x₂ ∈ S.carrier ) := ⟨by - have : IsDomain R.carrier := NSubring.isDomain R - have : UniqueFactorizationMonoid R.carrier := R.isUFD - -- Derive mod-principal transcendence for both x₁ (mod y₂) and x₂ (mod y₁) - have hx₁_mod_trans := derive_mod_principal_trans R x₁ y₂ hAss_ht hx₁_ker - have hx₂_mod_trans := derive_mod_principal_trans R x₂ y₁ hAss_ht hx₂_ker + b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a} := by set Rbar := intersectionSet R x₁ x₂ y₁ y₂ have hunit : ∀ (a : T), a ∉ IsLocalRing.maximalIdeal T → IsUnit a := fun a ha => IsLocalRing.notMem_maximalIdeal.mp ha @@ -688,7 +618,6 @@ private def build_intersection_nsubring_proof a * b ∉ IsLocalRing.maximalIdeal T := by intro a b ha hb exact IsLocalRing.notMem_maximalIdeal.mpr ((hunit a ha).mul (hunit b hb)) - -- S = {a/b : a,b ∈ Rbar, b ∉ M} -- localize Rbar at elements outside the maximal ideal set S_carrier : Set T := {t : T | ∃ (a : T) (b : T), a ∈ Rbar ∧ b ∈ Rbar ∧ b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a} @@ -702,46 +631,38 @@ private def build_intersection_nsubring_proof fun _ _ => (intersectionLocalizationSubring R x₁ x₂ y₁ y₂).mul_mem have hRbar_add : ∀ t₁ t₂, t₁ ∈ Rbar → t₂ ∈ Rbar → t₁ + t₂ ∈ Rbar := fun _ _ => (intersectionLocalizationSubring R x₁ x₂ y₁ y₂).add_mem - -- Verify S_carrier is closed under ring operations, hence forms a subring of T - have hS_carrier_subring : ∃ S_sub : Subring T, (S_sub : Set T) = S_carrier := by - refine ⟨{ - carrier := S_carrier - zero_mem' := ⟨0, 1, hRbar_zero, hRbar_one, - IsLocalRing.notMem_maximalIdeal.mpr isUnit_one, by rw [zero_mul]⟩ - one_mem' := ⟨1, 1, hRbar_one, hRbar_one, - IsLocalRing.notMem_maximalIdeal.mpr isUnit_one, by rw [one_mul]⟩ - neg_mem' := ?neg - add_mem' := ?add - mul_mem' := ?mul - }, rfl⟩ - case neg => - intro t ⟨a, b, ha, hb, hb_notM, htb⟩ - exact ⟨-a, b, hRbar_neg a ha, hb, hb_notM, by rw [neg_mul, htb]⟩ - case mul => - intro t₁ t₂ ⟨a₁, b₁, ha₁, hb₁, hb₁_notM, ht₁⟩ ⟨a₂, b₂, ha₂, hb₂, hb₂_notM, ht₂⟩ - refine ⟨a₁ * a₂, b₁ * b₂, hRbar_mul a₁ a₂ ha₁ ha₂, hRbar_mul b₁ b₂ hb₁ hb₂, - hprod_notmem b₁ b₂ hb₁_notM hb₂_notM, ?_⟩ - rw [show t₁ * t₂ * (b₁ * b₂) = (t₁ * b₁) * (t₂ * b₂) from by ring, ht₁, ht₂] - case add => - intro t₁ t₂ ⟨a₁, b₁, ha₁, hb₁, hb₁_notM, ht₁⟩ ⟨a₂, b₂, ha₂, hb₂, hb₂_notM, ht₂⟩ - refine ⟨a₁ * b₂ + a₂ * b₁, b₁ * b₂, - hRbar_add _ _ (hRbar_mul a₁ b₂ ha₁ hb₂) (hRbar_mul a₂ b₁ ha₂ hb₁), - hRbar_mul b₁ b₂ hb₁ hb₂, - hprod_notmem b₁ b₂ hb₁_notM hb₂_notM, ?_⟩ - rw [show (t₁ + t₂) * (b₁ * b₂) = t₁ * b₁ * b₂ + t₂ * b₂ * b₁ from by ring, ht₁, ht₂] - obtain ⟨S_sub, hS_sub_eq⟩ := hS_carrier_subring - have hRbar_le_S : ∀ t ∈ Rbar, t ∈ (S_sub : Set T) := by - intro t ht - rw [hS_sub_eq] - exact ⟨t, 1, - ht, - ⟨R_le_adjoinLocSetY R x₁ y₂ 1, R_le_adjoinLocSetY R x₂ y₁ 1⟩, - IsLocalRing.notMem_maximalIdeal.mpr isUnit_one, - mul_one t⟩ - have hR_le : R.carrier ≤ S_sub := by - intro r hr - exact hRbar_le_S _ (R_le_intersectionSet R x₁ x₂ y₁ y₂ ⟨r, hr⟩) - -- Show x₁ ∈ Rbar: trivially in R[x₁,y₂⁻¹]; in R[x₂,y₁⁻¹] via c = x₁y₁ + x₂y₂ + refine ⟨{ + carrier := S_carrier + zero_mem' := ⟨0, 1, hRbar_zero, hRbar_one, + IsLocalRing.notMem_maximalIdeal.mpr isUnit_one, by rw [zero_mul]⟩ + one_mem' := ⟨1, 1, hRbar_one, hRbar_one, + IsLocalRing.notMem_maximalIdeal.mpr isUnit_one, by rw [one_mul]⟩ + neg_mem' := ?neg + add_mem' := ?add + mul_mem' := ?mul + }, rfl⟩ + case neg => + intro t ⟨a, b, ha, hb, hb_notM, htb⟩ + exact ⟨-a, b, hRbar_neg a ha, hb, hb_notM, by rw [neg_mul, htb]⟩ + case mul => + intro t₁ t₂ ⟨a₁, b₁, ha₁, hb₁, hb₁_notM, ht₁⟩ ⟨a₂, b₂, ha₂, hb₂, hb₂_notM, ht₂⟩ + refine ⟨a₁ * a₂, b₁ * b₂, hRbar_mul a₁ a₂ ha₁ ha₂, hRbar_mul b₁ b₂ hb₁ hb₂, + hprod_notmem b₁ b₂ hb₁_notM hb₂_notM, ?_⟩ + rw [show t₁ * t₂ * (b₁ * b₂) = (t₁ * b₁) * (t₂ * b₂) from by ring, ht₁, ht₂] + case add => + intro t₁ t₂ ⟨a₁, b₁, ha₁, hb₁, hb₁_notM, ht₁⟩ ⟨a₂, b₂, ha₂, hb₂, hb₂_notM, ht₂⟩ + refine ⟨a₁ * b₂ + a₂ * b₁, b₁ * b₂, + hRbar_add _ _ (hRbar_mul a₁ b₂ ha₁ hb₂) (hRbar_mul a₂ b₁ ha₂ hb₁), + hRbar_mul b₁ b₂ hb₁ hb₂, + hprod_notmem b₁ b₂ hb₁_notM hb₂_notM, ?_⟩ + rw [show (t₁ + t₂) * (b₁ * b₂) = t₁ * b₁ * b₂ + t₂ * b₂ * b₁ from by ring, ht₁, ht₂] + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Both `x₁` and `x₂` lie in Rbar, using `c = x₁ y₁ + x₂ y₂`. -/ +private theorem mem_intersectionSet_of_linear_combination + (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (c : R.carrier) + (hc_eq : (↑c : T) = x₁ * ↑y₁ + x₂ * ↑y₂) : + x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂ := by have hx₁_A₁ : x₁ ∈ adjoinLocSetY R x₁ y₂ := x_mem_adjoinLocSetY R x₁ y₂ have hx₁_A₂ : x₁ ∈ adjoinLocSetY R x₂ y₁ := by refine ⟨C c - X * C y₂, 1, ?_⟩ @@ -753,8 +674,6 @@ private def build_intersection_nsubring_proof rw [h] ring convert hc' using 2 <;> rfl - have hx₁_Rbar : x₁ ∈ Rbar := ⟨hx₁_A₁, hx₁_A₂⟩ - -- Symmetrically, x₂ ∈ Rbar using x₂ = (c - x₁y₁)/y₂ have hx₂_A₂ : x₂ ∈ adjoinLocSetY R x₂ y₁ := x_mem_adjoinLocSetY R x₂ y₁ have hx₂_A₁ : x₂ ∈ adjoinLocSetY R x₁ y₂ := by refine ⟨C c - X * C y₁, 1, ?_⟩ @@ -769,35 +688,219 @@ private def build_intersection_nsubring_proof rw [h] ring convert hc' - have hx₂_Rbar : x₂ ∈ Rbar := ⟨hx₂_A₁, hx₂_A₂⟩ + exact ⟨⟨hx₁_A₁, hx₁_A₂⟩, ⟨hx₂_A₁, hx₂_A₂⟩⟩ + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Elements of the fraction subring outside `M` are units of the subring. -/ +private theorem isUnit_of_notMem_maximalIdeal_fractionSubring + (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) + (hS_sub_eq : (S_sub : Set T) = + {t : T | ∃ (a : T) (b : T), + a ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ + b ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ + b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) + (s : S_sub) (hs_notM : (s : T) ∉ IsLocalRing.maximalIdeal T) : IsUnit s := by + obtain ⟨s, hs_mem⟩ := s + have hs_carrier : s ∈ (S_sub : Set T) := hs_mem + rw [hS_sub_eq] at hs_carrier + obtain ⟨a, b, ha_Rbar, hb_Rbar, hb_notM, hsb_eq⟩ := hs_carrier + have hs_unit : IsUnit s := IsLocalRing.notMem_maximalIdeal.mp hs_notM + let s_inv : T := ↑(hs_unit.unit⁻¹ : Tˣ) + have hs_mul_inv : s * s_inv = 1 := hs_unit.mul_val_inv + have hs_inv_mul : s_inv * s = 1 := hs_unit.val_inv_mul + have ha_notM : a ∉ IsLocalRing.maximalIdeal T := by + rw [← hsb_eq] + exact IsLocalRing.notMem_maximalIdeal.mpr + (hs_unit.mul (IsLocalRing.notMem_maximalIdeal.mp hb_notM)) + have hs_inv_S : s_inv ∈ S_sub := by + change s_inv ∈ (S_sub : Set T) + rw [hS_sub_eq] + refine ⟨b, a, hb_Rbar, ha_Rbar, ha_notM, ?_⟩ + calc s_inv * a = s_inv * (s * b) := by rw [hsb_eq] + _ = (s_inv * s) * b := by ring + _ = 1 * b := by rw [hs_inv_mul] + _ = b := one_mul b + have hmul_one : (⟨s, hs_mem⟩ : S_sub) * ⟨s_inv, hs_inv_S⟩ = 1 := + Subtype.ext hs_mul_inv + exact IsUnit.of_mul_eq_one _ hmul_one + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- `R[x, y⁻¹]` is closed under division by primes of `R`. -/ +private theorem adjoinLocSetY_div_prime + (R : NSubring T) (x : T) (y : R.carrier) + (hx_mod_trans : ∀ (p : R.carrier), Prime p → ¬p ∣ y → ∀ (f : Polynomial R.carrier), + aeval x f ∈ Ideal.span {(↑p : T)} → (C p : Polynomial R.carrier) ∣ f) + (p : R.carrier) (hp : Prime p) (t d : T) (ht : t ∈ adjoinLocSetY R x y) + (htpd : t = (↑p : T) * d) : d ∈ adjoinLocSetY R x y := by + obtain ⟨f, n, hfn⟩ := ht + have hpd_eq : (↑p : T) * (d * (↑y : T) ^ n) = aeval x f := by + rw [← hfn, htpd] + ring + -- If p | y, absorb extra y into the polynomial; otherwise use mod-principal transcendence + by_cases hpy : p ∣ y + · obtain ⟨q, hq⟩ := hpy + have hy_eq : (↑y : T) = (↑p : T) * (↑q : T) := by + rw [hq] + simp + refine ⟨f * C q, n + 1, ?_⟩ + have key : d * (↑y : T) ^ (n + 1) = aeval x f * (↑q : T) := by + have hpow : (↑y : T) ^ (n + 1) = (↑y : T) ^ n * ((↑p : T) * (↑q : T)) := by + rw [pow_succ, hy_eq] + rw [hpow] + have : d * ((↑y : T) ^ n * ((↑p : T) * (↑q : T))) = + ((↑p : T) * (d * (↑y : T) ^ n)) * (↑q : T) := by ring + rw [this, hpd_eq] + rw [key, map_mul, aeval_C, + show algebraMap R.carrier T = R.carrier.subtype from rfl, Subring.coe_subtype] + · suffices hCp_dvd : (C p : Polynomial R.carrier) ∣ f by + obtain ⟨g, hfg⟩ := hCp_dvd + have hr_ne : (↑p : T) ≠ 0 := + fun h => hp.ne_zero (R.carrier.subtype_injective h) + refine ⟨g, n, mul_left_cancel₀ hr_ne ?_⟩ + rw [hpd_eq, hfg, map_mul, aeval_C, + show algebraMap R.carrier T = R.carrier.subtype from rfl] + rfl + exact hx_mod_trans p hp hpy f + (Ideal.mem_span_singleton.mpr ⟨d * (↑y : T) ^ n, hpd_eq.symm⟩) + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Cardinality bound: `|S| ≤ |Rbar|² ≤ max(aleph0, |R|)` since `S ↪ Rbar × Rbar`. -/ +private theorem card_fractionSubring_le + (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (hy₂ : (↑y₂ : T) ≠ 0) + (S_sub : Subring T) + (hS_sub_eq : (S_sub : Set T) = + {t : T | ∃ (a : T) (b : T), + a ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ + b ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ + b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) : + Cardinal.mk S_sub ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) := by + set Rbar := intersectionSet R x₁ x₂ y₁ y₂ + set S_carrier : Set T := + {t : T | ∃ (a : T) (b : T), a ∈ Rbar ∧ b ∈ Rbar ∧ + b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a} + have hALS_card : Cardinal.mk ↥(adjoinLocSetY R x₁ y₂) ≤ + max Cardinal.aleph0 (Cardinal.mk R.carrier) := by + have hsub : (adjoinLocSetY R x₁ y₂ : Set T) ⊆ + ⋃ (f : Polynomial R.carrier), {t : T | ∃ n : ℕ, t * (↑y₂ : T) ^ n = aeval x₁ f} := by + intro t ⟨f, n, h⟩ + exact Set.mem_iUnion.mpr ⟨f, ⟨n, h⟩⟩ + apply le_trans (Cardinal.mk_le_mk_of_subset hsub) + apply le_trans (Cardinal.mk_iUnion_le _) + calc Cardinal.mk (Polynomial R.carrier) * + ⨆ (f : Polynomial R.carrier), Cardinal.mk ↑{t : T | ∃ n : ℕ, + t * (↑y₂ : T) ^ n = aeval x₁ f} + ≤ max (Cardinal.mk R.carrier) Cardinal.aleph0 * Cardinal.aleph0 := by + gcongr + · exact Polynomial.cardinalMk_le_max + · apply ciSup_le' + intro f + apply Cardinal.mk_le_aleph0_iff.mpr + apply Set.Countable.to_subtype + apply (Set.countable_iUnion (fun (n : ℕ) => + Set.Subsingleton.countable (fun (t₁ : T) (ht₁ : t₁ * (↑y₂ : T) ^ n = aeval x₁ f) + (t₂ : T) (ht₂ : t₂ * (↑y₂ : T) ^ n = aeval x₁ f) => + mul_right_cancel₀ (pow_ne_zero n hy₂) (ht₁.trans ht₂.symm)))).mono + intro t ⟨n, hn⟩ + exact Set.mem_iUnion.mpr ⟨n, hn⟩ + _ = max (Cardinal.mk R.carrier) Cardinal.aleph0 := + Cardinal.mul_aleph0_eq (le_max_right _ _) + _ = max Cardinal.aleph0 (Cardinal.mk R.carrier) := max_comm _ _ + have hRbar_card : Cardinal.mk ↥Rbar ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) := + le_trans (Cardinal.mk_le_of_injective + (Set.inclusion_injective (Set.inter_subset_left))) hALS_card + have hf : Function.Injective (fun (s : S_sub) => + Prod.mk + (⟨(hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose, + (hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose_spec.choose_spec.1⟩ : ↥Rbar) + (⟨(hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose_spec.choose, + (hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose_spec.choose_spec.2.1⟩ : ↥Rbar)) := by + intro s₁ s₂ heq + simp only [Prod.mk.injEq, Subtype.mk.injEq] at heq + obtain ⟨ha_eq, hb_eq⟩ := heq + have h₁ := (hS_sub_eq ▸ s₁.2 : s₁.val ∈ S_carrier).choose_spec.choose_spec + have h₂ := (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose_spec + have key : s₁.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose = + s₂.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose := by + calc s₁.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose + = s₁.val * (hS_sub_eq ▸ s₁.2 : s₁.val ∈ S_carrier).choose_spec.choose := by rw [← hb_eq] + _ = (hS_sub_eq ▸ s₁.2 : s₁.val ∈ S_carrier).choose := h₁.2.2.2 + _ = (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose := ha_eq + _ = s₂.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose := h₂.2.2.2.symm + have hb_ne : (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose ≠ (0 : T) := by + intro hb0 + exact h₂.2.2.1 (hb0 ▸ Ideal.zero_mem _) + have hsub : (s₁.val - s₂.val) * + (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose = 0 := by + rw [sub_mul, key, sub_self] + exact Subtype.ext (sub_eq_zero.mp + ((mul_eq_zero.mp hsub).resolve_right hb_ne)) + calc Cardinal.mk S_sub + ≤ Cardinal.mk (↥Rbar × ↥Rbar) := Cardinal.mk_le_of_injective hf + _ = Cardinal.mk ↥Rbar * Cardinal.mk ↥Rbar := (Cardinal.mul_def _ _).symm + _ ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) * + max Cardinal.aleph0 (Cardinal.mk R.carrier) := + mul_le_mul' hRbar_card hRbar_card + _ = max Cardinal.aleph0 (Cardinal.mk R.carrier) := + Cardinal.mul_eq_self (le_max_left _ _) + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +include T in +/-- The Krull domain intersection construction produces an NSubring +containing both x₁ and x₂. Core algebraic construction from Heitmann (1993) Lemma 4. -/ +theorem build_intersection_nsubring + (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (c : R.carrier) + (hc_eq : (↑c : T) = x₁ * ↑y₁ + x₂ * ↑y₂) + (hx₁_trans : Transcendental R.carrier x₁) + (hx₂_trans : Transcendental R.carrier x₂) + (hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) + (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) + (_hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) + (hM_not_assoc : ∀ (r : T), r ≠ 0 → + IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) + (hAss_ht : ∀ (r : T), r ≠ 0 → + ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) + (_hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (_hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) + (hx₁_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₂ : T) ∉ P → + ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → + ∀ (f : Polynomial R.carrier), + aeval x₁ f ∈ P → (C p : Polynomial R.carrier) ∣ f) + (hx₂_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₁ : T) ∉ P → + ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → + ∀ (f : Polynomial R.carrier), + aeval x₂ f ∈ P → (C p : Polynomial R.carrier) ∣ f) : + ∃ S : NSubring T, IsAExtension R S ∧ x₁ ∈ S.carrier ∧ x₂ ∈ S.carrier := by + have : IsDomain R.carrier := NSubring.isDomain R + have : UniqueFactorizationMonoid R.carrier := R.isUFD + -- Derive mod-principal transcendence for both x₁ (mod y₂) and x₂ (mod y₁) + have hx₁_mod_trans := derive_mod_principal_trans R x₁ y₂ hAss_ht hx₁_ker + have hx₂_mod_trans := derive_mod_principal_trans R x₂ y₁ hAss_ht hx₂_ker + set Rbar := intersectionSet R x₁ x₂ y₁ y₂ + -- S = {a/b : a,b ∈ Rbar, b ∉ M} -- localize Rbar at elements outside the maximal ideal + set S_carrier : Set T := + {t : T | ∃ (a : T) (b : T), a ∈ Rbar ∧ b ∈ Rbar ∧ + b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a} + obtain ⟨S_sub, hS_sub_eq⟩ : ∃ S_sub : Subring T, (S_sub : Set T) = S_carrier := + exists_subring_eq_fractionCarrier R x₁ x₂ y₁ y₂ + have hRbar_le_S : ∀ t ∈ Rbar, t ∈ (S_sub : Set T) := by + intro t ht + rw [hS_sub_eq] + exact ⟨t, 1, + ht, + ⟨R_le_adjoinLocSetY R x₁ y₂ 1, R_le_adjoinLocSetY R x₂ y₁ 1⟩, + IsLocalRing.notMem_maximalIdeal.mpr isUnit_one, + mul_one t⟩ + have hR_le : R.carrier ≤ S_sub := by + intro r hr + exact hRbar_le_S _ (R_le_intersectionSet R x₁ x₂ y₁ y₂ ⟨r, hr⟩) + -- x₁ ∈ Rbar and x₂ ∈ Rbar via c = x₁y₁ + x₂y₂ + obtain ⟨hx₁_Rbar, hx₂_Rbar⟩ : x₁ ∈ Rbar ∧ x₂ ∈ Rbar := + mem_intersectionSet_of_linear_combination R x₁ x₂ y₁ y₂ c hc_eq have hx₁_S : x₁ ∈ S_sub := hRbar_le_S _ hx₁_Rbar have hx₂_S : x₂ ∈ S_sub := hRbar_le_S _ hx₂_Rbar -- S is local: elements outside M are units (their inverses lie in S via the a/b representation) - have hinv : ∀ (s : S_sub), (s : T) ∉ IsLocalRing.maximalIdeal T → IsUnit s := by - intro ⟨s, hs_mem⟩ hs_notM - have hs_carrier : s ∈ S_carrier := by rw [← hS_sub_eq] - exact hs_mem - obtain ⟨a, b, ha_Rbar, hb_Rbar, hb_notM, hsb_eq⟩ := hs_carrier - have hs_unit : IsUnit s := hunit s hs_notM - let s_inv : T := ↑(hs_unit.unit⁻¹ : Tˣ) - have hs_mul_inv : s * s_inv = 1 := hs_unit.mul_val_inv - have hs_inv_mul : s_inv * s = 1 := hs_unit.val_inv_mul - have ha_notM : a ∉ IsLocalRing.maximalIdeal T := by - rw [← hsb_eq] - exact hprod_notmem s b hs_notM hb_notM - have hs_inv_carrier : s_inv ∈ S_carrier := by - refine ⟨b, a, hb_Rbar, ha_Rbar, ha_notM, ?_⟩ - calc s_inv * a = s_inv * (s * b) := by rw [hsb_eq] - _ = (s_inv * s) * b := by ring - _ = 1 * b := by rw [hs_inv_mul] - _ = b := one_mul b - have hs_inv_S : s_inv ∈ S_sub := by - change s_inv ∈ (S_sub : Set T) - rw [hS_sub_eq] - exact hs_inv_carrier - have hmul_one : (⟨s, hs_mem⟩ : S_sub) * ⟨s_inv, hs_inv_S⟩ = 1 := - Subtype.ext hs_mul_inv - exact IsUnit.of_mul_eq_one _ hmul_one + have hinv : ∀ (s : S_sub), (s : T) ∉ IsLocalRing.maximalIdeal T → IsUnit s := + isUnit_of_notMem_maximalIdeal_fractionSubring R x₁ x₂ y₁ y₂ S_sub hS_sub_eq have hLocal : IsLocalRing S_sub := by apply IsLocalRing.of_isUnit_or_isUnit_one_sub_self intro a @@ -823,88 +926,12 @@ private def build_intersection_nsubring_proof refine ⟨fun h => ha_ne (Subtype.ext h), c.val, ?_, congrArg Subtype.val hab_eq⟩ exact fun hcu_T => hc_nu (hinv c (IsLocalRing.notMem_maximalIdeal.mpr hcu_T)) · exact InvImage.wf _ wellFounded_dvdNotUnit - have hS_mem_rep : ∀ s : S_sub, - ∃ (a b : T), a ∈ Rbar ∧ b ∈ Rbar ∧ - b ∉ IsLocalRing.maximalIdeal T ∧ (s : T) * b = a := by - intro s - have := s.2 - change s.1 ∈ (S_sub : Set T) at this - rw [hS_sub_eq] at this - exact this - have hRbar_inv_S : ∀ t : T, t ∈ Rbar → t ∉ IsLocalRing.maximalIdeal T → - ∃ (t_inv : T), t_inv ∈ (S_sub : Set T) ∧ t * t_inv = 1 := by - intro t ht ht_notM - have ht_unit := hunit t ht_notM - refine ⟨↑ht_unit.unit⁻¹, ?_, ht_unit.mul_val_inv⟩ - rw [hS_sub_eq] - refine ⟨1, t, hRbar_one, ht, ht_notM, ?_⟩ - rw [ht_unit.val_inv_mul] -- Rbar is closed under division by primes of R (key for building the UFD structure) have hR_prime_div_Rbar : ∀ (p : R.carrier), Prime p → ∀ t ∈ Rbar, - ∀ (d : T), t = (↑p : T) * d → d ∈ Rbar := by - intro p hp t ⟨ht_A1, ht_A2⟩ d htpd - have hcop := hcoprime p hp - push Not at hcop - constructor - · obtain ⟨f, n, hfn⟩ := ht_A1 - have hpd_eq : (↑p : T) * (d * (↑y₂ : T) ^ n) = aeval x₁ f := by - rw [← hfn, htpd] - ring - -- If p | y₂, absorb extra y₂ into the polynomial; otherwise use mod-principal transcendence - by_cases hpy₂ : p ∣ y₂ - · obtain ⟨q, hq⟩ := hpy₂ - have hy₂_eq : (↑y₂ : T) = (↑p : T) * (↑q : T) := by - rw [hq] - simp - refine ⟨f * C q, n + 1, ?_⟩ - have key : d * (↑y₂ : T) ^ (n + 1) = aeval x₁ f * (↑q : T) := by - have hpow : (↑y₂ : T) ^ (n + 1) = (↑y₂ : T) ^ n * ((↑p : T) * (↑q : T)) := by - rw [pow_succ, hy₂_eq] - rw [hpow] - have : d * ((↑y₂ : T) ^ n * ((↑p : T) * (↑q : T))) = - ((↑p : T) * (d * (↑y₂ : T) ^ n)) * (↑q : T) := by ring - rw [this, hpd_eq] - rw [key, map_mul, aeval_C, - show algebraMap R.carrier T = R.carrier.subtype from rfl, Subring.coe_subtype] - · suffices hCp_dvd : (C p : Polynomial R.carrier) ∣ f by - obtain ⟨g, hfg⟩ := hCp_dvd - have hr_ne : (↑p : T) ≠ 0 := - fun h => hp.ne_zero (R.carrier.subtype_injective h) - refine ⟨g, n, mul_left_cancel₀ hr_ne ?_⟩ - rw [hpd_eq, hfg, map_mul, aeval_C, - show algebraMap R.carrier T = R.carrier.subtype from rfl] - rfl - exact hx₁_mod_trans p hp hpy₂ f - (Ideal.mem_span_singleton.mpr ⟨d * (↑y₂ : T) ^ n, hpd_eq.symm⟩) - · obtain ⟨f, n, hfn⟩ := ht_A2 - have hpd_eq : (↑p : T) * (d * (↑y₁ : T) ^ n) = aeval x₂ f := by - rw [← hfn, htpd] - ring - by_cases hpy₁ : p ∣ y₁ - · obtain ⟨q, hq⟩ := hpy₁ - have hy₁_eq : (↑y₁ : T) = (↑p : T) * (↑q : T) := by - rw [hq] - simp - refine ⟨f * C q, n + 1, ?_⟩ - have key : d * (↑y₁ : T) ^ (n + 1) = aeval x₂ f * (↑q : T) := by - have hpow : (↑y₁ : T) ^ (n + 1) = (↑y₁ : T) ^ n * ((↑p : T) * (↑q : T)) := by - rw [pow_succ, hy₁_eq] - rw [hpow] - have : d * ((↑y₁ : T) ^ n * ((↑p : T) * (↑q : T))) = - ((↑p : T) * (d * (↑y₁ : T) ^ n)) * (↑q : T) := by ring - rw [this, hpd_eq] - rw [key, map_mul, aeval_C, - show algebraMap R.carrier T = R.carrier.subtype from rfl, Subring.coe_subtype] - · suffices hCp_dvd : (C p : Polynomial R.carrier) ∣ f by - obtain ⟨g, hfg⟩ := hCp_dvd - have hr_ne : (↑p : T) ≠ 0 := - fun h => hp.ne_zero (R.carrier.subtype_injective h) - refine ⟨g, n, mul_left_cancel₀ hr_ne ?_⟩ - rw [hpd_eq, hfg, map_mul, aeval_C, - show algebraMap R.carrier T = R.carrier.subtype from rfl] - rfl - exact hx₂_mod_trans p hp hpy₁ f - (Ideal.mem_span_singleton.mpr ⟨d * (↑y₁ : T) ^ n, hpd_eq.symm⟩) + ∀ (d : T), t = (↑p : T) * d → d ∈ Rbar := + fun p hp t ht d htpd => + ⟨adjoinLocSetY_div_prime R x₁ y₂ hx₁_mod_trans p hp t d ht.1 htpd, + adjoinLocSetY_div_prime R x₂ y₁ hx₂_mod_trans p hp t d ht.2 htpd⟩ -- Primes of R remain prime in S, then build UFD structure on S have hR_prime_in_S := build_R_prime_in_S R x₁ x₂ y₁ y₂ S_sub hR_le hx₁_trans hx₂_trans hcoprime hS_sub_eq hR_prime_div_Rbar hinv @@ -912,71 +939,8 @@ private def build_intersection_nsubring_proof build_ufd_proof R x₁ x₂ y₁ y₂ S_sub hR_le hcoprime hy₁ hy₂ hx₁_trans hx₂_trans hx₁_mod_trans hx₂_mod_trans hinv hR_prime_in_S hS_sub_eq hRbar_le_S hx₁_Rbar hx₂_Rbar -- Cardinality bound: |S| ≤ |Rbar|² ≤ max(aleph0, |R|) since S ↪ Rbar × Rbar via (a,b) - have hCard_S : Cardinal.mk S_sub ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) := by - have hALS_card : Cardinal.mk ↥(adjoinLocSetY R x₁ y₂) ≤ - max Cardinal.aleph0 (Cardinal.mk R.carrier) := by - have hsub : (adjoinLocSetY R x₁ y₂ : Set T) ⊆ - ⋃ (f : Polynomial R.carrier), {t : T | ∃ n : ℕ, t * (↑y₂ : T) ^ n = aeval x₁ f} := by - intro t ⟨f, n, h⟩ - exact Set.mem_iUnion.mpr ⟨f, ⟨n, h⟩⟩ - apply le_trans (Cardinal.mk_le_mk_of_subset hsub) - apply le_trans (Cardinal.mk_iUnion_le _) - calc Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), Cardinal.mk ↑{t : T | ∃ n : ℕ, - t * (↑y₂ : T) ^ n = aeval x₁ f} - ≤ max (Cardinal.mk R.carrier) Cardinal.aleph0 * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - apply Set.Countable.to_subtype - apply (Set.countable_iUnion (fun (n : ℕ) => - Set.Subsingleton.countable (fun (t₁ : T) (ht₁ : t₁ * (↑y₂ : T) ^ n = aeval x₁ f) - (t₂ : T) (ht₂ : t₂ * (↑y₂ : T) ^ n = aeval x₁ f) => - mul_right_cancel₀ (pow_ne_zero n hy₂) (ht₁.trans ht₂.symm)))).mono - intro t ⟨n, hn⟩ - exact Set.mem_iUnion.mpr ⟨n, hn⟩ - _ = max (Cardinal.mk R.carrier) Cardinal.aleph0 := - Cardinal.mul_aleph0_eq (le_max_right _ _) - _ = max Cardinal.aleph0 (Cardinal.mk R.carrier) := max_comm _ _ - have hRbar_card : Cardinal.mk ↥Rbar ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) := - le_trans (Cardinal.mk_le_of_injective - (Set.inclusion_injective (Set.inter_subset_left))) hALS_card - have hf : Function.Injective (fun (s : S_sub) => - Prod.mk - (⟨(hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose, - (hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose_spec.choose_spec.1⟩ : ↥Rbar) - (⟨(hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose_spec.choose, - (hS_sub_eq ▸ s.2 : s.val ∈ S_carrier).choose_spec.choose_spec.2.1⟩ : ↥Rbar)) := by - intro s₁ s₂ heq - simp only [Prod.mk.injEq, Subtype.mk.injEq] at heq - obtain ⟨ha_eq, hb_eq⟩ := heq - have h₁ := (hS_sub_eq ▸ s₁.2 : s₁.val ∈ S_carrier).choose_spec.choose_spec - have h₂ := (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose_spec - have key : s₁.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose = - s₂.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose := by - calc s₁.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose - = s₁.val * (hS_sub_eq ▸ s₁.2 : s₁.val ∈ S_carrier).choose_spec.choose := by rw [← hb_eq] - _ = (hS_sub_eq ▸ s₁.2 : s₁.val ∈ S_carrier).choose := h₁.2.2.2 - _ = (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose := ha_eq - _ = s₂.val * (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose := h₂.2.2.2.symm - have hb_ne : (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose ≠ (0 : T) := by - intro hb0 - exact h₂.2.2.1 (hb0 ▸ Ideal.zero_mem _) - have hsub : (s₁.val - s₂.val) * - (hS_sub_eq ▸ s₂.2 : s₂.val ∈ S_carrier).choose_spec.choose = 0 := by - rw [sub_mul, key, sub_self] - exact Subtype.ext (sub_eq_zero.mp - ((mul_eq_zero.mp hsub).resolve_right hb_ne)) - calc Cardinal.mk S_sub - ≤ Cardinal.mk (↥Rbar × ↥Rbar) := Cardinal.mk_le_of_injective hf - _ = Cardinal.mk ↥Rbar * Cardinal.mk ↥Rbar := (Cardinal.mul_def _ _).symm - _ ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) * - max Cardinal.aleph0 (Cardinal.mk R.carrier) := - mul_le_mul' hRbar_card hRbar_card - _ = max Cardinal.aleph0 (Cardinal.mk R.carrier) := - Cardinal.mul_eq_self (le_max_left _ _) + have hCard_S : Cardinal.mk S_sub ≤ max Cardinal.aleph0 (Cardinal.mk R.carrier) := + card_fractionSubring_le R x₁ x₂ y₁ y₂ hy₂ S_sub hS_sub_eq have hcard : Cardinal.mk S_sub ≤ max Cardinal.aleph0 (Cardinal.mk (IsLocalRing.ResidueField T)) := by calc Cardinal.mk S_sub @@ -1018,37 +982,7 @@ private def build_intersection_nsubring_proof hmax_eq hS_sub_eq hR_prime_div_Rbar card_le := hCard_S } -⟩ -omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -include T in theorem build_intersection_nsubring - (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (c : R.carrier) - (hc_eq : (↑c : T) = x₁ * ↑y₁ + x₂ * ↑y₂) - (hx₁_trans : Transcendental R.carrier x₁) - (hx₂_trans : Transcendental R.carrier x₂) - (hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) - (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) - (_hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (_hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (_hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) - (hx₁_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₂ : T) ∉ P → - ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → - ∀ (f : Polynomial R.carrier), - aeval x₁ f ∈ P → (C p : Polynomial R.carrier) ∣ f) - (hx₂_ker : ∀ (P : Ideal T), P.IsPrime → P ≠ ⊤ → P.height ≤ 1 → (↑y₁ : T) ∉ P → - ∀ (p : R.carrier), Prime p → (↑p : T) ∈ P → - ∀ (f : Polynomial R.carrier), - aeval x₂ f ∈ P → (C p : Polynomial R.carrier) ∣ f) : - ∃ S : NSubring T, IsAExtension R S ∧ x₁ ∈ S.carrier ∧ x₂ ∈ S.carrier := by - exact - (build_intersection_nsubring_proof - R x₁ x₂ y₁ y₂ c hc_eq hx₁_trans hx₂_trans hcoprime hy₁ hy₂ _hM_ne_bot hM_not_assoc - hAss_ht _hR_card _hT_card hx₁_ker hx₂_ker - ).down end MainTheorem end diff --git a/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean b/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean index bb9f076793..9910c5287d 100644 --- a/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean +++ b/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean @@ -309,7 +309,134 @@ include T in theorem intersection_close_up_ker_pf₂ exact hu_avoid P hP_C r₀ hr₀_D hu_coset omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -private def intersection_close_up_proof +/- Helper for `intersection_close_up`: a nonzero polynomial over `R` has finitely many +roots along an injective map `g : T → T`. -/ +private theorem intersection_close_up_root_preimage_finite (R : NSubring T) (g : T → T) + (hg : Function.Injective g) (f : Polynomial R.carrier) (hf : f ≠ 0) : + {u : T | (aeval (g u) f : T) = 0}.Finite := by + have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by + rw [Ne, ← Polynomial.map_zero R.carrier.subtype] + exact (Polynomial.map_injective R.carrier.subtype Subtype.val_injective).ne hf + rw [show {u : T | (aeval (g u) f : T) = 0} = + g ⁻¹' {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} from by + ext u + simp only [Set.mem_preimage, Set.mem_ofPred_eq, + Polynomial.IsRoot, Polynomial.eval_map, Polynomial.aeval_def, + show algebraMap R.carrier T = R.carrier.subtype from rfl]] + exact (Polynomial.finite_setOfPred_isRoot hmap_ne).preimage + (Set.InjOn.mono (Set.subset_univ _) hg.injOn) + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Helper for `intersection_close_up`: for a prime `P`, the chosen lifts of the roots of +`f mod P` along a map `g` (injective once multiplied by `b ≠ 0`) form a finite set. -/ +private theorem intersection_close_up_quotient_root_lift_finite (R : NSubring T) + (P : Ideal T) (hP : P.IsPrime) (f : Polynomial R.carrier) + (hmap_ne : Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f ≠ 0) + (b : T ⧸ P) (hb : b ≠ 0) (g : T ⧸ P → T ⧸ P) + (hg : ∀ v₁ v₂, g v₁ = g v₂ → v₁ * b = v₂ * b) : + ((Function.invFun (Ideal.Quotient.mk P)) '' + {v : T ⧸ P | (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).eval + (g v) = 0}).Finite := by + have : P.IsPrime := hP + have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P + have h_inj : Function.Injective g := fun v₁ v₂ h => mul_right_cancel₀ hb (hg v₁ v₂ h) + exact ((Polynomial.finite_setOfPred_isRoot hmap_ne).preimage + (Set.InjOn.mono (Set.subset_univ _) h_inj.injOn)).image _ + +omit [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] + [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Helper for `intersection_close_up`: a union of two sets of size at most an infinite +cardinal `κ` has size at most `κ`. -/ +private theorem intersection_close_up_union_card_le {κ : Cardinal} (hκ : ℵ₀ ≤ κ) + {A B : Set T} (hA : Cardinal.mk A ≤ κ) (hB : Cardinal.mk B ≤ κ) : + Cardinal.mk ↑(A ∪ B) ≤ κ := + (Cardinal.mk_union_le A B).trans ((add_le_add hA hB).trans (Cardinal.add_eq_self hκ).le) + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Helper for `intersection_close_up`: a union of sets indexed by the nonzero polynomials +over `R`, each of size at most `max |R| ℵ₀`, has size at most `max |R| ℵ₀`. -/ +private theorem intersection_close_up_polynomial_iUnion_card_le (R : NSubring T) + (F : Polynomial R.carrier → Set T) + (hF : ∀ f, f ≠ 0 → Cardinal.mk (F f) ≤ max (Cardinal.mk R.carrier) ℵ₀) : + Cardinal.mk ↑(⋃ (f : Polynomial R.carrier) (_ : f ≠ 0), F f) ≤ + max (Cardinal.mk R.carrier) ℵ₀ := by + have hκ : ℵ₀ ≤ max (Cardinal.mk R.carrier) ℵ₀ := le_max_right _ _ + refine (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' Polynomial.cardinalMk_le_max + (ciSup_le' fun f => ?_)).trans (Cardinal.mul_eq_self hκ).le) + by_cases hf : f = 0 + · simp [hf] + · exact (Cardinal.mk_le_mk_of_subset (Set.iUnion_subset fun _ => le_refl _)).trans (hF f hf) + +omit [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] + [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Helper for `intersection_close_up`: a union of countable sets indexed by a set of ideals +of size at most an infinite cardinal `κ` has size at most `κ`. -/ +private theorem intersection_close_up_ideal_biUnion_card_le {κ : Cardinal} (hκ : ℵ₀ ≤ κ) + {C : Set (Ideal T)} (hC : Cardinal.mk C ≤ κ) (E : Ideal T → Set T) + (hE : ∀ P ∈ C, (E P).Countable) : + Cardinal.mk ↑(⋃ P ∈ C, E P) ≤ κ := by + refine (Cardinal.mk_biUnion_le _ _).trans ((mul_le_mul' hC (ciSup_le' fun P => ?_)).trans + (Cardinal.mul_eq_self hκ).le) + exact (Cardinal.le_aleph0_iff_set_countable.mpr (hE P.1 P.2)).trans hκ + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Helper for `intersection_close_up`: the zero ideal together with all associated primes +of `T/(r)`, `r ∈ R` nonzero, form a set of size at most `max |R| ℵ₀`. -/ +private theorem intersection_close_up_associated_primes_card_le (R : NSubring T) : + Cardinal.mk ↑(({⊥} : Set (Ideal T)) ∪ ⋃ (r : R.carrier) (_ : (↑r : T) ≠ 0), + (associatedPrimes T (T ⧸ Ideal.span {(↑r : T)}))) ≤ + max (Cardinal.mk R.carrier) ℵ₀ := by + have hκ : ℵ₀ ≤ max (Cardinal.mk R.carrier) ℵ₀ := le_max_right _ _ + refine (Cardinal.mk_union_le _ _).trans ((add_le_add ?_ ?_).trans (Cardinal.add_eq_self hκ).le) + · exact (Cardinal.mk_le_one_iff_set_subsingleton.mpr Set.subsingleton_singleton).trans + (one_le_aleph0.trans hκ) + · refine (Cardinal.mk_iUnion_le _).trans ((mul_le_mul' (le_max_left _ _) + (ciSup_le' fun r => ?_)).trans (Cardinal.mul_eq_self hκ).le) + refine (Cardinal.mk_le_aleph0_iff.mpr ?_).trans hκ + by_cases hr : (r : T) = 0 + · exact Set.Countable.to_subtype (by simp [hr]) + · exact (Set.Finite.subset (associatedPrimes.finite T _) + (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +/- Helper for `intersection_close_up`: the cardinality hypothesis of `avoidance`, from +bounds `max |R| ℵ₀` on the primes `C` and the values `D` to avoid. -/ +private theorem intersection_close_up_avoidance_bound (R : NSubring T) + (C : Set (Ideal T)) (D : Set T) + (hC : Cardinal.mk C ≤ max (Cardinal.mk R.carrier) ℵ₀) + (hD : Cardinal.mk D ≤ max (Cardinal.mk R.carrier) ℵ₀) + (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) + (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : + Cardinal.mk (↑C × ↑D) < Cardinal.mk (IsLocalRing.ResidueField T) ∨ + (C.Countable ∧ D.Countable) := by + by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 + · -- R countable: use countable avoidance branch + right + rw [max_eq_right hR_le] at hC hD + exact ⟨Cardinal.le_aleph0_iff_set_countable.mp hC, + Cardinal.le_aleph0_iff_set_countable.mp hD⟩ + · -- R uncountable: |C × D| ≤ |R|² = |R| < |T| = |residue field| + left + push Not at hR_le + have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le + rw [max_eq_left hR_inf] at hC hD + calc Cardinal.mk (↑C × ↑D) + = Cardinal.mk C * Cardinal.mk D := (Cardinal.mul_def _ _).symm + _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC hD + _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf + _ < Cardinal.mk T := hR_card + _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + +/- Coprime close-up via Krull domain intersection (Heitmann Lemma 4). + +Given R an NSubring, y₁ y₂ ∈ R coprime non-units with (y₁:T) ≠ 0 and (y₂:T) ≠ 0, +and c ∈ (y₁,y₂)·T ∩ R, construct an A-extension S with c ∈ (y₁,y₂)·S. + +The construction: choose x₁ = t₁ + u·y₂ transcendental, set x₂ = t₂ - u·y₁, +build Rbar = R[x₁,y₂⁻¹] ∩ R[x₂,y₁⁻¹], localize at M to get S. +Then c = x₁·y₁ + x₂·y₂ ∈ (y₁,y₂)·S since x₁ ∈ A₁ ⊆ S, x₂ ∈ A₂ ⊆ S. -/ +include T in theorem + intersection_close_up (R : NSubring T) (y₁ y₂ : R.carrier) (c : R.carrier) (hc : (c : T) ∈ Ideal.span {(y₁ : T), (y₂ : T)}) (hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) @@ -321,10 +448,10 @@ private def intersection_close_up_proof ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : - PLift (∃ S : NSubring T, IsAExtension R S ∧ + ∃ S : NSubring T, IsAExtension R S ∧ ∃ (hle : R.carrier ≤ S.carrier) (x₁ : S.carrier), (⟨(c : T), hle c.2⟩ : S.carrier) - x₁ * ⟨(y₁ : T), hle y₁.2⟩ ∈ - Ideal.span {⟨(y₂ : T), hle y₂.2⟩}) := ⟨by + Ideal.span {⟨(y₂ : T), hle y₂.2⟩} := by have : IsDomain R.carrier := NSubring.isDomain R have : UniqueFactorizationMonoid R.carrier := R.isUFD -- Write c = t₁·y₁ + t₂·y₂ with t₁, t₂ ∈ T from the membership in (y₁,y₂)T @@ -338,59 +465,12 @@ private def intersection_close_up_proof simpa only [smul_eq_mul] using hc_eq.symm rw [hceq] ring - -- It suffices to find x₁, x₂ transcendental over R with c = x₁·y₁ + x₂·y₂ - suffices ∃ (x₁ x₂ : T), - (↑c : T) = x₁ * (↑y₁ : T) + x₂ * (↑y₂ : T) ∧ - x₁ ∈ adjoinLocSetY R x₁ y₂ ∧ - x₂ ∈ adjoinLocSetY R x₂ y₁ ∧ - Transcendental R.carrier x₁ ∧ - Transcendental R.carrier x₂ ∧ - (∃ S : NSubring T, IsAExtension R S ∧ - ∃ (hle : R.carrier ≤ S.carrier) (x₁' : S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) - x₁' * ⟨(y₁ : T), hle y₁.2⟩ ∈ - Ideal.span {⟨(y₂ : T), hle y₂.2⟩}) by - obtain ⟨_, _, _, _, _, _, _, hS⟩ := this - exact hS + -- We find u such that x₁ = t₁ + u·y₂ and x₂ = t₂ - u·y₁ are suitably transcendental over R -- D₁, D₂ = values of u making x₁ = t₁+u·y₂ or x₂ = t₂-u·y₁ algebraic over R set D₁ : Set T := ⋃ (f : Polynomial R.carrier) (_ : f ≠ 0), {u : T | (aeval (t₁ + u * (↑y₂ : T)) f : T) = 0} set D₂ : Set T := ⋃ (f : Polynomial R.carrier) (_ : f ≠ 0), {u : T | (aeval (t₂ - u * (↑y₁ : T)) f : T) = 0} - have hD₁_fiber_finite : ∀ (f : Polynomial R.carrier), f ≠ 0 → - {u : T | (aeval (t₁ + u * (↑y₂ : T)) f : T) = 0}.Finite := by - intro f hf - have h_inj : Function.Injective fun (u : T) => t₁ + u * (↑y₂ : T) := - fun u₁ u₂ h => mul_right_cancel₀ hy₂ (add_left_cancel h) - have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by - rw [Ne, ← Polynomial.map_zero R.carrier.subtype] - exact (Polynomial.map_injective R.carrier.subtype Subtype.val_injective).ne hf - rw [show {u : T | (aeval (t₁ + u * (↑y₂ : T)) f : T) = 0} = - (fun u => t₁ + u * (↑y₂ : T)) ⁻¹' - {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} from by - ext u - simp only [Set.mem_preimage, Set.mem_ofPred_eq, - Polynomial.IsRoot, Polynomial.eval_map, Polynomial.aeval_def, - show algebraMap R.carrier T = R.carrier.subtype from rfl]] - exact (Polynomial.finite_setOfPred_isRoot hmap_ne).preimage - (Set.InjOn.mono (Set.subset_univ _) h_inj.injOn) - have hD₂_fiber_finite : ∀ (f : Polynomial R.carrier), f ≠ 0 → - {u : T | (aeval (t₂ - u * (↑y₁ : T)) f : T) = 0}.Finite := by - intro f hf - have h_inj : Function.Injective fun (u : T) => t₂ - u * (↑y₁ : T) := by - intro u₁ u₂ h - exact mul_right_cancel₀ hy₁ (sub_right_inj.mp h) - have hmap_ne : Polynomial.map R.carrier.subtype f ≠ 0 := by - rw [Ne, ← Polynomial.map_zero R.carrier.subtype] - exact (Polynomial.map_injective R.carrier.subtype Subtype.val_injective).ne hf - rw [show {u : T | (aeval (t₂ - u * (↑y₁ : T)) f : T) = 0} = - (fun u => t₂ - u * (↑y₁ : T)) ⁻¹' - {x : T | (Polynomial.map R.carrier.subtype f).IsRoot x} from by - ext u - simp only [Set.mem_preimage, Set.mem_ofPred_eq, - Polynomial.IsRoot, Polynomial.eval_map, Polynomial.aeval_def, - show algebraMap R.carrier T = R.carrier.subtype from rfl]] - exact (Polynomial.finite_setOfPred_isRoot hmap_ne).preimage - (Set.InjOn.mono (Set.subset_univ _) h_inj.injOn) -- C_ext = {(0)} ∪ all associated primes of T/(r) for r ∈ R nonzero (the primes to avoid) set C_ext : Set (Ideal T) := {⊥} ∪ ⋃ (r : R.carrier) (_ : (↑r : T) ≠ 0), @@ -428,341 +508,43 @@ private def intersection_close_up_proof {v : T ⧸ P | (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).eval (Ideal.Quotient.mk P t₂ - v * Ideal.Quotient.mk P (↑y₁ : T)) = 0} set D_ext : Set T := D₁ ∪ D₂ ∪ D_mod₁ ∪ D_mod₂ - -- Finiteness of D_mod₁ fibers: fbar has finitely many roots in T/P (integral domain) - have hD_mod₁_fiber_finite : ∀ (f : Polynomial R.carrier) (_ : f ≠ 0) - (P : Ideal T) (_ : P ∈ C_ext) (_ : P ≠ ⊥) - (hmap_ne : Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f ≠ 0) - (hy₂_ne : Ideal.Quotient.mk P (↑y₂ : T) ≠ 0), - ((Function.invFun (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₁ + v * Ideal.Quotient.mk P (↑y₂ : T)) = 0}).Finite := by - intro f _ P hP hP_ne hmap_ne hy₂_ne - have : P.IsPrime := hC_ext_prime P hP - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - have h_inj : Function.Injective - fun (v : T ⧸ P) => Ideal.Quotient.mk P t₁ + v * Ideal.Quotient.mk P (↑y₂ : T) := by - intro v₁ v₂ h - exact mul_right_cancel₀ hy₂_ne (add_left_cancel h) - apply Set.Finite.image - exact (Polynomial.finite_setOfPred_isRoot hmap_ne).preimage - (Set.InjOn.mono (Set.subset_univ _) h_inj.injOn) - have hD_mod₂_fiber_finite : ∀ (f : Polynomial R.carrier) (_ : f ≠ 0) - (P : Ideal T) (_ : P ∈ C_ext) (_ : P ≠ ⊥) - (hmap_ne : Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f ≠ 0) - (hy₁_ne : Ideal.Quotient.mk P (↑y₁ : T) ≠ 0), - ((Function.invFun (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₂ - v * Ideal.Quotient.mk P (↑y₁ : T)) = 0}).Finite := by - intro f _ P hP hP_ne hmap_ne hy₁_ne - have : P.IsPrime := hC_ext_prime P hP - have : IsDomain (T ⧸ P) := Ideal.Quotient.isDomain P - have h_inj : Function.Injective - fun (v : T ⧸ P) => Ideal.Quotient.mk P t₂ - v * Ideal.Quotient.mk P (↑y₁ : T) := by - intro v₁ v₂ h - exact mul_right_cancel₀ hy₁_ne (sub_right_inj.mp h) - apply Set.Finite.image - exact (Polynomial.finite_setOfPred_isRoot hmap_ne).preimage - (Set.InjOn.mono (Set.subset_univ _) h_inj.injOn) - -- Cardinal bound for avoidance: |C_ext × D_ext| < |residue field| or both countable - have hCD_bound : Cardinal.mk (↑C_ext × ↑D_ext) < - Cardinal.mk (IsLocalRing.ResidueField T) ∨ - (C_ext.Countable ∧ D_ext.Countable) := by - by_cases hR_le : Cardinal.mk R.carrier ≤ Cardinal.aleph0 - · -- R countable: use countable avoidance branch - have : Countable R.carrier := Cardinal.mk_le_aleph0_iff.mp hR_le - have : Countable (Polynomial R.carrier) := - Countable.of_equiv _ ((Polynomial.toFinsuppIso R.carrier).toEquiv.trans - AddMonoidAlgebra.coeffEquiv).symm - -- C_ext is countable: countable union of finite associated prime sets - have hC_ext_countable : C_ext.Countable := by - apply Set.Countable.union (Set.countable_singleton _) - apply Set.countable_iUnion - intro r - apply Set.countable_iUnion - intro _ - exact (associatedPrimes.finite T _).countable - -- D₁ is a countable union of finite root sets - have hD₁_countable : D₁.Countable := by - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hf - exact (hD₁_fiber_finite f hf).countable - have hD₂_countable : D₂.Countable := by - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hf - exact (hD₂_fiber_finite f hf).countable - -- D_mod₁ countable: countable polynomials × countable primes × finite root sets - have hD_mod₁_countable : D_mod₁.Countable := by - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hf_ne - apply hC_ext_countable.biUnion - intro P hP - apply Set.countable_iUnion - intro hP_ne - apply Set.countable_iUnion - intro hmap_ne - apply Set.countable_iUnion - intro hy₂_ne - exact (hD_mod₁_fiber_finite f hf_ne P hP hP_ne hmap_ne hy₂_ne).countable - have hD_mod₂_countable : D_mod₂.Countable := by - apply Set.countable_iUnion - intro f - apply Set.countable_iUnion - intro hf_ne - apply hC_ext_countable.biUnion - intro P hP - apply Set.countable_iUnion - intro hP_ne - apply Set.countable_iUnion - intro hmap_ne - apply Set.countable_iUnion - intro hy₁_ne - exact (hD_mod₂_fiber_finite f hf_ne P hP hP_ne hmap_ne hy₁_ne).countable - right - exact ⟨hC_ext_countable, - ((hD₁_countable.union hD₂_countable).union hD_mod₁_countable).union hD_mod₂_countable⟩ - · -- R uncountable: |C_ext × D_ext| ≤ |R|² = |R| < |T| = |residue field| - left - push Not at hR_le - -- Key: |R| ≥ ℵ₀ allows infinite cardinal absorption (|R|·ℵ₀ = |R|² = |R|) - have hR_inf : Cardinal.aleph0 ≤ Cardinal.mk R.carrier := le_of_lt hR_le - -- |C_ext| ≤ |R|: it is {0} plus ≤ |R| associated primes, each finite - have hC_le : Cardinal.mk C_ext ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk C_ext - ≤ Cardinal.mk ↑({⊥} : Set (Ideal T)) + - Cardinal.mk ↑(⋃ (r : R.carrier) (_ : (↑r : T) ≠ 0), - associatedPrimes T (T ⧸ Ideal.span {(↑r : T)})) := - Cardinal.mk_union_le _ _ - _ ≤ 1 + Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Cardinal.mk_le_one_iff_set_subsingleton.mpr Set.subsingleton_singleton - · apply (Cardinal.mk_iUnion_le _).trans - gcongr - apply ciSup_le' - intro r - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hr : (r : T) = 0 - · exact Set.Countable.to_subtype (by simp [hr]) - · exact (Set.Finite.subset (associatedPrimes.finite T _) - (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype - _ = Cardinal.mk R.carrier := by - rw [Cardinal.mul_aleph0_eq hR_inf] - exact Cardinal.add_eq_right hR_inf (one_le_aleph0.trans hR_inf) - -- |D₁| ≤ |R|: union of |R[X]| = |R| polynomial fibers, each finite - have hD₁_le : Cardinal.mk D₁ ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D₁ - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), Cardinal.mk ↑(⋃ (_ : f ≠ 0), - {u : T | (aeval (t₁ + u * (↑y₂ : T)) f : T) = 0}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hf : f = 0 - · exact Set.Countable.to_subtype (by simp [hf]) - · exact (Set.Finite.subset (hD₁_fiber_finite f hf) - (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - have hD₂_le : Cardinal.mk D₂ ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D₂ - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), Cardinal.mk ↑(⋃ (_ : f ≠ 0), - {u : T | (aeval (t₂ - u * (↑y₁ : T)) f : T) = 0}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.aleph0 := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - apply Cardinal.mk_le_aleph0_iff.mpr - by_cases hf : f = 0 - · exact Set.Countable.to_subtype (by simp [hf]) - · exact (Set.Finite.subset (hD₂_fiber_finite f hf) - (Set.iUnion_subset fun _ => le_refl _)).countable.to_subtype - _ = Cardinal.mk R.carrier := Cardinal.mul_aleph0_eq hR_inf - -- |D_mod₁| ≤ |R|: indexed by |R[X]| × |C_ext|, each fiber finite, so ≤ |R|² = |R| - have hD_mod₁_le : Cardinal.mk D_mod₁ ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D_mod₁ - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), - Cardinal.mk ↑(⋃ (_ : f ≠ 0) - (P : Ideal T) (_ : P ∈ C_ext) (_ : P ≠ ⊥) - (_ : Polynomial.map - ((Ideal.Quotient.mk P).comp R.carrier.subtype) - f ≠ 0) - (_ : Ideal.Quotient.mk P (↑y₂ : T) ≠ 0), - (Function.invFun (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | - (Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₁ + - v * Ideal.Quotient.mk P (↑y₂ : T)) = - 0}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - by_cases hf : f = 0 - · simp [hf] - · -- inner for f ≠ 0: union over C_ext of finite sets - have : (⋃ (_ : f ≠ 0) - (P : Ideal T) (_ : P ∈ C_ext) - (_ : P ≠ ⊥) - (_ : Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f ≠ 0) - (_ : Ideal.Quotient.mk P (↑y₂ : T) ≠ 0), - (Function.invFun - (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | - (Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₁ + - v * Ideal.Quotient.mk P - (↑y₂ : T)) = 0}) ⊆ - ⋃ P ∈ C_ext, ⋃ (_ : P ≠ ⊥) - (_ : Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f ≠ 0) - (_ : Ideal.Quotient.mk P - (↑y₂ : T) ≠ 0), - (Function.invFun - (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | - (Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₁ + - v * Ideal.Quotient.mk P - (↑y₂ : T)) = 0} := - Set.iUnion_subset fun _ => le_refl _ - apply le_trans (Cardinal.mk_le_mk_of_subset this) - apply (Cardinal.mk_biUnion_le _ _).trans - apply le_trans (mul_le_mul' hC_le ?_) - · exact (Cardinal.mul_eq_self hR_inf).le - · apply ciSup_le' - intro ⟨P, hP⟩ - apply le_trans (Cardinal.mk_le_aleph0_iff.mpr _) hR_inf - apply Set.Countable.to_subtype - by_cases hP_ne : P = ⊥ - · simp [hP_ne] - · apply Set.countable_iUnion - intro _ - apply Set.countable_iUnion - intro hmap_ne - apply Set.countable_iUnion - intro hy₂_ne - exact (hD_mod₁_fiber_finite f hf P hP hP_ne hmap_ne hy₂_ne).countable - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - -- |D_mod₂| ≤ |R| by the same argument as D_mod₁ - have hD_mod₂_le : Cardinal.mk D_mod₂ ≤ Cardinal.mk R.carrier := by - calc Cardinal.mk D_mod₂ - ≤ Cardinal.mk (Polynomial R.carrier) * - ⨆ (f : Polynomial R.carrier), - Cardinal.mk ↑(⋃ (_ : f ≠ 0) - (P : Ideal T) (_ : P ∈ C_ext) - (_ : P ≠ ⊥) - (_ : Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f ≠ 0) - (_ : Ideal.Quotient.mk P - (↑y₁ : T) ≠ 0), - (Function.invFun - (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | - (Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₂ - - v * Ideal.Quotient.mk P - (↑y₁ : T)) = 0}) := - Cardinal.mk_iUnion_le _ - _ ≤ Cardinal.mk R.carrier * - Cardinal.mk R.carrier := by - gcongr - · exact Polynomial.cardinalMk_le_max.trans (max_le le_rfl hR_inf) - · apply ciSup_le' - intro f - by_cases hf : f = 0 - · simp [hf] - · have : (⋃ (_ : f ≠ 0) - (P : Ideal T) (_ : P ∈ C_ext) - (_ : P ≠ ⊥) - (_ : Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f ≠ 0) - (_ : Ideal.Quotient.mk P - (↑y₁ : T) ≠ 0), - (Function.invFun - (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | - (Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₂ - - v * Ideal.Quotient.mk P - (↑y₁ : T)) = 0}) ⊆ - ⋃ P ∈ C_ext, ⋃ (_ : P ≠ ⊥) - (_ : Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f ≠ 0) - (_ : Ideal.Quotient.mk P - (↑y₁ : T) ≠ 0), - (Function.invFun - (Ideal.Quotient.mk P)) '' - {v : T ⧸ P | - (Polynomial.map - ((Ideal.Quotient.mk P).comp - R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₂ - - v * Ideal.Quotient.mk P - (↑y₁ : T)) = 0} := - Set.iUnion_subset fun _ => le_refl _ - apply le_trans (Cardinal.mk_le_mk_of_subset this) - apply (Cardinal.mk_biUnion_le _ _).trans - apply le_trans (mul_le_mul' hC_le ?_) - · exact (Cardinal.mul_eq_self hR_inf).le - · apply ciSup_le' - intro ⟨P, hP⟩ - apply le_trans (Cardinal.mk_le_aleph0_iff.mpr _) hR_inf - apply Set.Countable.to_subtype - by_cases hP_ne : P = ⊥ - · simp [hP_ne] - · apply Set.countable_iUnion - intro _ - apply Set.countable_iUnion - intro hmap_ne - apply Set.countable_iUnion - intro hy₁_ne - exact (hD_mod₂_fiber_finite f hf P hP hP_ne hmap_ne hy₁_ne).countable - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - have hD_le : Cardinal.mk D_ext ≤ Cardinal.mk R.carrier := by - apply le_trans (Cardinal.mk_union_le _ _) - apply le_trans (add_le_add (Cardinal.mk_union_le _ _) hD_mod₂_le) - apply le_trans (add_le_add (add_le_add (Cardinal.mk_union_le _ _) hD_mod₁_le) le_rfl) - apply le_trans (add_le_add (add_le_add (add_le_add hD₁_le hD₂_le) le_rfl) le_rfl) - rw [Cardinal.add_eq_left hR_inf le_rfl, - Cardinal.add_eq_left hR_inf le_rfl, - Cardinal.add_eq_left hR_inf le_rfl] - -- Final chain: |C_ext × D_ext| ≤ |R|² = |R| < |T| = |k| - calc Cardinal.mk (↑C_ext × ↑D_ext) - = Cardinal.mk C_ext * Cardinal.mk D_ext := (Cardinal.mul_def _ _).symm - _ ≤ Cardinal.mk R.carrier * Cardinal.mk R.carrier := mul_le_mul' hC_le hD_le - _ = Cardinal.mk R.carrier := Cardinal.mul_eq_self hR_inf - _ < Cardinal.mk T := hR_card - _ = Cardinal.mk (IsLocalRing.ResidueField T) := hT_card + -- Cardinal bound for avoidance: C_ext and every piece of D_ext have size ≤ max |R| ℵ₀ + have hκ : ℵ₀ ≤ max (Cardinal.mk R.carrier) ℵ₀ := le_max_right _ _ + have hfin_le : ∀ s : Set T, s.Finite → Cardinal.mk s ≤ max (Cardinal.mk R.carrier) ℵ₀ := + fun s hs => (Cardinal.le_aleph0_iff_set_countable.mpr hs.countable).trans hκ + have hC_le : Cardinal.mk C_ext ≤ max (Cardinal.mk R.carrier) ℵ₀ := + intersection_close_up_associated_primes_card_le R + -- D₁, D₂: unions over |R[X]| ≤ max |R| ℵ₀ polynomials of finite root sets + have hD₁_le : Cardinal.mk D₁ ≤ max (Cardinal.mk R.carrier) ℵ₀ := + intersection_close_up_polynomial_iUnion_card_le R _ fun f hf => hfin_le _ + (intersection_close_up_root_preimage_finite R (fun u => t₁ + u * (↑y₂ : T)) + (fun _ _ h => mul_right_cancel₀ hy₂ (add_left_cancel h)) f hf) + have hD₂_le : Cardinal.mk D₂ ≤ max (Cardinal.mk R.carrier) ℵ₀ := + intersection_close_up_polynomial_iUnion_card_le R _ fun f hf => hfin_le _ + (intersection_close_up_root_preimage_finite R (fun u => t₂ - u * (↑y₁ : T)) + (fun _ _ h => mul_right_cancel₀ hy₁ (sub_right_inj.mp h)) f hf) + -- D_mod₁, D_mod₂: indexed by R[X] × C_ext, each fiber finite (fbar has finitely many roots) + have hD_mod₁_le : Cardinal.mk D_mod₁ ≤ max (Cardinal.mk R.carrier) ℵ₀ := + intersection_close_up_polynomial_iUnion_card_le R _ fun f _ => + intersection_close_up_ideal_biUnion_card_le hκ hC_le _ fun P hP => + Set.countable_iUnion fun _ => Set.countable_iUnion fun hmap_ne => + Set.countable_iUnion fun hy₂_ne => + (intersection_close_up_quotient_root_lift_finite R P (hC_ext_prime P hP) f hmap_ne + _ hy₂_ne (fun v => Ideal.Quotient.mk P t₁ + v * Ideal.Quotient.mk P (↑y₂ : T)) + fun _ _ h => add_left_cancel h).countable + have hD_mod₂_le : Cardinal.mk D_mod₂ ≤ max (Cardinal.mk R.carrier) ℵ₀ := + intersection_close_up_polynomial_iUnion_card_le R _ fun f _ => + intersection_close_up_ideal_biUnion_card_le hκ hC_le _ fun P hP => + Set.countable_iUnion fun _ => Set.countable_iUnion fun hmap_ne => + Set.countable_iUnion fun hy₁_ne => + (intersection_close_up_quotient_root_lift_finite R P (hC_ext_prime P hP) f hmap_ne + _ hy₁_ne (fun v => Ideal.Quotient.mk P t₂ - v * Ideal.Quotient.mk P (↑y₁ : T)) + fun _ _ h => sub_right_inj.mp h).countable + have hD_le : Cardinal.mk D_ext ≤ max (Cardinal.mk R.carrier) ℵ₀ := + intersection_close_up_union_card_le hκ (intersection_close_up_union_card_le hκ + (intersection_close_up_union_card_le hκ hD₁_le hD₂_le) hD_mod₁_le) hD_mod₂_le + have hCD_bound := intersection_close_up_avoidance_bound R C_ext D_ext hC_le hD_le + hR_card hT_card -- Apply prime avoidance to obtain u ∉ ⋃ (P + {r}) for all P ∈ C_ext, r ∈ D_ext obtain ⟨u, _, hu_avoid⟩ := avoidance hC_ext_prime hC_ext_ne_M (D := D_ext) hCD_bound (I := ⊤) @@ -789,42 +571,23 @@ private def intersection_close_up_proof ∀ P, P ∈ associatedPrimes T (T ⧸ Ideal.span {(↑p : T)}) → P ∈ C_ext := fun p hp_ne P hP_ass => Set.mem_union_right _ (Set.mem_iUnion.mpr ⟨p, Set.mem_iUnion.mpr ⟨hp_ne, hP_ass⟩⟩) - have hD_ext_invFun₁ : ∀ (f : Polynomial R.carrier), f ≠ 0 → - ∀ (P : Ideal T), P ∈ C_ext → P ≠ ⊥ → - Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f ≠ 0 → - Ideal.Quotient.mk P (↑y₂ : T) ≠ 0 → - ∀ v₀, v₀ ∈ {v : T ⧸ P | - (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₁ + v * Ideal.Quotient.mk P (↑y₂ : T)) = 0} → - Function.invFun (Ideal.Quotient.mk P) v₀ ∈ D_ext := - fun f hf_ne P hPC hPne hmap_ne hy₂_ne v₀ hv₀ => + -- Kernel proofs: for each height-≤-1 prime P, if p ∈ P is prime in R then C(p) | f + have hx₁_ker_pf := intersection_close_up_ker_pf₁ R y₂ t₁ u C_ext D_ext hC_ext_mem + (fun f hf_ne P hPC hPne hmap_ne hy₂_ne v₀ hv₀ => Set.mem_union_left _ (Set.mem_union_right _ (Set.mem_iUnion.mpr ⟨f, Set.mem_iUnion.mpr ⟨hf_ne, Set.mem_iUnion.mpr ⟨P, Set.mem_iUnion.mpr ⟨hPC, Set.mem_iUnion.mpr ⟨hPne, Set.mem_iUnion.mpr ⟨hmap_ne, - Set.mem_iUnion.mpr ⟨hy₂_ne, ⟨v₀, hv₀, rfl⟩⟩⟩⟩⟩⟩⟩⟩)) - have hD_ext_invFun₂ : ∀ (f : Polynomial R.carrier), f ≠ 0 → - ∀ (P : Ideal T), P ∈ C_ext → P ≠ ⊥ → - Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f ≠ 0 → - Ideal.Quotient.mk P (↑y₁ : T) ≠ 0 → - ∀ v₀, v₀ ∈ {v : T ⧸ P | - (Polynomial.map ((Ideal.Quotient.mk P).comp R.carrier.subtype) f).eval - (Ideal.Quotient.mk P t₂ - v * Ideal.Quotient.mk P (↑y₁ : T)) = 0} → - Function.invFun (Ideal.Quotient.mk P) v₀ ∈ D_ext := - fun f hf_ne P hPC hPne hmap_ne hy₁_ne v₀ hv₀ => + Set.mem_iUnion.mpr ⟨hy₂_ne, ⟨v₀, hv₀, rfl⟩⟩⟩⟩⟩⟩⟩⟩))) + hu_avoid + have hx₂_ker_pf := intersection_close_up_ker_pf₂ R y₁ t₂ u C_ext D_ext hC_ext_mem + (fun f hf_ne P hPC hPne hmap_ne hy₁_ne v₀ hv₀ => Set.mem_union_right _ (Set.mem_iUnion.mpr ⟨f, Set.mem_iUnion.mpr ⟨hf_ne, Set.mem_iUnion.mpr ⟨P, Set.mem_iUnion.mpr ⟨hPC, Set.mem_iUnion.mpr ⟨hPne, Set.mem_iUnion.mpr ⟨hmap_ne, - Set.mem_iUnion.mpr ⟨hy₁_ne, ⟨v₀, hv₀, rfl⟩⟩⟩⟩⟩⟩⟩⟩) - -- Kernel proofs: for each height-≤-1 prime P, if p ∈ P is prime in R then C(p) | f - have hx₁_ker_pf := intersection_close_up_ker_pf₁ R y₂ t₁ u - C_ext D_ext hC_ext_mem hD_ext_invFun₁ hu_avoid - have hx₂_ker_pf := intersection_close_up_ker_pf₂ R y₁ t₂ u - C_ext D_ext hC_ext_mem hD_ext_invFun₂ hu_avoid - refine ⟨t₁ + u * ↑y₂, t₂ - u * ↑y₁, halg u, - x_mem_adjoinLocSetY R _ y₂, x_mem_adjoinLocSetY R _ y₁, - hx₁_trans, hx₂_trans, ?_⟩ + Set.mem_iUnion.mpr ⟨hy₁_ne, ⟨v₀, hv₀, rfl⟩⟩⟩⟩⟩⟩⟩⟩)) + hu_avoid -- Build Rbar = R[x₁,y₂⁻¹] ∩ R[x₂,y₁⁻¹] and localize at M to get the A-extension S obtain ⟨S, hAext, hx₁_mem, hx₂_mem⟩ := build_intersection_nsubring R (t₁ + u * ↑y₂) (t₂ - u * ↑y₁) y₁ y₂ c (halg u) @@ -835,37 +598,6 @@ private def intersection_close_up_proof exact ⟨S, hAext, hAext.le, ⟨_, hx₁_mem⟩, Ideal.mem_span_singleton.mpr ⟨⟨_, hx₂_mem⟩, Subtype.ext (show (↑c : T) - (t₁ + u * ↑y₂) * ↑y₁ = ↑y₂ * (t₂ - u * ↑y₁) from by linear_combination halg u)⟩⟩ -⟩ - -/- Coprime close-up via Krull domain intersection (Heitmann Lemma 4). - -Given R an NSubring, y₁ y₂ ∈ R coprime non-units with (y₁:T) ≠ 0 and (y₂:T) ≠ 0, -and c ∈ (y₁,y₂)·T ∩ R, construct an A-extension S with c ∈ (y₁,y₂)·S. - -The construction: choose x₁ = t₁ + u·y₂ transcendental, set x₂ = t₂ - u·y₁, -build Rbar = R[x₁,y₂⁻¹] ∩ R[x₂,y₁⁻¹], localize at M to get S. -Then c = x₁·y₁ + x₂·y₂ ∈ (y₁,y₂)·S since x₁ ∈ A₁ ⊆ S, x₂ ∈ A₂ ⊆ S. -/ -include T in theorem - intersection_close_up - (R : NSubring T) (y₁ y₂ : R.carrier) (c : R.carrier) - (hc : (c : T) ∈ Ideal.span {(y₁ : T), (y₂ : T)}) - (hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) - (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) - (hM_ne_bot : IsLocalRing.maximalIdeal T ≠ ⊥) - (hM_not_assoc : ∀ (r : T), r ≠ 0 → - IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) - (hAss_ht : ∀ (r : T), r ≠ 0 → - ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) - (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) - (hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) : - ∃ S : NSubring T, IsAExtension R S ∧ - ∃ (hle : R.carrier ≤ S.carrier) (x₁ : S.carrier), - (⟨(c : T), hle c.2⟩ : S.carrier) - x₁ * ⟨(y₁ : T), hle y₁.2⟩ ∈ - Ideal.span {⟨(y₂ : T), hle y₂.2⟩} := by - exact - (intersection_close_up_proof - R y₁ y₂ c hc hcoprime hy₁ hy₂ hM_ne_bot hM_not_assoc hAss_ht hR_card hT_card - ).down end MainTheorem diff --git a/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean b/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean index 38643cc882..f22e946db8 100644 --- a/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean +++ b/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean @@ -161,7 +161,70 @@ include T in theorem build_R_prime_in_S omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -private def build_loc_away_ufd_proof +/- Helper for `build_loc_away_ufd`: polynomial expressions over `R` in an element `x₁` of +`S_sub ⊇ R` stay in `S_sub`. -/ +private theorem build_loc_away_ufd_aeval_mem (R : NSubring T) (x₁ : T) (S_sub : Subring T) + (hR_le : R.carrier ≤ S_sub) (hx₁_S : x₁ ∈ S_sub) (f : Polynomial R.carrier) : + (aeval x₁ f : T) ∈ S_sub := by + induction f using Polynomial.induction_on' with + | add f g hf hg => + rw [map_add] + exact S_sub.add_mem hf hg + | monomial n a => + rw [Polynomial.aeval_monomial] + simp only [ + show algebraMap R.carrier T = + R.carrier.subtype from rfl, + Subring.coe_subtype] + exact S_sub.mul_mem (hR_le a.property) + (S_sub.pow_mem hx₁_S n) + +/- Helper for `build_loc_away_ufd`: elements sent to units by an injective ring hom are +non-zero-divisors. -/ +private theorem build_loc_away_ufd_le_nonZeroDivisors {A B : Type*} [CommRing A] [CommRing B] + (φ : A →+* B) (hφ_inj : Function.Injective φ) (M : Submonoid A) + (hM : ∀ f ∈ M, IsUnit (φ f)) : M ≤ nonZeroDivisors A := by + intro f hf + have hφf_unit : IsUnit (φ f) := hM f hf + refine ⟨fun g hfg => ?_, fun g hgf => ?_⟩ + · have h1 : φ f * φ g = 0 := by + rw [← map_mul, hfg, map_zero] + have : φ g = 0 := hφf_unit.mul_right_eq_zero.mp h1 + exact hφ_inj (by rw [this, map_zero]) + · have h1 : φ g * φ f = 0 := by + rw [← map_mul, hgf, map_zero] + have : φ g = 0 := hφf_unit.mul_left_eq_zero.mp h1 + exact hφ_inj (by rw [this, map_zero]) + +/- Helper for `build_loc_away_ufd`: clearing the denominator `s ^ nn` of `z` in the +localization away from `s`. -/ +private theorem build_loc_away_ufd_mul_eq {S : Type*} [CommRing S] (s : S) + (z : Localization.Away s) (w m a : S) (nn : ℕ) + (hz : z * algebraMap S (Localization.Away s) s ^ nn = + algebraMap S (Localization.Away s) w) + (hkey : w * m = a * s ^ nn) : + z * algebraMap S (Localization.Away s) m = algebraMap S (Localization.Away s) a := by + let A := algebraMap S (Localization.Away s) + have hs_pow_unit : + IsUnit (A (s ^ nn)) := by + rw [map_pow] + exact IsUnit.pow nn + (IsLocalization.Away.algebraMap_isUnit + (S := Localization.Away s) (x := s)) + have hz' : z * A (s ^ nn) = A w := by + show z * A (s ^ nn) = A w + rw [map_pow] + exact hz + apply hs_pow_unit.mul_right_cancel + calc z * A m * A (s ^ nn) + = z * A (s ^ nn) * A m := by ring + _ = A w * A m := by rw [hz'] + _ = A (w * m) := (map_mul A _ _).symm + _ = A (a * s ^ nn) := by rw [hkey] + _ = A a * A (s ^ nn) := map_mul A _ _ + +omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in +include T in theorem build_loc_away_ufd (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) [IsDomain S_sub] (hR_le : R.carrier ≤ S_sub) @@ -174,11 +237,11 @@ private def build_loc_away_ufd_proof b ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) (hRbar_le_S : ∀ t, t ∈ intersectionSet R x₁ x₂ y₁ y₂ → t ∈ (S_sub : Set T)) - (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) : PLift ( + (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) : UniqueFactorizationMonoid (Localization.Away (Subring.inclusion hR_le y₁ * - Subring.inclusion hR_le y₂)) ) := ⟨by + Subring.inclusion hR_le y₂)) := by have : IsDomain R.carrier := NSubring.isDomain R have : UniqueFactorizationMonoid R.carrier := R.isUFD set Rbar := intersectionSet R x₁ x₂ y₁ y₂ @@ -210,20 +273,8 @@ private def build_loc_away_ufd_proof IsLocalization.injective (Localization.Away s) hpow_le have haeval_S : ∀ f : Polynomial R.carrier, - (aeval x₁ f : T) ∈ S_sub := by - intro f - induction f using Polynomial.induction_on' with - | add f g hf hg => - rw [map_add] - exact S_sub.add_mem hf hg - | monomial n a => - rw [Polynomial.aeval_monomial] - simp only [ - show algebraMap R.carrier T = - R.carrier.subtype from rfl, - Subring.coe_subtype] - exact S_sub.mul_mem (hR_le a.property) - (S_sub.pow_mem hx₁_S n) + (aeval x₁ f : T) ∈ S_sub := + build_loc_away_ufd_aeval_mem R x₁ S_sub hR_le hx₁_S let evalS : Polynomial R.carrier →+* S_sub := RingHom.codRestrict (aeval (R := R.carrier) (A := T) x₁).toRingHom @@ -273,23 +324,8 @@ private def build_loc_away_ufd_proof rw [map_mul] exact ha.mul hb } have hM_le : - M ≤ nonZeroDivisors (Polynomial R.carrier) := by - intro f hf - have hφf_unit : IsUnit (φ f) := hf - have hφf_ne : φ f ≠ 0 := hφf_unit.ne_zero - refine ⟨fun g hfg => ?_, fun g hgf => ?_⟩ - · have h1 : φ f * φ g = 0 := by - rw [← map_mul, hfg, map_zero] - have : φ g = 0 := - Or.resolve_left (mul_eq_zero.mp h1) - hφf_ne - exact hφ_inj (by rw [this, map_zero]) - · have h1 : φ g * φ f = 0 := by - rw [← map_mul, hgf, map_zero] - have : φ g = 0 := - Or.resolve_right (mul_eq_zero.mp h1) - hφf_ne - exact hφ_inj (by rw [this, map_zero]) + M ≤ nonZeroDivisors (Polynomial R.carrier) := + build_loc_away_ufd_le_nonZeroDivisors φ hφ_inj M fun _ hf => hf have : IsLocalization M (Localization.Away s) := by rw [isLocalization_iff] refine ⟨fun ⟨f, hf⟩ => hf, @@ -335,34 +371,8 @@ private def build_loc_away_ufd_proof A |>.mul (hy₂_unit.pow jw))).mul (hy₂_unit.pow kw) refine ⟨⟨a_poly, ⟨m_poly, hm_mem⟩⟩, ?_⟩ - change z * φ m_poly = φ a_poly - suffices hkey : - w * evalS m_poly = - evalS a_poly * s ^ nn by - have hs_pow_unit : - IsUnit (A (s ^ nn)) := by - rw [map_pow] - exact IsUnit.pow nn - (IsLocalization.Away.algebraMap_isUnit - (S := Localization.Away s) (x := s)) - change z * A (evalS m_poly) = - A (evalS a_poly) - have hz' : z * A (s ^ nn) = A w := by - show z * A (s ^ nn) = A w - rw [map_pow] - exact hz - apply hs_pow_unit.mul_right_cancel - calc z * A (evalS m_poly) * A (s ^ nn) - = z * A (s ^ nn) * - A (evalS m_poly) := by ring - _ = A w * A (evalS m_poly) := by - rw [hz'] - _ = A (w * evalS m_poly) := - (map_mul A _ _).symm - _ = A (evalS a_poly * s ^ nn) := by - rw [hkey] - _ = A (evalS a_poly) * - A (s ^ nn) := map_mul A _ _ + change z * A (evalS m_poly) = A (evalS a_poly) + refine build_loc_away_ufd_mul_eq s z w _ _ nn hz ?_ apply Subtype.ext simp only [Subring.coe_mul, SubmonoidClass.coe_pow] @@ -395,34 +405,128 @@ private def build_loc_away_ufd_proof (↑y₂ : T) ^ kw * hw_eq · exact ⟨1, by rw [hφ_inj hab]⟩ exact localization_submonoid_UFD hM_le -⟩ + +/- Helper for `build_ufd_proof`: divisibility in the localization away from `s` descends +to divisibility up to a power of `s`. -/ +private theorem build_ufd_dvd_mul_pow_of_dvd {S : Type*} [CommRing S] (s : S) + (hinj_loc : Function.Injective (algebraMap S (Localization.Away s))) (r x : S) + (hqx : algebraMap S (Localization.Away s) r ∣ algebraMap S _ x) : + ∃ m : ℕ, r ∣ x * s ^ m := by + obtain ⟨z, hz⟩ := hqx + obtain ⟨⟨c, ⟨_, m, rfl⟩⟩, hc⟩ := + IsLocalization.surj (Submonoid.powers s) z + have key : x * s ^ m = r * c := by + apply hinj_loc + rw [map_mul, map_mul, map_pow] + calc algebraMap S _ x * (algebraMap S _ s) ^ m + = algebraMap S _ r * (z * (algebraMap S _ s) ^ m) := by + rw [hz, mul_assoc] + _ = algebraMap S _ r * algebraMap S _ c := by rw [← map_pow, hc] + exact ⟨m, c, key⟩ + +/- Helper for `build_ufd_proof`: an element that is prime in the localization away from `s` +is prime, provided it is a nonzero nonunit and powers of `s` can be cancelled from its +multiples. -/ +private theorem build_ufd_prime_of_prime_away {S : Type*} [CommRing S] (s : S) + (hinj_loc : Function.Injective (algebraMap S (Localization.Away s))) (r : S) + (hr_ne : r ≠ 0) (hr_not_unit : ¬IsUnit r) + (hr_prime_loc : Prime (algebraMap S (Localization.Away s) r)) + (hcancel : ∀ (x : S) (m : ℕ), r ∣ x * s ^ m → r ∣ x) : Prime r := by + have hdvd_back : ∀ (x : S), + (algebraMap S (Localization.Away s) r ∣ algebraMap S _ x) → r ∣ x := by + intro x hqx + obtain ⟨m, hm⟩ := build_ufd_dvd_mul_pow_of_dvd s hinj_loc r x hqx + exact hcancel x m hm + refine ⟨hr_ne, hr_not_unit, fun a b hab => ?_⟩ + have hab_loc : algebraMap S (Localization.Away s) r ∣ + algebraMap S _ a * algebraMap S _ b := by + rw [← map_mul] + exact map_dvd _ hab + exact (hr_prime_loc.dvd_or_dvd hab_loc).imp (hdvd_back a) (hdvd_back b) + +/- Helper for `build_ufd_proof`: inductive stripping, removing all prime factors `ι p`, +`p ∈ ps`, from an element of `P` while preserving membership in `P`. -/ +private theorem build_ufd_strip_prime_factors {A S : Type*} [CommRing S] [WfDvdMonoid S] + (ι : A → S) (P : Ideal S) (hP_prime : P.IsPrime) (ps : List A) : + ∀ (a : S), a ≠ 0 → a ∈ P → + (∀ p ∈ ps, (Prime (ι p) ∧ ι p ∉ P) ∨ IsUnit (ι p)) → + ∃ (a' : S) (d : S), + a = d * a' ∧ a' ∈ P ∧ a' ≠ 0 ∧ + (∀ p ∈ ps, Prime (ι p) → ¬(ι p ∣ a')) := by + induction ps with + | nil => + intro a ha_ne ha_P _ + exact ⟨a, 1, by ring, ha_P, ha_ne, fun _ h _ => absurd h List.not_mem_nil⟩ + | cons q qs ih => + intro a ha_ne ha_P hclass + have hqs_class : ∀ p ∈ qs, (Prime (ι p) ∧ ι p ∉ P) ∨ IsUnit (ι p) := + fun p hp => hclass p (List.mem_cons_of_mem q hp) + rcases hclass q List.mem_cons_self with ⟨hq_prime, hq_avoid⟩ | hq_unit + · obtain ⟨kq, a₁, hq_ndvd_a₁, ha_eq⟩ := + WfDvdMonoid.max_power_factor' ha_ne hq_prime.not_isUnit + have ha₁_P : a₁ ∈ P := by + rw [ha_eq] at ha_P + exact (hP_prime.mem_or_mem ha_P).resolve_left + (fun h => hq_avoid (hP_prime.mem_of_pow_mem kq h)) + have ha₁_ne : a₁ ≠ 0 := right_ne_zero_of_mul (ha_eq ▸ ha_ne) + obtain ⟨a', d', ha₁_eq, ha'_P, ha'_ne, ha'_ndvd⟩ := + ih a₁ ha₁_ne ha₁_P hqs_class + refine ⟨a', (ι q) ^ kq * d', ?_, ha'_P, ha'_ne, ?_⟩ + · rw [ha_eq, ha₁_eq] + ring + · intro p hp hp_prime + rcases List.mem_cons.mp hp with rfl | hp' + · intro h + exact hq_ndvd_a₁ (dvd_trans h (Dvd.intro_left d' ha₁_eq.symm)) + · exact ha'_ndvd p hp' hp_prime + · obtain ⟨a', d', ha_eq, ha'_P, ha'_ne, ha'_ndvd⟩ := + ih a ha_ne ha_P hqs_class + refine ⟨a', d', ha_eq, ha'_P, ha'_ne, ?_⟩ + intro p hp hp_prime + rcases List.mem_cons.mp hp with rfl | hp' + · exact absurd hq_unit hp_prime.not_isUnit + · exact ha'_ndvd p hp' hp_prime + +/- Helper for `build_ufd_proof`: if `r' ∣ a * (∏ ι p)^m` and no prime `ι p` divides `r'`, +then `r' ∣ a`. -/ +private theorem build_ufd_dvd_of_dvd_mul_prod_pow {A S : Type*} [CommRing S] [IsDomain S] + (ι : A → S) (P : Ideal S) (r' : S) (m : ℕ) (ps : List A) : + ∀ (a : S), + (∀ p ∈ ps, (Prime (ι p) ∧ ι p ∉ P) ∨ IsUnit (ι p)) → + (∀ p ∈ ps, Prime (ι p) → ¬(ι p ∣ r')) → + r' ∣ a * (ps.map ι).prod ^ m → r' ∣ a := by + induction ps with + | nil => intro a _ _ h + simpa using h + | cons p ps ih => + intro a hclass hndvd h + have hclass' := fun q hq => hclass q (List.mem_cons_of_mem p hq) + have hndvd' := fun q hq => hndvd q (List.mem_cons_of_mem p hq) + simp only [List.map_cons, List.prod_cons] at h + rcases hclass p List.mem_cons_self with ⟨hp_prime, _⟩ | hp_unit + · have hp_ndvd := hndvd p List.mem_cons_self hp_prime + have h1 : r' ∣ (a * (ps.map ι).prod ^ m) * (ι p) ^ m := by + rwa [show a * (ι p * (List.map ι ps).prod) ^ m = + (a * (List.map ι ps).prod ^ m) * (ι p) ^ m from by + rw [mul_pow] + ring] at h + have h2 : r' ∣ a * (ps.map ι).prod ^ m := + dvd_of_dvd_mul_prime_pow hp_prime hp_ndvd m h1 + exact ih a hclass' hndvd' h2 + · have hpm_unit : IsUnit ((ι p) ^ m) := hp_unit.pow m + have h1 : r' ∣ (a * (ι p) ^ m) * (ps.map ι).prod ^ m := by + rwa [show a * (ι p * (List.map ι ps).prod) ^ m = + (a * (ι p) ^ m) * (List.map ι ps).prod ^ m from by + rw [mul_pow] + ring] at h + have h2 : r' ∣ a * (ι p) ^ m := + ih (a * (ι p) ^ m) hclass' hndvd' h1 + exact (hpm_unit.dvd_mul_right).mp h2 omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -include T in theorem build_loc_away_ufd - (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) - (S_sub : Subring T) [IsDomain S_sub] - (hR_le : R.carrier ≤ S_sub) - (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) - (hx₁_trans : Transcendental R.carrier x₁) - (hinv : ∀ (s : S_sub), (s : T) ∉ IsLocalRing.maximalIdeal T → IsUnit s) - (hS_sub_eq : (S_sub : Set T) = - {t : T | ∃ (a : T) (b : T), - a ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ - b ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ - b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) - (hRbar_le_S : ∀ t, t ∈ intersectionSet R x₁ x₂ y₁ y₂ → t ∈ (S_sub : Set T)) - (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) : - UniqueFactorizationMonoid - (Localization.Away - (Subring.inclusion hR_le y₁ * - Subring.inclusion hR_le y₂)) := by - exact - (build_loc_away_ufd_proof - R x₁ x₂ y₁ y₂ S_sub hR_le hy₁ hy₂ hx₁_trans hinv hS_sub_eq hRbar_le_S hx₁_Rbar - ).down -/-- S_sub is a UFD via Kaplansky criterion. Uses the intersection construction +/- S_sub is a UFD via Kaplansky criterion. Uses the intersection construction and Nagata-type arguments for the P∩R = ⊥ case. -/ -private def build_ufd_proof_proof +include T in theorem build_ufd_proof (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) [IsDomain S_sub] [WfDvdMonoid S_sub] (hR_le : R.carrier ≤ S_sub) @@ -447,8 +551,8 @@ private def build_ufd_proof_proof b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) (hRbar_le_S : ∀ t, t ∈ intersectionSet R x₁ x₂ y₁ y₂ → t ∈ (S_sub : Set T)) (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) - (_hx₂_Rbar : x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂) : PLift ( - UniqueFactorizationMonoid S_sub ) := ⟨by + (_hx₂_Rbar : x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂) : + UniqueFactorizationMonoid S_sub := by have : IsDomain R.carrier := NSubring.isDomain R have : UniqueFactorizationMonoid R.carrier := R.isUFD rw [UniqueFactorizationMonoid.iff_exists_prime_mem_of_isPrime] @@ -534,30 +638,9 @@ private def build_ufd_proof_proof IsUnit.pow _ (IsLocalization.Away.algebraMap_isUnit s) exact hq'_eq ▸ associated_mul_unit_left _ _ hpn_unit exact hassoc.prime_iff.mpr hq'_prime - have hdvd_back : ∀ (x : S_sub), - (algebraMap S_sub (Localization.Away s) r ∣ algebraMap S_sub _ x) → - r ∣ x := by - intro x hqx - obtain ⟨z, hz⟩ := hqx - obtain ⟨⟨c, ⟨_, m, rfl⟩⟩, hc⟩ := - IsLocalization.surj (Submonoid.powers s) z - have key : x * s ^ m = r * c := by - apply hinj_loc - rw [map_mul, map_mul, map_pow] - calc algebraMap S_sub _ x * (algebraMap S_sub _ s) ^ m - = algebraMap S_sub _ r * (z * (algebraMap S_sub _ s) ^ m) := by - rw [hz, mul_assoc] - _ = algebraMap S_sub _ r * algebraMap S_sub _ c := by rw [← map_pow, hc] - have hsm_unit : IsUnit (s ^ m) := IsUnit.pow m hs_unit - have : r ∣ x * s ^ m := ⟨c, key⟩ - exact (hsm_unit.dvd_mul_right).mp this - have hr_prime : Prime r := by - refine ⟨hr_ne, hr_not_unit, fun a b hab => ?_⟩ - have hab_loc : algebraMap S_sub (Localization.Away s) r ∣ - algebraMap S_sub _ a * algebraMap S_sub _ b := by - rw [← map_mul] - exact map_dvd _ hab - exact (hr_prime_loc.dvd_or_dvd hab_loc).imp (hdvd_back a) (hdvd_back b) + have hr_prime : Prime r := + build_ufd_prime_of_prime_away s hinj_loc r hr_ne hr_not_unit hr_prime_loc + fun x m h => (IsUnit.pow m hs_unit).dvd_mul_right.mp h exact ⟨r, hr_in_P, hr_prime⟩ -- Case s is not a unit: factor y₁y₂ into primes in R and strip those factors from r · have hy₁y₂_ne : y₁ * y₂ ≠ (0 : R.carrier) := mul_ne_zero hy₁_ne hy₂_ne @@ -584,50 +667,9 @@ private def build_ufd_proof_proof exact ⟨hR_prime_in_S p hp_prime hpM, hR_avoids_P p hp_prime.ne_zero⟩ · right exact hinv (ι p) hpM - -- Inductive stripping: remove all prime factors of s from r, preserving membership in P - have fold_strip : ∀ (ps : List R.carrier) (a : S_sub), - a ≠ 0 → a ∈ P → - (∀ p ∈ ps, (Prime (ι p) ∧ ι p ∉ P) ∨ IsUnit (ι p)) → - ∃ (a' : S_sub) (d : S_sub), - a = d * a' ∧ a' ∈ P ∧ a' ≠ 0 ∧ - (∀ p ∈ ps, Prime (ι p) → ¬(ι p ∣ a')) := by - intro ps - induction ps with - | nil => - intro a ha_ne ha_P _ - exact ⟨a, 1, by ring, ha_P, ha_ne, fun _ h _ => absurd h List.not_mem_nil⟩ - | cons q qs ih => - intro a ha_ne ha_P hclass - have hqs_class : ∀ p ∈ qs, (Prime (ι p) ∧ ι p ∉ P) ∨ IsUnit (ι p) := - fun p hp => hclass p (List.mem_cons_of_mem q hp) - rcases hclass q List.mem_cons_self with ⟨hq_prime, hq_avoid⟩ | hq_unit - · obtain ⟨kq, a₁, hq_ndvd_a₁, ha_eq⟩ := - WfDvdMonoid.max_power_factor' ha_ne hq_prime.not_isUnit - have ha₁_P : a₁ ∈ P := by - rw [ha_eq] at ha_P - exact (hP_prime.mem_or_mem ha_P).resolve_left - (fun h => hq_avoid (hP_prime.mem_of_pow_mem kq h)) - have ha₁_ne : a₁ ≠ 0 := right_ne_zero_of_mul (ha_eq ▸ ha_ne) - obtain ⟨a', d', ha₁_eq, ha'_P, ha'_ne, ha'_ndvd⟩ := - ih a₁ ha₁_ne ha₁_P hqs_class - refine ⟨a', (ι q) ^ kq * d', ?_, ha'_P, ha'_ne, ?_⟩ - · rw [ha_eq, ha₁_eq] - ring - · intro p hp hp_prime - rcases List.mem_cons.mp hp with rfl | hp' - · intro h - exact hq_ndvd_a₁ (dvd_trans h (Dvd.intro_left d' ha₁_eq.symm)) - · exact ha'_ndvd p hp' hp_prime - · obtain ⟨a', d', ha_eq, ha'_P, ha'_ne, ha'_ndvd⟩ := - ih a ha_ne ha_P hqs_class - refine ⟨a', d', ha_eq, ha'_P, ha'_ne, ?_⟩ - intro p hp hp_prime - rcases List.mem_cons.mp hp with rfl | hp' - · exact absurd hq_unit hp_prime.not_isUnit - · exact ha'_ndvd p hp' hp_prime -- Apply the stripping lemma to get r' ∈ P with no prime factor of s dividing r' obtain ⟨r', d_strip, hr_eq_strip, hr'_in_P, hr'_ne, hr'_ndvd⟩ := - fold_strip pfactors r hr_ne hr_in_P hfactor_class + build_ufd_strip_prime_factors ι P hP_prime pfactors r hr_ne hr_in_P hfactor_class -- Show r' maps to a prime in the localization have hr'_prime_loc : Prime (algebraMap S_sub (Localization.Away s) r') := by have h1 : algebraMap S_sub (Localization.Away s) r = @@ -656,76 +698,21 @@ private def build_ufd_proof_proof hq'_prime -- Descend primality from the localization back to S_sub have hr'_prime : Prime r' := by - refine ⟨hr'_ne, ?_, ?_⟩ - · intro hu - exact hP_prime.ne_top (Ideal.eq_top_of_isUnit_mem P hr'_in_P hu) - · intro a b hab - have hab_loc : algebraMap S_sub (Localization.Away s) r' ∣ - algebraMap S_sub _ a * algebraMap S_sub _ b := by - rw [← map_mul] - exact map_dvd _ hab - suffices hdvd_back : ∀ (x : S_sub), - (algebraMap S_sub (Localization.Away s) r' ∣ algebraMap S_sub _ x) → - r' ∣ x by - exact (hr'_prime_loc.dvd_or_dvd hab_loc).imp (hdvd_back a) (hdvd_back b) - intro x hqx - obtain ⟨z, hz⟩ := hqx - obtain ⟨⟨c, ⟨_, m, rfl⟩⟩, hc⟩ := - IsLocalization.surj (Submonoid.powers s) z - have key : x * s ^ m = r' * c := by - apply hinj_loc - rw [map_mul, map_mul, map_pow] - calc algebraMap S_sub _ x * (algebraMap S_sub _ s) ^ m - = algebraMap S_sub _ r' * (z * (algebraMap S_sub _ s) ^ m) := by - rw [hz, mul_assoc] - _ = algebraMap S_sub _ r' * algebraMap S_sub _ c := by - rw [← map_pow, hc] - have hr'_dvd_xsm : r' ∣ x * s ^ m := ⟨c, key⟩ - obtain ⟨u_s, hu_s⟩ := hpfactors_assoc - -- Key lemma: if r' | a * (prod of primes)^m and r' is coprime to each prime, then r' | a - have strip_list_prod_pow : ∀ (ps : List R.carrier) (a : S_sub), - (∀ p ∈ ps, (Prime (ι p) ∧ ι p ∉ P) ∨ IsUnit (ι p)) → - (∀ p ∈ ps, Prime (ι p) → ¬(ι p ∣ r')) → - r' ∣ a * (ps.map ι).prod ^ m → r' ∣ a := by - intro ps - induction ps with - | nil => intro a _ _ h - simpa using h - | cons p ps ih => - intro a hclass hndvd h - have hclass' := fun q hq => hclass q (List.mem_cons_of_mem p hq) - have hndvd' := fun q hq => hndvd q (List.mem_cons_of_mem p hq) - simp only [List.map_cons, List.prod_cons] at h - rcases hclass p List.mem_cons_self with ⟨hp_prime, _⟩ | hp_unit - · have hp_ndvd := hndvd p List.mem_cons_self hp_prime - have h1 : r' ∣ (a * (ps.map ι).prod ^ m) * (ι p) ^ m := by - rwa [show a * (ι p * (List.map ι ps).prod) ^ m = - (a * (List.map ι ps).prod ^ m) * (ι p) ^ m from by - rw [mul_pow] - ring] at h - have h2 : r' ∣ a * (ps.map ι).prod ^ m := - dvd_of_dvd_mul_prime_pow hp_prime hp_ndvd m h1 - exact ih a hclass' hndvd' h2 - · have hpm_unit : IsUnit ((ι p) ^ m) := hp_unit.pow m - have h1 : r' ∣ (a * (ι p) ^ m) * (ps.map ι).prod ^ m := by - rwa [show a * (ι p * (List.map ι ps).prod) ^ m = - (a * (ι p) ^ m) * (List.map ι ps).prod ^ m from by - rw [mul_pow] - ring] at h - have h2 : r' ∣ a * (ι p) ^ m := - ih (a * (ι p) ^ m) hclass' hndvd' h1 - exact (hpm_unit.dvd_mul_right).mp h2 - -- Factor s^m = (prod of primes)^m * unit^m, strip primes, then cancel the unit - have hr'_dvd_xU : r' ∣ x * ↑u_s ^ m := by - have hsm_eq : s ^ m = (pfactors.map ι).prod ^ m * ↑u_s ^ m := by - rw [← hu_s, mul_pow] - have h1 : r' ∣ (x * ↑u_s ^ m) * (pfactors.map ι).prod ^ m := by - rwa [show (x * ↑u_s ^ m) * (pfactors.map ι).prod ^ m = - x * s ^ m from by rw [hsm_eq] - ring] - exact strip_list_prod_pow pfactors (x * ↑u_s ^ m) - hfactor_class hr'_ndvd h1 - exact (u_s.isUnit.pow m).dvd_mul_right.mp hr'_dvd_xU + obtain ⟨u_s, hu_s⟩ := hpfactors_assoc + refine build_ufd_prime_of_prime_away s hinj_loc r' hr'_ne + (fun hu => hP_prime.ne_top (Ideal.eq_top_of_isUnit_mem P hr'_in_P hu)) + hr'_prime_loc fun x m hr'_dvd_xsm => ?_ + -- Factor s^m = (prod of primes)^m * unit^m, strip primes, then cancel the unit + have hr'_dvd_xU : r' ∣ x * ↑u_s ^ m := by + have hsm_eq : s ^ m = (pfactors.map ι).prod ^ m * ↑u_s ^ m := by + rw [← hu_s, mul_pow] + have h1 : r' ∣ (x * ↑u_s ^ m) * (pfactors.map ι).prod ^ m := by + rwa [show (x * ↑u_s ^ m) * (pfactors.map ι).prod ^ m = + x * s ^ m from by rw [hsm_eq] + ring] + exact build_ufd_dvd_of_dvd_mul_prod_pow ι P r' m pfactors (x * ↑u_s ^ m) + hfactor_class hr'_ndvd h1 + exact (u_s.isUnit.pow m).dvd_mul_right.mp hr'_dvd_xU exact ⟨r', hr'_in_P, hr'_prime⟩ -- Case P ∩ R ≠ 0: R is a UFD, so P ∩ R contains a prime q of R; q maps to a prime in S_sub · obtain ⟨q, hq_mem, hq_prime⟩ := @@ -737,41 +724,6 @@ private def build_ufd_proof_proof by_contra h exact hP_prime.ne_top (Ideal.eq_top_of_isUnit_mem P hq_P (hinv (ι q) h)) exact ⟨ι q, hq_P, hR_prime_in_S q hq_prime hq_M⟩ -⟩ - -omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -include T in theorem build_ufd_proof - (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) - (S_sub : Subring T) [IsDomain S_sub] [WfDvdMonoid S_sub] - (hR_le : R.carrier ≤ S_sub) - (_hcoprime : ∀ p : R.carrier, Prime p → ¬(p ∣ y₁ ∧ p ∣ y₂)) - (hy₁ : (↑y₁ : T) ≠ 0) (hy₂ : (↑y₂ : T) ≠ 0) - (hx₁_trans : Transcendental R.carrier x₁) - (_hx₂_trans : Transcendental R.carrier x₂) - (_hx₁_mod_trans : ∀ (p : R.carrier), Prime p → ¬p ∣ y₂ → - ∀ (f : Polynomial R.carrier), - aeval x₁ f ∈ Ideal.span {(↑p : T)} → (C p : Polynomial R.carrier) ∣ f) - (_hx₂_mod_trans : ∀ (p : R.carrier), Prime p → ¬p ∣ y₁ → - ∀ (f : Polynomial R.carrier), - aeval x₂ f ∈ Ideal.span {(↑p : T)} → (C p : Polynomial R.carrier) ∣ f) - (hinv : ∀ (s : S_sub), (s : T) ∉ IsLocalRing.maximalIdeal T → IsUnit s) - (hR_prime_in_S : ∀ (p : R.carrier), Prime p → - (↑p : T) ∈ IsLocalRing.maximalIdeal T → - Prime (⟨(↑p : T), hR_le p.2⟩ : S_sub)) - (hS_sub_eq : (S_sub : Set T) = - {t : T | ∃ (a : T) (b : T), - a ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ - b ∈ intersectionSet R x₁ x₂ y₁ y₂ ∧ - b ∉ IsLocalRing.maximalIdeal T ∧ t * b = a}) - (hRbar_le_S : ∀ t, t ∈ intersectionSet R x₁ x₂ y₁ y₂ → t ∈ (S_sub : Set T)) - (hx₁_Rbar : x₁ ∈ intersectionSet R x₁ x₂ y₁ y₂) - (_hx₂_Rbar : x₂ ∈ intersectionSet R x₁ x₂ y₁ y₂) : - UniqueFactorizationMonoid S_sub := by - exact - (build_ufd_proof_proof - R x₁ x₂ y₁ y₂ S_sub hR_le _hcoprime hy₁ hy₂ hx₁_trans _hx₂_trans _hx₁_mod_trans - _hx₂_mod_trans hinv hR_prime_in_S hS_sub_eq hRbar_le_S hx₁_Rbar _hx₂_Rbar - ).down omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in /- R-primes stay prime in S_sub: given the intersection subring construction, every prime element of R maps to a prime element of S_sub. -/ From 3ebef2a2dd9b0682e0a468e983e4d5c12917036f Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Thu, 5 Nov 2026 08:36:07 -0800 Subject: [PATCH 2/4] Remove the now-unused smul_lift_of_filtration Its only callers were replaced by the coefficient-based argument. Co-Authored-By: Claude Opus 5.5 --- .../AndersonConjecture/AdicNoetherian.lean | 25 ------------------- 1 file changed, 25 deletions(-) diff --git a/LeanPool/AndersonConjecture/AdicNoetherian.lean b/LeanPool/AndersonConjecture/AdicNoetherian.lean index 96a579ae25..2061decffb 100644 --- a/LeanPool/AndersonConjecture/AdicNoetherian.lean +++ b/LeanPool/AndersonConjecture/AdicNoetherian.lean @@ -225,31 +225,6 @@ omit [IsLocalRing R] [IsNoetherianRing R] in lemma evalₐ_mk_smul_eq rw [mul_sub] at hmk_kills rw [sub_eq_zero.mp hmk_kills, show m • s = m * s from rfl, ← map_mul] -/- Auxiliary: lift elements of Mi^K • FN(n0) to I₀ with evalₐ compatibility. -/ -omit [IsLocalRing R] [IsNoetherianRing R] in lemma smul_lift_of_filtration - (Mi : Ideal R) - (n0 K : ℕ) - (FN_n0 : Ideal R) - (S_F : Finset R) (hS_F : Ideal.span ↑S_F = FN_n0) - (I₀ : Ideal (AdicCompletion Mi R)) - (hlift_span : ∀ t : R, t ∈ (Ideal.span ↑S_F : Ideal R) → - ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ - evalₐ Mi (n0 + 1) δ = Ideal.Quotient.mk (Mi ^ (n0 + 1)) t) - (r' : R) (hr' : r' ∈ (Mi ^ K • (FN_n0 : Submodule R R) : Submodule R R)) : - ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ - evalₐ Mi (n0 + K + 1) δ = - Ideal.Quotient.mk (Mi ^ (n0 + K + 1)) r' := by - refine Submodule.smul_induction_on hr' ?_ ?_ - · intro m hm s hs - have hs_span : s ∈ (Ideal.span ↑S_F : Ideal R) := - hS_F ▸ hs - obtain ⟨δ_s, hδ_s_I, hδ_s_eq⟩ := hlift_span s hs_span - refine ⟨of Mi R m * δ_s, I₀.mul_mem_left _ hδ_s_I, ?_⟩ - rw [map_mul, evalₐ_of] - exact evalₐ_mk_smul_eq R Mi n0 K m s hm δ_s hδ_s_eq - · intro a b ⟨δa, hδaI, hδaeq⟩ ⟨δb, hδbI, hδbeq⟩ - exact ⟨δa + δb, I₀.add_mem hδaI hδbI, by rw [map_add, hδaeq, hδbeq, map_add]⟩ - /- Auxiliary: per-generator coefficient decomposition for r' ∈ Mi^K • FN_n0. -/ omit [IsLocalRing R] [IsNoetherianRing R] in lemma coeff_decomp_of_smul (Mi : Ideal R) From ad0593598df67726f85b3bcd0888e3edb49731b1 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Thu, 5 Nov 2026 08:58:21 -0800 Subject: [PATCH 3/4] Preserve the public filtration lifting lemma Restore the existing exported smul_lift_of_filtration contract and its bounded proof while retaining the long-proof decomposition. The lemma remains available to downstream users even though current internal callers now use coefficient decomposition. Refs #723. --- .../AndersonConjecture/AdicNoetherian.lean | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/LeanPool/AndersonConjecture/AdicNoetherian.lean b/LeanPool/AndersonConjecture/AdicNoetherian.lean index 2061decffb..96a579ae25 100644 --- a/LeanPool/AndersonConjecture/AdicNoetherian.lean +++ b/LeanPool/AndersonConjecture/AdicNoetherian.lean @@ -225,6 +225,31 @@ omit [IsLocalRing R] [IsNoetherianRing R] in lemma evalₐ_mk_smul_eq rw [mul_sub] at hmk_kills rw [sub_eq_zero.mp hmk_kills, show m • s = m * s from rfl, ← map_mul] +/- Auxiliary: lift elements of Mi^K • FN(n0) to I₀ with evalₐ compatibility. -/ +omit [IsLocalRing R] [IsNoetherianRing R] in lemma smul_lift_of_filtration + (Mi : Ideal R) + (n0 K : ℕ) + (FN_n0 : Ideal R) + (S_F : Finset R) (hS_F : Ideal.span ↑S_F = FN_n0) + (I₀ : Ideal (AdicCompletion Mi R)) + (hlift_span : ∀ t : R, t ∈ (Ideal.span ↑S_F : Ideal R) → + ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ + evalₐ Mi (n0 + 1) δ = Ideal.Quotient.mk (Mi ^ (n0 + 1)) t) + (r' : R) (hr' : r' ∈ (Mi ^ K • (FN_n0 : Submodule R R) : Submodule R R)) : + ∃ δ : AdicCompletion Mi R, δ ∈ I₀ ∧ + evalₐ Mi (n0 + K + 1) δ = + Ideal.Quotient.mk (Mi ^ (n0 + K + 1)) r' := by + refine Submodule.smul_induction_on hr' ?_ ?_ + · intro m hm s hs + have hs_span : s ∈ (Ideal.span ↑S_F : Ideal R) := + hS_F ▸ hs + obtain ⟨δ_s, hδ_s_I, hδ_s_eq⟩ := hlift_span s hs_span + refine ⟨of Mi R m * δ_s, I₀.mul_mem_left _ hδ_s_I, ?_⟩ + rw [map_mul, evalₐ_of] + exact evalₐ_mk_smul_eq R Mi n0 K m s hm δ_s hδ_s_eq + · intro a b ⟨δa, hδaI, hδaeq⟩ ⟨δb, hδbI, hδbeq⟩ + exact ⟨δa + δb, I₀.add_mem hδaI hδbI, by rw [map_add, hδaeq, hδbeq, map_add]⟩ + /- Auxiliary: per-generator coefficient decomposition for r' ∈ Mi^K • FN_n0. -/ omit [IsLocalRing R] [IsNoetherianRing R] in lemma coeff_decomp_of_smul (Mi : Ideal R) From 4b1e37f24ca68d279459789b3d4ca0de02ebf542 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Thu, 5 Nov 2026 09:00:57 -0800 Subject: [PATCH 4/4] Put theorem headers on their own line after include/omit Main's text-based proof-size check only recognizes declarations that start a line, so one-line 'include T in theorem' headers merged neighbouring blocks into apparent 264/364-line proofs. Splitting the header is the standard layout and keeps both checkers accurate. Co-Authored-By: Claude Opus 5.5 --- .../AndersonConjecture/AdicNoetherian.lean | 24 +++++++---- .../Jensen/CloseUp/NoCommonFactor.lean | 12 ++++-- .../Jensen/CombinedStep.lean | 42 ++++++++++++------- .../Jensen/KrullDomain/HeightBound.lean | 6 ++- .../Jensen/KrullDomain/KrullDomain.lean | 9 ++-- .../Jensen/KrullDomain/UFDConstruction.lean | 12 ++++-- 6 files changed, 70 insertions(+), 35 deletions(-) diff --git a/LeanPool/AndersonConjecture/AdicNoetherian.lean b/LeanPool/AndersonConjecture/AdicNoetherian.lean index 96a579ae25..2a575f38ab 100644 --- a/LeanPool/AndersonConjecture/AdicNoetherian.lean +++ b/LeanPool/AndersonConjecture/AdicNoetherian.lean @@ -38,7 +38,8 @@ section KernelEvalₐ variable (I : Ideal R) /- `(map f I)ⁿ ⊆ ker(evalₐ I n)`: elements from I^n evaluate to zero. -/ -include R in lemma map_pow_le_ker_evalₐ (n : ℕ) : +include R in +lemma map_pow_le_ker_evalₐ (n : ℕ) : Ideal.map (algebraMap R (AdicCompletion I R)) (I ^ n) ≤ RingHom.ker (AdicCompletion.evalₐ I n).toRingHom := by rw [Ideal.map_le_iff_le_comap] @@ -49,7 +50,8 @@ include R in lemma map_pow_le_ker_evalₐ (n : ℕ) : exact Ideal.Quotient.eq_zero_iff_mem.mpr hr /- `ker(evalₐ M n) = M̂ⁿ` for Noetherian local R. -/ -include R in lemma ker_evalₐ_eq [IsLocalRing R] [IsNoetherianRing R] (n : ℕ) : +include R in +lemma ker_evalₐ_eq [IsLocalRing R] [IsNoetherianRing R] (n : ℕ) : RingHom.ker (evalₐ (IsLocalRing.maximalIdeal R) n).toRingHom = Ideal.map (algebraMap R (AdicCompletion (IsLocalRing.maximalIdeal R) R)) (IsLocalRing.maximalIdeal R) ^ n := by @@ -61,7 +63,8 @@ include R in lemma ker_evalₐ_eq [IsLocalRing R] [IsNoetherianRing R] (n : ℕ) exact map_pow_le_ker_evalₐ (IsLocalRing.maximalIdeal R) n /- Evaluations are stable along Cauchy sequences. -/ -include R in lemma eval_cauchy_stable (f : ℕ → AdicCompletion I R) +include R in +lemma eval_cauchy_stable (f : ℕ → AdicCompletion I R) (hf : ∀ {m n : ℕ}, m ≤ n → SModEq (I ^ m • (⊤ : Submodule R (AdicCompletion I R))) (f m) (f n)) {k n : ℕ} (hkn : k ≤ n) : @@ -73,7 +76,8 @@ include R in lemma eval_cauchy_stable (f : ℕ → AdicCompletion I R) exact this.symm /- `factorPow ∘ evalₐ n = evalₐ m` for m ≤ n. -/ -include R in lemma factorPow_comp_evalₐ_noeth {m n : ℕ} (hmn : m ≤ n) (x : AdicCompletion I R) : +include R in +lemma factorPow_comp_evalₐ_noeth {m n : ℕ} (hmn : m ≤ n) (x : AdicCompletion I R) : Ideal.Quotient.factorPow I hmn (evalₐ I n x) = evalₐ I m x := by apply induction_on I R (p := fun x => Ideal.Quotient.factorPow I hmn (evalₐ I n x) = evalₐ I m x) x @@ -142,7 +146,8 @@ noncomputable def buildAdicSeq {α : Type*} {P : ℕ → α → Prop} fun K => Nat.rec base (fun K prev => step K prev) K /- Auxiliary: M * FN(n) ≤ FN(n+1) for the leading-term filtration FN. -/ -omit [IsLocalRing R] [IsNoetherianRing R] in lemma filtration_smul_le +omit [IsLocalRing R] [IsNoetherianRing R] in +lemma filtration_smul_le (Mi : Ideal R) (J : Ideal (AdicCompletion Mi R)) (FN : ℕ → Ideal R) (hFN_def : ∀ n, FN n = Mi ^ n ⊓ Ideal.comap (Ideal.Quotient.mk (Mi ^ (n + 1))) @@ -197,7 +202,8 @@ omit [IsLocalRing R] [IsNoetherianRing R] in lemma filtration_smul_le exact Ideal.mul_mem_mul hm hs /- Auxiliary: the shared coefficient-matching step for a single smul generator. -/ -omit [IsLocalRing R] [IsNoetherianRing R] in lemma evalₐ_mk_smul_eq +omit [IsLocalRing R] [IsNoetherianRing R] in +lemma evalₐ_mk_smul_eq (Mi : Ideal R) (n0 K : ℕ) (m s : R) (hm : m ∈ (Mi ^ K : Ideal R)) (δ_s : AdicCompletion Mi R) (hδ_s_eq : evalₐ Mi (n0 + 1) δ_s = Ideal.Quotient.mk (Mi ^ (n0 + 1)) s) : @@ -251,7 +257,8 @@ omit [IsLocalRing R] [IsNoetherianRing R] in lemma smul_lift_of_filtration exact ⟨δa + δb, I₀.add_mem hδaI hδbI, by rw [map_add, hδaeq, hδbeq, map_add]⟩ /- Auxiliary: per-generator coefficient decomposition for r' ∈ Mi^K • FN_n0. -/ -omit [IsLocalRing R] [IsNoetherianRing R] in lemma coeff_decomp_of_smul +omit [IsLocalRing R] [IsNoetherianRing R] in +lemma coeff_decomp_of_smul (Mi : Ideal R) (n0 K : ℕ) (FN_n0 : Ideal R) @@ -293,7 +300,8 @@ omit [IsLocalRing R] [IsNoetherianRing R] in lemma coeff_decomp_of_smul rw [hexp, map_add, hcaeq, hcbeq, map_add] /- Auxiliary: extract a representative r ∈ Mi^K • FN_n0 from e ∈ Mhat^(n0+K) ∩ J. -/ -omit [IsLocalRing R] [IsNoetherianRing R] in lemma extract_filtration_rep +omit [IsLocalRing R] [IsNoetherianRing R] in +lemma extract_filtration_rep (Mi : Ideal R) (J : Ideal (AdicCompletion Mi R)) (FN : ℕ → Ideal R) (n0 K : ℕ) (hFN_def : ∀ n, FN n = Mi ^ n ⊓ Ideal.comap (Ideal.Quotient.mk (Mi ^ (n + 1))) diff --git a/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean b/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean index a9b49f2a63..c1b6291efb 100644 --- a/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean +++ b/LeanPool/AndersonConjecture/Jensen/CloseUp/NoCommonFactor.lean @@ -39,7 +39,8 @@ open Cardinal Ideal variable {T : Type*} [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] -- Helper: a prime P of height ≤ 1 with P ∩ R ≠ ⊥ lies in Ass(T/r₀T) for some nonzero r₀ ∈ R. -include T in theorem prime_height_le_one_mem_assoc +include T in +theorem prime_height_le_one_mem_assoc {R : NSubring T} (P : Ideal T) (hP_prime : P.IsPrime) (hP_ht : P.height ≤ 1) (hPR_ne : P.comap R.carrier.subtype ≠ ⊥) : @@ -66,7 +67,8 @@ include T in theorem prime_height_le_one_mem_assoc exact ⟨r₀, hr₀T_ne, hP_assoc⟩ -- Helper: I_s' ⊄ P for associated primes P when no common prime divides s'. -include T in theorem no_common_I_not_le_assoc +include T in +theorem no_common_I_not_le_assoc {R : NSubring T} [DecidableEq R.carrier] {a : R.carrier} {s : Finset R.carrier} @@ -538,7 +540,8 @@ private theorem no_common_exists_transcendental -- Extracted: no-common-factor branch of close_up_aux_wf. -- When no prime divides all generators in s', use Heitmann reparametrization. -include T in theorem close_up_aux_no_common_nonzero +include T in +theorem close_up_aux_no_common_nonzero [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -644,7 +647,8 @@ include T in theorem close_up_aux_no_common_nonzero simp only [Subring.coe_add, Subring.coe_mul] ring) -include T in theorem close_up_aux_no_common +include T in +theorem close_up_aux_no_common [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) diff --git a/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean b/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean index 770e785948..f9ab1d461b 100644 --- a/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean +++ b/LeanPool/AndersonConjecture/Jensen/CombinedStep.lean @@ -35,7 +35,8 @@ universe u variable {T : Type u} [CommRing T] [IsLocalRing T] [IsNoetherianRing T] [IsDomain T] /- Transitivity of A-extensions: if R → S and S → U are A-extensions, so is R → U. -/ -include T in theorem isAExtension_trans {R S U : NSubring T} +include T in +theorem isAExtension_trans {R S U : NSubring T} (h₁ : IsAExtension R S) (h₂ : IsAExtension S U) : IsAExtension R U where le := le_trans h₁.le h₂.le -- Primality lifts through each link of the chain R ≤ S ≤ U @@ -45,7 +46,8 @@ include T in theorem isAExtension_trans {R S U : NSubring T} -- max(ℵ₀, #U) ≤ max(ℵ₀, max(ℵ₀, #R)) = max(ℵ₀, #R) by idempotence h₂.card_le.trans ((max_le_max_left _ h₁.card_le).trans (by rw [← max_assoc, max_self])) -include T in lemma card_lt_of_aext' (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) +include T in +lemma card_lt_of_aext' (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) {A B : NSubring T} (hAB : IsAExtension A B) (hA : Cardinal.mk A.carrier < Cardinal.mk T) : Cardinal.mk B.carrier < Cardinal.mk T := @@ -53,7 +55,8 @@ include T in lemma card_lt_of_aext' (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T /- Build an NSubring from a chain with explicit carrier = unionSubring. Unlike `transfinite_union_isNSubring`, the carrier is accessible (not opaque via .choose). -/ -include T in theorem build_union_isNSubring +include T in +theorem build_union_isNSubring {ι' : Type u} [LinearOrder ι'] [Nonempty ι'] (chain : NSubringChain T ι') (h_card : ∀ (α : ι'), @@ -79,7 +82,8 @@ include T in theorem build_union_isNSubring /- Process one (gens, c) pair: given NSubring Sk with R' ≤ Sk and #Sk < #T, produce an A-extension Sk1 that closes the pair if c ∈ I·T. -/ -include T in private theorem close_up_all_mk_next +include T in +private theorem close_up_all_mk_next [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -128,7 +132,8 @@ include T in private theorem close_up_all_mk_next /- Cardinality bound for a union of NSubrings in a chain. -/ -- #(⋃_α R_α) ≤ #ι · sup(#R_α) ≤ κ² = κ where κ = max(ℵ₀, #R') -include T in private theorem union_card_le_max +include T in +private theorem union_card_le_max {ι : Type u} [LinearOrder ι] [Nonempty ι] (R' : NSubring T) (chain : NSubringChain T ι) @@ -151,7 +156,8 @@ include T in private theorem union_card_le_max /- `#(Finset R × R) ≤ max(ℵ₀, #R)`: for infinite `R`, `#(Finset R × R) = #R`. -/ -include T in private theorem card_finset_prod_le (R' : NSubring T) : +include T in +private theorem card_finset_prod_le (R' : NSubring T) : Cardinal.mk (Finset R'.carrier × R'.carrier) ≤ max Cardinal.aleph0 (Cardinal.mk R'.carrier) := by by_cases hfin : Finite R'.carrier @@ -164,7 +170,8 @@ include T in private theorem card_finset_prod_le (R' : NSubring T) : /- Assembly of the one-pass close-up: the union of a chain `f` of A-extensions of `R'` is an A-extension of `R'` of small cardinality in which every pair `(I, c)` closed at some stage stays closed. -/ -include T in private theorem close_up_all_one_pass_union +include T in +private theorem close_up_all_one_pass_union {ι : Type u} [LinearOrder ι] [Nonempty ι] (hT_aleph0 : Cardinal.aleph0 < Cardinal.mk T) (R' : NSubring T) (hR' : Cardinal.mk R'.carrier < Cardinal.mk T) (f : ι → NSubring T) @@ -239,7 +246,8 @@ include T in private theorem close_up_all_one_pass_union exact Ideal.mem_map_of_mem _ hc_fp /- Build the transfinite recursion and prove its invariant for close_up_all. -/ -include T in private theorem close_up_all_one_pass_aux +include T in +private theorem close_up_all_one_pass_aux [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -441,7 +449,8 @@ include T in private theorem close_up_all_one_pass_aux (fun gens c hc => ⟨(gens, c), (hGood (gens, c)).2.2.2 hc⟩) /- One-pass transfinite close-up: given NSubring R' with #R' < #T, produce an A-extension S such that every (I, c) pair from R' with c ∈ IT is closed in S. -/ -include T in theorem close_up_all_one_pass +include T in +theorem close_up_all_one_pass [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (hM_not_assoc : ∀ (r : T), r ≠ 0 → IsLocalRing.maximalIdeal T ∉ associatedPrimes T (T ⧸ Ideal.span {r})) @@ -460,7 +469,8 @@ include T in theorem close_up_all_one_pass /- Build an NSubring from an ℕ-indexed chain (cross-universe: ℕ : Type 0, T : Type u). Returns the NSubring with carrier = unionSubring. -/ -include T in theorem build_union_isNSubring_nat +include T in +theorem build_union_isNSubring_nat (chain : NSubringChain T ℕ) (h_card : ∀ (n : ℕ), Cardinal.mk (chain.ring n).carrier ≤ @@ -485,7 +495,8 @@ include T in theorem build_union_isNSubring_nat exact ⟨chain.unionNSubring hU_card, rfl, chain.le_union⟩ /- ω-iteration: given a one-pass close-up procedure, iterate it to close all f.g. ideals. -/ -include T in theorem close_up_all_omega +include T in +theorem close_up_all_omega (R : NSubring T) (hR_card : Cardinal.mk R.carrier < Cardinal.mk T) (_hT_card : Cardinal.mk T = Cardinal.mk (IsLocalRing.ResidueField T)) @@ -646,7 +657,8 @@ include T in theorem close_up_all_omega /- Transfinite close-up: given NSubring R with #R < #T, produce an A-extension S with IT ∩ S = I for all f.g. ideals I of S. -/ -include T in theorem close_up_all +include T in +theorem close_up_all [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (R : NSubring T) (hM_not_assoc : ∀ (r : T), r ≠ 0 → @@ -665,7 +677,8 @@ include T in theorem close_up_all (fun R' hR' => close_up_all_one_pass hM_not_assoc hAss_ht hT_card hT_aleph0 R' hR') /- Heitmann Lemma 7 (adapted for Jensen P = (0)). -/ -include T in theorem combined_step +include T in +theorem combined_step [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (R : NSubring T) (ℓ : T ⧸ IsLocalRing.maximalIdeal T ^ 2) @@ -718,7 +731,8 @@ include T in theorem combined_step exact hc₁ /- Variant without the prime-catching requirement, just surjectivity + closing up. -/ -include T in theorem combined_step_surj +include T in +theorem combined_step_surj [IsAdicComplete (IsLocalRing.maximalIdeal T) T] (R : NSubring T) (ℓ : T ⧸ IsLocalRing.maximalIdeal T ^ 2) diff --git a/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean b/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean index eac7511c34..5d8ad1bb49 100644 --- a/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean +++ b/LeanPool/AndersonConjecture/Jensen/KrullDomain/HeightBound.lean @@ -71,7 +71,8 @@ private def intersectionLocalizationSubring If for every associated prime P of T/(p) with y ∉ P, the polynomial evaluation aeval x f ∈ P implies C(p) | f, then aeval x f ∈ span{p} already implies C(p) | f. -/ -include T in theorem derive_mod_principal_trans +include T in +theorem derive_mod_principal_trans (R : NSubring T) (x : T) (y : R.carrier) (hAss_ht : ∀ (r : T), r ≠ 0 → ∀ P ∈ associatedPrimes T (T ⧸ Ideal.span {r}), P.height ≤ 1) @@ -153,7 +154,8 @@ every element of P ∩ S_sub is divisible by a prime p₀ generating P ∩ R, then every nonzero element of any prime q ⊊ P ∩ S_sub would be infinitely divisible by p₀, contradicting WfDvdMonoid. Hence q = ⊥, giving the height bound contradiction. -/ -include T in theorem height_bound_wf_descent +include T in +theorem height_bound_wf_descent (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) (hR_le : R.carrier ≤ S_sub) diff --git a/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean b/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean index 9910c5287d..d50f05bb65 100644 --- a/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean +++ b/LeanPool/AndersonConjecture/Jensen/KrullDomain/KrullDomain.lean @@ -42,7 +42,8 @@ omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in /- Shared height-1 step for the kernel proofs: a height-≤-1 prime `P` of `T` containing a prime `p` of `R` is an associated prime of `T/(p)`, and `(p)R` equals `P ∩ R`. -/ -include T in private theorem ker_pf_span_eq +include T in +private theorem ker_pf_span_eq (R : NSubring T) (P : Ideal T) (hP_prime : P.IsPrime) (hP_ht : P.height ≤ 1) (p : R.carrier) (hp : Prime p) (hp_P : (↑p : T) ∈ P) (hp_ne : (↑p : T) ≠ 0) : @@ -191,7 +192,8 @@ private def intersection_close_up_proof_ker_pf₁ ⟩ omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -include T in theorem intersection_close_up_ker_pf₁ +include T in +theorem intersection_close_up_ker_pf₁ (R : NSubring T) (y₂ : R.carrier) (t₁ u : T) (C_ext : Set (Ideal T)) (D_ext : Set T) @@ -222,7 +224,8 @@ omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in /- Helper for `intersection_close_up`: kernel proof for x₂ = t₂ - u·y₁. Shows that for each height-≤-1 prime P with y₁ ∉ P and p ∈ P prime in R, any polynomial f with aeval(x₂) f ∈ P is divisible by C(p). -/ -include T in theorem intersection_close_up_ker_pf₂ +include T in +theorem intersection_close_up_ker_pf₂ (R : NSubring T) (y₁ : R.carrier) (t₂ u : T) (C_ext : Set (Ideal T)) (D_ext : Set T) diff --git a/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean b/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean index f22e946db8..4359b137ca 100644 --- a/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean +++ b/LeanPool/AndersonConjecture/Jensen/KrullDomain/UFDConstruction.lean @@ -46,7 +46,8 @@ omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in /- R-primes in the maximal ideal are prime in S_sub. If p is prime in R with (p:T) ∈ M_T, then the image of p in S_sub is prime. The proof uses denominator clearing in Rbar and coprime prime_in_adjoinLocSet. -/ -include T in theorem build_R_prime_in_S +include T in +theorem build_R_prime_in_S (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) (hR_le : R.carrier ≤ S_sub) @@ -224,7 +225,8 @@ private theorem build_loc_away_ufd_mul_eq {S : Type*} [CommRing S] (s : S) _ = A a * A (s ^ nn) := map_mul A _ _ omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in -include T in theorem build_loc_away_ufd +include T in +theorem build_loc_away_ufd (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) [IsDomain S_sub] (hR_le : R.carrier ≤ S_sub) @@ -526,7 +528,8 @@ private theorem build_ufd_dvd_of_dvd_mul_prod_pow {A S : Type*} [CommRing S] [Is omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in /- S_sub is a UFD via Kaplansky criterion. Uses the intersection construction and Nagata-type arguments for the P∩R = ⊥ case. -/ -include T in theorem build_ufd_proof +include T in +theorem build_ufd_proof (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) [IsDomain S_sub] [WfDvdMonoid S_sub] (hR_le : R.carrier ≤ S_sub) @@ -727,7 +730,8 @@ include T in theorem build_ufd_proof omit [IsAdicComplete (IsLocalRing.maximalIdeal T) T] in /- R-primes stay prime in S_sub: given the intersection subring construction, every prime element of R maps to a prime element of S_sub. -/ -include T in theorem build_primes_preserved +include T in +theorem build_primes_preserved (R : NSubring T) (x₁ x₂ : T) (y₁ y₂ : R.carrier) (S_sub : Subring T) [IsLocalRing S_sub] [UniqueFactorizationMonoid S_sub] (hR_le : R.carrier ≤ S_sub)