/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import tactic.ring
import data.num.lemmas
import data.tree

/-!
# ring2

An experimental variant on the `ring` tactic that uses computational
reflection instead of proof generation. Useful for kernel benchmarking.
-/

namespace tree

/-- `(reflect' t u α)` quasiquotes a tree `(t: tree expr)` of quoted
values of type `α` at level `u` into an `expr` which reifies to a `tree α`
containing the reifications of the `expr`s from the original `t`. -/
protected meta def reflect' (u : level) (α : expr) : tree expr → expr
| tree.nil := (expr.const ``tree.nil [u] : expr) α
| (tree.node a t₁ t₂) :=
  (expr.const ``tree.node [u] : expr) α a t₁.reflect' t₂.reflect'

/-- Returns an element indexed by `n`, or zero if `n` isn't a valid index.
See `tree.get`. -/
protected def get_or_zero {α} [has_zero α] (t : tree α) (n : pos_num) : α :=
  t.get_or_else n 0

end tree

namespace tactic.ring2

/-- A reflected/meta representation of an expression in a commutative
semiring. This representation is a direct translation of such
expressions - see `horner_expr` for a normal form. -/
@[derive has_reflect]
inductive csring_expr
/- (atom n) is an opaque element of the csring. For example,
a local variable in the context. n indexes into a storage
of such atoms - a `tree α`. -/
| atom : pos_num → csring_expr
/- (const n) is technically the csring's one, added n times.
Or the zero if n is 0. -/
| const : num → csring_expr
| add : csring_expr → csring_expr → csring_expr
| mul : csring_expr → csring_expr → csring_expr
| pow : csring_expr → num → csring_expr

namespace csring_expr

instance : inhabited csring_expr := ⟨const 0⟩

/-- Evaluates a reflected `csring_expr` into an element of the
original `comm_semiring` type `α`, retrieving opaque elements
(atoms) from the tree `t`. -/
def eval {α} [comm_semiring α] (t : tree α) : csring_expr → α
| (atom n)  := t.get_or_zero n
| (const n) := n
| (add x y) := eval x + eval y
| (mul x y) := eval x * eval y
| (pow x n) := eval x ^ (n : ℕ)

end csring_expr

/-- An efficient representation of expressions in a commutative
semiring using the sparse Horner normal form. This type admits
non-optimal instantiations (e.g. `P` can be represented as `P+0+0`),
so to get good performance out of it, care must be taken to maintain
an optimal, *canonical* form. -/
@[derive decidable_eq]
inductive horner_expr
/- (const n) is a constant n in the csring, similarly to the same
constructor in `csring_expr`. This one, however, can be negative. -/
| const : znum → horner_expr
/- (horner a x n b) is a*xⁿ + b, where x is the x-th atom
in the atom tree. -/
| horner : horner_expr → pos_num → num → horner_expr → horner_expr

namespace horner_expr

/-- True iff the `horner_expr` argument is a valid `csring_expr`.
For that to be the case, all its constants must be non-negative. -/
def is_cs : horner_expr → Prop
| (const n) := ∃ m:num, n = m.to_znum
| (horner a x n b) := is_cs a ∧ is_cs b

instance : has_zero horner_expr := ⟨const 0⟩
instance : has_one horner_expr := ⟨const 1⟩
instance : inhabited horner_expr := ⟨0⟩

/-- Represent a `csring_expr.atom` in Horner form. -/
def atom (n : pos_num) : horner_expr := horner 1 n 1 0

def to_string : horner_expr → string
| (const n) := _root_.repr n
| (horner a x n b) :=
    "(" ++ to_string a ++ ") * x" ++ _root_.repr x ++ "^"
        ++ _root_.repr n ++ " + " ++ to_string b
instance : has_to_string horner_expr := ⟨to_string⟩

/-- Alternative constructor for (horner a x n b) which maintains canonical
form by simplifying special cases of `a`. -/
def horner' (a : horner_expr)
  (x : pos_num) (n : num) (b : horner_expr) : horner_expr :=
match a with
| const q := if q = 0 then b else horner a x n b
| horner a₁ x₁ n₁ b₁ :=
  if x₁ = x ∧ b₁ = 0 then horner a₁ x (n₁ + n) b
  else horner a x n b
end

def add_const (k : znum) (e : horner_expr) : horner_expr :=
if k = 0 then e else begin
  induction e with n a x n b A B,
  { exact const (k + n) },
  { exact horner a x n B }
end

def add_aux (a₁ : horner_expr) (A₁ : horner_expr → horner_expr) (x₁ : pos_num) :
  horner_expr → num → horner_expr → (horner_expr → horner_expr) → horner_expr
| (const n₂)           n₁ b₁ B₁ := add_const n₂ (horner a₁ x₁ n₁ b₁)
| (horner a₂ x₂ n₂ b₂) n₁ b₁ B₁ :=
  let e₂ := horner a₂ x₂ n₂ b₂ in
  match pos_num.cmp x₁ x₂ with
  | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
  | ordering.gt := horner a₂ x₂ n₂ (add_aux b₂ n₁ b₁ B₁)
  | ordering.eq :=
    match num.sub' n₁ n₂ with
    | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
    | (znum.pos k) := horner (add_aux a₂ k 0 id) x₁ n₂ (B₁ b₂)
    | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
    end
  end

def add : horner_expr → horner_expr → horner_expr
| (const n₁)           e₂ := add_const n₁ e₂
| (horner a₁ x₁ n₁ b₁) e₂ := add_aux a₁ (add a₁) x₁ e₂ n₁ b₁ (add b₁)
/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact add_const n₁ e₂ },
  exact match e₂ with e₂ := begin
    induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁;
    let e₁ := horner a₁ x₁ n₁ b₁,
    { exact add_const n₂ e₁ },
    let e₂ := horner a₂ x₂ n₂ b₂,
    exact match pos_num.cmp x₁ x₂ with
    | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
    | ordering.gt := horner a₂ x₂ n₂ (B₂ n₁ b₁)
    | ordering.eq :=
      match num.sub' n₁ n₂ with
      | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
      | (znum.pos k) := horner (A₂ k 0) x₁ n₂ (B₁ b₂)
      | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
      end
    end
  end end
end-/

def neg (e : horner_expr) : horner_expr :=
begin
  induction e with n a x n b A B,
  { exact const (-n) },
  { exact horner A x n B }
end

def mul_const (k : znum) (e : horner_expr) : horner_expr :=
if k = 0 then 0 else if k = 1 then e else begin
  induction e with n a x n b A B,
  { exact const (n * k) },
  { exact horner A x n B }
end

def mul_aux (a₁ x₁ n₁ b₁) (A₁ B₁ : horner_expr → horner_expr) :
  horner_expr → horner_expr
| (const n₂) := mul_const n₂ (horner a₁ x₁ n₁ b₁)
| e₂@(horner a₂ x₂ n₂ b₂) :=
  match pos_num.cmp x₁ x₂ with
  | ordering.lt := horner (A₁ e₂) x₁ n₁ (B₁ e₂)
  | ordering.gt := horner (mul_aux a₂) x₂ n₂ (mul_aux b₂)
  | ordering.eq := let haa := horner' (mul_aux a₂) x₁ n₂ 0 in
    if b₂ = 0 then haa else haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂))
  end

def mul : horner_expr → horner_expr → horner_expr
| (const n₁)           := mul_const n₁
| (horner a₁ x₁ n₁ b₁) := mul_aux a₁ x₁ n₁ b₁ (mul a₁) (mul b₁).
/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact mul_const n₁ e₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂;
  let e₁ := horner a₁ x₁ n₁ b₁,
  { exact mul_const n₂ e₁ },
  let e₂ := horner a₂ x₂ n₂ b₂,
  cases pos_num.cmp x₁ x₂,
  { exact horner (A₁ e₂) x₁ n₁ (B₁ e₂) },
  { let haa := horner' A₂ x₁ n₂ 0,
    exact if b₂ = 0 then haa else
      haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂)) },
  { exact horner A₂ x₂ n₂ B₂ }
end-/

instance : has_add horner_expr := ⟨add⟩
instance : has_neg horner_expr := ⟨neg⟩
instance : has_mul horner_expr := ⟨mul⟩

def pow (e : horner_expr) : num → horner_expr
| 0 := 1
| (num.pos p) := begin
  induction p with p ep p ep,
  { exact e },
  { exact (ep.mul ep).mul e },
  { exact ep.mul ep }
end

def inv (e : horner_expr) : horner_expr := 0

/-- Brings expressions into Horner normal form. -/
def of_csexpr : csring_expr → horner_expr
| (csring_expr.atom n)  := atom n
| (csring_expr.const n) := const n.to_znum
| (csring_expr.add x y) := (of_csexpr x).add (of_csexpr y)
| (csring_expr.mul x y) := (of_csexpr x).mul (of_csexpr y)
| (csring_expr.pow x n) := (of_csexpr x).pow n

/-- Evaluates a reflected `horner_expr` - see `csring_expr.eval`. -/
def cseval {α} [comm_semiring α] (t : tree α) : horner_expr → α
| (const n)        := n.abs
| (horner a x n b) := tactic.ring.horner (cseval a) (t.get_or_zero x) n (cseval b)

theorem cseval_atom {α} [comm_semiring α] (t : tree α)
  (n : pos_num) : (atom n).is_cs ∧ cseval t (atom n) = t.get_or_zero n :=
⟨⟨⟨1, rfl⟩, ⟨0, rfl⟩⟩, (tactic.ring.horner_atom _).symm⟩

theorem cseval_add_const {α} [comm_semiring α] (t : tree α)
  (k : num) {e : horner_expr} (cs : e.is_cs) :
  (add_const k.to_znum e).is_cs ∧
    cseval t (add_const k.to_znum e) = k + cseval t e :=
begin
  simp [add_const],
  cases k; simp! *,
  simp [show znum.pos k ≠ 0, from dec_trivial],
  induction e with n a x n b A B; simp *,
  { rcases cs with ⟨n, rfl⟩,
    refine ⟨⟨n + num.pos k, by simp [add_comm]; refl⟩, _⟩,
    cases n; simp! },
  { rcases B cs.2 with ⟨csb, h⟩, simp! [*, cs.1],
    rw [← tactic.ring.horner_add_const, add_comm], rw add_comm }
end

theorem cseval_horner' {α} [comm_semiring α] (t : tree α)
  (a x n b) (h₁ : is_cs a) (h₂ : is_cs b) :
  (horner' a x n b).is_cs ∧ cseval t (horner' a x n b) =
    tactic.ring.horner (cseval t a) (t.get_or_zero x) n (cseval t b) :=
