/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.quasi_separated
import morphisms.isomorphism

/-!

# Affine morphisms

A morphism of schemes is affine if the preimages of affine open sets are affine.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

/-- A morphism is `affine` if the preimages of affine open sets are affine. -/
@[mk_iff]
class affine (f : X ⟶ Y) : Prop :=
(is_affine_preimage : ∀ U : opens Y.carrier,
  is_affine_open U → is_affine_open ((opens.map f.1.base).obj U))

/-- The `affine_target_morphism_property` corresponding to affine morphisms. -/
def affine.affine_property : affine_target_morphism_property :=
λ X Y f hf, is_affine X

@[simp] lemma affine_affine_property_to_property {X Y : Scheme} (f : X ⟶ Y) :
  affine_target_morphism_property.to_property affine.affine_property f ↔
    is_affine Y ∧ is_affine X :=
by { delta affine_target_morphism_property.to_property affine.affine_property, simp }

@[priority 900]
instance affine_of_is_iso {X Y : Scheme} (f : X ⟶ Y) [is_iso f] : affine f :=
⟨λ U hU, hU.map_is_iso f⟩

@[priority 100]
instance affine.to_quasi_compact [affine f] : quasi_compact f :=
(quasi_compact_iff_forall_affine f).mpr (λ U hU, (affine.is_affine_preimage U hU).is_compact)

instance affine_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [affine f] [affine g] : affine (f ≫ g) :=
begin
  constructor,
  intros U hU,
  rw [Scheme.comp_val_base, opens.map_comp_obj],
  apply affine.is_affine_preimage,
  apply affine.is_affine_preimage,
  exact hU
end

lemma affine_iff_affine_property :
  affine f ↔ target_affine_locally affine.affine_property f :=
(affine_iff f).trans ⟨λ H U, H U U.prop, λ H U hU, H ⟨U, hU⟩⟩

lemma affine_eq_affine_property :
  @affine = target_affine_locally affine.affine_property :=
by { ext, exact affine_iff_affine_property _ }

instance {X : Scheme} (r : X.presheaf.obj (op ⊤)) :
  affine (X.of_restrict (X.basic_open r).open_embedding) :=
begin
  constructor,
  intros U hU,
  fapply (is_affine_open_iff_of_is_open_immersion (X.of_restrict _) _).mp,
  swap,
  { apply_instance },
  convert hU.basic_open_is_affine (X.presheaf.map (hom_of_le le_top).op r),
  rw X.basic_open_res,
  ext1,
  refine set.image_preimage_eq_inter_range.trans _,
  erw subtype.range_coe,
  refl
end

/-- The preimage of an affine open as an `Scheme.affine_opens`. -/
@[simps]
def affine_preimage {X Y : Scheme} (f : X ⟶ Y) [affine f] (U : Y.affine_opens) :
  X.affine_opens :=
⟨(opens.map f.1.base).obj (U : opens Y.carrier), affine.is_affine_preimage _ U.prop⟩

lemma is_affine_of_span_top_of_is_affine_open (X : Scheme) (s : set (X.presheaf.obj $ op ⊤))
  (h₁ : ideal.span s = ⊤) (h₂ : ∀ r : s, is_affine_open (X.basic_open r.1)) : is_affine X :=
