import Lbar.ext_aux3
import Lbar.iota

noncomputable theory

universes v u u'

open opposite category_theory category_theory.limits category_theory.preadditive
open_locale nnreal zero_object

variables (r r' : ℝ≥0)
variables [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r < 1)] [fact (r' < 1)]

open bounded_homotopy_category

variables {r'}
variables (BD : breen_deligne.package)
variables (κ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
variables [∀ (c : ℝ≥0), BD.data.suitable (κ c)] [∀ n, fact (monotone (function.swap κ n))]
variables [∀ (c : ℝ≥0), BD.data.suitable (κ₂ c)] [∀ n, fact (monotone (function.swap κ₂ n))]
variables (M : ProFiltPseuNormGrpWithTinv₁.{u} r')

section preps

variables (V : SemiNormedGroup.{u}) [complete_space V] [separated_space V]
variables (ι : ulift.{u+1} ℕ → ℝ≥0) (hι : monotone ι)

set_option pp.universes true

lemma homotopy_category.colimit_cofan_bdd {A : Type u} [category.{v} A] [abelian A]
[has_coproducts A] {α : Type v} (X : α → bounded_homotopy_category A)
  [uniformly_bounded X] : homotopy_category.is_bounded_above
  (homotopy_category.colimit_cofan $ λ a : α, (X a).val).X :=
begin
    obtain ⟨n,hn⟩ := homotopy_category.is_uniformly_bounded_above.cond (val ∘ X),
      use n, intros i hi,
    dsimp [homotopy_category.colimit_cofan],
    let e : (∐ λ (a : α), (X a).val.as).X i ≅
      (∐ λ (a : α), (X a).val.as.X i) := homotopy_category.coproduct_iso _ _,
    refine is_zero_of_iso_of_zero _ e.symm,
    apply category_theory.is_zero_colimit,
    intros j,
    apply hn j _ hi,
  end

def Tinv2_iso_of_bicartesian_aux_1
  (i : ℤ) : commsq.{u+2 u+1}
  (shift_sub_id.{u+1}
     ((QprimeFP.{u} r' BD.data κ₂ M).op ⋙
        (Ext.{u+1 u+2} i).flip.obj ((single.{u+1 u+2} (Condensed.{u u+1 u+2} Ab.{u+1}) 0).obj V.to_Cond))
     ι
     hι)
  (pi_Ext_iso_Ext_sigma.{u} BD κ₂ M V (λ (k : ulift.{u+1 0} ℕ), ι k) i).hom
  (pi_Ext_iso_Ext_sigma.{u} BD κ₂ M V (λ (k : ulift.{u+1 0} ℕ), ι k) i).hom
  (((Ext.{u+1 u+2} i).map
      (of_hom.{u+1 u+2} (QprimeFP.shift_sub_id.{u u+2 u+1} ι hι (QprimeFP_int.{u} r' BD.data κ₂ M))).op).app
     ((single.{u+1 u+2} (Condensed.{u u+1 u+2} Ab.{u+1}) 0).obj (Condensed.of_top_ab.{u} ↥V))) :=
begin
    apply commsq.of_eq,
    dsimp only [shift_sub_id, QprimeFP.shift_sub_id],
    simp only [sub_comp, comp_sub, homological_complex.of_hom_sub, category_theory.op_sub,
      functor.map_sub, op_id, category_theory.functor.map_id, of_hom_id,
      nat_trans.app_sub, nat_trans.id_app, category.comp_id, category.id_comp],
    apply congr_arg2 _ _ rfl,
    rw ← iso.eq_comp_inv,
    dsimp only [pi_Ext_iso_Ext_sigma, iso.trans_hom, iso.trans_inv,
      iso.symm_hom, iso.symm_inv, functor.map_iso_hom,
      iso.op_hom, op_comp, functor.flip_obj_map, functor.map_iso_inv],
    simp only [category.assoc, ← nat_trans.comp_app_assoc, ← functor.map_comp_assoc,
      ← functor.map_comp, iso.op_inv, ← op_comp],
    rw cofan_point_iso_colimit_conj_eq_desc,
    rw iso.eq_inv_comp,
    have := Ext_coproduct_iso_naturality_shift _
      (λ (k : ulift ℕ), (QprimeFP r' BD.data κ₂ M).obj (ι k))
      (λ k, (QprimeFP r' BD.data κ₂ M).map (hom_of_le $ hι $
        by exact_mod_cast k.down.le_succ)) i ((single (Condensed Ab) 0).obj V.to_Cond),
    exact this.symm,
    { apply homotopy_category.colimit_cofan_bdd },
end

@[reassoc]
lemma Ext_coproduct_iso_π
  (A : Type u) [category.{v} A] [abelian A] [enough_projectives A] [has_coproducts A] [AB4 A]
  (X : ulift.{v} ℕ → bounded_homotopy_category A) [uniformly_bounded X] (i : ℤ) (Y) (k) :
  (Ext_coproduct_iso X i Y).hom ≫ pi.π _ k =
  ((Ext i).map $ quiver.hom.op $ sigma.ι _ _).app Y :=
begin
  dsimp only [Ext_coproduct_iso, iso.trans_hom, pi_iso, preadditive_yoneda_coproduct_iso,
    as_iso_hom, preadditive_yoneda_coproduct_to_product],
  simp only [category.assoc, limit.lift_π, limit.lift_π_assoc, fan.mk_π_app],
  dsimp only [Ext_iso, iso.symm_hom, functor.map_iso_hom, functor.map_iso_inv],
  simp only [← functor.map_comp, iso.op_hom, iso.op_inv, ← op_comp],
  dsimp only [Ext, Ext0, functor.comp_map, whiskering_left_obj_map, whisker_left_app,
    functor.flip_map_app, replacement_iso],
  congr' 2,
  simp only [category.assoc, iso.inv_comp_eq, quiver.hom.unop_op, unop_op, op_unop],
  apply lift_unique,
  simp only [category.assoc, iso.inv_comp_eq, quiver.hom.unop_op, unop_op, op_unop],
  erw lift_lifts,
  simp only [uniform_π, colimit.ι_desc, cofan.mk_ι_app, lift_lifts_assoc],
  refl,
end

lemma Tinv2_iso_of_bicartesian_aux_2
  [∀ c n, fact (κ₂ c n ≤ r' * κ c n)]
  (j) {e : (homotopy_category.colimit_cofan.{u+1 u+2}
     (λ (a : ulift.{u+1 0} ℕ),
        ((λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ₂ M).obj (ι k)) a).val)).X.is_bounded_above } :
  ((cofan.{u+1 u+2} (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ₂ M).obj (ι k))).ι.app j ≫
     of_hom.{u+1 u+2} (sigma_map.{u u+2 u+1} ι (QprimeFP_int.Tinv.{u} BD.data κ₂ κ M))) ≫
  (cofan_point_iso_colimit.{u} (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ M).obj (ι k))).hom =
  (QprimeFP.Tinv _ _ _ _).app _ ≫
  sigma.ι (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ M).obj (ι k)) j :=
begin
  rw [← iso.eq_comp_inv], simp only [category.assoc, cofan_point_iso_colimit,
    colimit.comp_cocone_point_unique_up_to_iso_inv],
  dsimp only [bounded_homotopy_category.cofan, cofan.mk_ι_app, of_hom,
    homotopy_category.colimit_cofan, QprimeFP.Tinv, whisker_right_app,
    chain_complex.to_bounded_homotopy_category, functor.comp_map],
  erw [← (homotopy_category.quotient.{u+1 u+2 0} (Condensed.{u u+1 u+2} Ab.{u+1}) (complex_shape.up.{0} ℤ)).map_comp],
  erw [← (homotopy_category.quotient.{u+1 u+2 0} (Condensed.{u u+1 u+2} Ab.{u+1}) (complex_shape.up.{0} ℤ)).map_comp],
  congr' 1,
  dsimp only [sigma_map],
  erw [colimit.ι_desc],
  refl,
end

lemma Tinv2_iso_of_bicartesian_aux_3
  [∀ c n, fact (κ₂ c n ≤ κ c n)]
  [∀ c n, fact (κ₂ c n ≤ r' * κ c n)]
  (j)
  {e : (homotopy_category.colimit_cofan.{u+1 u+2}
     (λ (a : ulift.{u+1 0} ℕ),
        ((λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ₂ M).obj (ι k)) a).val)).X.is_bounded_above} :
  (cofan.{u+1 u+2} (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ₂ M).obj (ι k))).ι.app j ≫
  of_hom.{u+1 u+2} (sigma_map.{u u+2 u+1} ι (QprimeFP_int.ι.{u} BD.data κ₂ κ M)) ≫
    (cofan_point_iso_colimit.{u} (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ M).obj (ι k))).hom =
  (QprimeFP.ι _ κ₂ κ M).app _ ≫
  sigma.ι ((λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ M).obj (ι k))) j :=
begin
  simp only [← category.assoc], rw [← iso.eq_comp_inv],
  simp only [category.assoc, cofan_point_iso_colimit, colimit.comp_cocone_point_unique_up_to_iso_inv],
  dsimp only [bounded_homotopy_category.cofan, cofan.mk_ι_app, of_hom,
    homotopy_category.colimit_cofan, QprimeFP.ι, whisker_right_app,
    chain_complex.to_bounded_homotopy_category, functor.comp_map],
  erw [← (homotopy_category.quotient.{u+1 u+2 0} (Condensed.{u u+1 u+2} Ab.{u+1}) (complex_shape.up.{0} ℤ)).map_comp],
  erw [← (homotopy_category.quotient.{u+1 u+2 0} (Condensed.{u u+1 u+2} Ab.{u+1}) (complex_shape.up.{0} ℤ)).map_comp],
  congr' 1,
  dsimp only [sigma_map],
  erw [colimit.ι_desc],
  refl,
end

lemma Tinv2_iso_of_bicartesian_aux [normed_with_aut r V]
  [∀ c n, fact (κ₂ c n ≤ κ c n)] [∀ c n, fact (κ₂ c n ≤ r' * κ c n)]
  (i : ℤ)
  (H1 : (shift_sub_id.commsq (ExtQprime.Tinv2 r r' BD.data κ κ₂ M V i) ι hι).bicartesian) :
  (Ext_Tinv2_commsq (of_hom (sigma_map (λ (k : ulift ℕ), ι k) (QprimeFP_int.Tinv BD.data κ₂ κ M)))
  (of_hom (sigma_map (λ (k : ulift ℕ), ι k) (QprimeFP_int.ι BD.data κ₂ κ M)))
  (of_hom (sigma_map (λ (k : ulift ℕ), ι k) (QprimeFP_int.Tinv BD.data κ₂ κ M)))
  (of_hom (sigma_map (λ (k : ulift ℕ), ι k) (QprimeFP_int.ι BD.data κ₂ κ M)))
  (of_hom (QprimeFP.shift_sub_id ι hι (QprimeFP_int r' BD.data κ₂ M)))
  (of_hom (QprimeFP.shift_sub_id ι hι (QprimeFP_int r' BD.data κ M)))
  (auux $ commsq_shift_sub_id_Tinv _ _ _ _ _ _)
  (auux $ commsq_shift_sub_id_ι _ _ _ _ _ _)
  ((single _ 0).map (Condensed.of_top_ab_map (normed_group_hom.to_add_monoid_hom (normed_with_aut.T.inv : V ⟶ V)) (normed_group_hom.continuous _)))
  i).bicartesian :=
begin
  have h1 := _, have h2 := _, have h3 := _,
  refine commsq.bicartesian.of_iso
    (pi_Ext_iso_Ext_sigma _ _ _ _ _ _) (pi_Ext_iso_Ext_sigma _ _ _ _ _ _)
    (pi_Ext_iso_Ext_sigma _ _ _ _ _ _) (pi_Ext_iso_Ext_sigma _ _ _ _ _ _)
    h1 h2 h2 h3 H1,
  apply Tinv2_iso_of_bicartesian_aux_1,
  { clear h1, apply commsq.of_eq, rw ← iso.eq_comp_inv,
    apply limit.hom_ext, intros j, rw lim_map_π,
    dsimp [pi_Ext_iso_Ext_sigma],
    simp only [category.assoc],
    have := Ext_coproduct_iso_π _
      (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ₂ M).obj (ι k))
      i ((single.{u+1 u+2} (Condensed.{u u+1 u+2} Ab.{u+1}) 0).obj V.to_Cond) j,
    rw [this, ← nat_trans.comp_app, ← functor.map_comp, ← op_comp],
    clear this,
    erw colimit.ι_desc,
    dsimp [Ext_Tinv2, ExtQprime.Tinv2],
    simp only [sub_comp, comp_sub],
    refine congr_arg2 _ _ _,
    { simp only [← nat_trans.comp_app, ← functor.map_comp, ← op_comp],
      rw Tinv2_iso_of_bicartesian_aux_2,
      swap,
      { apply homotopy_category.colimit_cofan_bdd },
      simp only [functor.map_comp, op_comp, nat_trans.comp_app, category.assoc],
      have := Ext_coproduct_iso_π _
        (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ M).obj (ι k))
        i ((single.{u+1 u+2} (Condensed.{u u+1 u+2} Ab.{u+1}) 0).obj V.to_Cond) j,
      rw ← iso.eq_inv_comp at this,
      rw ← reassoc_of this, refl },
    { simp only [category.assoc, nat_trans.naturality, ← nat_trans.comp_app_assoc,
        ← functor.map_comp_assoc, ← functor.map_comp, ← nat_trans.comp_app, ← op_comp],
      rw Tinv2_iso_of_bicartesian_aux_3,
      simp only [functor.map_comp, op_comp, nat_trans.comp_app, category.assoc],
      have := Ext_coproduct_iso_π _
        (λ (k : ulift.{u+1 0} ℕ), (QprimeFP.{u} r' BD.data κ M).obj (ι k))
        i ((single.{u+1 u+2} (Condensed.{u u+1 u+2} Ab.{u+1}) 0).obj V.to_Cond) j,
      rw ← iso.eq_inv_comp at this,
      rw ← reassoc_of this,
      refl,
      { apply homotopy_category.colimit_cofan_bdd } } },
  apply Tinv2_iso_of_bicartesian_aux_1,
end

lemma Tinv2_iso_of_bicartesian [normed_with_aut r V]
  [∀ c n, fact (κ₂ c n ≤ κ c n)] [∀ c n, fact (κ₂ c n ≤ r' * κ c n)]
  (hκ : Lbar.sufficiently_increasing κ ι)
  (hκ₂ : Lbar.sufficiently_increasing κ₂ ι)
  (i : ℤ)
  (H1 : (shift_sub_id.commsq (ExtQprime.Tinv2 r r' BD.data κ κ₂ M V i) ι hι).bicartesian)
  (H2 : (shift_sub_id.commsq (ExtQprime.Tinv2 r r' BD.data κ κ₂ M V (i+1)) ι hι).bicartesian) :
  is_iso (((Ext (i+1)).map ((BD.eval freeCond'.{u}).map M.Tinv_cond).op).app
    ((single (Condensed Ab) 0).obj V.to_Cond) -
    ((Ext (i+1)).obj ((BD.eval freeCond').op.obj (op (M.to_Condensed)))).map
      ((single (Condensed Ab) 0).map
        (Condensed.of_top_ab_map
          (normed_group_hom.to_add_monoid_hom normed_with_aut.T.inv) (normed_group_hom.continuous _)))) :=
begin
  let Vc := (single (Condensed Ab) 0).obj V.to_Cond,
  have SES₁ := QprimeFP.short_exact BD κ₂ M ι hι hκ₂,
  have SES₂ := QprimeFP.short_exact BD κ M ι hι hκ,
  have := Ext_iso_of_bicartesian_of_bicartesian SES₁ SES₂
    (sigma_map _ (QprimeFP_int.Tinv BD.data _ _ M))
    (sigma_map _ (QprimeFP_int.Tinv BD.data _ _ M))
    (category_theory.functor.map _ M.Tinv_cond)
    (sigma_map _ (QprimeFP_int.ι BD.data _ _ M))
    (sigma_map _ (QprimeFP_int.ι BD.data _ _ M))
    (commsq_shift_sub_id_Tinv BD.data _ _ M ι hι)
    (commsq_sigma_proj_Tinv BD _ _ M ι)
    (commsq_shift_sub_id_ι BD.data _ _ M ι hι)
    (commsq_sigma_proj_ι BD _ _ M ι)
    Vc ((single _ _).map $ Condensed.of_top_ab_map
      (normed_group_hom.to_add_monoid_hom normed_with_aut.T.inv) (normed_group_hom.continuous _))
    _
    (Tinv2_iso_of_bicartesian_aux _ _ _ _ _ _ _ _ _ H1)
    (Tinv2_iso_of_bicartesian_aux _ _ _ _ _ _ _ _ _ H2),
  delta Ext_Tinv2 at this,
  simpa only [op_id, category_theory.functor.map_id, category.id_comp, nat_trans.id_app],
end

lemma Tinv2_iso_of_bicartesian' [normed_with_aut r V]
  [∀ c n, fact (κ₂ c n ≤ κ c n)] [∀ c n, fact (κ₂ c n ≤ r' * κ c n)]
  (H : ∀ i, ∃ (ι) (hι),
    Lbar.sufficiently_increasing κ ι ∧
    Lbar.sufficiently_increasing κ₂ ι ∧
    (shift_sub_id.commsq (ExtQprime.Tinv2 r r' BD.data κ κ₂ M V i) ι hι).bicartesian ∧
    (shift_sub_id.commsq (ExtQprime.Tinv2 r r' BD.data κ κ₂ M V (i+1)) ι hι).bicartesian)
  (i : ℤ) :
  is_iso (((Ext i).map ((BD.eval freeCond'.{u}).map M.Tinv_cond).op).app
    ((single (Condensed Ab) 0).obj V.to_Cond) -
    ((Ext i).obj ((BD.eval freeCond').op.obj (op (M.to_Condensed)))).map
      ((single (Condensed Ab) 0).map
        (Condensed.of_top_ab_map
          (normed_group_hom.to_add_monoid_hom normed_with_aut.T.inv) (normed_group_hom.continuous _)))) :=
begin
  obtain ⟨i, rfl⟩ : ∃ k, k+1 = i := ⟨i-1, sub_add_cancel _ _⟩,
  obtain ⟨ι, hι, hκ, hκ₂, H1, H2⟩ := H i,
  apply Tinv2_iso_of_bicartesian _ _ _ _ _ _ ι hι hκ hκ₂ i H1 H2,
end

end preps


import ReactorModel.Determinism.InstantaneousStep

open Classical

namespace Execution
namespace Instantaneous
namespace Execution

variable [ReactorType.Indexable α] {s₁ s₂ : State α}

theorem progress_not_mem_rcns (e : s₁ ⇓ᵢ* s₂) (h : rcn ∈ s₁.progress) : rcn ∉ e.rcns := by
  induction e <;> simp [rcns, not_or]
  case trans e e' hi =>
    simp [hi $ e.monotonic_progress h]
    intro hc
    exact absurd (hc ▸ h) e.rcn_not_mem_progress

theorem mem_progress_iff (e : s₁ ⇓ᵢ* s₂) :
    (rcn ∈ s₂.progress) ↔ (rcn ∈ e.rcns ∨ rcn ∈ s₁.progress) := by
  induction e <;> simp [rcns]
  case trans s₁ s₂ s₃ e e' hi =>
    simp [hi]
    constructor <;> intro
    all_goals repeat cases ‹_ ∨ _› <;> simp [*]
    case mp.inr h      => cases e.mem_progress_iff.mp h <;> simp [*]
    case mpr.inl.inl h => simp [e.rcn_mem_progress]
    case mpr.inr h     => simp [e.monotonic_progress h]

-- Corollary of `InstExecution.mem_progress_iff`.
theorem rcns_mem_progress (e : s₁ ⇓ᵢ* s₂) (h : rcn ∈ e.rcns) : rcn ∈ s₂.progress :=
  e.mem_progress_iff.mpr $ .inl h

theorem rcns_nodup {s₁ s₂ : State α} : (e : s₁ ⇓ᵢ* s₂) → e.rcns.Nodup
  | refl       => List.nodup_nil
  | trans e e' => List.nodup_cons.mpr ⟨e'.progress_not_mem_rcns e.rcn_mem_progress, e'.rcns_nodup⟩

theorem progress_eq_rcns_perm
    (e₁ : s ⇓ᵢ* s₁) (e₂ : s ⇓ᵢ* s₂) (hp : s₁.progress = s₂.progress) : e₁.rcns ~ e₂.rcns := by
  apply List.perm_ext e₁.rcns_nodup e₂.rcns_nodup |>.mpr
  intro rcn
  by_cases hc : rcn ∈ s.progress
  case pos => simp [e₁.progress_not_mem_rcns hc, e₂.progress_not_mem_rcns hc]
  case neg =>
    constructor <;> intro hm
    case mp  => exact e₂.mem_progress_iff.mp (hp ▸ e₁.rcns_mem_progress hm) |>.resolve_right hc
    case mpr => exact e₁.mem_progress_iff.mp (hp ▸ e₂.rcns_mem_progress hm) |>.resolve_right hc

theorem preserves_tag {s₁ s₂ : State α} : (s₁ ⇓ᵢ* s₂) → s₁.tag = s₂.tag
  | refl => rfl
  | trans e e' => e.preserves_tag.trans e'.preserves_tag

theorem rcns_trans_eq_cons (e₁ : s ⇓ᵢ s₁) (e₂ : s₁ ⇓ᵢ* s₂) :
    (trans e₁ e₂).rcns = e₁.rcn :: e₂.rcns := by
  simp [rcns, Step.rcn]

theorem progress_eq {s₁ s₂ : State α} :
    (e : s₁ ⇓ᵢ* s₂) → s₂.progress = s₁.progress ∪ { i | i ∈ e.rcns }
  | refl => by simp [rcns]
  | trans e e' => by
    simp [e.progress_eq ▸ e'.progress_eq, rcns_trans_eq_cons]
    apply Set.insert_union'

theorem mem_rcns_not_mem_progress (e : s₁ ⇓ᵢ* s₂) (h : rcn ∈ e.rcns) : rcn ∉ s₁.progress := by
  induction e
  case refl => contradiction
  case trans e e' hi =>
    cases e'.rcns_trans_eq_cons e ▸ h
    case head   => exact e.rcn_not_mem_progress
    case tail h => exact mt e.monotonic_progress (hi h)

theorem mem_rcns_iff (e : s₁ ⇓ᵢ* s₂) : rcn ∈ e.rcns ↔ (rcn ∈ s₂.progress ∧ rcn ∉ s₁.progress) := by
  simp [e.progress_eq, s₁.mem_record'_progress_iff e.rcns rcn, or_and_right]
  exact e.mem_rcns_not_mem_progress

theorem equiv {s₁ s₂ : State α} : (s₁ ⇓ᵢ* s₂) → s₁.rtr ≈ s₂.rtr
  | refl => .refl
  | trans e e' => ReactorType.Equivalent.trans e.equiv e'.equiv

theorem head_minimal (e : s₁ ⇓ᵢ s₂) (e' : s₂ ⇓ᵢ* s₃) : (e.rcn :: e'.rcns) ≮[s₁.rtr] e.rcn := by
  by_contra hc
  simp [Minimal] at hc
  have ⟨_, hm, h⟩ := hc e.acyclic
  replace hc := mt e.monotonic_progress $ e'.mem_rcns_not_mem_progress hm
  exact absurd (e.allows_rcn.deps h) hc

theorem head_not_mem_tail (e : s₁ ⇓ᵢ s₂) (e' : s₂ ⇓ᵢ* s₃) (h : i ∈ e'.rcns) : e.rcn ≠ i := by
  intro hc
  have := trans e e' |>.rcns_nodup
  have := hc.symm ▸ List.not_nodup_cons_of_mem h
  contradiction

-- The core lemma for `prepend_minimal`.
theorem cons_prepend_minimal
    (e : s₁ ⇓ᵢ s₂) (e' : s₂ ⇓ᵢ* s₃) (hm : i ∈ e'.rcns) (hr : (e.rcn :: e'.rcns) ≮[s₁.rtr] i) :
    ∃ f : s₁ ⇓ᵢ* s₃, f.rcns = i :: e.rcn :: (e'.rcns.erase i) := by
  induction e' generalizing s₁ <;> simp [rcns] at *
  case trans s₁ s₂ s₄ e' e'' hi =>
    cases hm
    case inl hm =>
      simp [hm] at hr
      have ⟨_, f, f', ⟨hf₁, hf₂⟩⟩ := e.prepend_indep e' hr.cons_head
      exists trans f $ trans f' e''
      simp [hm, rcns, ←hf₁, ←hf₂]
    case inr hm =>
      have ⟨f, hf⟩ :=  hi e' hm $ hr.cons_tail.equiv e.equiv
      cases f <;> simp [rcns] at hf
      case trans f f'' =>
        have ⟨h₁, h₂⟩ := hf
        have ⟨_, f, f', ⟨hf₁, hf₂⟩⟩ := e.prepend_indep f $ h₁.symm ▸ hr |>.cons_head
        exists trans f $ trans f' f''
        simp [rcns, hf₁, h₁, hf₂, h₂, e''.rcns.erase_cons_tail $ head_not_mem_tail e' e'' hm]

theorem prepend_minimal (e : s₁ ⇓ᵢ* s₂) (hm : i ∈ e.rcns) (hr : e.rcns ≮[s₁.rtr] i) :
    ∃ (e' : s₁ ⇓ᵢ* s₂), e'.rcns = i :: (e.rcns.erase i) := by
  cases e <;> simp [rcns] at *; cases ‹_ ∨ _›
  case trans.inl e e' h =>
    exists trans e e'
    simp [rcns, h]
  case trans.inr e e' h =>
    exact e'.rcns.erase_cons_tail (head_not_mem_tail e e' h) ▸ cons_prepend_minimal e e' h hr

theorem rcns_perm_deterministic
    (e₁ : s ⇓ᵢ* s₁) (e₂ : s ⇓ᵢ* s₂) (hp : e₁.rcns ~ e₂.rcns) : s₁.rtr = s₂.rtr := by
  induction e₁
  case refl => cases e₂ <;> simp [rcns] at hp ⊢
  case trans s sₘ₁ s₁ e₁ e₁' hi =>
    have hm := hp.mem_iff.mp $ List.mem_cons_self _ _
    have hm' := e₁'.head_minimal e₁ |>.perm hp
    have ⟨e₂, he₂⟩ := e₂.prepend_minimal hm hm'
    cases e₂ <;> simp [rcns] at he₂
    case trans sₘ₂ e₂ e₂' =>
      have ⟨h, h'⟩ := he₂
      cases e₁.deterministic e₂ h.symm
      apply hi e₂'
      rw [h']
      exact List.perm_cons _ |>.mp (hp.trans $ List.perm_cons_erase hm)

protected theorem deterministic
    (e₁ : s ⇓ᵢ* s₁) (e₂ : s ⇓ᵢ* s₂) (ht : s₁.tag = s₂.tag) (hp : s₁.progress = s₂.progress) :
    s₁ = s₂ := by
  ext1 <;> try assumption
  exact rcns_perm_deterministic e₁ e₂ $ progress_eq_rcns_perm e₁ e₂ hp

end Execution
end Instantaneous
end Execution


import data.real.irrational
import topology.basic
import algebra.order.floor

--OUTPUT 1
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
begin
  have h1 : ∀ i j : ℤ, i ≠ j → int.fract (α * ↑i) ≠ int.fract (α * ↑j), from by auto [int.fract_eq_iff, hα_irrat],
  have h2 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h1],
  have h3 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h2],
  have h4 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h3],
  have h5 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h4],
  have h6 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h5],
  have h7 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h6],
  have h8 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h7],
  have h9 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h8],
  have h10 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h9],
  have h11 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h10],
  have h12 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h11],
  have h13 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h12],
  have h14 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h13],
  have h15 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h14],
  have h16 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h15],
  have h17 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h16],
  have h18 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h17],
  have h19 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h18],
  have h20 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h19],
  have h21 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h20],
  have h22 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h21],
  have h23 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h22],
  have h24 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h23],
  have h25 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h24],
  have h26 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h25],
  have h27 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h26],
  have h28 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h27],
  have h29 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h28],
  have h30 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h29],
  have h31 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h30],
  have h32 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h31],
  have h33 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h32],
  have h34 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h33],
  have h35 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h34],
  have h36 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h35],
  have h37 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h36],
  have h38 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h37],
  have h39 : ∀ i j : ℤ, i ≠ j → (int.fract (α * ↑i)) ≠ (int.fract (α * ↑j)), from by auto [h38
end --Needs more than 2000 tokens!

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from by auto [set.subset_of_mem_powerset, set.subset_of_mem_powerset],
  have h2 : (A ∩ B) ⊆ A, from by auto [set.inter_subset_left],
  have h3 : (A ∩ B) ⊆ S, from by auto [set.subset.trans],
  show (A ∩ B) ∈  𝒫 S, from by auto [set.mem_powerset],
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by auto [sq]
  ... = x*(x+y) + y*(x+y) : by auto [add_mul]
  ... = x*x + x*y + y*x + y*y : by auto [mul_comm, add_mul] using [ring]
  ... = x^2 + 2*x*y + y^2 : by auto [sq, mul_comm] using [ring]
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from by auto using [use (a⁻¹ * b)],
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from by auto using [use b * a⁻¹],

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from by auto [h1],
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from by auto [h2],

  have h5 : ∀ a : G, classical.some (h3 a).exists = (1 : G), from by auto [exists_unique.unique, h3, classical.some_spec, exists_unique.exists, mul_one],
  have h6 : ∀ a : G, classical.some (h4 a).exists = (1 : G), from by auto [exists_unique.unique, h4, classical.some_spec, exists_unique.exists, one_mul],

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by auto [h3, h4, exists_unique.unique, classical.some_spec, exists_unique.exists] using [use (1 : G)],
end

/--`theorem`
Density of irrational orbit
The fractional parts of the integer multiples of an irrational number form a dense subset of the unit interval
`proof`
Let $\alpha$ be an irrational number. Then for distinct $i, j \in \mathbb{Z}$, we must have $\{i \alpha\} \neq\{j \alpha\}$. If this were not true, then
$$
i \alpha-\lfloor i \alpha\rfloor=\{i \alpha\}=\{j \alpha\}=j \alpha-\lfloor j \alpha\rfloor,
$$
which yields the false statement $\alpha=\frac{\lfloor i \alpha\rfloor-\lfloor j \alpha\rfloor}{i-j} \in \mathbb{Q}$. Hence,
$$
S:=\{\{i \alpha\} \mid i \in \mathbb{Z}\}
$$
is an infinite subset of $\left[0,1\right]$.

By the Bolzano-Weierstrass theorem, $S$ has a limit point in $[0, 1]$. One can thus find pairs of elements of $S$ that are arbitrarily close. Since (the absolute value of) the difference of any two elements of $S$ is also an element of $S$, it follows that $0$ is a limit point of $S$.

To show that $S$ is dense in $[0, 1]$, consider $y \in[0,1]$, and $\epsilon>0$. Then by selecting $x \in S$ such that $\{x\}<\epsilon$ (which exists as $0$ is a limit point), and $N$ such that $N \cdot\{x\} \leq y<(N+1) \cdot\{x\}$, we get: $|y-\{N x\}|<\epsilon$.

QED
-/
theorem  irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=
FEW SHOT PROMPTS TO CODEX(END)-/


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Match.Match
import Lean.Meta.Match.MatchEqsExt
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Refl
import Lean.Meta.Tactic.Delta
import Lean.Meta.Tactic.SplitIf
import Lean.Meta.Tactic.Injection
import Lean.Meta.Tactic.Contradiction

namespace Lean.Meta

/--
  Helper method for `proveCondEqThm`. Given a goal of the form `C.rec ... xMajor = rhs`,
  apply `cases xMajor`. -/
partial def casesOnStuckLHS (mvarId : MVarId) : MetaM (Array MVarId) := do
  let target ← mvarId.getType
  if let some (_, lhs, _) ← matchEq? target then
    if let some fvarId ← findFVar? lhs then
      return (←  mvarId.cases fvarId).map fun s => s.mvarId
  throwError "'casesOnStuckLHS' failed"
where
  findFVar? (e : Expr) : MetaM (Option FVarId) := do
    match e.getAppFn with
    | Expr.proj _ _ e => findFVar? e
    | f =>
      if !f.isConst then
        return none
      else
        let declName := f.constName!
        let args := e.getAppArgs
        match (← getProjectionFnInfo? declName) with
        | some projInfo =>
          if projInfo.numParams < args.size then
            findFVar? args[projInfo.numParams]!
          else
            return none
        | none =>
          matchConstRec f (fun _ => return none) fun recVal _ => do
            if recVal.getMajorIdx >= args.size then
              return none
            let major := args[recVal.getMajorIdx]!
            if major.isFVar then
              return some major.fvarId!
            else
              return none

def casesOnStuckLHS? (mvarId : MVarId) : MetaM (Option (Array MVarId)) := do
  try casesOnStuckLHS mvarId catch _ => return none

namespace Match

def unfoldNamedPattern (e : Expr) : MetaM Expr := do
  let visit (e : Expr) : MetaM TransformStep := do
    if let some e := isNamedPattern? e then
      if let some eNew ← unfoldDefinition? e then
        return TransformStep.visit eNew
    return .continue
  Meta.transform e (pre := visit)

/--
  Similar to `forallTelescopeReducing`, but

  1. Eliminates arguments for named parameters and the associated equation proofs.

  2. Equality parameters associated with the `h : discr` notation are replaced with `rfl` proofs.
     Recall that this kind of parameter always occurs after the parameters correspoting to pattern variables.
     `numNonEqParams` is the size of the prefix.

  The continuation `k` takes four arguments `ys args mask type`.
  - `ys` are variables for the hypotheses that have not been eliminated.
  - `eqs` are variables for equality hypotheses associated with discriminants annotated with `h : discr`.
  - `args` are the arguments for the alternative `alt` that has type `altType`. `ys.size <= args.size`
  - `mask[i]` is true if the hypotheses has not been eliminated. `mask.size == args.size`.
  - `type` is the resulting type for `altType`.

  We use the `mask` to build the splitter proof. See `mkSplitterProof`.
-/
partial def forallAltTelescope (altType : Expr) (numNonEqParams : Nat)
    (k : (ys : Array Expr) → (eqs : Array Expr) → (args : Array Expr) → (mask : Array Bool) → (type : Expr) → MetaM α)
    : MetaM α := do
  go #[] #[] #[] #[] 0 altType
where
  go (ys : Array Expr) (eqs : Array Expr) (args : Array Expr) (mask : Array Bool) (i : Nat) (type : Expr) : MetaM α := do
    let type ← whnfForall type
    match type with
    | Expr.forallE n d b .. =>
      if i < numNonEqParams then
        let d ← unfoldNamedPattern d
        withLocalDeclD n d fun y => do
          let typeNew := b.instantiate1 y
          if let some (_, lhs, rhs) ← matchEq? d then
            if lhs.isFVar && ys.contains lhs && args.contains lhs && isNamedPatternProof typeNew y then
               let some i  := ys.getIdx? lhs | unreachable!
               let ys      := ys.eraseIdx i
               let some j  := args.getIdx? lhs | unreachable!
               let mask    := mask.set! j false
               let args    := args.map fun arg => if arg == lhs then rhs else arg
               let args    := args.push (← mkEqRefl rhs)
               let typeNew := typeNew.replaceFVar lhs rhs
               return (← go ys eqs args (mask.push false) (i+1) typeNew)
          go (ys.push y) eqs (args.push y) (mask.push true) (i+1) typeNew
      else
        let arg ← if let some (_, _, rhs) ← matchEq? d then
          mkEqRefl rhs
        else if let some (_, _, _, rhs) ← matchHEq? d then
          mkHEqRefl rhs
        else
          throwError "unexpected match alternative type{indentExpr altType}"
        withLocalDeclD n d fun eq => do
          let typeNew := b.instantiate1 eq
          go ys (eqs.push eq) (args.push arg) (mask.push false) (i+1) typeNew
    | _ =>
      let type ← unfoldNamedPattern type
      /- Recall that alternatives that do not have variables have a `Unit` parameter to ensure
         they are not eagerly evaluated. -/
      if ys.size == 1 then
        if (← inferType ys[0]!).isConstOf ``Unit && !(← dependsOn type ys[0]!.fvarId!) then
          return (← k #[] #[] #[mkConst ``Unit.unit] #[false] type)
      k ys eqs args mask type

  isNamedPatternProof (type : Expr) (h : Expr) : Bool :=
    Option.isSome <| type.find? fun e =>
      if let some e := isNamedPattern? e then
        e.appArg! == h
      else
        false

namespace SimpH

/--
  State for the equational theorem hypothesis simplifier.

  Recall that each equation contains additional hypotheses to ensure the associated case does not taken by previous cases.
  We have one hypothesis for each previous case.

  Each hypothesis is of the form `forall xs, eqs → False`

  We use tactics to minimize code duplication.
-/
structure State where
  mvarId : MVarId            -- Goal representing the hypothesis
  xs  : List FVarId          -- Pattern variables for a previous case
  eqs : List FVarId          -- Equations to be processed
  eqsNew : List FVarId := [] -- Simplied (already processed) equations

abbrev M := StateRefT State MetaM

/--
  Apply the given substitution to `fvarIds`.
  This is an auxiliary method for `substRHS`.
-/
private def applySubst (s : FVarSubst) (fvarIds : List FVarId) : List FVarId :=
  fvarIds.filterMap fun fvarId => match s.apply (mkFVar fvarId) with
    | Expr.fvar fvarId .. => some fvarId
    | _ => none

/--
  Given an equation of the form `lhs = rhs` where `rhs` is variable in `xs`,
  the replace it everywhere with `lhs`.
-/
private def substRHS (eq : FVarId) (rhs : FVarId) : M Unit := do
  assert! (← get).xs.contains rhs
  let (subst, mvarId) ← substCore (← get).mvarId eq (symm := true)
  modify fun s => { s with
    mvarId,
    xs  := applySubst subst (s.xs.erase rhs)
    eqs := applySubst subst s.eqs
    eqsNew := applySubst subst s.eqsNew
  }

private def isDone : M Bool :=
  return (← get).eqs.isEmpty

/-- Customized `contradiction` tactic for `simpH?` -/
private def contradiction (mvarId : MVarId) : MetaM Bool :=
   mvarId.contradictionCore { genDiseq := false, emptyType := false }

/--
  Auxiliary tactic that tries to replace as many variables as possible and then apply `contradiction`.
  We use it to discard redundant hypotheses.
-/
partial def trySubstVarsAndContradiction (mvarId : MVarId) : MetaM Bool :=
  commitWhen do
    let mvarId ← substVars mvarId
    match (← injections mvarId) with
    | .solved => return true -- closed goal
    | .subgoal mvarId' _ =>
      if mvarId' == mvarId then
        contradiction mvarId
      else
        trySubstVarsAndContradiction mvarId'

private def processNextEq : M Bool := do
  let s ← get
  s.mvarId.withContext do
    -- If the goal is contradictory, the hypothesis is redundant.
    if (← contradiction s.mvarId) then
      return false
    if let eq :: eqs := s.eqs then
      modify fun s => { s with eqs }
      let eqType ← inferType (mkFVar eq)
      -- See `substRHS`. Recall that if `rhs` is a variable then if must be in `s.xs`
      if let some (_, lhs, rhs) ← matchEq? eqType then
        if (← isDefEq lhs rhs) then
          return true
        if rhs.isFVar then
          substRHS eq rhs.fvarId!
          return true
      if let some (α, lhs, β, rhs) ← matchHEq? eqType then
        -- Try to convert `HEq` into `Eq`
        if (← isDefEq α β) then
          let (eqNew, mvarId) ← heqToEq s.mvarId eq (tryToClear := true)
          modify fun s => { s with mvarId, eqs := eqNew :: s.eqs }
          return true
        -- If it is not possible, we try to show the hypothesis is redundant by substituting even variables that are not at `s.xs`, and then use contradiction.
        else
          match lhs.isConstructorApp? (← getEnv), rhs.isConstructorApp? (← getEnv) with
          | some lhsCtor, some rhsCtor =>
            if lhsCtor.name != rhsCtor.name then
              return false -- If the constructors are different, we can discard the hypothesis even if it a heterogeneous equality
            else if (← trySubstVarsAndContradiction s.mvarId) then
              return false
          | _, _ =>
            if (← trySubstVarsAndContradiction s.mvarId) then
              return false
      try
        -- Try to simplify equation using `injection` tactic.
        match (← injection s.mvarId eq) with
        | InjectionResult.solved => return false
        | InjectionResult.subgoal mvarId eqNews .. =>
          modify fun s => { s with mvarId, eqs := eqNews.toList ++ s.eqs }
      catch _ =>
        modify fun s => { s with eqsNew := eq :: s.eqsNew }
    return true

partial def go : M Bool := do
  if (← isDone) then
    return true
  else if (← processNextEq) then
    go
  else
    return false

end SimpH

/--
  Auxiliary method for simplifying equational theorem hypotheses.

  Recall that each equation contains additional hypotheses to ensure the associated case was not taken by previous cases.
  We have one hypothesis for each previous case.
-/
private partial def simpH? (h : Expr) (numEqs : Nat) : MetaM (Option Expr) := withDefault do
  let numVars ← forallTelescope h fun ys _ => pure (ys.size - numEqs)
  let mvarId := (← mkFreshExprSyntheticOpaqueMVar h).mvarId!
  let (xs, mvarId) ← mvarId.introN numVars
  let (eqs, mvarId) ← mvarId.introN numEqs
  let (r, s) ← SimpH.go |>.run { mvarId, xs := xs.toList, eqs := eqs.toList }
  if r then
    s.mvarId.withContext do
      let eqs := s.eqsNew.reverse.toArray.map mkFVar
      let mut r ← mkForallFVars eqs (mkConst ``False)
      /- We only include variables in `xs` if there is a dependency. -/
      for x in s.xs.reverse do
        if (← dependsOn r x) then
          r ← mkForallFVars #[mkFVar x] r
      trace[Meta.Match.matchEqs] "simplified hypothesis{indentExpr r}"
      check r
      return some r
  else
    return none

private def substSomeVar (mvarId : MVarId) : MetaM (Array MVarId) := mvarId.withContext do
  for localDecl in (← getLCtx) do
    if let some (_, lhs, rhs) ← matchEq? localDecl.type then
      if lhs.isFVar then
        if !(← dependsOn rhs lhs.fvarId!) then
          match (← subst? mvarId lhs.fvarId!) with
          | some mvarId => return #[mvarId]
          | none => pure ()
  throwError "substSomeVar failed"

/--
  Helper method for proving a conditional equational theorem associated with an alternative of
  the `match`-eliminator `matchDeclName`. `type` contains the type of the theorem. -/
partial def proveCondEqThm (matchDeclName : Name) (type : Expr) : MetaM Expr := withLCtx {} {} do
  let type ← instantiateMVars type
  forallTelescope type fun ys target => do
    let mvar0  ← mkFreshExprSyntheticOpaqueMVar target
    trace[Meta.Match.matchEqs] "proveCondEqThm {mvar0.mvarId!}"
    let mvarId ← mvar0.mvarId!.deltaTarget (· == matchDeclName)
    withDefault <| go mvarId 0
    mkLambdaFVars ys (← instantiateMVars mvar0)
where
  go (mvarId : MVarId) (depth : Nat) : MetaM Unit := withIncRecDepth do
    trace[Meta.Match.matchEqs] "proveCondEqThm.go {mvarId}"
    let mvarId' ← mvarId.modifyTargetEqLHS whnfCore
    let mvarId := mvarId'
    let subgoals ←
      (do mvarId.refl; return #[])
      <|>
      (do mvarId.contradiction { genDiseq := true }; return #[])
      <|>
      (casesOnStuckLHS mvarId)
      <|>
      (do let mvarId' ← simpIfTarget mvarId (useDecide := true)
          if mvarId' == mvarId then throwError "simpIf failed"
          return #[mvarId'])
      <|>
      (do if let some (s₁, s₂) ← splitIfTarget? mvarId then
            let mvarId₁ ← trySubst s₁.mvarId s₁.fvarId
            return #[mvarId₁, s₂.mvarId]
          else
            throwError "spliIf failed")
      <|>
      (substSomeVar mvarId)
      <|>
      (throwError "failed to generate equality theorems for `match` expression `{matchDeclName}`\n{MessageData.ofGoal mvarId}")
    subgoals.forM (go · (depth+1))

/-- Construct new local declarations `xs` with types `altTypes`, and then execute `f xs`  -/
private partial def withSplitterAlts (altTypes : Array Expr) (f : Array Expr → MetaM α) : MetaM α := do
  let rec go (i : Nat) (xs : Array Expr) : MetaM α := do
    if h : i < altTypes.size then
      let hName := (`h).appendIndexAfter (i+1)
      withLocalDeclD hName (altTypes.get ⟨i, h⟩) fun x =>
        go (i+1) (xs.push x)
    else
      f xs
  go 0 #[]

inductive InjectionAnyResult where
  | solved
  | failed
  | subgoal (mvarId : MVarId)

private def injectionAnyCandidate? (type : Expr) : MetaM (Option (Expr × Expr)) := do
  if let some (_, lhs, rhs) ← matchEq? type then
    return some (lhs, rhs)
  else if let some (α, lhs, β, rhs) ← matchHEq? type then
    if (← isDefEq α β) then
      return some (lhs, rhs)
  return none

private def injectionAny (mvarId : MVarId) : MetaM InjectionAnyResult :=
  mvarId.withContext do
    for localDecl in (← getLCtx) do
      if let some (lhs, rhs) ← injectionAnyCandidate? localDecl.type then
        unless (← isDefEq lhs rhs) do
          let lhs ← whnf lhs
          let rhs ← whnf rhs
          unless lhs.isNatLit && rhs.isNatLit do
            try
              match (← injection mvarId localDecl.fvarId) with
              | InjectionResult.solved  => return InjectionAnyResult.solved
              | InjectionResult.subgoal mvarId .. => return InjectionAnyResult.subgoal mvarId
            catch ex =>
              trace[Meta.Match.matchEqs] "injectionAnyFailed at {localDecl.userName}, error\n{ex.toMessageData}"
              pure ()
    return InjectionAnyResult.failed

private abbrev ConvertM := ReaderT (FVarIdMap (Expr × Nat × Array Bool)) $ StateRefT (Array MVarId) MetaM

/--
  Construct a proof for the splitter generated by `mkEquationsfor`.
  The proof uses the definition of the `match`-declaration as a template (argument `template`).
  - `alts` are free variables corresponding to alternatives of the `match` auxiliary declaration being processed.
  - `altNews` are the new free variables which contains aditional hypotheses that ensure they are only used
     when the previous overlapping alternatives are not applicable. -/
private partial def mkSplitterProof (matchDeclName : Name) (template : Expr) (alts altsNew : Array Expr)
    (altsNewNumParams : Array Nat)
    (altArgMasks : Array (Array Bool)) : MetaM Expr := do
  trace[Meta.Match.matchEqs] "proof template: {template}"
  let map := mkMap
  let (proof, mvarIds) ← convertTemplate template |>.run map |>.run #[]
  trace[Meta.Match.matchEqs] "splitter proof: {proof}"
  for mvarId in mvarIds do
    proveSubgoal mvarId
  instantiateMVars proof
where
  mkMap : FVarIdMap (Expr × Nat × Array Bool) := Id.run do
    let mut m := {}
    for alt in alts, altNew in altsNew, numParams in altsNewNumParams, argMask in altArgMasks do
      m := m.insert alt.fvarId! (altNew, numParams, argMask)
    return m

  trimFalseTrail (argMask : Array Bool) : Array Bool :=
    if argMask.isEmpty then
      argMask
    else if !argMask.back then
      trimFalseTrail argMask.pop
    else
      argMask

  /--
    Auxiliary function used at `convertTemplate` to decide whether to use `convertCastEqRec`.
    See `convertCastEqRec`.  -/
  isCastEqRec (e : Expr) : ConvertM Bool := do
    -- TODO: we do not handle `Eq.rec` since we never found an example that needed it.
    -- If we find one we must extend `convertCastEqRec`.
    unless e.isAppOf ``Eq.ndrec do return false
    unless e.getAppNumArgs > 6 do return false
    for arg in e.getAppArgs[6:] do
      if arg.isFVar && (← read).contains arg.fvarId! then
        return true
    return true

  /--
    Auxiliary function used at `convertTemplate`. It is needed when the auxiliary `match` declaration had to refine the type of its
    minor premises during dependent pattern match. For an example, consider
    ```
    inductive Foo : Nat → Type _
    | nil             : Foo 0
    | cons  (t: Foo l): Foo l

    def Foo.bar (t₁: Foo l₁): Foo l₂ → Bool
    | cons s₁ => t₁.bar s₁
    | _ => false
    attribute [simp] Foo.bar
    ```
    The auxiliary `Foo.bar.match_1` is of the form
    ```
    def Foo.bar.match_1.{u_1} : {l₂ : Nat} →
      (t₂ : Foo l₂) →
        (motive : Foo l₂ → Sort u_1) →
          (t₂ : Foo l₂) → ((s₁ : Foo l₂) → motive (Foo.cons s₁)) → ((x : Foo l₂) → motive x) → motive t₂ :=
    fun {l₂} t₂ motive t₂_1 h_1 h_2 =>
      (fun t₂_2 =>
          Foo.casesOn (motive := fun a x => l₂ = a → HEq t₂_1 x → motive t₂_1) t₂_2
            (fun h =>
              Eq.ndrec (motive := fun {l₂} =>
                (t₂ t₂ : Foo l₂) →
                  (motive : Foo l₂ → Sort u_1) →
                    ((s₁ : Foo l₂) → motive (Foo.cons s₁)) → ((x : Foo l₂) → motive x) → HEq t₂ Foo.nil → motive t₂)
                (fun t₂ t₂ motive h_1 h_2 h => Eq.symm (eq_of_heq h) ▸ h_2 Foo.nil) (Eq.symm h) t₂ t₂_1 motive h_1 h_2) --- HERE
            fun {l} t h =>
            Eq.ndrec (motive := fun {l} => (t : Foo l) → HEq t₂_1 (Foo.cons t) → motive t₂_1)
              (fun t h => Eq.symm (eq_of_heq h) ▸ h_1 t) h t)
        t₂_1 (Eq.refl l₂) (HEq.refl t₂_1)
    ```
    The `HERE` comment marks the place where the type of `Foo.bar.match_1` minor premises `h_1` and `h_2` is being "refined"
    using `Eq.ndrec`.

    This function will adjust the motive and minor premise of the `Eq.ndrec` to reflect the new minor premises used in the
    corresponding splitter theorem.

    We may have to extend this function to handle `Eq.rec` too.

    This function was added to address issue #1179
  -/
  convertCastEqRec (e : Expr) : ConvertM Expr := do
    assert! (← isCastEqRec e)
    e.withApp fun f args => do
      let mut argsNew := args
      let mut isAlt := #[]
      for i in [6:args.size] do
        let arg := argsNew[i]!
        if arg.isFVar then
          match (← read).find? arg.fvarId! with
          | some (altNew, _, _) =>
            argsNew := argsNew.set! i altNew
            trace[Meta.Match.matchEqs] "arg: {arg} : {← inferType arg}, altNew: {altNew} : {← inferType altNew}"
            isAlt := isAlt.push true
          | none =>
            argsNew := argsNew.set! i (← convertTemplate arg)
            isAlt := isAlt.push false
        else
          argsNew := argsNew.set! i (← convertTemplate arg)
          isAlt := isAlt.push false
      assert! isAlt.size == args.size - 6
      let rhs := args[4]!
      let motive := args[2]!
      -- Construct new motive using the splitter theorem minor premise types.
      let motiveNew ← lambdaTelescope motive fun motiveArgs body => do
        unless motiveArgs.size == 1 do
          throwError "unexpected `Eq.ndrec` motive while creating splitter/eliminator theorem for `{matchDeclName}`, expected lambda with 1 binder{indentExpr motive}"
        let x := motiveArgs[0]!
        forallTelescopeReducing body fun motiveTypeArgs resultType => do
          unless motiveTypeArgs.size >= isAlt.size do
            throwError "unexpected `Eq.ndrec` motive while creating splitter/eliminator theorem for `{matchDeclName}`, expected arrow with at least #{isAlt.size} binders{indentExpr body}"
          let rec go (i : Nat) (motiveTypeArgsNew : Array Expr) : ConvertM Expr := do
            assert! motiveTypeArgsNew.size == i
            if h : i < motiveTypeArgs.size then
              let motiveTypeArg := motiveTypeArgs.get ⟨i, h⟩
              if i < isAlt.size && isAlt[i]! then
                let altNew := argsNew[6+i]! -- Recall that `Eq.ndrec` has 6 arguments
                let altTypeNew ← inferType altNew
                trace[Meta.Match.matchEqs] "altNew: {altNew} : {altTypeNew}"
                -- Replace `rhs` with `x` (the lambda binder in the motive)
                let mut altTypeNewAbst := (← kabstract altTypeNew rhs).instantiate1 x
                -- Replace args[6:6+i] with `motiveTypeArgsNew`
                for j in [:i] do
                  altTypeNewAbst := (← kabstract altTypeNewAbst argsNew[6+j]!).instantiate1 motiveTypeArgsNew[j]!
                let localDecl ← motiveTypeArg.fvarId!.getDecl
                withLocalDecl localDecl.userName localDecl.binderInfo altTypeNewAbst fun motiveTypeArgNew =>
                  go (i+1) (motiveTypeArgsNew.push motiveTypeArgNew)
              else
                go (i+1) (motiveTypeArgsNew.push motiveTypeArg)
            else
              mkLambdaFVars motiveArgs (← mkForallFVars motiveTypeArgsNew resultType)
          go 0 #[]
      trace[Meta.Match.matchEqs] "new motive: {motiveNew}"
      unless (← isTypeCorrect motiveNew) do
        throwError "failed to construct new type correct motive for `Eq.ndrec` while creating splitter/eliminator theorem for `{matchDeclName}`{indentExpr motiveNew}"
      argsNew := argsNew.set! 2 motiveNew
      -- Construct the new minor premise for the `Eq.ndrec` application.
      -- First, we use `eqRecNewPrefix` to infer the new minor premise binders for `Eq.ndrec`
      let eqRecNewPrefix := mkAppN f argsNew[:3] -- `Eq.ndrec` minor premise is the fourth argument.
      let .forallE _ minorTypeNew .. ← whnf (← inferType eqRecNewPrefix) | unreachable!
      trace[Meta.Match.matchEqs] "new minor type: {minorTypeNew}"
      let minor := args[3]!
      let minorNew ← forallBoundedTelescope minorTypeNew isAlt.size fun minorArgsNew _ => do
        let mut minorBodyNew := minor
        -- We have to extend the mapping to make sure `convertTemplate` can "fix" occurrences of the refined minor premises
        let mut m ← read
        for i in [:isAlt.size] do
          if isAlt[i]! then
            -- `convertTemplate` will correct occurrences of the alternative
            let alt := args[6+i]! -- Recall that `Eq.ndrec` has 6 arguments
            let some (_, numParams, argMask) := m.find? alt.fvarId! | unreachable!
            -- We add a new entry to `m` to make sure `convertTemplate` will correct the occurrences of the alternative
            m := m.insert minorArgsNew[i]!.fvarId! (minorArgsNew[i]!, numParams, argMask)
          unless minorBodyNew.isLambda do
            throwError "unexpected `Eq.ndrec` minor premise while creating splitter/eliminator theorem for `{matchDeclName}`, expected lambda with at least #{isAlt.size} binders{indentExpr minor}"
          minorBodyNew := minorBodyNew.bindingBody!
        minorBodyNew := minorBodyNew.instantiateRev minorArgsNew
        trace[Meta.Match.matchEqs] "minor premise new body before convertTemplate:{indentExpr minorBodyNew}"
        minorBodyNew ← withReader (fun _ => m) <| convertTemplate minorBodyNew
        trace[Meta.Match.matchEqs] "minor premise new body after convertTemplate:{indentExpr minorBodyNew}"
        mkLambdaFVars minorArgsNew minorBodyNew
      unless (← isTypeCorrect minorNew) do
        throwError "failed to construct new type correct minor premise for `Eq.ndrec` while creating splitter/eliminator theorem for `{matchDeclName}`{indentExpr minorNew}"
      argsNew := argsNew.set! 3 minorNew
      -- trace[Meta.Match.matchEqs] "argsNew: {argsNew}"
      trace[Meta.Match.matchEqs] "found cast target {e}"
      return mkAppN f argsNew

  convertTemplate (e : Expr) : ConvertM Expr :=
    transform e fun e => do
      if (← isCastEqRec e) then
        return .done (← convertCastEqRec e)
      else
        let Expr.fvar fvarId .. := e.getAppFn | return .continue
        let some (altNew, numParams, argMask) := (← read).find? fvarId | return .continue
        trace[Meta.Match.matchEqs] ">> argMask: {argMask}, e: {e}, {altNew}"
        let mut newArgs := #[]
        let argMask := trimFalseTrail argMask
        unless e.getAppNumArgs ≥ argMask.size do
          throwError "unexpected occurrence of `match`-expression alternative (aka minor premise) while creating splitter/eliminator theorem for `{matchDeclName}`, minor premise is partially applied{indentExpr e}\npossible solution if you are matching on inductive families: add its indices as additional discriminants"
        for arg in e.getAppArgs, includeArg in argMask do
          if includeArg then
            newArgs := newArgs.push arg
        let eNew := mkAppN altNew newArgs
        /- Recall that `numParams` does not include the equalities associated with discriminants of the form `h : discr`. -/
        let (mvars, _, _) ← forallMetaBoundedTelescope (← inferType eNew) (numParams - newArgs.size) (kind := MetavarKind.syntheticOpaque)
        modify fun s => s ++ (mvars.map (·.mvarId!))
        let eNew := mkAppN eNew mvars
        return TransformStep.done eNew

  proveSubgoalLoop (mvarId : MVarId) : MetaM Unit := do
    trace[Meta.Match.matchEqs] "proveSubgoalLoop\n{mvarId}"
    match (← injectionAny mvarId) with
    | InjectionAnyResult.solved => return ()
    | InjectionAnyResult.failed =>
      let mvarId' ← substVars mvarId
      if mvarId' == mvarId then
        if (← mvarId.contradictionCore {}) then
          return ()
        throwError "failed to generate splitter for match auxiliary declaration '{matchDeclName}', unsolved subgoal:\n{MessageData.ofGoal mvarId}"
      else
        proveSubgoalLoop mvarId'
    | InjectionAnyResult.subgoal mvarId => proveSubgoalLoop mvarId

  proveSubgoal (mvarId : MVarId) : MetaM Unit := do
    trace[Meta.Match.matchEqs] "subgoal {mkMVar mvarId}, {repr (← mvarId.getDecl).kind}, {← mvarId.isAssigned}\n{MessageData.ofGoal mvarId}"
    let (_, mvarId) ← mvarId.intros
    let mvarId ← mvarId.tryClearMany (alts.map (·.fvarId!))
    proveSubgoalLoop mvarId

/--
  Create new alternatives (aka minor premises) by replacing `discrs` with `patterns` at `alts`.
  Recall that `alts` depends on `discrs` when `numDiscrEqs > 0`, where `numDiscrEqs` is the number of discriminants
  annotated with `h : discr`.
-/
private partial def withNewAlts (numDiscrEqs : Nat) (discrs : Array Expr) (patterns : Array Expr) (alts : Array Expr) (k : Array Expr → MetaM α) : MetaM α :=
  if numDiscrEqs == 0 then
    k alts
  else
    go 0 #[]
where
  go (i : Nat) (altsNew : Array Expr) : MetaM α := do
   if h : i < alts.size then
     let alt := alts.get ⟨i, h⟩
     let altLocalDecl ← getFVarLocalDecl alt
     let typeNew := altLocalDecl.type.replaceFVars discrs patterns
     withLocalDecl altLocalDecl.userName altLocalDecl.binderInfo typeNew fun altNew =>
       go (i+1) (altsNew.push altNew)
   else
     k altsNew

/--
  Create conditional equations and splitter for the given match auxiliary declaration. -/
private partial def mkEquationsFor (matchDeclName : Name) :  MetaM MatchEqns := withLCtx {} {} do
  trace[Meta.Match.matchEqs] "mkEquationsFor '{matchDeclName}'"
  withConfig (fun c => { c with etaStruct := .none }) do
  let baseName := mkPrivateName (← getEnv) matchDeclName
  let constInfo ← getConstInfo matchDeclName
  let us := constInfo.levelParams.map mkLevelParam
  let some matchInfo ← getMatcherInfo? matchDeclName | throwError "'{matchDeclName}' is not a matcher function"
  let numDiscrEqs := getNumEqsFromDiscrInfos matchInfo.discrInfos
  forallTelescopeReducing constInfo.type fun xs matchResultType => do
    let mut eqnNames := #[]
    let params := xs[:matchInfo.numParams]
    let motive := xs[matchInfo.getMotivePos]!
    let alts   := xs[xs.size - matchInfo.numAlts:]
    let firstDiscrIdx := matchInfo.numParams + 1
    let discrs := xs[firstDiscrIdx : firstDiscrIdx + matchInfo.numDiscrs]
    let mut notAlts := #[]
    let mut idx := 1
    let mut splitterAltTypes := #[]
    let mut splitterAltNumParams := #[]
    let mut altArgMasks := #[] -- masks produced by `forallAltTelescope`
    for i in [:alts.size] do
      let altNumParams := matchInfo.altNumParams[i]!
      let altNonEqNumParams := altNumParams - numDiscrEqs
      let thmName := baseName ++ ((`eq).appendIndexAfter idx)
      eqnNames := eqnNames.push thmName
      let (notAlt, splitterAltType, splitterAltNumParam, argMask) ← forallAltTelescope (← inferType alts[i]!) altNonEqNumParams fun ys eqs rhsArgs argMask altResultType => do
        let patterns := altResultType.getAppArgs
        let mut hs := #[]
        for notAlt in notAlts do
          let h ← instantiateForall notAlt patterns
          if let some h ← simpH? h patterns.size then
            hs := hs.push h
        trace[Meta.Match.matchEqs] "hs: {hs}"
        let splitterAltType ← mkForallFVars ys (← hs.foldrM (init := (← mkForallFVars eqs altResultType)) (mkArrow · ·))
        let splitterAltNumParam := hs.size + ys.size
        -- Create a proposition for representing terms that do not match `patterns`
        let mut notAlt := mkConst ``False
        for discr in discrs.toArray.reverse, pattern in patterns.reverse do
          notAlt ← mkArrow (← mkEqHEq discr pattern) notAlt
        notAlt ← mkForallFVars (discrs ++ ys) notAlt
        /- Recall that when we use the `h : discr`, the alternative type depends on the discriminant.
           Thus, we need to create new `alts`. -/
        withNewAlts numDiscrEqs discrs patterns alts fun alts => do
          let alt := alts[i]!
          let lhs := mkAppN (mkConst constInfo.name us) (params ++ #[motive] ++ patterns ++ alts)
          let rhs := mkAppN alt rhsArgs
          let thmType ← mkEq lhs rhs
          let thmType ← hs.foldrM (init := thmType) (mkArrow · ·)
          let thmType ← mkForallFVars (params ++ #[motive] ++ ys ++ alts) thmType
          let thmType ← unfoldNamedPattern thmType
          let thmVal ← proveCondEqThm matchDeclName thmType
          addDecl <| Declaration.thmDecl {
            name        := thmName
            levelParams := constInfo.levelParams
            type        := thmType
            value       := thmVal
          }
          return (notAlt, splitterAltType, splitterAltNumParam, argMask)
      notAlts := notAlts.push notAlt
      splitterAltTypes := splitterAltTypes.push splitterAltType
      splitterAltNumParams := splitterAltNumParams.push splitterAltNumParam
      altArgMasks := altArgMasks.push argMask
      trace[Meta.Match.matchEqs] "splitterAltType: {splitterAltType}"
      idx := idx + 1
    -- Define splitter with conditional/refined alternatives
    withSplitterAlts splitterAltTypes fun altsNew => do
      let splitterParams := params.toArray ++ #[motive] ++ discrs.toArray ++ altsNew
      let splitterType ← mkForallFVars splitterParams matchResultType
      trace[Meta.Match.matchEqs] "splitterType: {splitterType}"
      let template := mkAppN (mkConst constInfo.name us) (params ++ #[motive] ++ discrs ++ alts)
      let template ← deltaExpand template (· == constInfo.name)
      let template := template.headBeta
      let splitterVal ← mkLambdaFVars splitterParams (← mkSplitterProof matchDeclName template alts altsNew splitterAltNumParams altArgMasks)
      let splitterName := baseName ++ `splitter
      addAndCompile <| Declaration.defnDecl {
        name        := splitterName
        levelParams := constInfo.levelParams
        type        := splitterType
        value       := splitterVal
        hints       := .abbrev
        safety      := .safe
      }
      setInlineAttribute splitterName
      let result := { eqnNames, splitterName, splitterAltNumParams }
      registerMatchEqns matchDeclName result
      return result

/- See header at `MatchEqsExt.lean` -/
@[export lean_get_match_equations_for]
def getEquationsForImpl (matchDeclName : Name) : MetaM MatchEqns := do
  match matchEqnsExt.getState (← getEnv) |>.map.find? matchDeclName with
  | some matchEqns => return matchEqns
  | none => mkEquationsFor matchDeclName

builtin_initialize registerTraceClass `Meta.Match.matchEqs

end Lean.Meta.Match


import Lbar.ext_aux4
import Lbar.iota

noncomputable theory

universes v u u'

open opposite category_theory category_theory.limits category_theory.preadditive
open_locale nnreal zero_object

variables (r r' : ℝ≥0)
variables [fact (0 < r)] [fact (0 < r')] [fact (r < r')] [fact (r < 1)] [fact (r' < 1)]

open bounded_homotopy_category

variables {r'}
variables (BD : breen_deligne.package)
variables (κ κ₂ : ℝ≥0 → ℕ → ℝ≥0)
variables [∀ (c : ℝ≥0), BD.data.suitable (κ c)] [∀ n, fact (monotone (function.swap κ n))]
variables [∀ (c : ℝ≥0), BD.data.suitable (κ₂ c)] [∀ n, fact (monotone (function.swap κ₂ n))]
variables (M : ProFiltPseuNormGrpWithTinv₁.{u} r')

namespace Lbar

open ProFiltPseuNormGrpWithTinv₁ ProFiltPseuNormGrp₁ CompHausFiltPseuNormGrp₁
open bounded_homotopy_category

variables (r r')

def Tinv_sub (S : Profinite.{u}) (V : SemiNormedGroup.{u}) [normed_with_aut r V] (i : ℤ) :
  ((Ext' i).obj (op $ (Lbar.condensed.{u} r').obj S)).obj V.to_Cond ⟶
  ((Ext' i).obj (op $ (Lbar.condensed.{u} r').obj S)).obj V.to_Cond :=
((Ext' i).map ((condensify_Tinv _).app S).op).app _ -
((Ext' i).obj _).map (Condensed.of_top_ab_map (normed_with_aut.T.inv).to_add_monoid_hom
  (normed_group_hom.continuous _))

-- move me
attribute [simps] Condensed.of_top_ab_map

variables (S : Profinite.{0}) (V : SemiNormedGroup.{0})
variables [complete_space V] [separated_space V]
variables (r')

def condensify_iso_extend :
  condensify (Fintype_Lbar.{0 0} r' ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r') ≅
  (Profinite.extend (Fintype_Lbar.{0 0} r')) ⋙
    (PFPNGT₁_to_CHFPNG₁ₑₗ r' ⋙ CHFPNG₁_to_CHFPNGₑₗ.{0} ⋙
  CompHausFiltPseuNormGrp.to_Condensed.{0}) :=
(((whiskering_left _ _ _).map_iso $
  Profinite.extend_commutes (Fintype_Lbar.{0 0} r') (PFPNGT₁_to_CHFPNG₁ₑₗ r')).app
    (CHFPNG₁_to_CHFPNGₑₗ.{0} ⋙ CompHausFiltPseuNormGrp.to_Condensed.{0})).symm

def condensify_iso_extend' :
  (condensify (Fintype_Lbar.{0 0} r' ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ r')).obj S ≅
  ((Profinite.extend (Fintype_Lbar.{0 0} r')).obj S).to_Condensed :=
(condensify_iso_extend r').app S

section move_me

--universes u'

open Profinite

variables {C : Type u} [category.{v} C] (F : Fintype.{v} ⥤ C)
variables {D : Type u'} [category.{v} D]
variable [∀ X : Profinite, has_limit (X.fintype_diagram ⋙ F)]

@[reassoc]
lemma extend_commutes_comp_extend_extends' (G : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) G]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ G)] :
  whisker_left Fintype.to_Profinite (extend_commutes F G).hom =
  (functor.associator _ _ _).inv ≫ (whisker_right (extend_extends _).hom G) ≫
    (extend_extends _).inv :=
by rw [← category.assoc, iso.eq_comp_inv, extend_commutes_comp_extend_extends]

@[reassoc]
lemma extend_commutes_comp_extend_extends'' (G : C ⥤ D)
  [∀ X : Profinite.{v}, preserves_limits_of_shape (discrete_quotient X) G]
  [∀ X : Profinite.{v}, has_limit (X.fintype_diagram ⋙ F ⋙ G)] :
  whisker_left Fintype.to_Profinite (extend_commutes F G).inv =
  (extend_extends _).hom ≫ (whisker_right (extend_extends _).inv G) ≫
    (functor.associator _ _ _).hom :=
begin
  rw [← iso.inv_comp_eq, ← iso_whisker_left_inv, iso.comp_inv_eq, iso_whisker_left_hom,
    extend_commutes_comp_extend_extends', category.assoc, iso.hom_inv_id_assoc,
    ← iso_whisker_right_hom, ← iso_whisker_right_inv, iso.inv_hom_id_assoc],
end

end move_me

lemma condensify_Tinv_iso :
  condensify_Tinv (Fintype_Lbar.{0 0} r') ≫ (condensify_iso_extend r').hom =
  (condensify_iso_extend r').hom ≫ (@whisker_right _ _ _ _ _ _ _ _ (Tinv_nat_trans _) _) :=
begin
  delta Tinv_cond condensify_Tinv condensify_nonstrict condensify_iso_extend' condensify_iso_extend,
  ext S : 2,
  rw [iso.symm_hom, iso.app_inv, functor.map_iso_inv, nat_trans.comp_app, nat_trans.comp_app,
    whiskering_left_map_app_app, ← iso.app_inv, ← functor.map_iso_inv, iso.comp_inv_eq,
    functor.map_iso_inv, functor.map_iso_hom, functor.comp_map, functor.comp_map,
    whisker_right_app, whisker_right_app, ← functor.map_comp, ← functor.map_comp],
  congr' 1,
  rw [iso.app_inv, iso.app_hom, ← whisker_right_app, ← whisker_right_app,
    ← nat_trans.comp_app, ← nat_trans.comp_app],
  congr' 1,
  refine nonstrict_extend_ext _ _ (r'⁻¹) (1 * (r'⁻¹ * 1)) _ _ _,
  { intro X, apply nonstrict_extend_bound_by },
  { intro X,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    apply comphaus_filtered_pseudo_normed_group_hom.bound_by.comp,
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one },
    { apply Tinv_bound_by },
    { apply strict_comphaus_filtered_pseudo_normed_group_hom.to_chfpsng_hom.bound_by_one }, },
  { rw [whisker_left_comp, whisker_left_comp, ← whisker_right_left, ← whisker_right_left,
      extend_commutes_comp_extend_extends', extend_commutes_comp_extend_extends''],
    rw nonstrict_extend_whisker_left,

    ext X : 2,
    simp only [whisker_left_app, whisker_right_app, nat_trans.comp_app,
      functor.associator_hom_app, functor.associator_inv_app,
      category.id_comp, category.comp_id, category.assoc, functor.map_comp],
    slice_rhs 2 3 {},
    congr' 2,

    simp only [← iso.app_hom, ← iso.app_inv, ← functor.map_iso_hom, ← functor.map_iso_inv,
      category.assoc, iso.eq_inv_comp],

    ext x : 1,
    exact (comphaus_filtered_pseudo_normed_group_with_Tinv_hom.map_Tinv
      ((Profinite.extend_extends (Fintype_Lbar.{0 0} r')).app X).hom x).symm }
end

lemma condensify_Tinv_iso' :
  (condensify_Tinv (Fintype_Lbar.{0 0} r')).app S ≫ (condensify_iso_extend' r' S).hom =
  (condensify_iso_extend' r' S).hom ≫ ((Profinite.extend (Fintype_Lbar.{0 0} r')).obj S).Tinv_cond :=
begin
  have := condensify_Tinv_iso r',
  apply_fun (λ η, η.app S) at this,
  exact this,
end

def useful_commsq (i : ℤ) (ι : ulift.{1} ℕ → ℝ≥0) (hι : monotone ι) [normed_with_aut r V] :=
  shift_sub_id.commsq
    (ExtQprime.Tinv2 r r' breen_deligne.eg.data
      (λ c n, c * breen_deligne.eg.κ r r' n)
      (λ c n, r' * (c * breen_deligne.eg.κ r r' n))
      ((Lbar.functor.{0 0} r').obj S) V i) ι hι

section
open breen_deligne thm95.universal_constants

variables (i : ℕ)

lemma useful_commsq_bicartesian (ι : ulift.{1} ℕ → ℝ≥0) (hι : monotone ι) [normed_with_aut r V]
  (H1 : ∀ j, c₀ r r' eg (λ n, eg.κ r r' n) (eg.κ' r r') (i+1) ⟨ℤ⟩ ≤ ι j)
  (H2 : ∀ j, k (eg.κ' r r') i ^ 2 * ι j ≤ ι (j + 1))
  (H3 : ∀ j, k (eg.κ' r r') (i+1) ^ 2 * ι j ≤ ι (j + 1)) :
  (useful_commsq r r' S V i ι hι).bicartesian :=
begin
  apply shift_sub_id.bicartesian_iso _ _
    (ExtQprime_iso_aux_system r' _ _ _ V i).symm (ExtQprime_iso_aux_system r' _ _ _ V i).symm ι hι
    (ExtQprime_iso_aux_system_comm' _ _ _ _ _ _ _ _),
  rw [← whisker_right_twice],
  refine shift_sub_id.bicartesian (aux_system.incl'.{0 1} r r' _ _ _ (eg.κ r r')) _
    i ι hι _ _ _,
  { apply_with system_of_complexes.shift_eq_zero {instances := ff},
    swap 3, { apply thm94.explicit r r' _ _ (eg.κ' r r'), },
    any_goals { apply_instance },
    { intro j,
      refine le_trans _ ((c₀_mono _ _ _ _ _ _ (i+1)).out.trans (H1 j)),
      rw nat.add_sub_cancel, },
    { exact H2 } },
  { apply_with system_of_complexes.shift_eq_zero {instances := ff},
    swap 3, { apply thm94.explicit r r' _ _ (eg.κ' r r'), },
    any_goals { apply_instance },
    { exact H1 },
    { exact H3 } },
  { intros c n,
    let κ := eg.κ r r',
    apply aux_system.short_exact r r' _ _ _ (λ c n, r' * (c * κ n)) κ,
    intro c, dsimp, apply_instance, }
end

lemma bicartesian_of_is_zero {𝓒 : Type*} [category 𝓒] [abelian 𝓒]
  {A B C D : 𝓒} (f₁ : A ⟶ B) (g₁ : A ⟶ C) (g₂ : B ⟶ D) (f₂ : C ⟶ D) (h : commsq f₁ g₁ g₂ f₂)
  (hA : is_zero A) (hB : is_zero B) (hC : is_zero C) (hD : is_zero D) :
  h.bicartesian :=
begin
  delta commsq.bicartesian,
  apply_with short_exact.mk {instances:=ff},
  { refine ⟨λ X f g h, _⟩, apply hA.eq_of_tgt },
  { refine ⟨λ X f g h, _⟩, apply hD.eq_of_src },
  { apply exact_of_is_zero ((is_zero_biprod _ _ hB hC).of_iso (h.sum.iso (sum_str.biprod _ _))), }
end

lemma is_zero_pi {𝓒 : Type*} [category 𝓒] [abelian 𝓒] {ι : Type*} (f : ι → 𝓒) [has_product f]
  (hf : ∀ i, is_zero (f i)) :
  is_zero (∏ f) :=
begin
  rw is_zero_iff_id_eq_zero,
  ext,
  apply (hf j).eq_of_tgt,
end

lemma useful_commsq_bicartesian_neg  (ι : ulift.{1} ℕ → ℝ≥0) (hι : monotone ι) [normed_with_aut r V]
  (i : ℤ) (hi : i < 0) :
  (useful_commsq r r' S V i ι hι).bicartesian :=
begin
  have : 1 + i ≤ 0, { linarith only [hi] },
  apply bicartesian_of_is_zero;
  apply is_zero_pi; intro x;
  apply Ext_single_right_is_zero _ _ 1 _ _ (chain_complex.bounded_by_one _) this
end

lemma is_iso_sq {𝓒 : Type*} [category 𝓒] {X Y : 𝓒} (f₁ : X ⟶ X) (f₂ : Y ⟶ Y)
  (e : X ≅ Y) (h : f₁ ≫ e.hom = e.hom ≫ f₂) (h₁ : is_iso f₁) :
  is_iso f₂ :=
by { rw [← iso.inv_comp_eq] at h, rw ← h, apply_instance }

open category_theory.preadditive

lemma is_iso_sq' {𝓒 : Type*} [category 𝓒] [abelian 𝓒] [enough_projectives 𝓒]
  {X Y Z : bounded_homotopy_category 𝓒} (f₁ : X ⟶ X) (f₂ : Y ⟶ Y) (f₃ : Z ⟶ Z)
  (e : Y ≅ X) (h : e.hom ≫ f₁ = f₂ ≫ e.hom) (i : ℤ)
  (h₁ : is_iso (((Ext i).map f₁.op).app Z - ((Ext i).obj _).map f₃)) :
  is_iso (((Ext i).map f₂.op).app Z - ((Ext i).obj _).map f₃) :=
begin
  refine is_iso_sq _ _ ((functor.map_iso _ e.op).app _) _ h₁,
  rw [iso.app_hom, functor.map_iso_hom, sub_comp, comp_sub, nat_trans.naturality,
      ← nat_trans.comp_app, ← nat_trans.comp_app, ← functor.map_comp, ← functor.map_comp,
      iso.op_hom, ← op_comp, ← op_comp, h],
end

/-- Thm 9.4bis of [Analytic]. More precisely: the first observation in the proof 9.4 => 9.1. -/
theorem is_iso_Tinv_sub [normed_with_aut r V] : ∀ i, is_iso (Tinv_sub r r' S V i) :=
begin
  erw (Condensed.bd_lemma _ _ _ _),
  swap, { apply Lbar.obj.no_zero_smul_divisors },
  intro i,
  refine is_iso_sq' _ _ _ (functor.map_iso _ $ condensify_iso_extend' _ _) _ _ _,
  { refine category_theory.functor.map _ _, refine Tinv_cond _ },
  { rw [functor.map_iso_hom, ← functor.map_comp, ← functor.map_comp, condensify_Tinv_iso'], },
  revert i,
  refine Tinv2_iso_of_bicartesian' r breen_deligne.eg
      (λ c n, c * breen_deligne.eg.κ r r' n)
      (λ c n, r' * (c * breen_deligne.eg.κ r r' n))
    ((Lbar.functor.{0 0} r').obj S) V _,
  rintro (i|(_|i)),
  { refine ⟨ι r r' i, hι r r' i, _, _, _, _⟩,
    { intros s m,
      apply Lbar.sufficiently_increasing_eg },
    { intros s m,
      apply Lbar.sufficiently_increasing_eg' },
    all_goals { apply useful_commsq_bicartesian },
    { rintro ⟨j⟩, apply Hι1 },
    { rintro ⟨j⟩, apply Hι2a },
    { rintro ⟨j⟩, apply Hι2b },
    { rintro ⟨j⟩, apply Hι1' },
    { rintro ⟨j⟩, apply Hι2b },
    { rintro ⟨j⟩, apply Hι2c } },
  { refine ⟨ι r r' 0, hι r r' 0, _, _, _, _⟩,
    { intros s m, apply Lbar.sufficiently_increasing_eg, },
    { intros s m, apply Lbar.sufficiently_increasing_eg', },
    { apply useful_commsq_bicartesian_neg, dec_trivial },
    { apply useful_commsq_bicartesian,
    { rintro ⟨j⟩, apply Hι1 },
    { rintro ⟨j⟩, apply Hι2a },
    { rintro ⟨j⟩, apply Hι2b }, }, },
  { refine ⟨ι r r' 0, hι r r' 0, _, _, _, _⟩,
    { intros s m, apply Lbar.sufficiently_increasing_eg, },
    { intros s m, apply Lbar.sufficiently_increasing_eg', },
    { apply useful_commsq_bicartesian_neg, dec_trivial },
    { apply useful_commsq_bicartesian_neg,
      rw [int.neg_succ_of_nat_eq'],
      simp only [int.coe_nat_succ, neg_add_rev, sub_add_cancel, add_neg_lt_iff_le_add', add_zero],
      dec_trivial }, },
end

/-- Thm 9.4bis of [Analytic]. More precisely: the first observation in the proof 9.4 => 9.1. -/
theorem is_iso_Tinv2 [normed_with_aut r V]
  (hV : ∀ (v : V), (normed_with_aut.T.inv v) = 2 • v) :
  ∀ i, is_iso (((Ext' i).map ((condensify_Tinv2 (Fintype_Lbar.{0 0} r')).app S).op).app
    (Condensed.of_top_ab ↥V)) :=
begin
  intro i,
  rw [condensify_Tinv2_eq, ← functor.flip_obj_map, nat_trans.app_sub, category_theory.op_sub,
    nat_trans.app_nsmul,  category_theory.op_nsmul, two_nsmul, nat_trans.id_app, op_id,
    functor.map_sub, functor.map_add, category_theory.functor.map_id],
  convert is_iso_Tinv_sub r r' S V i using 2,
  suffices : Condensed.of_top_ab_map (normed_group_hom.to_add_monoid_hom normed_with_aut.T.inv) _ =
    2 • 𝟙 _,
  { rw [this, two_nsmul, functor.map_add, category_theory.functor.map_id], refl, },
  ext T f t,
  dsimp only [Condensed.of_top_ab_map_val, whisker_right_app, Ab.ulift_map_apply_down,
    add_monoid_hom.mk'_apply, continuous_map.coe_mk, function.comp_app],
  erw [hV, two_nsmul, two_nsmul],
  refl,
end

end

end Lbar


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import Aesop.Builder.Constructors
import Aesop.Builder.NormSimp
import Aesop.Builder.Tactic

open Lean
open Lean.Meta

namespace Aesop

-- TODO In the default builders below, we should distinguish between fatal and
-- nonfatal errors. E.g. if the `tactic` builder finds a declaration that is not
-- of tactic type, this is a nonfatal error and we should continue with the next
-- builder. But if the simp builder finds an equation that cannot be interpreted
-- as a simp lemma for some reason, this is a fatal error. Continuing with the
-- next builder is more confusing than anything because the user probably
-- intended to add a simp lemma.

namespace RuleBuilder

private def err (ruleType : String) : RuleBuilder := λ input =>
  throwError m!"aesop: Unable to interpret {input.kind.toRuleIdent} as {ruleType} rule. Try specifying a builder."

def default : RuleBuilder := λ input =>
  match input.phase with
  | PhaseName.safe =>
    constructorsDef input <|>
    tacticDef input <|>
    applyDef input <|>
    err "a safe" input
  | PhaseName.unsafe =>
    constructorsDef input <|>
    tacticDef input <|>
    applyDef input <|>
    err "an unsafe" input
  | PhaseName.norm =>
    constructorsDef input <|>
    tacticDef input <|>
    simp input <|>
    applyDef input <|>
    err "a norm" input
  where
    tacticDef := tactic RegularBuilderOptions.default
    applyDef := apply RegularBuilderOptions.default
    constructorsDef := constructors RegularBuilderOptions.default

end RuleBuilder

end Aesop