begin
  cases a with n₁ a₁ x₁ n₁ b₁; simp [horner']; split_ifs,
  { simp! [*, tactic.ring.horner] },
  { exact ⟨⟨h₁, h₂⟩, rfl⟩ },
  { refine ⟨⟨h₁.1, h₂⟩, eq.symm _⟩, simp! *,
    apply tactic.ring.horner_horner, simp },
  { exact ⟨⟨h₁, h₂⟩, rfl⟩ }
end

theorem cseval_add {α} [comm_semiring α] (t : tree α)
  {e₁ e₂ : horner_expr} (cs₁ : e₁.is_cs) (cs₂ : e₂.is_cs) :
  (add e₁ e₂).is_cs ∧
  cseval t (add e₁ e₂) = cseval t e₁ + cseval t e₂ :=
begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂; simp!,
  { rcases cs₁ with ⟨n₁, rfl⟩,
    simpa using cseval_add_const t n₁ cs₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁,
  { rcases cs₂ with ⟨n₂, rfl⟩,
    simp! [cseval_add_const t n₂ cs₁, add_comm] },
  cases cs₁ with csa₁ csb₁, cases id cs₂ with csa₂ csb₂,
  simp!, have C := pos_num.cmp_to_nat x₁ x₂,
  cases pos_num.cmp x₁ x₂; simp!,
  { rcases B₁ csb₁ cs₂ with ⟨csh, h⟩,
    refine ⟨⟨csa₁, csh⟩, eq.symm _⟩,
    apply tactic.ring.horner_add_const,
    exact h.symm },
  { cases C,
    have B0 : is_cs 0 → ∀ {e₂ : horner_expr}, is_cs e₂ →
      is_cs (add 0 e₂) ∧ cseval t (add 0 e₂) = cseval t 0 + cseval t e₂ :=
      λ _ e₂ c, ⟨c, (zero_add _).symm⟩,
     cases e : num.sub' n₁ n₂ with k k; simp!,
    { have : n₁ = n₂,
      { have := congr_arg (coe : znum → ℤ) e,
        simp at this,
        have := sub_eq_zero.1 this,
        rw [← num.to_nat_to_int, ← num.to_nat_to_int] at this,
        exact num.to_nat_inj.1 (int.coe_nat_inj this) },
      subst n₂,
      rcases cseval_horner' _ _ _ _ _ _ _ with ⟨csh, h⟩,
      { refine ⟨csh, h.trans (eq.symm _)⟩,
        simp *,
        apply tactic.ring.horner_add_horner_eq; try {refl} },
      all_goals {simp! *} },
    { simp [B₁ csb₁ csb₂, add_comm],
      rcases A₂ csa₂ _ _ B0 ⟨csa₁, 0, rfl⟩ with ⟨csh, h⟩,
      refine ⟨csh, eq.symm _⟩,
      rw [show id = add 0, from rfl, h],
      apply tactic.ring.horner_add_horner_gt,
      { change (_ + k : ℕ) = _,
        rw [← int.coe_nat_inj', int.coe_nat_add,
          eq_comm, ← sub_eq_iff_eq_add'],
        simpa using congr_arg (coe : znum → ℤ) e },
      { refl },
      { apply add_comm } },
    { have : (horner a₂ x₁ (num.pos k) 0).is_cs := ⟨csa₂, 0, rfl⟩,
      simp [B₁ csb₁ csb₂, A₁ csa₁ this],
      symmetry, apply tactic.ring.horner_add_horner_lt,
      { change (_ + k : ℕ) = _,
          rw [← int.coe_nat_inj', int.coe_nat_add,
            eq_comm, ← sub_eq_iff_eq_add', ← neg_inj, neg_sub],
        simpa using congr_arg (coe : znum → ℤ) e },
      all_goals { refl } } },
  { rcases B₂ csb₂ _ _ B₁ ⟨csa₁, csb₁⟩ with ⟨csh, h⟩,
    refine ⟨⟨csa₂, csh⟩, eq.symm _⟩,
    apply tactic.ring.const_add_horner,
    simp [h] }
end

theorem cseval_mul {α} [comm_semiring α] (t : tree α)
  {e₁ e₂ : horner_expr} (cs₁ : e₁.is_cs) (cs₂ : e₂.is_cs) :
  (mul e₁ e₂).is_cs ∧
  cseval t (mul e₁ e₂) = cseval t e₁ * cseval t e₂ :=
begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂; simp!,
  { rcases cs₁ with ⟨n₁, rfl⟩,
    simpa [mul_comm] using cseval_mul_const t n₁ cs₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂,
  { rcases cs₂ with ⟨n₂, rfl⟩,
    simpa! using cseval_mul_const t n₂ cs₁ },
  cases cs₁ with csa₁ csb₁, cases id cs₂ with csa₂ csb₂,
  simp!, have C := pos_num.cmp_to_nat x₁ x₂,
  cases A₂ csa₂ with csA₂ hA₂,
  cases pos_num.cmp x₁ x₂; simp!,
  { simp [A₁ csa₁ cs₂, B₁ csb₁ cs₂],
    symmetry, apply tactic.ring.horner_mul_const; refl },
  { cases cseval_horner' t _ x₁ n₂ 0 csA₂ ⟨0, rfl⟩ with csh₁ h₁,
    cases C, split_ifs,
    { subst b₂,
      refine ⟨csh₁, h₁.trans (eq.symm _)⟩,
      apply tactic.ring.horner_mul_horner_zero; try {refl},
      simp! [hA₂] },
    { cases A₁ csa₁ csb₂ with csA₁ hA₁,
      cases cseval_add t csh₁ _ with csh₂ h₂,
      { refine ⟨csh₂, h₂.trans (eq.symm _)⟩,
        apply tactic.ring.horner_mul_horner; try {refl},
        simp! * },
      exact ⟨csA₁, (B₁ csb₁ csb₂).1⟩ } },
  { simp [A₂ csa₂, B₂ csb₂], rw [mul_comm, eq_comm],
    apply tactic.ring.horner_const_mul,
    {apply mul_comm}, {refl} },
end

theorem cseval_pow {α} [comm_semiring α] (t : tree α)
  {x : horner_expr} (cs : x.is_cs) :
  ∀ (n : num), (pow x n).is_cs ∧
    cseval t (pow x n) = cseval t x ^ (n : ℕ)
| 0 := ⟨⟨1, rfl⟩, (pow_zero _).symm⟩
| (num.pos p) := begin
  simp [pow], induction p with p ep p ep,
  { simp * },
  { simp [pow_bit1],
    cases cseval_mul t ep.1 ep.1 with cs₀ h₀,
    cases cseval_mul t cs₀ cs with cs₁ h₁,
    simp * },
  { simp [pow_bit0],
    cases cseval_mul t ep.1 ep.1 with cs₀ h₀,
    simp * }
end

/-- For any given tree `t` of atoms and any reflected expression `r`,
the Horner form of `r` is a valid csring expression, and under `t`,
the Horner form evaluates to the same thing as `r`. -/
theorem cseval_of_csexpr {α} [comm_semiring α] (t : tree α) :
  ∀ (r : csring_expr), (of_csexpr r).is_cs ∧ cseval t (of_csexpr r) = r.eval t
| (csring_expr.atom n)  := cseval_atom _ _
| (csring_expr.const n) := ⟨⟨n, rfl⟩, by cases n; refl⟩
| (csring_expr.add x y) :=
  let ⟨cs₁, h₁⟩ := cseval_of_csexpr x,
      ⟨cs₂, h₂⟩ := cseval_of_csexpr y,
      ⟨cs, h⟩ := cseval_add t cs₁ cs₂ in ⟨cs, by simp! [h, *]⟩
| (csring_expr.mul x y) :=
  let ⟨cs₁, h₁⟩ := cseval_of_csexpr x,
      ⟨cs₂, h₂⟩ := cseval_of_csexpr y,
      ⟨cs, h⟩ := cseval_mul t cs₁ cs₂ in ⟨cs, by simp! [h, *]⟩
| (csring_expr.pow x n) :=
  let ⟨cs, h⟩ := cseval_of_csexpr x,
      ⟨cs, h⟩ := cseval_pow t cs n in ⟨cs, by simp! [h, *]⟩

end horner_expr

/-- The main proof-by-reflection theorem. Given reflected csring expressions
`r₁` and `r₂` plus a storage `t` of atoms, if both expressions go to the
same Horner normal form, then the original non-reflected expressions are
equal. `H` follows from kernel reduction and is therefore `rfl`. -/
theorem correctness {α} [comm_semiring α] (t : tree α) (r₁ r₂ : csring_expr)
  (H : horner_expr.of_csexpr r₁ = horner_expr.of_csexpr r₂) :
  r₁.eval t = r₂.eval t :=
by repeat {rw ← (horner_expr.cseval_of_csexpr t _).2}; rw H

/-- Reflects a csring expression into a `csring_expr`, together
with a dlist of atoms, i.e. opaque variables over which the
expression is a polynomial. -/
meta def reflect_expr : expr → csring_expr × dlist expr
| `(%%e₁ + %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂, l₁ ++ l₂)
/-| `(%%e₁ - %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂.neg, l₁ ++ l₂)
| `(- %%e) := let (r, l) := reflect_expr e in (r.neg, l)-/
| `(%%e₁ * %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂, l₁ ++ l₂)
/-| `(has_inv.inv %%e) := let (r, l) := reflect_expr e in (r.neg, l)
| `(%%e₁ / %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂.inv, l₁ ++ l₂)-/
| e@`(%%e₁ ^ %%e₂) :=
  match reflect_expr e₁, expr.to_nat e₂ with
  | (r₁, l₁), some n₂ := (r₁.pow (num.of_nat' n₂), l₁)
  | (r₁, l₁), none := (csring_expr.atom 1, dlist.singleton e)
  end
| e := match expr.to_nat e with
  | some n := (csring_expr.const (num.of_nat' n), dlist.empty)
  | none := (csring_expr.atom 1, dlist.singleton e)
  end

/-- In the output of `reflect_expr`, `atom`s are initialized with incorrect indices.
The indices cannot be computed until the whole tree is built, so another pass over
the expressions is needed - this is what `replace` does. The computation (expressed
in the state monad) fixes up `atom`s to match their positions in the atom tree.
The initial state is a list of all atom occurrences in the goal, left-to-right. -/
meta def csring_expr.replace (t : tree expr) : csring_expr → state_t (list expr) option csring_expr
| (csring_expr.atom _)  := do e ← get,
  p ← monad_lift (t.index_of (<) e.head),
  put e.tail, pure (csring_expr.atom p)
| (csring_expr.const n) := pure (csring_expr.const n)
| (csring_expr.add x y) := csring_expr.add <$> x.replace <*> y.replace
| (csring_expr.mul x y) := csring_expr.mul <$> x.replace <*> y.replace
| (csring_expr.pow x n) := (λ x, csring_expr.pow x n) <$> x.replace
--| (csring_expr.neg x)   := csring_expr.neg <$> x.replace
--| (csring_expr.inv x)   := csring_expr.inv <$> x.replace

end tactic.ring2

namespace tactic
namespace interactive
open interactive interactive.types lean.parser
open tactic.ring2

local postfix (name := parser.optional) `?`:9001 := optional

/-- `ring2` solves equations in the language of rings.

It supports only the commutative semiring operations, i.e. it does not normalize subtraction or
division.

  This variant on the `ring` tactic uses kernel computation instead
  of proof generation. In general, you should use `ring` instead of `ring2`. -/
meta def ring2 : tactic unit :=
do `[repeat {rw ← nat.pow_eq_pow}],
  `(%%e₁ = %%e₂) ← target
  | fail "ring2 tactic failed: the goal is not an equality",
  α ← infer_type e₁,
  expr.sort (level.succ u) ← infer_type α,
  let (r₁, l₁) := reflect_expr e₁,
  let (r₂, l₂) := reflect_expr e₂,
  let L := (l₁ ++ l₂).to_list,
  let s := tree.of_rbnode (rbtree_of L).1,
  (r₁, L) ← (state_t.run (r₁.replace s) L : option _),
  (r₂, _) ← (state_t.run (r₂.replace s) L : option _),
  let se : expr := s.reflect' u α,
  let er₁ : expr := reflect r₁,
  let er₂ : expr := reflect r₂,
  cs ← mk_app ``comm_semiring [α] >>= mk_instance,
  e ← to_expr ``(correctness %%se %%er₁ %%er₂ rfl)
    <|> fail ("ring2 tactic failed, cannot show equality:\n"
      ++ to_string (horner_expr.of_csexpr r₁) ++
      "\n  =?=\n" ++ to_string (horner_expr.of_csexpr r₂)),
  tactic.exact e

add_tactic_doc
{ name        := "ring2",
  category    := doc_category.tactic,
  decl_names  := [`tactic.interactive.ring2],
  tags        := ["arithmetic", "simplification", "decision procedure"] }

end interactive
end tactic

namespace conv.interactive
open conv

meta def ring2 : conv unit := discharge_eq_lhs tactic.interactive.ring2

end conv.interactive


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 :=density_irrational_orbit (α : ℚ) : (α.is_irrational) → ∀ ε > 0, ∃! n ∈ ℤ, ε > n * α - n,
begin
  assume (h1 : α.is_irrational) (ε),
  have h2 : ∃! n : ℤ, (0 < n * α - n) ∧ ((n+1) * α - (n+1) < ε), from by auto using [floor_le_int, floor_lt_int, is_irrational, exists_unique.exists],
  show ∃! n : ℤ, ε > n * α - n, from by auto [h2, exists_unique.unique, exists_unique.exists, floor_le_int, floor_lt_int, is_irrational],
end

--OUTPUT 2
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℚ) (h1 : α ≠ 0) : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ [0, 1], |y - (n * α) % 1| < ε :=
begin
  assume h2 : α ≠ 0,
  have h3 : ∀ i j : ℤ, i ≠ j → ⟨i*α⟩ ≠ ⟨j*α⟩, from
  begin
    assume (i j : ℤ) (h4 : i ≠ j),
    have h5 : i * α - ⌊i * α⌋ ≠ j * α - ⌊j * α⌋, from
      begin
        assume h6,
        show false, from
          begin
            have h7 : α = ⌊i * α⌋ - ⌊j * α⌋ / (i - j), from
              begin
                calc α = i * α - ⌊i * α⌋ : by linarith
                ... = j * α - ⌊j * α⌋ : by linarith
                ... = (j - i) * α + ⌊j * α⌋ - ⌊i * α⌋ : by linarith
                ... = ⌊j * α⌋ - ⌊i * α⌋ : by linarith
                ... = ⌊j * α⌋ - ⌊i * α⌋ / (i - j) : by linarith
              end,
            have h8 : α ∈ ℤ, from
              begin
                have h9 : ⌊j * α⌋ - ⌊i * α⌋ / (i - j) ∈ ℤ, from
                  begin
                    have h10 : i ≠ j, from by linarith,
                    show ⌊j * α⌋ - ⌊i * α⌋ / (i - j) ∈ ℤ, from
                      begin
                        have h11 : ⌊j * α⌋ - ⌊i * α⌋ ∈ ℤ, from by linarith,
                        have h12 : (i - j) ∈ ℤ, from by linarith,
                        show ⌊j * α⌋ - ⌊i * α⌋ / (i - j) ∈ ℤ, from
                          begin
                            have h13 : (i - j) ≠ 0, from by linarith,
                            show (⌊j * α⌋ - ⌊i * α⌋) / (i - j) ∈ ℤ, from by linarith [h11, h13],
                          end
                      end
                  end,
                have h11 : α ∈ ℚ, from
                  begin
                    show α ∈ ℚ, from by linarith using [old_nat_cast.injective]
                  end,
                show α ∈ ℤ, from by linarith [h9],
              end,
            show false, from by linarith [h7, h8]
          end
      end,
      show ⟨i*α⟩ ≠ ⟨j*α⟩, from
        begin
          show ⟨i*α⟩ ≠ ⟨j*α⟩, from
            begin
              show ⟨i*α⟩ ≠ ⟨j*α⟩, from by linarith [h5]
            end
        end
  end,

  have h6 : ∀ (i j : ℤ), i ≠ j → ⟨i * α⟩ ≠ ⟨j * α⟩, from h3,

  have h7 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ x : ℤ, ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
    begin
      have h8 : ∀ i j : ℤ, i ≠ j → ⟨i * α⟩ ≠ ⟨j * α⟩, from h6,
      have h9 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
        begin
          have h10 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
            begin
              have h11 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                begin
                  have h12 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                    begin
                      have h13 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                        begin
                          have h14 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                            begin
                              have h15 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                begin
                                  have h16 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                    begin
                                      have h17 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                        begin
                                          have h18 : ∃ x : ℝ, ∀ ε > 0, ∃ N, ∀ n > N, ∀ y ∈ set.range (λ (x : ℤ), ⟨x * α⟩), |y - ⟨n * α⟩| < ε, from
                                            begin
                                              have h19 : set.range (λ (i : ℤ), ⟨i * α⟩) ⊆ set.Ico 0 1, from
                                                begin
                                                  assume (x : ℝ),
                                                  assume (h20 : x ∈ set.range (λ (i : ℤ), ⟨i * α⟩)),
                                                  cases h20 with i h21,
                                                  assume h22 : ⟨i * α
end --Needs more than 2000 tokens!

--OUTPUT 3
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense (α : ℝ) (hα : ¬ is_rat α) :  dense_of_dense_range (λ j : ℤ, (floor j α : ℝ)) :=
begin
  let s : set ℝ := λ (i : ℤ), ((floor i α) : ℝ),
  let ƒ : ℤ → ℤ → ℝ := λ (i j : ℤ), floor i α - floor j α,
  let h1 : s.finite.nonempty := by norm_num,
  let h2 : ∀ (i j : ℤ), (i : ℝ) ≠ j → s i ≠ s j := by auto [hα, floor_divides_iff_rat],
  let h3 : s.infinite := by auto [hα, floor_divides_iff_rat],
  let h4 : ∃ (y : ℝ), is_limit_point s y, from exists_limit_point_of_infinite s h3,
  let h5 : ∃ (y : ℝ), is_limit_point s y := by auto [h4],

  let h6 : ∃ (y : ℝ), is_limit_point s y, from exists_limit_point_of_infinite s h3,
  let h7 : ∃ (y : ℝ), is_limit_point s y := by auto [h6],

  have h8 : ∃! x ∈ s, ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε, from exists_unique_limit_point_of_infinite s h3 h5,

  let h9 : ∃! x ∈ s, ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε, from exists_unique_limit_point_of_infinite s h3 h7,
  let h10 : ∃! x ∈ s, ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h9],
  let h11 : ∃! x ∈ s, ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h8],
  let h12 : ∃! x ∈ s, ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h11],
  let h13 : ∃ (x : ℤ), ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h12],
  let h14 : ∃ (x : ℤ), ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h13],

  let x := classical.some (h12).some,
  let h15 : ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h12],
  let h16 : ∀ (ε : ℝ), 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h15],
  let h17 : ∀ {ε : ℝ}, 0 < ε → ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] ε := by auto [h15],

  let h18 : ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] 0.5 := by auto [h16],
  let h19 : ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] 0.5 := by auto [h18],
  let h20 : ∃ (n : ℤ), n > x ∧ s n ∈ 𝓝[s x] 0.5 := by auto [h19],

  let N := classical.some (h20).some,
  let y : ℝ := (floor N α - floor x α) * (floor N α : ℝ),
  let h21 : y ∈ s N := by auto [floor_divides_iff_rat, hα],
  let h22 : N > x := by auto [h20],
  let h23 : s N ∈ 𝓝[s x] 0.5 := by auto [h20],

  have h24 : {N • s N - s x} < √2,
  from by auto [floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  have h25 : {N • s N - s x} < √2,
  from by auto [floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  let h26 : {N • s N - s x} < √2 := by auto [h25],
  let h27 : {N • s N - s x} < √2 := by auto [h24],
  let h28 : {N • s N - s x} < √2 := by auto [h27],

  have h29 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [div_self, floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  have h30 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [div_self, floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  have h31 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [h29],

  have h32 : 2 • {N • s N - s x} < 2 * √2,
  from by auto [h30],
  let h33 : 2 • {N • s N - s x} < 2 * √2 := by auto [h32],

  have h34 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h25],

  have h35 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h24],
  let h36 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h35],

  have h37 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h34],
  let h38 : y < ((N • s N - s x) + (N • s N - s x)) := by auto [h37],

  have h39 : y < 2 • {N • s N - s x},
  from by auto [floor_divides_iff_rat, hα, h21, h23, mem_nhds_iff, sqrt_lt_iff],

  let h40 : y < 2 • {N • s N - s x} := by auto [h39],
  let h41 : ((y / 2) + s x : ℝ) < (N • s N : ℝ) := by auto [h40],
