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

Authors: Mario Carneiro, Gabriel Ebner
-/
import Std.Data.Nat.Lemmas
import Std.Data.List.Lemmas
import Std.Tactic.HaveI
import Std.Tactic.Simpa

local macro_rules | `($x[$i]'$h) => `(getElem $x $i $h)

@[simp] theorem getElem_fin [GetElem Cont Nat Elem Dom] (a : Cont) (i : Fin n) (h : Dom a i) :
    a[i] = a[i.1] := rfl

@[simp] theorem getElem?_fin [GetElem Cont Nat Elem Dom] (a : Cont) (i : Fin n)
    [Decidable (Dom a i)] : a[i]? = a[i.1]? := rfl

@[simp] theorem getElem!_fin [GetElem Cont Nat Elem Dom] (a : Cont) (i : Fin n)
    [Decidable (Dom a i)] [Inhabited Elem] : a[i]! = a[i.1]! := rfl

theorem getElem?_pos [GetElem Cont Idx Elem Dom]
    (a : Cont) (i : Idx) (h : Dom a i) [Decidable (Dom a i)] : a[i]? = a[i] := dif_pos h

theorem getElem?_neg [GetElem Cont Idx Elem Dom]
    (a : Cont) (i : Idx) (h : ¬Dom a i) [Decidable (Dom a i)] : a[i]? = none := dif_neg h

@[simp] theorem mkArray_data (n : Nat) (v : α) : (mkArray n v).data = List.replicate n v := rfl

namespace Array

attribute [simp] isEmpty uget

@[simp] theorem singleton_def (v : α) : singleton v = #[v] := rfl

@[simp] theorem toArray_data : (a : Array α) → a.data.toArray = a
  | ⟨l⟩ => ext' (data_toArray l)

@[simp] theorem get_eq_getElem (a : Array α) (i : Fin _) : a.get i = a[i.1] := rfl
@[simp] theorem get?_eq_getElem? (a : Array α) (i : Nat) : a.get? i = a[i]? := rfl
theorem getElem_fin_eq_data_get (a : Array α) (i : Fin _) : a[i] = a.data.get i := rfl

@[simp] theorem ugetElem_eq_getElem (a : Array α) {i : USize} (h : i.toNat < a.size) :
  a[i] = a[i.toNat] := rfl

theorem getElem?_eq_getElem (a : Array α) (i : Nat) (h : i < a.size) : a[i]? = a[i] :=
  getElem?_pos ..

theorem get?_len_le (a : Array α) (i : Nat) (h : a.size ≤ i) : a[i]? = none := by
  simp [getElem?_neg, h]

theorem getElem_mem_data (a : Array α) (h : i < a.size) : a[i] ∈ a.data := by
  simp [getElem_eq_data_get, List.get_mem]

theorem getElem?_eq_data_get? (a : Array α) (i : Nat) : a[i]? = a.data.get? i := by
  by_cases i < a.size <;> simp_all [getElem?_pos, getElem?_neg, List.get?_eq_get, eq_comm]; rfl

theorem get?_eq_data_get? (a : Array α) (i : Nat) : a.get? i = a.data.get? i :=
  getElem?_eq_data_get? ..

@[simp] theorem getD_eq_get? (a : Array α) (n d) : a.getD n d = (a.get? n).getD d := by
  simp [get?, getD]; split <;> simp

theorem get!_eq_getD [Inhabited α] (a : Array α) : a.get! n = a.getD n default := rfl

@[simp] theorem get!_eq_get? [Inhabited α] (a : Array α) : a.get! n = (a.get? n).getD default := by
  simp [get!_eq_getD]

@[simp] theorem back_eq_back? [Inhabited α] (a : Array α) : a.back = a.back?.getD default := by
  simp [back, back?]

@[simp] theorem back?_push (a : Array α) : (a.push x).back? = some x := by
  simp [back?, getElem?_eq_data_get?]

theorem back_push [Inhabited α] (a : Array α) : (a.push x).back = x := by simp

theorem get?_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
    (a.push x)[i]? = some a[i] := by
  rw [getElem?_pos, get_push_lt]

theorem get?_push_eq (a : Array α) (x : α) : (a.push x)[a.size]? = some x := by
  rw [getElem?_pos, get_push_eq]

@[simp] theorem data_set (a : Array α) (i v) : (a.set i v).data = a.data.set i.1 v := rfl

@[simp] theorem get_set_eq (a : Array α) (i : Fin a.size) (v : α) :
    (a.set i v)[i.1]'(by simp [i.2]) = v := by
  simp only [set, getElem_eq_data_get, List.get_set_eq]

@[simp] theorem get_set_ne (a : Array α) (i : Fin a.size) {j : Nat} (v : α) (hj : j < a.size)
    (h : i.1 ≠ j) : (a.set i v)[j]'(by simp [*]) = a[j] := by
  simp only [set, getElem_eq_data_get, List.get_set_ne h]

@[simp] theorem get?_set_eq (a : Array α) (i : Fin a.size) (v : α) :
    (a.set i v)[i.1]? = v := by simp [getElem?_pos, i.2]

@[simp] theorem get?_set_ne (a : Array α) (i : Fin a.size) {j : Nat} (v : α)
    (h : i.1 ≠ j) : (a.set i v)[j]? = a[j]? := by
  by_cases j < a.size <;> simp [getElem?_pos, getElem?_neg, *]

theorem get?_set (a : Array α) (i : Fin a.size) (j : Nat) (v : α) :
    (a.set i v)[j]? = if i.1 = j then some v else a[j]? := by
  if h : i.1 = j then subst j; simp [*] else simp [*]

theorem get_set (a : Array α) (i : Fin a.size) (j : Nat) (hj : j < a.size) (v : α) :
    (a.set i v)[j]'(by simp [*]) = if i = j then v else a[j] := by
  if h : i.1 = j then subst j; simp [*] else simp [*]