begin
  haveI hX' : quasi_separated_space X.carrier,
  { obtain ⟨s', hs', e⟩ := (ideal.span_eq_top_iff_finite _).mp h₁,
    rw quasi_separated_space_iff_affine,
    intros U V,
    rw [← set.inter_univ (U ∩ V : set X.carrier), ← (show _ = set.univ, from
      (congr_arg subtype.val $ supr_basic_open_eq_top_of_span_eq_top _ _ e : _)), opens.supr_def,
      subtype.val_eq_coe, subtype.coe_mk, set.inter_Union],
    apply is_compact_Union,
    intro i,
    convert_to is_compact ((U.1 ⊓ (X.basic_open i.val)) ⊓ (V.1 ⊓ (X.basic_open i.val))).1,
    { conv_rhs { rw [inf_assoc, ← @inf_assoc _ _ (X.basic_open i.1),
        @inf_comm _ _ (X.basic_open i.1), inf_assoc, inf_idem, ← inf_assoc] },
      refl },
    have : ∀ (S : opens X.carrier), S ⊓ X.basic_open i.1 = X.basic_open
      (X.presheaf.map (hom_of_le le_top : S ⟶ _).op i.1) := λ S, (X.basic_open_res _ _).symm,
    apply (h₂ ⟨i.1, hs' i.2⟩).is_quasi_separated,
    { exact @inf_le_right _ _ U.1 _ },
    { exact (U.val ⊓ X.basic_open i.val).2 },
    { rw this, exact (U.prop.basic_open_is_affine _).is_compact },
    { exact @inf_le_right _ _ V.1 _ },
    { exact (V.val ⊓ X.basic_open i.val).2 },
    { rw this, exact (V.prop.basic_open_is_affine _).is_compact } },
  have hX : compact_space X.carrier,
  { obtain ⟨s', hs', e⟩ := (ideal.span_eq_top_iff_finite _).mp h₁,
    rw [← is_compact_univ_iff, ← (show _ = set.univ, from
      (congr_arg subtype.val $ supr_basic_open_eq_top_of_span_eq_top _ _ e : _)), opens.supr_def],
    apply is_compact_Union,
    intro i, exact (h₂ ⟨i.1, hs' i.2⟩).is_compact },
  constructor,
  rw (is_iso.open_cover_tfae (Γ_Spec.adjunction.unit.app X)).out 0 5,
  refine ⟨s, λ i, prime_spectrum.basic_open i.1, _, _⟩,
  { rw prime_spectrum.Union_basic_open_eq_top_iff, convert h₁, simp },
  { intro r,
    apply_with is_iso_of_is_affine_is_iso { instances := ff },
    { change is_affine_open _,
      rw preimage_adjunction_unit_basic_open,
      exact h₂ r },
    { change is_affine_open _,
      rw ← basic_open_eq_of_affine,
      apply is_affine_open.basic_open_is_affine,
      apply_with top_is_affine_open { instances := ff },
      exact algebraic_geometry.Spec_is_affine _ },
    { suffices : ∀ (U = prime_spectrum.basic_open r.val),
        is_iso ((Γ_Spec.adjunction.unit.app X).val.c.app (op $ U)),
      { rw morphism_restrict_c_app,
        apply_with is_iso.comp_is_iso { instances := ff },
        { apply this, rw opens.open_embedding_obj_top },
        { apply_instance } },
      rintros _ rfl,
      rw CommRing.is_iso_iff_bijective,
      fapply bijective_of_is_localization (submonoid.powers r.1),
      rotate,
      { apply structure_sheaf.open_algebra },
      { apply ring_hom.to_algebra,
        exact X.presheaf.map (hom_of_le le_top :
          (opens.map (Γ_Spec.adjunction.unit.app X).val.base).obj _ ⟶ _).op },
      { apply structure_sheaf.is_localization.to_basic_open },
      { dsimp,
        rw ← is_compact_univ_iff at hX,
        rw ← is_quasi_separated_univ_iff at hX',
        convert is_localization_basic_open_of_qcqs
          (show is_compact (⊤ : opens _).1, from hX) hX' r.1;
          apply Γ_Spec.adjunction.unit_app_map_basic_open },
      { rw [ring_hom.algebra_map_to_algebra, ring_hom.algebra_map_to_algebra,
          Γ_Spec.adjunction_unit_app],
        exact X.1.to_Γ_Spec_SheafedSpace_app_spec r.1 } } }
end

lemma affine_affine_property_is_local :
  affine_target_morphism_property.is_local affine.affine_property :=
begin
  split,
  { apply affine_target_morphism_property.respects_iso_mk,
    all_goals { rintros X Y Z _ _ _ (H : is_affine _), resetI },
    exacts [is_affine_of_iso e.hom, H] },
  { introv H,
    change is_affine_open _,
    rw Scheme.preimage_basic_open f r,
    exact (@@top_is_affine_open X H).basic_open_is_affine _ },
  { rintros X Y H f S hS hS',
    resetI,
    apply_fun ideal.map (f.1.c.app (op ⊤)) at hS,
    rw [ideal.map_span, ideal.map_top] at hS,
    delta affine.affine_property,
    unfreezingI { change ∀ (i : S), is_affine_open _ at hS',
      simp_rw Scheme.preimage_basic_open at hS' },
    apply is_affine_of_span_top_of_is_affine_open X _ hS,
    rintro ⟨_, r, hr, rfl⟩,
    exact hS' ⟨r, hr⟩ }
end

lemma affine_is_local_at_target :
  property_is_local_at_target @affine :=
affine_eq_affine_property.symm ▸
  affine_affine_property_is_local.target_affine_locally_is_local

lemma affine_affine_property_stable_under_base_change :
  affine_target_morphism_property.stable_under_base_change affine.affine_property :=
begin
  introv X H,
  delta affine.affine_property at H ⊢,
  resetI,
  apply_instance
end

lemma affine_stable_under_base_change :
  morphism_property.stable_under_base_change @affine :=
affine_eq_affine_property.symm ▸
  affine_affine_property_is_local.stable_under_base_change
    affine_affine_property_stable_under_base_change

lemma affine_stable_under_composition :
  morphism_property.stable_under_composition @affine :=
λ X Y Z f g hf hg, by exactI infer_instance

lemma affine_over_affine_iff {X Y : Scheme} (f : X ⟶ Y) [is_affine Y] :
  affine f ↔ is_affine X :=
affine_eq_affine_property.symm ▸
  affine_affine_property_is_local.affine_target_iff f

@[priority 100]
instance affine_of_is_affine [is_affine X] [is_affine Y] : affine f :=
begin
  rw affine_over_affine_iff,
  apply_instance
end

lemma is_affine_of_affine [affine f] [is_affine Y] : is_affine X :=
begin
  rw ← affine_over_affine_iff f,
  apply_instance
end

end algebraic_geometry


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.nat.default
import Mathlib.Lean3Lib.init.data.bool.default
import Mathlib.Lean3Lib.init.ite_simp

universes u l u_1 w v

namespace Mathlib

/-- In the VM, d_array is implemented as a persistent array. -/
structure d_array (n : ℕ) (α : fin n → Type u) where
  data : (i : fin n) → α i

namespace d_array

/-- The empty array. -/
def nil {α : fin 0 → Type u_1} : d_array 0 α := mk fun (_x : fin 0) => sorry

/-- `read a i` reads the `i`th member of `a`. Has builtin VM implementation. -/
def read {n : ℕ} {α : fin n → Type u} (a : d_array n α) (i : fin n) : α i := data a i

/-- `write a i v` sets the `i`th member of `a` to be `v`. Has builtin VM implementation. -/
def write {n : ℕ} {α : fin n → Type u} (a : d_array n α) (i : fin n) (v : α i) : d_array n α :=
  mk fun (j : fin n) => dite (i = j) (fun (h : i = j) => eq.rec_on h v) fun (h : ¬i = j) => read a j

def iterate_aux {n : ℕ} {α : fin n → Type u} {β : Type w} (a : d_array n α)
    (f : (i : fin n) → α i → β → β) (i : ℕ) : i ≤ n → β → β :=
  sorry

/-- Fold over the elements of the given array in ascending order. Has builtin VM implementation. -/
def iterate {n : ℕ} {α : fin n → Type u} {β : Type w} (a : d_array n α) (b : β)
    (f : (i : fin n) → α i → β → β) : β :=
  iterate_aux a f n sorry b

/-- Map the array. Has builtin VM implementation. -/
def foreach {n : ℕ} {α : fin n → Type u} {α' : fin n → Type v} (a : d_array n α)
    (f : (i : fin n) → α i → α' i) : d_array n α' :=
  mk fun (i : fin n) => f i (read a i)

def map {n : ℕ} {α : fin n → Type u} {α' : fin n → Type v} (f : (i : fin n) → α i → α' i)
    (a : d_array n α) : d_array n α' :=
  foreach a f

def map₂ {n : ℕ} {α : fin n → Type u} {α' : fin n → Type v} {α'' : fin n → Type w}
    (f : (i : fin n) → α i → α' i → α'' i) (a : d_array n α) (b : d_array n α') : d_array n α'' :=
  foreach b fun (i : fin n) => f i (read a i)

def foldl {n : ℕ} {α : fin n → Type u} {β : Type w} (a : d_array n α) (b : β)
    (f : (i : fin n) → α i → β → β) : β :=
  iterate a b f

def rev_iterate_aux {n : ℕ} {α : fin n → Type u} {β : Type w} (a : d_array n α)
    (f : (i : fin n) → α i → β → β) (i : ℕ) : i ≤ n → β → β :=
  sorry

def rev_iterate {n : ℕ} {α : fin n → Type u} {β : Type w} (a : d_array n α) (b : β)
    (f : (i : fin n) → α i → β → β) : β :=
  rev_iterate_aux a f n sorry b

@[simp] theorem read_write {n : ℕ} {α : fin n → Type u} (a : d_array n α) (i : fin n) (v : α i) :
    read (write a i v) i = v :=
  sorry

@[simp] theorem read_write_of_ne {n : ℕ} {α : fin n → Type u} (a : d_array n α) {i : fin n}
    {j : fin n} (v : α i) : i ≠ j → read (write a i v) j = read a j :=
  sorry

protected theorem ext {n : ℕ} {α : fin n → Type u} {a : d_array n α} {b : d_array n α}
    (h : ∀ (i : fin n), read a i = read b i) : a = b :=
  sorry

protected theorem ext' {n : ℕ} {α : fin n → Type u} {a : d_array n α} {b : d_array n α}
    (h :
      ∀ (i : ℕ) (h : i < n),
        read a { val := i, property := h } = read b { val := i, property := h }) :
    a = b :=
  sorry

protected def beq_aux {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)]
    (a : d_array n α) (b : d_array n α) (i : ℕ) : i ≤ n → Bool :=
  sorry

/-- Boolean element-wise equality check. -/
protected def beq {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)] (a : d_array n α)
    (b : d_array n α) : Bool :=
  d_array.beq_aux a b n sorry

theorem of_beq_aux_eq_tt {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)]
    {a : d_array n α} {b : d_array n α} (i : ℕ) (h : i ≤ n) :
    d_array.beq_aux a b i h = tt →
        ∀ (j : ℕ) (h' : j < i),
          read a { val := j, property := lt_of_lt_of_le h' h } =
            read b { val := j, property := lt_of_lt_of_le h' h } :=
  sorry

theorem of_beq_eq_tt {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)]
    {a : d_array n α} {b : d_array n α} : d_array.beq a b = tt → a = b :=
  sorry

theorem of_beq_aux_eq_ff {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)]
    {a : d_array n α} {b : d_array n α} (i : ℕ) (h : i ≤ n) :
    d_array.beq_aux a b i h = false →
        ∃ (j : ℕ),
          ∃ (h' : j < i),
            read a { val := j, property := lt_of_lt_of_le h' h } ≠
              read b { val := j, property := lt_of_lt_of_le h' h } :=
  sorry

theorem of_beq_eq_ff {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)]
    {a : d_array n α} {b : d_array n α} : d_array.beq a b = false → a ≠ b :=
  sorry

protected instance decidable_eq {n : ℕ} {α : fin n → Type u} [(i : fin n) → DecidableEq (α i)] :
    DecidableEq (d_array n α) :=
  fun (a b : d_array n α) =>
    dite (d_array.beq a b = tt) (fun (h : d_array.beq a b = tt) => is_true sorry)
      fun (h : ¬d_array.beq a b = tt) => isFalse sorry

end d_array

/-- A non-dependent array (see `d_array`). Implemented in the VM as a persistent array.  -/
def array (n : ℕ) (α : Type u) := d_array n fun (_x : fin n) => α

/-- `mk_array n v` creates a new array of length `n` where each element is `v`. Has builtin VM implementation. -/
def mk_array {α : Type u_1} (n : ℕ) (v : α) : array n α := d_array.mk fun (_x : fin n) => v

namespace array

def nil {α : Type u_1} : array 0 α := d_array.nil

def read {n : ℕ} {α : Type u} (a : array n α) (i : fin n) : α := d_array.read a i

def write {n : ℕ} {α : Type u} (a : array n α) (i : fin n) (v : α) : array n α :=
  d_array.write a i v

/-- Fold array starting from 0, folder function includes an index argument. -/
def iterate {n : ℕ} {α : Type u} {β : Type v} (a : array n α) (b : β) (f : fin n → α → β → β) : β :=
  d_array.iterate a b f

/-- Map each element of the given array with an index argument. -/
def foreach {n : ℕ} {α : Type u} {β : Type v} (a : array n α) (f : fin n → α → β) : array n β :=
  d_array.foreach a f

def map₂ {n : ℕ} {α : Type u} (f : α → α → α) (a : array n α) (b : array n α) : array n α :=
  foreach b fun (i : fin n) => f (read a i)

def foldl {n : ℕ} {α : Type u} {β : Type v} (a : array n α) (b : β) (f : α → β → β) : β :=
  iterate a b fun (_x : fin n) => f

def rev_list {n : ℕ} {α : Type u} (a : array n α) : List α :=
  foldl a [] fun (_x : α) (_y : List α) => _x :: _y

def rev_iterate {n : ℕ} {α : Type u} {β : Type v} (a : array n α) (b : β) (f : fin n → α → β → β) :
    β :=
  d_array.rev_iterate a b f

def rev_foldl {n : ℕ} {α : Type u} {β : Type v} (a : array n α) (b : β) (f : α → β → β) : β :=
  rev_iterate a b fun (_x : fin n) => f

def to_list {n : ℕ} {α : Type u} (a : array n α) : List α :=
  rev_foldl a [] fun (_x : α) (_y : List α) => _x :: _y

theorem push_back_idx {j : ℕ} {n : ℕ} (h₁ : j < n + 1) (h₂ : j ≠ n) : j < n :=
  nat.lt_of_le_and_ne (nat.le_of_lt_succ h₁) h₂

/-- `push_back a v` pushes value `v` to the end of the array. Has builtin VM implementation. -/
def push_back {n : ℕ} {α : Type u} (a : array n α) (v : α) : array (n + 1) α :=
  d_array.mk fun (_x : fin (n + 1)) => sorry

theorem pop_back_idx {j : ℕ} {n : ℕ} (h : j < n) : j < n + 1 := nat.lt.step h

/-- Discard _last_ element in the array. Has builtin VM implementation. -/
def pop_back {n : ℕ} {α : Type u} (a : array (n + 1) α) : array n α :=
  d_array.mk fun (_x : fin n) => sorry

/-- Auxilliary function for monadically mapping a function over an array. -/
def mmap_core {n : ℕ} {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (a : array n α)
    (f : α → m β) (i : ℕ) (H : i ≤ n) : m (array i β) :=
  sorry

/-- Monadically map a function over the array. -/
def mmap {n : ℕ} {α : Type u} {β : Type v} {m : Type v → Type u_1} [Monad m] (a : array n α)
    (f : α → m β) : m (array n β) :=
  mmap_core a f n sorry

/-- Map a function over the array. -/
def map {n : ℕ} {α : Type u} {β : Type v} (a : array n α) (f : α → β) : array n β :=
  d_array.map (fun (_x : fin n) => f) a

protected def mem {n : ℕ} {α : Type u} (v : α) (a : array n α) := ∃ (i : fin n), read a i = v

protected instance has_mem {n : ℕ} {α : Type u} : has_mem α (array n α) := has_mem.mk array.mem

theorem read_mem {n : ℕ} {α : Type u} (a : array n α) (i : fin n) : read a i ∈ a :=
  exists.intro i rfl

protected instance has_repr {n : ℕ} {α : Type u} [has_repr α] : has_repr (array n α) :=
  has_repr.mk (repr ∘ to_list)

@[simp] theorem read_write {n : ℕ} {α : Type u} (a : array n α) (i : fin n) (v : α) :
    read (write a i v) i = v :=
  d_array.read_write a i v

@[simp] theorem read_write_of_ne {n : ℕ} {α : Type u} (a : array n α) {i : fin n} {j : fin n}
    (v : α) : i ≠ j → read (write a i v) j = read a j :=
  d_array.read_write_of_ne a v

def read' {n : ℕ} {β : Type v} [Inhabited β] (a : array n β) (i : ℕ) : β :=
  dite (i < n) (fun (h : i < n) => read a { val := i, property := h })
    fun (h : ¬i < n) => Inhabited.default

def write' {n : ℕ} {α : Type u} (a : array n α) (i : ℕ) (v : α) : array n α :=
  dite (i < n) (fun (h : i < n) => write a { val := i, property := h } v) fun (h : ¬i < n) => a

theorem read_eq_read' {n : ℕ} {α : Type u} [Inhabited α] (a : array n α) {i : ℕ} (h : i < n) :
    read a { val := i, property := h } = read' a i :=
  sorry

theorem write_eq_write' {n : ℕ} {α : Type u} (a : array n α) {i : ℕ} (h : i < n) (v : α) :
    write a { val := i, property := h } v = write' a i v :=
  sorry

protected theorem ext {n : ℕ} {α : Type u} {a : array n α} {b : array n α}
    (h : ∀ (i : fin n), read a i = read b i) : a = b :=
  d_array.ext h

protected theorem ext' {n : ℕ} {α : Type u} {a : array n α} {b : array n α}
    (h :
      ∀ (i : ℕ) (h : i < n),
        read a { val := i, property := h } = read b { val := i, property := h }) :
    a = b :=
  d_array.ext' h

protected instance decidable_eq {n : ℕ} {α : Type u} [DecidableEq α] : DecidableEq (array n α) :=
  eq.mpr sorry fun (a b : d_array n fun (_x : fin n) => α) => d_array.decidable_eq a b

end Mathlib


example (h : x ≠ true) : (x && y) = false := by
  simp [h]

example (h : ¬ (x = true)) : (x && y) = false := by
  simp [h]

example (h : x ≠ false) : (x && y) = y := by
  simp [h]

example (h : ¬ (x = false)) : (x && y) = y := by
  simp [h]


import Lean.Meta
import Lean.Elab
open Lean.Core
open Lean.Meta
open Lean.Elab.Term
open Lean
open Nat

def lower (n : MetaM Nat) : CoreM Nat :=
  n.run' {}

def raise (n: CoreM Nat) : MetaM Nat :=
  do
    let i <- n
    return i

-- copied from source

syntax (name := fooKind) "foo!" term : term

@[termElab fooKind] def elabFoo : TermElab :=
fun stx expectedType? => elabTerm (stx.getArg 1) expectedType?

#check foo! 10

def eg1 : Bool := foo! true

-- example of how to use the elaborator

syntax (name := addone) "addone!" (term)? : term

def addoneMeta (expr0 : Expr) : MetaM Expr :=
    do
      let name2 : Name := `Nat.succ
      let expr : Expr ←
        mkAppM name2  #[expr0]
            -- the expression returned by a function
      return expr

@[termElab addone] def addoneImpl : TermElab :=
fun stx expectedType? =>
  match stx with
  | `(addone! $s) =>
    do
      let s0 ← s
      let expr0 ←  elabTerm s0 (some (Lean.mkConst `Nat))
      let name2 : Name := `Nat.succ
      let expr : Expr ←
        mkAppM name2  #[expr0]
            -- the expression returned by a function
      return expr
  | _ =>
    do
      let name : Name := `Nat.zero
      let name2 : Name := `Nat.succ
      let expr : Expr :=
        mkApp (Lean.mkConst name2)  (Lean.mkConst name)
            -- the expression returned by a function
      return expr

def eg2 := addone! 10

#eval eg2
#eval 3 + addone!

def metaAddOne (n: MetaM Expr) : MetaM Expr :=
  do
    let i <- n
    let env ← getEnv
    IO.println s!"{env.contains ``succ}"
    IO.println s!"{env.contains `succ}"
    let decls ← getOpenDecls
    IO.println s!"{decls}"
    return mkApp (Lean.mkConst ``succ) i

def addOne(n: Nat) : Nat := addone! n

#print addOne
#eval addOne 7
#eval metaAddOne (mkConst `zero)
#eval ``succ

#check Elab.resolveGlobalConstNoOverloadWithInfo

def egNameM : TermElabM Name := do
  let stx : Syntax ← `(succ)
  IO.println s!"syntax : {stx}"
  match stx with
  | stx@(Syntax.ident _ _ n pre) => IO.println (s!"n: {n};  pre :{pre}")
  | _ => IO.println "Error"
  let ns : List Name ← Lean.resolveGlobalConst stx
  return ns.head!

#eval egNameM

#check open List Nat in fun n => cons n

syntax (name := tryapp) term ">>>>>" term : term

@[termElab tryapp] def tryappImpl : TermElab :=
fun stx expectedType? =>
  match stx with
  | `($s >>>>> $t) =>
    do
      let f <- elabTerm s none
      let x <- elabTerm t none
      let expr : Expr := mkApp f x
      let c  ← isTypeCorrect expr
      -- let cc ← hasType expr
      if c  then
        return expr
      else
        return (Lean.mkConst `Nat.zero)
      -- return (Lean.mkConst `Nat.zero)
  | _ =>
    do
      return (Lean.mkConst `Nat)

#check Nat.succ >>>>> Nat.zero
def one := Nat.succ >>>>> Nat.zero
#eval one

#check Eq >>>>> 2
#check (@Eq Nat) >>>>> 2

def shiftnat (n: Nat)(e : Expr) : MetaM Expr :=
  match n with
  | Nat.zero => return e
  | Nat.succ n => do
    let prev ← shiftnat n e
    return ← mkApp (mkConst `Nat.succ) prev

syntax (name := natshift) term ">>+>>" term : term

@[termElab natshift] def natshiftImpl : TermElab :=
fun stx expectedType? =>
  match stx with
  | `($s >>+>> $t) =>
    do
      let e <- elabTerm s (some (Lean.mkConst `Nat))
      let n : Nat <- t.isNatLit?.getD 0
      return ←  shiftnat n e
  | _ =>
    do
      return (Lean.mkConst `Nat)

#check 3 >>+>> 2
#eval 3 >>+>> 12

#check Lean.Syntax.mkScientificLit (Float.toString 3.14)

inductive Someterm  where
  | something  : {α : Type} → (a: α ) → Someterm
  | nothing : Someterm

def Someterm.isEmpty : Someterm → Bool
  | Someterm.something  _ => false
  | Someterm.nothing => true

syntax (name := tryapp2) term " >>>> " term : term

@[termElab tryapp2] def tryappImpl2 : TermElab :=
  let nt := Lean.mkConst `Someterm.nothing
  let st := Lean.mkConst `Someterm.something

  fun stx expectedType? =>
    match stx with
    | `($s >>>> $t) =>
      do
        let f <- elabTerm s none
        let x <- elabTerm t none
        let expr : Expr ←  mkApp f x
        let c ←  isTypeCorrect expr
        -- let cc := !expr.hasExprMVar
        if c then
          return Lean.mkApp st expr
        else
          return nt
    | _ =>
      do
        return nt

#check Nat.succ >>>> 3
#check Nat.succ >>>> true

#check (Eq.trans >>>> (rfl : Nat.zero = Nat.zero))

def optApp {α β γ : Type} (f : α → β) (x : γ)  :=
  f >>>> x

#print optApp

def eg3 := optApp Nat.succ 3

def eg4 := optApp Nat.succ true

#eval eg3.isEmpty -- this fails, the lambda body does not type check
#eval eg4.isEmpty

#print eg3

def exprApp (e1 e1t e2 : Expr) : MetaM Expr :=
  let n := Name.mkSimple "unsafe-name"
  withLetDecl n e1t e1 fun x => do
    let b ←  (mkAppM n #[e2])
    return ← (mkLetFVars #[x] b)

syntax (name := unapp) term " :: " term " |< " term : term

@[termElab unapp] def unappImpl : TermElab :=
  let nt := Lean.mkConst `Someterm.nothing
  let st := Lean.mkConst `Someterm.something
  let n := Name.mkSimple "unsafe-name"
  fun stx expectedType? =>
    match stx with
    | `($s :: $t |< $u) =>
      do
        let f <- elabTerm s none
        let type ← elabTerm t none
        let z <- elabTerm u none
        let expr : Expr ←  withLetDecl n type f fun x => do
                              let b ←  (mkAppM n #[z])
                              return ← (mkLetFVars #[x] b)
        let c <- isTypeCorrect expr
        if c then
          return Lean.mkApp st expr
        else
          return nt
    | _ =>
      do
        return nt

-- #check Nat.succ :: (Nat → Nat) |< 3

#print unappImpl
#print exprApp

syntax (name := minlet) "minlet!" : term

@[termElab minlet] def minletImpl : TermElab :=
  fun stx expectedType? =>
  let n := Name.mkSimple "n"
  let z := Lean.mkConst `Nat.zero
  let ty := Lean.mkConst `Nat
  withLetDecl n ty z fun x => do
    let e <- mkLetFVars #[x] x
    return e

#print minletImpl
#check minlet!

def eglit := minletImpl (Syntax.mkStrLit "minlet!") none

#check eglit
#eval eglit

def blahh := Meta.isExprDefEqAux

def nameLess (name: Name) := 1

syntax (name := ignorename) "ignore!" ident : term

macro_rules
  | `(ignore! $s) => `(Nat.zero)

#check nameLess ``Nat.succ

#check ignore! Nat.succ

inductive WrapTerm where
  | wrap : {α : Type} → (a: α ) → WrapTerm
  | wrapName : Name → WrapTerm
  | wrapExpr : Array Expr → WrapTerm

#check WrapTerm

def makeTypeFamily := Eq 1

#check makeTypeFamily
#check Eq

def makeProp : Prop := by
  apply Eq
  focus
    exact 1
  exact 2

def makeType : Type := by
  apply Option
  exact Nat

def makeIndFam : Nat → Type := by
  intro n
  induction n with
  | zero =>
    exact Nat
  | succ k ih =>
    exact Nat × ih

#check Eq.trans

def eqStatement: Prop := by
  apply Eq
  focus
    apply 1
  focus
    apply 2

def asFunc {α β : Type} (a: α) : (α → β) → β  :=
    fun f => f a

def asPi {α : Type}{motive : α → Type} (a: α) :
      ((x : α) → motive x) → motive a :=
        fun f => f a

def natGen : Nat := by
    apply (asFunc 3)
    exact Nat.succ

def piFactorizer (α : Type)(motive : α → Type) : Type :=
    (a: α ) → motive a

def island : Type := by
  apply piFactorizer
  focus
    exact fun _ => Nat
  focus
    exact Nat

def island2: Type := by
  apply piFactorizer Nat
  intro n
  induction n with
  | zero => exact Nat
  | succ k ih => exact Nat × ih

def egT := island2

open Nat

def egEgt : island2 := fun n =>
  match n with
  | zero =>  Nat.zero
  | succ k  => (k, egEgt k)

def WithType := Σ A : Type, A

def WithType.mk (α : Type) (a : α) : WithType := ⟨α , a⟩

def WithType.getType (w : WithType) : Type := w.1
def WithType.getVal (w : WithType) : w.1 := w.2

def metaWithType(e: Expr) : MetaM Expr := do
  let tp <- inferType e
  let pair  ← mkAppM ``WithType.mk #[tp, e]
  return pair

syntax (name := withtype) "withType! " term : term

@[termElab withtype] def metaWithTypeStx : TermElab :=
  fun stx expectedType? =>
  match stx with
  | `(withType! $s) =>
    do
      let e <- elabTerm s none
      let pair ← metaWithType e
      return pair
  | _ => Elab.throwIllFormedSyntax

def egName := ``Nat

#check egName

def egTyped  := withType! 3

#check egTyped
#check egTyped.getType

def elem : Nat := egTyped.getVal

#eval elem

def infEg : Inhabited Nat := inferInstance

#print infEg

#check @inferInstance (ToString Nat)

def viewExp : ToString Expr := inferInstance

def explicitToString (α : Type)(a: α)(ts: ToString α) : String :=
  ts.toString a

def exprToString (e: Expr) : String := viewExp.toString e

def exprView(e: Expr) : MetaM Expr :=
  do
    let tp ←  inferType e
    let tst ← mkAppM ``ToString #[tp]
    let ts ← synthInstance? tst
    match ts with
    | none =>
      do
        let viewExp : ToString Expr := inferInstance
        let litStr := Literal.strVal (viewExp.toString e)
        let strExp := mkLit litStr
        return  strExp
    | some t => do
      -- let tts ← mkAppM ``ToString.toString #[t]
      let v ← -- mkAppN tts #[e]
         mkAppM ``explicitToString #[tp, e, t]
      return ← whnf v

syntax (name := showexpr) "show! " term : term

@[termElab showexpr] def showexprImpl : TermElab :=
  fun stx expectedType? =>
  match stx with
  | `(show! $s) =>
    do
      let e <- elabTerm s none
      let s ← exprView e
      return s
  | _ => Elab.throwIllFormedSyntax

def egShow : String := show! (3 : Nat)

#eval egShow

def egShow2 : String  := show! (fun n : Nat => 2 + n)

#eval egShow2

def hashExpr : Hashable Expr := inferInstance

#check hashExpr

theorem constfunc{α : Type}{f: Nat → α}:
        (∀ n: Nat, f n = f (succ n)) →  (∀ n: Nat, f n = f zero) := by
          intro hyp
          intro n
          induction n with
          | zero => rfl
          | succ k ih =>
             rw [← ih]
             apply Eq.symm
             apply hyp

theorem constfuncGen{α : Type}{f: Nat → α}:
        (∀ n: Nat, f n = f (succ n)) →
          (∃ c : α, ∀ n: Nat, f n = c) := by
          intro hyp
          apply Exists.intro
          intro n
          induction n with
          | zero => rfl
          | succ k ih =>
             rw [← ih]
             apply Eq.symm
             apply hyp

def mvarMeta : MetaM Expr := do
  let mvar ← mkFreshExprMVar (some (mkConst ``Nat))
  let mvarId := mvar.mvarId!
  let mvar2 ← mkFreshExprMVar (some (mkConst ``Nat)) -- none works too
  let mvarId2 := mvar2.mvarId!
  assignExprMVar mvarId2 mvar
  assignExprMVar mvarId (mkConst ``Nat.zero)
  let mvarUnused := mkFreshExprMVar (some (mkConst ``Nat))
  return mvar2

syntax (name := minass) "minass!" : term

@[termElab minass] def minAssImpl : TermElab :=
  fun stx expectedType? =>
    do
      let e ← mvarMeta
      return mkApp (mkConst ``Nat.succ) e

def chkMinAss  := minass!

#eval chkMinAss

variable {m n: Nat}

constant k : Nat

constant l: Nat

def kl := k * l

def cname := `k

#print kl

#print cname

def mn := m * n

def names := [`n, ``mn]

def nPlusOne := addone! n

#check nPlusOne
#print nPlusOne
#print mn

#eval @nPlusOne 3

#check ignore! n
#check ignore! pqrst

def useName (fn: Nat → Nat) (arg: Name) : MetaM Expr :=
  do
    let lctx ← getLCtx
    match (← getLCtx).findFromUserName? arg with
  | some d => return d.value
  | none   => return mkConst `Nat.zero

def useFVar (z: Bool) (arg: Expr) : MetaM Expr :=
  do
    let lctx ← getLCtx
    let e ← lctx.getFVar! arg
    return mkApp (mkConst `Nat.succ) e.value

syntax (name := minname) "minname! " term : term

@[termElab minname] def minNameImpl : TermElab :=
  fun stx expectedType? =>
   match stx with
  | `(minname! $s) =>
    do
      let n := Name.mkSimple "n"
      let z := Lean.mkConst `Nat.zero
      let ty := Lean.mkConst `Nat
      withLetDecl n ty z fun x =>
        let e := useFVar true x
        return ← e
  | _ => Elab.throwIllFormedSyntax

#eval minname! true


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Compiler.IR.Basic
import Lean.Compiler.IR.LiveVars
import Lean.Compiler.IR.Format

namespace Lean.IR.ResetReuse
/-! Remark: the insertResetReuse transformation is applied before we have
   inserted `inc/dec` instructions, and perfomed lower level optimizations
   that introduce the instructions `release` and `set`. -/

/-! Remark: the functions `S`, `D` and `R` defined here implement the
  corresponding functions in the paper "Counting Immutable Beans"

  Here are the main differences:
  - We use the State monad to manage the generation of fresh variable names.
  - Support for join points, and `uset` and `sset` instructions for unboxed data.
  - `D` uses the auxiliary function `Dmain`.
  - `Dmain` returns a pair `(b, found)` to avoid quadratic behavior when checking
    the last occurrence of the variable `x`.
  - Because we have join points in the actual implementation, a variable may be live even if it
    does not occur in a function body. See example at `livevars.lean`.
-/

private def mayReuse (c₁ c₂ : CtorInfo) : Bool :=
  c₁.size == c₂.size && c₁.usize == c₂.usize && c₁.ssize == c₂.ssize &&
  /- The following condition is a heuristic.
     We don't want to reuse cells from different types even when they are compatible
     because it produces counterintuitive behavior. -/
  c₁.name.getPrefix == c₂.name.getPrefix

private partial def S (w : VarId) (c : CtorInfo) : FnBody → FnBody
  | FnBody.vdecl x t v@(Expr.ctor c' ys) b   =>
    if mayReuse c c' then
      let updtCidx := c.cidx != c'.cidx
      FnBody.vdecl x t (Expr.reuse w c' updtCidx ys) b
    else
      FnBody.vdecl x t v (S w c b)
  | FnBody.jdecl j ys v b   =>
    let v' := S w c v
    if v == v' then FnBody.jdecl j ys v (S w c b)
    else FnBody.jdecl j ys v' b
  | FnBody.case tid x xType alts    => FnBody.case tid x xType <| alts.map fun alt => alt.modifyBody (S w c)
  | b =>
    if b.isTerminal then b
    else let
      (instr, b) := b.split
      instr.setBody (S w c b)

/-- We use `Context` to track join points in scope. -/
abbrev M := ReaderT LocalContext (StateT Index Id)

private def mkFresh : M VarId := do
  let idx ← getModify (fun n => n + 1)
  pure { idx := idx }

private def tryS (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody := do
  let w ← mkFresh
  let b' := S w c b
  if b == b' then pure b
  else pure $ FnBody.vdecl w IRType.object (Expr.reset c.size x) b'

private def Dfinalize (x : VarId) (c : CtorInfo) : FnBody × Bool → M FnBody
  | (b, true)  => pure b
  | (b, false) => tryS x c b

private def argsContainsVar (ys : Array Arg) (x : VarId) : Bool :=
  ys.any fun arg => match arg with
    | Arg.var y => x == y
    | _         => false

private def isCtorUsing (b : FnBody) (x : VarId) : Bool :=
  match b with
  | (FnBody.vdecl _ _ (Expr.ctor _ ys) _) => argsContainsVar ys x
  | _ => false

/-- Given `Dmain b`, the resulting pair `(new_b, flag)` contains the new body `new_b`,
   and `flag == true` if `x` is live in `b`.

   Note that, in the function `D` defined in the paper, for each `let x := e; F`,
   `D` checks whether `x` is live in `F` or not. This is great for clarity but it
   is expensive: `O(n^2)` where `n` is the size of the function body. -/
private partial def Dmain (x : VarId) (c : CtorInfo) : FnBody → M (FnBody × Bool)
  | e@(FnBody.case tid y yType alts) => do
    let ctx ← read
    if e.hasLiveVar ctx x then do
      /- If `x` is live in `e`, we recursively process each branch. -/
      let alts ← alts.mapM fun alt => alt.mmodifyBody fun b => Dmain x c b >>= Dfinalize x c
      pure (FnBody.case tid y yType alts, true)
    else pure (e, false)
  | FnBody.jdecl j ys v b   => do
    let (b, found) ← withReader (fun ctx => ctx.addJP j ys v) (Dmain x c b)
    let (v, _ /- found' -/) ← Dmain x c v
    /- If `found' == true`, then `Dmain b` must also have returned `(b, true)` since
       we assume the IR does not have dead join points. So, if `x` is live in `j` (i.e., `v`),
       then it must also live in `b` since `j` is reachable from `b` with a `jmp`.
       On the other hand, `x` may be live in `b` but dead in `j` (i.e., `v`). -/
    pure (FnBody.jdecl j ys v b, found)
  | e => do
    let ctx ← read
    if e.isTerminal then
      pure (e, e.hasLiveVar ctx x)
    else do
      let (instr, b) := e.split
      if isCtorUsing instr x then
        /- If the scrutinee `x` (the one that is providing memory) is being
           stored in a constructor, then reuse will probably not be able to reuse memory at runtime.
           It may work only if the new cell is consumed, but we ignore this case. -/
        pure (e, true)
      else
        let (b, found) ← Dmain x c b
        /- Remark: it is fine to use `hasFreeVar` instead of `hasLiveVar`
           since `instr` is not a `FnBody.jmp` (it is not a terminal) nor it is a `FnBody.jdecl`. -/
        if found || !instr.hasFreeVar x then
          pure (instr.setBody b, found)
        else
          let b ← tryS x c b
          pure (instr.setBody b, true)

private def D (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody :=
  Dmain x c b >>= Dfinalize x c

partial def R : FnBody → M FnBody
  | FnBody.case tid x xType alts   => do
      let alts ← alts.mapM fun alt => do
        let alt ← alt.mmodifyBody R
        match alt with
        | Alt.ctor c b =>
          if c.isScalar then pure alt
          else Alt.ctor c <$> D x c b
        | _            => pure alt
      pure $ FnBody.case tid x xType alts
  | FnBody.jdecl j ys v b   => do
    let v ← R v
    let b ← withReader (fun ctx => ctx.addJP j ys v) (R b)
    pure $ FnBody.jdecl j ys v b
  | e => do
    if e.isTerminal then pure e
    else do
      let (instr, b) := e.split
      let b ← R b
      pure (instr.setBody b)

end ResetReuse

open ResetReuse

def Decl.insertResetReuse (d : Decl) : Decl :=
  match d with
  | .fdecl (body := b) ..=>
    let nextIndex := d.maxIndex + 1
    let bNew      := (R b {}).run' nextIndex
    d.updateBody! bNew
  | other => other

end Lean.IR


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.ScopedEnvExtension
import Lean.Util.Recognizers
import Lean.Meta.LevelDefEq
import Lean.Meta.DiscrTree
import Lean.Meta.AppBuilder
import Lean.Meta.Tactic.AuxLemma
namespace Lean.Meta

/--
  The fields `levelParams` and `proof` are used to encode the proof of the simp lemma.
  If the `proof` is a global declaration `c`, we store `Expr.const c []` at `proof` without the universe levels, and `levelParams` is set to `#[]`
  When using the lemma, we create fresh universe metavariables.
  Motivation: most simp lemmas are global declarations, and this approach is faster and saves memory.

  The field `levelParams` is not empty only when we elaborate an expression provided by the user, and it contains universe metavariables.
  Then, we use `abstractMVars` to abstract the universe metavariables and create new fresh universe parameters that are stored at the field `levelParams`.
-/
structure SimpLemma where
  keys        : Array DiscrTree.Key
  levelParams : Array Name -- non empty for local universe polymorhic proofs.
  proof       : Expr
  priority    : Nat
  post        : Bool
  perm        : Bool -- true is lhs and rhs are identical modulo permutation of variables
  name?       : Option Name := none -- for debugging and tracing purposes
  deriving Inhabited

def SimpLemma.getName (s : SimpLemma) : Name :=
  match s.name? with
  | some n => n
  | none   => "<unknown>"

instance : ToFormat SimpLemma where
  format s :=
    let perm := if s.perm then ":perm" else ""
    let name := fmt s.getName
    let prio := f!":{s.priority}"
    name ++ prio ++ perm

instance : ToMessageData SimpLemma where
  toMessageData s := fmt s

instance : BEq SimpLemma where
  beq e₁ e₂ := e₁.proof == e₂.proof

structure SimpLemmas where
  pre         : DiscrTree SimpLemma := DiscrTree.empty
  post        : DiscrTree SimpLemma := DiscrTree.empty
  lemmaNames  : Std.PHashSet Name := {}
  toUnfold    : Std.PHashSet Name := {}
  erased      : Std.PHashSet Name := {}
  deriving Inhabited

def addSimpLemmaEntry (d : SimpLemmas) (e : SimpLemma) : SimpLemmas :=
  if e.post then
    { d with post := d.post.insertCore e.keys e, lemmaNames := updateLemmaNames d.lemmaNames }
  else
    { d with pre := d.pre.insertCore e.keys e, lemmaNames := updateLemmaNames d.lemmaNames }
where
  updateLemmaNames (s : Std.PHashSet Name) : Std.PHashSet Name :=
    match e.name? with
    | none => s
    | some name => s.insert name

def SimpLemmas.addDeclToUnfold (d : SimpLemmas) (declName : Name) : SimpLemmas :=
  { d with toUnfold := d.toUnfold.insert declName }

def SimpLemmas.isDeclToUnfold (d : SimpLemmas) (declName : Name) : Bool :=
  d.toUnfold.contains declName

def SimpLemmas.isLemma (d : SimpLemmas) (declName : Name) : Bool :=
  d.lemmaNames.contains declName

def SimpLemmas.eraseCore [Monad m] [MonadError m] (d : SimpLemmas) (declName : Name) : m SimpLemmas := do
  return { d with erased := d.erased.insert declName, lemmaNames := d.lemmaNames.erase declName, toUnfold := d.toUnfold.erase declName }

def SimpLemmas.erase [Monad m] [MonadError m] (d : SimpLemmas) (declName : Name) : m SimpLemmas := do
  unless d.isLemma declName || d.isDeclToUnfold declName do
    throwError "'{declName}' does not have [simp] attribute"
  d.eraseCore declName

inductive SimpEntry where
  | lemma    : SimpLemma → SimpEntry
  | toUnfold : Name → SimpEntry
  deriving Inhabited

builtin_initialize simpExtension : SimpleScopedEnvExtension SimpEntry SimpLemmas ←
  registerSimpleScopedEnvExtension {
    name     := `simpExt
    initial  := {}
    addEntry := fun d e =>
      match e with
      | SimpEntry.lemma e => addSimpLemmaEntry d e
      | SimpEntry.toUnfold n => d.addDeclToUnfold n
  }

private partial def isPerm : Expr → Expr → MetaM Bool
  | Expr.app f₁ a₁ _, Expr.app f₂ a₂ _ => isPerm f₁ f₂ <&&> isPerm a₁ a₂
  | Expr.mdata _ s _, t => isPerm s t
  | s, Expr.mdata _ t _ => isPerm s t
  | s@(Expr.mvar ..), t@(Expr.mvar ..) => isDefEq s t
  | Expr.forallE n₁ d₁ b₁ _, Expr.forallE n₂ d₂ b₂ _ => isPerm d₁ d₂ <&&> withLocalDeclD n₁ d₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.lam n₁ d₁ b₁ _, Expr.lam n₂ d₂ b₂ _ => isPerm d₁ d₂ <&&> withLocalDeclD n₁ d₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.letE n₁ t₁ v₁ b₁ _, Expr.letE n₂ t₂ v₂ b₂ _ =>
    isPerm t₁ t₂ <&&> isPerm v₁ v₂ <&&> withLetDecl n₁ t₁ v₁ fun x => isPerm (b₁.instantiate1 x) (b₂.instantiate1 x)
  | Expr.proj _ i₁ b₁ _, Expr.proj _ i₂ b₂ _ => i₁ == i₂ <&&> isPerm b₁ b₂
  | s, t => s == t

private partial def shouldPreprocess (type : Expr) : MetaM Bool :=
  forallTelescopeReducing type fun xs result => return !result.isEq

private partial def preprocess (e type : Expr) : MetaM (List (Expr × Expr)) := do
  let type ← whnf type
  if type.isForall then
    forallTelescopeReducing type fun xs type => do
      let e := mkAppN e xs
      let ps ← preprocess e type
      ps.mapM fun (e, type) =>
        return (← mkLambdaFVars xs e, ← mkForallFVars xs type)
  else if type.isEq then
    return [(e, type)]
  else if let some (lhs, rhs) := type.iff? then
    let type ← mkEq lhs rhs
    let e    ← mkPropExt e
    return [(e, type)]
  else if let some (_, lhs, rhs) := type.ne? then
    let type ← mkEq (← mkEq lhs rhs) (mkConst ``False)
    let e    ← mkEqFalse e
    return [(e, type)]
  else if let some p := type.not? then
    let type ← mkEq p (mkConst ``False)
    let e    ← mkEqFalse e
    return [(e, type)]
  else if let some (type₁, type₂) := type.and? then
    let e₁ := mkProj ``And 0 e
    let e₂ := mkProj ``And 1 e
    return (← preprocess e₁ type₁) ++ (← preprocess e₂ type₂)
  else
    let type ← mkEq type (mkConst ``True)
    let e    ← mkEqTrue e
    return [(e, type)]

private def checkTypeIsProp (type : Expr) : MetaM Unit :=
  unless (← isProp type) do
    throwError "invalid 'simp', proposition expected{indentExpr type}"

private def mkSimpLemmaCore (e : Expr) (levelParams : Array Name) (proof : Expr) (post : Bool) (prio : Nat) (name? : Option Name) : MetaM SimpLemma := do
  let type ← instantiateMVars (← inferType e)
  withNewMCtxDepth do
    let (xs, _, type) ← withReducible <| forallMetaTelescopeReducing type
    let type ← whnfR type
    let (keys, perm) ←
      match type.eq? with
      | some (_, lhs, rhs) => pure (← DiscrTree.mkPath lhs, ← isPerm lhs rhs)
      | none => throwError "unexpected kind of 'simp' theorem{indentExpr type}"
    return { keys := keys, perm := perm, post := post, levelParams := levelParams, proof := proof, name? := name?, priority := prio }

private def mkSimpLemmasFromConst (declName : Name) (post : Bool) (prio : Nat) : MetaM (Array SimpLemma) := do
  let cinfo ← getConstInfo declName
  let val := mkConst declName (cinfo.levelParams.map mkLevelParam)
  withReducible do
    let type ← inferType val
    checkTypeIsProp type
    if (← shouldPreprocess type) then
      let mut r := #[]
      for (val, type) in (← preprocess val type) do
        let auxName ← mkAuxLemma cinfo.levelParams type val
        r := r.push <| (← mkSimpLemmaCore (mkConst auxName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst auxName) post prio declName)
      return r
    else
      #[← mkSimpLemmaCore (mkConst declName (cinfo.levelParams.map mkLevelParam)) #[] (mkConst declName) post prio declName]

def addSimpLemma (declName : Name) (post : Bool) (attrKind : AttributeKind) (prio : Nat) : MetaM Unit := do
  let simpLemmas ← mkSimpLemmasFromConst declName post prio
  for simpLemma in simpLemmas do
    simpExtension.add (SimpEntry.lemma simpLemma) attrKind

builtin_initialize
  registerBuiltinAttribute {
    name  := `simp
    descr := "simplification theorem"
    add   := fun declName stx attrKind =>
      let go : MetaM Unit := do
        let info ← getConstInfo declName
        if (← isProp info.type) then
          let post :=
            if stx[1].isNone then true else stx[1][0].getKind == ``Lean.Parser.Tactic.simpPost
          let prio ← getAttrParamOptPrio stx[2]
          addSimpLemma declName post attrKind prio
        else if info.hasValue then
          simpExtension.add (SimpEntry.toUnfold declName) attrKind
        else
          throwError "invalid 'simp', it is not a proposition nor a definition (to unfold)"
      discard <| go.run {} {}
    erase := fun declName => do
      let s ← simpExtension.getState (← getEnv)
      let s ← s.erase declName
      modifyEnv fun env => simpExtension.modifyState env fun _ => s
  }

def getSimpLemmas : MetaM SimpLemmas :=
  return simpExtension.getState (← getEnv)

/- Auxiliary method for adding a global declaration to a `SimpLemmas` datastructure. -/
def SimpLemmas.addConst (s : SimpLemmas) (declName : Name) (post : Bool := true) (prio : Nat := eval_prio default) : MetaM SimpLemmas := do
  let simpLemmas ← mkSimpLemmasFromConst declName post prio
  return simpLemmas.foldl addSimpLemmaEntry s

def SimpLemma.getValue (simpLemma : SimpLemma) : MetaM Expr := do
  if simpLemma.proof.isConst && simpLemma.levelParams.isEmpty then
    let info ← getConstInfo simpLemma.proof.constName!
    if info.levelParams.isEmpty then
      return simpLemma.proof
    else
      return simpLemma.proof.updateConst! (← info.levelParams.mapM (fun _ => mkFreshLevelMVar))
  else
    let us ← simpLemma.levelParams.mapM fun _ => mkFreshLevelMVar
    simpLemma.proof.instantiateLevelParamsArray simpLemma.levelParams us

private def preprocessProof (val : Expr) : MetaM (Array Expr) := do
  let type ← inferType val
  checkTypeIsProp type
  let ps ← preprocess val type
  return ps.toArray.map fun (val, _) => val

/- Auxiliary method for creating simp lemmas from a proof term `val`. -/
def mkSimpLemmas (levelParams : Array Name) (proof : Expr) (post : Bool := true) (prio : Nat := eval_prio default) (name? : Option Name := none): MetaM (Array SimpLemma) :=
  withReducible do
    (← preprocessProof proof).mapM fun val => mkSimpLemmaCore val levelParams val post prio name?

/- Auxiliary method for adding a local simp lemma to a `SimpLemmas` datastructure. -/
def SimpLemmas.add (s : SimpLemmas) (levelParams : Array Name) (proof : Expr) (post : Bool := true) (prio : Nat := eval_prio default) (name? : Option Name := none): MetaM SimpLemmas := do
  if proof.isConst then
    s.addConst proof.constName! post prio
  else
    let simpLemmas ← mkSimpLemmas levelParams proof post prio (← getName? proof)
    return simpLemmas.foldl addSimpLemmaEntry s
where
  getName? (e : Expr) : MetaM (Option Name) := do
    match name? with
    | some _ => return name?
    | none   =>
      let f := e.getAppFn
      if f.isConst then
        return f.constName!
      else if f.isFVar then
        let localDecl ← getFVarLocalDecl f
        return localDecl.userName
      else
        return none

end Lean.Meta


example (f : α → α) (a b : α) (h : HEq a b) : f a = f b := by
  subst h
  rfl


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis

! This file was ported from Lean 3 source module tactic.norm_cast
! leanprover-community/mathlib commit 32b08ef840dd25ca2e47e035c5da03ce16d2dc3c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Converter.Interactive
import Mathbin.Tactic.Hint

/-!
# A tactic for normalizing casts inside expressions

This tactic normalizes casts inside expressions.
It can be thought of as a call to the simplifier with a specific set of lemmas to
move casts upwards in the expression.
It has special handling of numerals and a simple heuristic to help moving
casts "past" binary operators.
Contrary to simp, it should be safe to use as a non-terminating tactic.

The algorithm implemented here is described in the paper
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.

## Important definitions
* `tactic.interactive.norm_cast`
* `tactic.interactive.push_cast`
* `tactic.interactive.exact_mod_cast`
* `tactic.interactive.apply_mod_cast`
* `tactic.interactive.rw_mod_cast`
* `tactic.interactive.assumption_mod_cast`
-/

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
namespace Tactic

/-- Runs `mk_instance` with a time limit.

This is a work around to the fact that in some cases
mk_instance times out instead of failing,
for example: `has_lift_t ℤ ℕ`

`mk_instance_fast` is used when we assume the type class search
should end instantly.
-/
unsafe def mk_instance_fast (e : expr) (timeout := 1000) : tactic expr :=
  try_for timeout (mk_instance e)
#align tactic.mk_instance_fast tactic.mk_instance_fast

end Tactic

namespace NormCast

open Tactic Expr

initialize
  registerTraceClass.1 `norm_cast

/-- Output a trace message if `trace.norm_cast` is enabled.
-/
unsafe def trace_norm_cast {α} [has_to_tactic_format α] (msg : String) (a : α) : tactic Unit :=
  when_tracing `norm_cast do
    let a ← pp a
    trace ("[norm_cast] " ++ msg ++ a : format)
#align norm_cast.trace_norm_cast norm_cast.trace_norm_cast

/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment
       "/--"
       "The `push_cast` simp attribute uses `norm_cast` lemmas\nto move casts toward the leaf nodes of the expression. -/")]
     "register_simp_attr"
     `push_cast)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/--
    The `push_cast` simp attribute uses `norm_cast` lemmas
    to move casts toward the leaf nodes of the expression. -/
  register_simp_attr
  push_cast

/-- `label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
inductive Label
  | elim : label
  | move : label
  | squash : label
  deriving DecidableEq, has_reflect, Inhabited
#align norm_cast.label NormCast.Label

namespace Label

/-- Convert `label` into `string`. -/
protected def toString : Label → String
  | elim => "elim"
  | move => "move"
  | squash => "squash"
#align norm_cast.label.to_string NormCast.Label.toString

instance : ToString Label :=
  ⟨Label.toString⟩

instance : Repr Label :=
  ⟨Label.toString⟩

unsafe instance : has_to_format Label :=
  ⟨fun l => l.toString⟩

/-- Convert `string` into `label`. -/
def ofString : String → Option Label
  | "elim" => some elim
  | "move" => some move
  | "squash" => some squash
  | _ => none
#align norm_cast.label.of_string NormCast.Label.ofString

end Label

open Label

/-- Count how many coercions are at the top of the expression. -/
unsafe def count_head_coes : expr → ℕ
  | q(coe $(e)) => count_head_coes e + 1
  | q(coeSort $(e)) => count_head_coes e + 1
  | q(coeFn $(e)) => count_head_coes e + 1
  | _ => 0
#align norm_cast.count_head_coes norm_cast.count_head_coes

/-- Count how many coercions are inside the expression, including the top ones. -/
unsafe def count_coes : expr → tactic ℕ
  | q(coe $(e)) => (· + 1) <$> count_coes e
  | q(coeSort $(e)) => (· + 1) <$> count_coes e
  | q(coeFn $(e)) => (· + 1) <$> count_coes e
  | app q(coeFn $(e)) x => (· + ·) <$> count_coes x <*> (· + 1) <$> count_coes e
  | expr.lam n bi t e => do
    let l ← mk_local' n bi t
    count_coes <| e l
  | e => do
    let as ← e.get_simp_args
    List.sum <$> as count_coes
#align norm_cast.count_coes norm_cast.count_coes

/-- Count how many coercions are inside the expression, excluding the top ones. -/
private unsafe def count_internal_coes (e : expr) : tactic ℕ := do
  let ncoes ← count_coes e
  pure <| ncoes - count_head_coes e
#align norm_cast.count_internal_coes norm_cast.count_internal_coes

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      Classifies a declaration of type `ty` as a `norm_cast` rule.
      -/
    unsafe
  def
    classify_type
    ( ty : expr ) : tactic Label
    :=
      do
        let ( _ , ty ) ← open_pis ty
          let
            ( lhs , rhs )
              ←
              match
                ty
                with
                | q( $ ( lhs ) = $ ( rhs ) ) => pure ( lhs , rhs )
                  | q( $ ( lhs ) ↔ $ ( rhs ) ) => pure ( lhs , rhs )
                  | _ => fail "norm_cast: lemma must be = or ↔"
          let lhs_coes ← count_coes lhs
          when ( lhs_coes = 0 )
            <|
            fail "norm_cast: badly shaped lemma, lhs must contain at least one coe"
          let lhs_head_coes := count_head_coes lhs
          let lhs_internal_coes ← count_internal_coes lhs
          let rhs_head_coes := count_head_coes rhs
          let rhs_internal_coes ← count_internal_coes rhs
          if
            lhs_head_coes = 0
            then
            return elim
            else
            if
              lhs_head_coes = 1
              then
              do
                when ( rhs_head_coes ≠ 0 )
                    <|
                    fail "norm_cast: badly shaped lemma, rhs can't start with coe"
                  if rhs_internal_coes = 0 then return squash else return move
              else
              if
                rhs_head_coes < lhs_head_coes
                then
                do return squash
                else
                do
                  fail
                    "norm_cast: badly shaped shaped squash lemma, rhs must have fewer head coes than lhs"
#align norm_cast.classify_type norm_cast.classify_type

/-- The cache for `norm_cast` attribute stores three `simp_lemma` objects. -/
unsafe structure norm_cast_cache where
  up : simp_lemmas
  down : simp_lemmas
  squash : simp_lemmas
#align norm_cast.norm_cast_cache norm_cast.norm_cast_cache

/-- Empty `norm_cast_cache`. -/
unsafe def empty_cache : norm_cast_cache
    where
  up := simp_lemmas.mk
  down := simp_lemmas.mk
  squash := simp_lemmas.mk
#align norm_cast.empty_cache norm_cast.empty_cache

unsafe instance : Inhabited norm_cast_cache :=
  ⟨empty_cache⟩

/-- `add_elim cache e` adds `e` as an `elim` lemma to `cache`. -/
unsafe def add_elim (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache := do
  let new_up ← cache.up.add e
  return
      { up := new_up
        down := cache
        squash := cache }
#align norm_cast.add_elim norm_cast.add_elim

/-- `add_move cache e` adds `e` as a `move` lemma to `cache`. -/
unsafe def add_move (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache := do
  let new_up ← cache.up.add e true
  let new_down ← cache.down.add e
  return
      { up := new_up
        down := new_down
        squash := cache }
#align norm_cast.add_move norm_cast.add_move

/-- `add_squash cache e` adds `e` as an `squash` lemma to `cache`. -/
unsafe def add_squash (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache := do
  let new_squash ← cache.squash.add e
  let new_down ← cache.down.add e
  return
      { up := cache
        down := new_down
        squash := new_squash }
#align norm_cast.add_squash norm_cast.add_squash

/-- The type of the `norm_cast` attribute.
The optional label is used to overwrite the classifier.
-/
unsafe def norm_cast_attr_ty : Type :=
  user_attribute norm_cast_cache (Option Label)
#align norm_cast.norm_cast_attr_ty norm_cast.norm_cast_attr_ty

/-- Efficient getter for the `@[norm_cast]` attribute parameter that does not call `eval_expr`.

See Note [user attribute parameters].
-/
unsafe def get_label_param (attr : norm_cast_attr_ty) (decl : Name) : tactic (Option Label) := do
  let p ← attr.get_param_untyped decl
  match p with
    | q(none) => pure none
    | q(some Label.elim) => pure label.elim
    | q(some Label.move) => pure label.move
    | q(some Label.squash) => pure label.squash
    | _ => fail p
#align norm_cast.get_label_param norm_cast.get_label_param

/--
`add_lemma cache decl` infers the proper `norm_cast` attribute for `decl` and adds it to `cache`.
-/
unsafe def add_lemma (attr : norm_cast_attr_ty) (cache : norm_cast_cache) (decl : Name) :
    tactic norm_cast_cache := do
  let e ← mk_const decl
  let param ← get_label_param attr decl
  let l ← param <|> infer_type e >>= classify_type
  match l with
    | elim => add_elim cache e
    | move => add_move cache e
    | squash => add_squash cache e
#align norm_cast.add_lemma norm_cast.add_lemma

-- special lemmas to handle the ≥, > and ≠ operators
private theorem ge_from_le {α} [LE α] : ∀ x y : α, x ≥ y ↔ y ≤ x := fun _ _ => Iff.rfl
#align norm_cast.ge_from_le norm_cast.ge_from_le

private theorem gt_from_lt {α} [LT α] : ∀ x y : α, x > y ↔ y < x := fun _ _ => Iff.rfl
#align norm_cast.gt_from_lt norm_cast.gt_from_lt

private theorem ne_from_not_eq {α} : ∀ x y : α, x ≠ y ↔ ¬x = y := fun _ _ => Iff.rfl
#align norm_cast.ne_from_not_eq norm_cast.ne_from_not_eq

/-- `mk_cache names` creates a `norm_cast_cache`. It infers the proper `norm_cast` attributes
for names in `names`, and collects the lemmas attributed with specific `norm_cast` attributes.
-/
unsafe def mk_cache (attr : Thunk norm_cast_attr_ty) (names : List Name) : tactic norm_cast_cache :=
  do
  let cache
    ←-- names has the declarations in reverse order
          names.foldrM
        (fun name cache => add_lemma (attr ()) cache Name) empty_cache
  let--some special lemmas to handle binary relations
  up := cache.up
  let up ← up.add_simp `` ge_from_le
  let up ← up.add_simp `` gt_from_lt
  let up ← up.add_simp `` ne_from_not_eq
  let down := cache.down
  let down ← down.add_simp `` coe_coe
  pure {
        up
        down
        squash := cache }
#align norm_cast.mk_cache norm_cast.mk_cache

/-- The `norm_cast` attribute.
-/
@[user_attribute]
unsafe def norm_cast_attr : user_attribute norm_cast_cache (Option Label)
    where
  Name := `norm_cast
  descr := "attribute for norm_cast"
  parser :=
    (do
        let some l ← (Label.ofString ∘ toString) <$> ident
        return l) <|>
      return none
  after_set :=
    some fun decl prio persistent => do
      let param ← get_label_param norm_cast_attr decl
      match param with
        | some l => when (l ≠ elim) <| simp_attr.push_cast decl () tt prio
        | none => do
          let e ← mk_const decl
          let ty ← infer_type e
          let l ← classify_type ty
          norm_cast_attr decl l persistent prio
  before_unset := some fun _ _ => tactic.skip
  cache_cfg :=
    { mk_cache := mk_cache norm_cast_attr
      dependencies := [] }
#align norm_cast.norm_cast_attr norm_cast.norm_cast_attr

/-- Classify a declaration as a `norm_cast` rule. -/
unsafe def make_guess (decl : Name) : tactic Label := do
  let e ← mk_const decl
  let ty ← infer_type e
  classify_type ty
#align norm_cast.make_guess norm_cast.make_guess

/-- Gets the `norm_cast` classification label for a declaration. Applies the
override specified on the attribute, if necessary.
-/
unsafe def get_label (decl : Name) : tactic Label := do
  let param ← get_label_param norm_cast_attr decl
  param <|> make_guess decl
#align norm_cast.get_label norm_cast.get_label

end NormCast

namespace Tactic.Interactive

open NormCast

/-- `push_cast` rewrites the expression to move casts toward the leaf nodes.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
Equivalent to `simp only with push_cast`.
Can also be used at hypotheses.

`push_cast` can also be used at hypotheses and with extra simp rules.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```
-/
unsafe def push_cast (hs : parse tactic.simp_arg_list) (l : parse location) : tactic Unit :=
  tactic.interactive.simp none none true hs [`push_cast] l { discharger := tactic.assumption }
#align tactic.interactive.push_cast tactic.interactive.push_cast

end Tactic.Interactive

namespace NormCast

open Tactic Expr

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Prove `a = b` using the given simp set. -/ unsafe
  def
    prove_eq_using
    ( s : simp_lemmas ) ( a b : expr ) : tactic expr
    :=
      do
        let ( a' , a_a' , _ ) ← simplify s [ ] a { failIfUnchanged := false }
          let ( b' , b_b' , _ ) ← simplify s [ ] b { failIfUnchanged := false }
          on_exception ( trace_norm_cast "failed: " ( to_expr ` `( $ ( a' ) = $ ( b' ) ) >>= pp ) )
            <|
            is_def_eq a' b' reducible
          let b'_b ← mk_eq_symm b_b'
          mk_eq_trans a_a' b'_b
#align norm_cast.prove_eq_using norm_cast.prove_eq_using

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- Prove `a = b` by simplifying using move and squash lemmas. -/ unsafe
  def
    prove_eq_using_down
    ( a b : expr ) : tactic expr
    :=
      do
        let cache ← norm_cast_attr . get_cache
          trace_norm_cast "proving: " ( to_expr ` `( $ ( a ) = $ ( b ) ) >>= pp )
          prove_eq_using cache a b
#align norm_cast.prove_eq_using_down norm_cast.prove_eq_using_down

/-- This is the main heuristic used alongside the elim and move lemmas.
The goal is to help casts move past operators by adding intermediate casts.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten to:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when (↑(↑(x : α) : β) : γ) = (↑(x : α) : γ) can be proven with a squash lemma
-/
unsafe def splitting_procedure : expr → tactic (expr × expr)
  | app (app op x) y =>
    (do
        let q(@coe $(α) $(δ) $(coe1) $(xx)) ← return x
        let q(@coe $(β) $(γ) $(coe2) $(yy)) ← return y
        success_if_fail <| is_def_eq α β
        is_def_eq δ γ
        (do
              let coe3 ← mk_app `has_lift_t [α, β] >>= mk_instance_fast
              let new_x ← to_expr ``(@coe $(β) $(δ) $(coe2) (@coe $(α) $(β) $(coe3) $(xx)))
              let new_e := app (app op new_x) y
              let eq_x ← prove_eq_using_down x new_x
              let pr ← mk_congr_arg op eq_x
              let pr ← mk_congr_fun pr y
              return (new_e, pr)) <|>
            do
            let coe3 ← mk_app `has_lift_t [β, α] >>= mk_instance_fast
            let new_y ← to_expr ``(@coe $(α) $(δ) $(coe1) (@coe $(β) $(α) $(coe3) $(yy)))
            let new_e := app (app op x) new_y
            let eq_y ← prove_eq_using_down y new_y
            let pr ← mk_congr_arg (app op x) eq_y
            return (new_e, pr)) <|>
      (do
          let q(@coe $(α) $(β) $(coe1) $(xx)) ← return x
          let q(@One.one $(β) $(h1)) ← return y
          let h2 ← to_expr ``(One $(α)) >>= mk_instance_fast
          let new_y ← to_expr ``(@coe $(α) $(β) $(coe1) (@One.one $(α) $(h2)))
          let eq_y ← prove_eq_using_down y new_y
          let new_e := app (app op x) new_y
          let pr ← mk_congr_arg (app op x) eq_y
          return (new_e, pr)) <|>
        (do
            let q(@coe $(α) $(β) $(coe1) $(xx)) ← return x
            let q(@Zero.zero $(β) $(h1)) ← return y
            let h2 ← to_expr ``(Zero $(α)) >>= mk_instance_fast
            let new_y ← to_expr ``(@coe $(α) $(β) $(coe1) (@Zero.zero $(α) $(h2)))
            let eq_y ← prove_eq_using_down y new_y
            let new_e := app (app op x) new_y
            let pr ← mk_congr_arg (app op x) eq_y
            return (new_e, pr)) <|>
          (do
              let q(@One.one $(β) $(h1)) ← return x
              let q(@coe $(α) $(β) $(coe1) $(xx)) ← return y
              let h1 ← to_expr ``(One $(α)) >>= mk_instance_fast
              let new_x ← to_expr ``(@coe $(α) $(β) $(coe1) (@One.one $(α) $(h1)))
              let eq_x ← prove_eq_using_down x new_x
              let new_e := app (app op new_x) y
              let pr ← mk_congr_arg (lam `x BinderInfo.default β (app (app op (var 0)) y)) eq_x
              return (new_e, pr)) <|>
            do
            let q(@Zero.zero $(β) $(h1)) ← return x
            let q(@coe $(α) $(β) $(coe1) $(xx)) ← return y
            let h1 ← to_expr ``(Zero $(α)) >>= mk_instance_fast
            let new_x ← to_expr ``(@coe $(α) $(β) $(coe1) (@Zero.zero $(α) $(h1)))
            let eq_x ← prove_eq_using_down x new_x
            let new_e := app (app op new_x) y
            let pr ← mk_congr_arg (lam `x BinderInfo.default β (app (app op (var 0)) y)) eq_x
            return (new_e, pr)
  | _ => failed
#align norm_cast.splitting_procedure norm_cast.splitting_procedure

/-- Discharging function used during simplification in the "squash" step.

TODO: norm_cast takes a list of expressions to use as lemmas for the discharger
TODO: a tactic to print the results the discharger fails to proove
-/
private unsafe def prove : tactic Unit :=
  assumption
#align norm_cast.prove norm_cast.prove

/-- Core rewriting function used in the "squash" step, which moves casts upwards
and eliminates them.

It tries to rewrite an expression using the elim and move lemmas.
On failure, it calls the splitting procedure heuristic.
-/
unsafe def upward_and_elim (s : simp_lemmas) (e : expr) : tactic (expr × expr) :=
  (do
      let r ← condM (is_prop e) (return `iff) (return `eq)
      let (new_e, pr) ← s.rewrite e prove r
      let pr ←
        match r with
          | `iff => mk_app `propext [pr]
          | _ => return pr
      return (new_e, pr)) <|>
    splitting_procedure e
#align norm_cast.upward_and_elim norm_cast.upward_and_elim

/-!
The following auxiliary functions are used to handle numerals.
-/

/-- If possible, rewrite `(n : α)` to `((n : ℕ) : α)` where `n` is a numeral and `α ≠ ℕ`.
Returns a pair of the new expression and proof that they are equal.
-/
unsafe def numeral_to_coe (e : expr) : tactic (expr × expr) := do
  let α ← infer_type e
  success_if_fail <| is_def_eq α q(ℕ)
  let n ← e.toNat
  let h1 ← mk_app `has_lift_t [q(ℕ), α] >>= mk_instance_fast
  let new_e : expr := reflect n
  let new_e ← to_expr ``(@coe ℕ $(α) $(h1) $(new_e))
  let pr ← prove_eq_using_down e new_e
  return (new_e, pr)
#align norm_cast.numeral_to_coe norm_cast.numeral_to_coe

/-- If possible, rewrite `((n : ℕ) : α)` to `(n : α)` where `n` is a numeral.
Returns a pair of the new expression and proof that they are equal.
-/
unsafe def coe_to_numeral (e : expr) : tactic (expr × expr) := do
  let q(@coe ℕ $(α) $(h1) $(e')) ← return e
  let n ← e'.toNat
  -- replace e' by normalized numeral
      is_def_eq
      (reflect n) e' reducible
  let e := e.app_fn (reflect n)
  let new_e ← expr.of_nat α n
  let pr ← prove_eq_using_down e new_e
  return (new_e, pr)
#align norm_cast.coe_to_numeral norm_cast.coe_to_numeral

/-- A local variant on `simplify_top_down`. -/
private unsafe def simplify_top_down' {α} (a : α) (pre : α → expr → tactic (α × expr × expr))
    (e : expr) (cfg : SimpConfig := { }) : tactic (α × expr × expr) :=
  ext_simplify_core a cfg simp_lemmas.mk (fun _ => failed)
    (fun a _ _ _ e => do
      let (new_a, new_e, pr) ← pre a e
      guard ¬new_e == e
      return (new_a, new_e, some pr, ff))
    (fun _ _ _ _ _ => failed) `eq e
#align norm_cast.simplify_top_down' norm_cast.simplify_top_down'

/-- The core simplification routine of `norm_cast`.
-/
unsafe def derive (e : expr) : tactic (expr × expr) := do
  let cache ← norm_cast_attr.get_cache
  let e ← instantiate_mvars e
  let cfg : SimpConfig :=
    { zeta := false
      beta := false
      eta := false
      proj := false
      iota := false
      iotaEqn := false
      failIfUnchanged := false }
  let e0 := e
  let-- step 1: pre-processing of numerals
    ((), e1, pr1)
    ← simplify_top_down' () (fun _ e => Prod.mk () <$> numeral_to_coe e) e0 cfg
  trace_norm_cast "after numeral_to_coe: " e1
  let-- step 2: casts are moved upwards and eliminated
    ((), e2, pr2)
    ← simplify_bottom_up () (fun _ e => Prod.mk () <$> upward_and_elim cache.up e) e1 cfg
  trace_norm_cast "after upward_and_elim: " e2
  let-- step 3: casts are squashed
    (e3, pr3, _)
    ← simplify cache.squash [] e2 cfg
  trace_norm_cast "after squashing: " e3
  let-- step 4: post-processing of numerals
    ((), e4, pr4)
    ← simplify_top_down' () (fun _ e => Prod.mk () <$> coe_to_numeral e) e3 cfg
  trace_norm_cast "after coe_to_numeral: " e4
  let new_e := e4
  guard ¬new_e == e
  let pr ← mk_eq_trans pr1 pr2
  let pr ← mk_eq_trans pr pr3
  let pr ← mk_eq_trans pr pr4
  return (new_e, pr)
#align norm_cast.derive norm_cast.derive

/-- A small variant of `push_cast` suited for non-interactive use.

`derive_push_cast extra_lems e` returns an expression `e'` and a proof that `e = e'`.
-/
unsafe def derive_push_cast (extra_lems : List simp_arg_type) (e : expr) : tactic (expr × expr) :=
  do
  let (s, _) ← mk_simp_set true [`push_cast] extra_lems
  let (e, prf, _) ←
    simplify (s.eraseₓ [`nat.cast_succ]) [] e { failIfUnchanged := false } `eq tactic.assumption
  return (e, prf)
#align norm_cast.derive_push_cast norm_cast.derive_push_cast

end NormCast

namespace Tactic

open Expr NormCast

/-- `aux_mod_cast e` runs `norm_cast` on `e` and returns the result. If `include_goal` is true, it
also normalizes the goal. -/
unsafe def aux_mod_cast (e : expr) (include_goal : Bool := true) : tactic expr :=
  match e with
  | local_const _ lc _ _ => do
    let e ← get_local lc
    replace_at derive [e] include_goal
    get_local lc
  | e => do
    let t ← infer_type e
    let e ← assertv `this t e
    replace_at derive [e] include_goal
    get_local `this
#align tactic.aux_mod_cast tactic.aux_mod_cast

/-- `exact_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to use `e` to close the
goal. -/
unsafe def exact_mod_cast (e : expr) : tactic Unit :=
  decorate_error "exact_mod_cast failed:" do
    let new_e ← aux_mod_cast e
    exact new_e
#align tactic.exact_mod_cast tactic.exact_mod_cast

/-- `apply_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to apply `e`. -/
unsafe def apply_mod_cast (e : expr) : tactic (List (Name × expr)) :=
  decorate_error "apply_mod_cast failed:" do
    let new_e ← aux_mod_cast e
    apply new_e
#align tactic.apply_mod_cast tactic.apply_mod_cast

/-- `assumption_mod_cast` runs `norm_cast` on the goal. For each local hypothesis `h`, it also
normalizes `h` and tries to use that to close the goal. -/
unsafe def assumption_mod_cast : tactic Unit :=
  decorate_error "assumption_mod_cast failed:" do
    let cfg : SimpConfig :=
      { failIfUnchanged := false
        canonizeInstances := false
        canonizeProofs := false
        proj := false }
    replace_at derive [] tt
    let ctx ← local_context
    ctx fun h => aux_mod_cast h ff >>= tactic.exact
#align tactic.assumption_mod_cast tactic.assumption_mod_cast

end Tactic

namespace Tactic.Interactive

open Tactic NormCast

/-- Normalize casts at the given locations by moving them "upwards".
As opposed to simp, norm_cast can be used without necessarily closing the goal.
-/
unsafe def norm_cast (loc : parse location) : tactic Unit := do
  let ns ← loc.get_locals
  let tt ← replace_at derive ns loc.include_goal |
    fail "norm_cast failed to simplify"
  when loc <| try tactic.reflexivity
  when loc <| try tactic.triv
  when ¬ns <| try tactic.contradiction
#align tactic.interactive.norm_cast tactic.interactive.norm_cast

/-- Rewrite with the given rules and normalize casts between steps.
-/
unsafe def rw_mod_cast (rs : parse rw_rules) (loc : parse location) : tactic Unit :=
  decorate_error "rw_mod_cast failed:" do
    let cfg_norm : SimpConfig := { }
    let cfg_rw : RewriteCfg := { }
    let ns ← loc.get_locals
    Monad.mapM'
        (fun r : rw_rule => do
          save_info r
          replace_at derive ns loc
          rw ⟨[r], none⟩ loc { })
        rs
    replace_at derive ns loc
    skip
#align tactic.interactive.rw_mod_cast tactic.interactive.rw_mod_cast

/-- Normalize the goal and the given expression, then close the goal with exact.
-/
unsafe def exact_mod_cast (e : parse texpr) : tactic Unit := do
  let e ←
    i_to_expr e <|> do
        let ty ← target
        let e ← i_to_expr_strict ``(($(e) : $(ty)))
        let pty ← pp ty
        let ptgt ← pp e
        fail
            ("exact_mod_cast failed, expression type not directly " ++
                      "inferrable. Try:\n\nexact_mod_cast ...\nshow " ++
                    to_fmt pty ++
                  ",\nfrom " ++
                ptgt :
              format)
  tactic.exact_mod_cast e
#align tactic.interactive.exact_mod_cast tactic.interactive.exact_mod_cast

/-- Normalize the goal and the given expression, then apply the expression to the goal.
-/
unsafe def apply_mod_cast (e : parse texpr) : tactic Unit := do
  let e ← i_to_expr_for_apply e
  concat_tags <| tactic.apply_mod_cast e
#align tactic.interactive.apply_mod_cast tactic.interactive.apply_mod_cast

/--
Normalize the goal and every expression in the local context, then close the goal with assumption.
-/
unsafe def assumption_mod_cast : tactic Unit :=
  tactic.assumption_mod_cast
#align tactic.interactive.assumption_mod_cast tactic.interactive.assumption_mod_cast

end Tactic.Interactive

namespace Conv.Interactive

open Conv

open NormCast (derive)

/-- the converter version of `norm_cast' -/
unsafe def norm_cast : conv Unit :=
  replace_lhs derive
#align conv.interactive.norm_cast conv.interactive.norm_cast

end Conv.Interactive

-- TODO: move this elsewhere?
@[norm_cast]
theorem ite_cast {α β} [HasLiftT α β] {c : Prop} [Decidable c] {a b : α} :
    ↑(ite c a b) = ite c (↑a : β) (↑b : β) := by by_cases h : c <;> simp [h]
#align ite_cast ite_cast

@[norm_cast]
theorem dite_cast {α β} [HasLiftT α β] {c : Prop} [Decidable c] {a : c → α} {b : ¬c → α} :
    ↑(dite c a b) = dite c (fun h => (↑(a h) : β)) fun h => (↑(b h) : β) := by
  by_cases h : c <;> simp [h]
#align dite_cast dite_cast

add_hint_tactic norm_cast  at *

/-- The `norm_cast` family of tactics is used to normalize casts inside expressions.
It is basically a simp tactic with a specific set of lemmas to move casts
upwards in the expression.
Therefore it can be used more safely as a non-terminating tactic.
It also has special handling of numerals.

For instance, given an assumption
```lean
a b : ℤ
h : ↑a + ↑b < (10 : ℚ)
```

writing `norm_cast at h` will turn `h` into
```lean
h : a + b < 10
```

You can also use `exact_mod_cast`, `apply_mod_cast`, `rw_mod_cast`
or `assumption_mod_cast`.
Writing `exact_mod_cast h` and `apply_mod_cast h` will normalize the goal and
`h` before using `exact h` or `apply h`.
Writing `assumption_mod_cast` will normalize the goal and for every
expression `h` in the context it will try to normalize `h` and use
`exact h`.
`rw_mod_cast` acts like the `rw` tactic but it applies `norm_cast` between steps.

`push_cast` rewrites the expression to move casts toward the leaf nodes.
This uses `norm_cast` lemmas in the forward direction.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
It is equivalent to `simp only with push_cast`.
It can also be used at hypotheses with `push_cast at h`
and with extra simp lemmas with `push_cast [int.add_zero]`.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```

The implementation and behavior of the `norm_cast` family is described in detail at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
  { Name := "norm_cast"
    category := DocCategory.tactic
    declNames :=
      [`` tactic.interactive.norm_cast, `` tactic.interactive.rw_mod_cast,
        `` tactic.interactive.apply_mod_cast, `` tactic.interactive.assumption_mod_cast,
        `` tactic.interactive.exact_mod_cast, `` tactic.interactive.push_cast]
    tags := ["coercions", "simplification"] }

/-- The `norm_cast` attribute should be given to lemmas that describe the
behaviour of a coercion in regard to an operator, a relation, or a particular
function.

It only concerns equality or iff lemmas involving `↑`, `⇑` and `↥`, describing the behavior of
the coercion functions.
It does not apply to the explicit functions that define the coercions.

Examples:
```lean
@[norm_cast] theorem coe_nat_inj' {m n : ℕ} : (↑m : ℤ) = ↑n ↔ m = n

@[norm_cast] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1

@[norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n

@[norm_cast] theorem coe_nat_add (m n : ℕ) : (↑(m + n) : ℤ) = ↑m + ↑n

@[norm_cast] theorem cast_sub [add_group α] [has_one α] {m n} (h : m ≤ n) :
  ((n - m : ℕ) : α) = n - m

@[norm_cast] theorem coe_nat_bit0 (n : ℕ) : (↑(bit0 n) : ℤ) = bit0 ↑n

@[norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℤ) : α) = n

@[norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1
```

Lemmas tagged with `@[norm_cast]` are classified into three categories: `move`, `elim`, and
`squash`. They are classified roughly as follows:

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes

`norm_cast` uses `move` and `elim` lemmas to factor coercions toward the root of an expression
and to cancel them from both sides of an equation or relation. It uses `squash` lemmas to clean
up the result.

Occasionally you may want to override the automatic classification.
You can do this by giving an optional `elim`, `move`, or `squash` parameter to the attribute.

```lean
@[simp, norm_cast elim] lemma nat_cast_re (n : ℕ) : (n : ℂ).re = n :=
by rw [← of_real_nat_cast, of_real_re]
```

Don't do this unless you understand what you are doing.

A full description of the tactic, and the use of each lemma category, can be found at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
  { Name := "norm_cast attributes"
    category := DocCategory.attr
    declNames := [`` norm_cast.norm_cast_attr]
    tags := ["coercions", "simplification"] }


import Lean

structure A :=
(x : Nat := 10)

def f : A :=
{ }

theorem ex : f = { x := 10 } :=
rfl

#check f

syntax (name := emptyS) "⟨" "⟩"  : term -- overload `⟨ ⟩` notation

open Lean
open Lean.Elab
open Lean.Elab.Term

@[termElab emptyS] def elabEmptyS : TermElab :=
fun stx expectedType? => do
  tryPostponeIfNoneOrMVar expectedType?
  let stxNew ← `(Nat.zero)
  withMacroExpansion stx stxNew $
    elabTerm stxNew expectedType?

def foo (x : Unit) := x

def f1 : Unit :=
let x := ⟨ ⟩
foo x

def f2 : Unit :=
let x := ⟨ ⟩
x

def f3 : Nat :=
let x := ⟨ ⟩
x

theorem ex2 : f3 = 0 :=
rfl


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.powerset
import Mathlib.data.multiset.range
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# The `nodup` predicate for multisets without duplicate elements.
-/

namespace multiset

/- nodup -/

/-- `nodup s` means that `s` has no duplicates, i.e. the multiplicity of
  any element is at most 1. -/
def nodup {α : Type u_1} (s : multiset α) :=
  quot.lift_on s list.nodup sorry

@[simp] theorem coe_nodup {α : Type u_1} {l : List α} : nodup ↑l ↔ list.nodup l :=
  iff.rfl

@[simp] theorem nodup_zero {α : Type u_1} : nodup 0 :=
  list.pairwise.nil

@[simp] theorem nodup_cons {α : Type u_1} {a : α} {s : multiset α} : nodup (a ::ₘ s) ↔ ¬a ∈ s ∧ nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_cons

theorem nodup_cons_of_nodup {α : Type u_1} {a : α} {s : multiset α} (m : ¬a ∈ s) (n : nodup s) : nodup (a ::ₘ s) :=
  iff.mpr nodup_cons { left := m, right := n }

theorem nodup_singleton {α : Type u_1} (a : α) : nodup (a ::ₘ 0) :=
  list.nodup_singleton

theorem nodup_of_nodup_cons {α : Type u_1} {a : α} {s : multiset α} (h : nodup (a ::ₘ s)) : nodup s :=
  and.right (iff.mp nodup_cons h)

theorem not_mem_of_nodup_cons {α : Type u_1} {a : α} {s : multiset α} (h : nodup (a ::ₘ s)) : ¬a ∈ s :=
  and.left (iff.mp nodup_cons h)

theorem nodup_of_le {α : Type u_1} {s : multiset α} {t : multiset α} (h : s ≤ t) : nodup t → nodup s :=
  le_induction_on h fun (l₁ l₂ : List α) => list.nodup_of_sublist

theorem not_nodup_pair {α : Type u_1} (a : α) : ¬nodup (a ::ₘ a ::ₘ 0) :=
  list.not_nodup_pair

theorem nodup_iff_le {α : Type u_1} {s : multiset α} : nodup s ↔ ∀ (a : α), ¬a ::ₘ a ::ₘ 0 ≤ s :=
  quot.induction_on s
    fun (l : List α) => iff.trans list.nodup_iff_sublist (forall_congr fun (a : α) => not_congr (iff.symm repeat_le_coe))

theorem nodup_iff_ne_cons_cons {α : Type u_1} {s : multiset α} : nodup s ↔ ∀ (a : α) (t : multiset α), s ≠ a ::ₘ a ::ₘ t := sorry

theorem nodup_iff_count_le_one {α : Type u_1} [DecidableEq α] {s : multiset α} : nodup s ↔ ∀ (a : α), count a s ≤ 1 :=
  quot.induction_on s fun (l : List α) => list.nodup_iff_count_le_one

@[simp] theorem count_eq_one_of_mem {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} (d : nodup s) (h : a ∈ s) : count a s = 1 :=
  le_antisymm (iff.mp nodup_iff_count_le_one d a) (iff.mpr count_pos h)

theorem nodup_iff_pairwise {α : Type u_1} {s : multiset α} : nodup s ↔ pairwise ne s :=
  quotient.induction_on s fun (l : List α) => iff.symm (pairwise_coe_iff_pairwise fun (a b : α) => ne.symm)

theorem pairwise_of_nodup {α : Type u_1} {r : α → α → Prop} {s : multiset α} : (∀ (a : α), a ∈ s → ∀ (b : α), b ∈ s → a ≠ b → r a b) → nodup s → pairwise r s := sorry

theorem forall_of_pairwise {α : Type u_1} {r : α → α → Prop} (H : symmetric r) {s : multiset α} (hs : pairwise r s) (a : α) : a ∈ s → ∀ (b : α), b ∈ s → a ≠ b → r a b := sorry

theorem nodup_add {α : Type u_1} {s : multiset α} {t : multiset α} : nodup (s + t) ↔ nodup s ∧ nodup t ∧ disjoint s t :=
  quotient.induction_on₂ s t fun (l₁ l₂ : List α) => list.nodup_append

theorem disjoint_of_nodup_add {α : Type u_1} {s : multiset α} {t : multiset α} (d : nodup (s + t)) : disjoint s t :=
  and.right (and.right (iff.mp nodup_add d))

theorem nodup_add_of_nodup {α : Type u_1} {s : multiset α} {t : multiset α} (d₁ : nodup s) (d₂ : nodup t) : nodup (s + t) ↔ disjoint s t := sorry

theorem nodup_of_nodup_map {α : Type u_1} {β : Type u_2} (f : α → β) {s : multiset α} : nodup (map f s) → nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_of_nodup_map f

theorem nodup_map_on {α : Type u_1} {β : Type u_2} {f : α → β} {s : multiset α} : (∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → f x = f y → x = y) → nodup s → nodup (map f s) :=
  quot.induction_on s fun (l : List α) => list.nodup_map_on

theorem nodup_map {α : Type u_1} {β : Type u_2} {f : α → β} {s : multiset α} (hf : function.injective f) : nodup s → nodup (map f s) :=
  nodup_map_on fun (x : α) (_x : x ∈ s) (y : α) (_x : y ∈ s) (h : f x = f y) => hf h

theorem nodup_filter {α : Type u_1} (p : α → Prop) [decidable_pred p] {s : multiset α} : nodup s → nodup (filter p s) :=
  quot.induction_on s fun (l : List α) => list.nodup_filter p

@[simp] theorem nodup_attach {α : Type u_1} {s : multiset α} : nodup (attach s) ↔ nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_attach

theorem nodup_pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} {f : (a : α) → p a → β} {s : multiset α} {H : ∀ (a : α), a ∈ s → p a} (hf : ∀ (a : α) (ha : p a) (b : α) (hb : p b), f a ha = f b hb → a = b) : nodup s → nodup (pmap f s H) :=
  quot.induction_on s (fun (l : List α) (H : ∀ (a : α), a ∈ Quot.mk setoid.r l → p a) => list.nodup_pmap hf) H

protected instance nodup_decidable {α : Type u_1} [DecidableEq α] (s : multiset α) : Decidable (nodup s) :=
  quotient.rec_on_subsingleton s fun (l : List α) => list.nodup_decidable l

theorem nodup_erase_eq_filter {α : Type u_1} [DecidableEq α] (a : α) {s : multiset α} : nodup s → erase s a = filter (fun (_x : α) => _x ≠ a) s :=
  quot.induction_on s fun (l : List α) (d : nodup (Quot.mk setoid.r l)) => congr_arg coe (list.nodup_erase_eq_filter a d)

theorem nodup_erase_of_nodup {α : Type u_1} [DecidableEq α] (a : α) {l : multiset α} : nodup l → nodup (erase l a) :=
  nodup_of_le (erase_le a l)

theorem mem_erase_iff_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {b : α} {l : multiset α} (d : nodup l) : a ∈ erase l b ↔ a ≠ b ∧ a ∈ l := sorry

theorem mem_erase_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {l : multiset α} (h : nodup l) : ¬a ∈ erase l a := sorry

theorem nodup_product {α : Type u_1} {β : Type u_2} {s : multiset α} {t : multiset β} : nodup s → nodup t → nodup (product s t) := sorry

theorem nodup_sigma {α : Type u_1} {σ : α → Type u_2} {s : multiset α} {t : (a : α) → multiset (σ a)} : nodup s → (∀ (a : α), nodup (t a)) → nodup (multiset.sigma s t) := sorry

theorem nodup_filter_map {α : Type u_1} {β : Type u_2} (f : α → Option β) {s : multiset α} (H : ∀ (a a' : α) (b : β), b ∈ f a → b ∈ f a' → a = a') : nodup s → nodup (filter_map f s) :=
  quot.induction_on s fun (l : List α) => list.nodup_filter_map H

theorem nodup_range (n : ℕ) : nodup (range n) :=
  list.nodup_range n

theorem nodup_inter_left {α : Type u_1} [DecidableEq α] {s : multiset α} (t : multiset α) : nodup s → nodup (s ∩ t) :=
  nodup_of_le (inter_le_left s t)

theorem nodup_inter_right {α : Type u_1} [DecidableEq α] (s : multiset α) {t : multiset α} : nodup t → nodup (s ∩ t) :=
  nodup_of_le (inter_le_right s t)

@[simp] theorem nodup_union {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} : nodup (s ∪ t) ↔ nodup s ∧ nodup t := sorry

@[simp] theorem nodup_powerset {α : Type u_1} {s : multiset α} : nodup (powerset s) ↔ nodup s := sorry

theorem nodup_powerset_len {α : Type u_1} {n : ℕ} {s : multiset α} (h : nodup s) : nodup (powerset_len n s) :=
  nodup_of_le (powerset_len_le_powerset n s) (iff.mpr nodup_powerset h)

@[simp] theorem nodup_bind {α : Type u_1} {β : Type u_2} {s : multiset α} {t : α → multiset β} : nodup (bind s t) ↔ (∀ (a : α), a ∈ s → nodup (t a)) ∧ pairwise (fun (a b : α) => disjoint (t a) (t b)) s := sorry

theorem nodup_ext {α : Type u_1} {s : multiset α} {t : multiset α} : nodup s → nodup t → (s = t ↔ ∀ (a : α), a ∈ s ↔ a ∈ t) :=
  quotient.induction_on₂ s t
    fun (l₁ l₂ : List α) (d₁ : nodup (quotient.mk l₁)) (d₂ : nodup (quotient.mk l₂)) =>
      iff.trans quotient.eq (list.perm_ext d₁ d₂)

theorem le_iff_subset {α : Type u_1} {s : multiset α} {t : multiset α} : nodup s → (s ≤ t ↔ s ⊆ t) :=
  quotient.induction_on₂ s t
    fun (l₁ l₂ : List α) (d : nodup (quotient.mk l₁)) => { mp := subset_of_le, mpr := list.subperm_of_subset_nodup d }

theorem range_le {m : ℕ} {n : ℕ} : range m ≤ range n ↔ m ≤ n :=
  iff.trans (le_iff_subset (nodup_range m)) range_subset

theorem mem_sub_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} {t : multiset α} (d : nodup s) : a ∈ s - t ↔ a ∈ s ∧ ¬a ∈ t := sorry

theorem map_eq_map_of_bij_of_nodup {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → γ) (g : β → γ) {s : multiset α} {t : multiset β} (hs : nodup s) (ht : nodup t) (i : (a : α) → a ∈ s → β) (hi : ∀ (a : α) (ha : a ∈ s), i a ha ∈ t) (h : ∀ (a : α) (ha : a ∈ s), f a = g (i a ha)) (i_inj : ∀ (a₁ a₂ : α) (ha₁ : a₁ ∈ s) (ha₂ : a₂ ∈ s), i a₁ ha₁ = i a₂ ha₂ → a₁ = a₂) (i_surj : ∀ (b : β), b ∈ t → ∃ (a : α), ∃ (ha : a ∈ s), b = i a ha) : map f s = map g t := sorry


import o_minimal.sheaf.tactic

namespace o_minimal

variables {R : Type*} {S : struc R}
variables {X Y Z : Type*} [definable_sheaf S X] [definable_sheaf S Y] [definable_sheaf S Z]

-- TODO: consistent naming

lemma definable.const : definable S (@function.const X Y) :=
begin [defin]
  intro x,
  intro y,
  var
end

lemma definable_comp : definable S (@function.comp X Y Z) :=
begin [defin]
  intro f,
  intro g,
  intro x,
  app, var,
  app, var, var
end

lemma definable.app {f : X → Y} (hf : definable S f) {x : X} (hx : definable S x) :
  definable S (f x) :=
begin [defin]
  app,
  exact hf.definable _,
  exact hx.definable _
end

lemma definable.comp {g : Y → Z} (hg : definable S g) {f : X → Y} (hf : definable S f) :
  definable S (g ∘ f) :=
(definable_comp.app hg).app hf

lemma definable.prod_mk : definable S (@prod.mk X Y) :=
begin [defin]
  intro x,
  intro y,
  exact ⟨x.definable, y.definable⟩
end

lemma definable.fst : definable S (prod.fst : X × Y → X) :=
begin [defin]
  intro p,
  exact p.definable.1
end

lemma definable.snd : definable S (prod.snd : X × Y → Y) :=
begin [defin]
  intro p,
  exact p.definable.2
end

lemma definable.curry : definable S (@function.curry X Y Z) :=
begin [defin]
  intro f,
  intro x,
  intro y,
  app, var,
  app, app, exact definable.prod_mk.definable _, var, var
end

lemma definable.uncurry : definable S (@function.uncurry X Y Z) :=
begin [defin]
  intro f,
  intro p,
  app, app, var,
  app, exact definable.fst.definable _, var,
  app, exact definable.snd.definable _, var
end

instance punit.definable_sheaf : definable_sheaf S punit :=
{ definable := λ K f, true,
  definable_precomp := λ L K φ f hf, trivial,
  definable_cover := λ K f 𝓛 h, trivial }

lemma definable.star : definable S punit.star :=
begin [defin]
  exact trivial
end

instance Prop.definable_sheaf : definable_sheaf S Prop :=
{ definable := λ K f, def_set S f,
  definable_precomp := λ L K φ f hf, φ.is_definable.preimage hf,
  definable_cover := λ K f 𝓛 h, Def.set_subcanonical 𝓛 f h }

lemma definable.and : definable S and :=
begin [defin]
  intro p,
  intro q,
  exact def_set.inter p.definable q.definable
end

lemma definable.or : definable S or :=
begin [defin]
  intro p,
  intro q,
  exact def_set.union p.definable q.definable
end

lemma definable.imp : definable S ((→) : Prop → Prop → Prop) :=
begin [defin]
  intro p,
  intro q,
  exact def_set.imp p.definable q.definable
end

lemma definable.not : definable S not :=
begin [defin]
  intro p,
  exact def_set.compl p.definable
end

lemma definable.iff : definable S iff :=
begin [defin]
  intro p,
  intro q,
  exact def_set.iff p.definable q.definable
end

instance set.definable_sheaf : definable_sheaf S (set X) :=
show definable_sheaf S (X → Prop), by apply_instance

lemma definable.mem : definable S ((∈) : X → set X → Prop) :=
begin [defin]
  intro x,
  intro s,
  app, var, var
end

lemma definable.inter : definable S ((∩) : set X → set X → set X) :=
begin [defin]
  intro s,
  intro t,
  intro x,
  app,
  app,
  exact definable.and.definable _,
  app, app, exact definable.mem.definable _, var, var,
  app, app, exact definable.mem.definable _, var, var
end

lemma definable.union : definable S ((∪) : set X → set X → set X) :=
begin [defin]
  intro s,
  intro t,
  intro x,
  app,
  app,
  exact definable.or.definable _,
  app, app, exact definable.mem.definable _, var, var,
  app, app, exact definable.mem.definable _, var, var
end

lemma definable.compl : definable S (set.compl : set X → set X) :=
begin [defin]
  intro s,
  intro x,
  app, exact definable.not.definable _,
  app, app, exact definable.mem.definable _, var, var
end

lemma definable.diff : definable S ((\) : set X → set X → set X) :=
begin [defin]
  intro s,
  intro t,
  intro x,
  app, app, exact definable.and.definable _,
  app, app, exact definable.mem.definable _, var, var,
  -- unnecessarily complicated, but hey why not
  -- TODO: `change`
  app,
  intro a,
  app, exact definable.not.definable _,
  app, app, exact definable.mem.definable _, var, var,
  var
end

-- Quantification over X is not definable in general.
-- Needs a special property of X: "quasicompactness"?
-- See `quantifiers` (for now, just over representables)

instance set.coe.definable_sheaf {s : set X} : definable_sheaf S s :=
{ definable := λ K f, definable_sheaf.definable (subtype.val ∘ f),
  definable_precomp := λ L K φ f hf,
    definable_sheaf.definable_precomp φ (subtype.val ∘ f) hf,
  definable_cover := λ K f 𝓛 hf,
    definable_sheaf.definable_cover (subtype.val ∘ f) 𝓛 hf }

instance subtype.definable_sheaf {p : X → Prop} : definable_sheaf S {x // p x} :=
show definable_sheaf S (set_of p), by apply_instance

-- instance prop.definable_sheaf {p : Prop} : definable_sheaf S p := sorry

-- TODO: With an instance for Pi types, can we state the definable dependence on `s`?
lemma definable.subtype.val {s : set X} : definable S (subtype.val : s → X) :=
begin [defin]
  intro v,
  exact v.definable
end

lemma definable_of_subtype_val {s : set Y} {f : X → s}
  (hf : definable S (subtype.val ∘ f)) : definable S f :=
begin
  cases hf with hf,
  exact ⟨λ K, hf K⟩
end

-- How to state definable subtype.mk?
/-
lemma definable.subtype.mk {s : set X} :
  definable S (subtype.mk : Π (x : X), x ∈ s → s) :=
begin
end
-/

lemma definable_subtype.map {s : set X} {t : set Y} {f : X → Y} (hf : definable S f)
  (h : ∀ x ∈ s, f x ∈ t) : definable S (subtype.map f h : s → t) :=
definable_of_subtype_val $ hf.comp definable.subtype.val

end o_minimal


import Lean

structure A :=
(x : Nat := 10)

def f : A :=
{ }

theorem ex : f = { x := 10 } :=
rfl

#check f

syntax (name := emptyS) "⟨" "⟩"  : term -- overload `⟨ ⟩` notation

open Lean
open Lean.Elab
open Lean.Elab.Term

@[term_elab emptyS] def elabEmptyS : TermElab :=
fun stx expectedType? => do
  tryPostponeIfNoneOrMVar expectedType?
  let stxNew ← `(Nat.zero)
  withMacroExpansion stx stxNew $
    elabTerm stxNew expectedType?

def foo (x : Unit) := x

def f1 : Unit :=
let x := ⟨ ⟩
foo x

def f2 : Unit :=
let x := ⟨ ⟩
x

def f3 : Nat :=
let x := ⟨ ⟩
x

theorem ex2 : f3 = 0 :=
rfl


import C0deine.Utils.Symbol

namespace C0deine

inductive Typ.Primitive
| int
| bool
deriving DecidableEq, Inhabited, Hashable

mutual
inductive Typ
| prim (p : Typ.Primitive)
| mem (m : Typ.Memory)
deriving Inhabited, Hashable

inductive Typ.Memory
| pointer (typ : Typ)
| array (typ : Typ)
| struct (sym : Symbol)
deriving Inhabited, Hashable
end

inductive Typ.Check
| type : Typ → Typ.Check
| void
| any
deriving Inhabited

namespace Typ

def Primitive.toString : Typ.Primitive → String
  | .int  => "int"
  | .bool => "bool"
instance : ToString Primitive where toString := Primitive.toString

mutual
def Memory.toString : Typ.Memory → String
  | .pointer (typ : Typ)   => s!"{toString typ}*"
  | .array (typ : Typ)     => s!"{toString typ}[]"
  | .struct (sym : Symbol) => s!"struct {sym}"

def toString : Typ → String
  | .prim (p : Primitive) => Primitive.toString p
  | .mem (m : Typ.Memory) => Memory.toString m
end

def Check.toString : Check → String
  | .type t => s!"{Typ.toString t}"
  | .void => "`void"
  | .any => "`any"

instance : ToString Memory where toString := Memory.toString
instance : ToString Typ where toString := Typ.toString
instance : ToString Typ.Check where toString := Typ.Check.toString
instance : ToString (Option Typ) where
  toString | none => "void" | some t => s!"{t}"

mutual
-- encoding structural equality
def structEq (a b : Typ) : Bool :=
  match a, b with
  | .prim p1, .prim p2 => p1 = p2
  | .mem m1, .mem m2 => Memory.structEq m1 m2
  | _, _ => false

def Memory.structEq (a b : Memory) : Bool :=
  match a, b with
  | .struct s1, .struct s2 => s1 = s2
  | .pointer t1, .pointer t2 => Typ.structEq t1 t2
  | .array t1, .array t2 => Typ.structEq t1 t2
  | _, _ => false
end

mutual
theorem deq {a b : Typ} : structEq a b = true ↔ a = b := by
  cases a <;> cases b <;>
  ( unfold structEq
    simp
    try apply Memory.deq
  )

theorem Memory.deq {a b : Memory} : Memory.structEq a b = true ↔ a = b := by
  cases a <;> cases b <;>
  ( unfold Memory.structEq
    simp
    try apply Typ.deq
  )
end

instance : DecidableEq Typ := fun a b =>
  match Bool.decEq (Typ.structEq a b) true with
  | .isTrue h  => .isTrue (Typ.deq.mp h)
  | .isFalse h => .isFalse (h ∘ Typ.deq.mpr)
instance : DecidableEq Memory := fun a b =>
  match Bool.decEq (Memory.structEq a b) true with
  | .isTrue h  => .isTrue (Memory.deq.mp h)
  | .isFalse h => .isFalse (h ∘ Memory.deq.mpr)

deriving instance DecidableEq for Typ.Check

mutual
  def equiv (a b : Typ) : Bool :=
    match a, b with
    | .prim p1  , .prim p2    => p1 == p2
    | .mem m1   , .mem m2     => Memory.equiv m1 m2
    | _, _                    => false

  def Memory.equiv (a b : Memory) : Bool :=
    match a, b with
    | .pointer t1, .pointer t2 => equiv t1 t2
    | .array t1  , .array t2   => equiv t1 t2
    | .struct s1 , .struct s2  => s1 == s2
    | _, _                     => false
end

def Check.equiv (a b : Check) : Bool :=
  match a, b with
  | .type t1, .type t2                          => Typ.equiv t1 t2
  | .void, .void                                => true
  | .any, .type (.mem (.array _))
  | .type (.mem (.array _)), .any               => false
  | .any, .type (.mem _) | .type (.mem _), .any => true
  | .any, .any => true
  | _, _       => false

def isScalar : Typ → Bool
  | .prim .int => true
  | .prim .bool => true
  | _ => false
def Check.isScalar : Typ.Check → Bool
  | .type t => t.isScalar
  | _ => false

def isSmall : Typ → Bool
  | .mem (.struct _) => false
  | _ => true
def Check.isSmall : Typ.Check → Bool
  | .type t => t.isSmall
  | _ => true

def sizeof : Typ → Option Nat
  | .prim .int => some 4
  | .prim .bool => some 1
  | .mem (.pointer _) => some 8
  | .mem (.array _) => some 8
  | .mem (.struct _) => none
def Check.sizeof : Typ.Check → Option Nat
  | .type t => t.sizeof
  | _ => none
end Typ