end --Needs more than 2000 tokens!

--OUTPUT 4
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h1 : ¬ is_rat α) : ∀ ε > 0, ∃ n, n ∈ ℤ ∧ abs(n * α - ⌊n * α⌋) < ε :=
begin
  assume ε,
  assume h2 : ε > 0,

  have h3 : α ≠ 0, from by auto [irrat],

  let S : set ℝ := {(⌊i * α⌋ - i * α) | i : ℤ},
  have h4 : ∀ (i j : ℤ), i ≠ j → (⌊i * α⌋ - i * α) ≠ (⌊j * α⌋ - j * α), from by auto [floor_eq_iff_rat, irrat],

  have h5 : ∀ (i j : ℤ), i ≠ j → i * α ≠ j * α, from by auto [irrat, mul_eq_zero, eq_zero_of_mul_eq_zero, h3],

  have h6 : ∀ (i j : ℤ), i ≠ j → i * α ∉ {j * α}, from by auto [h5],

  have h7 : ∀ (i j : ℤ), i ≠ j → i * α - ⌊i * α⌋ ∉ {j * α - ⌊j * α⌋}, from by auto [eq_iff_sub_eq_zero, h6],

  have h8 : ∀ (i j : ℤ), i ≠ j → (⌊i * α⌋ - i * α) ∉ {(⌊j * α⌋ - j * α)}, from by auto [h7],

  have h9 : ∀ (i j : ℤ), i ≠ j → (⌊i * α⌋ - i * α) ∉ S := by auto [S, h8],

  have h10 : ∀ a ∈ S, ∃ b ∈ S, abs(a - b) < ε, from by auto [sub_le_sub_left, h2],

  have h11 : ∃ b ∈ S, abs(0 - b) < ε, from by auto [irrat, h10, h4, h9, S],

  cases h11 with b h12,

  have h13 : ∀ n : ℤ, n * α - ⌊n * α⌋ ∈ S, from by auto [n_floor_eq_sub, S, exists.intro 0, mem_image, exists.intro 0, mem_range],
  have h14 : ∀ n : ℤ, n * α - ⌊n * α⌋ ∈ {(⌊i * α⌋ - i * α) | i : ℤ}, from by auto [S, h13],

  have h15 : ∀ n : ℤ, n * α - ⌊n * α⌋ ∈ {i * α - ⌊i * α⌋ | i : ℤ}, from by auto [S, h14],

  have h16 : ∃ n, n ∈ ℤ ∧ abs (n * α - ⌊n * α⌋) < ε,
  from by auto [h12, h15, exists.intro 1, exists.intro 0, exists.intro b, exists.intro 0, exists.intro 0],
  show ∃ n, n ∈ ℤ ∧ abs (n * α - ⌊n * α⌋) < ε, from by auto [h16],
end

--OUTPUT 5
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit (α : ℝ) : ∀ ε > 0, ∃ x : ℝ, x ∈ set.range (λ i, ↑i*α) ∧ x ∈ Icc (0 : ℝ) (1 : ℝ) ∧ ∃ n : ℕ, |x - n * α| < ε :=
begin
  assume ε,
  assume hε : ε > 0,

  have h3 : ∀ i j : ℕ, ((i : ℝ) * α - ↑i) ≠ ((j : ℝ) * α - ↑j), from by auto,

  -- choose a sequence of all the fractional parts from 0 to infinity, or all the A such that (∃ B : ℝ, A = B - ⌊B⌋)
  -- in other words, choose (A is an element of the powerset of ℝ, and there exists a B such that A = B - ⌊B⌋)
  have h4 : ∀ A ∈ 𝒫 ℝ, ∃ B : ℝ, A = B - ⌊B⌋, from by auto,

  have h6 : ∀ n : ℕ, ((n : ℚ) * α - ⌊(n : ℚ) * α⌋) ∈ set.range (λ B, B - ⌊B⌋), from by auto,

  have h7 : (∀ x, x ∈ set.range (λ B, B - ⌊B⌋) →  x ∈ Icc (0 : ℝ) (1 : ℝ)), from by auto [set.mem_range],

  have h8 : ∀ n : ℕ, ((n : ℝ) * α - ⌊(n : ℝ) * α⌋)  ∈ Icc (0 : ℝ) (1 : ℝ), from by auto [h6, h7],

  have h9 : ∀ B ∈ Icc (0 : ℝ) (1 : ℝ), ∃ n : ℕ, |((n : ℝ) * α - ⌊(n : ℝ) * α⌋) - B| < ε, from by auto,

  show (∃ (x : ℝ), x ∈ set.range (λ B, B - ⌊B⌋) ∧ x ∈ Icc (0 : ℝ) (1 : ℝ) ∧ ∃ (n : ℕ), |x - n * α| < ε) := by auto [h6, h8, h9],
end

--OUTPUT 6
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=irrational_orbit_dense (α : ℝ) : irrational α → ∀ e : ℝ, ∃ δ:ℝ, 0 < δ ∧ δ < e :=
begin
intros h,
assume e,
let x : ℝ := (1 + e/2) * (1/2),
have hx : 0 < x, from by auto [lt_mul_iff],
use x,

 show (0 < x) ∧ x < e, from by auto [add_one_le_iff, le_add_iff, sub_neg_iff, le_of_lt, lt_mul_iff] using [lt_add_iff, add_lt_add_right, one_lt_two, mul_self_lt_mul_self_iff, hx],
