Foundation Primitive Recognition Calculus Grow Eta Completion M0a Equiv Equivale

/-- `equiv` is an equivalence relation: reflexive, symmetric, transitive. This is
the completion of the M0a carrier into a genuine setoid, all choice-free. -/
theorem equiv_equivalence : Equivalence equiv where
  refl := equiv_refl
  symm := equiv_symm
  trans := equiv_trans

/-- `equiv` is reflexive: every regular sequence is equivalent to itself. -/
theorem equiv_refl (s : RegularSeq) : equiv s s := by
  intro k
  refine ⟨0, ?_⟩
  intro n _
  rw [crossDiff_self, Int.natAbs_zero, Nat.zero_mul]
  exact Nat.zero_le _

/-- `equiv` is symmetric. The cross-difference only flips sign, so its absolute
value and the denominator product are unchanged. Choice-free. -/
theorem equiv_symm {s t : RegularSeq} (h : equiv s t) : equiv t s := by
  intro k
  obtain ⟨N, hN⟩ := h k
  refine ⟨N, ?_⟩
  intro n hn
  have hcd : crossDiff (t.seq n) (s.seq n) = -crossDiff (s.seq n) (t.seq n) :=
    crossDiff_swap (s.seq n) (t.seq n)
  rw [hcd, Int.natAbs_neg, Nat.mul_comm (t.seq n).den.toNat (s.seq n).den.toNat]
  exact hN n hn

