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

import for_mathlib.dold_kan.homotopies
import tactic.ring_exp

/-!

# Study of face maps for the Dold-Kan correspondence

TODO (@joelriou) continue adding the various files referenced below

In this file, we obtain the technical lemmas that are used in the file
`projections.lean` in order to get basic properties of the endomorphisms
`P q : K[X] ⟶ K[X]` with respect to face maps (see `homotopies.lean` for the
role of these endomorphisms in the overall strategy of proof).

The main lemma in this file is `higher_faces_vanish.induction`. It is based
on two technical lemmas `higher_faces_vanish.comp_Hσ_eq` and
`higher_faces_vanish.comp_Hσ_eq_zero`.

-/

open nat
open category_theory
open category_theory.limits
open category_theory.category
open category_theory.preadditive
open category_theory.simplicial_object
open_locale simplicial dold_kan

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]
variables {X : simplicial_object C}

/-- A morphism `φ : Y ⟶ X _[n+1]` satisfies `higher_faces_vanish q φ`
when the compositions `φ ≫ X.δ j` are `0` for `j ≥ max 1 (n+2-q)`. When `q ≤ n+1`,
it basically means that the composition `φ ≫ X.δ j` are `0` for the `q` highest
possible values of a nonzero `j`. Otherwise, when `q ≥ n+2`, all the compositions
`φ ≫ X.δ j` for nonzero `j` vanish. See also the lemma `comp_P_eq_self_iff` in
`projections.lean` which states that `higher_faces_vanish q φ` is equivalent to
the identity `φ ≫ (P q).f (n+1) = φ`. -/
def higher_faces_vanish {Y : C} {n : ℕ} (q : ℕ) (φ : Y ⟶ X _[n+1]) : Prop :=
∀ (j : fin (n+1)), (n+1 ≤ (j : ℕ) + q) → φ ≫ X.δ j.succ = 0

namespace higher_faces_vanish

@[reassoc]
lemma comp_δ_eq_zero {Y : C} {n : ℕ} {q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) (j : fin (n+2)) (hj₁ : j ≠ 0) (hj₂ : n+2 ≤ (j : ℕ) + q) :
  φ ≫ X.δ j = 0 :=
begin
  obtain ⟨i, hi⟩ := fin.eq_succ_of_ne_zero hj₁,
  subst hi,
  apply v i,
  rw [← @nat.add_le_add_iff_right 1, add_assoc],
  simpa only [fin.coe_succ, add_assoc, add_comm 1] using hj₂,
end

lemma of_succ {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish (q+1) φ) : higher_faces_vanish q φ :=
λ j hj, v j (by simpa only [← add_assoc] using le_add_right hj)

lemma of_comp {Y Z : C} {q n : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) (f : Z ⟶ Y) :
  higher_faces_vanish q (f ≫ φ) := λ j hj,
by rw [assoc, v j hj, comp_zero]

lemma comp_Hσ_eq {Y : C} {n a q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) (hnaq : n=a+q) : φ ≫ (Hσ q).f (n+1) =
  - φ ≫ X.δ ⟨a+1, nat.succ_lt_succ (nat.lt_succ_iff.mpr (nat.le.intro hnaq.symm))⟩ ≫
    X.σ ⟨a, nat.lt_succ_iff.mpr (nat.le.intro hnaq.symm)⟩ :=