end

--OUTPUT 7
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=rational_orbit (α : ℝ) : irrational α → ∀ y ⊆ set.range (λ n : ℤ, n * α % 1), dense y :=
begin
  assume h1,
  assume y ⊆ set.range (λ n : ℤ, n * α % 1),
  have h2 : ∀ n m : ℤ, n ≠ m → (n*α % 1) ≠ (m*α % 1), from by auto [ring, mul_comm],
  have h3 : ∀ n m : ℤ, (n*α % 1) ≠ (m*α % 1), from by auto [h2] using [irrational_of_int_eq_zero, irrational_of_int_neq_zero, h1],
  let S : set ℝ := {m * α % 1 | m : ℤ},
  have h4 : y ⊆ S, from by auto [set.subset_def],
  have h5 : S ⊆ set.range (λ n : ℤ, n * α % 1), from by auto [set.subset_def],
  have h6 : finite y → y ≠ ∅ → nonempty y → nonempty y, from by auto [finite.ne_empty_iff_exists_mem, set.not_empty_iff_exists_mem, finite_subset, finite.coe_to_finset],
  have h8 : y ⊆ y, from by auto [set.subset.refl],
  have h9 : y.nonempty, from by auto [h4, h6, h5, set.nonempty_range],
  have h10 : dense S, from by auto [dense_iff_countable_open_dense_union, countable_iff_countably_infinite, range_is_countably_infinite, countable_iff_seq_range, set.seq_range_iff_forall_range, set.dense_Icc_iff_Ico_union_Ioc],
  have h11 : dense y, from by auto [h10, h4, set.dense_subset],
  show ∃ n : ℝ, n ∈ y ∧ ∀ ε > 0, ∃ m : ℝ, m ∈ y ∧ m ≠ n ∧ m ∈ Icc (n - ε) (n + ε), from by auto [h11, set.dense_iff_exists_between]
end

--OUTPUT 8
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit (α : ℝ) (h : ¬ is_rational α) : ∀ y ∈ set.Icc 0 1, ∃ x ∈ set.Icc 0 1, |y - x| ≤ 1 :=
begin
    assume (y : ℝ) (hy : y ∈ set.Icc 0 1),

    set S : set ℝ := {x : ℝ | ∃ i : ℤ, x = (x - floor x) ∧ x ∈ set.Icc 0 1},

    have h_empty : ∀ x : ℝ, x ∉ S, from by auto [not_lt_of_ge, lt_irrefl, (show 0 ≤ x - floor x, by linarith)],
    have h_not_empty : S ≠ ∅, from by auto [exists.intro (x - floor x) (and.intro (eq.refl x) (and.intro (by auto [floor_nonneg]) (by auto [not_lt_of_ge])))],
    have h_infinite : S.infinite, from by auto [h_not_empty, h_empty, infinite_Icc_iff, forall_exists_not],
    have h_bounded : S.bounded, from by auto [h_not_empty, bounded_Icc_iff, set.Icc_subset_Icc_left],
    have h_closed : S.closed, from by auto [set.Icc_closed],

    have h_Icc_0_1 : ∀ x : ℝ, x ∈ S ↔ x ∈ set.Icc 0 1, from by auto [set.Icc_subset_Icc_left],

    have h_dense : ∀ y : ℝ, y ∈ set.Icc 0 1 → ∃ x : ℝ, x ∈ S ∧ |y - x| ≤ 1, from by auto [dense_iff_inter_open, h_Icc_0_1, h_infinite, h_bounded, h_closed, h_not_empty],

    cases h_dense y hy with x hx,
    cases hx with hx_mem hx_pf,
    use x,
    from and.intro hx_mem hx_pf,
end

--OUTPUT 9
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_of_irrational_orbit {α : Type*} [s : dense_linear_order α] (a : α) : a ∉ (𝕀) → ∀ x, ∃ n ∈ ℤ, x - (1 : α) < (n : α) * a ∧ (n + 1) * a ≤ x :=
begin
  assume h1 : a ∉ (𝕀),
  assume x : α,

  have h2 : ∀ n m : ℤ, n ≠ m → n * a ≠ m * a,
  from by {intros n m h3, assume h4, have h5 := h3, rw h4 at h5, contradiction},

  have h6 : ∀ n m : ℤ,  n ≠ m → ∀ b : α, n * b ≠ m * b,
  from by auto [h2],

  have h7 : ∀ b : α, is_irrational b → ∀ n m : ℤ,  n ≠ m → n * b ≠ m * b, from by auto [h6],

  have h8 : n * a ≠ m * a, from by auto [h7],

  have h9 : ∀ n m : ℤ, n ≠ m → n * a ∈ set.range (λ n : ℤ, n * a),
  from by {intros n m h10, use [n], rw ←one_mul (n * a)},

  have h10 : ∀ n m : ℤ, n ≠ m → n * a ∉ set.range (λ n : ℤ, n * a),
  from by auto [h9],

  have h11 : set.range (λ n : ℤ, n * a) ≠ univ,
  from by auto [h10, h8, univ_def_eq],

  have h12 : set.range (λ n : ℤ, n * a) ≠ univ,
  from by auto [h10, h8, univ_def_eq],

  have h13 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h14 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h15 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h16 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

  have h17 : set.range (λ n : ℤ, n * a) ≠ set.univ,
  from by auto [h10, h8],

(*
  have h10 : ∅ ≠ set.range (λ n : ℤ, n * a),
  from by auto [h3, classical.not_forall, classical.not_not_elim, classical.not_not_intro, set.exists_mem_of_ne_empty,
  set.not_exists_mem_of_not_nonempty, set.not_exists_mem_of_not_nonempty],
*)
  have h11 : ∀ x, ∃ n ∈ ℤ, x - 1 < n * a ∧ (n + 1) * a ≤ x,
  from by auto [s.dense, set.range_iff, exists_nat],

  show ∃ (n : ℤ), n ∈ ℤ ∧ x - 1 < n * a ∧ (n + 1) * a ≤ x,
  from by auto [h11],
end