private theorem fin_cast_val (e : n = n') (i : Fin n) : e ▸ i = ⟨i.1, e ▸ i.2⟩ := by cases e; rfl

theorem swap_def (a : Array α) (i j : Fin a.size) :
    a.swap i j = (a.set i (a.get j)).set ⟨j.1, by simp [j.2]⟩ (a.get i) := by
  simp [swap, fin_cast_val]

theorem data_swap (a : Array α) (i j : Fin a.size) :
    (a.swap i j).data = (a.data.set i (a.get j)).set j (a.get i) := by simp [swap_def]

theorem get?_swap (a : Array α) (i j : Fin a.size) (k : Nat) : (a.swap i j)[k]? =
    if j = k then some a[i.1] else if i = k then some a[j.1] else a[k]? := by
  simp [swap_def, get?_set, ← getElem_fin_eq_data_get]

@[simp] theorem swapAt_def (a : Array α) (i : Fin a.size) (v : α) :
    a.swapAt i v = (a[i.1], a.set i v) := rfl

-- @[simp] -- FIXME: gives a weird linter error

@[simp] theorem data_pop (a : Array α) : a.pop.data = a.data.dropLast := by simp [pop]

@[simp] theorem pop_empty : (#[] : Array α).pop = #[] := rfl

@[simp] theorem pop_push (a : Array α) : (a.push x).pop = a := by simp [pop]

theorem SatisfiesM_foldrM [Monad m] [LawfulMonad m]
    {as : Array α} (motive : Nat → β → Prop)
    {init : β} (h0 : motive as.size init) {f : α → β → m β}
    (hf : ∀ i : Fin as.size, ∀ b, motive (i.1 + 1) b → SatisfiesM (motive i.1) (f as[i] b)) :
    SatisfiesM (motive 0) (as.foldrM f init) := by
  let rec go {i b} (hi : i ≤ as.size) (H : motive i b) :
    SatisfiesM (motive 0) (foldrM.fold f as 0 i hi b) := by
    unfold foldrM.fold; simp; split
    · next hi => exact .pure (hi ▸ H)
    · next hi =>
      split; {simp at hi}
      · next i hi' =>
        exact (hf ⟨i, hi'⟩ b H).bind fun _ => go _
  simp [foldrM]; split; {exact go _ h0}
  · next h => exact .pure (Nat.eq_zero_of_nonpos _ h ▸ h0)

theorem foldr_induction
    {as : Array α} (motive : Nat → β → Prop) {init : β} (h0 : motive as.size init) {f : α → β → β}
    (hf : ∀ i : Fin as.size, ∀ b, motive (i.1 + 1) b → motive i.1 (f as[i] b)) :
    motive 0 (as.foldr f init) := by
  have := SatisfiesM_foldrM (m := Id) (as := as) (f := f) motive h0
  simp [SatisfiesM_Id_eq] at this
  exact this hf

theorem mapM_eq_mapM_data [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
    arr.mapM f = return mk (← arr.data.mapM f) := by
  rw [mapM, foldlM_eq_foldlM_data, ← List.foldrM_reverse, mkEmpty_eq]
  conv => rhs; rw [← List.reverse_reverse arr.data]
  induction arr.data.reverse with
  | nil => simp; rfl
  | cons a l ih => simp [ih]; simp [push]

theorem SatisfiesM_mapIdxM [Monad m] [LawfulMonad m] (as : Array α) (f : Fin as.size → α → m β)
    (motive : Nat → Prop) (h0 : motive 0)
    (p : Fin as.size → β → Prop)
    (hs : ∀ i, motive i.1 → SatisfiesM (p i · ∧ motive (i + 1)) (f i as[i])) :
    SatisfiesM
      (fun arr => motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p ⟨i, h⟩ (arr[i]'(eq ▸ h)))
      (Array.mapIdxM as f) := by
  let rec go {bs i j h} (h₁ : j = bs.size) (h₂ : ∀ i h h', p ⟨i, h⟩ bs[i]) (hm : motive j) :
    SatisfiesM
      (fun arr => motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p ⟨i, h⟩ (arr[i]'(eq ▸ h)))
      (Array.mapIdxM.map as f i j h bs) := by
    induction i generalizing j bs with simp [mapIdxM.map]
    | zero =>
      have := (Nat.zero_add _).symm.trans h
      exact .pure ⟨this ▸ hm, h₁ ▸ this, fun _ _ => h₂ ..⟩
    | succ i ih =>
      refine (hs _ (by exact hm)).bind fun b hb => ih (by simp [h₁]) (fun i hi hi' => ?_) hb.2
      simp at hi'; simp [get_push]; split
      · next h => exact h₂ _ _ h
      · next h => cases h₁.symm ▸ (Nat.le_or_eq_of_le_succ hi').resolve_left h; exact hb.1
  simp [mapIdxM]; exact go rfl (fun.) h0

theorem mapIdx_induction (as : Array α) (f : Fin as.size → α → β)
    (motive : Nat → Prop) (h0 : motive 0)
    (p : Fin as.size → β → Prop)
    (hs : ∀ i, motive i.1 → p i (f i as[i]) ∧ motive (i + 1)) :
    motive as.size ∧ ∃ eq : (Array.mapIdx as f).size = as.size,
      ∀ i h, p ⟨i, h⟩ ((Array.mapIdx as f)[i]'(eq ▸ h)) := by
  have := SatisfiesM_mapIdxM (m := Id) (as := as) (f := f) motive h0
  simp [SatisfiesM_Id_eq] at this
  exact this _ hs

theorem mapIdx_induction' (as : Array α) (f : Fin as.size → α → β)
    (p : Fin as.size → β → Prop) (hs : ∀ i, p i (f i as[i])) :
    ∃ eq : (Array.mapIdx as f).size = as.size,
      ∀ i h, p ⟨i, h⟩ ((Array.mapIdx as f)[i]'(eq ▸ h)) :=
  (mapIdx_induction _ _ (fun _ => True) trivial p fun _ _ => ⟨hs .., trivial⟩).2

@[simp] theorem size_mapIdx (a : Array α) (f : Fin a.size → α → β) : (a.mapIdx f).size = a.size :=
  (mapIdx_induction' (p := fun _ _ => True) (hs := fun _ => trivial)).1

@[simp] theorem getElem_mapIdx (a : Array α) (f : Fin a.size → α → β) (i : Nat) (h) :
    haveI : i < a.size := by simp_all
    (a.mapIdx f)[i]'h = f ⟨i, this⟩ a[i] :=
  (mapIdx_induction' _ _ (fun i b => b = f i a[i]) fun _ => rfl).2 i _

@[simp] theorem size_swap! (a : Array α) (i j) (hi : i < a.size) (hj : j < a.size) :
    (a.swap! i j).size = a.size := by simp [swap!, hi, hj]

@[simp] theorem size_reverse (a : Array α) : a.reverse.size = a.size := by
  let rec go (as : Array α) (i j) : (reverse.loop as i j).size = as.size := by
    rw [reverse.loop]
    if h : i < j then
      have := reverse.termination h
      simp [(go · (i+1) ⟨j-1, ·⟩), h]
    else simp [h]
  simp only [reverse]; split <;> simp [go]
termination_by _ => j - i

@[simp] theorem reverse_data (a : Array α) : a.reverse.data = a.data.reverse := by
  let rec go (as : Array α) (i j hj)
      (h : i + j + 1 = a.size) (h₂ : as.size = a.size)
      (H : ∀ k, as.data.get? k = if i ≤ k ∧ k ≤ j then a.data.get? k else a.data.reverse.get? k)
      (k) : (reverse.loop as i ⟨j, hj⟩).data.get? k = a.data.reverse.get? k := by
    rw [reverse.loop]; dsimp; split <;> rename_i h₁
    · have := reverse.termination h₁
      match j with | j+1 => ?_
      simp at *
      simp; rw [(go · (i+1) j)]
      · rwa [Nat.add_right_comm i]
      · simp [size_swap, h₂]
      · intro k
        rw [← getElem?_eq_data_get?, get?_swap]
        simp [getElem?_eq_data_get?, getElem_eq_data_get, ← List.get?_eq_get, H, Nat.le_of_lt h₁]
        split <;> rename_i h₂
        · simp [← h₂, Nat.not_le.2 (Nat.lt_succ_self _)]
          exact (List.get?_reverse' _ _ (Eq.trans (by simp_arith) h)).symm
        split <;> rename_i h₃
        · simp [← h₃, Nat.not_le.2 (Nat.lt_succ_self _)]
          exact (List.get?_reverse' _ _ (Eq.trans (by simp_arith) h)).symm
        simp only [Nat.succ_le, Nat.lt_iff_le_and_ne.trans (and_iff_left h₃),
          Nat.lt_succ.symm.trans (Nat.lt_iff_le_and_ne.trans (and_iff_left (Ne.symm h₂)))]
    · rw [H]; split <;> rename_i h₂
      · cases Nat.le_antisymm (Nat.not_lt.1 h₁) (Nat.le_trans h₂.1 h₂.2)
        cases Nat.le_antisymm h₂.1 h₂.2
        exact (List.get?_reverse' _ _ h).symm
      · rfl
  simp only [reverse]; split
  · match a with | ⟨[]⟩ | ⟨[_]⟩ => rfl
  · have := Nat.sub_add_cancel (Nat.le_of_not_le ‹_›)
    refine List.ext <| go _ _ _ _ (by simp [this]) rfl fun k => ?_
    split; {rfl}; rename_i h
    simp [← show k < _ + 1 ↔ _ from Nat.lt_succ (n := a.size - 1), this] at h
    rw [List.get?_eq_none.2 ‹_›, List.get?_eq_none.2 (a.data.length_reverse ▸ ‹_›)]
termination_by _ => j - i

@[simp] theorem size_ofFn_go {n} (f : Fin n → α) (i acc) :
    (ofFn.go f i acc).size = acc.size + (n - i) := by
  if hin : i < n then
    unfold ofFn.go
    have : 1 + (n - (i + 1)) = n - i :=
      Nat.sub_sub .. ▸ Nat.add_sub_cancel' (Nat.le_sub_of_add_le (Nat.add_comm .. ▸ hin))
    rw [dif_pos hin, size_ofFn_go f (i+1), size_push, Nat.add_assoc, this]
  else
    have : n - i = 0 := Nat.sub_eq_zero_of_le (Nat.le_of_not_lt hin)
    unfold ofFn.go
    simp [hin, this]
termination_by _ => n - i

@[simp] theorem size_ofFn (f : Fin n → α) : (ofFn f).size = n := by simp [ofFn]

theorem getElem_ofFn_go (f : Fin n → α) (i) {acc k}
    (hki : k < n) (hin : i ≤ n) (hi : i = acc.size)
    (hacc : ∀ j, ∀ hj : j < acc.size, acc[j] = f ⟨j, Nat.lt_of_lt_of_le hj (hi ▸ hin)⟩) :
    haveI : acc.size + (n - acc.size) = n := Nat.add_sub_cancel' (hi ▸ hin)
    (ofFn.go f i acc)[k]'(by simp [*]) = f ⟨k, hki⟩ := by
  unfold ofFn.go
  if hin : i < n then
    have : 1 + (n - (i + 1)) = n - i :=
      Nat.sub_sub .. ▸ Nat.add_sub_cancel' (Nat.le_sub_of_add_le (Nat.add_comm .. ▸ hin))
    simp only [dif_pos hin]
    rw [getElem_ofFn_go f (i+1) _ hin (by simp [*]) (fun j hj => ?hacc)]
    cases (Nat.lt_or_eq_of_le <| Nat.le_of_lt_succ (by simpa using hj)) with
    | inl hj => simp [get_push, hj, hacc j hj]
    | inr hj => simp [get_push, *]
  else
    simp [hin, hacc k (Nat.lt_of_lt_of_le hki (Nat.le_of_not_lt (hi ▸ hin)))]
termination_by _ => n - i

@[simp] theorem getElem_ofFn (f : Fin n → α) (i : Nat) (h) :
    (ofFn f)[i] = f ⟨i, size_ofFn f ▸ h⟩ :=
  getElem_ofFn_go _ _ _ (by simp) (by simp) fun.


example (h : α = β) : h ▸ (a : α) = (b : β) := _
example (h : α = β) : id h ▸ (a : α) = (b : β) := _
example (h : α = β) : id h ▸ (a : α) = (b : β) := by simp
set_option pp.proofs.withType false
example (h : α = β) : id h ▸ (a : α) = (b : β) := _
set_option pp.proofs true
example (h : α = β) : id h ▸ (a : α) = (b : β) := _


/-
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.immersion
import morphisms.radicial
import for_mathlib.pullback_lift_comp

/-!
# Separated morphisms

A morphism of schemes `f : X ⟶ Y` is separated if the diagonal morphism `X ⟶ X ×[Y] X` is
a closed immersion.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

open_locale algebraic_geometry

namespace algebraic_geometry

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

/-- A morphism is `separated` if diagonal map is a closed immersion. -/
@[mk_iff]
class separated (f : X ⟶ Y) : Prop :=
(diagonal_is_closed_immersion : is_closed_immersion (pullback.diagonal f))

attribute [instance] separated.diagonal_is_closed_immersion

/-- A scheme is separated if it is separated over `Spec ℤ`. -/
@[mk_iff]
class is_separated (X : Scheme) : Prop :=
(out : separated (terminal.from X))

attribute [instance] is_separated.out

lemma separated_eq_diagonal_is_is_closed_immersion :
  @separated = morphism_property.diagonal @is_closed_immersion :=
by { ext, exact separated_iff _ }

lemma separated_eq_affine_property_diagonal :
  @separated =
    target_affine_locally is_closed_immersion.affine_property.diagonal :=
begin
  rw [separated_eq_diagonal_is_is_closed_immersion, is_closed_immersion_eq_affine_property],
  exact diagonal_target_affine_locally_eq_target_affine_locally
    _ is_closed_immersion.affine_property_is_local
end

@[priority 100]
instance separated.to_quasi_separated [separated f] : quasi_separated f := ⟨infer_instance⟩

lemma separated_of_injective (hf : function.injective f.1.base) : separated f :=
⟨pullback.diagonal_is_closed_immersion_of_injective f hf⟩

@[priority 100]
instance separated_of_radicial [radicial f] : separated f :=
separated_of_injective f (radicial.base_injective f)

lemma separated_stable_under_composition :
  morphism_property.stable_under_composition @separated :=
separated_eq_diagonal_is_is_closed_immersion.symm ▸
  is_closed_immersion_stable_under_composition.diagonal
    is_closed_immersion_respects_iso
    is_closed_immersion_stable_under_base_change

lemma separated_stable_under_base_change :
  morphism_property.stable_under_base_change @separated :=
separated_eq_diagonal_is_is_closed_immersion.symm ▸
  is_closed_immersion_stable_under_base_change.diagonal
    is_closed_immersion_respects_iso

instance separated_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [separated f] [separated g] : separated (f ≫ g) :=
separated_stable_under_composition f g infer_instance infer_instance

lemma separated_respects_iso : morphism_property.respects_iso @separated :=
separated_eq_diagonal_is_is_closed_immersion.symm ▸
  is_closed_immersion_respects_iso.diagonal

lemma separated.is_local_at_target :
  property_is_local_at_target @separated :=
separated_eq_affine_property_diagonal.symm ▸
  is_closed_immersion.affine_property_is_local.diagonal.target_affine_locally_is_local

lemma separated.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
  tfae [separated f,
    ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
      separated (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
      separated (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
    ∀ (U : opens Y.carrier), separated (f ∣_ U),
    ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
      separated (pullback.snd : pullback f g ⟶ _),
    ∃ {ι : Type u} (U : ι → opens Y.carrier) (hU : supr U = ⊤),
      ∀ i, separated (f ∣_ (U i))] :=
separated.is_local_at_target.open_cover_tfae f

lemma affine_le_separated :
  @affine ≤ @separated :=
begin
  rw [affine_eq_affine_property, ← separated.is_local_at_target.target_affine_locally_eq],
  apply target_affine_locally_mono,
  rintros X Y f H (hf : is_affine X),
  resetI,
  rw [← separated_respects_iso.cancel_right_is_iso _ (Γ_Spec.adjunction.unit.app Y),
    ← Γ_Spec.adjunction.unit_naturality f, separated_respects_iso.cancel_left_is_iso,
    functor.right_op_map],
  exact ⟨is_closed_immersion_pullback_diagonal_Spec (Scheme.Spec.map (Scheme.Γ.map f.op).op)⟩
end

@[priority 100]
instance affine.to_separated [affine f] : separated f := affine_le_separated _ _ _ infer_instance

lemma is_closed_immersion.of_comp_of_is_immersion [is_closed_immersion (f ≫ g)] [is_immersion g] :
  is_closed_immersion f :=
begin
  haveI := is_immersion.of_comp_of_is_immersion f g,
  apply is_closed_immersion.of_is_immersion,
  rw [← set.preimage_image_eq (set.range _) (is_immersion.base_embedding g).inj,
    ← set.range_comp, ← coe_comp, ← Scheme.comp_val_base],
  exact (is_closed_immersion.base_closed $ f ≫ g).2.preimage g.1.base.2,
end

lemma separated_of_comp {Z : Scheme} (g : Y ⟶ Z) [H : separated (f ≫ g)] : separated f :=
begin
  constructor,
  apply_with is_closed_immersion.of_comp_of_is_immersion { instances := ff },
  { rwa [separated_iff, pullback.diagonal_comp] at H },
  rw [is_immersion_respects_iso.cancel_left_is_iso],
  apply_instance
end

@[priority 100]
instance is_affine.to_is_separated [is_affine X] : is_separated X := ⟨infer_instance⟩

lemma separated_of_comp_iff {Z : Scheme} (g : Y ⟶ Z) [separated g] :
  separated (f ≫ g) ↔ separated f :=
⟨λ h, by exactI separated_of_comp f g, λ h, by exactI infer_instance⟩

lemma separated_over_is_separated_iff [is_separated Y] :
  separated f ↔ is_separated X :=
by { rw [is_separated_iff, ← terminal.comp_from f], exact (separated_of_comp_iff _ _).symm }

@[priority 100]
instance separated.of_is_separated [is_separated X] : separated f :=
@@separated_of_comp f (terminal.from Y) (by { rw terminal.comp_from, apply_instance })

lemma is_separated_of_separated [is_separated Y] [separated f] : is_separated X :=
begin
  rw [is_separated_iff, ← terminal.comp_from f],
  apply_instance
end

def separated.affine_property : affine_target_morphism_property :=
λ X Y f _, is_separated X

lemma separated_eq_affine_property : @separated = target_affine_locally separated.affine_property :=
begin
  rw ← separated.is_local_at_target.target_affine_locally_eq,
  congr' 1,
  ext X Y f hY,
  exactI separated_over_is_separated_iff f
end

-- lemma separated.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
--   [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
--   separated f ↔ ∀ i, is_separated (pullback f (𝒰.map i)) :=
-- begin
--   rw [separated_eq_affine_property,
--     separated.affine_property_is_local.affine_open_cover_iff f 𝒰],
--   refl,
-- end

lemma separated.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  (f : X ⟶ Y) :
  separated f ↔ ∀ i, separated (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
separated.is_local_at_target.open_cover_iff f 𝒰

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [separated g] :
  separated (pullback.fst : pullback f g ⟶ X) :=
separated_stable_under_base_change.fst f g infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [separated f] :
  separated (pullback.snd : pullback f g ⟶ Y) :=
separated_stable_under_base_change.snd f g infer_instance

instance {X Y Z: Scheme} (f : X ⟶ Y) (g : Y ⟶ Z) [separated f] [separated g] :
  separated (f ≫ g) :=
separated_stable_under_composition f g infer_instance infer_instance

instance {S T : Scheme} (f : X ⟶ S) (g : Y ⟶ S) (i : S ⟶ T) :
  is_immersion (pullback.map_desc f g i) :=
is_immersion_stable_under_base_change (pullback_map_diagonal_is_pullback f g i) infer_instance

instance {S T : Scheme} (f : X ⟶ S) (g : Y ⟶ S) (i : S ⟶ T) [separated i] :
  is_closed_immersion (pullback.map_desc f g i) :=
is_closed_immersion_stable_under_base_change (pullback_map_diagonal_is_pullback f g i)
  infer_instance

instance {S T : Scheme} (f : X ⟶ S) (g : Y ⟶ S) (i : S ⟶ T) [quasi_separated i] :
  quasi_compact (pullback.map_desc f g i) :=
quasi_compact_stable_under_base_change (pullback_map_diagonal_is_pullback f g i)
  infer_instance

lemma is_affine_open.inter [is_separated X] {U V : opens X.carrier} (hU : is_affine_open U)
  (hV : is_affine_open V) : is_affine_open (U ⊓ V) :=
begin
  haveI : is_affine _ := hU,
  haveI : is_affine _ := hV,
  haveI : is_affine (pullback (X.of_restrict U.open_embedding) (X.of_restrict V.open_embedding)),
  { apply is_affine_of_affine (pullback.map_desc (X.of_restrict U.open_embedding)
      (X.of_restrict V.open_embedding) (terminal.from X)) },
  have : (pullback (X.of_restrict U.open_embedding) (X.of_restrict V.open_embedding)) ≅
    X.restrict (U ⊓ V).open_embedding,
  { refine is_open_immersion.iso_of_range_eq (pullback.fst ≫ X.of_restrict _) (X.of_restrict _) _,
    simp_rw [is_open_immersion.range_pullback_to_base_of_left, Scheme.of_restrict_val_base,
      opens.range_inclusion], refl },
  exact is_affine_of_iso this.inv
end

instance : is_immersion (pullback.lift_comp f g) :=
begin
  rw is_immersion_respects_iso.arrow_mk_iso_iff (pullback.lift_comp_iso_map_desc f g),
  apply_instance
end

instance [separated g] : is_closed_immersion (pullback.lift_comp f g) :=
begin
  rw is_closed_immersion_respects_iso.arrow_mk_iso_iff (pullback.lift_comp_iso_map_desc f g),
  apply_instance
end

instance [quasi_separated g] : quasi_compact (pullback.lift_comp f g) :=
begin
  rw quasi_compact_respects_iso.arrow_mk_iso_iff (pullback.lift_comp_iso_map_desc f g),
  apply_instance
end

instance is_immersion_of_is_split_mono [is_split_mono f] : is_immersion f :=
begin
  have : pullback.map_desc f (𝟙 _) (retraction f) ≫ pullback.snd = pullback.fst ≫ f,
  { rw [pullback.lift_snd, pullback.condition] },
  rw ← is_iso.inv_comp_eq at this,
  rw ← this,
  haveI : is_iso (f ≫ retraction f) := by { rw is_split_mono.id, apply_instance },
  apply_instance
end

lemma quasi_compact_of_comp [quasi_compact (f ≫ g)] [quasi_separated g] : quasi_compact f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

lemma quasi_compact_of_comp_surjective [quasi_compact (f ≫ g)] [surjective f] : quasi_compact g :=
begin
  constructor,
  intros U hU hU',
  convert is_compact.image (quasi_compact.is_compact_preimage (f ≫ g) U hU hU') f.1.base.2 using 1,
  rw [Scheme.comp_val_base, coe_comp, @set.preimage_comp _ _ _ f.1.base,
      continuous_map.to_fun_eq_coe, set.image_preimage_eq _ (surjective.out f)]
end

lemma is_immersion_of_comp [is_immersion (f ≫ g)] : is_immersion f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

lemma is_closed_immersion_of_comp [is_closed_immersion (f ≫ g)] [separated g] :
  is_closed_immersion f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

lemma finite_of_comp [finite (f ≫ g)] [separated g] : finite f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

lemma integral_of_comp [integral (f ≫ g)] [separated g] : integral f :=
by { rw [← pullback.lift_comp_snd f g], apply_instance }

end algebraic_geometry


-- TODO: generate point-free lemmas
-- use registerSimpAttr to create simp rewrite sets

import Lib.Algebra.Monoid
import Lib.Data.Foldable
import Lib.Data.Functor
import Lib.Function

class Traversable (T : Type u → Type u) extends Functor T, Foldable T where
  traverse {F : Type u → Type u} [Applicative F] (f : α → F β) : T α → F (T β)
  mapM {F : Type u → Type u} [Monad F] (f : α → F β) : T α → F (T β)

namespace Traversable
end Traversable

open Traversable

def StateT.mk {σ α} (f : σ → m (α × σ)) : StateT σ m α := f

section Accum

variable {T : Type u → Type u} [Traversable T]
variable {α β : Type u} (f : α → σ → β × σ)

def accuml (x₀ : σ) (x : T α) : T β × σ :=
StateT.run (m := Id) (mapM (StateT.mk.{u,u} ∘ f) x) x₀

def scanl (x₀ : σ) (x : T α) : T β :=
StateT.run' (m := Id) (mapM (StateT.mk.{u,u} ∘ f) x) x₀

def accumr (x₀ : σ) (x : T α) : T β × σ :=
StateT.run (m := Id) (Op1.run (traverse (Op1.mk.{u,u} ∘ StateT.mk.{u,u} ∘ f) x)) x₀

def scanr (x₀ : σ) (x : T α) : T β :=
accumr f x₀ x |>.1

end Accum

section AccumIdx

variable {T : Type u → Type u} [Traversable.{u} T]
variable {α β : Type u} (f : Nat → α → σ → β × σ)

def accumlIdx (x₀ : σ) (x : T α) : T β × σ :=
accuml (λ a (x, i) => f i a x |>.map id (., i+1)) (x₀, 0) x |>.map id Prod.fst

def scanlIdx (x₀ : σ) (x : T α) : T β :=
accumlIdx f x₀ x |>.fst

end AccumIdx

class LawfulTraversable (T : Type u → Type u) [Traversable T]
extends LawfulFunctor T, LawfulFoldable T where
  traverse_eq_mapM {α β} {M} [Monad M] [LawfulMonad M] (f : α → M β) (x : T α) :
    traverse f x = mapM f x
  map_eq_traverse {α β} (f : α → β) (x : T α) :
    Functor.map f x = Id.run (traverse (Id.mk ∘ f) x)
  -- id_traverse {α} (x : T α) : traverse Id.mk x = Id.mk x
  comp_traverse {α} {F G} [Applicative F] [LawfulApplicative F]
    [Applicative G] [LawfulApplicative G]
    (x : T α) (f : β → F γ) (g : α → G β) :
    Comp.run (traverse (Comp.mk ∘ Functor.map f ∘ g) x) =
    traverse f <$> traverse g x
  foldl_eq_traverse {α β} (f : β → α → β) (x : T α) (x₀ : β) :
    Foldable.foldl f x₀ x =
    Endo.run (Op.run (Const.run (traverse
      (Const.mk (α := α) ∘ Op.mk ∘ Endo.mk ∘ flip f) x))) x₀
  traverse_sim {α} {F G}
               [Applicative F] [LawfulApplicative F]
               [Applicative G] [LawfulApplicative G]
               (x : T α) (R : ApplicativeRel F G)
               (f : α → F β) (g : α → G β) :
      (∀ a, R (f a) (g a)) →
      R (traverse f x) (traverse g x)

  -- traverse_nat {α} {F G} [Applicative F] [LawfulApplicative F]
  --   [Applicative G] [LawfulApplicative G]
  --   (x : T α) (f : ApplicativeHom F G) (g : α → F β) :
  --     f (traverse g x) = traverse (f.fn ∘ g) x

namespace LawfulTraversable

variable {T} [Traversable T] [LawfulTraversable T]

theorem id_traverse {α} (x : T α) : traverse Id.mk x = Id.mk x := by
have := (map_eq_traverse id x).symm
simp [id_map] at this; assumption

section nat
variable {T : Type u → Type u} [Traversable T] [LawfulTraversable T]
variable {F : Type u → Type u} [Applicative F] [LawfulApplicative F]
variable {G : Type u → Type u} [Applicative G] [LawfulApplicative G]

theorem traverse_nat {α}  (x : T α) (f : ApplicativeHom F G) (g : α → F β) :
      f (traverse g x) = traverse (f.fn ∘ g) x := by
let R := f.toApplicativeRel
apply LawfulTraversable.traverse_sim _ R; intro a
simp [ApplicativeHom.toApplicativeRel]

end nat

end LawfulTraversable

theorem Id.run_map {α β} (f : α → β) (x : Id α) :
  Id.run (f <$> x) = f (Id.run x) := rfl

section LawfulTraversable_of_hom

open Foldable LawfulTraversable Functor
open LawfulFoldable
variable {T₀} [Traversable T₀] [LawfulTraversable T₀]
variable {T₁} [Traversable T₁] [LawfulFoldable T₁]
              [LawfulFunctor T₁]

variable {f : {α : Type u} → T₁ α → T₀ α}
variable {g : {α : Type u} → T₀ α → T₁ α}
variable (Hinj : ∀ {α}, LeftInv (@f α) g)
variable (Hinj' : ∀ {α}, RightInv (@f α) g)
variable (Hmap : ∀ {α β} (x : T₁ α) (g : α → β),
               f (g <$> x) = g <$> f x)
variable (HmapConst : ∀ {α β} (x : T₁ α) (g : β),
               f (mapConst g x) = mapConst g (f x))
variable (Hfoldl : ∀ {α β} (x : T₁ α) (g : β → α → β) x₀,
               foldl g x₀ x = foldl g x₀ (f x))
variable (Hfoldr : ∀ {α β} (x : T₁ α) (g : α → β → β) x₀,
               foldr g x₀ x = foldr g x₀ (f x))
variable (Htraverse_f :
  ∀ {α β m} [Applicative m] (x : T₁ α) (g : α → m β),
               f <$> traverse g x = traverse g (f x))
variable (HmapM :
  ∀ {α β m} [Monad m] (x : T₁ α) (g : α → m β),
               f <$> mapM g x = mapM g (f x))

private theorem Htraverse_g {α β m} [Applicative m] [LawfulFunctor m]
        (x : T₀ α) (f : α → m β) :
  g <$> traverse f x = traverse f (g x) :=
Functor.Injective_map (Hinj.toHasLeftInv) _ _ $ by
rw [map_comp, Hinj', id_map, Htraverse_f, Hinj'.apply]

-- abbrev Map (F) [Functor F] (f : α → β) : F α → F β := map f

-- theorem Map_eq  (F) [Functor F] (f : α → β) : map f = Map F f := rfl

def LawfulTraversable_of_hom : LawfulTraversable T₁ where
  map_eq_traverse := by
    intros
    apply Injective_of_LeftInv Hinj
    rw [← Id.run_map f]
    simp [Hmap, Htraverse_f, map_eq_traverse, -Id.map_eq]
  foldr_eq_foldMap := foldr_eq_foldMap
  foldl_eq_traverse := by
    intros
    rw [Hfoldl, foldl_eq_traverse, ← Htraverse_f, Const.run_map]
  -- map_const := by
  --   intros; ext; simp only [(.∘.), HmapConst]
  --   -- apply Functor.Injective_map
  --   apply Injective_of_LeftInv Hinj
  --   simp [Hmap, HmapConst, map_const]
  -- id_map := by
  --   intros
  --   apply Injective_of_LeftInv Hinj
  --   simp [Hmap]
  -- comp_map := by
  --   intros
  --   apply Injective_of_LeftInv Hinj
  --   simp [Hmap]
  foldl_sim := foldl_sim
  toArray_toList := toArray_toList
  length_toList := length_toList
  foldl_toList := foldl_toList
  traverse_eq_mapM := by
    intros
    apply Functor.Injective_map (f := f)
    . apply HasLeftInv.intro; auto
    simp [HmapM, Htraverse_f, traverse_eq_mapM]
  comp_traverse := by
    intros α β γ F G; intros
    have : ∀ β x (y : G (F β)),
         Comp.run x = y ↔ x = Comp.mk y :=
      by intros; refl
    rw [this]
    apply Functor.Injective_map (f := f) Hinj.toHasLeftInv
    simp only [Htraverse_f, comp_traverse, Comp.map_mk]
    rw [← this, comp_traverse, ← Htraverse_f]
    simp only [map_comp]
    congr; ext;
    simp [(.∘.), Htraverse_f]
  traverse_sim x R := by
    intros
    rw [← Hinj.apply x]
    rw [← Htraverse_g Hinj Hinj' Htraverse_f]
    rw [← Htraverse_g Hinj Hinj' Htraverse_f]
    apply R.naturality; auto [traverse_sim]

end LawfulTraversable_of_hom

-- #exit


import Mathlib.Tactic.Clear!

-- Most basic test
example (delete_this : Nat) (_delete_this_dep : delete_this = delete_this) : Nat := by
  clear! delete_this
  fail_if_success assumption
  exact 0

-- Confirms clear! deletes class instances
example [delete_this : Inhabited Nat] : Inhabited Nat := by
  clear! delete_this
  fail_if_success assumption
  infer_instance

-- Confirms clear! can clear the dependencies of multiple hypotheses
example (delete_this : Nat) (delete_this2 : Nat) (_delete_this_dep : delete_this = delete_this2) : Nat := by
  clear! delete_this delete_this2
  fail_if_success assumption
  exact 0

-- Confirms that clear! does not delete independent hypotheses
example (delete_this : Nat) (dont_delete_this : Int) : Nat := by
  clear! delete_this
  fail_if_success assumption
  exact dont_delete_this.toNat

-- Confirms that clear! only deletes dependencies in the right direction
example (dont_delete_this : Nat) (delete_this : dont_delete_this = dont_delete_this) : Nat := by
  clear! delete_this
  assumption


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.tactic.lint.default
import Mathlib.PostPort

universes u v u_1 u_2 u_3 w

namespace Mathlib

/-!
# Functors

This module provides additional lemmas, definitions, and instances for `functor`s.

## Main definitions

* `const α` is the functor that sends all types to `α`.
* `add_const α` is `const α` but for when `α` has an additive structure.
* `comp F G` for functors `F` and `G` is the functor composition of `F` and `G`.
* `liftp` and `liftr` respectively lift predicates and relations on a type `α`
  to `F α`.  Terms of `F α` are considered to, in some sense, contain values of type `α`.

## Tags

functor, applicative
-/

theorem functor.map_id {F : Type u → Type v} {α : Type u} [Functor F] [is_lawful_functor F] :
    Functor.map id = id :=
  funext id_map

theorem functor.map_comp_map {F : Type u → Type v} {α : Type u} {β : Type u} {γ : Type u}
    [Functor F] [is_lawful_functor F] (f : α → β) (g : β → γ) :
    Functor.map g ∘ Functor.map f = Functor.map (g ∘ f) :=
  sorry

theorem functor.ext {F : Type u_1 → Type u_2} {F1 : Functor F} {F2 : Functor F}
    [is_lawful_functor F] [is_lawful_functor F]
    (H : ∀ (α β : Type u_1) (f : α → β) (x : F α), f <$> x = f <$> x) : F1 = F2 :=
  sorry

/-- Introduce the `id` functor. Incidentally, this is `pure` for
`id` as a `monad` and as an `applicative` functor. -/
def id.mk {α : Sort u} : α → id α := id

namespace functor

/-- `const α` is the constant functor, mapping every type to `α`. When
`α` has a monoid structure, `const α` has an `applicative` instance.
(If `α` has an additive monoid structure, see `functor.add_const`.) -/
def const (α : Type u_1) (β : Type u_2) := α

/-- `const.mk` is the canonical map `α → const α β` (the identity), and
it can be used as a pattern to extract this value. -/
def const.mk {α : Type u_1} {β : Type u_2} (x : α) : const α β := x

/-- `const.mk'` is `const.mk` but specialized to map `α` to
`const α punit`, where `punit` is the terminal object in `Type*`. -/
def const.mk' {α : Type u_1} (x : α) : const α PUnit := x

/-- Extract the element of `α` from the `const` functor. -/
def const.run {α : Type u_1} {β : Type u_2} (x : const α β) : α := x

namespace const

protected theorem ext {α : Type u_1} {β : Type u_2} {x : const α β} {y : const α β}
    (h : run x = run y) : x = y :=
  h

/-- The map operation of the `const γ` functor. -/
protected def map {γ : Type u_1} {α : Type u_2} {β : Type u_3} (f : α → β) (x : const γ β) :
    const γ α :=
  x

protected instance functor {γ : Type u_1} : Functor (const γ) :=
  { map := const.map, mapConst := fun (α β : Type u_2) => const.map ∘ function.const β }

protected instance is_lawful_functor {γ : Type u_1} : is_lawful_functor (const γ) :=
  is_lawful_functor.mk (fun (α : Type u_2) (x : const γ α) => Eq.refl (id <$> x))
    fun (α β γ_1 : Type u_2) (g : α → β) (h : β → γ_1) (x : const γ α) => Eq.refl ((h ∘ g) <$> x)

protected instance inhabited {α : Type u_1} {β : Type u_2} [Inhabited α] : Inhabited (const α β) :=
  { default := Inhabited.default }

end const

/-- `add_const α` is a synonym for constant functor `const α`, mapping
every type to `α`. When `α` has a additive monoid structure,
`add_const α` has an `applicative` instance. (If `α` has a
multiplicative monoid structure, see `functor.const`.) -/
def add_const (α : Type u_1) (β : Type u_2) := const α

/-- `add_const.mk` is the canonical map `α → add_const α β`, which is the identity,
where `add_const α β = const α β`. It can be used as a pattern to extract this value. -/
def add_const.mk {α : Type u_1} {β : Type u_2} (x : α) : add_const α β := x

/-- Extract the element of `α` from the constant functor. -/
def add_const.run {α : Type u_1} {β : Type u_2} : add_const α β → α := id

protected instance add_const.functor {γ : Type u_1} : Functor (add_const γ) := const.functor

protected instance add_const.is_lawful_functor {γ : Type u_1} : is_lawful_functor (add_const γ) :=
  const.is_lawful_functor

protected instance add_const.inhabited {α : Type u_1} {β : Type u_2} [Inhabited α] :
    Inhabited (add_const α β) :=
  { default := Inhabited.default }

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) := F (G α)

/-- Construct a term of `comp F G α` from a term of `F (G α)`, which is the same type.
Can be used as a pattern to extract a term of `F (G α)`. -/
def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : F (G α)) : comp F G α := x

/-- Extract a term of `F (G α)` from a term of `comp F G α`, which is the same type. -/
def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : comp F G α) : F (G α) :=
  x

namespace comp

protected theorem ext {F : Type u → Type w} {G : Type v → Type u} {α : Type v} {x : comp F G α}
    {y : comp F G α} : run x = run y → x = y :=
  id

protected instance inhabited {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
    [Inhabited (F (G α))] : Inhabited (comp F G α) :=
  { default := Inhabited.default }

/-- The map operation for the composition `comp F G` of functors `F` and `G`. -/
protected def map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v}
    {β : Type v} (h : α → β) : comp F G α → comp F G β :=
  sorry

protected instance functor {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] :
    Functor (comp F G) :=
  { map := comp.map, mapConst := fun (α β : Type v) => comp.map ∘ function.const β }

theorem map_mk {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v}
    {β : Type v} (h : α → β) (x : F (G α)) : h <$> mk x = mk (Functor.map h <$> x) :=
  rfl

@[simp] protected theorem run_map {F : Type u → Type w} {G : Type v → Type u} [Functor F]
    [Functor G] {α : Type v} {β : Type v} (h : α → β) (x : comp F G α) :
    run (h <$> x) = Functor.map h <$> run x :=
  rfl

protected theorem id_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G]
    [is_lawful_functor F] [is_lawful_functor G] {α : Type v} (x : comp F G α) : comp.map id x = x :=
  sorry

protected theorem comp_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G]
    [is_lawful_functor F] [is_lawful_functor G] {α : Type v} {β : Type v} {γ : Type v} (g' : α → β)
    (h : β → γ) (x : comp F G α) : comp.map (h ∘ g') x = comp.map h (comp.map g' x) :=
  sorry

protected instance is_lawful_functor {F : Type u → Type w} {G : Type v → Type u} [Functor F]
    [Functor G] [is_lawful_functor F] [is_lawful_functor G] : is_lawful_functor (comp F G) :=
  is_lawful_functor.mk comp.id_map comp.comp_map

theorem functor_comp_id {F : Type u_1 → Type u_2} [AF : Functor F] [is_lawful_functor F] :
    comp.functor = AF :=
  ext fun (α β : Type u_1) (f : α → β) (x : F α) => rfl

theorem functor_id_comp {F : Type u_1 → Type u_2} [AF : Functor F] [is_lawful_functor F] :
    comp.functor = AF :=
  ext fun (α β : Type u_1) (f : α → β) (x : F α) => rfl

end comp

namespace comp

/-- The `<*>` operation for the composition of applicative functors. -/
protected def seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G]
    {α : Type v} {β : Type v} : comp F G (α → β) → comp F G α → comp F G β :=
  sorry

protected instance has_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F]
    [Applicative G] : Pure (comp F G) :=
  { pure := fun (_x : Type v) (x : _x) => mk (pure (pure x)) }

protected instance has_seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F]
    [Applicative G] : Seq (comp F G) :=
  { seq := fun (_x _x_1 : Type v) (f : comp F G (_x → _x_1)) (x : comp F G _x) => comp.seq f x }

@[simp] protected theorem run_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F]
    [Applicative G] {α : Type v} (x : α) : run (pure x) = pure (pure x) :=
  idRhs (run (pure x) = run (pure x)) rfl

@[simp] protected theorem run_seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F]
    [Applicative G] {α : Type v} {β : Type v} (f : comp F G (α → β)) (x : comp F G α) :
    run (f <*> x) = Seq.seq <$> run f <*> run x :=
  rfl

protected instance applicative {F : Type u → Type w} {G : Type v → Type u} [Applicative F]
    [Applicative G] : Applicative (comp F G) :=
  { toFunctor := { map := comp.map, mapConst := fun (α β : Type v) => comp.map ∘ function.const β },
    toPure := { pure := pure }, toSeq := { seq := comp.seq },
    toSeqLeft :=
      { seqLeft :=
          fun (α β : Type v) (a : comp F G α) (b : comp F G β) =>
            comp.seq (comp.map (function.const β) a) b },
    toSeqRight :=
      { seqRight :=
          fun (α β : Type v) (a : comp F G α) (b : comp F G β) =>
            comp.seq (comp.map (function.const α id) a) b } }

end comp

/-- If we consider `x : F α` to, in some sense, contain values of type `α`,
predicate `liftp p x` holds iff every value contained by `x` satisfies `p`. -/
def liftp {F : Type u → Type u} [Functor F] {α : Type u} (p : α → Prop) (x : F α) :=
  ∃ (u : F (Subtype p)), subtype.val <$> u = x

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`liftr r x y` relates `x` and `y` iff (1) `x` and `y` have the same shape and
(2) we can pair values `a` from `x` and `b` from `y` so that `r a b` holds. -/
def liftr {F : Type u → Type u} [Functor F] {α : Type u} (r : α → α → Prop) (x : F α) (y : F α) :=
  ∃ (u : F (Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p))),
    (fun (t : Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p)) =>
            prod.fst (subtype.val t)) <$>
          u =
        x ∧
      (fun (t : Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p)) =>
            prod.snd (subtype.val t)) <$>
          u =
        y

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`supp x` is the set of values of type `α` that `x` contains. -/
def supp {F : Type u → Type u} [Functor F] {α : Type u} (x : F α) : set α :=
  set_of fun (y : α) => ∀ {p : α → Prop}, liftp p x → p y

theorem of_mem_supp {F : Type u → Type u} [Functor F] {α : Type u} {x : F α} {p : α → Prop}
    (h : liftp p x) (y : α) (H : y ∈ supp x) : p y :=
  hy h

end functor

namespace ulift

protected instance functor : Functor ulift :=
  { map := fun (α β : Type u_1) (f : α → β) => up ∘ f ∘ down,
    mapConst := fun (α β : Type u_1) => (fun (f : β → α) => up ∘ f ∘ down) ∘ function.const β }

end Mathlib


import Mathlib.Algebra.Group.Defs
import Mathlib.Tactic.Simps.Basic
import Mathlib.Tactic.RunCmd
import Mathlib.Lean.Exception
import Mathlib.Logic.Equiv.Defs
import Mathlib.Data.Prod.Basic

-- set_option trace.simps.debug true
-- set_option trace.simps.verbose true
-- set_option pp.universes true

open Lean Meta Elab Term Command Simps

structure Foo1 : Type where
  Projone : Nat
  two : Bool
  three : Nat → Bool
  four : 1 = 1
  five : 2 = 1

initialize_simps_projections Foo1 (Projone → toNat, two → toBool, three → coe, as_prefix coe,
  -toBool)

run_cmd liftTermElabM <| do
  let env ← getEnv
  let state := ((Simps.structureExt.getState env).find? `Foo1).get!
  guard <| state.1 == []
  guard <| state.2.map (·.1) == #[`toNat, `toBool, `coe, `four, `five]
  liftMetaM <| guard (← isDefEq (state.2[0]!.2) (← elabTerm (← `(Foo1.Projone)) none))
  liftMetaM <| guard (← isDefEq (state.2[1]!.2) (← elabTerm (← `(Foo1.two)) none))
  guard <| state.2.map (·.3) == (Array.range 5).map ([·])
  guard <| state.2.map (·.4) == #[true, false, true, false, false]
  guard <| state.2.map (·.5) == #[false, false, true, false, false]
  pure ()

structure Foo2 (α : Type _) : Type _ where
  elim : α × α

def Foo2.Simps.elim (α : Type _) : Foo2 α → α × α := fun x => (x.elim.1, x.elim.2)

initialize_simps_projections Foo2

@[simps]
def Foo2.foo2 : Foo2 Nat := ⟨(0, 0)⟩

-- run_cmd do
--   logInfo m!"{Simps.structureExt.getState (← getEnv) |>.find? `Foo2 |>.get!}"

structure Left (α : Type _) extends Foo2 α where
  moreData1 : Nat
  moreData2 : Nat

initialize_simps_projections Left

structure Right (α : Type u) (β : Type v) extends Foo2 α where
  otherData : β

initialize_simps_projections Right (elim → newProjection, -otherData, +toFoo2)

run_cmd liftTermElabM <| do
  let env ← getEnv
  let state := ((Simps.structureExt.getState env).find? `Right).get!
  -- logInfo m!"{state}"
  guard <| state.1 == [`u, `v]
  guard <| state.2.map (·.1) == #[`toFoo2, `otherData, `newProjection]
  guard <| state.2.map (·.3) == #[[0], [1], [0,0]]
  guard <| state.2.map (·.4) == #[true, false, true]
  guard <| state.2.map (·.5) == #[false, false, false]

structure Top (α β : Type _) extends Left α, Right α β

initialize_simps_projections Top

structure NewTop (α β : Type _) extends Right α β, Left α

def NewTop.Simps.newElim {α β : Type _} (x : NewTop α β) : α × α := x.elim

initialize_simps_projections NewTop (elim → newElim)

run_cmd liftCoreM <| successIfFail <| getRawProjections .missing `DoesntExist

class Something (α : Type _) where
  op : α → α → α → α

instance {α : Type _} [Something α] : Add α :=
⟨λ x y => Something.op x y y⟩

initialize_simps_projections Something

universe v u w

structure Equiv' (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)
(left_inv  : invFun.LeftInverse toFun)
(right_inv : invFun.RightInverse toFun)

infix:25 (priority := default+1) " ≃ " => Equiv'

/- Since `prod` and `PProd` are a special case for `@[simps]`, we define a new structure to test
  the basic functionality.-/
structure MyProd (α β : Type _) := (fst : α) (snd : β)

def MyProd.map {α α' β β'} (f : α → α') (g : β → β') (x : MyProd α β) : MyProd α' β' :=
⟨f x.1, g x.2⟩

namespace foo
@[simps] protected def rfl {α} : α ≃ α :=
⟨id, λ x => x, λ _ => rfl, λ _ => rfl⟩

/- simps adds declarations -/
run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `foo.rfl_toFun |>.isSome
  guard <| env.find? `foo.rfl_invFun |>.isSome
  guard <| env.find? `foo.rfl_left_inv |>.isNone
  guard <| env.find? `foo.rfl_right_inv |>.isNone
  guard <| simpsAttr.getParam? env `foo.rfl == #[`foo.rfl_toFun, `foo.rfl_invFun]

example (n : ℕ) : foo.rfl.toFun n = n := by rw [foo.rfl_toFun, id]
example (n : ℕ) : foo.rfl.invFun n = n := by rw [foo.rfl_invFun]

/- the declarations are `simp` lemmas -/
@[simps] def foo : ℕ × ℤ := (1, 2)

-- note: in Lean 4 the first test succeeds without `@[simps]`, however, the remaining tests don't
example : foo.1 = 1 := by simp
example {a : ℕ} {h : 1 = a} : foo.1 = a := by rw [foo_fst, h]
example {a : ℕ} {h : 1 = a} : foo.1 = a := by simp; rw [h]
example {a : ℤ} {h : 2 = a} : foo.2 = a := by simp; rw [h]
example {a : ℕ} {h : 1 = a} : foo.1 = a := by dsimp; rw [h] -- check that dsimp also unfolds
example {a : ℤ} {h : 2 = a} : foo.2 = a := by dsimp; rw [h]
example {α} (x y : α) (h : x = y) : foo.rfl.toFun x = y := by simp; rw [h]
example {α} (x y : α) (h : x = y) : foo.rfl.invFun x = y := by simp; rw [h]
-- example {α} (x y : α) (h : x = y) : foo.rfl.toFun = @id α := by { successIfFail {simp}, rfl }

/- check some failures -/
def bar1 : ℕ := 1 -- type is not a structure
noncomputable def bar2 {α} : α ≃ α :=
Classical.choice ⟨foo.rfl⟩

run_cmd liftCoreM <| do
  _ ← successIfFail <| simpsTac .missing `foo.bar1 { rhsMd := .default, simpRhs := true }
  --   "Invalid `simps` attribute. Target Nat is not a structure"
  _ ← successIfFail <| simpsTac .missing `foo.bar2 { rhsMd := .default, simpRhs := true }
  --   "Invalid `simps` attribute. The body is not a constructor application:
  -- Classical.choice (_ : Nonempty (α ≃ α))"
  pure ()

/- test that if a non-constructor is given as definition, then
  `{rhsMd := .default, simpRhs := true}` is applied automatically. -/
@[simps!] def rfl2 {α} : α ≃ α := foo.rfl

example {α} (x : α) : rfl2.toFun x = x ∧ rfl2.invFun x = x := by
  dsimp
  guard_target = x = x ∧ x = x
  exact ⟨rfl, rfl⟩

example {α} (x : α) : rfl2.toFun x = x ∧ rfl2.invFun x = x := by
  dsimp only [rfl2_toFun, rfl2_invFun]
  guard_target = x = x ∧ x = x
  exact ⟨rfl, rfl⟩

/- test `fullyApplied` option -/

@[simps (config := {fullyApplied := false})]
def rfl3 {α} : α ≃ α := ⟨id, λ x => x, λ _ => rfl, λ _ => rfl⟩

end foo

/- we reduce the type when applying [simps] -/
def my_equiv := Equiv'
@[simps] def baz : my_equiv ℕ ℕ := ⟨id, λ x => x, λ _ => rfl, λ _ => rfl⟩

/- todo: test that name clashes gives an error -/

/- check projections for nested structures -/

namespace CountNested
@[simps]
def nested1 : MyProd ℕ $ MyProd ℤ ℕ :=
⟨2, -1, 1⟩

@[simps (config := .lemmasOnly)]
def nested2 : ℕ × MyProd ℕ ℕ :=
⟨2, MyProd.map Nat.succ Nat.pred ⟨1, 2⟩⟩

end CountNested

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `CountNested.nested1_fst |>.isSome
  guard <| env.find? `CountNested.nested1_snd_fst |>.isSome
  guard <| env.find? `CountNested.nested1_snd_snd |>.isSome
  guard <| env.find? `CountNested.nested2_fst |>.isSome
  guard <| env.find? `CountNested.nested2_snd |>.isSome
  guard <| simpsAttr.getParam? env `CountNested.nested1 ==
    #[`CountNested.nested1_fst, `CountNested.nested1_snd_fst, `CountNested.nested1_snd_snd]
  guard <| simpsAttr.getParam? env `CountNested.nested2 ==
    #[`CountNested.nested2_fst, `CountNested.nested2_snd]
  -- todo: test that another attribute can be added (not working yet)
  guard <| hasSimpAttribute env `CountNested.nested1_fst -- simp attribute is global
  guard <| not <| hasSimpAttribute env `CountNested.nested2_fst -- lemmas_only doesn't add simp lemma
  -- todo: maybe test that there are no other lemmas generated
  -- guard $ 7 = env.fold 0
  --   (λ d n => n + if d.to_name.components.init.ilast = `CountNested then 1 else 0)

-- testing with arguments
@[simps] def bar {_ : Type _} (n m : ℕ) : ℕ × ℤ :=
⟨n - m, n + m⟩

structure EquivPlusData (α β) extends α ≃ β where
  P : (α → β) → Prop
  data : P toFun

structure ComplicatedEquivPlusData (α) extends α ⊕ α ≃ α ⊕ α where
  P : (α ⊕ α → α ⊕ α) → Prop
  data : P toFun
  extra : Bool → MyProd ℕ ℕ

/-- Test whether structure-eta-reduction is working correctly. -/
@[simps!]
def rflWithData {α} : EquivPlusData α α :=
{ foo.rfl with
  P := λ f => f = id
  data := rfl }

@[simps!]
def rflWithData' {α} : EquivPlusData α α :=
{ P := λ f => f = id
  data := rfl
  toEquiv' := foo.rfl }

/- test whether eta expansions are reduced correctly -/
@[simps!]
def test {α} : ComplicatedEquivPlusData α :=
{ foo.rfl with
  P := λ f => f = id
  data := rfl
  extra := λ _ => ⟨(⟨3, 5⟩ : MyProd _ _).1, (⟨3, 5⟩ : MyProd _ _).2⟩ }

/- test whether this is indeed rejected as a valid eta expansion -/
@[simps!]
def test_sneaky {α} : ComplicatedEquivPlusData α :=
{ foo.rfl with
  P := λ f => f = id
  data := rfl
  extra := λ _ => ⟨(3,5).1,(3,5).2⟩ }

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `rflWithData_toFun |>.isSome
  guard <| env.find? `rflWithData'_toFun |>.isSome
  guard <| env.find? `test_extra_fst |>.isSome
  guard <| simpsAttr.getParam? env `test ==
    #[`test_P, `test_extra_fst, `test_extra_snd, `test_toFun, `test_invFun]
  guard <| env.find? `test_sneaky_extra_fst |>.isSome
  guard <| env.find? `rflWithData_toEquiv_toFun |>.isNone
  guard <| env.find? `rflWithData'_toEquiv_toFun |>.isNone
  guard <| env.find? `test_sneaky_extra |>.isNone

structure PartiallyAppliedStr :=
(data : ℕ → MyProd ℕ ℕ)

/- if we have a partially applied constructor, we treat it as if it were eta-expanded -/
@[simps]
def partially_applied_term : PartiallyAppliedStr := ⟨MyProd.mk 3⟩

@[simps]
def another_term : PartiallyAppliedStr := ⟨λ n => ⟨n + 1, n + 2⟩⟩

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `partially_applied_term_data_fst |>.isSome
  guard <| env.find? `partially_applied_term_data_snd |>.isSome
  guard <| simpsAttr.getParam? env `partially_applied_term ==
    #[`partially_applied_term_data_fst, `partially_applied_term_data_snd]

structure VeryPartiallyAppliedStr :=
(data : ∀β, ℕ → β → MyProd ℕ β)

/- if we have a partially applied constructor, we treat it as if it were eta-expanded.
  (this is not very useful, and we could remove this behavior if convenient) -/
@[simps]
def very_partially_applied_term : VeryPartiallyAppliedStr := ⟨@MyProd.mk ℕ⟩

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `very_partially_applied_term_data_fst |>.isSome
  guard <| env.find? `very_partially_applied_term_data_snd |>.isSome

@[simps] def let1 : ℕ × ℤ :=
let n := 3; ⟨n + 4, 5⟩

@[simps] def let2 : ℕ × ℤ :=
let n := 3; let m := 4; let k := 5; ⟨n + m, k⟩

@[simps] def let3 : ℕ → ℕ × ℤ :=
λ n => let m := 4; let k := 5; ⟨n + m, k⟩

@[simps] def let4 : ℕ → ℕ × ℤ :=
let m := 4; let k := 5; λ n => ⟨n + m, k⟩

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `let1_fst |>.isSome
  guard <| env.find? `let2_fst |>.isSome
  guard <| env.find? `let3_fst |>.isSome
  guard <| env.find? `let4_fst |>.isSome
  guard <| env.find? `let1_snd |>.isSome
  guard <| env.find? `let2_snd |>.isSome
  guard <| env.find? `let3_snd |>.isSome
  guard <| env.find? `let4_snd |>.isSome

namespace specify
-- todo: error when naming arguments
@[simps fst] def specify1 : ℕ × ℕ × ℕ := (1, 2, 3)
@[simps snd] def specify2 : ℕ × ℕ × ℕ := (1, 2, 3)
@[simps snd_fst] def specify3 : ℕ × ℕ × ℕ := (1, 2, 3)
@[simps snd snd_snd] def specify4 : ℕ × ℕ × ℕ := (1, 2, 3) -- last argument is ignored
@[simps] noncomputable def specify5 : ℕ × ℕ × ℕ := (1, Classical.choice ⟨(2, 3)⟩)
end specify

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `specify.specify1_fst |>.isSome
  guard <| env.find? `specify.specify2_snd |>.isSome
  guard <| env.find? `specify.specify3_snd_fst  |>.isSome
  guard <| env.find? `specify.specify4_snd_snd |>.isSome
  guard <| env.find? `specify.specify4_snd |>.isSome
  guard <| env.find? `specify.specify5_fst |>.isSome
  guard <| env.find? `specify.specify5_snd |>.isSome
  guard <| simpsAttr.getParam? env `specify.specify1 == #[`specify.specify1_fst]
  guard <| simpsAttr.getParam? env `specify.specify4 ==
    #[`specify.specify4_snd_snd, `specify.specify4_snd]
  guard <| simpsAttr.getParam? env `specify.specify5 ==
    #[`specify.specify5_fst, `specify.specify5_snd]
  _ ← successIfFail <| simpsTac .missing `specify.specify1 {} [("fst_fst", .missing)]
--     "Invalid simp lemma specify.specify1_fst_fst.
-- Projection fst doesn't exist, because target is not a structure."
  _ ← successIfFail <| simpsTac .missing `specify.specify1 {} [("foo_fst", .missing)]
--     "Invalid simp lemma specify.specify1_foo_fst. Structure prod does not have projection foo.
-- The known projections are:
--   [fst, snd]
-- You can also see this information by running
--   `initialize_simps_projections? prod`.
-- Note: these projection names might not correspond to the projection names of the structure."
  _ ← successIfFail <| simpsTac .missing `specify.specify1 {} [("snd_bar", .missing)]
--     "Invalid simp lemma specify.specify1_snd_bar. Structure prod does not have projection bar.
-- The known projections are:
--   [fst, snd]
-- You can also see this information by running
--   `initialize_simps_projections? prod`.
-- Note: these projection names might not correspond to the projection names of the structure."
  _ ← successIfFail <| simpsTac .missing `specify.specify5 { rhsMd := .default, simpRhs := true }
    [("snd_snd", .missing)]
--     "Invalid simp lemma specify.specify5_snd_snd.
-- The given definition is not a constructor application:
--   Classical.choice specify.specify5._proof_1"

/- We also eta-reduce if we explicitly specify the projection. -/
attribute [simps extra] test
example {α} {b : Bool} {x} (h : (⟨3, 5⟩ : MyProd _ _) = x) : (@test α).extra b = x := by
  dsimp
  rw [h]

/- check simpRhs option -/
@[simps (config := {simpRhs := true})] def Equiv'.trans {α β γ} (f : α ≃ β) (g : β ≃ γ) : α ≃ γ :=
⟨ g.toFun ∘ f.toFun,
  f.invFun ∘ g.invFun,
  (by intro x; simp [Equiv'.left_inv _ _]),
  (by intro x; simp [Equiv'.right_inv _ _])⟩

example {α β γ : Type} (f : α ≃ β) (g : β ≃ γ) (x : α) {z : γ} (h : g.toFun (f.toFun x) = z) :
  (f.trans g).toFun x = z := by
  dsimp only [Equiv'.trans_toFun]
  rw [h]

attribute [local simp] Nat.zero_add Nat.one_mul Nat.mul_one
@[simps (config := {simpRhs := true})] def myNatEquiv : ℕ ≃ ℕ :=
⟨λ n => 0 + n, λ n => 1 * n * 1, by intro n; simp, by intro n; simp⟩

example (n : ℕ) : myNatEquiv.toFun (myNatEquiv.toFun $ myNatEquiv.invFun n) = n :=
by { /-successIfFail { rfl },-/ simp only [myNatEquiv_toFun, myNatEquiv_invFun] }

@[simps (config := {simpRhs := true})] def succeed_without_simplification_possible : ℕ ≃ ℕ :=
⟨λ n => n, λ n => n, by intro n; rfl, by intro n; rfl⟩

/- test that we don't recursively take projections of `prod` and `PProd` -/
@[simps] def pprodEquivProd2 : PProd ℕ ℕ ≃ ℕ × ℕ :=
{ toFun := λ x => ⟨x.1, x.2⟩
  invFun := λ x => ⟨x.1, x.2⟩
  left_inv := λ ⟨_, _⟩ => rfl
  right_inv := λ ⟨_, _⟩ => rfl }

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `pprodEquivProd2_toFun |>.isSome
  guard <| env.find? `pprodEquivProd2_invFun |>.isSome

attribute [simps toFun_fst invFun_snd] pprodEquivProd2

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `pprodEquivProd2_toFun_fst |>.isSome
  guard <| env.find? `pprodEquivProd2_invFun_snd |>.isSome

-- we can disable this behavior with the option `notRecursive`.
@[simps! (config := {notRecursive := []})] def pprodEquivProd22 : PProd ℕ ℕ ≃ ℕ × ℕ :=
pprodEquivProd2

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `pprodEquivProd22_toFun_fst |>.isSome
  guard <| env.find? `pprodEquivProd22_toFun_snd |>.isSome
  guard <| env.find? `pprodEquivProd22_invFun_fst |>.isSome
  guard <| env.find? `pprodEquivProd22_invFun_snd |>.isSome

/- Tests with universe levels -/
class has_hom (obj : Type u) : Type (max u (v+1)) :=
(hom : obj → obj → Type v)

infixr:10 " ⟶ " => has_hom.hom -- type as \h

class CategoryStruct (obj : Type u) extends has_hom.{v} obj : Type (max u (v+1)) :=
(id       : ∀ X : obj, hom X X)
(comp     : ∀ {X Y Z : obj}, (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z))

notation "𝟙" => CategoryStruct.id -- type as \b1
infixr:80 " ≫ " => CategoryStruct.comp -- type as \gg

@[simps] instance types : CategoryStruct (Type u) :=
{ hom     := λ a b => (a → b)
  id      := λ _ => id
  comp    := λ f g => g ∘ f }

@[ext] theorem types.ext {X Y : Type u} {f g : X ⟶ Y} : (∀ x, f x = g x) → f = g := funext

example (X : Type u) {x : Type u} (h : (X → X) = x) : (X ⟶ X) = x := by simp; rw [h]
example (X : Type u) {f : X → X} (h : ∀ x, f x = x) : 𝟙 X = f := by ext; simp; rw [h]
example (X Y Z : Type u) (f : X ⟶ Y) (g : Y ⟶ Z) {k : X → Z} (h : ∀ x, g (f x) = k x) :
  f ≫ g = k := by ext; simp; rw [h]

namespace coercing

structure FooStr :=
 (c : Type)
 (x : c)

instance : CoeSort FooStr Type := ⟨FooStr.c⟩

@[simps] def foo : FooStr := ⟨ℕ, 3⟩
@[simps] def foo2 : FooStr := ⟨ℕ, 34⟩

example {x : Type} (h : ℕ = x) : foo = x := by simp only [foo_c]; rw [h]
example {x : ℕ} (h : (3 : ℕ) = x) : foo.x = x := by simp only [foo_x]; rw [h]

structure VooStr (n : ℕ) :=
 (c : Type)
 (x : c)

instance (n : ℕ) : CoeSort (VooStr n) Type := ⟨VooStr.c⟩

@[simps] def voo : VooStr 7 := ⟨ℕ, 3⟩
@[simps] def voo2 : VooStr 4 := ⟨ℕ, 34⟩

example {x : Type} (h : ℕ = x) : voo = x := by simp only [voo_c]; rw [h]
example {x : ℕ} (h : (3 : ℕ) = x) : voo.x = x := by simp only [voo_x]; rw [h]

structure Equiv2 (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)
(left_inv  : invFun.LeftInverse toFun)
(right_inv : invFun.RightInverse toFun)

instance {α β} : CoeFun (Equiv2 α β) (λ _ => α → β) := ⟨Equiv2.toFun⟩

@[simps] protected def rfl2 {α} : Equiv2 α α :=
⟨λ x => x, λ x => x, λ _ => rfl, λ _ => rfl⟩

example {α} (x x' : α) (h : x = x') : coercing.rfl2 x = x' := by rw [coercing.rfl2_toFun, h]
example {α} (x x' : α) (h : x = x') : coercing.rfl2 x = x' := by simp; rw [h]
example {α} (x x' : α) (h : x = x') : coercing.rfl2.invFun x = x' := by simp; rw [h]

@[simps] protected def Equiv2.symm {α β} (f : Equiv2 α β) : Equiv2 β α :=
⟨f.invFun, f, f.right_inv, f.left_inv⟩

@[simps] protected def Equiv2.symm2 {α β} (f : Equiv2 α β) : Equiv2 β α :=
⟨f.invFun, f.toFun, f.right_inv, f.left_inv⟩

@[simps (config := .asFn)] protected def Equiv2.symm3 {α β} (f : Equiv2 α β) : Equiv2 β α :=
⟨f.invFun, f, f.right_inv, f.left_inv⟩

example {α β} (f : Equiv2 α β) (y : β) {x} (h : f.invFun y = x) : f.symm y = x := by simp; rw [h]
example {α β} (f : Equiv2 α β) (x : α) {z} (h : f x = z) : f.symm.invFun x = z := by simp; rw [h]

-- example {α β} (f : Equiv2 α β) {x} (h : f = x) : f.symm.invFun = x :=
-- by { /-successIfFail {simp <;> rw [h]} <;>-/ rfl }
example {α β} (f : Equiv2 α β) {x} (h : f = x) : f.symm3.invFun = x := by simp; rw [h]

class Semigroup (G : Type u) extends Mul G where
  mul_assoc : ∀ a b c : G, a * b * c = a * (b * c)

@[simps] instance {α β} [Semigroup α] [Semigroup β] : Semigroup (α × β) :=
{ mul := λ x y => (x.1 * y.1, x.2 * y.2)
  mul_assoc := λ _ _ _ => Prod.ext (Semigroup.mul_assoc ..) (Semigroup.mul_assoc ..) }

example {α β} [Semigroup α] [Semigroup β] (x y : α × β) : x * y = (x.1 * y.1, x.2 * y.2) := by simp
example {α β} [Semigroup α] [Semigroup β] (x y : α × β) : (x * y).1 = x.1 * y.1 := by simp

structure BSemigroup :=
  (G : Type _)
  (op : G → G → G)
  -- (infix:60 " * " => op) -- this seems to be removed
  (op_assoc : ∀ (x y z : G), op (op x y) z = op x (op y z))

namespace BSemigroup

instance : CoeSort BSemigroup (Type _) := ⟨BSemigroup.G⟩
-- We could try to generate lemmas with this `HMul` instance, but it is unused in mathlib3/mathlib4.
-- Therefore, this is ignored.
instance (G : BSemigroup) : Mul G := ⟨G.op⟩

protected def prod (G H : BSemigroup) : BSemigroup :=
{ G := G × H
  op := λ x y => (x.1 * y.1, x.2 * y.2)
  op_assoc := λ _ _ _ => Prod.ext (BSemigroup.op_assoc ..) (BSemigroup.op_assoc ..) }

end BSemigroup

class ExtendingStuff (G : Type u) extends Mul G, Zero G, Neg G, HasSubset G :=
(new_axiom : ∀ x : G, x * - 0 ⊆ - x)

@[simps] def bar : ExtendingStuff ℕ :=
{ mul := (·*·)
  zero := 0
  neg := Nat.succ
  Subset := λ _ _ => True
  new_axiom := λ _ => trivial }

section
attribute [local instance] bar
example (x : ℕ) : x * - 0 ⊆ - x := by simp
end

class new_ExtendingStuff (G : Type u) extends Mul G, Zero G, Neg G, HasSubset G :=
(new_axiom : ∀ x : G, x * - 0 ⊆ - x)

@[simps] def new_bar : new_ExtendingStuff ℕ :=
{ mul := (·*·)
  zero := 0
  neg := Nat.succ
  Subset := λ _ _ => True
  new_axiom := λ _ => trivial }

section
attribute [local instance] new_bar
example (x : ℕ) : x * - 0 ⊆ - x := by simp
end

end coercing

namespace ManualCoercion

structure Equiv (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => ManualCoercion.Equiv

variable {α β γ : Sort _}

instance : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv.toFun⟩

def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

/-- See Note [custom simps projection] -/
def Equiv.Simps.invFun (e : α ≃ β) : β → α := e.symm

/-- Composition of equivalences `e₁ : α ≃ β` and `e₂ : β ≃ γ`. -/
@[simps (config := {simpRhs := true})]
protected def Equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ (e₁ : α → β), e₁.symm ∘ (e₂.symm : γ → β)⟩

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : γ) {z} (h : e₁.symm (e₂.symm x) = z) :
  (e₁.trans e₂).symm x = z :=
by simp only [Equiv.trans_invFun]; rw [h]

end ManualCoercion

namespace FaultyManualCoercion

structure Equiv (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => FaultyManualCoercion.Equiv

variable {α β γ : Sort _}

/-- See Note [custom simps projection] -/
noncomputable def Equiv.Simps.invFun (e : α ≃ β) : β → α := Classical.choice ⟨e.invFun⟩

run_cmd liftTermElabM <| do
  successIfFail (getRawProjections .missing `FaultyManualCoercion.Equiv)
-- "Invalid custom projection:
--   λ {α : Sort u_1} {β : Sort u_2} (e : α ≃ β), Classical.choice _
-- Expression is not definitionally equal to
--   λ (α : Sort u_1) (β : Sort u_2) (x : α ≃ β), x.invFun"

end FaultyManualCoercion

namespace ManualInitialize
/- defining a manual coercion. -/
variable {α β γ : Sort _}

structure Equiv (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => ManualInitialize.Equiv

instance : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv.toFun⟩

def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

/-- See Note [custom simps projection] -/
def Equiv.Simps.invFun (e : α ≃ β) : β → α := e.symm

initialize_simps_projections Equiv

-- run_cmd has_attribute `_simps_str `ManualInitialize.Equiv

/-- Composition of equivalences `e₁ : α ≃ β` and `e₂ : β ≃ γ`. -/
@[simps (config := {simpRhs := true})]
protected def Equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ (e₁ : α → β), e₁.symm ∘ (e₂.symm : γ → β)⟩

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : γ) {z} (h : e₁.symm (e₂.symm x) = z) :
  (e₁.trans e₂).symm x = z :=
by simp only [Equiv.trans_invFun]; rw [h]

end ManualInitialize

namespace FaultyUniverses

variable {α β γ : Sort _}

structure Equiv (α : Sort u) (β : Sort v) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => FaultyUniverses.Equiv

instance : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv.toFun⟩

def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

/-- See Note [custom simps projection] -/
def Equiv.Simps.invFun {α : Type u} {β : Type v} (e : α ≃ β) : β → α := e.symm

run_cmd liftTermElabM <| do
  successIfFail (getRawProjections .missing `FaultyUniverses.Equiv)
-- "Invalid custom projection:
--   fun {α} {β} e => (Equiv.symm e).toFun
-- Expression has different type than FaultyUniverses.Equiv.invFun. Given type:
--   {α : Type u} → {β : Type v} → α ≃ β → β → α
-- Expected type:
--   (α : Sort u) → (β : Sort v) → α ≃ β → β → α
-- Note: make sure order of implicit arguments is exactly the same."

end FaultyUniverses

namespace ManualUniverses

variable {α β γ : Sort _}

structure Equiv (α : Sort u) (β : Sort v) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => ManualUniverses.Equiv

instance : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv.toFun⟩

def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

/-- See Note [custom simps projection] -/
-- test: intentionally using different unvierse levels for Equiv.symm than for Equiv
def Equiv.Simps.invFun {α : Sort w} {β : Sort u} (e : α ≃ β) : β → α := e.symm

-- check whether we can generate custom projections even if the universe names don't match
initialize_simps_projections Equiv

end ManualUniverses

namespace ManualProjectionNames

structure Equiv (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => ManualProjectionNames.Equiv

variable {α β γ : Sort _}

instance : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv.toFun⟩

def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

/-- See Note [custom simps projection] -/
def Equiv.Simps.symm_apply (e : α ≃ β) : β → α := e.symm

initialize_simps_projections Equiv (toFun → apply, invFun → symm_apply)

run_cmd liftTermElabM <| do
  let data ← getRawProjections .missing `ManualProjectionNames.Equiv
  guard <| data.2.map (·.name) == #[`apply, `symm_apply]

@[simps (config := {simpRhs := true})]
protected def Equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ (e₁ : α → β), e₁.symm ∘ (e₂.symm : γ → β)⟩

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : α) {z} (h : e₂ (e₁ x) = z) : (e₁.trans e₂) x = z :=
by simp only [Equiv.trans_apply]; rw [h]

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : γ) {z} (h : e₁.symm (e₂.symm x) = z) :
  (e₁.trans e₂).symm x = z :=
by simp only [Equiv.trans_symm_apply]; rw [h]

-- the new projection names are parsed correctly (the old projection names won't work anymore)
@[simps apply symm_apply] protected def Equiv.trans2 (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ (e₁ : α → β), e₁.symm ∘ (e₂.symm : γ → β)⟩

end ManualProjectionNames

namespace PrefixProjectionNames

structure Equiv (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => PrefixProjectionNames.Equiv

variable {α β γ : Sort _}

instance : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv.toFun⟩

def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

/-- See Note [custom simps projection] -/
def Equiv.Simps.symm_apply (e : α ≃ β) : β → α := e.symm
initialize_simps_projections Equiv (toFun → coe, as_prefix coe, invFun → symm_apply)

run_cmd liftTermElabM <| do
  let data ← getRawProjections .missing `PrefixProjectionNames.Equiv
  guard $ data.2.map (·.name) = #[`coe, `symm_apply]
  guard $ data.2.map (·.isPrefix) = #[true, false]

@[simps (config := {simpRhs := true})] protected def Equiv.trans (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ (e₁ : α → β), e₁.symm ∘ (e₂.symm : γ → β)⟩

example (e₁ : α ≃ β) (e₂ : β ≃ γ) (x : α) {z} (h : e₂ (e₁ x) = z) : (e₁.trans e₂) x = z := by
  simp only [Equiv.coe_trans]
  rw [h]

-- the new projection names are parsed correctly
@[simps coe symm_apply] protected def Equiv.trans2 (e₁ : α ≃ β) (e₂ : β ≃ γ) : α ≃ γ :=
⟨e₂ ∘ (e₁ : α → β), e₁.symm ∘ (e₂.symm : γ → β)⟩

-- it interacts somewhat well with multiple projections (though the generated name is not great)
@[simps! snd_coe_fst] def foo {α β γ δ : Type _} (x : α) (e₁ : α ≃ β) (e₂ : γ ≃ δ) :
  α × (α × γ ≃ β × δ) :=
⟨x, Prod.map e₁ e₂, Prod.map e₁.symm e₂.symm⟩

example {α β γ δ : Type _} (x : α) (e₁ : α ≃ β) (e₂ : γ ≃ δ) (z : α × γ) {y} (h : e₁ z.1 = y) :
  ((foo x e₁ e₂).2 z).1 = y := by
  simp only [coe_foo_snd_fst]
  rw [h]

end PrefixProjectionNames

-- test transparency setting
structure SetPlus (α : Type) :=
(s : Set α)
(x : α)
(h : x ∈ s)

@[simps] def Nat.SetPlus1 : SetPlus ℕ := ⟨Set.univ, 1, trivial⟩

example {x : Set ℕ} (h : Set.univ = x) : Nat.SetPlus1.s = x := by
  dsimp only [Nat.SetPlus1_s]
  rw [h]

@[simps (config := {typeMd := .default})]
def Nat.SetPlus2 : SetPlus ℕ := ⟨Set.univ, 1, trivial⟩

example {x : Set ℕ} (h : Set.univ = x) : Nat.SetPlus2.s = x := by
  dsimp only [Nat.SetPlus2_s]
  -- successIfFail { rw [h] } -- todo
  exact h

@[simps (config := {rhsMd := .default})]
def Nat.SetPlus3 : SetPlus ℕ := Nat.SetPlus1

example {x : Set ℕ} (h : Set.univ = x) : Nat.SetPlus3.s = x := by
  dsimp only [Nat.SetPlus3_s]
  rw [h]

namespace NestedNonFullyApplied

structure Equiv (α : Sort _) (β : Sort _) :=
(toFun    : α → β)
(invFun   : β → α)

local infix:25 (priority := high) " ≃ " => NestedNonFullyApplied.Equiv

variable {α β γ : Sort _}

@[simps] def Equiv.symm (e : α ≃ β) : β ≃ α := ⟨e.invFun, e.toFun⟩

@[simps (config := {rhsMd := .default, fullyApplied := false})]
def Equiv.symm2 : (α ≃ β) ≃ (β ≃ α) :=
⟨Equiv.symm, Equiv.symm⟩

example (e : α ≃ β) {x : β → α} (h : e.invFun = x) : (Equiv.symm2.invFun e).toFun = x := by
  dsimp only [Equiv.symm2_invFun_toFun]
  rw [h]

/- do not prematurely unfold `Equiv.symm`, unless necessary -/
@[simps (config := {rhsMd := .default}) toFun toFun_toFun] def Equiv.symm3 : (α ≃ β) ≃ (β ≃ α) :=
Equiv.symm2

-- this fails in Lean 4, not sure what is going on
-- example (e : α ≃ β) (y : β) : (Equiv.symm3.toFun e).toFun y = e.invFun y ∧
--   (Equiv.symm3.toFun e).toFun y = e.invFun y := by
--   constructor
--   { dsimp only [Equiv.symm3_toFun]
--     guard_target = e.symm.toFun y = e.invFun y
--     rfl }
--   { dsimp only [Equiv.symm3_toFun_toFun]
--     guard_target = e.invFun y = e.invFun y
--     rfl }

end NestedNonFullyApplied

-- test that type classes which are props work
class PropClass (n : ℕ) : Prop :=
(has_true : True)

instance has_PropClass (n : ℕ) : PropClass n := ⟨trivial⟩

structure NeedsPropClass (n : ℕ) [PropClass n] :=
(t : True)

@[simps] def test_PropClass : NeedsPropClass 1 :=
{ t := trivial }

/- check that when the coercion is given in eta-expanded form, we can also find the coercion. -/
structure AlgHom (R A B : Type _) :=
(toFun : A → B)

instance (R A B : Type _) : CoeFun (AlgHom R A B) (λ _ => A → B) := ⟨λ f => f.toFun⟩

@[simps] def myAlgHom : AlgHom Unit Bool Bool :=
{ toFun := id }

example (x : Bool) {z} (h : id x = z) : myAlgHom x = z := by
  simp only [myAlgHom_toFun]
  rw [h]

structure RingHom (A B : Type _) where
  toFun : A → B

instance (A B : Type _) : CoeFun (RingHom A B) (λ _ => A → B) := ⟨λ f => f.toFun⟩

@[simps] def myRingHom : RingHom Bool Bool :=
{ toFun := id }

example (x : Bool) {z} (h : id x = z) : myRingHom x = z := by
  simp only [myRingHom_toFun]
  rw [h]

/- check interaction with the `@[to_additive]` attribute -/

-- set_option trace.simps.debug true

@[to_additive (attr := simps) instAddProd]
instance {M N} [Mul M] [Mul N] : Mul (M × N) := ⟨λ p q => ⟨p.1 * q.1, p.2 * q.2⟩⟩

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `instMulProd_mul |>.isSome
  guard <| env.find? `instAddProd_add |>.isSome
  -- hasAttribute `to_additive `instMulProd
  -- hasAttribute `to_additive `instMulProd_mul
  guard <| hasSimpAttribute env `instMulProd_mul
  guard <| hasSimpAttribute env `instAddProd_add

example {M N} [Mul M] [Mul N] (p q : M × N) : p * q = ⟨p.1 * q.1, p.2 * q.2⟩ := by simp
example {M N} [Add M] [Add N] (p q : M × N) : p + q = ⟨p.1 + q.1, p.2 + q.2⟩ := by simp

/- The names of the generated simp lemmas for the additive version are not great if the definition
  had a custom additive name -/
@[to_additive (attr := simps) my_add_instance]
instance my_instance {M N} [One M] [One N] : One (M × N) := ⟨(1, 1)⟩

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `my_instance_one |>.isSome
  guard <| env.find? `my_add_instance_zero |>.isSome
  -- hasAttribute `to_additive `my_instance -- todo
  -- hasAttribute `to_additive `my_instance_one
  guard <| hasSimpAttribute env `my_instance_one
  guard <| hasSimpAttribute env `my_add_instance_zero

example {M N} [One M] [One N] : (1 : M × N) = ⟨1, 1⟩ := by simp
example {M N} [Zero M] [Zero N] : (0 : M × N) = ⟨0, 0⟩ := by simp

section
/-! Test `dsimp, simp` with the option `simpRhs` -/

attribute [local simp] Nat.add

structure MyType :=
(A : Type)

@[simps (config := {simpRhs := true})] def myTypeDef : MyType :=
⟨{ _x : Fin (Nat.add 3 0) // 1 + 1 = 2 }⟩

-- todo: this fails in Lean 4, not sure what is going on
example (h : false) (x y : { x : Fin (Nat.add 3 0) // 1 + 1 = 2 }) : myTypeDef.A = Unit := by
  simp only [myTypeDef_A]
  guard_target = { _x : Fin 3 // True } = Unit
  /- note: calling only one of `simp` or `dsimp` does not produce the current target
  as the following tests show. -/
  -- successIfFail { guard_hyp x : { x : Fin 3 // true } }
  dsimp at x
  -- successIfFail { guard_hyp x : { x : Fin 3 // true } }
  simp at y
  -- successIfFail { guard_hyp y : { x : Fin 3 // true } }
  simp at x
  dsimp at y
  guard_hyp x : { _x : Fin 3 // True }
  guard_hyp y : { _x : Fin 3 // True }
  contradiction

-- test that `to_additive` works with a custom name
@[to_additive (attr := simps) some_test2]
def some_test1 (M : Type _) [CommMonoid M] : Subtype (λ _ : M => True) := ⟨1, trivial⟩

run_cmd liftTermElabM <| do
  let env ← getEnv
  guard <| env.find? `some_test2_val |>.isSome

end

/- Test custom compositions of projections. -/

section comp_projs

instance {α β} : CoeFun (α ≃ β) (λ _ => α → β) := ⟨Equiv'.toFun⟩

@[simps] protected def Equiv'.symm {α β} (f : α ≃ β) : β ≃ α :=
⟨f.invFun, f, f.right_inv, f.left_inv⟩

structure DecoratedEquiv (α : Sort _) (β : Sort _) extends Equiv' α β :=
(P_toFun    : Function.Injective toFun )
(P_invFun   : Function.Injective invFun)

instance {α β} : CoeFun (DecoratedEquiv α β) (λ _ => α → β) := ⟨λ f => f.toEquiv'⟩

def DecoratedEquiv.symm {α β : Sort _} (e : DecoratedEquiv α β) : DecoratedEquiv β α :=
{ toEquiv' := e.toEquiv'.symm
  P_toFun := e.P_invFun
  P_invFun := e.P_toFun }

def DecoratedEquiv.Simps.apply {α β : Sort _} (e : DecoratedEquiv α β) : α → β := e
def DecoratedEquiv.Simps.symm_apply {α β : Sort _} (e : DecoratedEquiv α β) : β → α := e.symm

initialize_simps_projections DecoratedEquiv (toFun → apply, invFun → symm_apply, -toEquiv')

@[simps] def foo (α : Type) : DecoratedEquiv α α :=
{ toFun    := λ x => x
  invFun   := λ x => x
  left_inv  := λ _ => rfl
  right_inv := λ _ => rfl
  P_toFun  := λ _ _ h => h
  P_invFun := λ _ _ h => h }

example {α : Type} (x z : α) (h : x = z) : (foo α).symm x = z := by
  dsimp
  guard_target = x = z
  rw [h]

@[simps! toEquiv' apply symm_apply] def foo2 (α : Type) : DecoratedEquiv α α :=
{ foo.rfl with
  P_toFun  := λ _ _ h => h
  P_invFun := λ _ _ h => h }

example {α : Type} (x z : α) (h : foo.rfl x = z) : (foo2 α).toEquiv' x = z := by
  dsimp only [foo2_toEquiv']
  guard_target = foo.rfl x = z
  rw [h]

example {α : Type} (x z : α) (h : x = z) : (foo2 α).toEquiv' x = z := by
  dsimp only [foo2_apply]
  guard_target = x = z
  rw [h]

example {α : Type} (x z : α) (h : x = z) : foo2 α x = z := by
  dsimp
  guard_target = x = z
  rw [h]

structure FurtherDecoratedEquiv (α : Sort _) (β : Sort _) extends DecoratedEquiv α β :=
(Q_toFun    : Function.Surjective toFun )
(Q_invFun   : Function.Surjective invFun )

instance {α β} : CoeFun (FurtherDecoratedEquiv α β) (λ _ => α → β) :=
⟨λ f => f.toDecoratedEquiv⟩

def FurtherDecoratedEquiv.symm {α β : Sort _} (e : FurtherDecoratedEquiv α β) :
  FurtherDecoratedEquiv β α :=
{ toDecoratedEquiv := e.toDecoratedEquiv.symm
  Q_toFun := e.Q_invFun
  Q_invFun := e.Q_toFun }

def FurtherDecoratedEquiv.Simps.apply {α β : Sort _} (e : FurtherDecoratedEquiv α β) : α → β := e
def FurtherDecoratedEquiv.Simps.symm_apply {α β : Sort _} (e : FurtherDecoratedEquiv α β) :
  β → α := e.symm

initialize_simps_projections FurtherDecoratedEquiv
  (toFun → apply, invFun → symm_apply, -toDecoratedEquiv, toEquiv' → toEquiv', -toEquiv')

@[simps] def ffoo (α : Type) : FurtherDecoratedEquiv α α :=
{ toFun    := λ x => x
  invFun   := λ x => x
  left_inv  := λ _ => rfl
  right_inv := λ _ => rfl
  P_toFun  := λ _ _ h => h
  P_invFun := λ _ _ h => h
  Q_toFun  := λ y => ⟨y, rfl⟩
  Q_invFun := λ y => ⟨y, rfl⟩ }

example {α : Type} (x z : α) (h : x = z) : (ffoo α).symm x = z := by
  dsimp
  guard_target = x = z
  rw [h]

@[simps!] def ffoo3 (α : Type) : FurtherDecoratedEquiv α α :=
{ foo α with Q_toFun  := λ y => ⟨y, rfl⟩, Q_invFun  := λ y => ⟨y, rfl⟩ }

@[simps! apply toEquiv' toEquiv'_toFun toDecoratedEquiv_apply]
def ffoo4 (α : Type) : FurtherDecoratedEquiv α α :=
{ Q_toFun := λ y => ⟨y, rfl⟩, Q_invFun := λ y => ⟨y, rfl⟩, toDecoratedEquiv := foo α }

structure OneMore (α : Sort _) (β : Sort _) extends FurtherDecoratedEquiv α β

instance {α β} : CoeFun (OneMore α β) (λ _ => α → β) :=
⟨λ f => f.toFurtherDecoratedEquiv⟩

def OneMore.symm {α β : Sort _} (e : OneMore α β) :
  OneMore β α :=
{ toFurtherDecoratedEquiv := e.toFurtherDecoratedEquiv.symm }

def OneMore.Simps.apply {α β : Sort _} (e : OneMore α β) : α → β := e
def OneMore.Simps.symm_apply {α β : Sort _} (e : OneMore α β) : β → α := e.symm

initialize_simps_projections OneMore (toFun → apply, invFun → symm_apply,
  -toFurtherDecoratedEquiv, toDecoratedEquiv → to_dequiv, -to_dequiv)

@[simps] def fffoo (α : Type) : OneMore α α :=
{ toFun    := λ x => x
  invFun   := λ x => x
  left_inv  := λ _ => rfl
  right_inv := λ _ => rfl
  P_toFun  := λ _ _ h => h
  P_invFun := λ _ _ h => h
  Q_toFun  := λ y => ⟨y, rfl⟩
  Q_invFun := λ y => ⟨y, rfl⟩ }

example {α : Type} (x : α) : (fffoo α).symm x = x := by dsimp

@[simps! apply to_dequiv_apply toFurtherDecoratedEquiv_apply to_dequiv]
def fffoo2 (α : Type) : OneMore α α := fffoo α

/- test the case where a projection takes additional arguments. -/
variable {ι : Type _} [DecidableEq ι] (A : ι → Type _)

structure ZeroHom (M N : Type _) [Zero M] [Zero N] :=
(toFun : M → N)
(map_zero' : toFun 0 = 0)

structure AddHom (M N : Type _) [Add M] [Add N] :=
(toFun : M → N)
(map_add' : ∀ x y, toFun (x + y) = toFun x + toFun y)

structure AddMonoidHom (M N : Type _) [AddMonoid M] [AddMonoid N]
  extends ZeroHom M N, AddHom M N

infixr:25 " →+ " => AddMonoidHom

instance (M N : Type _) [AddMonoid M] [AddMonoid N] : CoeFun (M →+ N) (λ _ => M → N) := ⟨(·.toFun)⟩

class AddHomPlus [Add ι] [∀ i, AddCommMonoid (A i)] :=
(myMul {i} : A i →+ A i)

def AddHomPlus.Simps.apply [Add ι] [∀ i, AddCommMonoid (A i)] [AddHomPlus A] {i : ι} (x : A i) :
  A i :=
AddHomPlus.myMul x

initialize_simps_projections AddHomPlus (myMul_toFun → apply, -myMul)

class AddHomPlus2 [Add ι] :=
(myMul {i j} : A i ≃ (A j ≃ A (i + j)))

def AddHomPlus2.Simps.mul [Add ι] [AddHomPlus2 A] {i j : ι}
  (x : A i) (y : A j) : A (i + j) :=
AddHomPlus2.myMul x y

initialize_simps_projections AddHomPlus2 (-myMul, myMul_toFun_toFun → mul)

attribute [ext] Equiv'

@[simps]
def thing (h : Bool ≃ (Bool ≃ Bool)) : AddHomPlus2 (λ _ : ℕ => Bool) :=
{ myMul :=
  { toFun := λ b =>
    { toFun := h b
      invFun := (h b).symm
      left_inv := (h b).left_inv
      right_inv := (h b).right_inv }
    invFun := h.symm
    left_inv := h.left_inv -- definitional eta
    right_inv := h.right_inv } } -- definitional eta

example (h : Bool ≃ (Bool ≃ Bool)) (i j : ℕ) (b1 b2 : Bool) {x} (h2 : h b1 b2 = x) :
  @AddHomPlus2.myMul _ _ _ (thing h) i j b1 b2 = x := by
  simp only [thing_mul]
  rw [h2]

end comp_projs

section
/-! Check that the tactic also works if the elaborated type of `type` reduces to `Sort _`, but is
  not `Sort _` itself. -/
structure MyFunctor (C D : Type _) :=
(obj : C → D)
local infixr:26 " ⥤ " => MyFunctor

@[simps]
noncomputable def fooSum {I J : Type _} (C : I → Type _) {D : J → Type _} :
  (∀ i, C i) ⥤ (∀ j, D j) ⥤ (∀ s : I ⊕ J, Sum.rec C D s) :=
{ obj := λ f => { obj := λ g s => Sum.rec f g s }}

end

/-! Test that we deal with classes whose names are prefixes of other classes -/

class MyDiv (α : Type _) extends Div α
class MyDivInv (α : Type _) extends MyDiv α
class MyGroup (α : Type _) extends MyDivInv α
initialize_simps_projections MyGroup

/-! Test that the automatic projection module doesn't throw an error if we have a projection name
unrelated to one of the classes. -/

class MyGOne {ι} [Zero ι] (A : ι → Type _)  where
  /-- The term `one` of grade 0 -/
  one : A 0

initialize_simps_projections MyGOne

class Artificial (n : Nat)  where
  /-- The term `one` of grade 0 -/
  one : Nat

initialize_simps_projections Artificial


import order.hom.basic
import order.complete_boolean_algebra

/-!
# Transfer order structures across `equiv`s

In this file we prove theorems of the following form: if `β` has a
group structure and `α ≃ β` then `α` has a group structure, and
similarly for monoids, semigroups, rings, integral domains, fields and
so on.

Note that most of these constructions can also be obtained using the `transport` tactic.

## Tags

equiv
-/

namespace equiv
variables {α β : Type*} (e : α ≃ β)

/-- Transfer `has_le` across an `equiv` -/
protected def has_le [has_le β] : has_le α := ⟨λ x y, e x ≤ e y⟩

/-- Transfer `has_lt` across an `equiv` -/
protected def has_lt [has_lt β] : has_lt α := ⟨λ x y, e x < e y⟩

/-- Transfer `has_top` across an `equiv` -/
protected def has_top [has_top β] : has_top α := ⟨e.symm ⊤⟩

/-- Transfer `has_bot` across an `equiv` -/
protected def has_bot [has_bot β] : has_bot α := ⟨e.symm ⊥⟩

/-- Transfer `has_sup` across an `equiv` -/
protected def has_sup [has_sup β] : has_sup α := ⟨λ x y, e.symm (e x ⊔ e y)⟩

/-- Transfer `has_inf` across an `equiv` -/
protected def has_inf [has_inf β] : has_inf α := ⟨λ x y, e.symm (e x ⊓ e y)⟩

/-- Transfer `has_Sup` across an `equiv` -/
protected def has_Sup [has_Sup β] : has_Sup α := ⟨λ s, e.symm (⨆ x ∈ s, e x)⟩

/-- Transfer `has_Inf` across an `equiv` -/
protected def has_Inf [has_Inf β] : has_Inf α := ⟨λ s, e.symm (⨅ x ∈ s, e x)⟩

lemma le_def [has_le β] {x y : α} : @has_le.le _ e.has_le x y ↔ e x ≤ e y := iff.rfl
lemma lt_def [has_lt β] {x y : α} : @has_lt.lt _ e.has_lt x y ↔ e x < e y := iff.rfl
lemma top_def [has_top β] : @has_top.top _ e.has_top = e.symm ⊤ := rfl
lemma bot_def [has_bot β] : @has_bot.bot _ e.has_bot = e.symm ⊥ := rfl
lemma sup_def [has_sup β] (x y : α) : @has_sup.sup _ e.has_sup x y = e.symm (e x ⊔ e y) := rfl
lemma inf_def [has_inf β] (x y : α) : @has_inf.inf _ e.has_inf x y = e.symm (e x ⊓ e y) := rfl
lemma Sup_def [has_Sup β] (s : set α) : @has_Sup.Sup _ e.has_Sup s = e.symm (⨆ x ∈ s, e x) := rfl
lemma Inf_def [has_Inf β] (s : set α) : @has_Inf.Inf _ e.has_Inf s = e.symm (⨅ x ∈ s, e x) := rfl

/-- An equivalence `e : α ≃ β` gives a suptiplicative equivalence `α ≃⊔ β` where the suptiplicative
structure on `α` is the top obtained by transporting a suptiplicative structure on `β` back along
`e`. -/
def order_iso (e : α ≃ β) [has_le β] : by { letI := e.has_le, exact α ≃o β } :=
by { introsI, exact { map_rel_iff' := λ x y, iff.rfl, ..e } }

@[simp] lemma order_iso_apply [has_le β] (a : α) : order_iso e a = e a := rfl

lemma order_iso_symm_apply (e : α ≃ β) [has_le β] (b : β) :
  by { letI := e.has_le, exact (order_iso e).symm b = e.symm b } :=
by { intros, refl }

/-- Transfer `preorder` across an `equiv` -/
protected def preorder [preorder β] : preorder α := preorder.lift e

/-- Transfer `partial_order` across an `equiv` -/
protected def partial_order [partial_order β] : partial_order α := partial_order.lift e e.injective

/-- Transfer `linear_order` across an `equiv` -/
protected def linear_order [linear_order β] : linear_order α := linear_order.lift' e e.injective

/-- Transfer `semilattice_sup` across an `equiv` -/
protected def semilattice_sup [semilattice_sup β] : semilattice_sup α :=
let preorder := e.preorder, sup := e.has_sup in
by resetI; apply e.injective.semilattice_sup _; intros; exact e.apply_symm_apply _

/-- Transfer `semilattice_inf` across an `equiv` -/
protected def semilattice_inf [semilattice_inf β] : semilattice_inf α :=
let preorder := e.preorder, inf := e.has_inf in
by resetI; apply e.injective.semilattice_inf _; intros; exact e.apply_symm_apply _

/-- Transfer `lattice` across an `equiv` -/
protected def lattice [lattice β] : lattice α :=
let preorder := e.preorder, sup := e.has_sup, inf := e.has_inf in
by resetI; apply e.injective.lattice _; intros; exact e.apply_symm_apply _

/-- Transfer `complete_lattice` across an `equiv` -/
protected def complete_lattice [complete_lattice β] : complete_lattice α :=
let top := e.has_top, bot := e.has_bot, sup := e.has_sup, inf := e.has_inf, Sup := e.has_Sup,
  Inf := e.has_Inf in
by resetI; apply e.injective.complete_lattice _; intros; exact e.apply_symm_apply _

/-- Transfer `complete_distrib_lattice` across an `equiv` -/
protected def complete_distrib_lattice [complete_distrib_lattice β] : complete_distrib_lattice α :=
let complete_lattice := e.complete_lattice in
by resetI; apply e.injective.complete_distrib_lattice _; intros; exact e.apply_symm_apply _

end equiv


/-
Copyright (c) 2022 Siddhartha Gadgil. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Siddhartha Gadgil, Mario Carneiro
-/
import Mathlib.Lean.Meta
import Lean.Elab.Tactic.Location

/-!
# `symm` tactic

This implements the `symm` tactic, which can apply symmetry theorems to either the goal or a
hypothesis.
-/

open Lean Meta

namespace Mathlib.Tactic

/-- Environment extensions for symm lemmas -/
initialize symmExt :
    SimpleScopedEnvExtension (Name × Array (DiscrTree.Key true)) (DiscrTree Name true) ←
  registerSimpleScopedEnvExtension {
    addEntry := fun dt (n, ks) ↦ dt.insertCore ks n
    initial := {}
  }

initialize registerBuiltinAttribute {
  name := `symm
  descr := "symmetric relation"
  add := fun decl _ kind ↦ MetaM.run' do
    let declTy := (← getConstInfo decl).type
    let (xs, _, targetTy) ← withReducible <| forallMetaTelescopeReducing declTy
    let fail := throwError
      "@[symm] attribute only applies to lemmas proving x ∼ y → y ∼ x, got {declTy}"
    let some _ := xs.back? | fail
    let targetTy ← reduce targetTy
    let .app (.app rel _) _ := targetTy | fail
    let key ← withReducible <| DiscrTree.mkPath rel
    symmExt.add (decl, key) kind
}

end Mathlib.Tactic

open Mathlib.Tactic

namespace Lean.Expr

/--
Internal implementation of `Lean.Expr.symm`, `Lean.MVarId.symm`, and the user-facing tactic.

`tgt` should be of the form `a ~ b`, and is used to index the symm lemmas.

`k lem args body` should calculate a result,
given a candidate `symm` lemma `lem`, which will have type `∀ args, body`.

In `Lean.Expr.symm` this result will be a new `Expr`,
and in `Lean.MVarId.symm` and `Lean.MVarId.symmAt` this result will be a new goal.
-/
-- This function is rather opaque, but the design with a generic continuation `k`
-- is necessary in order to factor out all the common requirements below.
def symmAux (tgt : Expr) (k : Expr → Array Expr → Expr → MetaM α) : MetaM α := do
  let .app (.app rel _) _ := tgt
    | throwError "symmetry lemmas only apply to binary relations, not{indentExpr tgt}"
  for lem in ← (symmExt.getState (← getEnv)).getMatch rel do
    try
      let lem ← mkConstWithFreshMVarLevels lem
      let (args, _, body) ← withReducible <| forallMetaTelescopeReducing (← inferType lem)
      return (← k lem args body)
    catch _ => pure ()
  throwError "no applicable symmetry lemma found for{indentExpr tgt}"

/-- Given a term `e : a ~ b`, construct a term in `b ~ a` using `@[symm]` lemmas. -/
def symm (e : Expr) : MetaM Expr := do
  symmAux (← instantiateMVars (← inferType e)) fun lem args body => do
    let .true ← isDefEq args.back e | failure
    mkExpectedTypeHint (mkAppN lem args) (← instantiateMVars body)

end Lean.Expr

namespace Lean.MVarId

/--
Internal implementation of `Lean.MVarId.symm` and the user-facing tactic.

`tgt` should be of the form `a ~ b`, and is used to index the symm lemmas.

`k lem args body goal` should transform `goal` into a new goal,
given a candidate `symm` lemma `lem`, which will have type `∀ args, body`.
Depending on whether we are working on a hypothesis or a goal,
`k` will internally use either `replace` or `assign`.
-/
def symmAux (tgt : Expr) (k : Expr → Array Expr → Expr → MVarId → MetaM MVarId) (g : MVarId) :
    MetaM MVarId := do
  tgt.symmAux fun lem args body => do
    let g' ← k lem args body g
    g'.setTag (← g.getTag)
    return g'

/-- Apply a symmetry lemma (i.e. marked with `@[symm]`) to a metavariable. -/
def symm (g : MVarId) : MetaM MVarId := do
  g.symmAux (← g.getType') fun lem args body g => do
    let .true ← isDefEq (← g.getType) body | failure
    g.assign (mkAppN lem args)
    return args.back.mvarId!

/-- Use a symmetry lemma (i.e. marked with `@[symm]`) to replace a hypothesis in a goal. -/
def symmAt (h : FVarId) (g : MVarId) : MetaM MVarId := do
  let h' ← (Expr.fvar h).symm
  pure (← g.replace h h').mvarId

/-- For every hypothesis `h : a ~ b` where a `@[symm]` lemma is available,
add a hypothesis `h_symm : b ~ a`. -/
def symmSaturate (g : MVarId) : MetaM MVarId := g.withContext do
  let mut g' := g
  let hyps ← getLocalHyps
  let types ← hyps.mapM inferType
  for h in hyps do try
    let symm ← h.symm
    let symmType ← inferType symm
    if ¬ (← types.anyM (isDefEq symmType)) then
      (_, g') ← g'.note ((← h.fvarId!.getUserName).appendAfter "_symm") symm
  catch _ => g' ← pure g'
  return g'

end Lean.MVarId

namespace Mathlib.Tactic

open Lean.Elab.Tactic

/--
* `symm` applies to a goal whose target has the form `t ~ u` where `~` is a symmetric relation,
  that is, a relation which has a symmetry lemma tagged with the attribute [symm].
  It replaces the target with `u ~ t`.
* `symm at h` will rewrite a hypothesis `h : t ~ u` to `h : u ~ t`.
-/
elab "symm" loc:((Parser.Tactic.location)?) : tactic =>
  let atHyp h := liftMetaTactic1 fun g => g.symmAt h
  let atTarget := liftMetaTactic1 fun g => g.symm
  withLocation (expandOptLocation loc) atHyp atTarget fun _ ↦ throwError "symm made no progress"

/-- For every hypothesis `h : a ~ b` where a `@[symm]` lemma is available,
add a hypothesis `h_symm : b ~ a`. -/
elab "symm_saturate" : tactic => liftMetaTactic1 fun g => g.symmSaturate