begin
  have hnaq_shift : Π d : ℕ, n+d=(a+d)+q,
  { intro d, rw [add_assoc, add_comm d, ← add_assoc, hnaq], },
  rw [Hσ, homotopy.null_homotopic_map'_f (c_mk (n+2) (n+1) rfl) (c_mk (n+1) n rfl),
    hσ'_eq hnaq (c_mk (n+1) n rfl), hσ'_eq (hnaq_shift 1) (c_mk (n+2) (n+1) rfl)],
  simp only [alternating_face_map_complex.obj_d_eq, eq_to_hom_refl,
    comp_id, comp_sum, sum_comp, comp_add],
  simp only [comp_zsmul, zsmul_comp, ← assoc, ← mul_zsmul],
  /- cleaning up the first sum -/
  rw [← fin.sum_congr' _ (hnaq_shift 2).symm, fin.sum_trunc], swap,
  { rintro ⟨k, hk⟩,
    suffices : φ ≫ X.δ (⟨a+2+k, by linarith⟩ : fin (n+2)) = 0,
    { simp only [this, fin.nat_add_mk, fin.cast_mk, zero_comp, smul_zero], },
    convert v ⟨a+k+1, by linarith⟩ (by { rw fin.coe_mk, linarith, }),
    rw [nat.succ_eq_add_one],
    linarith, },
  /- cleaning up the second sum -/
  rw [← fin.sum_congr' _ (hnaq_shift 3).symm, @fin.sum_trunc _ _ (a+3)], swap,
  { rintros ⟨k, hk⟩,
    rw [assoc, X.δ_comp_σ_of_gt', v.comp_δ_eq_zero_assoc, zero_comp, zsmul_zero],
    { intro h,
      rw [fin.pred_eq_iff_eq_succ, fin.ext_iff] at h,
      dsimp at h,
      linarith, },
    { dsimp,
      simp only [fin.coe_pred, fin.coe_mk, succ_add_sub_one],
      linarith, },
    { dsimp,
      linarith, }, },
  /- leaving out three specific terms -/
  conv_lhs { congr, skip, rw [fin.sum_univ_cast_succ, fin.sum_univ_cast_succ], },
  rw fin.sum_univ_cast_succ,
  simp only [fin.last, fin.cast_le_mk, fin.coe_cast, fin.cast_mk,
    fin.coe_cast_le, fin.coe_mk, fin.cast_succ_mk, fin.coe_cast_succ],
  /- the purpose of the following `simplif` is to create three subgoals in order
    to finish the proof -/
  have simplif : ∀ (a b c d e f : Y ⟶ X _[n+1]), b=f → d+e=0 → c+a=0 → a+b+(c+d+e) = f,
  { intros a b c d e f h1 h2 h3,
    rw [add_assoc c d e, h2, add_zero, add_comm a b, add_assoc,
      add_comm a c, h3, add_zero, h1], },
  apply simplif,
  { /- b=f -/
    rw [← pow_add, odd.neg_one_pow, neg_smul, one_zsmul],
    use a,
    linarith, },
  { /- d+e = 0 -/
    rw [assoc, assoc, X.δ_comp_σ_self' (fin.cast_succ_mk _ _ _).symm,
      X.δ_comp_σ_succ' (fin.succ_mk _ _ _).symm],
    simp only [comp_id, pow_add _ (a+1) 1, pow_one, mul_neg, mul_one, neg_smul,
      add_right_neg], },
  { /- c+a = 0 -/
    rw ← finset.sum_add_distrib,
    apply finset.sum_eq_zero,
    rintros ⟨i, hi⟩ h₀,
    have hia : (⟨i, by linarith⟩ : fin (n+2)) ≤ fin.cast_succ (⟨a, by linarith⟩ : fin (n+1)) :=
      by simpa only [fin.le_iff_coe_le_coe, fin.coe_mk, fin.cast_succ_mk, ← lt_succ_iff] using hi,
    simp only [fin.coe_mk, fin.cast_le_mk, fin.cast_succ_mk, fin.succ_mk, assoc, fin.cast_mk,
      ← δ_comp_σ_of_le X hia, add_eq_zero_iff_eq_neg, ← neg_zsmul],
    congr,
    ring_exp, },
end

lemma comp_Hσ_eq_zero {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) (hqn : n<q) : φ ≫ (Hσ q).f (n+1) = 0 :=
begin
  simp only [Hσ, homotopy.null_homotopic_map'_f (c_mk (n+2) (n+1) rfl) (c_mk (n+1) n rfl)],
  rw [hσ'_eq_zero hqn (c_mk (n+1) n rfl), comp_zero, zero_add],
  by_cases hqn' : n+1<q,
  { rw [hσ'_eq_zero hqn' (c_mk (n+2) (n+1) rfl), zero_comp, comp_zero], },
  { simp only [hσ'_eq (show n+1=0+q, by linarith) (c_mk (n+2) (n+1) rfl),
      pow_zero, fin.mk_zero, one_zsmul, eq_to_hom_refl, comp_id,
      comp_sum, alternating_face_map_complex.obj_d_eq],
    rw [← fin.sum_congr' _ (show 2+(n+1)=n+1+2, by linarith), fin.sum_trunc],
    { simp only [fin.sum_univ_cast_succ, fin.sum_univ_zero, zero_add, fin.last,
        fin.cast_le_mk, fin.cast_mk, fin.cast_succ_mk],
      simp only [fin.mk_zero, fin.coe_zero, pow_zero, one_zsmul, fin.mk_one,
        fin.coe_one, pow_one, neg_smul, comp_neg],
      erw [δ_comp_σ_self, δ_comp_σ_succ, add_right_neg], },
    { intro j,
      rw [comp_zsmul, comp_zsmul, δ_comp_σ_of_gt', v.comp_δ_eq_zero_assoc, zero_comp, zsmul_zero],
      { intro h,
        rw [fin.pred_eq_iff_eq_succ, fin.ext_iff] at h,
        dsimp at h,
        linarith, },
      { dsimp,
        simp only [fin.cast_nat_add, fin.coe_pred, fin.coe_add_nat, add_succ_sub_one],
        linarith, },
      { rw fin.lt_iff_coe_lt_coe,
        dsimp,
        linarith, }, }, },
end

lemma induction {Y : C} {n q : ℕ} {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish q φ) : higher_faces_vanish (q+1) (φ ≫ (𝟙 _ + Hσ q).f (n+1)) :=
begin
  intros j hj₁,
  dsimp,
  simp only [comp_add, add_comp, comp_id],
  -- when n < q, the result follows immediately from the assumption
  by_cases hqn : n<q,
  { rw [v.comp_Hσ_eq_zero hqn, zero_comp, add_zero, v j (by linarith)], },
  -- we now assume that n≥q, and write n=a+q
  cases nat.le.dest (not_lt.mp hqn) with a ha,
  rw [v.comp_Hσ_eq (show n=a+q, by linarith), neg_comp, add_neg_eq_zero, assoc, assoc],
  cases n with m hm,
  -- the boundary case n=0
  { simpa only [nat.eq_zero_of_add_eq_zero_left ha, fin.eq_zero j,
      fin.mk_zero, fin.mk_one, δ_comp_σ_succ, comp_id], },
  -- in the other case, we need to write n as m+1
  -- then, we first consider the particular case j = a
  by_cases hj₂ : a = (j : ℕ),
  { simp only [hj₂, fin.eta, δ_comp_σ_succ, comp_id],
    congr,
    ext,
    simp only [fin.coe_succ, fin.coe_mk], },
  -- now, we assume j ≠ a (i.e. a < j)
  have haj : a<j := (ne.le_iff_lt hj₂).mp (by linarith),
  have hj₃ := j.is_lt,
  have ham : a≤m,
  { by_contradiction,
    rw [not_le, ← nat.succ_le_iff] at h,
    linarith, },
  rw [X.δ_comp_σ_of_gt', j.pred_succ], swap,
  { rw fin.lt_iff_coe_lt_coe,
    simpa only [fin.coe_mk, fin.coe_succ, add_lt_add_iff_right] using haj, },
  obtain (ham' | ham'') := ham.lt_or_eq,
  { -- case where `a<m`
    rw ← X.δ_comp_δ''_assoc, swap,
    { rw fin.le_iff_coe_le_coe,
      dsimp,
      linarith, },
    simp only [← assoc, v j (by linarith), zero_comp], },
  { -- in the last case, a=m, q=1 and j=a+1
    rw X.δ_comp_δ_self'_assoc, swap,
    { ext,
      dsimp,
      have hq : q = 1 := by rw [← add_left_inj a, ha, ham'', add_comm],
      linarith, },
    simp only [← assoc, v j (by linarith), zero_comp], },
end

@[reassoc]
lemma d_eq {Y : C} (n : ℕ) {φ : Y ⟶ X _[n+1]}
  (v : higher_faces_vanish (n+1) φ) :
  φ ≫ K[X].d (n+1) n = φ ≫ X.δ 0 :=
begin
  simp only [alternating_face_map_complex.obj_d_eq, comp_sum],
  rw [finset.sum_eq_single (0 : fin (n+2)), fin.coe_zero, pow_zero, one_zsmul],
  { intros b h hb,
    rw [preadditive.comp_zsmul, ← fin.succ_pred b hb, v, zsmul_zero],
    linarith, },
  { intro h,
    exfalso,
    exact h (finset.mem_univ _), },
end

end higher_faces_vanish

end dold_kan

end algebraic_topology


-- Copyright (c) 2018 Keeley Hoek. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Keeley Hoek, Scott Morrison
import tactic.rewrite_search

namespace tactic.rewrite_search.testing

axiom foo' : [6] = [7]
axiom bar' : [[5],[5]] = [[6],[6]]

example : [[7],[6]] = [[5],[5]] :=
begin
 success_if_fail { rewrite_search_with [] {} },
-- rw [←foo', bar']
 rewrite_search_with [←foo', bar'] {explain := tt},
end

@[search] private axiom foo : [0] = [1]
@[search] private axiom bar1 : [1] = [2]
@[search] private axiom bar2 : [3] = [2]
@[search] private axiom bar3 : [3] = [4]

private example (a : unit) : [[0],[0]] = [[4],[4]] :=
begin
/- `rewrite_search` says -/
-- nth_rewrite_lhs 0 foo,
-- nth_rewrite_lhs 0 bar1,
-- nth_rewrite_lhs 0 foo,
-- nth_rewrite_lhs 0 bar1,
-- nth_rewrite_rhs 0 ←bar3,
-- nth_rewrite_rhs 0 ←bar3,
-- nth_rewrite_rhs 1 bar2,
-- nth_rewrite_rhs 0 bar2,

/- `rewrite_search` says -/
conv { to_lhs, congr, skip, rw foo, },
conv { to_lhs, congr, skip, rw bar1, },
conv { to_lhs, congr, },
-- conv { to_lhs, (*→func→arg→func) congr, congr, skip, congr, rw bar1, },
-- conv { to_rhs, (*→arg→func) congr, skip, congr, rw ←bar3, },
-- conv { to_rhs, (*→func→arg→func) congr, congr, skip, congr, rw ←bar3, },
-- conv { to_rhs, (*→func→arg→func) congr, congr, skip, congr, rw bar2, },
-- conv { to_rhs, (*→arg→func) congr, skip, congr, rw bar2, }

  rewrite_search_with [foo, bar1, ← bar2, bar2, ← bar3] {explain := tt},
end

private example (a : unit) : [[0],[0]] = [[4],[4]] :=
begin
  rewrite_search_with [foo, bar1, ← bar2, bar2, ← bar3] {strategy.pexplore {}, metric.edit_distance {}, visualiser},
end

private example : [[0],[0]] = [[4],[4]] :=
begin
/- `rewrite_search` says -/
-- nth_rewrite_lhs 0 foo,
-- nth_rewrite_lhs 0 bar1,
-- nth_rewrite_lhs 0 ←bar2,
-- nth_rewrite_lhs 0 foo,
-- nth_rewrite_rhs 0 ←bar3,
-- nth_rewrite_rhs 0 ←bar3,
-- nth_rewrite_rhs 1 bar2,
-- nth_rewrite_rhs 0 ←bar1

/- `rewrite_search` says -/
-- conv { to_lhs, congr, rw [foo, bar1], skip, rw [foo, bar1] },
-- conv { to_rhs, congr, rw [←bar3, bar2], skip, rw [←bar3, bar2] },

  rewrite_search {metric.edit_distance {}, strategy.pexplore {}, no visualiser,}
end

#check tactic.rewrite_search.strategy.bfs

@[search] private axiom qux' : [[1], [2]] = [[6], [7]]
@[search] private axiom qux'' : [6] = [7]
private example : [[1], [1]] = [[7], [7]] :=
begin
-- nth_rewrite_lhs 0 bar1,
-- nth_rewrite_lhs 0 qux',
-- nth_rewrite_rhs 1 ←qux'',
  rewrite_search {tracer.unit}, -- FIXME this is broken until we can do single replacements.
end

private example : [[0],[0]] = [[4],[4]] :=
begin
-- nth_rewrite_lhs 0 foo,
-- nth_rewrite_lhs 0 bar1,
-- nth_rewrite_lhs 0 ←bar2,
-- nth_rewrite_lhs 0 bar3,
-- nth_rewrite_lhs 0 foo,
-- nth_rewrite_lhs 0 bar1,
-- nth_rewrite_rhs 1 ←bar3,
-- nth_rewrite_rhs 0 bar2,
  rewrite_search { explain := ff },
end

private structure cat :=
  (O : Type)
  (H : O → O → Type)
  (i : Π o : O, H o o)
  (c : Π {X Y Z : O} (f : H X Y) (g : H Y Z), H X Z)
  (li : Π {X Y : O} (f : H X Y), c (i X) f = f)
  (ri : Π {X Y : O} (f : H X Y), c f (i Y) = f)
  (a : Π {W X Y Z : O} (f : H W X) (g : H X Y) (h : H Y Z), c (c f g) h = c f (c g h))

attribute [search] cat.li cat.a

private example (C : cat) (X Y Z : C.O) (f : C.H X Y) (g : C.H Y X) (w : C.c g f = C.i Y) (h k : C.H Y Z) (p : C.c f h = C.c f k) : h = k :=
begin
-- rewrite_search_using `search {trace := tt, trace_rules:=tt}, -- not quite there, we haven't activated intense search
perform_nth_rewrite 0 [← @cat.li C Y Z h],
perform_nth_rewrite 0 [← w],
perform_nth_rewrite 0 [C.a],
perform_nth_rewrite 0 [p],
perform_nth_rewrite 0 [← C.a],
perform_nth_rewrite 0 [w],
perform_nth_rewrite 0 [@cat.li C Y Z k],
-- PROJECT automate this!
-- rw [← C.li Y Z h],
-- rw [← C.li Y Z k],
-- rw [← w],
-- rw [C.a],
-- rw [C.a],
-- rw [p],
end

end tactic.rewrite_search.testing

namespace tactic.rewrite_search.examples

constants f g : ℕ → ℕ → ℕ → ℕ
@[search] axiom f_0_0 : ∀ a b c : ℕ, f a b c = f 0 b c
@[search] axiom f_0_1 : ∀ a b c : ℕ, f a b c = f 1 b c
@[search] axiom f_0_2 : ∀ a b c : ℕ, f a b c = f 2 b c
@[search] axiom f_1_0 : ∀ a b c : ℕ, f a b c = f a 0 c
@[search] axiom f_1_1 : ∀ a b c : ℕ, f a b c = f a 1 c
@[search] axiom f_1_2 : ∀ a b c : ℕ, f a b c = f a 2 c
@[search] axiom f_2_0 : ∀ a b c : ℕ, f a b c = f a b 0
@[search] axiom f_2_1 : ∀ a b c : ℕ, f a b c = f a b 1
@[search] axiom f_2_2 : ∀ a b c : ℕ, f a b c = f a b 2
@[search] axiom g_0_0 : ∀ a b c : ℕ, g a b c = g 0 b c
@[search] axiom g_0_1 : ∀ a b c : ℕ, g a b c = g 1 b c
@[search] axiom g_0_2 : ∀ a b c : ℕ, g a b c = g 2 b c
@[search] axiom g_1_0 : ∀ a b c : ℕ, g a b c = g a 0 c
@[search] axiom g_1_1 : ∀ a b c : ℕ, g a b c = g a 1 c
@[search] axiom g_1_2 : ∀ a b c : ℕ, g a b c = g a 2 c
@[search] axiom g_2_0 : ∀ a b c : ℕ, g a b c = g a b 0
@[search] axiom g_2_1 : ∀ a b c : ℕ, g a b c = g a b 1
@[search] axiom g_2_2 : ∀ a b c : ℕ, g a b c = g a b 2
@[search] axiom f_g : f 0 1 2 = g 2 0 1

set_option trace.app_builder true

lemma test : f 0 0 0 = g 0 0 0 :=
-- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := tt, tracer.unit, strategy.pexplore {pop_size := 1}, metric.edit_distance {refresh_freq := 5} cm}
-- begin
-- perform_nth_rewrite [f_2_2] 0,
-- perform_nth_rewrite [f_1_1] 0,
-- perform_nth_rewrite [g_0_2] 0,
-- perform_nth_rewrite [g_2_1] 0,
-- perform_nth_rewrite [← f_g] 0,
-- end

lemma test_bfs : f 0 0 0 = g 0 0 0 :=
-- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := tt, no visualiser, strategy.pexplore {pop_size:=5}, metric.edit_distance {} svm }

-- Compare: in these next two we just change pop_size 1 -> 5, and we find a much much
-- better proof, but we see a little more stuff.

lemma test_svm : f 0 0 0 = g 0 0 0 :=
-- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := tt, no visualiser, strategy.pexplore {pop_size := 1}, metric.edit_distance {refresh_freq := 1} svm}

lemma test_svm2 : f 0 0 0 = g 0 0 0 :=
-- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := tt, no visualiser, strategy.pexplore {pop_size := 5}, metric.edit_distance {refresh_freq := 1} svm}

lemma test_cm2 : f 0 0 0 = g 0 0 0 :=
-- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := tt, no visualiser, strategy.pexplore {pop_size := 5}, metric.edit_distance {refresh_freq := 1} cm}

constant h : ℕ → ℕ
@[search,simp] axiom a1 : h 0 = h 1
@[search,simp] axiom a2 : h 1 = h 2
@[search,simp] axiom a3 : h 2 = h 3
@[search,simp] axiom a4 : h 3 = h 4

lemma test2 : h 0 = h 4 :=
-- by erw [a1, a2, ←a4, ←a3]
by rewrite_search {}

constants a b c d e : ℚ

lemma test3 : (a * (b + c)) * d = a * (b * d) + a * (c * d) :=
by rewrite_search_with [add_comm, add_assoc, mul_assoc, mul_comm, left_distrib, right_distrib] {explain := tt, trace_summary := tt, no visualiser, metric.edit_distance {}}

-- lemma test4 : (a * (b + c + 1)) * d = a * (b * d) + a * (1 * d) + a * (c * d) :=
-- by rewrite_search_with [add_comm, add_assoc, mul_one, mul_assoc, mul_comm, left_distrib, right_distrib] {explain := tt, trace_summary := tt, view := visualiser, metric.edit_distance {refresh_freq := 10} cm, strategy.pexplore {pop_size := 3}, max_iterations := 1000}

namespace tactic.rewrite_search.tesseract

constants f_1 f_2 f_3 f_4 f_5 : ℕ -> ℕ -> ℕ ->  ℕ
@[search] axiom f_1_1_1: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 1 n2 n3
@[search] axiom f_2_1_1: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 1 n2 n3
@[search] axiom f_3_1_1: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 1 n2 n3
@[search] axiom f_4_1_1: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 1 n2 n3
@[search] axiom f_5_1_1: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 1 n2 n3
@[search] axiom f_1_1_2: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 2 n2 n3
@[search] axiom f_2_1_2: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 2 n2 n3
@[search] axiom f_3_1_2: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 2 n2 n3
@[search] axiom f_4_1_2: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 2 n2 n3
@[search] axiom f_5_1_2: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 2 n2 n3
@[search] axiom f_1_1_3: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 3 n2 n3
@[search] axiom f_2_1_3: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 3 n2 n3
@[search] axiom f_3_1_3: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 3 n2 n3
@[search] axiom f_4_1_3: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 3 n2 n3
@[search] axiom f_5_1_3: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 3 n2 n3
@[search] axiom f_1_2_1: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 n1 1 n3
@[search] axiom f_2_2_1: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 n1 1 n3
@[search] axiom f_3_2_1: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 n1 1 n3
@[search] axiom f_4_2_1: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 n1 1 n3
@[search] axiom f_5_2_1: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 n1 1 n3
@[search] axiom f_1_2_2: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 n1 2 n3
@[search] axiom f_2_2_2: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 n1 2 n3
@[search] axiom f_3_2_2: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 n1 2 n3
@[search] axiom f_4_2_2: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 n1 2 n3
@[search] axiom f_5_2_2: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 n1 2 n3
@[search] axiom f_1_2_3: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 n1 3 n3
@[search] axiom f_2_2_3: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 n1 3 n3
@[search] axiom f_3_2_3: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 n1 3 n3
@[search] axiom f_4_2_3: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 n1 3 n3
@[search] axiom f_5_2_3: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 n1 3 n3
@[search] axiom f_1_3_1: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 n1 n2 1
@[search] axiom f_2_3_1: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 n1 n2 1
@[search] axiom f_3_3_1: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 n1 n2 1
@[search] axiom f_4_3_1: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 n1 n2 1
@[search] axiom f_5_3_1: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 n1 n2 1
@[search] axiom f_1_3_2: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 n1 n2 2
@[search] axiom f_2_3_2: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 n1 n2 2
@[search] axiom f_3_3_2: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 n1 n2 2
@[search] axiom f_4_3_2: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 n1 n2 2
@[search] axiom f_5_3_2: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 n1 n2 2
@[search] axiom f_1_3_3: forall n1 n2 n3  : ℕ, f_1 n1 n2 n3  = f_1 n1 n2 3
@[search] axiom f_2_3_3: forall n1 n2 n3  : ℕ, f_2 n1 n2 n3  = f_2 n1 n2 3
@[search] axiom f_3_3_3: forall n1 n2 n3  : ℕ, f_3 n1 n2 n3  = f_3 n1 n2 3
@[search] axiom f_4_3_3: forall n1 n2 n3  : ℕ, f_4 n1 n2 n3  = f_4 n1 n2 3
@[search] axiom f_5_3_3: forall n1 n2 n3  : ℕ, f_5 n1 n2 n3  = f_5 n1 n2 3

namespace v1
@[search] axiom f_1_f_2 : f_1 1 1 1 = f_2 1 1 1
@[search] axiom f_2_f_3 : f_2 1 1 1 = f_3 1 1 1
@[search] axiom f_3_f_5 : f_3 1 1 1 = f_5 1 1 1
@[search] axiom f_1_f_4 : f_1 0 1 2 = f_4 2 0 1
@[search] axiom f_4_f_5 : f_4 0 1 2 = f_5 2 0 1

-- rewrite_search_with (saw/visited/used) 114/112/13 expressions during proof of tactic.rewrite_search.examples.tactic.rewrite_search.tesseract.v1.test
lemma test : f_1 0 0 0 = f_5 0 0 0 :=
-- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := ff, visualiser, strategy.pexplore {pop_size := 1, pop_alternate := ff}, metric.edit_distance {}, max_iterations := 1000}
end v1

namespace v2
@[search] axiom f_1_f_2' : f_1 0 1 2 = f_2 2 0 1
@[search] axiom f_2_f_3' : f_2 0 1 2 = f_3 2 0 1
@[search] axiom f_3_f_5' : f_3 0 1 2 = f_5 2 0 1
@[search] axiom f_1_f_4' : f_1 0 1 2 = f_4 2 0 1
-- @[search] axiom f_4_f_5' : f_4 0 1 2 = f_5 2 0 1

-- lemma test : f_1 0 0 0 = f_5 0 0 0 :=
-- -- by erw [f_2_2, f_1_1, g_0_2, g_2_1, ←f_g]
-- by rewrite_search {trace := ff, explain := tt, trace_summary := tt, exhaustive := ff, visualiser, strategy.pexplore { pop_size := 100 }, metric.edit_distance {refresh_freq := 5} cm}
end v2

end tactic.rewrite_search.tesseract

end tactic.rewrite_search.examples

-- Maybe Scott wants this
--
-- structure cat :=
--   (O : Type)
--   (H : O → O → Type)
--   (i : Π o : O, H o o)
--   (c : Π {X Y Z : O} (f : H X Y) (g : H Y Z), H X Z)
--   (li : Π {X Y : O} (f : H X Y), c (i X) f = f)
--   (ri : Π {X Y : O} (f : H X Y), c f (i Y) = f)
--   (a : Π {W X Y Z : O} (f : H W X) (g : H X Y) (h : H Y Z), c (c f g) h = c f (c g h))

-- attribute [search] cat.li cat.a

-- private example (C : cat) (X Y Z : C.O) (f : C.H X Y) (g : C.H Y X) (w : C.c g f = C.i Y) (h k : C.H Y Z) (p : C.c f h = C.c f k) : h = k :=
-- begin
-- rewrite_search {},
-- end


universes u

axiom elimEx (motive : Nat → Nat → Sort u) (x y : Nat)
  (diag  : (a : Nat) → motive a a)
  (upper : (delta a : Nat) → motive a (a + delta.succ))
  (lower : (delta a : Nat) → motive (a + delta.succ) a)
  : motive y x

theorem ex1 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl -- Error
  | upper d => apply Or.inr -- Error
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex2 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx2 with -- Error
  | lower d => apply Or.inl
  | upper d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex3 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p /- Error -/ using elimEx with
  | lower d => apply Or.inl
  | upper d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex4 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p using Nat.add with -- Error
  | lower d => apply Or.inl
  | upper d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex5 (x : Nat) : 0 + x = x := by
  match x with
  | 0   => done -- Error
  | y+1 => done -- Error

theorem ex5b (x : Nat) : 0 + x = x := by
  cases x with
  | zero   => done -- Error
  | succ y => done -- Error

inductive Vec : Nat → Type
  | nil  : Vec 0
  | cons : Bool → {n : Nat} → Vec n → Vec (n+1)

theorem ex6 (x : Vec 0) : x = Vec.nil := by
  cases x using Vec.casesOn with
  | nil  => rfl
  | cons => done -- Error

theorem ex7 (x : Vec 0) : x = Vec.nil := by
  cases x with -- Error: TODO: improve error location
  | nil  => rfl
  | cons => done

theorem ex8 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | upper2 /- Error -/ d => apply Or.inr
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex9 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | _ => apply Or.inr; admit
  | diag    => apply Or.inl; apply Nat.leRefl

theorem ex10 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | upper d => apply Or.inr; admit
  | diag    => apply Or.inl; apply Nat.leRefl
  | _  /- error unused -/ => admit

theorem ex11 (p q : Nat) : p ≤ q ∨ p > q := by
  cases p, q using elimEx with
  | lower d => apply Or.inl; admit
  | upper d => apply Or.inr; admit
  | lower d /- error unused -/ => apply Or.inl; admit
  | diag    => apply Or.inl; apply Nat.leRefl


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

! This file was ported from Lean 3 source module measure_theory.category.Meas
! leanprover-community/mathlib commit d6814c584384ddf2825ff038e868451a7c956f31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Measure.GiryMonad
import Mathbin.CategoryTheory.ConcreteCategory.UnbundledHom
import Mathbin.CategoryTheory.Monad.Algebra
import Mathbin.Topology.Category.Top.Basic

/-!
# The category of measurable spaces

Measurable spaces and measurable functions form a (concrete) category `Meas`.

## Main definitions

* `Measure : Meas ⥤ Meas`: the functor which sends a measurable space `X`
to the space of measures on `X`; it is a monad (the "Giry monad").

* `Borel : Top ⥤ Meas`: sends a topological space `X` to `X` equipped with the
`σ`-algebra of Borel sets (the `σ`-algebra generated by the open subsets of `X`).

## Tags

measurable space, giry monad, borel
-/

noncomputable section

open CategoryTheory MeasureTheory

open ENNReal

universe u v

/-- The category of measurable spaces and measurable functions. -/
def Meas : Type (u + 1) :=
  Bundled MeasurableSpace
#align Meas Meas

namespace Meas

instance : CoeSort Meas (Type _) :=
  Bundled.hasCoeToSort

instance (X : Meas) : MeasurableSpace X :=
  X.str

/-- Construct a bundled `Meas` from the underlying type and the typeclass. -/
def of (α : Type u) [MeasurableSpace α] : Meas :=
  ⟨α⟩
#align Meas.of Meas.of

@[simp]
theorem coe_of (X : Type u) [MeasurableSpace X] : (of X : Type u) = X :=
  rfl
#align Meas.coe_of Meas.coe_of

instance unbundledHom : UnbundledHom @Measurable :=
  ⟨@measurable_id, @Measurable.comp⟩
#align Meas.unbundled_hom Meas.unbundledHom

deriving instance LargeCategory, ConcreteCategory for Meas

instance : Inhabited Meas :=
  ⟨Meas.of Empty⟩

/-- `Measure X` is the measurable space of measures over the measurable space `X`. It is the
weakest measurable space, s.t. λμ, μ s is measurable for all measurable sets `s` in `X`. An
important purpose is to assign a monadic structure on it, the Giry monad. In the Giry monad,
the pure values are the Dirac measure, and the bind operation maps to the integral:
`(μ >>= ν) s = ∫ x. (ν x) s dμ`.

In probability theory, the `Meas`-morphisms `X → Prob X` are (sub-)Markov kernels (here `Prob` is
the restriction of `Measure` to (sub-)probability space.)
-/
def measure : Meas ⥤ Meas where
  obj X := ⟨@MeasureTheory.Measure X.1 X.2⟩
  map X Y f := ⟨Measure.map (f : X → Y), Measure.measurable_map f f.2⟩
  map_id' := fun ⟨α, I⟩ => Subtype.eq <| funext fun μ => @Measure.map_id α I μ
  map_comp' := fun X Y Z ⟨f, hf⟩ ⟨g, hg⟩ =>
    Subtype.eq <| funext fun μ => (Measure.map_map hg hf).symm
#align Meas.Measure Meas.measure

/-- The Giry monad, i.e. the monadic structure associated with `Measure`. -/
def giry : CategoryTheory.Monad Meas
    where
  toFunctor := measure
  η' :=
    { app := fun X => ⟨@Measure.dirac X.1 X.2, Measure.measurable_dirac⟩
      naturality' := fun X Y ⟨f, hf⟩ =>
        Subtype.eq <| funext fun a => (Measure.map_dirac hf a).symm }
  μ' :=
    { app := fun X => ⟨@Measure.join X.1 X.2, Measure.measurable_join⟩
      naturality' := fun X Y ⟨f, hf⟩ => Subtype.eq <| funext fun μ => Measure.join_map_map hf μ }
  assoc' α := Subtype.eq <| funext fun μ => @Measure.join_map_join _ _ _
  left_unit' α := Subtype.eq <| funext fun μ => @Measure.join_dirac _ _ _
  right_unit' α := Subtype.eq <| funext fun μ => @Measure.join_map_dirac _ _ _
#align Meas.Giry Meas.giry

/-- An example for an algebra on `Measure`: the nonnegative Lebesgue integral is a hom, behaving
nicely under the monad operations. -/
def integral : giry.Algebra where
  A := Meas.of ℝ≥0∞
  a := ⟨fun m : Measure ℝ≥0∞ => ∫⁻ x, x ∂m, Measure.measurable_lintegral measurable_id⟩
  unit' := Subtype.eq <| funext fun r : ℝ≥0∞ => lintegral_dirac' _ measurable_id
  assoc' :=
    Subtype.eq <|
      funext fun μ : Measure (Measure ℝ≥0∞) =>
        show (∫⁻ x, x ∂μ.join) = ∫⁻ x, x ∂Measure.map (fun m : Measure ℝ≥0∞ => ∫⁻ x, x ∂m) μ by
          rw [measure.lintegral_join, lintegral_map] <;>
            apply_rules [measurable_id, measure.measurable_lintegral]
#align Meas.Integral Meas.integral

end Meas

instance TopCat.hasForgetToMeas : HasForget₂ TopCat.{u} Meas.{u} :=
  BundledHom.mkHasForget₂ borel (fun X Y f => ⟨f.1, f.2.borel_measurable⟩) (by intros <;> rfl)
#align Top.has_forget_to_Meas TopCat.hasForgetToMeas

/- warning: Borel clashes with borel -> borel
warning: Borel -> borel is a dubious translation:
lean 3 declaration is
  CategoryTheory.Functor.{u1, u1, succ u1, succ u1} TopCat.{u1} TopCat.largeCategory.{u1} Meas.{u1} Meas.largeCategory.{u1}
but is expected to have type
  forall (α : Type.{u1}) [_inst_1 : TopologicalSpace.{u1} α], MeasurableSpace.{u1} α
Case conversion may be inaccurate. Consider using '#align Borel borelₓ'. -/
/-- The Borel functor, the canonical embedding of topological spaces into measurable spaces. -/
@[reducible]
def borel : TopCat.{u} ⥤ Meas.{u} :=
  forget₂ TopCat.{u} Meas.{u}
#align Borel borel


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import order.category.Lattice

/-!
# Category of linear orders

This defines `LinearOrder`, the category of linear orders with monotone maps.
-/

open category_theory

universe u

/-- The category of linear orders. -/
def LinearOrder := bundled linear_order

namespace LinearOrder

instance : bundled_hom.parent_projection @linear_order.to_partial_order := ⟨⟩

attribute [derive [large_category, concrete_category]] LinearOrder

instance : has_coe_to_sort LinearOrder Type* := bundled.has_coe_to_sort

/-- Construct a bundled `LinearOrder` from the underlying type and typeclass. -/
def of (α : Type*) [linear_order α] : LinearOrder := bundled.of α

@[simp] lemma coe_of (α : Type*) [linear_order α] : ↥(of α) = α := rfl

instance : inhabited LinearOrder := ⟨of punit⟩

instance (α : LinearOrder) : linear_order α := α.str

instance has_forget_to_Lattice : has_forget₂ LinearOrder Lattice :=
{ forget₂ := { obj := λ X, Lattice.of X,
               map := λ X Y f, (order_hom_class.to_lattice_hom X Y f : lattice_hom X Y) } }

/-- Constructs an equivalence between linear orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : LinearOrder.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply x },
  inv_hom_id' := by { ext, exact e.apply_symm_apply x } }

/-- `order_dual` as a functor. -/
@[simps] def dual : LinearOrder ⥤ LinearOrder :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, order_hom.dual }

/-- The equivalence between `LinearOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : LinearOrder ≌ LinearOrder :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end LinearOrder

lemma LinearOrder_dual_comp_forget_to_Lattice :
  LinearOrder.dual ⋙ forget₂ LinearOrder Lattice = forget₂ LinearOrder Lattice ⋙ Lattice.dual :=
rfl


import Lean.Elab

open Lean.Parser.Command
open Lean Std

universe u v w

/-
  Original implementation:
  https://github.com/gebner/hott3/blob/master/src/hott/init/meta/support.lean
-/

namespace GroundZero.Meta.HottTheory

partial def instArgsAux : LocalContext → Expr → MetaM (LocalContext × Expr)
| lctx, e => do
  let τ ← Meta.inferType e >>= Meta.whnf;
  if τ.isForall then do
    let varId ← mkFreshFVarId
    let lctx' := lctx.mkLocalDecl varId τ.bindingName! τ.bindingDomain! τ.bindingInfo!

    withReader (λ ctx => { ctx with lctx := lctx' }) do
      mkFVar varId
      |> mkApp e
      |> instArgsAux lctx'
  else return (lctx, e)

def instArgs (e : Expr) : MetaM (LocalContext × Expr) := do
  let ctx ← read; instArgsAux ctx.lctx e

def isProp : LocalContext → Expr → MetaM Bool :=
λ lctx e =>
  withReader (λ ctx => { ctx with lctx := lctx })
    (Expr.isProp <$> Meta.inferType e)

def isProof : LocalContext → Expr → MetaM Bool :=
λ lctx e => Meta.inferType e >>= isProp lctx

def mkNumMetaUnivs : Nat → MetaM (List Level)
|   0   => return []
| n + 1 => do
  let id ← mkFreshLMVarId;
  let xs ← mkNumMetaUnivs n;
  return (mkLevelMVar id :: xs)

def const (c : Name) : MetaM Expr := do
  let env ← getEnv;
  match env.constants.find? c with
  | some info => do
    let num := info.levelParams.length;
    let levels ← mkNumMetaUnivs num;
    return mkConst c levels
  | none => throwError "unknown identifier “{c}”"

def uncurry {A : Type u} {B : Type v} {C : Type w} : (A → B → C) → (A × B → C) :=
λ f (a, b) => f a b

def hasLargeElim (type : Name) : MetaM Bool := do
  let typeFormerIsProp ← const type >>= instArgs >>= uncurry isProp;
  let elimIsProp ← const (type ++ `rec) >>= instArgs >>= uncurry isProof;
  return (typeFormerIsProp ∧ ¬elimIsProp)

def renderChain : List Name → String :=
String.intercalate " <- " ∘ List.map toString

def checkLargeElim (tag : Syntax) (chain : List Name) (name : Name) : MetaM Unit := do
  let largeElim? ← hasLargeElim name;
  if largeElim? then throwErrorAt tag "uses large eliminator: {renderChain chain}"

initialize hottDecls : SimplePersistentEnvExtension Name NameSet ←
  registerSimplePersistentEnvExtension {
    name          := `hottDecls
    addEntryFn    := NameSet.insert
    addImportedFn := fun es => mkStateFromImportedEntries NameSet.insert {} es
  }

initialize nothott : TagAttribute ← registerTagAttribute `nothott "Marks a defintion as unsafe for HoTT"
initialize hottAxiom : TagAttribute ← registerTagAttribute `hottAxiom "Unsafely marks a definition as safe for HoTT"

def unsafeDecls :=
[`Quot.lift, `Quot.ind, `Quot.rec, `Classical.choice]

def checked? (decl : Name) : MetaM Bool := do
  let env ← getEnv
  let checked := (hottDecls.getState env).contains decl
  let isSafe := hottAxiom.hasTag env decl

  pure (checked ∨ isSafe)

def checkNotNotHoTT (tag : Syntax) (env : Environment) (decl : Name) : MetaM Unit := do
  if nothott.hasTag env decl ∨ unsafeDecls.contains decl then
    throwErrorAt tag "marked as [nothott]: {decl}"
  else return ()

partial def checkDeclAux (chain : List Name) (tag : Syntax) (name : Name) : MetaM Unit := do
  let env ← getEnv

  if ¬(← checked? name) then
    checkNotNotHoTT tag env name
    match env.find? name with
    | some (ConstantInfo.recInfo v) =>
      List.forM v.all (checkLargeElim tag chain)
    | some info =>
      match info.value? with
      | some expr => Array.forM (λ n => checkDeclAux (n :: chain) tag n)
                                expr.getUsedConstants
      | none => return ()
    | none => throwError "unknown identifier “{name}”"
  else return ()

def checkDecl := checkDeclAux []

def declTok : Parser.Parser :=
    "def "         <|> "definition " <|> "theorem "   <|> "lemma "
<|> "proposition " <|> "corollary "  <|> "principle " <|> "claim "
<|> "statement "   <|> "paradox "

def decl := leading_parser
   declTok >> declId >> Parser.ppIndent optDeclSig
>> declVal >> optDefDeriving >> terminationSuffix

@[command_parser] def hott :=
leading_parser declModifiers false >> "hott " >> decl

@[command_elab «hott»] def elabHoTT : Elab.Command.CommandElab :=
λ stx => match stx.getArgs with
| #[mods, _, cmd] => do
  let declId   := cmd[1]
  let declName := declId[0].getId

  let ns ← getCurrNamespace
  let name := ns ++ declName

  cmd.setKind `Lean.Parser.Command.«def»
  |> (Syntax.setArg · 0 (mkAtom "def "))
  |> (mkNode `Lean.Parser.Command.declaration #[mods, ·])
  |> Elab.Command.elabDeclaration

  if (← getEnv).contains name then do {
    Elab.Command.liftTermElabM (checkDecl declId name);
    modifyEnv (λ env => hottDecls.addEntry env name)
  }
| _ => throwError "invalid declaration"

end GroundZero.Meta.HottTheory