/-- `equiv` is transitive: the choice-free triangle argument at the integer
cross-multiplication level. From `|s_n - t_n| ≤ 1/(2k+2)` and
`|t_n - u_n| ≤ 1/(2k+2)` eventually, the three-point identity plus positivity of
the middle denominator give `|s_n - u_n| ≤ 1/(k+1)`, with no ℚ display (so the
proof stays on `{propext, Quot.sound}`). -/
theorem equiv_trans {s t u : RegularSeq}
    (hst : equiv s t) (htu : equiv t u) : equiv s u := by
  intro k
  obtain ⟨N₁, hN₁⟩ := hst (2 * k + 1)
  obtain ⟨N₂, hN₂⟩ := htu (2 * k + 1)
  refine ⟨max N₁ N₂, ?_⟩
  intro n hn
  have hn₁ : n ≥ N₁ := le_trans (Nat.le_max_left N₁ N₂) hn
  have hn₂ : n ≥ N₂ := le_trans (Nat.le_max_right N₁ N₂) hn
  -- The three participating rationals at index n.
  set A := s.seq n with hA
  set B := t.seq n with hB
  set C := u.seq n with hC
  -- Hypotheses at level 2k+1 (i.e. factor 2k+1+1), in Nat. `set` rewrote the
  -- goal but not the ∀-hypotheses, so re-fold `s.seq n → A` etc. by hand.
  have h1 : (crossDiff A B).natAbs * (2 * k + 1 + 1) ≤ A.den.toNat * B.den.toNat := by
    have h := hN₁ n hn₁; rw [← hA, ← hB] at h; exact h
  have h2 : (crossDiff B C).natAbs * (2 * k + 1 + 1) ≤ B.den.toNat * C.den.toNat := by
    have h := hN₂ n hn₂; rw [← hB, ← hC] at h; exact h
  -- Positive denominators.
  have hdBpos : 0 < B.den.toNat := Nat.pos_of_ne_zero B.den_toNat_ne_zero
  -- Triangle in Nat via the integer identity and `Int.natAbs_add_le`.
  have hid : crossDiff A C * (B.den.toNat : ℤ) =
      crossDiff A B * (C.den.toNat : ℤ) + crossDiff B C * (A.den.toNat : ℤ) :=
    crossDiff_triangle_id A B C
  have heq := congrArg Int.natAbs hid
  have hnatB : ((B.den.toNat : ℤ)).natAbs = B.den.toNat := Int.natAbs_natCast _
  have hnatC : ((C.den.toNat : ℤ)).natAbs = C.den.toNat := Int.natAbs_natCast _
  have hnatA : ((A.den.toNat : ℤ)).natAbs = A.den.toNat := Int.natAbs_natCast _
  have hL : (crossDiff A C * (B.den.toNat : ℤ)).natAbs
      = (crossDiff A C).natAbs * B.den.toNat := by
    rw [Int.natAbs_mul, hnatB]
  have hR : (crossDiff A B * (C.den.toNat : ℤ) + crossDiff B C * (A.den.toNat : ℤ)).natAbs
      ≤ (crossDiff A B).natAbs * C.den.toNat + (crossDiff B C).natAbs * A.den.toNat := by
    refine le_trans (Int.natAbs_add_le _ _) ?_
    rw [Int.natAbs_mul, Int.natAbs_mul, hnatC, hnatA]
  have htriN : (crossDiff A C).natAbs * B.den.toNat
      ≤ (crossDiff A B).natAbs * C.den.toNat + (crossDiff B C).natAbs * A.den.toNat := by
    rw [hL] at heq; rw [heq]; exact hR
  -- Do the ε/2 arithmetic entirely in ℕ, using only monotone product lemmas and
  -- `ring`/`omega` (all choice-free). Casting to ℤ via norm_cast smuggles
  -- `Classical.choice` here, so we stay in ℕ.
  set cAC := (crossDiff A C).natAbs with hcAC
  set cAB := (crossDiff A B).natAbs with hcAB
  set cBC := (crossDiff B C).natAbs with hcBC
  set dA := A.den.toNat with hdA
  set dB := B.den.toNat with hdB
  set dC := C.den.toNat with hdC
  set two := 2 * k + 1 + 1 with htwo_def
  -- htriN : cAC*dB ≤ cAB*dC + cBC*dA ;  h1 : cAB*two ≤ dA*dB ;  h2 : cBC*two ≤ dB*dC
  have e1 : cAB * two * dC ≤ dA * dB * dC := Nat.mul_le_mul_right dC h1
  have e2 : cBC * two * dA ≤ dB * dC * dA := Nat.mul_le_mul_right dA h2
  have base : cAC * dB * two ≤ (cAB * dC + cBC * dA) * two := Nat.mul_le_mul_right two htriN
  have expand : (cAB * dC + cBC * dA) * two = cAB * two * dC + cBC * two * dA := by ring
  have chain : cAC * dB * two ≤ dA * dB * dC + dB * dC * dA := by
    rw [expand] at base; exact le_trans base (add_le_add e1 e2)
  -- two = 2*(k+1); repackage both sides around the common positive factor 2*dB.
  have htwo : two = 2 * (k + 1) := by rw [htwo_def]; ring
  have lhs_eq : cAC * dB * two = cAC * (k + 1) * (2 * dB) := by rw [htwo]; ring
  have rhs_eq : dA * dB * dC + dB * dC * dA = dA * dC * (2 * dB) := by ring
  have cancel_in : cAC * (k + 1) * (2 * dB) ≤ dA * dC * (2 * dB) := by
    rw [← lhs_eq, ← rhs_eq]; exact chain
  have hpos : 0 < 2 * dB := by rw [hdB]; omega
  exact Nat.le_of_mul_le_mul_right cancel_in hpos

/-- The unit η : ℚδ → ℝδ_pre is injective: no two distinct δ-rationals collapse
in the completion. Together with well-definedness this makes η a genuine
embedding of the rational base into the M0a real line, choice-free. -/
theorem etaQ_injective : Function.Injective etaQ := by
  intro a b h
  induction a using Quot.ind with
  | mk q =>
    induction b using Quot.ind with
    | mk r =>
      have hq : RealDelta.mk (eta q) = RealDelta.mk (eta r) := h
      have hequiv : equiv (eta q) (eta r) := by
        have := Quot.eqvGen_exact hq
        -- Exactness gives `EqvGen`; collapse it with the proved equivalence.
        exact (Equivalence.eqvGen_iff equiv_equivalence).mp this
      exact Quot.sound (crossEq_of_equiv_eta hequiv)