/-
Copyright (c) 2019 The Flypitch Project. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Authors: Jesse Han, Floris van Doorn
-/
import .to_mathlib

/-
note: in comment above cofinality, change sentence with
+  `∀ a, ∃ b ∈ S, ¬(b > a)`. It is defined for all ordinals, but
-/

universe variables u v w w'
noncomputable theory

open ordinal set

section delta_system
variables {ι : Type w} {ι' : Type w'} {α : Type u} {β : Type v} {A : ι → set α}
def is_delta_system (A : ι → set α) :=
∃(root : set α), ∀{{x y}}, x ≠ y → A x ∩ A y = root

open cardinal
def root_subset (hι : 2 ≤ mk ι) {root : set α} (x : ι)
  (h : ∀{{x y}}, x ≠ y → A x ∩ A y = root) : root ⊆ A x :=
begin
  cases (two_le_iff' x).mp hι with y hy, rw [←h hy], apply inter_subset_left
end

def finite_root (hι : 2 ≤ mk ι) {root : set α} (h2A : ∀(x : ι), finite (A x))
  (h : ∀{{x y}}, x ≠ y → A x ∩ A y = root) : finite root :=
begin
  rcases two_le_iff.mp hι with ⟨t, u, htu⟩,
  rw [←h htu], exact finite_subset (h2A t) (inter_subset_left _ _)
end

open function
lemma is_delta_system_preimage (f : β → α) (h : is_delta_system A) :
  is_delta_system (preimage f ∘ A) :=
begin
  cases h with r hr, use f ⁻¹' r, rintro x y hxy,
  rw [←preimage_inter], apply congr_arg (preimage f), apply hr hxy
end

lemma is_delta_system_image {f : α → β} (hf : injective f) :
  is_delta_system (image f ∘ A) ↔ is_delta_system A :=
begin
  split,
  { intro h, have := is_delta_system_preimage f h,
    convert this, apply funext, intro x, dsimp, rw [preimage_image_eq _ hf] },
  rintro ⟨r, hr⟩, use f '' r, rintro x y hxy,
  rw [image_inter hf], apply congr_arg (image f), apply hr hxy
end

lemma is_delta_system_preimage_iff {f : β → α} (hf : injective f) (hf₂ : ∀i, A i ⊆ range f) :
  is_delta_system (preimage f ∘ A) ↔ is_delta_system A :=
begin
  split, rintro ⟨r, hr⟩, use f '' r, intros i j hij,
  rw [←hr hij, ←image_inter hf, image_preimage_eq_of_subset (hf₂ i),
    image_preimage_eq_of_subset (hf₂ j)],
  apply is_delta_system_preimage
end

lemma is_delta_system_precompose (f : ι' → ι) (hf : injective f) (h : is_delta_system A) :
  is_delta_system (A ∘ f) :=
by { cases h with r hr, use r, intros x y hxy, exact hr (λ hxy', hxy $ hf hxy') }

lemma is_delta_system_precompose_iff (f : ι' ≃ ι) : is_delta_system A ↔ is_delta_system (A ∘ f) :=
begin
  use is_delta_system_precompose f f.bijective.1,
  intro h, convert is_delta_system_precompose f.symm f.symm.bijective.1 h, apply funext,
  intro i, simp
end

end delta_system

namespace subrel

-- instance subrel.is_well_order' {α : Type u} (r : α → α → Prop) [is_well_order α r]
--   (p : α → Prop) : is_well_order {x // p x} (subrel r p) :=
-- subrel.is_well_order r p

end subrel

namespace delta_system

open cardinal ordinal set

open function
lemma delta_system_lemma_2 {κ : cardinal} (hκ : cardinal.omega ≤ κ)
  {θ : Type u} (θr : θ → θ → Prop) [θwo : is_well_order θ θr] (hκθ : κ < mk θ)
  (hθ : is_regular $ mk θ) (θtype_eq : ord (mk θ) = type θr) (hθ_le : ∀(β < mk θ), β ^< κ < mk θ)
  {ρ : Type u} (ρr : ρ → ρ → Prop) [ρwo : is_well_order ρ ρr] (hρ : mk ρ < κ)
  {ι : Type u} {A : ι → set θ} (h2A : ∀i, ρr ≃o subrel θr (A i))
  (h3A : unbounded θr (⋃i, A i)) : ∃(t : set ι), mk t = mk θ ∧ is_delta_system (restrict A t) :=
begin
  let nr : ι → ρ → θ := λ i ξ, (h2A i ξ).val,
  let good : ρ → Prop := λ ξ, unbounded θr (range $ λ i, nr i ξ),
  have : ∃ξ : ρ, good ξ,
  { apply unbounded_of_unbounded_Union θr (λ ξ, range $ λ i, nr i ξ),
    { rw [Union_range_eq_Union], exact h3A, intro i, exact (h2A i).to_equiv.bijective.2 },
    { rw [←cof_type, ←θtype_eq, hθ.2], refine lt_trans hρ hκθ }},
  let ξ₀ : ρ := ρwo.wf.min good this,
  let α₀ : ordinal := sup.{u u} (λ o : {x // ρr x ξ₀}, sup.{u u} $ λ x : ι,
    ordinal.succ $ typein θr $ nr x o.1),
  have hα₀ : α₀ < type θr,
  { rw [←θtype_eq], apply sup_lt_ord_of_is_regular _ hθ,
    { refine lt_of_le_of_lt _ (lt_trans hρ hκθ), rw [card_typein, ←card_type ρr],
    apply card_le_card, apply le_of_lt, apply typein_lt_type },
    rintro ⟨ξ, hξ⟩, refine lt_of_le_of_lt (sup_succ _) _,
    apply (ord_is_limit hθ.1).2, apply lt_of_not_ge, intro h,
    apply ρwo.wf.not_lt_min _ _ _ hξ, apply unbounded_range_of_sup_ge,
    dsimp, rw [←θtype_eq], exact h },
  let pick' : ∀(μ : θ), ∀(pick : ∀y, θr y μ → ι), ordinal :=
  λ μ pick, max α₀ $ sup.{u u} (λ x : ρ × {x // θr x μ}, typein θr $ nr (pick x.2.val x.2.2) x.1),
  have pick'_lt : ∀(μ : θ) (pick : ∀y, θr y μ → ι), pick' μ pick < type θr,
  { intros μ pick,
    apply max_lt hα₀,
    rw [←θtype_eq],
    apply sup_lt_ord_of_is_regular _ hθ,
    { apply @mul_lt_of_lt (mk ρ) (mk {x // θr x μ}) _ hθ.1 (lt_trans hρ hκθ),
      rw [←ord_lt_ord, θtype_eq], apply lt_of_le_of_lt (ord_le_type (subrel θr {x | θr x μ})),
      apply typein_lt_type },
    rintro ⟨x, y, hy⟩, rw [θtype_eq], apply typein_lt_type },
  have : ∀(x : θ), ∃i : ι, θr x (nr i ξ₀),
  { intro x, have : good ξ₀ := ρwo.wf.min_mem good _,
    have θr_unbounded : ∀(x : θ), ∃y, θr x y,
    { intro y, apply has_succ_of_is_limit, rw [←θtype_eq], exact ord_is_limit hθ.1 },
    cases θr_unbounded x with y hy,
    rcases this y with ⟨z, ⟨i, rfl⟩, hz⟩,
    use i, rcases trichotomous_of θr (nr i ξ₀) y with hw | rfl | hw,
    exfalso, exact hz hw, exact hy, exact trans hy hw },
  let pick : θ → ι := θwo.wf.fix
    (λ μ pick, classical.some $ this $ enum θr (pick' μ pick) (pick'_lt μ pick)),
  have lt_pick : ∀(μ : θ),
    θr (enum θr (pick' μ (λ y _, pick y)) (pick'_lt μ (λ y _, pick y))) (nr (pick μ) ξ₀),
  { intro μ, dsimp [pick], rw [θwo.wf.fix_eq _ μ], apply classical.some_spec (this _) },
  have pick_lt_pick : ∀{μ ν : θ} (h : θr ν μ) (η : ρ),
    θr (nr (pick ν) η) (nr (pick μ) ξ₀),
  { intros, apply trans_trichotomous_left _ (lt_pick μ), rw [←typein_le_typein, typein_enum],
    refine le_trans _ (le_max_right _ _), refine le_trans _ (le_sup _ ⟨η, ν, h⟩), refl },
  let sub_α₀ : set θ := typein θr ⁻¹' {c | c < α₀},
  have h1sub_α₀ : mk ↥sub_α₀ = α₀.card,
  { rw [←cardinal.lift_inj.{_ u+1}, mk_preimage_of_injective_of_subset_range_lift],
    rw [mk_initial_seg, cardinal.lift_lift],
    exact injective_typein θr,
    intros o ho,
    rcases typein_surj θr (lt_trans ho hα₀) with ⟨_, rfl⟩,
    apply mem_range_self },
  have h2A2' : ∀{x y : θ}, θr x y → A (pick x) ∩ A (pick y) ⊆ sub_α₀,
  { rintros x y hxy z ⟨hzx, hzy⟩,
    let η := typein (subrel θr $ A $ pick y) ⟨z, hzy⟩,
    have η_def : z = (enum (subrel θr $ A $ pick y) η (typein_lt_type _ _)).val, {rw [enum_typein]},
    cases lt_or_ge η (typein ρr ξ₀) with h h,
    { rw [mem_preimage, mem_set_of_eq],
      refine lt_of_lt_of_le _ (ordinal.le_sup _ _),
      { refine ⟨enum ρr η (lt_trans h (typein_lt_type _ _)), _⟩,
        rw [←typein_lt_typein ρr, typein_enum], exact h },
      refine lt_of_lt_of_le _ (ordinal.le_sup _ (pick y)),
      convert lt_succ_self (typein θr z), rw [η_def],
      dsimp [nr], congr' 1, apply order_iso_enum' (h2A _) },
    exfalso,
    have η_lt : η < type ρr,
    { convert typein_lt_type (subrel θr $ A $ pick y) ⟨z, hzy⟩ using 1, apply quotient.sound,
      exact ⟨h2A (pick y)⟩ },
    have : ¬ρr (enum ρr η η_lt) ξ₀, { rw [←typein_le_typein, typein_enum], exact h },
    apply this,
    rw [(h2A (pick y)).ord], dsimp only [subrel, order.preimage],
    convert pick_lt_pick hxy ((h2A (pick x)).symm ⟨z, hzx⟩) using 1,
    transitivity z, { rw [η_def], congr' 1, apply order_iso_enum (h2A _) },
    transitivity subtype.val ⟨z, hzx⟩, refl,
    congr' 1, symmetry, apply equiv.right_inv },
  have h1A2 : mk (range pick) = mk θ,
  { have increasing_pick : ∀{{x y : θ}}, θr x y → θr (nr (pick x) ξ₀) (nr (pick y) ξ₀),
    { intros x y hxy, apply pick_lt_pick hxy ξ₀ },
    have injective_pick : injective pick,
    { intros x y hx, apply injective_of_increasing _ _ _ increasing_pick, dsimp only,
      congr' 1, exact hx },
    rw [mk_range_eq], apply injective_pick },
  have h2A2 : ∀(x y : range pick), x ≠ y → A x ∩ A y ⊆ sub_α₀,
  { rintro ⟨_, ⟨x, rfl⟩⟩ ⟨_, ⟨y, rfl⟩⟩ hxy,
    rcases trichotomous_of θr x y with h | h | h,
    apply h2A2' h,
    exfalso, apply hxy, rw h,
    rw [inter_comm], apply h2A2' h },
  have hsub_α₀ : mk ↥sub_α₀ < mk θ,
  { rw [h1sub_α₀, ←ord_lt_ord, θtype_eq], refine lt_of_le_of_lt (ord_card_le _) hα₀ },
  let codomain := {s : set θ // s ⊆ sub_α₀ ∧ mk s ≤ mk ρ},
  have hcodomain : ∀(x : range pick), A x ∩ sub_α₀ ⊆ sub_α₀ ∧ mk (↥(A x ∩ sub_α₀)) ≤ mk ρ,
  { have α₀_lt_pick : ∀(μ : θ), θr (enum θr α₀ hα₀) (nr (pick μ) ξ₀),
    { intro μ, apply trans_trichotomous_left _ (lt_pick μ), rw enum_le_enum, apply le_max_left },
    rintro ⟨s, hs⟩, refine ⟨inter_subset_right _ _, _⟩,
    rcases hs with ⟨μ, rfl⟩, dsimp,
    transitivity mk {x : A (pick μ) // typein θr x.1 < α₀},
    { apply le_of_eq, apply mk_sep },
    let f := (h2A (pick μ)).to_equiv,
    rw [mk_subtype_of_equiv _ f.symm],
    transitivity mk { x : ρ // ρr x ξ₀},
    { apply mk_subtype_mono, intros x hx,
      rw [(h2A (pick μ)).ord], dsimp only [subrel, order.preimage],
      refine trans _ (α₀_lt_pick μ),
      rw [←enum_typein' θr (f x).val, @enum_lt _ θr], exact hx },
    transitivity (typein ρr ξ₀).card, { rw [typein, card_type], refl },
    rw [←card_type ρr], apply card_le_card, apply le_of_lt, apply typein_lt_type },
  let f : range pick → codomain := λx, ⟨A x.1 ∩ sub_α₀, hcodomain x⟩,
  have : ∃r (t : set ι), r ⊆ sub_α₀ ∧ t ⊆ range pick ∧ mk t = mk θ ∧ ∀{{x}}, x ∈ t → A x ∩ sub_α₀ = r,
  { have h1 : cardinal.omega ≤ mk (range pick), { rw [h1A2], exact hθ.1 },
    have h2 : mk codomain < cof (ord $ mk $ range pick),
    { rw [h1A2, hθ.2],
      apply lt_of_le_of_lt (mk_bounded_subset_le _ _),
      refine lt_of_le_of_lt (le_powerlt hρ) (hθ_le _ _),
      apply max_lt hsub_α₀ (lt_of_le_of_lt hκ hκθ) },
    cases infinite_pigeonhole f h1 h2 with r' hr',
    refine ⟨r'.val, subtype.val '' (f ⁻¹' {r'}), _, _, _, _⟩,
    { rintro x hx, exact r'.2.1 hx },
    { rintro _ ⟨⟨x, hx⟩, _, rfl⟩, exact hx },
    { rw [mk_image_eq subtype.val_injective, ←h1A2, ←hr'] },
    { rintro _ ⟨⟨x, hx⟩, hx', rfl⟩,
      simpa only [set.mem_singleton_iff, set.mem_preimage, f, subtype.ext] using hx' }},
  rcases this with ⟨r, t, hr, h1t, h2t, h3t⟩,
  refine ⟨t, h2t, r, _⟩,
  intros x y hxy, rw [←h3t x.2], apply set.ext, intro z, split,
  { intro hz, refine ⟨hz.1, h2A2 ⟨x, h1t x.2⟩ ⟨y, h1t y.2⟩ _ hz⟩,
    intro h, apply hxy, apply subtype.eq, apply congr_arg subtype.val h },
  intro hz, refine ⟨hz.1, _⟩, rw [h3t x.2, ←h3t y.2] at hz, exact hz.1
end

open_locale classical
lemma delta_system_lemma_1 {κ : cardinal} (hκ : cardinal.omega ≤ κ)
  {θ : Type u} (θr : θ → θ → Prop) [θwo : is_well_order θ θr] (hκθ : κ < mk θ)
  (hθ : is_regular $ mk θ) (θtype_eq : ord (mk θ) = type θr) (hθ_le : ∀(β < mk θ), β ^< κ < mk θ)
  {ρ : Type u} (ρr : ρ → ρ → Prop) [ρwo : is_well_order ρ ρr] (hρ : mk ρ < κ)
  {ι : Type u} {A : ι → set θ} (h2A : ∀i, ρr ≃o subrel θr (A i)) (hι : mk θ = mk ι) :
    ∃(t : set ι), mk t = mk θ ∧ is_delta_system (restrict A t) :=
begin
  by_cases h3A : unbounded θr (⋃i, A i),
  { exact delta_system_lemma_2 hκ θr hκθ hθ θtype_eq hθ_le ρr hρ h2A h3A },
  rw [not_unbounded_iff] at h3A, cases h3A with μ hμ,
  let γ := ⋃i, A i,
  let A' : @set.univ ι → {s : set θ // s ⊆ γ ∧ mk s ≤ mk ρ} :=
  λx, ⟨restrict A set.univ x, subset_Union A x.1, _⟩,
  swap, { apply le_of_eq, apply quotient.sound, exact ⟨(h2A x.1).to_equiv.symm⟩ },
  rcases infinite_pigeonhole_set A' (mk θ) _ hθ.1 _ with ⟨R, t, h₁t, h₂t, h₃t⟩,
  have : ∀(x : t), restrict A t x = R.1 := λ x, congr_arg subtype.val (h₃t x.2),
  refine ⟨t, _, R.1, _⟩,
  { apply le_antisymm _ h₂t, rw [hι], apply mk_set_le },
  { intros i j hij, rw [this i, this j, inter_self] },
  { rw [mk_univ, hι] },
  refine lt_of_le_of_lt (mk_bounded_subset_le _ _) _, refine lt_of_le_of_lt (le_powerlt hρ) _,
  rw [hθ.2], apply hθ_le, apply max_lt _ (lt_of_le_of_lt hκ hκθ),
  rw [←ord_lt_ord, θtype_eq],
  apply lt_of_le_of_lt _ (typein_lt_type θr μ),
  rw [ord_le, typein, card_type], apply mk_le_mk_of_subset hμ
end

/-- The delta-system lemma. [Kunen 1980, Theorem 1.6, p49] -/
theorem delta_system_lemma {α ι : Type u} {κ θ : cardinal} (hκ : cardinal.omega ≤ κ) (hκθ : κ < θ)
  (hθ : is_regular θ) (hθ_le : ∀(c < θ), c ^< κ < θ) (A : ι → set α)
  (hA : θ ≤ mk ι) (h2A : ∀i, mk (A i) < κ) :
  ∃(t : set ι), mk t = θ ∧ is_delta_system (restrict A t) :=
begin
  revert hθ hθ_le hκ hκθ hA h2A, refine quotient.induction_on θ _, clear θ, intro θ, intros,
  rcases ord_eq θ with ⟨θr, θwo, θtype_eq⟩,
  rcases le_mk_iff_exists_set.mp hA with ⟨t₁, ht₁⟩,
  resetI,
  let β := ⋃(i ∈ t₁), A i,
  have hβ : mk β ≤ mk θ,
  { refine le_trans (mk_bUnion_le _ _) _, rw [ht₁],
    refine le_trans (mul_le_max_of_omega_le_left _) _, exact hθ.1,
    apply max_le, refl, rw [cardinal.sup_le],
    intro i, apply le_of_lt, apply lt_trans (h2A i.1) hκθ },
  have h2β : A '' t₁ ⊆ powerset (range (subtype.val : β → α)),
  { rintro _ ⟨i, hi, rfl⟩ x hx, refine ⟨⟨x, mem_bUnion hi hx⟩, rfl⟩ },
  have f : β ↪ θ, { exact (classical.choice hβ) },
  let A₀ : ι → set θ := image f ∘ preimage subtype.val ∘ A,
  let κα := κ.ord.out.α,
  let κr := κ.ord.out.r,
  have h3A₀ : ∀(i : t₁), type (subrel θr (A₀ i)) < type κr,
  { rintro ⟨i, hi⟩, rw [type_out, lt_ord, card_type],
    rw [mk_image_eq], rw [mk_preimage_of_injective_of_subset_range], apply h2A i,
    apply subtype.val_injective, apply h2β (mem_image_of_mem _ hi), exact f.2 },
  have hκθ' : mk κα < cof (ord (mk θ)),
  { rw [←card_type κr, type_out, card_ord], convert hκθ, exact hθ.2 },
  let g : t₁ → κα := λ i : t₁, enum κr (type (subrel θr (A₀ i))) (h3A₀ i),
  rcases infinite_pigeonhole_set g (mk θ) (ge_of_eq ht₁) hθ.1 hκθ' with ⟨ρ', t₂, ht₂, h2t₂, h3t₂⟩,
  let ρ := { x : κα | κr x ρ' },
  let ρr := subrel κr ρ,
  have hρ : mk ρ < κ, { exact card_typein_out_lt κ ρ', },
  have h4A₁ : Π(i : t₂), ρr ≃o subrel θr (A₀ i),
  { rintro ⟨i, hi⟩, symmetry,
    have : type (subrel θr (A₀ i)) = typein κr ρ', { rw [← h3t₂ hi, typein_enum], refl },
    exact classical.choice (quotient.exact this) },
  have h4t₂ : mk θ = mk ↥t₂,
  { apply le_antisymm h2t₂, convert mk_le_mk_of_subset ht₂ using 1, rw ht₁, refl },
  rcases delta_system_lemma_1 hκ θr hκθ hθ θtype_eq hθ_le ρr hρ h4A₁ h4t₂ with ⟨t, h1t, h2t⟩,
  refine ⟨subtype.val '' t, _, _⟩,
  { rw [mk_image_eq], exact h1t, exact subtype.val_injective },
  have : is_delta_system (λ(i : t), A₀ i.1) := h2t,
  rw [is_delta_system_image, is_delta_system_preimage_iff] at this,
  rw [is_delta_system_precompose_iff (equiv.set.image subtype.val t subtype.val_injective)],
  convert this using 1, apply funext, rintro ⟨⟨i, hi⟩, h2i⟩,
  simp only [function.comp_app, subtype.coe_mk, equiv.set.image_apply, restrict],
  apply subtype.val_injective, intro i, refine h2β (mem_image_of_mem _ $ ht₂ i.1.2), exact f.2
end

theorem delta_system_lemma_uncountable {α : Type u} {ι : Type v}
  (A : ι → set α) (h : cardinal.omega < mk ι) (h2A : ∀i, finite (A i)) :
  ∃(t : set ι), cardinal.omega < mk t ∧ is_delta_system (restrict A t) :=
begin
  have :  ∀ (c : cardinal), c < succ omega → c ^< omega < succ omega,
  { intros c hc, refine lt_of_le_of_lt (powerlt_omega_le _) _,
    apply max_lt hc (lt_succ_self _) },
  rcases delta_system_lemma (le_refl _) (lt_succ_self _) (succ_is_regular (le_refl _)) this
    (image ulift.up.{v u} ∘ A ∘ ulift.down.{u v}) _ _ with ⟨t, h1t, h2t⟩,
  refine ⟨ulift.down '' t, _, _⟩,
  { rw [←cardinal.lift_lt.{_ max u v}, mk_image_eq_lift, h1t, cardinal.lift_succ,
      cardinal.lift_omega, cardinal.lift_omega], apply cardinal.lt_succ_self,
      apply equiv.ulift.bijective.1 },
  { rw [restrict, is_delta_system_image] at h2t, swap, exact equiv.ulift.symm.bijective.1,
    rw [is_delta_system_precompose_iff (equiv.set.image _ _ _)],
    swap, exact equiv.ulift.bijective.1,
    convert h2t, apply funext, rintro ⟨x, hx⟩, refl },
  { rw [←cardinal.lift_lt, cardinal.lift_omega, ←cardinal.succ_le] at h, exact h },
  rintro ⟨i⟩, rw [lt_omega_iff_finite], apply finite_image, exact h2A i
end

end delta_system

namespace set

variables {α β : Type u}
open cardinal subtype

/- currently the proof depends on cardinal numbers -/
lemma finite_of_finite_image_of_inj_on (f : α → β) (s : set α) (hf : inj_on f s)
  (h : finite (f '' s)) : finite s :=
by { rw [←lt_omega_iff_finite] at h ⊢, rwa [mk_image_eq_of_inj_on f s hf] at h }

/- currently the proof depends on cardinal numbers -/
lemma countable_of_embedding {s : set α} {t : set β} (f : s ↪ t) (h : countable t) : countable s :=
begin
  rw [countable_iff], rw [countable_iff] at h,
  refine le_trans _ h, refine ⟨f⟩
end

/- maybe generalize eq_on -/
def eq_on' {α} {β : α → Type*} (f g : ∀x, β x) (s : set α) : Prop :=
∀{{x}}, x ∈ s → f x = g x

lemma eq_on'_iff {α} {β : α → Type*} (f g : ∀x, β x) (s : set α) :
  eq_on' f g s ↔ restrict f s = restrict g s :=
begin
  split, intros h, apply funext, rintro ⟨x, hx⟩, exact h hx,
  intros h x hx, apply congr_fun h ⟨x, hx⟩
end

end set

-- namespace topological_space

open set topological_space cardinal subtype (restrict)

section CCC
variables (α : Type u) [topological_space α]

def countable_chain_condition : Prop :=
∀(s : set (set α)), (∀{{o}}, o ∈ s → is_open o) → pairwise_disjoint s → s.countable

variable {α}
lemma countable_chain_condition_of_nonempty
  (h : ∀(s : set (set α)), (∀{{o}}, o ∈ s → o ≠ ∅) → (∀{{o}}, o ∈ s → is_open o) →
  pairwise_disjoint s → s.countable) : countable_chain_condition α :=
begin
  intros s open_s hs,
  let s' : set (set α) := s \ {∅},
  have hs' : ∀{{o : set α}}, o ∈ s' → o ≠ ∅,
  { intros o ho h2o, apply ho.2, rw [mem_singleton_iff, h2o] },
  have open_s' : ∀{{o : set α}}, o ∈ s' → is_open o,
  { intros o ho, exact open_s (diff_subset _ _ ho), },
  have h2s' : pairwise_disjoint s',
  { refine pairwise_disjoint_subset _ hs, apply diff_subset },
  have : countable (insert ∅ s'), { apply countable_insert (h s' hs' open_s' h2s') },
  apply countable_subset _ this,
  rw [insert_diff_singleton], apply subset_insert
end

lemma countable_chain_condition_of_topological_basis (B : set (set α))
  (hB : is_topological_basis B)
  (h : ∀(s : set (set α)), s ⊆ B →
  pairwise_disjoint s → s.countable) : countable_chain_condition α :=
begin
  apply countable_chain_condition_of_nonempty,
  intros s s_nonempty s_open hs,
  have f : ∀(x : s), { y : set α // y ∈ B ∧ y ≠ ∅ ∧ y ⊆ x.1 },
  { rintro ⟨x, hx⟩, apply classical.subtype_of_exists,
    have : ∃y, y ∈ x, { exact ne_empty_iff_exists_mem.mp (s_nonempty hx) },
    cases this with y hy,
    rcases mem_basis_subset_of_mem_open hB hy (s_open hx) with ⟨h₁, h₂, h₃, h₄⟩,
    refine ⟨h₁, h₂, _, h₄⟩, rw [ne_empty_iff_exists_mem], exact ⟨_, h₃⟩ },
  let s' : set (set α) := range (λ(x : s), (f x).1),
  have hs' : ∀{{o : set α}}, o ∈ s' → o ∈ B,
  { rintro _ ⟨o, rfl⟩, exact (f o).2.1 },
  have h2s' : pairwise_disjoint s',
  { apply pairwise_disjoint_range _ _ hs, intro x, exact (f x).2.2.2 },
  have := h s' hs' h2s',
  rw [cardinal.countable_iff] at this ⊢, convert this using 1, rw [mk_range_eq],
  rintro x x' hxx',
  have : ∃y, y ∈ (f x).1, { exact ne_empty_iff_exists_mem.mp (f x).2.2.1 },
  cases this with y hy,
  apply subtype.eq, apply pairwise_disjoint_elim hs x.2 x'.2 y ((f x).2.2.2 hy),
  dsimp only at hxx', rw hxx' at hy, exact (f x').2.2.2 hy
end

lemma countable_chain_condition_of_separable_space [h : separable_space α] :
  countable_chain_condition α :=
begin
  have := h, rcases this with ⟨⟨D, h1D, h2D⟩⟩, rw [dense_iff_inter_open] at h2D,
  apply countable_chain_condition_of_nonempty, intros C h1C h2C h3C,
  refine countable_of_embedding _ h1D,
  have f : ∀(c : C), Σ'(d : D), d.1 ∈ c.1,
  { rintro ⟨s, hs⟩, have := h2D s (h2C hs) (h1C hs),
    rw [ne_empty_iff_exists_mem] at this,
    rcases classical.subtype_of_exists this with ⟨x, ⟨hx, h2x⟩⟩,
    exact ⟨⟨x, h2x⟩, hx⟩ },
  refine ⟨λ c, (f c).1, _⟩,
  rintros ⟨s, hs⟩ ⟨s', hs'⟩ hss',
  rw [subtype.ext], dsimp,
  apply pairwise_disjoint_elim h3C hs hs' (f ⟨s, hs⟩).1 (f ⟨s, hs⟩).2,
  dsimp only at hss', rw [hss'], exact (f ⟨s', hs'⟩).2
end

lemma countable_chain_condition_of_countable (h : mk α ≤ omega) : countable_chain_condition α :=
begin
  haveI : separable_space α := ⟨⟨set.univ, by rwa [countable_iff, mk_univ], closure_univ⟩⟩,
  apply countable_chain_condition_of_separable_space,
end

end CCC

section pi

variables {α : Type u} {β : α → Type v} [∀x, topological_space (β x)]
          {γ : Type w} [topological_space γ]

def standard_open {i : α} (o : opens (β i)) : set (Πx, β x) :=
{f : Πx, β x | f i ∈ o }

variable (β)
def pi_subbasis : set (set (Πx, β x)) :=
range (λ(x : Σ(i : α), opens (β i)), standard_open x.2)

variable {β}

variable (β)
lemma is_subbasis_pi : Pi.topological_space = generate_from (pi_subbasis β) :=
begin
  symmetry, apply le_antisymm,
  { refine lattice.le_infi _, intro i,
    rintro _ ⟨s, hs, rfl⟩, apply generate_open.basic, exact ⟨⟨i, s, hs⟩, rfl⟩ },
  { rw [le_generate_from_iff_subset_is_open], rintro _ ⟨⟨i, o, ho⟩, rfl⟩,
    apply generate_open.basic, apply mem_bUnion (mem_range_self i), exact ⟨o, ho, rfl⟩ }
end

def pi_basis : set (set (Πx, β x)) :=
(λf, ⋂₀ f) '' {f : set (set (Πx, β x)) | finite f ∧ f ⊆ pi_subbasis β ∧ ⋂₀ f ≠ ∅ }

lemma pi_basis_eq : pi_basis β =
  {g | ∃(s:Πx, set (β x)) (i : finset α), (∀x∈i, is_open (s x)) ∧ g = pi ↑i s} \ {∅} :=
begin
  apply subset.antisymm, swap,
  { rintro _ ⟨⟨s, i, hs, rfl⟩, hs'⟩,
    let O : (↑i : set α) → set (Πx, β x) := (λ x, standard_open ⟨s x.1, hs x.1 x.2⟩),
    have : ⋂₀ range O = pi ↑i s,
    { apply subset.antisymm,
      { rintro f hf x hx, exact hf (O ⟨x, hx⟩) (mem_range_self _) },
      { rintro f hf _ ⟨x, rfl⟩, exact hf x.1 x.2 } },
    refine ⟨range O, ⟨finite_range _, _, _⟩, this⟩,
    { rintro _ ⟨x, rfl⟩, dsimp only, refine ⟨⟨x.1, ⟨s x.1, hs x.1 x.2⟩⟩, rfl⟩ },
    { rw [this], exact mt mem_singleton_iff.mpr hs' } },
  rintro _ ⟨o, ⟨h1o, h2o, h3o⟩, rfl⟩, dsimp only, refine ⟨_, mt mem_singleton_iff.mp h3o⟩,
  rw [pi_subbasis, subset_range_iff] at h2o, rcases h2o with ⟨o', rfl, _⟩,
  let γ := Σi, opens (β i),
  let O := (λ (x : γ), standard_open (x.snd)),
  have hβ : nonempty (Πx, β x),
  { rw [←coe_nonempty_iff_ne_empty] at h3o, rcases h3o with ⟨f, hf⟩, exact ⟨f⟩ },
  have ho' : ∀(x ∈ o'), (x : γ).2.1 ≠ ∅,
  { rintros ⟨x, o⟩ ho, refine mt _ h3o, intro h,
    rw [eq_empty_iff_forall_not_mem], intros f hf, rw [eq_empty_iff_forall_not_mem] at h,
    apply h (f _), exact hf _ (mem_image_of_mem _ ho) },
  let o'' := {x ∈ o' | (x : γ).2.1 ≠ univ },
  let i := sigma.fst '' o'',
  have h2o' : finite o'',
  { refine finite_of_finite_image_of_inj_on O _ _ _,
    { haveI : decidable_eq α := λ _ _, classical.prop_decidable _,
      rintro ⟨x, o⟩ ⟨x', o'⟩ hx hx' hoo', cases hβ with f,
      have h₁ : nonempty o.1, { rw [coe_nonempty_iff_ne_empty], exact ho' _ hx.1 },
      have h₂ : nonempty (-o.1 : set (β x)), { rw [nonempty_compl], exact hx.2 },
      rcases h₁ with ⟨z₁, hz₁⟩, rcases h₂ with ⟨z₂, hz₂⟩,
      let f₁ : Πx', β x' := change f z₁,
      let f₂ : Πx', β x' := change f z₂,
      have hf₁ : f₁ ∈ O ⟨x, o⟩, { simp [O, standard_open, f₁, change], exact hz₁ },
      have hf₂ : f₂ ∉ O ⟨x, o⟩, { simp [O, standard_open, f₂, change], exact hz₂ },
      rw [hoo'] at hf₁ hf₂,
      have : x = x',
      { by_contradiction h',
        have : f₁ x' ≠ f₂ x', { refine mt _ hf₂,
        dsimp only [O, standard_open, mem_sep, mem_set_of_eq], intro h, rw ←h, exact hf₁ },
        apply this, simp [f₁, f₂, change, h'] },
      subst this, apply congr_arg (sigma.mk x), apply subtype.eq, apply set.ext, intro z,
      rw [set.ext_iff] at hoo',
      simpa [O, standard_open, change] using hoo' (change f z) },
    apply finite_subset h1o, apply image_subset, apply sep_subset } ,
  have hi : finite i,
  { refine finite_image _  h2o' },
  haveI : ∀x, decidable (x ∈ i) := λ x, classical.prop_decidable _,
  let C : Πx, set (β x) :=
  λ x, if h : x ∈ i then ⋂₀ { O | ∃h : _root_.is_open O, (⟨x, ⟨O, h⟩⟩ : γ) ∈ o'' } else univ,
  refine ⟨C, finite.to_finset hi, _, _⟩,
  { intros x hx, rw [finite.mem_to_finset] at hx, have := hx,
    rcases this with ⟨⟨x, u⟩, ⟨hu, hu'⟩, rfl⟩,
    simp only [C, dif_pos hx],
    apply is_open_sInter,
    { have : finite (subtype.val '' ((λ s : opens (β x), sigma.mk x s) ⁻¹' o'')),
      { apply finite_image, apply finite_preimage _ h2o', finish },
      convert this,
      apply subset.antisymm,
      { rintro o ⟨h1o, h2o⟩, exact ⟨⟨o, h1o⟩, h2o, rfl⟩ },
      rintro _ ⟨⟨o, ho⟩, h2o, rfl⟩, refine ⟨ho, h2o⟩ },
    rintro s ⟨hs, hs'⟩, exact hs },
  apply subset.antisymm,
  { rintro f hf x hx, rw [finite.coe_to_finset] at hx, have := hx,
    rcases this with ⟨⟨x, o⟩, ⟨ho, h2o⟩, rfl⟩,
    simp only [C, dif_pos hx], rintro s ⟨hs, h2s⟩,
    exact hf _ (mem_image_of_mem _ h2s.1) },
  rintro f hf _ ⟨⟨x, o⟩, ho, rfl⟩, dsimp [standard_open], rw [finite.coe_to_finset] at hf,
  haveI : decidable (o.1 = univ) := classical.prop_decidable _,
  by_cases ho' : o.1 = univ, { rw [mem_opens, ho'], apply mem_univ },
  have hx : x ∈ i, { refine ⟨⟨x, o⟩, ⟨ho, ho'⟩, rfl⟩ },
  have : C x ⊆ o.1,
  { cases o with o h2o, simp only [C, dif_pos hx], rintro z hz, exact hz o ⟨h2o, ⟨ho, ho'⟩⟩ },
  exact this (hf x hx),
end

variable {β}

lemma nonempty_of_mem_pi_basis {o : set (Πx, β x)} (h : o ∈ pi_basis β) : nonempty o :=
by { rcases h with ⟨o, ho, rfl⟩, rw [coe_nonempty_iff_ne_empty], exact ho.2.2 }

variable (β)
lemma is_topological_basis_pi : is_topological_basis (pi_basis β) :=
is_topological_basis_of_subbasis (is_subbasis_pi β)

variable {β}

open_locale classical
lemma is_open_map_apply (i : α) : is_open_map (λf : Πi, β i, f i) :=
begin
  apply is_open_map_of_is_topological_basis (is_topological_basis_pi β),
  intros o ho,
  rw [pi_basis_eq] at ho, rcases ho with ⟨⟨s, t, hs, rfl⟩, hs'⟩,
  have : nonempty (pi ↑t s), { rw [←nmem_singleton_empty], exact hs' },
  by_cases i ∈ t, { rw [image_pi_pos ↑t s this i h], exact hs i h },
  rw [image_pi_neg ↑t s this i h], exact is_open_univ
end

lemma restrict_image_pi (t : set α) (s : set α) (s' : Πi, set (β i))
  (h : nonempty (pi t s')) :
  (λ(f : Πi, β i), restrict f s) '' pi t s' = pi (subtype.val ⁻¹' t) (λi, s' i.1) :=
begin
  apply subset.antisymm,
  { rintro _ ⟨f, hf, rfl⟩ i hi, exact hf _ hi },
  rintro f hf, have := h, rcases this with ⟨f', hf'⟩,
  refine ⟨λ i, if h : i ∈ s then f ⟨i, h⟩ else f' i, _, _⟩,
  { intros i hi, dsimp only,
    by_cases h2i : i ∈ s,
    { rw [dif_pos h2i], exact hf ⟨i, h2i⟩ hi, },
    { rw [dif_neg h2i], exact hf' i hi } },
  apply funext, rintro ⟨i, hi⟩, dsimp only, rw [restrict], apply dif_pos hi
end

lemma is_open_map_restrict (s : set α) : is_open_map (λ(f : Πi, β i), restrict f s) :=
begin
  apply is_open_map_of_is_topological_basis (is_topological_basis_pi β),
  intros o ho,
  rw [pi_basis_eq] at ho, rcases ho with ⟨⟨s', t, hs, rfl⟩, hs'⟩,
  have : nonempty (pi ↑t s'), { rw [←nmem_singleton_empty], exact hs' },
  rw [restrict_image_pi _ _ _ this],
  apply is_open_of_is_topological_basis (is_topological_basis_pi _),
  rw [pi_basis_eq], refine ⟨⟨λ x, s' x.1, _, _, _⟩, _⟩,
  { apply finite.to_finset, apply finite_preimage (inj_on_of_injective _ subtype.val_injective),
    exact t.finite_to_set },
  { intros x hx, rw [finite.mem_to_finset] at hx, exact hs _ hx },
  { congr' 1, ext, rw [finite.coe_to_finset] },
  dsimp only, rw [nmem_singleton_empty],
  rcases this with ⟨f, hf⟩, exact ⟨⟨λ i, f i.1, λ i hi, hf i.1 hi⟩⟩
end

/- The set of indices where a set o is constant, i.e. that coordinate doesn't matter for
  deciding whether a point is in o -/
def support (o : set (Πx, β x)) : set α :=
⋂₀ { s : set α | ∀{{f g : Πi, β i}}, eq_on' f g s → f ∈ o → g ∈ o }

lemma support_pi (i : set α) (s : ∀x, set (β x)) (h : nonempty $ pi i s) :
  support (pi i s) = {x ∈ i | s x ≠ set.univ } :=
begin
  apply subset.antisymm,
  { apply sInter_subset_of_mem, intros f g hfg hf x hx,
    by_cases h : s x = univ, rw [h], trivial,
    rw [←hfg ⟨hx, h⟩], exact hf x hx },
  { apply subset_sInter, rintro j hj x ⟨hx, hs⟩,
    have := h, rcases this with ⟨f, hf⟩,
    have h₂ : nonempty (-(s x) : set _), { rw [nonempty_compl], exact hs },
    rcases h₂ with ⟨z₂, hz₂⟩,
    let f₂ : Πx', β x' := change f z₂,
    have hf₂ : f₂ ∉ pi i s, { refine mt _ hz₂, intro hf₂, convert hf₂ x hx,
    simp only [f₂, change, dif_pos] },
    by_contradiction h2x, apply hf₂, apply hj _ hf,
    intros x' hx',
    have hxx' : x ≠ x', { refine mt _ h2x, intro h, rw h, exact hx' },
    simp only [f₂, change, dif_neg hxx'] }
end

lemma support_elim {o : set (Πx, β x)} {f g : Πx, β x} (ho : o ∈ pi_basis β)
  (h : eq_on' f g (support o)) (hf : f ∈ o) : g ∈ o :=
begin
  rw [pi_basis_eq] at ho, rcases ho with ⟨⟨s, i, hs, rfl⟩, hs'⟩,
  have : nonempty (pi ↑i s), { rw [←nmem_singleton_empty], exact hs' },
  intros x hx, rw [support_pi _ _ this] at h,
  by_cases h' : s x = univ, rw [h'], trivial,
  rw [← h ⟨hx, h'⟩], exact hf x hx
end

lemma finite_support_of_pi_subbasis {o : set (Πx, β x)} (h : o ∈ pi_subbasis β) :
  finite (support o) :=
begin
  rcases h with ⟨⟨i, o⟩, rfl⟩,
  apply finite_subset (finite_singleton i),
  apply sInter_subset_of_mem, dsimp [standard_open],
  intros f g hfg hf, rwa [hfg (mem_singleton i)] at hf
end

lemma finite_support_of_pi_basis {o : set (Πx, β x)} (h : o ∈ pi_basis β) :
  finite (support o) :=
begin
  rcases h with ⟨s, ⟨hs, h2s, h3s⟩, rfl⟩,
  apply finite_subset (finite_bUnion' support hs $ λ i hi, finite_support_of_pi_subbasis $ h2s hi),
  apply sInter_subset_of_mem, dsimp only, intros f g hfg hf,
  intros t ht,
  apply support_elim _ _ (hf t ht),
  { apply subbasis_subset_basis, split,
    exact h2s ht, refine mt _ h3s, rw [mem_singleton_iff], rintro rfl,
    refine subset.antisymm _ (empty_subset _), exact sInter_subset_of_mem ht },
  intros x hx, apply hfg, exact mem_bUnion ht hx
end

def extend (g₁ g₂ : Πx, β x) (s : set α) (x : α) : β x :=
if h : x ∈ s then g₁ x else g₂ x

open delta_system
theorem countable_chain_condition_pi
  (h : ∀(s : set α), finite s → countable_chain_condition (Π(x : s), β x)) :
  countable_chain_condition (Πx, β x) :=
begin
  apply countable_chain_condition_of_topological_basis _ (is_topological_basis_pi β),
  intros C hC h2C, rw [countable_iff], apply le_of_not_gt, intro h3C,
  let A : C → set α := λ s, support s.1,
  have h2A : ∀ (s : C), finite (A s),
  { rintro ⟨s, hs⟩, apply finite_support_of_pi_basis, exact hC hs },
  rcases delta_system_lemma_uncountable A h3C h2A with ⟨C', h1C', ⟨R, hR⟩⟩,
  have h3A' : 2 ≤ mk C',
    { apply le_of_lt, refine lt_trans _ h1C', convert cardinal.nat_lt_omega 2,
      rw [nat.cast_bit0, nat.cast_one] },
  have h2R : finite R,
  { apply finite_root h3A' _ hR, intro s, exact h2A s.1 },
  let C'' := subtype.val '' C',
  have hC'' : C'' ⊆ C, { rintro _ ⟨⟨x, hx⟩, h2x, rfl⟩, exact hx },
  let π : (Πx, β x) → Π(x : R), β x := λ f, restrict f R,
  let D : set (set (Π(x : R), β x)) := image π '' C'',
  have hD : ∀ ⦃o : set (Π (x : R), β x)⦄, o ∈ D → is_open o,
  { rintro _ ⟨o, ho, rfl⟩, apply is_open_map_restrict,
    apply is_open_of_is_topological_basis (is_topological_basis_pi β) (hC $ hC'' ho) },
  have h2'D : ∀(s t : set (Πx, β x)), s ∈ C'' → t ∈ C'' → s ≠ t → disjoint (π '' s) (π '' t),
  { rintro s t hs ht hst,
    rw [disjoint_iff_eq_empty, eq_empty_iff_forall_not_mem],
    rintro f ⟨hfs, hft⟩,
    have := h2C _ (hC'' hs) _ (hC'' ht) (λ h, hst $ by rw h),
    rcases hfs with ⟨g₁, hg₁, rfl⟩,
    rcases hft with ⟨g₂, hg₂, hg⟩,
    rw [disjoint_iff_eq_empty, eq_empty_iff_forall_not_mem] at this,
    apply this (extend g₁ g₂ (support s)),
    split, { apply support_elim (hC (hC'' hs)) _ hg₁, intros x hx, rw [extend, dif_pos hx] },
    apply support_elim (hC (hC'' ht)) _ hg₂, intros x hx,
    by_cases x ∈ support s,
    { rw [extend, dif_pos h], rw [←eq_on'_iff] at hg, apply hg,
      rcases hs with ⟨s', hs', rfl⟩, rcases ht with ⟨t', ht', rfl⟩,
      rw [←@hR ⟨s', hs'⟩ ⟨t', ht'⟩], exact ⟨h, hx⟩, intro h, apply hst,
      apply congr_arg subtype.val (congr_arg subtype.val h) },
    rw [extend, dif_neg h] },
  have h2D : pairwise_disjoint D,
  { rintro _ ⟨s, hs, rfl⟩ _ ⟨t, ht, rfl⟩ hst, apply h2'D s t hs ht, intro h, apply hst, rw h },
  have h3D : cardinal.omega < mk D,
  { rw [mk_image_eq_of_inj_on, mk_image_eq], exact h1C',
    apply subtype.val_injective,
    intros s t hs ht hst, by_contradiction hst',
    apply ne_of_disjoint _ (h2'D s t hs ht hst') hst,
    apply coe_nonempty_iff_ne_empty.mp,
    apply nonempty_image, apply nonempty_of_mem_pi_basis (hC $ hC'' hs) },
  apply not_le_of_gt h3D, rw [←countable_iff], exact h R h2R D hD h2D
end

end pi


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module analysis.box_integral.divergence_theorem
! leanprover-community/mathlib commit f2ce6086713c78a7f880485f7917ea547a215982
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.BoxIntegral.Basic
import Mathbin.Analysis.BoxIntegral.Partition.Additive
import Mathbin.Analysis.Calculus.Fderiv

/-!
# Divergence integral for Henstock-Kurzweil integral

In this file we prove the Divergence Theorem for a Henstock-Kurzweil style integral. The theorem
says the following. Let `f : ℝⁿ → Eⁿ` be a function differentiable on a closed rectangular box
`I` with derivative `f' x : ℝⁿ →L[ℝ] Eⁿ` at `x ∈ I`. Then the divergence `λ x, ∑ k, f' x eₖ k`,
where `eₖ = pi.single k 1` is the `k`-th basis vector, is integrable on `I`, and its integral is
equal to the sum of integrals of `f` over the faces of `I` taken with appropriate signs.

To make the proof work, we had to ban tagged partitions with “long and thin” boxes. More precisely,
we use the following generalization of one-dimensional Henstock-Kurzweil integral to functions
defined on a box in `ℝⁿ` (it corresponds to the value `box_integral.integration_params.GP = ⊥` of
`box_integral.integration_params` in the definition of `box_integral.has_integral`).

We say that `f : ℝⁿ → E` has integral `y : E` over a box `I ⊆ ℝⁿ` if for an arbitrarily small
positive `ε` and an arbitrarily large `c`, there exists a function `r : ℝⁿ → (0, ∞)` such that for
any tagged partition `π` of `I` such that

* `π` is a Henstock partition, i.e., each tag belongs to its box;
* `π` is subordinate to `r`;
* for every box of `π`, the maximum of the ratios of its sides is less than or equal to `c`,

the integral sum of `f` over `π` is `ε`-close to `y`. In case of dimension one, the last condition
trivially holds for any `c ≥ 1`, so this definition is equivalent to the standard definition of
Henstock-Kurzweil integral.

## Tags

Henstock-Kurzweil integral, integral, Stokes theorem, divergence theorem
-/

open Classical BigOperators NNReal ENNReal Topology BoxIntegral

open ContinuousLinearMap (lsmul)

open Filter Set Finset Metric

open BoxIntegral.IntegrationParams (gP gP_le)

noncomputable section

universe u

variable {E : Type u} [NormedAddCommGroup E] [NormedSpace ℝ E] {n : ℕ}

namespace BoxIntegral

-- mathport name: «exprℝⁿ»
local notation "ℝⁿ" => Fin n → ℝ

-- mathport name: «exprℝⁿ⁺¹»
local notation "ℝⁿ⁺¹" => Fin (n + 1) → ℝ

-- mathport name: «exprEⁿ⁺¹»
local notation "Eⁿ⁺¹" => Fin (n + 1) → E

variable [CompleteSpace E] (I : Box (Fin (n + 1))) {i : Fin (n + 1)}

open MeasureTheory

/-- Auxiliary lemma for the divergence theorem. -/
theorem norm_volume_sub_integral_face_upper_sub_lower_smul_le {f : ℝⁿ⁺¹ → E} {f' : ℝⁿ⁺¹ →L[ℝ] E}
    (hfc : ContinuousOn f I.Icc) {x : ℝⁿ⁺¹} (hxI : x ∈ I.Icc) {a : E} {ε : ℝ} (h0 : 0 < ε)
    (hε : ∀ y ∈ I.Icc, ‖f y - a - f' (y - x)‖ ≤ ε * ‖y - x‖) {c : ℝ≥0} (hc : I.distortion ≤ c) :
    ‖(∏ j, I.upper j - I.lower j) • f' (Pi.single i 1) -
          (integral (I.face i) ⊥ (f ∘ i.insertNth (I.upper i)) BoxAdditiveMap.volume -
            integral (I.face i) ⊥ (f ∘ i.insertNth (I.lower i)) BoxAdditiveMap.volume)‖ ≤
      2 * ε * c * ∏ j, I.upper j - I.lower j :=
  by
  /- **Plan of the proof**. The difference of the integrals of the affine function
    `λ y, a + f' (y - x)` over the faces `x i = I.upper i` and `x i = I.lower i` is equal to the
    volume of `I` multiplied by `f' (pi.single i 1)`, so it suffices to show that the integral of
    `f y - a - f' (y - x)` over each of these faces is less than or equal to `ε * c * vol I`. We
    integrate a function of the norm `≤ ε * diam I.Icc` over a box of volume
    `∏ j ≠ i, (I.upper j - I.lower j)`. Since `diam I.Icc ≤ c * (I.upper i - I.lower i)`, we get the
    required estimate.  -/
  have Hl : I.lower i ∈ Icc (I.lower i) (I.upper i) := Set.left_mem_Icc.2 (I.lower_le_upper i)
  have Hu : I.upper i ∈ Icc (I.lower i) (I.upper i) := Set.right_mem_Icc.2 (I.lower_le_upper i)
  have Hi :
    ∀ x ∈ Icc (I.lower i) (I.upper i),
      Integrable.{0, u, u} (I.face i) ⊥ (f ∘ i.insert_nth x) box_additive_map.volume :=
    fun x hx => integrable_of_continuous_on _ (box.continuous_on_face_Icc hfc hx) volume
  /- We start with an estimate: the difference of the values of `f` at the corresponding points
    of the faces `x i = I.lower i` and `x i = I.upper i` is `(2 * ε * diam I.Icc)`-close to the value
    of `f'` on `pi.single i (I.upper i - I.lower i) = lᵢ • eᵢ`, where `lᵢ = I.upper i - I.lower i`
    is the length of `i`-th edge of `I` and `eᵢ = pi.single i 1` is the `i`-th unit vector. -/
  have :
    ∀ y ∈ (I.face i).Icc,
      ‖f' (Pi.single i (I.upper i - I.lower i)) -
            (f (i.insert_nth (I.upper i) y) - f (i.insert_nth (I.lower i) y))‖ ≤
        2 * ε * diam I.Icc :=
    by
    intro y hy
    set g := fun y => f y - a - f' (y - x) with hg
    change ∀ y ∈ I.Icc, ‖g y‖ ≤ ε * ‖y - x‖ at hε
    clear_value g
    obtain rfl : f = fun y => a + f' (y - x) + g y := by simp [hg]
    convert_to‖g (i.insert_nth (I.lower i) y) - g (i.insert_nth (I.upper i) y)‖ ≤ _
    · congr 1
      have := Fin.insertNth_sub_same i (I.upper i) (I.lower i) y
      simp only [← this, f'.map_sub]
      abel
    · have : ∀ z ∈ Icc (I.lower i) (I.upper i), i.insert_nth z y ∈ I.Icc := fun z hz =>
        I.maps_to_insert_nth_face_Icc hz hy
      replace hε : ∀ y ∈ I.Icc, ‖g y‖ ≤ ε * diam I.Icc
      · intro y hy
        refine' (hε y hy).trans (mul_le_mul_of_nonneg_left _ h0.le)
        rw [← dist_eq_norm]
        exact dist_le_diam_of_mem I.is_compact_Icc.bounded hy hxI
      rw [two_mul, add_mul]
      exact norm_sub_le_of_le (hε _ (this _ Hl)) (hε _ (this _ Hu))
  calc
    ‖(∏ j, I.upper j - I.lower j) • f' (Pi.single i 1) -
            (integral (I.face i) ⊥ (f ∘ i.insert_nth (I.upper i)) box_additive_map.volume -
              integral (I.face i) ⊥ (f ∘ i.insert_nth (I.lower i)) box_additive_map.volume)‖ =
        ‖integral.{0, u, u} (I.face i) ⊥
            (fun x : Fin n → ℝ =>
              f' (Pi.single i (I.upper i - I.lower i)) -
                (f (i.insert_nth (I.upper i) x) - f (i.insert_nth (I.lower i) x)))
            box_additive_map.volume‖ :=
      by
      rw [← integral_sub (Hi _ Hu) (Hi _ Hl), ← box.volume_face_mul i, mul_smul, ← box.volume_apply,
        ← box_additive_map.to_smul_apply, ← integral_const, ← box_additive_map.volume, ←
        integral_sub (integrable_const _) ((Hi _ Hu).sub (Hi _ Hl))]
      simp only [(· ∘ ·), Pi.sub_def, ← f'.map_smul, ← Pi.single_smul', smul_eq_mul, mul_one]
    _ ≤ (volume (I.face i : Set ℝⁿ)).toReal * (2 * ε * c * (I.upper i - I.lower i)) :=
      by
      -- The hard part of the estimate was done above, here we just replace `diam I.Icc`
      -- with `c * (I.upper i - I.lower i)`
      refine' norm_integral_le_of_le_const (fun y hy => (this y hy).trans _) volume
      rw [mul_assoc (2 * ε)]
      exact
        mul_le_mul_of_nonneg_left (I.diam_Icc_le_of_distortion_le i hc)
          (mul_nonneg zero_le_two h0.le)
    _ = 2 * ε * c * ∏ j, I.upper j - I.lower j :=
      by
      rw [← measure.to_box_additive_apply, box.volume_apply, ← I.volume_face_mul i]
      ac_rfl

#align box_integral.norm_volume_sub_integral_face_upper_sub_lower_smul_le BoxIntegral.norm_volume_sub_integral_face_upper_sub_lower_smul_le

/- ./././Mathport/Syntax/Translate/Basic.lean:635:2: warning: expanding binder collection (y₁ y₂ «expr ∈ » «expr ∩ »(closed_ball x δ, I.Icc)) -/
/-- If `f : ℝⁿ⁺¹ → E` is differentiable on a closed rectangular box `I` with derivative `f'`, then
the partial derivative `λ x, f' x (pi.single i 1)` is Henstock-Kurzweil integrable with integral
equal to the difference of integrals of `f` over the faces `x i = I.upper i` and `x i = I.lower i`.

More precisely, we use a non-standard generalization of the Henstock-Kurzweil integral and
we allow `f` to be non-differentiable (but still continuous) at a countable set of points.

TODO: If `n > 0`, then the condition at `x ∈ s` can be replaced by a much weaker estimate but this
requires either better integrability theorems, or usage of a filter depending on the countable set
`s` (we need to ensure that none of the faces of a partition contain a point from `s`). -/
theorem hasIntegralGPPderiv (f : ℝⁿ⁺¹ → E) (f' : ℝⁿ⁺¹ → ℝⁿ⁺¹ →L[ℝ] E) (s : Set ℝⁿ⁺¹)
    (hs : s.Countable) (Hs : ∀ x ∈ s, ContinuousWithinAt f I.Icc x)
    (Hd : ∀ x ∈ I.Icc \ s, HasFderivWithinAt f (f' x) I.Icc x) (i : Fin (n + 1)) :
    HasIntegral.{0, u, u} I gP (fun x => f' x (Pi.single i 1)) BoxAdditiveMap.volume
      (integral.{0, u, u} (I.face i) gP (fun x => f (i.insertNth (I.upper i) x))
          BoxAdditiveMap.volume -
        integral.{0, u, u} (I.face i) gP (fun x => f (i.insertNth (I.lower i) x))
          BoxAdditiveMap.volume) :=
  by
  /- Note that `f` is continuous on `I.Icc`, hence it is integrable on the faces of all boxes
    `J ≤ I`, thus the difference of integrals over `x i = J.upper i` and `x i = J.lower i` is a
    box-additive function of `J ≤ I`. -/
  have Hc : ContinuousOn f I.Icc := by
    intro x hx
    by_cases hxs : x ∈ s
    exacts[Hs x hxs, (Hd x ⟨hx, hxs⟩).ContinuousWithinAt]
  set fI : ℝ → box (Fin n) → E := fun y J =>
    integral.{0, u, u} J GP (fun x => f (i.insert_nth y x)) box_additive_map.volume
  set fb : Icc (I.lower i) (I.upper i) → Fin n →ᵇᵃ[↑(I.face i)] E := fun x =>
    (integrable_of_continuous_on GP (box.continuous_on_face_Icc Hc x.2) volume).toBoxAdditive
  set F : Fin (n + 1) →ᵇᵃ[I] E := box_additive_map.upper_sub_lower I i fI fb fun x hx J => rfl
  -- Thus our statement follows from some local estimates.
  change has_integral I GP (fun x => f' x (Pi.single i 1)) _ (F I)
  refine' has_integral_of_le_Henstock_of_forall_is_o GP_le _ _ _ s hs _ _
  ·-- We use the volume as an upper estimate.
    exact (volume : Measure ℝⁿ⁺¹).toBoxAdditive.restrict _ le_top
  · exact fun J => ENNReal.toReal_nonneg
  · intro c x hx ε ε0
    /- Near `x ∈ s` we choose `δ` so that both vectors are small. `volume J • eᵢ` is small because
        `volume J ≤ (2 * δ) ^ (n + 1)` is small, and the difference of the integrals is small
        because each of the integrals is close to `volume (J.face i) • f x`.
        TODO: there should be a shorter and more readable way to formalize this simple proof. -/
    have :
      ∀ᶠ δ in 𝓝[>] (0 : ℝ),
        δ ∈ Ioc (0 : ℝ) (1 / 2) ∧
          (∀ (y₁) (_ : y₁ ∈ closed_ball x δ ∩ I.Icc) (y₂) (_ : y₂ ∈ closed_ball x δ ∩ I.Icc),
              ‖f y₁ - f y₂‖ ≤ ε / 2) ∧
            (2 * δ) ^ (n + 1) * ‖f' x (Pi.single i 1)‖ ≤ ε / 2 :=
      by
      refine' eventually.and _ (eventually.and _ _)
      · exact Ioc_mem_nhdsWithin_Ioi ⟨le_rfl, one_half_pos⟩
      · rcases((nhdsWithin_hasBasis nhds_basis_closed_ball _).tendsto_iffₓ nhds_basis_closed_ball).1
            (Hs x hx.2) _ (half_pos <| half_pos ε0) with ⟨δ₁, δ₁0, hδ₁⟩
        filter_upwards [Ioc_mem_nhdsWithin_Ioi ⟨le_rfl, δ₁0⟩]with δ hδ y₁ hy₁ y₂ hy₂
        have : closed_ball x δ ∩ I.Icc ⊆ closed_ball x δ₁ ∩ I.Icc :=
          inter_subset_inter_left _ (closed_ball_subset_closed_ball hδ.2)
        rw [← dist_eq_norm]
        calc
          dist (f y₁) (f y₂) ≤ dist (f y₁) (f x) + dist (f y₂) (f x) := dist_triangle_right _ _ _
          _ ≤ ε / 2 / 2 + ε / 2 / 2 := (add_le_add (hδ₁ _ <| this hy₁) (hδ₁ _ <| this hy₂))
          _ = ε / 2 := add_halves _

      · have :
          ContinuousWithinAt (fun δ => (2 * δ) ^ (n + 1) * ‖f' x (Pi.single i 1)‖) (Ioi (0 : ℝ))
            0 :=
          ((continuous_within_at_id.const_mul _).pow _).mul_const _
        refine' this.eventually (ge_mem_nhds _)
        simpa using half_pos ε0
    rcases this.exists with ⟨δ, ⟨hδ0, hδ12⟩, hdfδ, hδ⟩
    refine' ⟨δ, hδ0, fun J hJI hJδ hxJ hJc => add_halves ε ▸ _⟩
    have Hl : J.lower i ∈ Icc (J.lower i) (J.upper i) := Set.left_mem_Icc.2 (J.lower_le_upper i)
    have Hu : J.upper i ∈ Icc (J.lower i) (J.upper i) := Set.right_mem_Icc.2 (J.lower_le_upper i)
    have Hi :
      ∀ x ∈ Icc (J.lower i) (J.upper i),
        Integrable.{0, u, u} (J.face i) GP (fun y => f (i.insert_nth x y))
          box_additive_map.volume :=
      fun x hx =>
      integrable_of_continuous_on _
        (box.continuous_on_face_Icc (Hc.mono <| box.le_iff_Icc.1 hJI) hx) volume
    have hJδ' : J.Icc ⊆ closed_ball x δ ∩ I.Icc := subset_inter hJδ (box.le_iff_Icc.1 hJI)
    have Hmaps :
      ∀ z ∈ Icc (J.lower i) (J.upper i),
        maps_to (i.insert_nth z) (J.face i).Icc (closed_ball x δ ∩ I.Icc) :=
      fun z hz => (J.maps_to_insert_nth_face_Icc hz).mono subset.rfl hJδ'
    simp only [dist_eq_norm, F, fI]
    dsimp
    rw [← integral_sub (Hi _ Hu) (Hi _ Hl)]
    refine' (norm_sub_le _ _).trans (add_le_add _ _)
    · simp_rw [box_additive_map.volume_apply, norm_smul, Real.norm_eq_abs, abs_prod]
      refine' (mul_le_mul_of_nonneg_right _ <| norm_nonneg _).trans hδ
      have : ∀ j, |J.upper j - J.lower j| ≤ 2 * δ :=
        by
        intro j
        calc
          dist (J.upper j) (J.lower j) ≤ dist J.upper J.lower := dist_le_pi_dist _ _ _
          _ ≤ dist J.upper x + dist J.lower x := (dist_triangle_right _ _ _)
          _ ≤ δ + δ := (add_le_add (hJδ J.upper_mem_Icc) (hJδ J.lower_mem_Icc))
          _ = 2 * δ := (two_mul δ).symm

      calc
        (∏ j, |J.upper j - J.lower j|) ≤ ∏ j : Fin (n + 1), 2 * δ :=
          prod_le_prod (fun _ _ => abs_nonneg _) fun j hj => this j
        _ = (2 * δ) ^ (n + 1) := by simp

    · refine'
        (norm_integral_le_of_le_const (fun y hy => hdfδ _ (Hmaps _ Hu hy) _ (Hmaps _ Hl hy))
              _).trans
          _
      refine' (mul_le_mul_of_nonneg_right _ (half_pos ε0).le).trans_eq (one_mul _)
      rw [box.coe_eq_pi, Real.volume_pi_Ioc_toReal (box.lower_le_upper _)]
      refine' prod_le_one (fun _ _ => sub_nonneg.2 <| box.lower_le_upper _ _) fun j hj => _
      calc
        J.upper (i.succ_above j) - J.lower (i.succ_above j) ≤
            dist (J.upper (i.succ_above j)) (J.lower (i.succ_above j)) :=
          le_abs_self _
        _ ≤ dist J.upper J.lower := (dist_le_pi_dist J.upper J.lower (i.succ_above j))
        _ ≤ dist J.upper x + dist J.lower x := (dist_triangle_right _ _ _)
        _ ≤ δ + δ := (add_le_add (hJδ J.upper_mem_Icc) (hJδ J.lower_mem_Icc))
        _ ≤ 1 / 2 + 1 / 2 := (add_le_add hδ12 hδ12)
        _ = 1 := add_halves 1

  · intro c x hx ε ε0
    /- At a point `x ∉ s`, we unfold the definition of Fréchet differentiability, then use
        an estimate we proved earlier in this file. -/
    rcases exists_pos_mul_lt ε0 (2 * c) with ⟨ε', ε'0, hlt⟩
    rcases(nhdsWithin_hasBasis nhds_basis_closed_ball _).mem_iff.1 ((Hd x hx).def ε'0) with
      ⟨δ, δ0, Hδ⟩
    refine' ⟨δ, δ0, fun J hle hJδ hxJ hJc => _⟩
    simp only [box_additive_map.volume_apply, box.volume_apply, dist_eq_norm]
    refine'
      (norm_volume_sub_integral_face_upper_sub_lower_smul_le _ (Hc.mono <| box.le_iff_Icc.1 hle) hxJ
            ε'0 (fun y hy => Hδ _) (hJc rfl)).trans
        _
    · exact ⟨hJδ hy, box.le_iff_Icc.1 hle hy⟩
    · rw [mul_right_comm (2 : ℝ), ← box.volume_apply]
      exact mul_le_mul_of_nonneg_right hlt.le ENNReal.toReal_nonneg
#align box_integral.has_integral_GP_pderiv BoxIntegral.hasIntegralGPPderiv

/-- Divergence theorem for a Henstock-Kurzweil style integral.

If `f : ℝⁿ⁺¹ → Eⁿ⁺¹` is differentiable on a closed rectangular box `I` with derivative `f'`, then
the divergence `∑ i, f' x (pi.single i 1) i` is Henstock-Kurzweil integrable with integral equal to
the sum of integrals of `f` over the faces of `I` taken with appropriate signs.

More precisely, we use a non-standard generalization of the Henstock-Kurzweil integral and
we allow `f` to be non-differentiable (but still continuous) at a countable set of points. -/
theorem hasIntegralGPDivergenceOfForallHasDerivWithinAt (f : ℝⁿ⁺¹ → Eⁿ⁺¹)
    (f' : ℝⁿ⁺¹ → ℝⁿ⁺¹ →L[ℝ] Eⁿ⁺¹) (s : Set ℝⁿ⁺¹) (hs : s.Countable)
    (Hs : ∀ x ∈ s, ContinuousWithinAt f I.Icc x)
    (Hd : ∀ x ∈ I.Icc \ s, HasFderivWithinAt f (f' x) I.Icc x) :
    HasIntegral.{0, u, u} I gP (fun x => ∑ i, f' x (Pi.single i 1) i) BoxAdditiveMap.volume
      (∑ i,
        integral.{0, u, u} (I.face i) gP (fun x => f (i.insertNth (I.upper i) x) i)
            BoxAdditiveMap.volume -
          integral.{0, u, u} (I.face i) gP (fun x => f (i.insertNth (I.lower i) x) i)
            BoxAdditiveMap.volume) :=
  by
  refine' has_integral_sum fun i hi => _; clear hi
  simp only [hasFderivWithinAt_pi', continuousWithinAt_pi] at Hd Hs
  convert has_integral_GP_pderiv I _ _ s hs (fun x hx => Hs x hx i) (fun x hx => Hd x hx i) i
#align box_integral.has_integral_GP_divergence_of_forall_has_deriv_within_at BoxIntegral.hasIntegralGPDivergenceOfForallHasDerivWithinAt

end BoxIntegral


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module tactic.ring
! leanprover-community/mathlib commit c1ada9d195393af8a78376fb35d4d7108666bda9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.NormNum
import Mathbin.Data.Fin.Basic

/-!
# `ring`

Evaluate expressions in the language of commutative (semi)rings.
Based on <http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf> .
-/

namespace Tactic

namespace Ring

/-- The normal form that `ring` uses is mediated by the function `horner a x n b := a * x ^ n + b`.
The reason we use a definition rather than the (more readable) expression on the right is because
this expression contains a number of typeclass arguments in different positions, while `horner`
contains only one `comm_semiring` instance at the top level. See also `horner_expr` for a
description of normal form. -/
def horner {α} [CommSemiring α] (a x : α) (n : ℕ) (b : α) :=
  a * x ^ n + b
#align tactic.ring.horner Tactic.Ring.horner

/-- This cache contains data required by the `ring` tactic during execution. -/
unsafe structure cache where
  α : expr
  univ : level
  comm_semiring_inst : expr
  red : Transparency
  ic : ref instance_cache
  nc : ref instance_cache
  atoms : ref (Buffer expr)
#align tactic.ring.cache tactic.ring.cache

/-- The monad that `ring` works in. This is a reader monad containing a mutable cache (using `ref`
for mutability), as well as the list of atoms-up-to-defeq encountered thus far, used for atom
sorting. -/
unsafe def ring_m (α : Type) : Type :=
  ReaderT cache tactic α deriving Monad, Alternative
#align tactic.ring.ring_m tactic.ring.ring_m

/-- Get the `ring` data from the monad. -/
unsafe def get_cache : ring_m cache :=
  ReaderT.read
#align tactic.ring.get_cache tactic.ring.get_cache

/-- Get an already encountered atom by its index. -/
unsafe def get_atom (n : ℕ) : ring_m expr :=
  ⟨fun c => do
    let es ← read_ref c.atoms
    pure (es n)⟩
#align tactic.ring.get_atom tactic.ring.get_atom

/-- Get the index corresponding to an atomic expression, if it has already been encountered, or
put it in the list of atoms and return the new index, otherwise. -/
unsafe def add_atom (e : expr) : ring_m ℕ :=
  ⟨fun c => do
    let red := c.red
    let es ← read_ref c.atoms
    (es failed fun n e' t => t <|> is_def_eq e e' red $> n) <|> es <$ write_ref c (es e)⟩
#align tactic.ring.add_atom tactic.ring.add_atom

/-- Lift a tactic into the `ring_m` monad. -/
@[inline]
unsafe def lift {α} (m : tactic α) : ring_m α :=
  ReaderT.lift m
#align tactic.ring.lift tactic.ring.lift

/-- Run a `ring_m` tactic in the tactic monad. This version of `ring_m.run` uses an external
atoms ref, so that subexpressions can be named across multiple `ring_m` calls. -/
unsafe def ring_m.run' (red : Transparency) (atoms : ref (Buffer expr)) (e : expr) {α}
    (m : ring_m α) : tactic α := do
  let α ← infer_type e
  let u ← mk_meta_univ
  infer_type α >>= unify (expr.sort (level.succ u))
  let u ← get_univ_assignment u
  let ic ← mk_instance_cache α
  let (ic, c) ← ic.get `` CommSemiring
  let nc ← mk_instance_cache q(ℕ)
  using_new_ref ic fun r => using_new_ref nc fun nr => ReaderT.run m ⟨α, u, c, red, r, nr, atoms⟩
#align tactic.ring.ring_m.run' tactic.ring.ring_m.run'

/-- Run a `ring_m` tactic in the tactic monad. -/
unsafe def ring_m.run (red : Transparency) (e : expr) {α} (m : ring_m α) : tactic α :=
  using_new_ref mkBuffer fun atoms => ring_m.run' red atoms e m
#align tactic.ring.ring_m.run tactic.ring.ring_m.run

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This version
is abstract over the instance cache in question (either the ring `α`, or `ℕ` for exponents). -/
@[inline]
unsafe def ic_lift' (icf : cache → ref instance_cache) {α}
    (f : instance_cache → tactic (instance_cache × α)) : ring_m α :=
  ⟨fun c => do
    let r := icf c
    let ic ← read_ref r
    let (ic', a) ← f ic
    a <$ write_ref r ic'⟩
#align tactic.ring.ic_lift' tactic.ring.ic_lift'

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This uses
the instance cache corresponding to the ring `α`. -/
@[inline]
unsafe def ic_lift {α} : (instance_cache → tactic (instance_cache × α)) → ring_m α :=
  ic_lift' cache.ic
#align tactic.ring.ic_lift tactic.ring.ic_lift

/-- Lift an instance cache tactic (probably from `norm_num`) to the `ring_m` monad. This uses
the instance cache corresponding to `ℕ`, which is used for computations in the exponent. -/
@[inline]
unsafe def nc_lift {α} : (instance_cache → tactic (instance_cache × α)) → ring_m α :=
  ic_lift' cache.nc
#align tactic.ring.nc_lift tactic.ring.nc_lift

/-- Apply a theorem that expects a `comm_semiring` instance. This is a special case of
`ic_lift mk_app`, but it comes up often because `horner` and all its theorems have this assumption;
it also does not require the tactic monad which improves access speed a bit. -/
unsafe def cache.cs_app (c : cache) (n : Name) : List expr → expr :=
  (@expr.const true n [c.univ] c.α c.comm_semiring_inst).mk_app
#align tactic.ring.cache.cs_app tactic.ring.cache.cs_app

/-- Every expression in the language of commutative semirings can be viewed as a sum of monomials,
where each monomial is a product of powers of atoms. We fix a global order on atoms (up to
definitional equality), and then separate the terms according to their smallest atom. So the top
level expression is `a * x^n + b` where `x` is the smallest atom and `n > 0` is a numeral, and
`n` is maximal (so `a` contains at least one monomial not containing an `x`), and `b` contains no
monomials with an `x` (hence all atoms in `b` are larger than `x`).

If there is no `x` satisfying these constraints, then the expression must be a numeral. Even though
we are working over rings, we allow rational constants when these can be interpreted in the ring,
so we can solve problems like `x / 3 = 1 / 3 * x` even though these are not technically in the
language of rings.

These constraints ensure that there is a unique normal form for each ring expression, and so the
algorithm is simply to calculate the normal form of each side and compare for equality.

To allow us to efficiently pattern match on normal forms, we maintain this inductive type that
holds a normalized expression together with its structure. All the `expr`s in this type could be
removed without loss of information, and conversely the `horner_expr` structure and the `ℕ` and
`ℚ` values can be recovered from the top level `expr`, but we keep both in order to keep proof
 producing normalization functions efficient. -/
unsafe inductive horner_expr : Type
  | const (e : expr) (coeff : ℚ) : horner_expr
  | xadd (e : expr) (a : horner_expr) (x : expr × ℕ) (n : expr × ℕ) (b : horner_expr) : horner_expr
#align tactic.ring.horner_expr tactic.ring.horner_expr

/-- Get the expression corresponding to a `horner_expr`. This can be calculated recursively from
the structure, but we cache the exprs in all subterms so that this function can be computed in
constant time. -/
unsafe def horner_expr.e : horner_expr → expr
  | horner_expr.const e _ => e
  | horner_expr.xadd e _ _ _ _ => e
#align tactic.ring.horner_expr.e tactic.ring.horner_expr.e

/-- Is this expr the constant `0`? -/
unsafe def horner_expr.is_zero : horner_expr → Bool
  | horner_expr.const _ c => c = 0
  | _ => false
#align tactic.ring.horner_expr.is_zero tactic.ring.horner_expr.is_zero

unsafe instance : Coe horner_expr expr :=
  ⟨horner_expr.e⟩

unsafe instance : CoeFun horner_expr fun _ => expr → expr :=
  ⟨fun e => ⇑(e : expr)⟩

/-- Construct a `xadd` node, generating the cached expr using the input cache. -/
unsafe def horner_expr.xadd' (c : cache) (a : horner_expr) (x : expr × ℕ) (n : expr × ℕ)
    (b : horner_expr) : horner_expr :=
  horner_expr.xadd (c.cs_app `` horner [a, x.1, n.1, b]) a x n b
#align tactic.ring.horner_expr.xadd' tactic.ring.horner_expr.xadd'

open HornerExpr

/-- Pretty printer for `horner_expr`. -/
unsafe def horner_expr.to_string : horner_expr → String
  | const e c => toString (e, c)
  | xadd e a x (_, n) b =>
    "(" ++ a.toString ++ ") * (" ++ toString x.1 ++ ")^" ++ toString n ++ " + " ++ b.toString
#align tactic.ring.horner_expr.to_string tactic.ring.horner_expr.to_string

/-- Pretty printer for `horner_expr`. -/
unsafe def horner_expr.pp : horner_expr → tactic format
  | const e c => pp (e, c)
  | xadd e a x (_, n) b => do
    let pa ← a.pp
    let pb ← b.pp
    let px ← pp x.1
    return <| "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ toString n ++ " + " ++ pb
#align tactic.ring.horner_expr.pp tactic.ring.horner_expr.pp

unsafe instance : has_to_tactic_format horner_expr :=
  ⟨horner_expr.pp⟩

/-- Reflexivity conversion for a `horner_expr`. -/
unsafe def horner_expr.refl_conv (e : horner_expr) : ring_m (horner_expr × expr) := do
  let p ← lift <| mk_eq_refl e
  return (e, p)
#align tactic.ring.horner_expr.refl_conv tactic.ring.horner_expr.refl_conv

theorem zero_horner {α} [CommSemiring α] (x n b) : @horner α _ 0 x n b = b := by simp [horner]
#align tactic.ring.zero_horner Tactic.Ring.zero_horner

theorem horner_horner {α} [CommSemiring α] (a₁ x n₁ n₂ b n') (h : n₁ + n₂ = n') :
    @horner α _ (horner a₁ x n₁ 0) x n₂ b = horner a₁ x n' b := by
  simp [h.symm, horner, pow_add, mul_assoc]
#align tactic.ring.horner_horner Tactic.Ring.horner_horner

/-- Evaluate `horner a n x b` where `a` and `b` are already in normal form. -/
unsafe def eval_horner :
    horner_expr → expr × ℕ → expr × ℕ → horner_expr → ring_m (horner_expr × expr)
  | ha@(const a coeff), x, n, b => do
    let c ← get_cache
    if coeff = 0 then return (b, c `` zero_horner [x.1, n.1, b]) else (xadd' c ha x n b).refl_conv
  | ha@(xadd a a₁ x₁ n₁ b₁), x, n, b => do
    let c ← get_cache
    if x₁.2 = x.2 ∧ b₁ = some 0 then do
        let (n', h) ← nc_lift fun nc => norm_num.prove_add_nat' nc n₁.1 n.1
        return (xadd' c a₁ x (n', n₁.2 + n.2) b, c `` horner_horner [a₁, x.1, n₁.1, n.1, b, n', h])
      else (xadd' c ha x n b).refl_conv
#align tactic.ring.eval_horner tactic.ring.eval_horner

theorem const_add_horner {α} [CommSemiring α] (k a x n b b') (h : k + b = b') :
    k + @horner α _ a x n b = horner a x n b' := by simp [h.symm, horner] <;> cc
#align tactic.ring.const_add_horner Tactic.Ring.const_add_horner

theorem horner_add_const {α} [CommSemiring α] (a x n b k b') (h : b + k = b') :
    @horner α _ a x n b + k = horner a x n b' := by simp [h.symm, horner, add_assoc]
#align tactic.ring.horner_add_const Tactic.Ring.horner_add_const

theorem horner_add_horner_lt {α} [CommSemiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b') (h₁ : n₁ + k = n₂)
    (h₂ : (a₁ + horner a₂ x k 0 : α) = a') (h₃ : b₁ + b₂ = b') :
    @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₁ b' := by
  simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm] <;> cc
#align tactic.ring.horner_add_horner_lt Tactic.Ring.horner_add_horner_lt

theorem horner_add_horner_gt {α} [CommSemiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b') (h₁ : n₂ + k = n₁)
    (h₂ : (horner a₁ x k 0 + a₂ : α) = a') (h₃ : b₁ + b₂ = b') :
    @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₂ b' := by
  simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm] <;> cc
#align tactic.ring.horner_add_horner_gt Tactic.Ring.horner_add_horner_gt

theorem horner_add_horner_eq {α} [CommSemiring α] (a₁ x n b₁ a₂ b₂ a' b' t) (h₁ : a₁ + a₂ = a')
    (h₂ : b₁ + b₂ = b') (h₃ : horner a' x n b' = t) :
    @horner α _ a₁ x n b₁ + horner a₂ x n b₂ = t := by
  simp [h₃.symm, h₂.symm, h₁.symm, horner, add_mul, mul_comm (x ^ n)] <;> cc
#align tactic.ring.horner_add_horner_eq Tactic.Ring.horner_add_horner_eq

/-- Evaluate `a + b` where `a` and `b` are already in normal form. -/
unsafe def eval_add : horner_expr → horner_expr → ring_m (horner_expr × expr)
  | const e₁ c₁, const e₂ c₂ =>
    ic_lift fun ic => do
      let n := c₁ + c₂
      let (ic, e) ← ic.of_rat n
      let (ic, p) ← norm_num.prove_add_rat ic e₁ e₂ e c₁ c₂ n
      return (ic, const e n, p)
  | he₁@(const e₁ c₁), he₂@(xadd e₂ a x n b) => do
    let c ← get_cache
    if c₁ = 0 then
        ic_lift fun ic => do
          let (ic, p) ← ic `` zero_add [e₂]
          return (ic, he₂, p)
      else do
        let (b', h) ← eval_add he₁ b
        return (xadd' c a x n b', c `` const_add_horner [e₁, a, x.1, n.1, b, b', h])
  | he₁@(xadd e₁ a x n b), he₂@(const e₂ c₂) => do
    let c ← get_cache
    if c₂ = 0 then
        ic_lift fun ic => do
          let (ic, p) ← ic `` add_zero [e₁]
          return (ic, he₁, p)
      else do
        let (b', h) ← eval_add b he₂
        return (xadd' c a x n b', c `` horner_add_const [a, x.1, n.1, b, e₂, b', h])
  | he₁@(xadd e₁ a₁ x₁ n₁ b₁), he₂@(xadd e₂ a₂ x₂ n₂ b₂) => do
    let c ← get_cache
    if x₁.2 < x₂.2 then do
        let (b', h) ← eval_add b₁ he₂
        return (xadd' c a₁ x₁ n₁ b', c `` horner_add_const [a₁, x₁.1, n₁.1, b₁, e₂, b', h])
      else
        if x₁.2 ≠ x₂.2 then do
          let (b', h) ← eval_add he₁ b₂
          return (xadd' c a₂ x₂ n₂ b', c `` const_add_horner [e₁, a₂, x₂.1, n₂.1, b₂, b', h])
        else
          if n₁.2 < n₂.2 then do
            let k := n₂.2 - n₁.2
            let (ek, h₁) ←
              nc_lift fun nc => do
                  let (nc, ek) ← nc k
                  let (nc, h₁) ← norm_num.prove_add_nat nc n₁.1 ek n₂.1
                  return (nc, ek, h₁)
            let α0 ← ic_lift fun ic => ic `` Zero.zero []
            let (a', h₂) ← eval_add a₁ (xadd' c a₂ x₁ (ek, k) (const α0 0))
            let (b', h₃) ← eval_add b₁ b₂
            return
                (xadd' c a' x₁ n₁ b',
                  c `` horner_add_horner_lt
                    [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
          else
            if n₁.2 ≠ n₂.2 then do
              let k := n₁.2 - n₂.2
              let (ek, h₁) ←
                nc_lift fun nc => do
                    let (nc, ek) ← nc k
                    let (nc, h₁) ← norm_num.prove_add_nat nc n₂.1 ek n₁.1
                    return (nc, ek, h₁)
              let α0 ← ic_lift fun ic => ic `` Zero.zero []
              let (a', h₂) ← eval_add (xadd' c a₁ x₁ (ek, k) (const α0 0)) a₂
              let (b', h₃) ← eval_add b₁ b₂
              return
                  (xadd' c a' x₁ n₂ b',
                    c `` horner_add_horner_gt
                      [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
            else do
              let (a', h₁) ← eval_add a₁ a₂
              let (b', h₂) ← eval_add b₁ b₂
              let (t, h₃) ← eval_horner a' x₁ n₁ b'
              return
                  (t, c `` horner_add_horner_eq [a₁, x₁.1, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])
#align tactic.ring.eval_add tactic.ring.eval_add

theorem horner_neg {α} [CommRing α] (a x n b a' b') (h₁ : -a = a') (h₂ : -b = b') :
    -@horner α _ a x n b = horner a' x n b' := by simp [h₂.symm, h₁.symm, horner] <;> cc
#align tactic.ring.horner_neg Tactic.Ring.horner_neg

/-- Evaluate `-a` where `a` is already in normal form. -/
unsafe def eval_neg : horner_expr → ring_m (horner_expr × expr)
  | const e coeff => do
    let (e', p) ← ic_lift fun ic => norm_num.prove_neg ic e
    return (const e' (-coeff), p)
  | xadd e a x n b => do
    let c ← get_cache
    let (a', h₁) ← eval_neg a
    let (b', h₂) ← eval_neg b
    let p ← ic_lift fun ic => ic.mk_app `` horner_neg [a, x.1, n.1, b, a', b', h₁, h₂]
    return (xadd' c a' x n b', p)
#align tactic.ring.eval_neg tactic.ring.eval_neg

theorem horner_const_mul {α} [CommSemiring α] (c a x n b a' b') (h₁ : c * a = a')
    (h₂ : c * b = b') : c * @horner α _ a x n b = horner a' x n b' := by
  simp [h₂.symm, h₁.symm, horner, mul_add, mul_assoc]
#align tactic.ring.horner_const_mul Tactic.Ring.horner_const_mul

theorem horner_mul_const {α} [CommSemiring α] (a x n b c a' b') (h₁ : a * c = a')
    (h₂ : b * c = b') : @horner α _ a x n b * c = horner a' x n b' := by
  simp [h₂.symm, h₁.symm, horner, add_mul, mul_right_comm]
#align tactic.ring.horner_mul_const Tactic.Ring.horner_mul_const

/-- Evaluate `k * a` where `k` is a rational numeral and `a` is in normal form. -/
unsafe def eval_const_mul (k : expr × ℚ) : horner_expr → ring_m (horner_expr × expr)
  | const e coeff => do
    let (e', p) ← ic_lift fun ic => norm_num.prove_mul_rat ic k.1 e k.2 coeff
    return (const e' (k.2 * coeff), p)
  | xadd e a x n b => do
    let c ← get_cache
    let (a', h₁) ← eval_const_mul a
    let (b', h₂) ← eval_const_mul b
    return (xadd' c a' x n b', c `` horner_const_mul [k.1, a, x.1, n.1, b, a', b', h₁, h₂])
#align tactic.ring.eval_const_mul tactic.ring.eval_const_mul

theorem horner_mul_horner_zero {α} [CommSemiring α] (a₁ x n₁ b₁ a₂ n₂ aa t)
    (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa) (h₂ : horner aa x n₂ 0 = t) :
    horner a₁ x n₁ b₁ * horner a₂ x n₂ 0 = t := by
  rw [← h₂, ← h₁] <;> simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]
#align tactic.ring.horner_mul_horner_zero Tactic.Ring.horner_mul_horner_zero

theorem horner_mul_horner {α} [CommSemiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ aa haa ab bb t)
    (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa) (h₂ : horner aa x n₂ 0 = haa) (h₃ : a₁ * b₂ = ab)
    (h₄ : b₁ * b₂ = bb) (H : haa + horner ab x n₁ bb = t) :
    horner a₁ x n₁ b₁ * horner a₂ x n₂ b₂ = t := by
  rw [← H, ← h₂, ← h₁, ← h₃, ← h₄] <;> simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]
#align tactic.ring.horner_mul_horner Tactic.Ring.horner_mul_horner

/-- Evaluate `a * b` where `a` and `b` are in normal form. -/
unsafe def eval_mul : horner_expr → horner_expr → ring_m (horner_expr × expr)
  | const e₁ c₁, const e₂ c₂ => do
    let (e', p) ← ic_lift fun ic => norm_num.prove_mul_rat ic e₁ e₂ c₁ c₂
    return (const e' (c₁ * c₂), p)
  | const e₁ c₁, e₂ =>
    if c₁ = 0 then do
      let c ← get_cache
      let α0 ← ic_lift fun ic => ic.mk_app `` Zero.zero []
      let p ← ic_lift fun ic => ic.mk_app `` MulZeroClass.zero_mul [e₂]
      return (const α0 0, p)
    else
      if c₁ = 1 then do
        let p ← ic_lift fun ic => ic.mk_app `` one_mul [e₂]
        return (e₂, p)
      else eval_const_mul (e₁, c₁) e₂
  | e₁, he₂@(const e₂ c₂) => do
    let p₁ ← ic_lift fun ic => ic.mk_app `` mul_comm [e₁, e₂]
    let (e', p₂) ← eval_mul he₂ e₁
    let p ← lift <| mk_eq_trans p₁ p₂
    return (e', p)
  | he₁@(xadd e₁ a₁ x₁ n₁ b₁), he₂@(xadd e₂ a₂ x₂ n₂ b₂) => do
    let c ← get_cache
    if x₁.2 < x₂.2 then do
        let (a', h₁) ← eval_mul a₁ he₂
        let (b', h₂) ← eval_mul b₁ he₂
        return (xadd' c a' x₁ n₁ b', c `` horner_mul_const [a₁, x₁.1, n₁.1, b₁, e₂, a', b', h₁, h₂])
      else
        if x₁.2 ≠ x₂.2 then do
          let (a', h₁) ← eval_mul he₁ a₂
          let (b', h₂) ← eval_mul he₁ b₂
          return
              (xadd' c a' x₂ n₂ b', c `` horner_const_mul [e₁, a₂, x₂.1, n₂.1, b₂, a', b', h₁, h₂])
        else do
          let (aa, h₁) ← eval_mul he₁ a₂
          let α0 ← ic_lift fun ic => ic `` Zero.zero []
          let (haa, h₂) ← eval_horner aa x₁ n₂ (const α0 0)
          if b₂ then
              return
                (haa, c `` horner_mul_horner_zero [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
            else do
              let (ab, h₃) ← eval_mul a₁ b₂
              let (bb, h₄) ← eval_mul b₁ b₂
              let (t, H) ← eval_add haa (xadd' c ab x₁ n₁ bb)
              return
                  (t,
                    c `` horner_mul_horner
                      [a₁, x₁.1, n₁.1, b₁, a₂, n₂.1, b₂, aa, haa, ab, bb, t, h₁, h₂, h₃, h₄, H])
#align tactic.ring.eval_mul tactic.ring.eval_mul

theorem horner_pow {α} [CommSemiring α] (a x n m n' a') (h₁ : n * m = n') (h₂ : a ^ m = a') :
    @horner α _ a x n 0 ^ m = horner a' x n' 0 := by
  simp [h₁.symm, h₂.symm, horner, mul_pow, pow_mul]
#align tactic.ring.horner_pow Tactic.Ring.horner_pow

theorem pow_succ {α} [CommSemiring α] (a n b c) (h₁ : (a : α) ^ n = b) (h₂ : b * a = c) :
    a ^ (n + 1) = c := by rw [← h₂, ← h₁, pow_succ']
#align tactic.ring.pow_succ Tactic.Ring.pow_succ

/-- Evaluate `a ^ n` where `a` is in normal form and `n` is a natural numeral. -/
unsafe def eval_pow : horner_expr → expr × ℕ → ring_m (horner_expr × expr)
  | e, (_, 0) => do
    let c ← get_cache
    let α1 ← ic_lift fun ic => ic.mk_app `` One.one []
    let p ← ic_lift fun ic => ic.mk_app `` pow_zero [e]
    return (const α1 1, p)
  | e, (_, 1) => do
    let p ← ic_lift fun ic => ic.mk_app `` pow_one [e]
    return (e, p)
  | const e coeff, (e₂, m) =>
    ic_lift fun ic => do
      let (ic, e', p) ← norm_num.prove_pow e coeff ic e₂
      return (ic, const e' (coeff ^ m), p)
  | he@(xadd e a x n b), m => do
    let c ← get_cache
    match b with
      | some 0 => do
        let (n', h₁) ← nc_lift fun nc => norm_num.prove_mul_rat nc n.1 m.1 n.2 m.2
        let (a', h₂) ← eval_pow a m
        let α0 ← ic_lift fun ic => ic `` Zero.zero []
        return
            (xadd' c a' x (n', n.2 * m.2) (const α0 0),
              c `` horner_pow [a, x.1, n.1, m.1, n', a', h₁, h₂])
      | _ => do
        let e₂ ← nc_lift fun nc => nc (m.2 - 1)
        let (tl, hl) ← eval_pow he (e₂, m.2 - 1)
        let (t, p₂) ← eval_mul tl he
        return (t, c `` pow_succ [e, e₂, tl, t, hl, p₂])
#align tactic.ring.eval_pow tactic.ring.eval_pow

theorem horner_atom {α} [CommSemiring α] (x : α) : x = horner 1 x 1 0 := by simp [horner]
#align tactic.ring.horner_atom Tactic.Ring.horner_atom

/-- Evaluate `a` where `a` is an atom. -/
unsafe def eval_atom (e : expr) : ring_m (horner_expr × expr) := do
  let c ← get_cache
  let i ← add_atom e
  let α0 ← ic_lift fun ic => ic.mk_app `` Zero.zero []
  let α1 ← ic_lift fun ic => ic.mk_app `` One.one []
  return (xadd' c (const α1 1) (e, i) (q(1), 1) (const α0 0), c `` horner_atom [e])
#align tactic.ring.eval_atom tactic.ring.eval_atom

/-- Evaluate `a` where `a` is an atom. -/
unsafe def eval_norm_atom (norm_atom : expr → tactic (expr × expr)) (e : expr) :
    ring_m (horner_expr × expr) := do
  let o ← lift <| try_core (guard (e.get_app_args.length > 0) >> norm_atom e)
  match o with
    | none => eval_atom e
    | some (e', p) => do
      let (e₂, p₂) ← eval_atom e'
      Prod.mk e₂ <$> lift (mk_eq_trans p p₂)
#align tactic.ring.eval_norm_atom tactic.ring.eval_norm_atom

theorem subst_into_pow {α} [Monoid α] (l r tl tr t) (prl : (l : α) = tl) (prr : (r : ℕ) = tr)
    (prt : tl ^ tr = t) : l ^ r = t := by rw [prl, prr, prt]
#align tactic.ring.subst_into_pow Tactic.Ring.subst_into_pow

theorem unfold_sub {α} [AddGroup α] (a b c : α) (h : a + -b = c) : a - b = c := by
  rw [sub_eq_add_neg, h]
#align tactic.ring.unfold_sub Tactic.Ring.unfold_sub

theorem unfold_div {α} [DivisionRing α] (a b c : α) (h : a * b⁻¹ = c) : a / b = c := by
  rw [div_eq_mul_inv, h]
#align tactic.ring.unfold_div Tactic.Ring.unfold_div

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Evaluate a ring expression `e` recursively to normal form, together with a proof of
      equality. -/
    unsafe
  def
    eval
    ( norm_atom : expr → tactic ( expr × expr ) ) : expr → ring_m ( horner_expr × expr )
    |
        q( $ ( e₁ ) + $ ( e₂ ) )
        =>
        do
          let ( e₁' , p₁ ) ← eval e₁
            let ( e₂' , p₂ ) ← eval e₂
            let ( e' , p' ) ← eval_add e₁' e₂'
            let
              p
                ←
                ic_lift
                  fun
                    ic
                      =>
                      ic . mk_app
                        ` ` NormNum.subst_into_add [ e₁ , e₂ , e₁' , e₂' , e' , p₁ , p₂ , p' ]
            return ( e' , p )
      |
        e @ q( @ Sub.sub $ ( α ) $ ( inst ) $ ( e₁ ) $ ( e₂ ) )
        =>
        condM
          ( succeeds ( lift <| mk_app ` ` CommRing [ α ] >>= mk_instance ) )
            (
              do
                let e₂' ← ic_lift fun ic => ic . mk_app ` ` Neg.neg [ e₂ ]
                  let e ← ic_lift fun ic => ic . mk_app ` ` Add.add [ e₁ , e₂' ]
                  let ( e' , p ) ← eval e
                  let p' ← ic_lift fun ic => ic . mk_app ` ` unfold_sub [ e₁ , e₂ , e' , p ]
                  return ( e' , p' )
              )
            ( eval_norm_atom norm_atom e )
      |
        q( - $ ( e ) )
        =>
        do
          let ( e₁ , p₁ ) ← eval e
            let ( e₂ , p₂ ) ← eval_neg e₁
            let
              p ← ic_lift fun ic => ic . mk_app ` ` NormNum.subst_into_neg [ e , e₁ , e₂ , p₁ , p₂ ]
            return ( e₂ , p )
      |
        q( $ ( e₁ ) * $ ( e₂ ) )
        =>
        do
          let ( e₁' , p₁ ) ← eval e₁
            let ( e₂' , p₂ ) ← eval e₂
            let ( e' , p' ) ← eval_mul e₁' e₂'
            let
              p
                ←
                ic_lift
                  fun
                    ic
                      =>
                      ic . mk_app
                        ` ` NormNum.subst_into_mul [ e₁ , e₂ , e₁' , e₂' , e' , p₁ , p₂ , p' ]
            return ( e' , p )
      |
        e @ q( Inv.inv $ ( _ ) )
        =>
        (
            do
              let ( e' , p ) ← lift <| norm_num.derive e <|> refl_conv e
                let n ← lift <| e' . to_rat
                return ( const e' n , p )
            )
          <|>
          eval_norm_atom norm_atom e
      |
        e @ q( @ Div.div _ $ ( inst ) $ ( e₁ ) $ ( e₂ ) )
        =>
        condM
          (
              succeeds
                do
                  let inst' ← ic_lift fun ic => ic . mk_app ` ` DivInvMonoid.toHasDiv [ ]
                    lift <| is_def_eq inst inst'
              )
            (
              do
                let e₂' ← ic_lift fun ic => ic . mk_app ` ` Inv.inv [ e₂ ]
                  let e ← ic_lift fun ic => ic . mk_app ` ` Mul.mul [ e₁ , e₂' ]
                  let ( e' , p ) ← eval e
                  let p' ← ic_lift fun ic => ic . mk_app ` ` unfold_div [ e₁ , e₂ , e' , p ]
                  return ( e' , p' )
              )
            ( eval_norm_atom norm_atom e )
      |
        e @ q( @ Pow.pow _ _ $ ( inst ) $ ( e₁ ) $ ( e₂ ) )
        =>
        condM
          (
              succeeds
                do
                  let inst' ← ic_lift fun ic => ic . mk_app ` ` Monoid.Pow [ ]
                    lift <| is_def_eq inst inst'
              )
            (
              do
                let ( e₂' , p₂ ) ← lift <| norm_num.derive e₂ <|> refl_conv e₂
                  match
                    e₂'
                    with
                    |
                        some k
                        =>
                        do
                          let ( e₁' , p₁ ) ← eval e₁
                            let ( e' , p' ) ← eval_pow e₁' ( e₂ , k )
                            let
                              p
                                ←
                                ic_lift
                                  fun
                                    ic
                                      =>
                                      ic
                                        ` ` subst_into_pow
                                          [ e₁ , e₂ , e₁' , e₂' , e' , p₁ , p₂ , p' ]
                            return ( e' , p )
                      | _ => eval_norm_atom norm_atom e
              )
            ( eval_norm_atom norm_atom e )
      |
        e
        =>
        match
          e . toNat
          with
          | some n => ( const e n ) . refl_conv | none => eval_norm_atom norm_atom e
#align tactic.ring.eval tactic.ring.eval

/-- Evaluate a ring expression `e` recursively to normal form, together with a proof of
equality. -/
unsafe def eval' (red : Transparency) (atoms : ref (Buffer expr))
    (norm_atom : expr → tactic (expr × expr)) (e : expr) : tactic (expr × expr) :=
  ring_m.run' red atoms e do
    let (e', p) ← eval norm_atom e
    return (e', p)
#align tactic.ring.eval' tactic.ring.eval'

theorem horner_def' {α} [CommSemiring α] (a x n b) : @horner α _ a x n b = x ^ n * a + b := by
  simp [horner, mul_comm]
#align tactic.ring.horner_def' Tactic.Ring.horner_def'

theorem mul_assoc_rev {α} [Semigroup α] (a b c : α) : a * (b * c) = a * b * c := by simp [mul_assoc]
#align tactic.ring.mul_assoc_rev Tactic.Ring.mul_assoc_rev

theorem pow_add_rev {α} [Monoid α] (a : α) (m n : ℕ) : a ^ m * a ^ n = a ^ (m + n) := by
  simp [pow_add]
#align tactic.ring.pow_add_rev Tactic.Ring.pow_add_rev

theorem pow_add_rev_right {α} [Monoid α] (a b : α) (m n : ℕ) :
    b * a ^ m * a ^ n = b * a ^ (m + n) := by simp [pow_add, mul_assoc]
#align tactic.ring.pow_add_rev_right Tactic.Ring.pow_add_rev_right

theorem add_neg_eq_sub {α} [AddGroup α] (a b : α) : a + -b = a - b :=
  (sub_eq_add_neg a b).symm
#align tactic.ring.add_neg_eq_sub Tactic.Ring.add_neg_eq_sub

/-- If `ring` fails to close the goal, it falls back on normalizing the expression to a "pretty"
form so that you can see why it failed. This setting adjusts the resulting form:

  * `raw` is the form that `ring` actually uses internally, with iterated applications of `horner`.
    Not very readable but useful if you don't want any postprocessing.
    This results in terms like `horner (horner (horner 3 y 1 0) x 2 1) x 1 (horner 1 y 1 0)`.
  * `horner` maintains the Horner form structure, but it unfolds the `horner` definition itself,
    and tries to otherwise minimize parentheses.
    This results in terms like `(3 * x ^ 2 * y + 1) * x + y`.
  * `SOP` means sum of products form, expanding everything to monomials.
    This results in terms like `3 * x ^ 3 * y + x + y`. -/
inductive NormalizeMode
  | raw
  | SOP
  | horner
  deriving has_reflect, DecidableEq
#align tactic.ring.normalize_mode Tactic.Ring.NormalizeMode

instance : Inhabited NormalizeMode :=
  ⟨NormalizeMode.horner⟩

/-- A `ring`-based normalization simplifier that rewrites ring expressions into the specified mode.
See `normalize`. This version takes a list of atoms to persist across multiple calls.

* `atoms`: a mutable reference containing the atom set from the previous call
* `red`: the reducibility setting to use when comparing atoms for defeq
* `mode`: the normalization style (see `normalize_mode`)
* `recursive`: if true, atoms will be reduced recursively using `normalize'`
* `e`: the expression to normalize
* `inner`: This should be set to `ff`. It is used internally to disable normalization
  at the top level when called from `eval` in order to prevent an infinite loop
  `eval' -> eval_atom -> normalize' -> eval'` when called on something that can't
  be simplified like `x`.
-/
unsafe def normalize' (atoms : ref (Buffer expr)) (red : Transparency)
    (mode := NormalizeMode.horner) (recursive := true) :
    expr → optParam _ false → tactic (expr × expr)
  | e, inner => do
    let pow_lemma ← simp_lemmas.mk.add_simp `` pow_one
    let lemmas :=
      match mode with
      | normalize_mode.SOP =>
        [`` horner_def', `` add_zero, `` mul_one, `` mul_add, `` mul_sub, `` mul_assoc_rev,
          `` pow_add_rev, `` pow_add_rev_right, `` mul_neg, `` add_neg_eq_sub]
      | normalize_mode.horner =>
        [`` horner.equations._eqn_1, `` add_zero, `` one_mul, `` pow_one, `` neg_mul,
          `` add_neg_eq_sub]
      | _ => []
    let lemmas ← lemmas.foldlM simp_lemmas.add_simp simp_lemmas.mk
    trans_conv
        (fun e => do
          guard (mode ≠ normalize_mode.raw)
          let (e', pr, _) ← simplify simp_lemmas.mk [] e
          pure (e', pr))
        (fun e => do
          let a ← read_ref atoms
          let norm_rec := if recursive then fun e => normalize' e tt else fun _ => failed
          let (a, e', pr) ←
            ext_simplify_core a { } simp_lemmas.mk (fun _ => failed)
                (fun a _ _ p e => do
                  guard (inner → p)
                  write_ref atoms a
                  let (new_e, pr) ← eval' red atoms norm_rec e
                  let (new_e, pr) ←
                    (match mode with
                        | normalize_mode.raw => fun _ => pure (new_e, pr)
                        | normalize_mode.horner =>
                          trans_conv (fun _ => pure (new_e, pr)) fun e => do
                            let (e', prf, _) ← simplify lemmas [] e
                            pure (e', prf)
                        | normalize_mode.SOP =>
                          (trans_conv fun _ => pure (new_e, pr)) <|
                            (trans_conv fun e => do
                                let (e', prf, _) ← simplify lemmas [] e
                                pure (e', prf)) <|
                              simp_bottom_up' fun e => norm_num.derive e <|> pow_lemma e)
                        e
                  guard ¬new_e == e
                  let a ← read_ref atoms
                  pure (a, new_e, some pr, ff))
                (fun _ _ _ _ _ => failed) `eq e
          write_ref atoms a
          pure (e', pr))
        e
#align tactic.ring.normalize' tactic.ring.normalize'

/-- A `ring`-based normalization simplifier that rewrites ring expressions into the specified mode.

  * `raw` is the form that `ring` actually uses internally, with iterated applications of `horner`.
    Not very readable but useful if you don't want any postprocessing.
    This results in terms like `horner (horner (horner 3 y 1 0) x 2 1) x 1 (horner 1 y 1 0)`.
  * `horner` maintains the Horner form structure, but it unfolds the `horner` definition itself,
    and tries to otherwise minimize parentheses.
    This results in terms like `(3 * x ^ 2 * y + 1) * x + y`.
  * `SOP` means sum of products form, expanding everything to monomials.
    This results in terms like `3 * x ^ 3 * y + x + y`. -/
unsafe def normalize (red : Transparency) (mode := NormalizeMode.horner) (recursive := true)
    (e : expr) : tactic (expr × expr) :=
  using_new_ref mkBuffer fun atoms => normalize' atoms red mode recursive e
#align tactic.ring.normalize tactic.ring.normalize

/-- Configuration for `ring_nf`.

  * `recursive`: if true, atoms inside ring expressions will be reduced recursively
-/
structure RingNfCfg where
  recursive := true
  deriving Inhabited
#align tactic.ring.ring_nf_cfg Tactic.Ring.RingNfCfg

end Ring

namespace Interactive

open Tactic.Ring

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Tactic for solving equations in the language of *commutative* (semi)rings.
        This version of `ring` fails if the target is not an equality
        that is provable by the axioms of commutative (semi)rings. -/
    unsafe
  def
    ring1
    ( red : parse ( tk "!" ) ? ) : tactic Unit
    :=
      let
        transp := if red . isSome then semireducible else reducible
        do
          let q( $ ( e₁ ) = $ ( e₂ ) ) ← target >>= instantiate_mvars
            let
              ( ( e₁' , p₁ ) , ( e₂' , p₂ ) )
                ←
                ring_m.run transp e₁
                  <|
                  Prod.mk <$> eval ( fun _ => failed ) e₁ <*> eval ( fun _ => failed ) e₂
            is_def_eq e₁' e₂'
            let p ← mk_eq_symm p₂ >>= mk_eq_trans p₁
            tactic.exact p
#align tactic.interactive.ring1 tactic.interactive.ring1

/-- Parser for `ring_nf`'s `mode` argument, which can only be the "keywords" `raw`, `horner` or
`SOP`. (Because these are not actually keywords we use a name parser and postprocess the result.)
-/
unsafe def ring.mode : lean.parser Ring.NormalizeMode :=
  with_desc "(SOP|raw|horner)?" do
    let mode ← ident ?
    match mode with
      | none => pure ring.normalize_mode.horner
      | some `horner => pure ring.normalize_mode.horner
      | some `SOP => pure ring.normalize_mode.SOP
      | some `raw => pure ring.normalize_mode.raw
      | _ => failed
#align tactic.interactive.ring.mode tactic.interactive.ring.mode

/-- Simplification tactic for expressions in the language of commutative (semi)rings,
which rewrites all ring expressions into a normal form. When writing a normal form,
`ring_nf SOP` will use sum-of-products form instead of horner form.
`ring_nf!` will use a more aggressive reducibility setting to identify atoms.
-/
unsafe def ring_nf (red : parse (tk "!")?) (SOP : parse ring.mode) (loc : parse location)
    (cfg : RingNfCfg := { }) : tactic Unit := do
  let ns ← loc.get_locals
  let transp := if red.isSome then semireducible else reducible
  let tt ←
    using_new_ref mkBuffer fun atoms =>
        tactic.replace_at (normalize' atoms transp SOP cfg.recursive) ns loc.include_goal |
    fail "ring_nf failed to simplify"
  when loc <| try tactic.reflexivity
#align tactic.interactive.ring_nf tactic.interactive.ring_nf

/-- Tactic for solving equations in the language of *commutative* (semi)rings.
`ring!` will use a more aggressive reducibility setting to identify atoms.

If the goal is not solvable, it falls back to rewriting all ring expressions
into a normal form, with a suggestion to use `ring_nf` instead, if this is the intent.
See also `ring1`, which is the same as `ring` but without the fallback behavior.

Based on [Proving Equalities in a Commutative Ring Done Right
in Coq](http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf) by Benjamin Grégoire
and Assia Mahboubi.
-/
unsafe def ring (red : parse (tk "!")?) : tactic Unit :=
  ring1 red <|> ring_nf red NormalizeMode.horner (Loc.ns [none]) >> trace "Try this: ring_nf"
#align tactic.interactive.ring tactic.interactive.ring

add_hint_tactic ring

add_tactic_doc
  { Name := "ring"
    category := DocCategory.tactic
    declNames := [`` Ring, `` ring_nf, `` ring1]
    inheritDescriptionFrom := `` Ring
    tags := ["arithmetic", "simplification", "decision procedure"] }

end Interactive

end Tactic

namespace Conv.Interactive

open Conv Interactive

open Tactic

open Tactic.Interactive (ring.mode ring1)

open Tactic.Ring (normalize normalize_mode.horner)

-- mathport name: parser.optional
local postfix:1024 "?" => optional

/--
Normalises expressions in commutative (semi-)rings inside of a `conv` block using the tactic `ring`.
-/
unsafe def ring_nf (red : parse (lean.parser.tk "!")?) (SOP : parse ring.mode)
    (cfg : Ring.RingNfCfg := { }) : conv Unit :=
  let transp := if red.isSome then semireducible else reducible
  replace_lhs (normalize transp SOP cfg.recursive) <|> fail "ring_nf failed to simplify"
#align conv.interactive.ring_nf conv.interactive.ring_nf

/--
Normalises expressions in commutative (semi-)rings inside of a `conv` block using the tactic `ring`.
-/
unsafe def ring (red : parse (lean.parser.tk "!")?) : conv Unit :=
  let transp := if red.isSome then semireducible else reducible
  discharge_eq_lhs (ring1 red) <|>
    replace_lhs (normalize transp NormalizeMode.horner) >> trace "Try this: ring_nf" <|>
      fail "ring failed to simplify"
#align conv.interactive.ring conv.interactive.ring

end Conv.Interactive


lemma add_right_eq_zero {a b : ℕ} : a + b = 0 → a = 0 :=
begin
    intro H,
    cases a with d,
    refl,

    rw nat.succ_add at H,
    exfalso,
    apply nat.succ_ne_zero (d + b) H,
end