--OUTPUT 10
theorem irrational_orbit_dense {α : ℝ} (hα_irrat : irrational α) : closure ((λ m : ℤ, int.fract (α * ↑m)) '' (@set.univ ℤ)) = set.Icc 0 1 :=density_irration_orbit (α : ℝ) : ∀ (ε : ℝ), ε > 0 → ∃ i : ℤ, (∀ j : ℤ, |i*α - (j*α)%ℝ| < ε) :=
begin
  assume (ε : ℝ),
  assume (h1 : ε > 0),

  have h2 : ∀ (x : ℕ), (x*ε)≠0, from by auto [nat.pos_of_ne_zero],
  have h3 : ∀ (x y : ℤ), (x*ε)%ℝ ≠ (y*ε)%ℝ → x ≠ y, from by auto [@eq.subst int ℝ _ _ _ _ h2],

  let S : ℝ := {x | ∃ i : ℤ, x = (i*α)%ℝ},
  let SS := (λ (i : ℤ), (i*α)%ℝ),

  have h4 : S = ⋃ i : ℤ, {i}, from by auto [SS, eq_univ_of_forall],

  have h5 : ∀ i j : ℤ, i ≠ j → (i*α)%ℝ ≠ (j*α)%ℝ, from
  begin
    assume (i j : ℤ),
    assume (h5 : i ≠ j),
    assume (h6 : (i*α)%ℝ = (j*α)%ℝ),
    have h8 : ∃ N : ℕ, ∃ i : ℤ, α = N⁻¹ * (i : ℝ), from by auto [rational_iff],
    cases h8 with N h9,
    cases h9 with i h10,
    have h11 : ∃ j : ℤ, (i : ℝ) = N * (j : ℝ), from by auto [rat.denom_ne_zero, rat.exists_int_eq],
    cases h11 with j h12,
    have h13 : α = (j : ℝ), from by auto [h10, h12, eq_div_iff],
    have h14 : α ∈ ℚ, from by auto [h13],
    have h15 : α ∈ ℚ → false, from by auto [eq.subst h13],
    have h16 : false, from by auto [h15, h14],
    show false, from h16,
  end,

  have h6 : ∀ i j : ℤ, ((i*α)%ℝ ∈ S) ∧ ((j*α)%ℝ ∈ S) → i = j, from
  begin
    assume (i j : ℤ),
    assume (h6 : ((i*α)%ℝ ∈ S) ∧ ((j*α)%ℝ ∈ S)),
    have h7 : (i*α)%ℝ = (j*α)%ℝ → i = j, from h3 i j,
    show i = j, from by auto [h7, h6, h5],
  end,

  have h7 : ∀ i j : ℤ, ((i*α)%ℝ ∈ S) → ((j*α)%ℝ ∈ S) → i = j, from
  begin
    assume (i j : ℤ),
    assume (h7 : ((i*α)%ℝ ∈ S)),
    assume (h8 : ((j*α)%ℝ ∈ S)),
    have h9 : ((i*α)%ℝ ∈ S) ∧ ((j*α)%ℝ ∈ S), from by auto [h7, h8],
    show i = j, from by auto [h6, h9],
  end,

  have h8 : ∀ i j : ℤ, ((i*α)%ℝ ∈ S) ↔ i = j, from
  begin
    assume (i j : ℤ),
    split,
    {
      assume (h9 : ((i*α)%ℝ ∈ S)),
      show i = j, from by auto [h7, h9],
    },
    {
      assume (h10 : i = j),
      show (i*α)%ℝ ∈ S, from by auto [h10],
    },
  end,

  have h9 : S = ⋃ i : ℤ, {i}, from by auto [SS, eq_univ_of_forall],

  have h10 : ∀ i : ℤ, (i*α)%ℝ ∈ S, from by auto [rat.denom_ne_zero],

  have h11 : ∀ i : ℤ, ∃ x : ℝ, x ∈ {i} ∧ x ∈ S, from
  begin
    assume (i : ℤ),
    have h12 : (i*α)%ℝ ∈ S, from by auto [h10],
    have h13 : (i*α)%ℝ ∈ {i}, from by auto [h12],
    show ∃ x : ℝ, x ∈ {i} ∧ x ∈ S, from by auto [h13, h12],
  end,

  have h12 : ⋃ i : ℤ, {i} = ⋃ x : S, {x}, from by auto [h9, h8, h11, set.ext_iff],

  have h13 : ∃ (i : ℤ), ∀ (j : ℤ), (i*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from
  begin
    use 1,
    assume j,
    have h14 : (1*α)%ℝ = (j*α)%ℝ → 1 = j, from by auto [h3],
    have h15 : (1*α)%ℝ ∈ S, from by auto [rat.denom_ne_zero],
    have h16 : (1*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from by auto [h15],
    show (1*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from by auto [h16],
  end,

  have h14 : ∃ (i : ℤ), ∀ (j : ℤ), (i*α)%ℝ ∈ S, from
  begin
    have h15 : ∃ i : ℤ, ∀ j : ℤ, (i*α)%ℝ ∈ {x | ∃ i : ℤ, x = (i*α)%ℝ}, from by auto [h13],
    cases h15 with i h16,
    have h17 : ∀ j : ℤ, (i*α)%ℝ ∈ S, from by auto [h16],
    show ∃ (i : ℤ), ∀ j : ℤ, (i*α)%ℝ ∈ S, from by auto [h17],
  end,

  have h15 : ∃ (i : ℤ), (i*α)%ℝ ∈ S ∧ ∀ (j : ℤ), (j*α)%ℝ ∈ S → i = j, from
  begin
    have h16 : ∃ (i : ℤ), ∀ (j : ℤ), (i*α)%ℝ ∈ S, from by auto [h14],
    cases h16 with i h17,
    have h18 : ∀ (j : ℤ), (i*α)%ℝ ∈ S ∧ (j*α)%ℝ ∈ S → i = j, from
    begin
      assume j,
      have h19 : (i*α)%ℝ ∈ S ∧ (j*α)%ℝ ∈ S → ((i*α)%ℝ = (j*α)%ℝ →
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`
Squeeze Theorem for Real Numbers
Let $\sequence {x_n}$, $\sequence {y_n}$ and $\sequence {z_n}$ be sequences in $\R$.

Let $\sequence {y_n}$ and $\sequence {z_n}$ both be convergent to the following limit:
:$\ds \lim_{n \mathop \to \infty} y_n = l, \lim_{n \mathop \to \infty} z_n = l$

Suppose that:
:$\forall n \in \N: y_n \le x_n \le z_n$

Then:
:$x_n \to l$ as $n \to \infty$
that is:
:$\ds \lim_{n \mathop \to \infty} x_n = l$

`proof`
From Negative of Absolute Value:
:$\size {x - l} < \epsilon \iff l - \epsilon < x < l + \epsilon$

Let $\epsilon > 0$.

We need to prove that:
:$\exists N: \forall n > N: \size {x_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} y_n = l$ we know that:
:$\exists N_1: \forall n > N_1: \size {y_n - l} < \epsilon$

As $\ds \lim_{n \mathop \to \infty} z_n = l$ we know that:
:$\exists N_2: \forall n > N_2: \size {z_n - l} < \epsilon$

Let $N = \max \set {N_1, N_2}$.

Then if $n > N$, it follows that $n > N_1$ and $n > N_2$.

So:
:$\forall n > N: l - \epsilon < y_n < l + \epsilon$
:$\forall n > N: l - \epsilon < z_n < l + \epsilon$

But:
:$\forall n \in \N: y_n \le x_n \le z_n$

So:
:$\forall n > N: l - \epsilon < y_n \le x_n \le z_n < l + \epsilon$

and so:
:$\forall n > N: l - \epsilon < x_n < l + \epsilon$

So:
:$\forall n > N: \size {x_n - l} < \epsilon$

Hence the result.
{{qed}}

-/
theorem squeeze_theorem_real_numbers (x y z : ℕ → ℝ) (l : ℝ) :
let seq_limit : (ℕ → ℝ) → ℝ → Prop :=  λ (u : ℕ → ℝ) (l : ℝ), ∀ ε > 0, ∃ N, ∀ n > N, |u n - l| < ε in
 seq_limit y l → seq_limit z l →  (∀ n : ℕ, (y n) ≤ (x n) ∧ (x n) ≤ (z n)) → seq_limit x l :=
begin
  assume seq_limit (h2 : seq_limit y l) (h3 : seq_limit z l) (h4 : ∀ (n : ℕ), y n ≤ x n ∧ x n ≤ z n) (ε),

  have h5 : ∀ x, |x - l| < ε ↔ (((l - ε) < x) ∧ (x < (l + ε))),
  from by auto [abs_sub_lt_iff] using [linarith],

  assume (h7 : ε > 0),

  cases h2 ε h7 with N1 h8,
  cases h3 ε h7 with N2 h9,
  let N := max N1 N2,
  use N,

  have h10 : ∀ n > N, n > N1 ∧ n > N2 := by auto [lt_of_le_of_lt, le_max_left, le_max_right],

  have h11 : ∀ n > N, (((l - ε) < (y n)) ∧ ((y n) ≤ (x n))) ∧ (((x n) ≤ (z n)) ∧ ((z n) < l+ε)),
  from by auto [h8, h10, h5, h9],

  have h15 : ∀ n > N, ((l - ε) < (x n)) ∧ ((x n) < (l+ε)),
  from by auto [h11] using [linarith],

  show  ∀ (n : ℕ), n > N → |x n - l| < ε,
  from by auto [h5, h15],

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
FEW SHOT PROMPTS TO CODEX(END)-/


example : α → α := by
                  --^ $/lean/plainGoal
                   --^ $/lean/plainGoal
  intro a
--^ $/lean/plainGoal
 --^ $/lean/plainGoal
 --v $/lean/plainGoal
  focus
    apply a

example : α → α := by
                  --^ $/lean/plainGoal

example : 0 + n = n := by
  induction n with
  | zero => simp; simp
       --^ $/lean/plainGoal
  | succ
   --^ $/lean/plainGoal

example : α → α := by
  intro a; apply a
       --^ $/lean/plainGoal

example (h1 : n = m) (h2 : m = 0) : 0 = n := by
  rw [h1, h2]
 --^ $/lean/plainGoal
       --^ $/lean/plainGoal
           --^ $/lean/plainGoal

example : 0 + n = n := by
  induction n
  focus
 --^ $/lean/plainGoal
    rfl
-- TODO: goal state after dedent

example : 0 + n = n := by
  induction n with
 --^ $/lean/plainGoal

example : 0 + n = n := by
  cases n with
 --^ $/lean/plainGoal

example : ∀ a b : Nat, a = b := by
  intro a b
 --^ $/lean/plainGoal

example : α → α := (by
                  --^ $/lean/plainGoal

example (p : α → Prop) (a b : α) [DecidablePred p] (h : ∀ {p} [DecidablePred p], p a → p b) : p b := by
  apply h _
 --^ $/lean/plainGoal
 -- should not display solved goal `⊢ DecidablePred p`

example : True ∧ False := by
  constructor
  { constructor }
 --^ $/lean/plainGoal
  { }
 --^ $/lean/plainGoal

example : True ∧ False := by
  constructor
  · constructor
 --^ $/lean/plainGoal
  ·
 --^ $/lean/plainGoal


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

! This file was ported from Lean 3 source module order.category.HeytAlg
! leanprover-community/mathlib commit e8ac6315bcfcbaf2d19a046719c3b553206dac75
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.Category.BddDistLat
import Mathbin.Order.Heyting.Hom

/-!
# The category of Heyting algebras

This file defines `HeytAlg`, the category of Heyting algebras.
-/

universe u

open CategoryTheory Opposite Order

/-- The category of Heyting algebras. -/
def HeytAlg :=
  Bundled HeytingAlgebra
#align HeytAlg HeytAlg

namespace HeytAlg

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

instance (X : HeytAlg) : HeytingAlgebra X :=
  X.str

/-- Construct a bundled `HeytAlg` from a `heyting_algebra`. -/
def of (α : Type _) [HeytingAlgebra α] : HeytAlg :=
  Bundled.of α
#align HeytAlg.of HeytAlg.of

@[simp]
theorem coe_of (α : Type _) [HeytingAlgebra α] : ↥(of α) = α :=
  rfl
#align HeytAlg.coe_of HeytAlg.coe_of

instance : Inhabited HeytAlg :=
  ⟨of PUnit⟩

instance bundledHom : BundledHom HeytingHom
    where
  toFun α β [HeytingAlgebra α] [HeytingAlgebra β] := (coeFn : HeytingHom α β → α → β)
  id := HeytingHom.id
  comp := @HeytingHom.comp
  hom_ext α β [HeytingAlgebra α] [HeytingAlgebra β] := FunLike.coe_injective
#align HeytAlg.bundled_hom HeytAlg.bundledHom

deriving instance LargeCategory, ConcreteCategory for HeytAlg

@[simps]
instance hasForgetToLat : HasForget₂ HeytAlg BddDistLat
    where forget₂ :=
    { obj := fun X => BddDistLat.of X
      map := fun X Y f => (f : BoundedLatticeHom X Y) }
#align HeytAlg.has_forget_to_Lat HeytAlg.hasForgetToLat

/-- Constructs an isomorphism of Heyting algebras from an order isomorphism between them. -/
@[simps]
def Iso.mk {α β : HeytAlg.{u}} (e : α ≃o β) : α ≅ β
    where
  Hom := e
  inv := e.symm
  hom_inv_id' := by
    ext
    exact e.symm_apply_apply _
  inv_hom_id' := by
    ext
    exact e.apply_symm_apply _
#align HeytAlg.iso.mk HeytAlg.Iso.mk

end HeytAlg


import .commun
import .tokens

namespace tactic
setup_tactic_parser

meta def Fait_parser : lean.parser (name × pexpr × option pexpr) :=
with_desc "... : ... (par ... (appliqué à ...))" $
do n ← ident <* tk ":",
   enonce ← texpr,
   do { dem ← tk "par" *> texpr,
        args ← applique_a_parser,
        pure (n, enonce, some (pexpr_mk_app dem args)) } <|>
   pure (n, enonce, none)

/--
Annonce un énoncé intermédiaire (et le démontre immédiatement si « par » est utilisé).
-/
@[interactive]
meta def tactic.interactive.Fait : parse Fait_parser → tactic unit
| (n, enonce, some prf) := do verifie_nom n,
                              eenonce ← i_to_expr enonce,
                              assert n eenonce,
                              conclure prf []

| (n, enonce, none) := do verifie_nom n,
                          i_to_expr enonce >>= tactic.assert n,
                          skip

end tactic

example (n : ℕ) : n + n + n = 3*n :=
begin
  Fait clef : n + n = 2*n,
  by ring,
  ring,
end

example (n : ℤ) (h : 0 < n) : true :=
begin
  Fait clef : 0 < 2*n par h,
  success_if_fail { Fait clef : 0 < 2*n par h },
  Fait clefbis : 0 < 2*n par mul_pos appliqué à [zero_lt_two, h],
  trivial
end

example (n : ℕ) (h : 0 < n) : 0 < 2*n :=
begin
  Fait clef : 0 < 2*n par h,
  exact clef
end


import algebra.homology.exact
import for_mathlib.abelian_category
import for_mathlib.exact_seq2
.

noncomputable theory

open category_theory category_theory.limits
open opposite

-- move me
namespace category_theory

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]

lemma exact_seq.is_iso_of_zero_of_zero {A B C D : 𝓐} {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}
  {L : list (arrow 𝓐)} (H : exact_seq 𝓐 (f :: g :: h :: L)) (hf : f = 0) (hh : h = 0) :
  is_iso g :=
begin
  subst f, subst h,
  have : mono g, { rw [H.pair.mono_iff_eq_zero], },
  haveI : epi g, { rw [(H.drop 1).pair.epi_iff_eq_zero] },
  exact is_iso_of_mono_of_epi g,
end

lemma exact.homology_is_zero {X Y Z : 𝓐} (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : exact f g) :
  is_zero (homology f g hfg.w) :=
begin
  rw preadditive.exact_iff_homology_zero at hfg,
  rcases hfg with ⟨w, ⟨e⟩⟩,
  exact is_zero_of_iso_of_zero (is_zero_zero _) e.symm,
end

lemma exact_of_homology_is_zero {X Y Z : 𝓐} {f : X ⟶ Y} {g : Y ⟶ Z} {w : f ≫ g = 0}
  (H : is_zero (homology f g w)) :
  exact f g :=
begin
  rw preadditive.exact_iff_homology_zero,
  refine ⟨w, ⟨_⟩⟩,
  exact H.iso_zero
end

namespace limits
namespace is_zero

lemma exact {X Y Z : 𝓐} (hY : is_zero Y)
  (f : X ⟶ Y) (g : Y ⟶ Z) : exact f g :=
by simp only [abelian.exact_iff, hY.eq_of_tgt f 0, hY.eq_of_tgt (limits.kernel.ι g) 0,
    limits.zero_comp, eq_self_iff_true, and_true]

lemma homology_is_zero {X Y Z : 𝓐} (hY : is_zero Y)
  (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  is_zero (homology f g w) :=
exact.homology_is_zero f g $ hY.exact f g

lemma is_iso {X Y : 𝓐} (hX : is_zero X) (hY : is_zero Y) (f : X ⟶ Y) :
  is_iso f :=
{ out := ⟨0, hX.eq_of_src _ _, hY.eq_of_tgt _ _⟩ }

lemma op {X : 𝓐} (h : is_zero X) : is_zero (op X) :=
begin
  rw [is_zero_iff_id_eq_zero] at h ⊢,
  rw [← op_id, h, op_zero]
end

lemma unop {X : 𝓐ᵒᵖ} (h : is_zero X) : is_zero (unop X) :=
begin
  rw [is_zero_iff_id_eq_zero] at h ⊢,
  rw [← unop_id, h, unop_zero]
end

end is_zero

@[simp] lemma is_zero_op {X : 𝓐} : is_zero (op X) ↔ is_zero X := ⟨is_zero.unop, is_zero.op⟩
@[simp] lemma is_zero_unop {X : 𝓐ᵒᵖ} : is_zero (unop X) ↔ is_zero X := ⟨is_zero.op, is_zero.unop⟩

end limits

end category_theory


/-
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.antisymmetrization
import order.category.Preorder

/-!
# Category of partial orders

This defines `PartialOrder`, the category of partial orders with monotone maps.
-/

open category_theory

universe u

/-- The category of partially ordered types. -/
def PartialOrder := bundled partial_order

namespace PartialOrder

instance : bundled_hom.parent_projection @partial_order.to_preorder := ⟨⟩

attribute [derive [large_category, concrete_category]] PartialOrder

instance : has_coe_to_sort PartialOrder Type* := bundled.has_coe_to_sort

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

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

instance : inhabited PartialOrder := ⟨of punit⟩

instance (α : PartialOrder) : partial_order α := α.str

instance has_forget_to_Preorder : has_forget₂ PartialOrder Preorder := bundled_hom.forget₂ _ _

/-- Constructs an equivalence between partial orders from an order isomorphism between them. -/
@[simps] def iso.mk {α β : PartialOrder.{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 : PartialOrder ⥤ PartialOrder :=
{ obj := λ X, of (order_dual X), map := λ X Y, order_hom.dual }

/-- The equivalence between `PartialOrder` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : PartialOrder ≌ PartialOrder :=
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 PartialOrder

lemma PartialOrder_dual_comp_forget_to_Preorder :
  PartialOrder.dual ⋙ forget₂ PartialOrder Preorder =
    forget₂ PartialOrder Preorder ⋙ Preorder.dual := rfl

/-- `antisymmetrization` as a functor. It is the free functor. -/
def Preorder_to_PartialOrder : Preorder.{u} ⥤ PartialOrder :=
{ obj := λ X, PartialOrder.of (antisymmetrization X (≤)),
  map := λ X Y f, f.antisymmetrization,
  map_id' := λ X,
    by { ext, exact quotient.induction_on' x (λ x, quotient.map'_mk' _ (λ a b, id) _) },
  map_comp' := λ X Y Z f g,
    by { ext, exact quotient.induction_on' x (λ x, order_hom.antisymmetrization_apply_mk _ _) } }

/-- `Preorder_to_PartialOrder` is left adjoint to the forgetful functor, meaning it is the free
functor from `Preorder` to `PartialOrder`. -/
def Preorder_to_PartialOrder_forget_adjunction :
  Preorder_to_PartialOrder.{u} ⊣ forget₂ PartialOrder Preorder :=
adjunction.mk_of_hom_equiv
  { hom_equiv := λ X Y, { to_fun := λ f,
      ⟨f ∘ to_antisymmetrization (≤), f.mono.comp to_antisymmetrization_mono⟩,
    inv_fun := λ f, ⟨λ a, quotient.lift_on' a f $ λ a b h, (antisymm_rel.image h f.mono).eq, λ a b,
      quotient.induction_on₂' a b $ λ a b h, f.mono h⟩,
    left_inv := λ f, order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl,
    right_inv := λ f, order_hom.ext _ _ $ funext $ λ x, rfl },
  hom_equiv_naturality_left_symm' := λ X Y Z f g,
    order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl,
  hom_equiv_naturality_right' := λ X Y Z f g, order_hom.ext _ _ $ funext $ λ x, rfl }

/-- `Preorder_to_PartialOrder` and `order_dual` commute. -/
@[simps] def Preorder_to_PartialOrder_comp_to_dual_iso_to_dual_comp_Preorder_to_PartialOrder :
 (Preorder_to_PartialOrder.{u} ⋙ PartialOrder.dual) ≅
    (Preorder.dual ⋙ Preorder_to_PartialOrder) :=
nat_iso.of_components (λ X, PartialOrder.iso.mk $ order_iso.dual_antisymmetrization _) $
  λ X Y f, order_hom.ext _ _ $ funext $ λ x, quotient.induction_on' x $ λ x, rfl


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.homology

/-!
# Chain complexes supported in a single degree

We define `single V j c : V ⥤ homological_complex V c`,
which constructs complexes in `V` of shape `c`, supported in degree `j`.

Similarly `single₀ V : V ⥤ chain_complex V ℕ` is the special case for
`ℕ`-indexed chain complexes, with the object supported in degree `0`,
but with better definitional properties.

In `to_single₀_equiv` we characterize chain maps to a `ℕ`-indexed complex concentrated in degree 0;
they are equivalent to `{ f : C.X 0 ⟶ X // C.d 1 0 ≫ f = 0 }`.
(This is useful translating between a projective resolution and
an augmented exact complex of projectives.)
-/

open category_theory
open category_theory.limits

universes v u

variables (V : Type u) [category.{v} V] [has_zero_morphisms V] [has_zero_object V]

namespace homological_complex
variables {ι : Type*} [decidable_eq ι] (c : complex_shape ι)

local attribute [instance] has_zero_object.has_zero

/--
The functor `V ⥤ homological_complex V c` creating a chain complex supported in a single degree.

See also `chain_complex.single₀ : V ⥤ chain_complex V ℕ`,
which has better definitional properties,
if you are working with `ℕ`-indexed complexes.
-/
@[simps]
def single (j : ι) : V ⥤ homological_complex V c :=
{ obj := λ A,
  { X := λ i, if i = j then A else 0,
    d := λ i j, 0, },
  map := λ A B f,
  { f := λ i, if h : i = j then
      eq_to_hom (by { dsimp, rw if_pos h, }) ≫ f ≫ eq_to_hom (by { dsimp, rw if_pos h, })
    else
      0, },
  map_id' := λ A, begin
    ext,
    dsimp,
    split_ifs with h,
    { subst h, simp, },
    { rw if_neg h, simp, },
  end,
  map_comp' := λ A B C f g, begin
    ext,
    dsimp,
    split_ifs with h,
    { subst h, simp, },
    { simp, },
  end, }.

/--
The object in degree `j` of `(single V c h).obj A` is just `A`.
-/
@[simps]
def single_obj_X_self (j : ι) (A : V) : ((single V c j).obj A).X j ≅ A :=
eq_to_iso (by simp)

@[simp]
lemma single_map_f_self (j : ι) {A B : V} (f : A ⟶ B) :
  ((single V c j).map f).f j =
    (single_obj_X_self V c j A).hom ≫ f ≫ (single_obj_X_self V c j B).inv :=
by { simp, refl, }

instance (j : ι) : faithful (single V c j) :=
{ map_injective' := λ X Y f g w, begin
    have := congr_hom w j,
    dsimp at this,
    simp only [dif_pos] at this,
    rw [←is_iso.inv_comp_eq, inv_eq_to_hom, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp,
      ←is_iso.comp_inv_eq, category.assoc, inv_eq_to_hom, eq_to_hom_trans, eq_to_hom_refl,
      category.comp_id] at this,
    exact this,
  end, }

instance (j : ι) : full (single V c j) :=
{ preimage := λ X Y f, eq_to_hom (by simp) ≫ f.f j ≫ eq_to_hom (by simp),
  witness' := λ X Y f, begin
    ext i,
    dsimp,
    split_ifs,
    { subst h, simp, },
    { symmetry,
      apply zero_of_target_iso_zero,
      dsimp,
      rw [if_neg h], },
  end }

end homological_complex

open homological_complex

namespace chain_complex

local attribute [instance] has_zero_object.has_zero

/--
`chain_complex.single₀ V` is the embedding of `V` into `chain_complex V ℕ`
as chain complexes supported in degree 0.

This is naturally isomorphic to `single V _ 0`, but has better definitional properties.
-/
def single₀ : V ⥤ chain_complex V ℕ :=
{ obj := λ X,
  { X := λ n, match n with
    | 0 := X
    | (n+1) := 0
    end,
    d := λ i j, 0, },
  map := λ X Y f,
  { f := λ n, match n with
    | 0 := f
    | (n+1) := 0
    end, },
  map_id' := λ X, by { ext n, cases n, refl, dsimp, unfold_aux, simp, },
  map_comp' := λ X Y Z f g, by { ext n, cases n, refl, dsimp, unfold_aux, simp, } }

@[simp] lemma single₀_obj_X_0 (X : V) : ((single₀ V).obj X).X 0 = X := rfl
@[simp] lemma single₀_obj_X_succ (X : V) (n : ℕ) : ((single₀ V).obj X).X (n+1) = 0 := rfl
@[simp] lemma single₀_obj_X_d (X : V) (i j : ℕ) : ((single₀ V).obj X).d i j = 0 := rfl
@[simp]

section
variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Sending objects to chain complexes supported at `0` then taking `0`-th homology
is the same as doing nothing.
-/
noncomputable
def homology_functor_0_single₀ : single₀ V ⋙ homology_functor V _ 0 ≅ (𝟭 V) :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by { ext, dsimp [homology_functor], simp, })

/--
Sending objects to chain complexes supported at `0` then taking `(n+1)`-st homology
is the same as the zero functor.
-/
noncomputable
def homology_functor_succ_single₀ (n : ℕ) : single₀ V ⋙ homology_functor V _ (n+1) ≅ 0 :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by ext)

end

variables {V}

/--
Morphisms from a `ℕ`-indexed chain complex `C`
to a single object chain complex with `X` concentrated in degree 0
are the same as morphisms `f : C.X 0 ⟶ X` such that `C.d 1 0 ≫ f = 0`.
-/
def to_single₀_equiv (C : chain_complex V ℕ) (X : V) :
  (C ⟶ (single₀ V).obj X) ≃ { f : C.X 0 ⟶ X // C.d 1 0 ≫ f = 0 } :=
{ to_fun := λ f, ⟨f.f 0, by { rw ←f.comm 1 0, simp, }⟩,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f.1
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      rcases i with _|_|i; cases j; unfold_aux; simp only [comp_zero, zero_comp, single₀_obj_X_d],
      { rw [C.shape, zero_comp], simp, },
      { exact f.2.symm, },
      { rw [C.shape, zero_comp], simp [i.succ_succ_ne_one.symm] },
    end, },
  left_inv := λ f, begin
    ext i,
    rcases i,
    { refl, },
    { ext, },
  end,
  right_inv := by tidy, }

variables (V)

/-- `single₀` is the same as `single V _ 0`. -/
def single₀_iso_single : single₀ V ≅ single V _ 0 :=
nat_iso.of_components
  (λ X,
  { hom := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    inv := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    hom_inv_id' := by { ext (_|i); { dsimp, simp, }, },
    inv_hom_id' := begin
      ext (_|i),
      { apply category.id_comp, },
      { apply has_zero_object.to_zero_ext, },
    end, })
  (λ X Y f, by { ext (_|i); { dsimp, simp, }, })

instance : faithful (single₀ V) := faithful.of_iso (single₀_iso_single V).symm
instance : full (single₀ V) := full.of_iso (single₀_iso_single V).symm

end chain_complex

namespace cochain_complex

local attribute [instance] has_zero_object.has_zero

/--
`cochain_complex.single₀ V` is the embedding of `V` into `cochain_complex V ℕ`
as cochain complexes supported in degree 0.

This is naturally isomorphic to `single V _ 0`, but has better definitional properties.
-/
def single₀ : V ⥤ cochain_complex V ℕ :=
{ obj := λ X,
  { X := λ n, match n with
    | 0 := X
    | (n+1) := 0
    end,
    d := λ i j, 0, },
  map := λ X Y f,
  { f := λ n, match n with
    | 0 := f
    | (n+1) := 0
    end, },
  map_id' := λ X, by { ext n, cases n, refl, dsimp, unfold_aux, simp, },
  map_comp' := λ X Y Z f g, by { ext n, cases n, refl, dsimp, unfold_aux, simp, } }

@[simp] lemma single₀_obj_X_0 (X : V) : ((single₀ V).obj X).X 0 = X := rfl
@[simp] lemma single₀_obj_X_succ (X : V) (n : ℕ) : ((single₀ V).obj X).X (n+1) = 0 := rfl
@[simp] lemma single₀_obj_X_d (X : V) (i j : ℕ) : ((single₀ V).obj X).d i j = 0 := rfl
@[simp] lemma single₀_obj_X_d_from (X : V) (j : ℕ) : ((single₀ V).obj X).d_from j = 0 :=
by { rw [d_from_eq ((single₀ V).obj X) rfl], simp, }
@[simp] lemma single₀_obj_X_d_to (X : V) (i : ℕ) : ((single₀ V).obj X).d_to i = 0 :=
begin
  cases i,
  { rw [d_to_eq_zero], simp, },
  { rw [d_to_eq ((single₀ V).obj X) rfl], simp, },
end
@[simp] lemma single₀_map_f_0 {X Y : V} (f : X ⟶ Y) : ((single₀ V).map f).f 0 = f := rfl
@[simp] lemma single₀_map_f_succ {X Y : V} (f : X ⟶ Y) (n : ℕ) :
  ((single₀ V).map f).f (n+1) = 0 := rfl

section
variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Sending objects to cochain complexes supported at `0` then taking `0`-th homology
is the same as doing nothing.
-/
noncomputable
def homology_functor_0_single₀ : single₀ V ⋙ homology_functor V _ 0 ≅ (𝟭 V) :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by { ext, dsimp [homology_functor], simp, })

/--
Sending objects to cochain complexes supported at `0` then taking `(n+1)`-st homology
is the same as the zero functor.
-/
noncomputable
def homology_functor_succ_single₀ (n : ℕ) : single₀ V ⋙ homology_functor V _ (n+1) ≅ 0 :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by ext)

end

variables {V}

/--
Morphisms from a single object cochain complex with `X` concentrated in degree 0
to a `ℕ`-indexed cochain complex `C`
are the same as morphisms `f : X ⟶ C.X 0` such that `f ≫ C.d 0 1 = 0`.
-/
def from_single₀_equiv (C : cochain_complex V ℕ) (X : V) :
  ((single₀ V).obj X ⟶ C) ≃ { f : X ⟶ C.X 0 // f ≫ C.d 0 1 = 0 } :=
{ to_fun := λ f, ⟨f.f 0, by { rw f.comm 0 1, simp, }⟩,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f.1
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      rcases j with _|_|j; cases i; unfold_aux; simp only [comp_zero, zero_comp, single₀_obj_X_d],
      { convert comp_zero, rw [C.shape], simp, },
      { exact f.2, },
      { convert comp_zero, rw [C.shape], simp only [complex_shape.up_rel, zero_add],
        exact (nat.one_lt_succ_succ j).ne },
    end, },
  left_inv := λ f, begin
    ext i,
    rcases i,
    { refl, },
    { ext, },
  end,
  right_inv := by tidy, }

variables (V)

/-- `single₀` is the same as `single V _ 0`. -/
def single₀_iso_single : single₀ V ≅ single V _ 0 :=
nat_iso.of_components
  (λ X,
  { hom := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    inv := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    hom_inv_id' := by { ext (_|i); { dsimp, simp, }, },
    inv_hom_id' := begin
      ext (_|i),
      { apply category.id_comp, },
      { apply has_zero_object.to_zero_ext, },
    end, })
  (λ X Y f, by { ext (_|i); { dsimp, simp, }, })

instance : faithful (single₀ V) := faithful.of_iso (single₀_iso_single V).symm
instance : full (single₀ V) := full.of_iso (single₀_iso_single V).symm

end cochain_complex


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Group
import category_theory.limits.shapes.kernels

noncomputable theory

open category_theory
open category_theory.limits

/-!
Some small examples of using limits and colimits in `Ab`, the category of additive commutative
groups.
-/

example (G H : Ab) (f : G ⟶ H) : Ab := kernel f
example (G H : Ab) (f : G ⟶ H) [epi f] : kernel (cokernel.π f) ≅ H :=
as_iso (kernel.ι (cokernel.π f))

-- TODO no images yet...


/-
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, David Renshaw
-/
import Lean
import Mathlib.Lean.Meta
import Mathlib.Tactic.LeftRight

/-!
# mk_iff_of_inductive_prop

This file defines a tactic `tactic.mk_iff_of_inductive_prop` that generates `iff` rules for
inductive `Prop`s. For example, when applied to `List.Chain`, it creates a declaration with
the following type:

```lean
∀ {α : Type _} (R : α → α → Prop) (a : α) (l : List α),
  Chain R a l ↔ l = [] ∨ ∃(b : α) (l' : List α), R a b ∧ Chain R b l ∧ l = b :: l'
```

This tactic can be called using either the `mk_iff_of_inductive_prop` user command or
the `mk_iff` attribute.
-/

namespace Mathlib.Tactic.MkIff

open Lean Meta Elab

/-- `select m n` runs `tactic.right` `m` times, and then `tactic.left` `(n-m)` times.
Fails if `n < m`. -/
private def select (m n : Nat) (goal : MVarId) : MetaM MVarId :=
  match m,n with
  | 0, 0             => pure goal
  | 0, (_ + 1)       => do let [new_goal] ← Mathlib.Tactic.LeftRight.leftRightMeta `left 0 2 goal
                                | throwError "expected only one new goal"
                           pure new_goal
  | (m + 1), (n + 1) => do let [new_goal] ← Mathlib.Tactic.LeftRight.leftRightMeta `right 1 2 goal
                                | throwError "expected only one new goal"
                           select m n new_goal
  | _, _             => failure

/-- `compactRelation bs as_ps`: Produce a relation of the form:
```lean
R := λ as ∃ bs, Λ_i a_i = p_i[bs]
```
This relation is user-visible, so we compact it by removing each `b_j` where a `p_i = b_j`, and
hence `a_i = b_j`. We need to take care when there are `p_i` and `p_j` with `p_i = p_j = b_k`.
-/
partial def compactRelation :
  List Expr → List (Expr × Expr) → List (Option Expr) × List (Expr × Expr) × (Expr → Expr)
| [],    as_ps => ([], as_ps, id)
| b::bs, as_ps =>
  match as_ps.span (λ⟨_,p⟩ => ¬ p == b) with
    | (_, []) => -- found nothing in ps equal to b
        let (bs, as_ps', subst) := compactRelation bs as_ps
        (b::bs, as_ps', subst)
    | (ps₁, (a, _) :: ps₂) => -- found one that matches b. Remove it.
      let i := fun e ↦ e.replaceFVar b a
      let (bs, as_ps', subst) := compactRelation (bs.map i) ((ps₁ ++ ps₂).map (λ⟨a, p⟩ => (a, i p)))
      (none :: bs, as_ps', i ∘ subst)

/-- Generates an expression of the form `∃(args), inner`. `args` is assumed to be a list of fvars.
When possible, `p ∧ q` is used instead of `∃(_ : p), q`. -/
def mkExistsList (args : List Expr) (inner : Expr) : MetaM Expr :=
args.foldrM (λarg i:Expr => do
    let t ← inferType arg
    let l := (← inferType t).sortLevel!
    pure $ if arg.occurs i || l != Level.zero
      then mkApp2 (mkConst `Exists [l] : Expr) t (←(mkLambdaFVars #[arg] i))
      else mkApp2 (mkConst `And [] : Expr) t i)
  inner

/-- `mkOpList op empty [x1, x2, ...]` is defined as `op x1 (op x2 ...)`.
  Returns `empty` if the list is empty. -/
def mkOpList (op : Expr) (empty : Expr) : List Expr → Expr
| []        => empty
| [e]       => e
| (e :: es) => mkApp2 op e $ mkOpList op empty es

/-- `mkAndList [x1, x2, ...]` is defined as `x1 ∧ (x2 ∧ ...)`, or `True` if the list is empty. -/
def mkAndList : List Expr → Expr := mkOpList (mkConst `And) (mkConst `True)

/-- `mkOrList [x1, x2, ...]` is defined as `x1 ∨ (x2 ∨ ...)`, or `False` if the list is empty. -/
def mkOrList : List Expr → Expr := mkOpList (mkConst `Or) (mkConst `False)

/-- Drops the final element of a list. -/
def List.init : List α → List α
| []     => []
| [_]    => []
| a::l => a::init l

/-- Auxiliary data associated with a single constructor of an inductive declaration.
-/
structure Shape : Type where
  /-- For each forall-bound variable in the type of the constructor, minus
  the "params" that apply to the entire inductive type, this list contains `true`
  if that variable has been kept after `compactRelation`.

  For example, `List.Chain.nil` has type
  ```lean
    ∀ {α : Type u_1} {R : α → α → Prop} {a : α}, List.Chain R a []`
  ```
  and the first two variables `α` and `R` are "params", while the `a : α` gets
  eliminated in a `compactRelation`, so `variablesKept = [false].

  `List.Chain.cons` has type
  ```lean
    ∀ {α : Type u_1} {R : α → α → Prop} {a b : α} {l : List α},
       R a b → List.Chain R b l → List.Chain R a (b :: l)
  ```
  and the `a : α` gets eliminated, so `compactRelation = [false,true,true,true,true]`.
   -/
  variablesKept : List Bool

  /-- The number of equalities, or `none` in the case when we've reduced something
  of the form `p ∧ True` to just `p`.
  -/
  neqs : Option Nat

/-- Converts an inductive constructor `c` into a `Shape` that will be used later in
while proving the iff theorem, and a proposition representing the constructor.
-/
def constrToProp (univs : List Level) (params : List Expr) (idxs : List Expr) (c : Name) :
  MetaM (Shape × Expr)  :=
do let type := (← getConstInfo c).instantiateTypeLevelParams univs
   let type' ← Meta.forallBoundedTelescope type (params.length) fun fvars ty ↦ do
     pure $ ty.replaceFVars fvars params.toArray

   Meta.forallTelescope type' fun fvars ty ↦ do
     let idxs_inst := ty.getAppArgs.toList.drop params.length
     let (bs, eqs, subst) := compactRelation fvars.toList (idxs.zip idxs_inst)
     let eqs ← eqs.mapM (λ⟨idx, inst⟩ => do
          let ty ← idx.fvarId!.getType
          let instTy ← inferType inst
          let u := (←inferType ty).sortLevel!
          if ←isDefEq ty instTy
          then pure (mkApp3 (mkConst `Eq [u]) ty idx inst)
          else pure (mkApp4 (mkConst `HEq [u]) ty idx instTy inst))
     let (n, r) ← match bs.filterMap id, eqs with
     | [], [] => do
           pure (some 0, (mkConst `True))
     | bs', []  => do
          let t : Expr ← bs'.getLast!.fvarId!.getType
          let l := (←inferType t).sortLevel!
          if l == Level.zero then do
            let r ← mkExistsList (List.init bs') t
            pure (none, subst r)
          else do
            let r ← mkExistsList bs' (mkConst `True)
            pure (some 0, subst r)
     | bs', _ => do
       let r ← mkExistsList bs' (mkAndList eqs)
       pure (some eqs.length, subst r)
     pure (⟨bs.map Option.isSome, n⟩, r)

/-- Splits the goal `n` times via `refine ⟨?_,?_⟩`, and then applies `constructor` to
close the resulting subgoals.
-/
def splitThenConstructor (mvar : MVarId) (n : Nat) : MetaM Unit :=
match n with
| 0   => do
  let (subgoals',_) ← Term.TermElabM.run $ Tactic.run mvar do
    Tactic.evalTactic (←`(tactic| constructor))
  let [] := subgoals' | throwError "expected no subgoals"
  pure ()
| n  + 1 => do
  let (subgoals,_) ← Term.TermElabM.run $ Tactic.run mvar do
    Tactic.evalTactic (←`(tactic| refine ⟨?_,?_⟩))
  let [sg1, sg2] := subgoals | throwError "expected two subgoals"
  let (subgoals',_) ← Term.TermElabM.run $ Tactic.run sg1 do
    Tactic.evalTactic (←`(tactic| constructor))
  let [] := subgoals' | throwError "expected no subgoals"
  splitThenConstructor sg2 n

/-- Proves the left to right direction of a generated iff theorem.
`shape` is the output of a call to `constrToProp`.
-/
def toCases (mvar : MVarId) (shape : List Shape) : MetaM Unit :=
do
  let ⟨h, mvar'⟩ ← mvar.intro1
  let subgoals ← mvar'.cases h
  let _ ← (shape.zip subgoals.toList).enum.mapM fun ⟨p, ⟨⟨shape, t⟩, subgoal⟩⟩ ↦ do
    let vars := subgoal.fields
    let si := (shape.zip vars.toList).filterMap (λ ⟨c,v⟩ => if c then some v else none)
    let mvar'' ← select p (subgoals.size - 1) subgoal.mvarId
    match t with
    | none => do
      let v := vars.get! (shape.length - 1)
      let mv ← mvar''.existsi (List.init si)
      mv.assign v
    | some n => do
      let mv ← mvar''.existsi si
      splitThenConstructor mv (n - 1)
  pure ()

/-- Calls `cases` on `h` (assumed to be a binary sum) `n` times, and returns
the resulting subgoals and their corresponding new hypotheses.
-/
def nCasesSum (n : Nat) (mvar : MVarId) (h : FVarId) : MetaM (List (FVarId × MVarId)) :=
match n with
| 0 => pure [(h, mvar)]
| n' + 1 => do
  let #[sg1, sg2] ← mvar.cases h | throwError "expected two case subgoals"
  let #[Expr.fvar fvar1] ← pure sg1.fields | throwError "expected fvar"
  let #[Expr.fvar fvar2] ← pure sg2.fields | throwError "expected fvar"
  let rest ← nCasesSum n' sg2.mvarId fvar2
  pure ((fvar1, sg1.mvarId)::rest)

/-- Calls `cases` on `h` (assumed to be a binary product) `n` times, and returns
the resulting subgoal and the new hypotheses.
-/
def nCasesProd (n : Nat) (mvar : MVarId) (h : FVarId) : MetaM (MVarId × List FVarId) :=
match n with
| 0 => pure (mvar, [h])
| n' + 1 => do
  let #[sg] ← mvar.cases h | throwError "expected one case subgoals"
  let #[Expr.fvar fvar1, Expr.fvar fvar2] ← pure sg.fields | throwError "expected fvar"
  let (mvar', rest) ← nCasesProd n' sg.mvarId fvar2
  pure (mvar', fvar1::rest)

/--
Iterate over two lists, if the first element of the first list is `false`, insert `none` into the
result and continue with the tail of first list. Otherwise, wrap the first element of the second
list with `some` and continue with the tails of both lists. Return when either list is empty.

Example:
```
listBoolMerge [false, true, false, true] [0, 1, 2, 3, 4] = [none, (some 0), none, (some 1)]
```
-/
def listBoolMerge {α : Type _} : List Bool → List α → List (Option α)
| [], _ => []
| false :: xs, ys => none :: listBoolMerge xs ys
| true :: xs, y :: ys => some y :: listBoolMerge xs ys
| true :: _, [] => []

/-- Proves the right to left direction of a generated iff theorem.
-/
def toInductive (mvar : MVarId) (cs : List Name)
  (gs : List Expr) (s : List Shape) (h : FVarId) :
  MetaM Unit := do
  match s.length with
  | 0       => do let _ ← mvar.cases h
                  pure ()
  | (n + 1) => do
      let subgoals ← nCasesSum n mvar h
      let _ ← (cs.zip (subgoals.zip s)).mapM $ λ⟨constr_name, ⟨h, mv⟩, bs, e⟩ => do
        let n := (bs.filter id).length
        let (mvar', _fvars) ← match e with
        | none => nCasesProd (n-1) mv h
        | some 0 => do let ⟨mvar', fvars⟩ ← nCasesProd n mv h
                          let mvar'' ← mvar'.tryClear fvars.getLast!
                          pure ⟨mvar'', fvars⟩
        | some (e + 1) => do
           let (mv', fvars) ← nCasesProd n mv h
           let lastfv := fvars.getLast!
           let (mv2, fvars') ← nCasesProd e mv' lastfv

           /- `fvars'.foldlM subst mv2` fails when we have dependent equalities (`HEq`).
           `subst` will change the dependent hypotheses, so that the `uniq` local names
           are wrong afterwards. Instead we revert them and pull them out one-by-one. -/
           let (_, mv3) ← mv2.revert fvars'.toArray
           let mv4 ← fvars'.foldlM (λ mv _ => do let ⟨fv, mv'⟩ ← mv.intro1
                                                 subst mv' fv
                                   ) mv3
           pure (mv4, fvars)
        mvar'.withContext do
          let fvarIds := (←getLCtx).getFVarIds.toList
          let gs := fvarIds.take gs.length
          let hs := (fvarIds.reverse.take n).reverse
          let m := gs.map some ++ listBoolMerge bs hs
          let args ← m.mapM (λa => match a with
                                   | some v => pure $ mkFVar v
                                   | none => mkFreshExprMVar none)
          let c ← mkConstWithFreshMVarLevels constr_name
          let e := mkAppN c args.toArray
          let t ← inferType e
          let mt ← mvar'.getType
          let _ ← isDefEq t mt -- infer values for those mvars we just made
          mvar'.assign e

/-- Implementation for both `mk_iff` and `mk_iff_of_inductive_prop`.y
-/
def mkIffOfInductivePropImpl (ind : Name) (rel : Name) (relStx : Syntax) : MetaM Unit := do
  let .inductInfo inductVal ← getConstInfo ind |
    throwError "mk_iff only applies to inductive declarations"
  let constrs := inductVal.ctors
  let params := inductVal.numParams
  let type := inductVal.type

  let univNames := inductVal.levelParams
  let univs := univNames.map mkLevelParam
  /- we use these names for our universe parameters, maybe we should construct a copy of them
  using `uniq_name` -/

  let (thmTy,shape) ← Meta.forallTelescope type fun fvars ty ↦ do
    if !ty.isProp then throwError "mk_iff only applies to prop-valued declarations"
    let lhs := mkAppN (mkConst ind univs) fvars
    let fvars' := fvars.toList
    let shape_rhss ← constrs.mapM (constrToProp univs (fvars'.take params) (fvars'.drop params))
    let (shape, rhss) := shape_rhss.unzip
    pure (←mkForallFVars fvars (mkApp2 (mkConst `Iff) lhs (mkOrList rhss)),
          shape)

  let mvar ← mkFreshExprMVar (some thmTy)
  let mvarId := mvar.mvarId!
  let (fvars, mvarId') ← mvarId.intros
  let [mp, mpr] ← mvarId'.apply (mkConst `Iff.intro) | throwError "failed to split goal"

  toCases mp shape

  let ⟨mprFvar, mpr'⟩ ← mpr.intro1
  toInductive mpr' constrs ((fvars.toList.take params).map .fvar) shape mprFvar

  addDecl $ .thmDecl {
    name := rel
    levelParams := univNames
    type := thmTy
    value := ← instantiateMVars mvar
  }
  addDeclarationRanges rel {
    range := ← getDeclarationRange (← getRef)
    selectionRange := ← getDeclarationRange relStx
  }
  addConstInfo relStx rel

/--
Applying the `mk_iff` attribute to an inductively-defined proposition `mk_iff` makes an `iff` rule
`r` with the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type parameters, `is` are
the indices, `j` ranges over all possible constructors, the `cs` are the parameters for each of the
constructors, and the equalities `is = cs` are the instantiations for each constructor for each of
the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, if we try the following:
```lean
@[mk_iff]
structure Foo (m n : Nat) : Prop where
  equal : m = n
  sum_eq_two : m + n = 2
```

Then `#check Foo_iff` returns:
```lean
Foo_iff : ∀ (m n : Nat), Foo m n ↔ m = n ∧ m + n = 2
```

You can add an optional string after `mk_iff` to change the name of the generated lemma.
For example, if we try the following:
```lean
@[mk_iff bar]
structure Foo (m n : Nat) : Prop where
  equal : m = n
  sum_eq_two : m + n = 2
```

Then `#check bar` returns:
```lean
bar : ∀ (m n : ℕ), Foo m n ↔ m = n ∧ m + n = 2
```

See also the user command `mk_iff_of_inductive_prop`.
-/
syntax (name := mkIff) "mk_iff" (ppSpace ident)? : attr

/--
`mk_iff_of_inductive_prop i r` makes an `iff` rule for the inductively-defined proposition `i`.
The new rule `r` has the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type
parameters, `is` are the indices, `j` ranges over all possible constructors, the `cs` are the
parameters for each of the constructors, and the equalities `is = cs` are the instantiations for
each constructor for each of the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, `mk_iff_of_inductive_prop` on `List.Chain` produces:

```lean
∀ { α : Type _} (R : α → α → Prop) (a : α) (l : List α),
  Chain R a l ↔ l = [] ∨ ∃(b : α) (l' : List α), R a b ∧ Chain R b l ∧ l = b :: l'
```

See also the `mk_iff` user attribute.
-/
syntax (name := mkIffOfInductiveProp) "mk_iff_of_inductive_prop" ident ident : command

elab_rules : command
| `(command| mk_iff_of_inductive_prop $i:ident $r:ident) =>
    Command.liftCoreM <| MetaM.run' do
      mkIffOfInductivePropImpl i.getId r.getId r

initialize Lean.registerBuiltinAttribute {
  name := `mkIff
  descr := "Generate an `iff` lemma for an inductive `Prop`."
  add := fun decl stx _ => Lean.Meta.MetaM.run' do
    let (tgt, idStx) ← match stx with
      | `(attr| mk_iff $tgt:ident) =>
        pure ((← mkDeclName (← getCurrNamespace) {} tgt.getId).1, tgt.raw)
      | `(attr| mk_iff) => pure (decl.appendAfter "_iff", stx)
      | _ => throwError "unrecognized syntax"
    mkIffOfInductivePropImpl decl tgt idStx
}


import Lean
import UserAttr.BlaAttr

@[bla] def f (x : Nat) := x + 2
@[bla] def g (x : Nat) := x + 1

@[foo 10] def h1 (x : Nat) := 2*x + 1
@[foo 20 important] def h2 (x : Nat) := 2*x + 1

open Lean in
def hasBlaAttr (declName : Name) : CoreM Bool :=
  return blaAttr.hasTag (← getEnv) declName

#eval hasBlaAttr ``f
#eval hasBlaAttr ``id

open Lean in
def getFooAttrInfo? (declName : Name) : CoreM (Option (Nat × Bool)) :=
  return fooAttr.getParam? (← getEnv) declName

#eval getFooAttrInfo? ``f
#eval getFooAttrInfo? ``h1
#eval getFooAttrInfo? ``h2

@[my_simp] theorem f_eq : f x = x + 2 := rfl
@[my_simp] theorem g_eq : g x = x + 1 := rfl

example : f x + g x = 2*x + 3 := by
  simp_arith -- does not appy f_eq and g_eq
  simp_arith [f, g]

example : f x + g x = 2*x + 3 := by
  simp_arith [my_simp]

example : f x = id (x + 2) := by
  simp
  simp [my_simp]

macro "my_simp" : tactic => `(tactic| simp [my_simp])

example : f x = id (x + 2) := by
  my_simp

@[simp low, my_simp low]
axiom expand_mul_add (x y z : Nat) : x * (y + z) = x * y + x * y
@[simp high, my_simp high]
axiom expand_add_mul (x y z : Nat) : (x + y) * z = x * z + y * z
@[simp, my_simp]
axiom lassoc_add (x y z : Nat) : x + (y + z) = x + y + z

set_option trace.Meta.Tactic.simp.rewrite true

-- Rewrites: expand_mul_add -> expand_mul_add -> lassoc_add
theorem ex1 (x : Nat) : (x + x) * (x + x) = x * x + x * x + x * x + x * x := by simp only [my_simp]

-- Rewrites: expand_add_mul -> expand_mul_add -> lassoc_add
theorem ex2 (x : Nat) : (x + x) * (x + x) = x * x + x * x + x * x + x * x := by simp

open Lean Meta in
def checkProofs : MetaM Unit := do
  let .thmInfo info1 ← getConstInfo `ex1 | throwError "unexpected"
  let .thmInfo info2 ← getConstInfo `ex2 | throwError "unexpected"
  unless info1.value == info2.value do
    throwError "unexpected values"

#eval checkProofs

open Lean Meta in
def showThmsOf (simpAttrName : Name) : MetaM Unit := do
  let some simpExt ← getSimpExtension? simpAttrName
    | throwError "`{simpAttrName}` is not a simp attribute"
  let thms ← simpExt.getTheorems
  let thmNames := thms.lemmaNames.fold (init := #[]) fun acc origin => acc.push origin.key
  for thmName in thmNames do
    IO.println thmName

#eval showThmsOf `my_simp