import algebraic_geometry.pullbacks
import algebraic_geometry.AffineScheme
import linear_algebra.tensor_product_basis
import algebraic_geometry.misc

open opposite topological_space category_theory category_theory.limits

open local_ring (closed_point)

namespace algebraic_geometry

universe u

noncomputable theory

section local_ring_to_Scheme

variables {R : CommRing.{u}} [local_ring R] (X : Scheme.{u}) (f : Scheme.Spec.obj (op R) ⟶ X)

lemma CommRing.of_eq (R : CommRing) : CommRing.of R = R :=
by { cases R, refl }

lemma is_localization.at_prime.comap_maximal_ideal {R : Type*} (S : Type*) [comm_ring R] [comm_ring S]
  (I : ideal R) [I.is_prime] [algebra R S] [is_localization.at_prime S I] [local_ring S] :
  (local_ring.maximal_ideal S).comap (algebra_map R S) = I :=
ideal.ext $ λ x, by
simpa only [ideal.mem_comap] using is_localization.at_prime.to_map_mem_maximal_iff _ I x

lemma local_ring.specializes_closed_point {R : Type*} [comm_ring R] [local_ring R]
  (x : prime_spectrum R) :
  x ⤳ closed_point R :=
begin
  rw ← prime_spectrum.le_iff_specializes,
  exact local_ring.le_maximal_ideal x.2.1,
end

lemma local_ring.closed_point_mem_iff {R : Type*} [comm_ring R] [local_ring R]
  (U : opens $ prime_spectrum R) :
  closed_point R ∈ U ↔ U = ⊤ :=
begin
  split,
  { rw eq_top_iff, exact λ h x _, (local_ring.specializes_closed_point x).mem_open U.2 h },
  { rintro rfl, trivial }
end

lemma _root_.ring.is_field_iff_forall_ideal_eq {R : Type*} [comm_ring R] [nontrivial R] :
  is_field R ↔ ∀ I : ideal R, I = ⊥ ∨ I = ⊤ :=
begin
  rw [← not_iff_not, ring.not_is_field_iff_exists_ideal_bot_lt_and_lt_top],
  push_neg,
  simp_rw [lt_top_iff_ne_top, bot_lt_iff_ne_bot],
end

lemma field.ideal_eq {R : Type*} [field R] (I : ideal R) :
  I = ⊥ ∨ I = ⊤ :=
ring.is_field_iff_forall_ideal_eq.mp (field.to_is_field R) I

lemma _root_.local_ring.is_field_iff_maximal_ideal_eq {R : Type*} [comm_ring R] [local_ring R] :
  is_field R ↔ local_ring.maximal_ideal R = ⊥ :=
begin
  simp_rw [ring.is_field_iff_forall_ideal_eq, or_iff_not_imp_right],
  exact ⟨λ H, H (local_ring.maximal_ideal R) (ideal.is_prime.ne_top infer_instance),
    λ e I hI, eq_bot_iff.mpr (e ▸ local_ring.le_maximal_ideal hI)⟩,
end

instance {R : Type*} [comm_ring R] [is_domain R] : order_bot (prime_spectrum R) :=
{ bot := ⟨⊥, ideal.bot_prime⟩, bot_le := λ I, @bot_le _ _ _ I.as_ideal }

instance {R : Type*} [field R] : unique (prime_spectrum R) :=
{ default := ⊥,
  uniq := λ x, subtype.ext
    ((field.ideal_eq x.as_ideal).resolve_right (ideal.is_prime.ne_top infer_instance)) }

lemma _root_.prime_spectrum.comap_residue {R : Type*} [comm_ring R] [local_ring R]
  (I : prime_spectrum (local_ring.residue_field R)) :
  prime_spectrum.comap (local_ring.residue R) I = local_ring.closed_point R :=
begin
  have : I = ⊥ := subsingleton.elim _ _,
  subst this,
  ext1,
  exact ideal.mk_ker,
end

lemma local_ring.maximal_ideal_eq_bot {R : Type*} [field R] : local_ring.maximal_ideal R = ⊥ :=
local_ring.is_field_iff_maximal_ideal_eq.mp (field.to_is_field R)

def local_ring.lift_residue_field {R S : Type*} [comm_ring R] [local_ring R] [field S]
  (f : R →+* S) [is_local_ring_hom f] : local_ring.residue_field R →+* S :=
ideal.quotient.lift _ f (λ a ha,
  classical.by_contradiction (λ h, ha (is_unit_of_map_unit f a (is_unit_iff_ne_zero.mpr h))))

lemma local_ring.lift_residue_field_comp {R S : Type*} [comm_ring R] [local_ring R] [field S]
  (f : R →+* S) [is_local_ring_hom f] : local_ring.residue_field R →+* S :=
ideal.quotient.lift _ f (λ a ha,
  classical.by_contradiction (λ h, ha (is_unit_of_map_unit f a (is_unit_iff_ne_zero.mpr h))))

instance {R S : Type*} [field R] [comm_ring S] [nontrivial S] (f : R →+* S) :
  is_local_ring_hom f :=
⟨λ a ha, is_unit_iff_ne_zero.mpr (λ e, @not_is_unit_zero S _ _ $ by rwa [← map_zero f, ← e])⟩

instance {R : Type*} [comm_ring R] [local_ring R] :
  is_local_ring_hom (local_ring.residue R) :=
⟨λ a ha, not_not.mp (ideal.quotient.eq_zero_iff_mem.not.mp (is_unit_iff_ne_zero.mp ha))⟩

open topological_space

variables {X}

lemma is_affine_open.map_from_Spec {U V : opens X.carrier} (h : op U ⟶ op V)
  (hU : is_affine_open U) (hV : is_affine_open V) :
  Scheme.Spec.map (X.presheaf.map h).op ≫ hU.from_Spec = hV.from_Spec :=
begin
  delta is_affine_open.from_Spec Scheme.iso_Spec,
  rw ← is_iso.inv_comp_eq,
  rw iso.eq_inv_comp,
  simp only [← functor.map_inv, ← op_inv, eq_to_hom_op, inv_eq_to_hom,
    ← functor.map_comp_assoc, ← op_comp, ← functor.map_comp],
  rw [as_iso_hom, as_iso_inv, ← category.assoc],
  have e := (Γ_Spec.adjunction.unit.naturality (X.restrict_functor.map h.unop).1),
  rw [functor.id_map, category_theory.functor.comp_map, functor.right_op_map,
    Scheme.Γ_map_op, X.restrict_functor_map_app] at e,
  dsimp only [Scheme.restrict_functor, unop_op, over.mk, costructured_arrow.mk] at e,
  erw ← e,
  rw [category.assoc, is_iso.hom_inv_id_assoc, over.hom_mk_left, is_open_immersion.lift_fac],
end

def is_affine_open.from_Spec_stalk {U : opens X.carrier} (hU : is_affine_open U) {x : X.carrier}
  (hxU : x ∈ U) :
  Scheme.Spec.obj (op $ X.presheaf.stalk x) ⟶ X :=
Scheme.Spec.map (X.presheaf.germ ⟨x, hxU⟩).op ≫ hU.from_Spec

lemma from_Spec_stalk_eq (x : X.carrier) {U V : opens X.carrier}
  (hU : is_affine_open U) (hV : is_affine_open V) (hxU : x ∈ U) (hxV : x ∈ V) :
    hU.from_Spec_stalk hxU = hV.from_Spec_stalk hxV :=
begin
  obtain ⟨U', h₁, h₂, h₃ : U' ≤ U ⊓ V⟩ :=
    opens.is_basis_iff_nbhd.mp (is_basis_affine_open X) (show x ∈ U ⊓ V, from ⟨hxU, hxV⟩),
  transitivity h₁.from_Spec_stalk h₂; delta is_affine_open.from_Spec_stalk,
  { rw [← hU.map_from_Spec (hom_of_le $ h₃.trans inf_le_left).op h₁, ← functor.map_comp_assoc,
      ← op_comp, Top.presheaf.germ_res], refl },
  { rw [← hV.map_from_Spec (hom_of_le $ h₃.trans inf_le_right).op h₁, ← functor.map_comp_assoc,
      ← op_comp, Top.presheaf.germ_res], refl },
end

def Scheme.from_Spec_stalk (X : Scheme) (x : X.carrier) :
  Scheme.Spec.obj (op $ X.presheaf.stalk x) ⟶ X :=
(range_is_affine_open_of_open_immersion $ X.affine_cover.map x).from_Spec_stalk
  (X.affine_cover.covers x)

lemma is_affine_open.from_Spec_stalk_eq {X : Scheme} {U : opens X.carrier} (hU : is_affine_open U)
  (x ∈ U) :
  hU.from_Spec_stalk H = X.from_Spec_stalk x :=
from_Spec_stalk_eq _ _ _ _ _

@[instance]
lemma Scheme.mono_from_Spec_stalk {X : Scheme} (x : X.carrier) : mono (X.from_Spec_stalk x) :=
begin
  apply_with mono_comp { instances := ff },
  swap, { apply_instance },
  apply_with functor.map_mono { instances := ff },
  { apply_instance },
  apply_with category_theory.op_mono_of_epi { instances := ff },
  have := (range_is_affine_open_of_open_immersion (X.affine_cover.map x)).is_localization_stalk
      ⟨x, X.affine_cover.covers x⟩,
  convert @is_localization.epi _ _ _ _ _ _ this,
  { exact (CommRing.of_eq _).symm },
  { exact (CommRing.of_eq _).symm }
end

lemma is_affine_open.from_Spec_stalk_closed_point {U : opens X.carrier} (hU : is_affine_open U)
  {x : X.carrier} (hxU : x ∈ U) :
  (hU.from_Spec_stalk hxU).1.base (closed_point (X.presheaf.stalk x) : _) = x :=
begin
  letI : is_affine _ := hU,
  rw [is_affine_open.from_Spec_stalk, is_affine_open.from_Spec, ← functor.map_comp_assoc,
    ← op_comp, Top.presheaf.germ_res],
  simp only [Top.comp_app, Scheme.of_restrict_val_base,
    quiver.hom.unop_op, Scheme.comp_coe_base, Scheme.Spec_map_2,
    eq_to_hom_op, opens.inclusion_apply],
  refine eq.trans _ (subtype.coe_mk x hxU),
  congr' 1,
  have : function.injective (X.restrict U.open_embedding).iso_Spec.hom.val.base,
  { rw ← Top.mono_iff_injective, apply_instance },
  apply this,
  convert_to ((X.restrict _).iso_Spec.inv ≫ (X.restrict _).iso_Spec.hom).val.base _ = _,
  rw [iso.inv_hom_id, Scheme.id_val_base, id_apply, Scheme.iso_Spec,
    as_iso_hom, Γ_Spec.adjunction_unit_app_base_apply, LocallyRingedSpace.Γ_to_stalk],
  erw [← PresheafedSpace.restrict_stalk_iso_inv_eq_germ, prime_spectrum.comap_comp],
  rw [continuous_map.comp_apply, local_ring.comap_closed_point],
  refl
end

lemma Scheme.from_Spec_stalk_closed_point (x : X.carrier) :
  (X.from_Spec_stalk x).1.base (closed_point (X.presheaf.stalk x) : _) = x :=
is_affine_open.from_Spec_stalk_closed_point _ _

lemma Scheme.range_from_Spec_stalk (X : Scheme) (x : X.carrier) :
  set.range (X.from_Spec_stalk x).1.base = { y | y ⤳ x } :=
begin
  apply le_antisymm,
  { rintros _ ⟨y, rfl⟩,
    dsimp at y,
    change _ ⤳ x,
    convert (local_ring.specializes_closed_point y).map (X.from_Spec_stalk x).1.base.2,
    exact (Scheme.from_Spec_stalk_closed_point x).symm },
  { rintros y (h : y ⤳ x),
    have h' := h,
    conv_rhs at h { rw ← Scheme.from_Spec_stalk_closed_point x },
    rw [Scheme.from_Spec_stalk, is_affine_open.from_Spec_stalk, Scheme.comp_val_base] at h ⊢,
    generalize_proofs _ _ hx hU,
    change x ∈ (X.affine_cover.map x).opens_range at hx,
    have hyU : y ∈ ((X.affine_cover.map x).opens_range : set X.carrier) :=
      h'.mem_open ((X.affine_cover.map x).opens_range.2) (X.affine_cover.covers x),
    rw [← hU.from_Spec_range] at hyU,
    obtain ⟨y', rfl⟩ := hyU,
    rw [coe_comp, set.range_comp],
    apply set.mem_image_of_mem,
    replace h := PresheafedSpace.is_open_immersion.base_open.to_inducing.specializes_iff.mp h,
    rw ← prime_spectrum.le_iff_specializes at h,
    haveI H := hU.is_localization_stalk ⟨x, hx⟩,
    erw @@prime_spectrum.localization_comap_range _ _ _ _ _ H,
    dsimp,
    apply set.subset_compl_iff_disjoint_left.mp,
    erw compl_compl,
    change y'.as_ideal ≤ (hU.prime_ideal_of ⟨x, hx⟩).as_ideal,
    convert h,
    ext1,
    exact (@@is_localization.at_prime.comap_maximal_ideal _ _ _ _ _ _ H _).symm }
end

def stalk_closed_point_to (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X) :
  X.presheaf.stalk (f.1.base (closed_point R : _)) ⟶ R :=
PresheafedSpace.stalk_map f.1 (closed_point R : _) ≫
  structure_sheaf.stalk_to_fiber_ring_hom R _ ≫
begin
  refine (@ring_equiv.to_CommRing_iso R
    (localization.at_prime (closed_point R).as_ideal) _ _ _).inv,
  refine (is_localization.at_units _
    (closed_point R).as_ideal.prime_compl _ _).to_ring_equiv,
  exact λ x, not_not.mp x.2,
end

instance (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X) : is_local_ring_hom (stalk_closed_point_to R f) :=
is_local_ring_hom_comp _ _

lemma structure_sheaf.is_iso_to_open_of_closed_point_mem (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X)
  (U : opens X.carrier) (hU : f.1.base (closed_point R : _) ∈ U) :
  is_iso (structure_sheaf.to_open R ((opens.map f.val.base).obj U)) :=
begin
  have : (opens.map f.val.base).obj U = ⊤ := (@local_ring.closed_point_mem_iff R _ _ _).mp hU,
  rw this,
  apply_instance,
end

@[reassoc]
lemma germ_stalk_closed_point_to (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X)
  (U : opens X.carrier) (hU : f.1.base (closed_point R : _) ∈ U) :
  X.presheaf.germ ⟨_, hU⟩ ≫ stalk_closed_point_to R f = f.1.c.app (op U)
    ≫ @@inv _ _ (structure_sheaf.is_iso_to_open_of_closed_point_mem R f U hU) :=
begin
  haveI H := structure_sheaf.is_iso_to_open_of_closed_point_mem R f U hU,
  rw stalk_closed_point_to,
  erw [PresheafedSpace.stalk_map_germ_assoc _ _ ⟨_, _⟩],
  slice_lhs 2 3 { erw structure_sheaf.germ_comp_stalk_to_fiber_ring_hom _ _ ⟨_, _⟩ },
  congr' 1,
  apply @@is_iso.eq_inv_of_hom_inv_id _ H,
  erw [← category.assoc, iso.comp_inv_eq_id],
  ext,
  refl,
end

@[reassoc]
lemma germ_stalk_closed_point_to_to_open (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X)
  (U : opens X.carrier) (hU : f.1.base (local_ring.closed_point R : _) ∈ U) :
  X.presheaf.germ ⟨_, hU⟩ ≫ stalk_closed_point_to R f
    ≫ structure_sheaf.to_open R ((opens.map f.val.base).obj U) = f.1.c.app (op U) :=
begin
  haveI H := structure_sheaf.is_iso_to_open_of_closed_point_mem R f U hU,
  rw germ_stalk_closed_point_to_assoc,
  erw @@is_iso.inv_hom_id _ _ H,
  exact category.comp_id _
end

instance {X Y : Scheme} (f : X ⟶ Y)
  [H : is_open_immersion f] (U) : is_iso (f.inv_app U) :=
by { delta Scheme.hom.inv_app, apply_instance }

@[reassoc]
lemma Spec_map_stalk_closed_point_to_from_stalk (R : CommRing) [local_ring R]
  (f : Scheme.Spec.obj (op R) ⟶ X) :
  Scheme.Spec.map (stalk_closed_point_to R f).op ≫ X.from_Spec_stalk _ = f :=
begin
  rw [Scheme.from_Spec_stalk, is_affine_open.from_Spec_stalk, ← functor.map_comp_assoc,
    ← op_comp],
  convert is_open_immersion.lift_fac _ _ _,
  rotate, { apply_instance },
  { rw [is_affine_open.from_Spec_range, ← set.image_univ,
      set.image_subset_iff, ← opens.map_coe],
    convert (@opens.coe_top (prime_spectrum R) _).symm.subset using 2,
    rw ← @local_ring.closed_point_mem_iff R,
    exact X.affine_cover.covers _ },
  { refine eq.trans _ (Scheme.Spec.image_preimage _),
    rw ← quiver.hom.op_unop (Scheme.Spec.preimage _),
    congr' 2,
    rw [germ_stalk_closed_point_to],
    erw @@is_iso.comp_inv_eq _ _ (structure_sheaf.is_iso_to_open_of_closed_point_mem R f _ _),
    rw ← structure_sheaf.to_open_res _ _ _ (hom_of_le le_top),
    swap, { apply_instance },
    erw [Spec_Γ_naturality'_assoc, Scheme.Spec.image_preimage],
    let U := (X.affine_cover.map (f.1.base (closed_point R : _))).opens_range,
    have hU : is_affine_open U := range_is_affine_open_of_open_immersion _,
    have : hU.from_Spec.opens_functor.obj ⊤ = U :=
      opens.ext (set.image_univ.trans hU.from_Spec_range),
    convert_to f.1.c.app (op U) = to_Spec_Γ (X.presheaf.obj $ op U) ≫ _,
    rw [Scheme.Γ_map, quiver.hom.unop_op, is_open_immersion.lift_app, category.assoc,
      category.assoc, ← category.assoc,
      (is_iso.eq_inv_comp _).mpr (f.1.c.naturality (eq_to_hom this.symm).op)],
    erw ← functor.map_comp,
    congr' 2,
    rw [Scheme.hom.inv_app, ← is_iso.comp_inv_eq, ← functor.map_inv, ← op_inv, inv_eq_to_hom,
      PresheafedSpace.is_open_immersion.inv_inv_app,
      nat_trans.naturality_assoc, is_affine_open.from_Spec_app_eq],
    simp only [eq_to_hom_op, eq_to_hom_map, eq_to_hom_trans, category.assoc,
      eq_to_hom_refl, category.comp_id],
    refl }
end

-- lemma Spec_map_comp_from_Spec_app {R : Type*} [comm_ring R] {X : Scheme} {U : opens X.carrier}
--   (hU : is_affine_open U) (f : X.presheaf.obj (op U) ⟶ CommRing.of R) :
--   (Scheme.Spec.map f.op ≫ hU.from_Spec).1.c.app (op U) = f ≫
--     structure_sheaf.to_open R ((opens.map (Scheme.Spec.map f.op ≫ hU.from_Spec).1.base).obj U) :=
-- begin
--   rw [Scheme.comp_val_c_app, is_affine_open.from_Spec_app_eq, category.assoc,
--     nat_trans.naturality, ← category.assoc],
--   convert_to (Γ_Spec.adjunction.counit.app (op (CommRing.of R)) ≫ f.op).unop ≫ _ = _,
--   { congr' 1, rw ← Γ_Spec.adjunction.counit_naturality f.op, refl },
--   convert_to (f ≫ to_Spec_Γ (CommRing.of R)) ≫ _ = _,
--   rw category.assoc,
--   congr' 1
-- end

lemma Spec_to_equiv_of_local_ring_eq_iff {R : CommRing} [local_ring R] {X : Scheme}
  {f₁ f₂ : Σ (x : X.carrier), { f : X.presheaf.stalk x ⟶ R // is_local_ring_hom f }} :
  f₁ = f₂ ↔ ∃ h₁ : f₁.1 = f₂.1, f₁.2.1 =
    X.presheaf.stalk_specializes (specializes_of_eq h₁.symm) ≫ f₂.2.1 :=
begin
  split,
  { rintro rfl, refine ⟨rfl, by simp⟩ },
  { rcases ⟨f₁, f₂⟩ with ⟨⟨_, ⟨⟩⟩, _, ⟨⟩⟩, dsimp, rintro ⟨rfl, rfl⟩, congr' 2,
    apply Top.presheaf.stalk_hom_ext, intros U hU, simp },
end

@[reassoc]
lemma Scheme.stalk_specializes_from_Spec_stalk {X : Scheme} {x y : X.carrier} (h : x ⤳ y) :
  Scheme.Spec.map (X.presheaf.stalk_specializes h).op ≫ X.from_Spec_stalk y =
    X.from_Spec_stalk x :=
begin
  rw Scheme.from_Spec_stalk,
  generalize_proofs _ _ h₁ h₂,
  rw ← h₁.from_Spec_stalk_eq _ (h.mem_open (X.affine_cover.map y).opens_range.2 h₂),
  delta is_affine_open.from_Spec_stalk,
  rw [← Scheme.Spec.map_comp_assoc, ← op_comp, Top.presheaf.germ_stalk_specializes'],
  refl
end

def Spec_to_equiv_of_local_ring (R : CommRing) [local_ring R] (X : Scheme) :
  (Scheme.Spec.obj (op R) ⟶ X) ≃
    Σ (x : X.carrier), { f : X.presheaf.stalk x ⟶ R // is_local_ring_hom f } :=
{ to_fun := λ f, ⟨f.1.base (closed_point R : _), stalk_closed_point_to R f, infer_instance⟩,
  inv_fun := λ xf, Scheme.Spec.map xf.2.1.op ≫ X.from_Spec_stalk xf.1,
  left_inv := Spec_map_stalk_closed_point_to_from_stalk R,
  right_inv := begin
    rintros ⟨x, f, hf⟩,
    resetI,
    have : (Scheme.Spec.map f.op ≫ X.from_Spec_stalk x).1.base (closed_point R : _) = x,
    { convert_to (X.from_Spec_stalk x).val.base (prime_spectrum.comap f $ closed_point R) = x,
      rw [local_ring.comap_closed_point, Scheme.from_Spec_stalk_closed_point] },
    refine Spec_to_equiv_of_local_ring_eq_iff.mpr ⟨_, _⟩,
    { dsimp only, exact this },
    { dsimp only,
      apply quiver.hom.op_inj,
      apply Scheme.Spec.map_injective,
      rw [← cancel_mono (X.from_Spec_stalk _), Spec_map_stalk_closed_point_to_from_stalk, op_comp,
        functor.map_comp_assoc, Scheme.stalk_specializes_from_Spec_stalk],
      apply_instance }
  end }
.

lemma stalk_closed_point_to_from_Spec_stalk {X : Scheme} (x : X.carrier) :
  stalk_closed_point_to (X.presheaf.stalk x) (X.from_Spec_stalk x) =
  X.presheaf.stalk_specializes (specializes_of_eq (Scheme.from_Spec_stalk_closed_point x).symm) :=
begin
  obtain ⟨e₁, e₂⟩ := Spec_to_equiv_of_local_ring_eq_iff.mp
    ((Spec_to_equiv_of_local_ring _ X).apply_symm_apply ⟨x, 𝟙 _, infer_instance⟩),
  dsimp [Spec_to_equiv_of_local_ring, - Scheme.Spec_map_2] at e₂,
  rw category.comp_id at e₂,
  convert e₂ using 2,
  rw Scheme.Spec.map_id,
  exact (category.id_comp _).symm,
end

lemma is_affine_open.from_Spec_stalk_app (X : Scheme)
  {x : X.carrier} {U : opens X.carrier} (h : x ∈ U) :
  (X.from_Spec_stalk x).1.c.app (op U) = X.presheaf.germ ⟨x, h⟩ ≫
    structure_sheaf.to_open (X.presheaf.stalk x)
      ((opens.map (X.from_Spec_stalk x).1.base).obj U) :=
begin
  have : (X.from_Spec_stalk x).1.base (local_ring.closed_point $ X.presheaf.stalk x : _) ∈ U,
  { rwa Scheme.from_Spec_stalk_closed_point },
  haveI H := structure_sheaf.is_iso_to_open_of_closed_point_mem
    (X.presheaf.stalk x) (X.from_Spec_stalk x) U this,
  have : X.presheaf.germ ⟨_, this⟩ ≫
    stalk_closed_point_to (X.presheaf.stalk x) (X.from_Spec_stalk x) =
     X.presheaf.germ ⟨x, h⟩,
  { rw [stalk_closed_point_to_from_Spec_stalk, Top.presheaf.germ_stalk_specializes'], refl },
  rw [germ_stalk_closed_point_to] at this,
  exact (@@is_iso.comp_inv_eq _ _ H).mp this,
end

lemma stalk_map_from_Spec_stalk
  {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
    Scheme.Spec.map (PresheafedSpace.stalk_map f.1 x).op ≫ Y.from_Spec_stalk _ =
      X.from_Spec_stalk x ≫ f :=
begin
  apply (@equiv.apply_eq_iff_eq_symm_apply _ _ (Spec_to_equiv_of_local_ring _ Y).symm
    ⟨f.1.base x, PresheafedSpace.stalk_map f.1 x, infer_instance⟩ _).mpr _,
  refine Spec_to_equiv_of_local_ring_eq_iff.mpr ⟨_, _⟩,
  { dsimp [Spec_to_equiv_of_local_ring], rw Scheme.from_Spec_stalk_closed_point },
  { apply Scheme.stalk_hom_affine_ext,
    intros U hU hxU,
    dsimp [Spec_to_equiv_of_local_ring],
    rw Top.presheaf.germ_stalk_specializes'_assoc,
    erw PresheafedSpace.stalk_map_germ f.1 U ⟨x, hxU⟩,
    convert (germ_stalk_closed_point_to _ (X.from_Spec_stalk x ≫ f) _ _).symm using 1,
    erw @@is_iso.eq_comp_inv _ _ (structure_sheaf.is_iso_to_open_of_closed_point_mem _ _ _ _),
    rw Scheme.comp_val_c_app,
    dsimp only [functor.op],
    rw is_affine_open.from_Spec_stalk_app, swap, { exact hxU },
    exact category.assoc _ _ _ }
end

end local_ring_to_Scheme

section residue_field

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

def Scheme.residue_field (X : Scheme) (x : X.carrier) : CommRing :=
CommRing.of $ local_ring.residue_field (X.presheaf.stalk x)

instance {x : X.carrier} : field (X.residue_field x) :=
show field (local_ring.residue_field _), by apply_instance

def Scheme.to_residue_field (X : Scheme) (x) : X.stalk x ⟶ X.residue_field x :=
local_ring.residue _

def Scheme.desc_residue_field {K : Type*} [field K] (X : Scheme) {x}
  (f : X.stalk x ⟶ CommRing.of K) [is_local_ring_hom f] : X.residue_field x ⟶ CommRing.of K :=
local_ring.lift_residue_field f

@[simp, reassoc]
lemma Scheme.to_desc_residue_field {K : Type*} [field K] (X : Scheme) {x}
  (f : X.stalk x ⟶ CommRing.of K) [is_local_ring_hom f] :
  X.to_residue_field x ≫ X.desc_residue_field f = f :=
ring_hom.ext (λ _, rfl)

instance (x) : epi (X.to_residue_field x) :=
begin
  refine (forget _).epi_of_epi_map _,
  exact (epi_iff_surjective _).mpr ideal.quotient.mk_surjective
end

instance (x) : is_local_ring_hom (X.to_residue_field x) := local_ring.is_local_ring_hom_residue

def Scheme.residue_field_of_eq (X : Scheme) {x y : X.carrier} (h : x = y) :
  X.residue_field y ⟶ X.residue_field x :=
X.desc_residue_field
  (X.presheaf.stalk_specializes (specializes_of_eq h) ≫ X.to_residue_field x)

@[simp, reassoc]
lemma Scheme.to_residue_field_of_eq (x y) (e : x = y) :
  X.to_residue_field _ ≫ X.residue_field_of_eq e =
    (X.presheaf.stalk_congr $ inseparable.of_eq e.symm).hom ≫ X.to_residue_field _ :=
rfl

@[simp, reassoc]
lemma Scheme.residue_field_of_eq_trans (X : Scheme) {x y z : X.carrier} (h : x = y) (h' : y = z) :
  X.residue_field_of_eq h' ≫ X.residue_field_of_eq h = X.residue_field_of_eq (h.trans h') :=
by { rw ← cancel_epi (X.to_residue_field z), simpa }

@[simp]
lemma Scheme.residue_field_of_eq_refl (X : Scheme) {x : X.carrier} :
  X.residue_field_of_eq (refl x) = 𝟙 _ :=
begin
  rw [← cancel_epi (X.to_residue_field x), Scheme.to_residue_field_of_eq,
    Top.presheaf.stalk_congr_hom],
  erw [X.presheaf.stalk_specializes_refl x, category.id_comp],
end

def Scheme.hom.map_residue_field {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
  Y.residue_field (f.1.base x) ⟶ X.residue_field x :=
Y.desc_residue_field (PresheafedSpace.stalk_map f.1 x ≫ X.to_residue_field x)

@[simp, reassoc]
lemma Scheme.to_residue_field_map_residue_field {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
  Y.to_residue_field (f.1.base x) ≫ f.map_residue_field x =
    PresheafedSpace.stalk_map f.1 x ≫ X.to_residue_field x :=
Y.to_desc_residue_field (PresheafedSpace.stalk_map f.1 x ≫ X.to_residue_field x)

def Scheme.from_Spec_residue_field (X : Scheme) (x : X.carrier) :
  Scheme.Spec.obj (op $ X.residue_field x) ⟶ X :=
Scheme.Spec.map (CommRing.of_hom $ local_ring.residue _).op ≫ X.from_Spec_stalk x

@[instance]
lemma Scheme.mono_from_Spec_residue_field {X : Scheme} (x : X.carrier) :
  mono (X.from_Spec_residue_field x) :=
begin
  rw Scheme.from_Spec_residue_field,
  apply_with mono_comp { instances := ff },
  swap, { apply_instance },
  apply_with functor.map_mono { instances := ff },
  { apply_instance },
  apply_with category_theory.op_mono_of_epi { instances := ff },
  apply concrete_category.epi_of_surjective,
  exact ideal.quotient.mk_surjective,
end

@[simp, reassoc]
lemma Scheme.residue_field_of_eq_from_Spec (X : Scheme) {x y : X.carrier} (h : x = y) :
  Scheme.Spec.map (X.residue_field_of_eq h).op ≫ X.from_Spec_residue_field y =
    X.from_Spec_residue_field x :=
begin
  subst h,
  rw [Scheme.residue_field_of_eq_refl, op_id, category_theory.functor.map_id, category.id_comp],
end

lemma Scheme.hom.map_residue_field_from_Spec_residue_field
  {X Y : Scheme} (f : X ⟶ Y) (x : X.carrier) :
    Scheme.Spec.map (f.map_residue_field x).op ≫ Y.from_Spec_residue_field _ =
      X.from_Spec_residue_field x ≫ f :=
begin
  rw [Scheme.from_Spec_residue_field, Scheme.from_Spec_residue_field, category.assoc,
    ← stalk_map_from_Spec_stalk, ← functor.map_comp_assoc, ← op_comp],
  convert eq.trans _ (Scheme.Spec.map_comp_assoc _ _ _),
  all_goals { delta PresheafedSpace.stalk, cases X.presheaf.stalk x, refl },
end

lemma Scheme.hom.map_residue_field_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  (x : X.carrier) :
  (f ≫ g).map_residue_field x = g.map_residue_field (f.1.base x) ≫ f.map_residue_field x :=
begin
  apply ideal.quotient.ring_hom_ext,
  transitivity (local_ring.residue (X.presheaf.stalk x)).comp
    (PresheafedSpace.stalk_map (f ≫ g).1 x),
  { refl },
  { erw PresheafedSpace.stalk_map.comp, ext, refl }
end
.
lemma Scheme.hom.map_residue_field_congr {X Y : Scheme} {f g : X ⟶ Y} (e : f = g)
  (x : X.carrier) :
  f.map_residue_field x = Y.residue_field_of_eq (by rw e) ≫ g.map_residue_field x :=
begin
  subst e,
  rw [Scheme.residue_field_of_eq_refl, category.id_comp],
end

lemma Scheme.hom.map_residue_field_eq {X Y : Scheme} (f : X ⟶ Y) (x) :
  f.map_residue_field x = local_ring.residue_field.map (PresheafedSpace.stalk_map f.1 x) :=
begin
  ext, refl,
end

instance {X Y : Scheme} (f : X ⟶ Y) [is_open_immersion f] (x) :
  is_iso (f.map_residue_field x) :=
begin
  rw [CommRing.is_iso_iff_bijective, Scheme.hom.map_residue_field_eq],
  exact (local_ring.residue_field.map_equiv
    (as_iso $ PresheafedSpace.stalk_map f.1 x).CommRing_iso_to_ring_equiv).bijective
end

lemma Scheme.from_Spec_residue_field_base (x : X.carrier) (s) :
  (X.from_Spec_residue_field x).1.base s = x :=
begin
  rw [Scheme.from_Spec_residue_field, Scheme.comp_val_base, comp_apply],
  convert Scheme.from_Spec_stalk_closed_point x,
  convert prime_spectrum.comap_residue _,
end

lemma Scheme.range_from_Spec_residue_field  (x : X.carrier) :
  set.range (X.from_Spec_residue_field x).1.base = {x} :=
begin
  ext y,
  simp only [set.mem_range, set.mem_singleton_iff, Scheme.from_Spec_residue_field_base],
  exact ⟨λ ⟨a, b⟩, b.symm, λ e, ⟨(⊥ : prime_spectrum (X.residue_field x)), e.symm⟩⟩,
end
.
lemma Spec_map_desc_residue_field_from_Spec_residue_field (K : Type*) [field K] (X : Scheme)
  (f : Scheme.Spec.obj (op $ CommRing.of K) ⟶ X) :
  Scheme.Spec.map (X.desc_residue_field (stalk_closed_point_to _ f)).op
    ≫ X.from_Spec_residue_field (f.1.base (local_ring.closed_point K)) = f :=
begin
  dsimp only [Scheme.from_Spec_residue_field],
  rw [← Scheme.Spec.map_comp_assoc, ← op_comp],
  exact Spec_map_stalk_closed_point_to_from_stalk _ f
end

lemma Spec_to_equiv_of_field_eq_iff {K : Type*} [field K] {X : Scheme}
  {f₁ f₂ : Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K} :
  f₁ = f₂ ↔ ∃ e : f₁.1 = f₂.1,f₁.2 = X.residue_field_of_eq e.symm ≫ f₂.2 :=
by { split, { rintro rfl, exact ⟨rfl, by simp⟩ },
  { cases f₁, cases f₂, dsimp, rintro ⟨rfl, rfl⟩, congr, simp  } }

lemma Spec_to_equiv_of_field_right_inv {K : Type*} [field K] {X : Scheme}
  (xf : Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K) :
  (sigma.mk _ (X.desc_residue_field (stalk_closed_point_to _ $
    Scheme.Spec.map xf.2.op ≫ X.from_Spec_residue_field xf.1)) :
      Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K) = xf :=
begin
  haveI : nontrivial (CommRing.of K) := show nontrivial K, by apply_instance,
  refine Spec_to_equiv_of_field_eq_iff.mpr ⟨_, _⟩,
  { exact Scheme.from_Spec_residue_field_base _ _ },
  apply ideal.quotient.ring_hom_ext,
  dsimp,
  convert_to stalk_closed_point_to (CommRing.of K)
    (Scheme.Spec_map xf.snd ≫ X.from_Spec_residue_field xf.fst) = _,
  have := is_local_ring_hom_comp xf.2 (local_ring.residue $ X.presheaf.stalk xf.1),
  obtain ⟨_, e₂⟩ := Spec_to_equiv_of_local_ring_eq_iff.mp ((Spec_to_equiv_of_local_ring _ X)
    .right_inv ⟨xf.1, CommRing.of_hom (local_ring.residue _) ≫ xf.2, this⟩),
  dsimp only [Spec_to_equiv_of_local_ring] at e₂,
  convert e₂ using 1,
  congr' 1,
  rw [op_comp, Scheme.Spec.map_comp_assoc],
  refl
end
.

@[simps]
def Spec_to_equiv_of_field (K : Type*) [field K] (X : Scheme) :
  (Scheme.Spec.obj (op $ CommRing.of $ K) ⟶ X) ≃
    Σ x : X.carrier, X.residue_field x ⟶ CommRing.of K :=
{ to_fun := λ f, ⟨_, X.desc_residue_field (stalk_closed_point_to _ f)⟩,
  inv_fun := λ xf, Scheme.Spec.map xf.2.op ≫ X.from_Spec_residue_field xf.1,
  left_inv := Spec_map_desc_residue_field_from_Spec_residue_field K X,
  right_inv := Spec_to_equiv_of_field_right_inv }

end residue_field

end algebraic_geometry


import SciLean.Core
-- import SciLean.Core.IsSmooth

open SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [Vec X] [Vec Y] [Vec Z] [Vec W]

namespace maintests

  variable {α β γ : Type}

  variable (f : Y → Z) (g : X → Y) [IsSmoothT f] [IsSmoothT g] (h : X → X) [IsSmoothT h] (h' : Y → Y) [IsSmoothT h']
  variable (a : α) (b : β)
  variable (F : Y → α → X) [IsSmoothT F]
  variable (G : X → α → β → Y) [IsSmoothT G]
  variable (G' : X → Z → W → Y) (z : Z) (w : W) [IsSmoothT G']
  variable (H : α → X → β → Y) [IsSmoothT (H a)]
  variable (H': α → β → X → Y) [IsSmoothT (H' a b)]

  example : IsSmoothT (λ x => g x) := by infer_instance
  example : IsSmoothT (λ x => f (g x)) := by infer_instance
  example : IsSmoothT (λ x => f (g (h (h x)))) := by infer_instance
  example : IsSmoothT (λ (g' : X → Y) => f ∘ g') := by unfold Function.comp; infer_instance
  example : IsSmoothT (λ (x : X) => F (g (h x)) a) := by infer_instance
  example : IsSmoothT (f ∘ g) := by unfold Function.comp; infer_instance
  example : IsSmoothT (λ (f : Y → Z) (x : X) => (f (g x))) := by infer_instance
  example : IsSmoothT (λ (h'' : X → X) (x : X) => h (h (h (h'' ((h ∘ h) (h x)))))) := by infer_instance
  example : IsSmoothT (λ (x : X) => G (h x) a b) := by infer_instance
  example : IsSmoothT (λ (x : X) => H a (h x) b) := by infer_instance
  example : IsSmoothT (λ (x : X) => H' a b (h x)) := by infer_instance
  example (f : β → Y → Z) [∀ b, IsSmoothT (f b)] : IsSmoothT (λ (g : α → Y) (b : β) (a : α) => f b (g a)) := by infer_instance
  example (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]: IsSmoothT (λ x => f x x) := by infer_instance
  example (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (λ x => f (h x) x) := by infer_instance
  example (f : X → X → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (λ x => f x (h x)) := by infer_instance
  example : IsSmoothT (λ (h : X → X) (x : X) => H' a b (h x)) := by infer_instance
  example (f : Y → Z) (g : X → Y) [IsSmoothT f] [IsSmoothT g] : IsSmoothT (f ∘ g) := by unfold Function.comp; infer_instance
  example (g : α → β) : IsSmoothT (λ (f : β → Z) (a : α) => (f (g a))) := by infer_instance
  example (f : Y → β → Z) (g : X → Y) (b : β) [IsSmoothT f] [IsSmoothT g] : IsSmoothT (λ x => f (g x) d) := by infer_instance
  example (f : Y → β → Z) (g : X → Y) (h : X → X) (b : β) [IsSmoothT f] [IsSmoothT g] [IsSmoothT h] : IsSmoothT (λ x => f (g (h (h x))) d) := by infer_instance
  example (f : α → Y → Z) [∀ a, IsSmoothT (f a)] : IsSmoothT (λ y a => f a y) := by infer_instance
  example (f : α → β → X → Y) [∀ a b, IsSmoothT (f a b)] : IsSmoothT (λ x b a => f a b x) := by infer_instance
  example (f : α → β → X → Y) [∀ a b, IsSmoothT (f a b)] : IsSmoothT (λ x a b => f a b x) := by infer_instance
  example (f : α → β → γ → X → Y) [∀ a b c, IsSmoothT (f a b c)] : IsSmoothT (λ x a b c => f a b c x) := by infer_instance
  example (f : X → X) [IsSmoothT f] : IsSmoothT (λ (g : X → X) x => f (f (g x))) := by infer_instance
  example (f : X → X → β → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y] : IsSmoothT (λ x b => f x x b) := by infer_instance
  example : IsSmoothT (λ (g : X → Y) (x : X) => F (g (h x)) a) := by infer_instance
  example : IsSmoothT (λ (x : X) => G' (h x) z w) := by infer_instance
  example (f : X → X → β → Y) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]  (b) : IsSmoothT (λ x => f x x b) := by infer_instance
  -- example (f : X → X → β → Y) (b) [IsSmoothNT 2 (λ x y => f x y b)] : IsSmoothT (λ x => f x x b) := by infer_instance
  example : IsSmoothT (λ (h : X → X) (x : X) => G (h x)) := by infer_instance

  example : IsSmoothT (λ (h : X → X) (x : X) => G (h x) a b) := by infer_instance
  example : IsSmoothT (λ (h : X → X) (x : X) => H a (h x) b) := by infer_instance
  example : IsSmoothT (λ (x : X) => h (F (h' ((h' ∘ g) (h x))) a)) := by unfold Function.comp; infer_instance
  example : IsSmoothT (λ (h'' : X → X) (x : X) => (h ∘ h ∘ h) (h (h'' (h ((h ∘ h) x))))) := by unfold Function.comp; infer_instance

end maintests

namespace foldtest

variable {α β γ : Type}
variable {X : Type} {Y : Type} {Z : Type} [Vec X] [Vec Y] [Vec Z]

variable (f : X → X) [IsSmoothT f]

example : IsSmoothT (λ x => f x) := by infer_instance
example : IsSmoothT (λ x => f (f x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f (g x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => g (f x)) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (g x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f (f (g x))) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f (g (f x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (g x))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => g (f (f x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (f (g x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (g (f x))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => g (g (g x))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => f (f (f (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => f (f (g (f x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (f (g (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => f (g (f (f x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (f (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (g (f x)))) := by infer_instance
example : IsSmoothT (λ (g : X ⟿ X) x => f (g (g (g x)))) := by infer_instance
example : IsSmoothT (λ (g : X → X)  x => g (f (f (f x)))) := by infer_instance

end foldtest

namespace forktest

variable {α β γ : Type}
variable {X : Type} {Y : Type} {Z : Type} [Vec X] [Vec Y] [Vec Z]

variable (f : X → X → X) [∀ x, IsSmoothT (f x)] [IsSmoothT λ x => λ y ⟿ f x y]

example : IsSmoothT (λ x => f x x) := by infer_instance
example : IsSmoothT (λ x => f (f x x) x) := by infer_instance
example : IsSmoothT (λ x => f x (f x x)) := by infer_instance
example : IsSmoothT (λ x => f (f x x) (f x x)) := by infer_instance
example : IsSmoothT (λ x => f (f (f x x) x) x) := by infer_instance
example : IsSmoothT (λ x => f (f x (f x x)) x) := by infer_instance
example : IsSmoothT (λ x => f x (f (f x x) x)) := by infer_instance
example : IsSmoothT (λ x => f x (f x (f x x))) := by infer_instance

example : IsSmoothT (λ (g : X → X) x => f (g x) x) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f x (g x)) := by infer_instance
example : IsSmoothT (λ (g : X → X) x => f x (g x)) := by infer_instance

end forktest

namespace combtests
  variable {α β γ : Type}
  variable {X : Type} {Y : Type} {Z : Type} [Vec X] [Vec Y] [Vec Z]

  example (f : X → X) [IsSmoothT f] : IsSmoothT ((f ∘ f) ∘ (f ∘ (f ∘ f))) := by unfold Function.comp; infer_instance
  example (f : β → X → Y) (g : α → β) (a : α) [IsSmoothT (f (g a))] : IsSmoothT ((f ∘ g) a) := by simp; infer_instance
  example (y : X) (A : X → X) (B : X → X) [IsSmoothT A] [IsSmoothT B] : IsSmoothT λ x => (B∘A) x + B (A (B x) + B x) := by unfold Function.comp; infer_instance
  example (y : X) (A : X → X) (B : X → X) [IsSmoothT A] [IsSmoothT B] : IsSmoothT (λ x : X => x + x) := by infer_instance
end combtests

section highorderfunctions

variable {X Y : Type} [Hilbert X] [Hilbert Y]

example : IsSmoothT fun (g : X⟿Y) => λ x ⟿ (c:ℝ) * g x := by infer_instance
example : IsSmoothT fun (g : ℝ⟿Y) => λ x ⟿ x * g x := by infer_instance
example : IsSmoothT fun (g : ℝ⟿ℝ) => λ x ⟿ g x * x := by apply IsSmoothT_rule_S₂ (λ (x y : ℝ) => y * x)
example  (f : X⟿Y) : IsSmoothT fun (g : X⟿Y) => λ x ⟿ ⟪f x, g x⟫ := by infer_instance
example  (f : X⟿Y) : IsSmoothT fun (g : X⟿Y) => λ x ⟿ ⟪g x, f x⟫ := by apply IsSmoothT_rule_S₂ (λ x y => ⟪y, f x⟫)
example  (f : X⟿Y) (A B : Y → Y) [IsSmoothT A] [IsSmooth B] : IsSmoothT fun (g : X⟿Y) => λ x ⟿ ⟪A (g x), B (f x)⟫ := by apply IsSmoothT_rule_S₂ (λ x y => ⟪A y, B (f x)⟫)
example : IsSmoothT fun (g : ℝ⟿Y) => λ x ⟿ x * g x := by infer_instance

end highorderfunctions

section argument_shuffling

-- Test in forgeting smoothenss in various components

--IsSmoothN 2 to IsSmooth
example (f : X → Y → Z) [IsSmoothN 2 f]
  : IsSmoothT f := by infer_instance

example (f : X → Y → Z) [IsSmoothN 2 f] (x : X)
  : IsSmoothT (f x) := by infer_instance

example (f : X → Y → Z) [IsSmoothN 2 f] (y : Y)
  : IsSmoothT (λ y => f x y) := by infer_instance

-- IsSmoothN 3 to IsSmooth
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x y z => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X)
  : IsSmoothT (f x) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X) (y : Y)
  : IsSmoothT (f x y) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X) (z : Z)
  : IsSmoothT (λ y => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (y : Y) (z : Z)
  : IsSmoothT (λ x => f x y z) := by infer_instance

-- IsSmoothN 3 to effectively IsSmoothN 2
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ λ z => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z ⟿ λ y => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ x ⟿ λ z => f x y z) := by infer_instance
set_option synthInstance.maxSize 300 in
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ z ⟿ λ x => f x y z) := by infer_instance
set_option synthInstance.maxSize 300 in
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ z => λ x ⟿ λ y => f x y z) := by infer_instance
set_option synthInstance.maxSize 500 in
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ z => λ y ⟿ λ x => f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (z : Z)
  : IsSmoothT (λ x => λ y ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (y : Y)
  : IsSmoothT (λ x => λ z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f] (x : X)
  : IsSmoothT (λ y => λ z ⟿ f x y z) := by infer_instance

-- Duplicating arguments
example (f : X → X → Z) [IsSmoothN 2 f]
  : IsSmoothT (λ x => f x x) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x x y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x x y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x y x) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f y x x) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x y y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f y x y) := by infer_instance

example (f : X → X → X → Z) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ y ⟿ f x y y) := by infer_instance

-- Permuting arguments
example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z y ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x => λ z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ x y => λ z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ x z ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ z => λ x y ⟿ f x y z) := by infer_instance

example (f : X → Y → Z → W) [IsSmoothN 3 f]
  : IsSmoothT (λ y => λ x z ⟿ f x y z) := by infer_instance

end argument_shuffling


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner
-/
import data.bool.basic
import meta.rb_map
import tactic.lint.basic

/-!
# Linters about type classes

This file defines several linters checking the correct usage of type classes
and the appropriate definition of instances:

 * `instance_priority` ensures that blanket instances have low priority.
 * `has_inhabited_instances` checks that every type has an `inhabited` instance.
 * `impossible_instance` checks that there are no instances which can never apply.
 * `incorrect_type_class_argument` checks that only type classes are used in
   instance-implicit arguments.
 * `dangerous_instance` checks for instances that generate subproblems with metavariables.
 * `fails_quickly` checks that type class resolution finishes quickly.
 * `class_structure` checks that every `class` is a structure, i.e. `@[class] def` is forbidden.
 * `has_coe_variable` checks that there is no instance of type `has_coe α t`.
 * `inhabited_nonempty` checks whether `[inhabited α]` arguments could be generalized
   to `[nonempty α]`.
 * `decidable_classical` checks propositions for `[decidable_... p]` hypotheses that are not used
   in the statement, and could thus be removed by using `classical` in the proof.
 * `linter.has_coe_to_fun` checks whether necessary `has_coe_to_fun` instances are declared.
 * `linter.check_reducibility` checks whether non-instances with a class as type are reducible.
-/

open tactic

/-- Pretty prints a list of arguments of a declaration. Assumes `l` is a list of argument positions
and binders (or any other element that can be pretty printed).
`l` can be obtained e.g. by applying `list.indexes_values` to a list obtained by
`get_pi_binders`. -/
meta def print_arguments {α} [has_to_tactic_format α] (l : list (ℕ × α)) : tactic string := do
  fs ← l.mmap (λ ⟨n, b⟩, (λ s, to_fmt "argument " ++ to_fmt (n+1) ++ ": " ++ s) <$> pp b),
  return $ fs.to_string_aux tt

/-- checks whether an instance that always applies has priority ≥ 1000. -/
private meta def instance_priority (d : declaration) : tactic (option string) := do
  let nm := d.to_name,
  b ← is_instance nm,
  /- return `none` if `d` is not an instance -/
  if ¬ b then return none else do
  (is_persistent, prio) ← has_attribute `instance nm,
  /- return `none` if `d` is has low priority -/
  if prio < 1000 then return none else do
  (_, tp) ← open_pis d.type,
  tp ← whnf tp transparency.none,
  let (fn, args) := tp.get_app_fn_args,
  cls ← get_decl fn.const_name,
  let (pi_args, _) := cls.type.pi_binders,
  guard (args.length = pi_args.length),
  /- List all the arguments of the class that block type-class inference from firing
    (if they are metavariables). These are all the arguments except instance-arguments and
    out-params. -/
  let relevant_args := (args.zip pi_args).filter_map $ λ⟨e, ⟨_, info, tp⟩⟩,
    if info = binder_info.inst_implicit ∨ tp.get_app_fn.is_constant_of `out_param
    then none else some e,
  let always_applies := relevant_args.all expr.is_local_constant ∧ relevant_args.nodup,
  if always_applies then return $ some "set priority below 1000" else return none

/--
There are places where typeclass arguments are specified with implicit `{}` brackets instead of
the usual `[]` brackets. This is done when the instances can be inferred because they are implicit
arguments to the type of one of the other arguments. When they can be inferred from these other
arguments,  it is faster to use this method than to use type class inference.

For example, when writing lemmas about `(f : α →+* β)`, it is faster to specify the fact that `α`
and `β` are `semiring`s as `{rα : semiring α} {rβ : semiring β}` rather than the usual
`[semiring α] [semiring β]`.
-/
library_note "implicit instance arguments"

/--
Certain instances always apply during type-class resolution. For example, the instance
`add_comm_group.to_add_group {α} [add_comm_group α] : add_group α` applies to all type-class
resolution problems of the form `add_group _`, and type-class inference will then do an
exhaustive search to find a commutative group. These instances take a long time to fail.
Other instances will only apply if the goal has a certain shape. For example
`int.add_group : add_group ℤ` or
`add_group.prod {α β} [add_group α] [add_group β] : add_group (α × β)`. Usually these instances
will fail quickly, and when they apply, they are almost the desired instance.
For this reason, we want the instances of the second type (that only apply in specific cases) to
always have higher priority than the instances of the first type (that always apply).
See also #1561.

Therefore, if we create an instance that always applies, we set the priority of these instances to
100 (or something similar, which is below the default value of 1000).
-/
library_note "lower instance priority"

/-- A linter object for checking instance priorities of instances that always apply.
This is in the default linter set. -/
@[linter] meta def linter.instance_priority : linter :=
{ test := instance_priority,
  no_errors_found := "All instance priorities are good.",
  errors_found := "DANGEROUS INSTANCE PRIORITIES.
The following instances always apply, and therefore should have a priority < 1000.
If you don't know what priority to choose, use priority 100.
See note [lower instance priority] for instructions to change the priority.",
  auto_decls := tt }

/-- Reports declarations of types that do not have an associated `inhabited` instance. -/
private meta def has_inhabited_instance (d : declaration) : tactic (option string) := do
tt ← pure d.is_trusted | pure none,
ff ← has_attribute' `reducible d.to_name | pure none,
ff ← has_attribute' `class d.to_name | pure none,
(_, ty) ← open_pis d.type,
ty ← whnf ty,
if ty = `(Prop) then pure none else do
`(Sort _) ← whnf ty | pure none,
insts ← attribute.get_instances `instance,
insts_tys ← insts.mmap $ λ i, expr.pi_codomain <$> declaration.type <$> get_decl i,
let inhabited_insts := insts_tys.filter (λ i,
  i.app_fn.const_name = ``inhabited ∨ i.app_fn.const_name = `unique),
let inhabited_tys := inhabited_insts.map (λ i, i.app_arg.get_app_fn.const_name),
if d.to_name ∈ inhabited_tys then
  pure none
else
  pure "inhabited instance missing"

/-- A linter for missing `inhabited` instances. -/
@[linter]
meta def linter.has_inhabited_instance : linter :=
{ test := has_inhabited_instance,
  auto_decls := ff,
  no_errors_found := "No types have missing inhabited instances.",
  errors_found := "TYPES ARE MISSING INHABITED INSTANCES:",
  is_fast := ff }

attribute [nolint has_inhabited_instance] pempty

/-- Checks whether an instance can never be applied. -/
private meta def impossible_instance (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  (binders, _) ← get_pi_binders_nondep d.type,
  let bad_arguments := binders.filter $ λ nb, nb.2.info ≠ binder_info.inst_implicit,
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "Impossible to infer " ++ s) <$> print_arguments bad_arguments

/-- A linter object for `impossible_instance`. -/
@[linter] meta def linter.impossible_instance : linter :=
{ test := impossible_instance,
  auto_decls := tt,
  no_errors_found := "All instances are applicable.",
  errors_found := "IMPOSSIBLE INSTANCES FOUND.
These instances have an argument that cannot be found during type-class resolution, and " ++
"therefore can never succeed. Either mark the arguments with square brackets (if it is a " ++
"class), or don't make it an instance." }

/-- Checks whether an instance can never be applied. -/
private meta def incorrect_type_class_argument (d : declaration) : tactic (option string) := do
  (binders, _) ← get_pi_binders d.type,
  let instance_arguments := binders.indexes_values $
    λ b : binder, b.info = binder_info.inst_implicit,
  /- the head of the type should either unfold to a class, or be a local constant.
  A local constant is allowed, because that could be a class when applied to the
  proper arguments. -/
  bad_arguments ← instance_arguments.mfilter (λ ⟨_, b⟩, do
    (_, head) ← open_pis b.type,
    if head.get_app_fn.is_local_constant then return ff else do
    bnot <$> is_class head),
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "These are not classes. " ++ s) <$> print_arguments bad_arguments

/-- A linter object for `incorrect_type_class_argument`. -/
@[linter] meta def linter.incorrect_type_class_argument : linter :=
{ test := incorrect_type_class_argument,
  auto_decls := tt,
  no_errors_found := "All declarations have correct type-class arguments.",
  errors_found := "INCORRECT TYPE-CLASS ARGUMENTS.
Some declarations have non-classes between [square brackets]:" }

/-- Checks whether an instance is dangerous: it creates a new type-class problem with metavariable
arguments. -/
private meta def dangerous_instance (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  (local_constants, target) ← open_pis d.type,
  let instance_arguments := local_constants.indexes_values $
    λ e : expr, e.local_binding_info = binder_info.inst_implicit,
  let bad_arguments := local_constants.indexes_values $ λ x,
      !target.has_local_constant x &&
      (x.local_binding_info ≠ binder_info.inst_implicit) &&
      instance_arguments.any (λ nb, nb.2.local_type.has_local_constant x),
  let bad_arguments : list (ℕ × binder) := bad_arguments.map $ λ ⟨n, e⟩, ⟨n, e.to_binder⟩,
  _ :: _ ← return bad_arguments | return none,
  (λ s, some $ "The following arguments become metavariables. " ++ s) <$>
    print_arguments bad_arguments

/-- A linter object for `dangerous_instance`. -/
@[linter] meta def linter.dangerous_instance : linter :=
{ test := dangerous_instance,
  no_errors_found := "No dangerous instances.",
  errors_found := "DANGEROUS INSTANCES FOUND.\nThese instances are recursive, and create a new " ++
"type-class problem which will have metavariables.
Possible solution: remove the instance attribute or make it a local instance instead.

Currently this linter does not check whether the metavariables only occur in arguments marked " ++
"with `out_param`, in which case this linter gives a false positive.",
  auto_decls := tt }

/-- Auxilliary definition for `find_nondep` -/
meta def find_nondep_aux : list expr → expr_set → tactic expr_set
| []      r := return r
| (h::hs) r :=
  do type ← infer_type h,
    find_nondep_aux hs $ r.union type.list_local_consts'

/-- Finds all hypotheses that don't occur in the target or other hypotheses. -/
meta def find_nondep : tactic (list expr) := do
  ctx ← local_context,
  tgt ← target,
  lconsts ← find_nondep_aux ctx tgt.list_local_consts',
  return $ ctx.filter $ λ e, !lconsts.contains e

/--
Tests whether type-class inference search will end quickly on certain unsolvable
type-class problems. This is to detect loops or very slow searches, which are problematic
(recall that normal type-class search often creates unsolvable subproblems, which have to fail
quickly for type-class inference to perform well.
We create these type-class problems by taking an instance, and removing the last hypothesis that
doesn't appear in the goal (or a later hypothesis). Note: this argument is necessarily an
instance-implicit argument if it passes the `linter.incorrect_type_class_argument`.
This tactic succeeds if `mk_instance` succeeds quickly or fails quickly with the error
message that it cannot find an instance. It fails if the tactic takes too long, or if any other
error message is raised (usually a maximum depth in the search).
-/
meta def fails_quickly (max_steps : ℕ) (d : declaration) : tactic (option string) := retrieve $ do
  tt ← is_instance d.to_name | return none,
  let e := d.type,
  g ← mk_meta_var e,
  set_goals [g],
  intros,
  l@(_::_) ← find_nondep | return none, -- if all arguments occur in the goal, this instance is ok
  clear l.ilast,
  reset_instance_cache,
  state ← read,
  let state_msg := "\nState:\n" ++ to_string state,
  tgt ← target >>= instantiate_mvars,
  sum.inr msg ← retrieve_or_report_error $ tactic.try_for max_steps $ mk_instance tgt |
    return none, /- it's ok if type-class inference can find an instance with fewer hypotheses.
    This happens a lot for `has_sizeof` and `has_well_founded`, but can also happen if there is a
    noncomputable instance with fewer assumptions. -/
  return $ if "tactic.mk_instance failed to generate instance for".is_prefix_of msg then none else
    some $ (++ state_msg) $
      if msg = "try_for tactic failed, timeout" then "type-class inference timed out" else msg

/--
A linter object for `fails_quickly`.
We currently set the number of steps in the type-class search pretty high.
Some instances take quite some time to fail, and we seem to run against the caching issue in
https://leanprover.zulipchat.com/#narrow/stream/113488-general/topic/odd.20repeated.20type.20class.20search
-/
@[linter] meta def linter.fails_quickly : linter :=
{ test := fails_quickly 15000,
  auto_decls := tt,
  no_errors_found := "No type-class searches timed out.",
  errors_found := "TYPE CLASS SEARCHES TIMED OUT.
The following instances are part of a loop, or an excessively long search.
It is common that the loop occurs in a different class than the one flagged below,
but usually an instance that is part of the loop is also flagged.
To debug:
(1) run `scripts/mk_all.sh` and create a file with `import all` and
`set_option trace.class_instances true`
(2) Recreate the state shown in the error message. You can do this easily by copying the type of
the instance (the output of `#check @my_instance`), turning this into an example and removing the
last argument in square brackets. Prove the example using `by apply_instance`.
For example, if `additive.topological_add_group` raises an error, run
```
example {G : Type*} [topological_space G] [group G] : topological_add_group (additive G) :=
by apply_instance
```
(3) What error do you get?
(3a) If the error is \"tactic.mk_instance failed to generate instance\",
there might be nothing wrong. But it might take unreasonably long for the type-class inference to
fail. Check the trace to see if type-class inference takes any unnecessary long unexpected turns.
If not, feel free to increase the value in the definition of the linter `fails_quickly`.
(3b) If the error is \"maximum class-instance resolution depth has been reached\" there is almost
certainly a loop in the type-class inference. Find which instance causes the type-class inference to
go astray, and fix that instance.",
  is_fast := ff }

/-- Checks that all uses of the `@[class]` attribute apply to structures or inductive types.
  This is future-proofing for lean 4, which no longer supports `@[class] def`. -/
private meta def class_structure (n : name) : tactic (option string) := do
  is_class ← has_attribute' `class n,
  if is_class then do
    env ← get_env,
    pure $ if env.is_inductive n then none else
      "is a non-structure or inductive type marked @[class]"
  else pure none

/-- A linter object for `class_structure`. -/
@[linter] meta def linter.class_structure : linter :=
{ test := λ d, class_structure d.to_name,
  auto_decls := tt,
  no_errors_found := "All classes are structures.",
  errors_found := "USE OF @[class] def IS DISALLOWED:" }

/--
Tests whether there is no instance of type `has_coe α t` where `α` is a variable,
or `has_coe t α` where `α` does not occur in `t`.
See note [use has_coe_t].
-/
private meta def has_coe_variable (d : declaration) : tactic (option string) := do
tt ← is_instance d.to_name | return none,
`(has_coe %%a %%b) ← return d.type.pi_codomain | return none,
if a.is_var then
  return $ some $ "illegal instance, first argument is variable"
else if b.is_var ∧ ¬ b.occurs a then
  return $ some $ "illegal instance, second argument is variable not occurring in first argument"
else
  return none

/-- A linter object for `has_coe_variable`. -/
@[linter] meta def linter.has_coe_variable : linter :=
{ test := has_coe_variable,
  auto_decls := tt,
  no_errors_found := "No invalid `has_coe` instances.",
  errors_found := "INVALID `has_coe` INSTANCES.
Make the following declarations instances of the class `has_coe_t` instead of `has_coe`." }

/-- Checks whether a declaration is prop-valued and takes an `inhabited _` argument that is unused
elsewhere in the type. In this case, that argument can be replaced with `nonempty _`. -/
private meta def inhabited_nonempty (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let inhd_binders := binders.filter $ λ pr, pr.2.type.is_app_of `inhabited,
   if inhd_binders.length = 0 then return none
   else (λ s, some $ "The following `inhabited` instances should be `nonempty`. " ++ s) <$>
      print_arguments inhd_binders

/-- A linter object for `inhabited_nonempty`. -/
@[linter] meta def linter.inhabited_nonempty : linter :=
{ test := inhabited_nonempty,
  auto_decls := ff,
  no_errors_found := "No uses of `inhabited` arguments should be replaced with `nonempty`.",
  errors_found := "USES OF `inhabited` SHOULD BE REPLACED WITH `nonempty`." }

/-- Checks whether a declaration is `Prop`-valued and takes a `decidable* _`
hypothesis that is unused lsewhere in the type.
In this case, that hypothesis can be replaced with `classical` in the proof.
Theorems in the `decidable` namespace are exempt from the check. -/
private meta def decidable_classical (d : declaration) : tactic (option string) :=
do tt ← is_prop d.type | return none,
   ff ← pure $ (`decidable).is_prefix_of d.to_name | return none,
   (binders, _) ← get_pi_binders_nondep d.type,
   let deceq_binders := binders.filter $ λ pr, pr.2.type.is_app_of `decidable_eq
     ∨ pr.2.type.is_app_of `decidable_pred ∨ pr.2.type.is_app_of `decidable_rel
     ∨ pr.2.type.is_app_of `decidable,
   if deceq_binders.length = 0 then return none
   else (λ s, some $ "The following `decidable` hypotheses should be replaced with
                      `classical` in the proof. " ++ s) <$>
      print_arguments deceq_binders

/-- A linter object for `decidable_classical`. -/
@[linter] meta def linter.decidable_classical : linter :=
{ test := decidable_classical,
  auto_decls := ff,
  no_errors_found := "No uses of `decidable` arguments should be replaced with `classical`.",
  errors_found := "USES OF `decidable` SHOULD BE REPLACED WITH `classical` IN THE PROOF." }

/- The file `logic/basic.lean` emphasizes the differences between what holds under classical
and non-classical logic. It makes little sense to make all these lemmas classical, so we add them
to the list of lemmas which are not checked by the linter `decidable_classical`. -/
attribute [nolint decidable_classical] dec_em dec_em' not.decidable_imp_symm

private meta def has_coe_to_fun_linter (d : declaration) : tactic (option string) :=
retrieve $ do
tt ← return d.is_trusted | pure none,
mk_meta_var d.type >>= set_goals ∘ pure,
args ← unfreezing intros,
expr.sort _ ← target | pure none,
let ty : expr := (expr.const d.to_name d.univ_levels).mk_app args,
some coe_fn_inst ←
  try_core $ to_expr ``(_root_.has_coe_to_fun %%ty _) >>= mk_instance | pure none,
set_bool_option `pp.all true,
some trans_inst@(expr.app (expr.app _ trans_inst_1) trans_inst_2) ←
  try_core $ to_expr ``(@_root_.coe_fn_trans %%ty _ _ _ _) | pure none,
tt ← succeeds $ unify trans_inst coe_fn_inst transparency.reducible | pure none,
set_bool_option `pp.all true,
trans_inst_1 ← pp trans_inst_1,
trans_inst_2 ← pp trans_inst_2,
pure $ format.to_string $
  "`has_coe_to_fun` instance is definitionally equal to a transitive instance composed of: " ++
  trans_inst_1.group.indent 2 ++
  format.line ++ "and" ++
  trans_inst_2.group.indent 2

/-- Linter that checks whether `has_coe_to_fun` instances comply with Note [function coercion]. -/
@[linter] meta def linter.has_coe_to_fun : linter :=
{ test := has_coe_to_fun_linter,
  auto_decls := tt,
  no_errors_found := "has_coe_to_fun is used correctly",
  errors_found := "INVALID/MISSING `has_coe_to_fun` instances.
You should add a `has_coe_to_fun` instance for the following types.
See Note [function coercion]." }

/--
Checks whether an instance contains a semireducible non-instance with a class as
type in its value. We add some restrictions to get not too many false positives:
* We only consider classes with an `add` or `mul` field, since those classes are most likely to
  occur as a field to another class, and be an extension of another class.
* We only consider instances of type-valued classes and non-instances that are definitions.
* We currently ignore declarations `foo` that have a `foo._main` declaration. We could look inside,
or at the generated equation lemmas, but it's unlikely that there are many problematic instances
defined using the equation compiler.
-/
meta def check_reducible_non_instances (d : declaration) : tactic (option string) := do
  tt ← is_instance d.to_name | return none,
  ff ← is_prop d.type | return none,
  env ← get_env,
  -- We only check if the class of the instance contains an `add` or a `mul` field.
  let cls := d.type.pi_codomain.get_app_fn.const_name,
  some constrs ← return $ env.structure_fields cls | return none,
  tt ← return $ constrs.mem `add || constrs.mem `mul | return none,
  l ← d.value.list_constant.mfilter $ λ nm, do
  { d ← env.get nm,
    ff ← is_instance nm | return ff,
    tt ← is_class d.type | return ff,
    tt ← return d.is_definition | return ff,
    -- We only check if the class of the non-instance contains an `add` or a `mul` field.
    let cls := d.type.pi_codomain.get_app_fn.const_name,
    some constrs ← return $ env.structure_fields cls | return ff,
    tt ← return $ constrs.mem `add || constrs.mem `mul | return ff,
    ff ← has_attribute' `reducible nm | return ff,
    return tt },
  if l.empty then return none else
  -- we currently ignore declarations that have a `foo._main` declaration.
  if l.to_list = [d.to_name ++ `_main] then return none else
    return $ some $ "This instance contains the declarations " ++ to_string l.to_list ++
      ", which are semireducible non-instances."

/-- A linter that checks whether an instance contains a semireducible non-instance. -/
@[linter]
meta def linter.check_reducibility : linter :=
{ test := check_reducible_non_instances,
  auto_decls := ff,
  no_errors_found :=
    "All non-instances are reducible.",
  errors_found := "THE FOLLOWING INSTANCES MIGHT NOT REDUCE.
These instances contain one or more declarations that are not instances and are also not marked
`@[reducible]`. This means that type-class inference cannot unfold these declarations, " ++
"which might mean that type-class inference cannot infer that two instances are definitionally " ++
"equal. This can cause unexpected errors when this class occurs " ++
"as an *argument* to a type-class problem. See note [reducible non-instances].",
  is_fast := tt }


/-
Copyright (c) 2022 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki
-/
import Std.Data.List.Lemmas
import Std.Data.Array.Lemmas
import Std.Tactic.ShowTerm

import Mathlib.Data.List.Perm

import ProofChecker.Model.ToMathlib
import ProofChecker.Data.HashMap.Basic
import ProofChecker.Data.HashMap.WF

namespace HashMap
open Std (AssocList)
variable [BEq α] [Hashable α] [LawfulHashable α] [PartialEquivBEq α]

namespace Imp
open List

-- NOTE(WN): These would ideally be solved by a congruence-closure-for-PERs tactic
-- See https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Rewriting.20congruent.20relations
-- Same for proofs about List.Perm
private theorem beq_nonsense_1 {a b c : α} : a != b → a == c → b != c :=
  fun h₁ h₂ => Bool.bne_iff_not_beq.mpr fun h₃ =>
    Bool.bne_iff_not_beq.mp h₁ (PartialEquivBEq.trans h₂ (PartialEquivBEq.symm h₃))

private theorem beq_nonsense_2 {a b c : α} : a == b → b == c → ¬(c != a) :=
  fun h₁ h₂ h₃ => Bool.bne_iff_not_beq.mp (bne_symm h₃) (PartialEquivBEq.trans h₁ h₂)

private theorem beq_nonsense_3 {a b c : α} : a != b → c == b  → c != a :=
  fun h₁ h₂ => bne_symm (beq_nonsense_1 (bne_symm h₁) (PartialEquivBEq.symm h₂))

namespace Buckets

/-- The contents of any given bucket are pairwise `bne`. -/
theorem Pairwise_bne_bucket (bkts : Buckets α β) (H : bkts.WF) (h : i < bkts.val.size) :
    Pairwise (·.1 != ·.1) bkts.val[i].toList := by
  have := H.distinct bkts.val[i] (Array.getElem_mem_data _ _)
  exact Pairwise.imp Bool.bne_iff_not_beq.mpr this

/-- Reformulation of `Pairwise_bne_bucket` for use with `List.foo_of_unique`. -/
theorem Pairwise_bne_bucket' (bkts : Buckets α β) (H : bkts.WF) (h : i < bkts.val.size) (a : α) :
    Pairwise (fun p q => p.1 == a → q.1 != a) bkts.val[i].toList :=
  Pairwise.imp beq_nonsense_1 (Pairwise_bne_bucket bkts H h)

/-! ## Main abstraction using `toListModel` -/

/-- It is a bit easier to reason about `foldl (append)` than `foldl (foldl)`, so we use this
(less efficient) variant of `toList` as the mathematical model. -/
def toListModel (bkts : Buckets α β) : List (α × β) :=
  -- Note(WN): the implementation is  `bkts.foldl` rather than `bkts.data.foldl` because we need
  -- to reason about array indices in some of the theorems.
  bkts.val.foldl (init := []) (fun acc bkt => acc ++ bkt.toList)

attribute [local simp] foldl_cons_fn foldl_append_fn

theorem toListModel_eq (bkts : Buckets α β) : bkts.toListModel = bkts.val.data.bind (·.toList) := by
  simp [toListModel, Array.foldl_eq_foldl_data]

theorem mem_toListModel_iff_mem_bucket (bkts : Buckets α β) (H : bkts.WF) (ab : α × β) :
    haveI := mkIdx (hash ab.fst) bkts.property
    ab ∈ bkts.toListModel ↔ ab ∈ (bkts.val[this.1.toNat]'this.2).toList := by
  have : ab ∈ bkts.toListModel ↔ ∃ bkt ∈ bkts.val.data, ab ∈ bkt.toList := by
    simp [toListModel_eq, mem_bind]
  rw [this]
  clear this
  apply Iff.intro
  . intro ⟨bkt, hBkt, hMem⟩
    have ⟨i, hGetI⟩ := Array.get_of_mem_data hBkt
    simp only [getElem_fin] at hGetI
    suffices (mkIdx (hash ab.fst) bkts.property).val.toNat = i by
      simp [Array.ugetElem_eq_getElem, this, hGetI, hMem]
    unfold Imp.mkIdx
    dsimp
    exact H.hash_self i.val i.isLt ab (hGetI ▸ hMem)
  . intro h
    refine ⟨_, Array.getElem_mem_data _ _, h⟩

/-- The map does not store duplicate (by `beq`) keys. -/
theorem Pairwise_bne_toListModel (bkts : Buckets α β) (H : bkts.WF) :
    bkts.toListModel.Pairwise (·.1 != ·.1) := by
  unfold toListModel
  refine Array.foldl_induction
    (motive := fun i (acc : List (α × β)) =>
      -- The acc has the desired property
      acc.Pairwise (·.1 != ·.1)
      -- All not-yet-accumulated buckets are pairwise disjoint with the acc
      ∧ ∀ j, i ≤ j → (_ : j < bkts.val.size) →
        ∀ p ∈ acc, ∀ r ∈ bkts.val[j].toList, p.1 != r.1)
    ?h0 ?hf |>.left
  case h0 => exact ⟨Pairwise.nil, fun.⟩
  case hf =>
    intro i acc h
    refine ⟨pairwise_append.mpr ⟨h.left, ?bkt, ?accbkt⟩, ?accbkts⟩
    case bkt => apply Pairwise_bne_bucket bkts H
    case accbkt =>
      intro a hA b hB
      exact h.right i.val (Nat.le_refl _) i.isLt a hA b hB
    case accbkts =>
      intro j hGe hLt p hP r hR
      cases mem_append.mp hP
      case inl hP => exact h.right j (Nat.le_of_succ_le hGe) hLt p hP r hR
      case inr hP =>
        -- Main proof 2: distinct buckets store bne keys
        refine Bool.bne_iff_not_beq.mpr fun h => ?_
        have hHashEq := LawfulHashable.hash_eq h
        have hGt := Nat.lt_of_succ_le hGe
        have hHashP := H.hash_self i (Nat.lt_trans hGt hLt) _ hP
        have hHashR := H.hash_self j hLt _ hR
        dsimp at hHashP hHashR
        have : i.val = j := by
          rw [hHashEq] at hHashP
          exact .trans hHashP.symm hHashR
        exact Nat.ne_of_lt hGt this

/-- Reformulation of `Pairwise_bne_toListModel` for use with `List.foo_of_unique`. -/
-- TODO: rm in favor of below
theorem Pairwise_bne_toListModel' (bkts : Buckets α β) (H : bkts.WF) (a : α) :
    bkts.toListModel.Pairwise (fun p q => p.1 == a → q.1 != a) :=
  Pairwise.imp beq_nonsense_1 (Pairwise_bne_toListModel bkts H)

theorem unique_toListModel (bkts : Buckets α β) (H : bkts.WF) (a : α) :
    bkts.toListModel.unique (·.1 == a) :=
  Pairwise.imp
    (fun h h₁ h₂ => Bool.bne_iff_not_beq.mp (h h₁) h₂)
    (Pairwise_bne_toListModel' bkts H a)

@[simp]
theorem toListModel_mk (size : Nat) (h : size.isPowerOfTwo) :
    (Buckets.mk (α := α) (β := β) size h).toListModel = [] := by
  simp only [Buckets.mk, toListModel_eq, mkArray_data]
  clear h
  induction size <;> simp [*]

theorem exists_of_toListModel_update (bkts : Buckets α β) (i d h) :
    ∃ l₁ l₂, bkts.toListModel = l₁ ++ bkts.1[i.toNat].toList ++ l₂
      ∧ (bkts.update i d h).toListModel = l₁ ++ d.toList ++ l₂ := by
  have ⟨bs₁, bs₂, hTgt, _, hUpd⟩ := bkts.exists_of_update i d h
  refine ⟨bs₁.bind (·.toList), bs₂.bind (·.toList), ?_, ?_⟩
  . simp [toListModel_eq, hTgt]
  . simp [toListModel_eq, hUpd]

theorem exists_of_toListModel_update_WF (bkts : Buckets α β) (H : bkts.WF) (i d h) :
    ∃ l₁ l₂, bkts.toListModel = l₁ ++ bkts.1[i.toNat].toList ++ l₂
      ∧ (bkts.update i d h).toListModel = l₁ ++ d.toList ++ l₂
      ∧ ∀ ab ∈ l₁, ((hash ab.fst).toUSize % bkts.val.size) < i := by
  have ⟨bs₁, bs₂, hTgt, hLen, hUpd⟩ := bkts.exists_of_update i d h
  refine ⟨bs₁.bind (·.toList), bs₂.bind (·.toList), ?_, ?_, ?_⟩
  . simp [toListModel_eq, hTgt]
  . simp [toListModel_eq, hUpd]
  . intro ab hMem
    have ⟨bkt, hBkt, hAb⟩ := mem_bind.mp hMem
    clear hMem
    have ⟨⟨j, hJ⟩, hEq⟩ := get_of_mem hBkt
    have hJ' : j < bkts.val.size := by
      apply Nat.lt_trans hJ
      simp [Array.size, hTgt, Nat.lt_add_of_pos_right (Nat.succ_pos _)]
    have : ab ∈ (bkts.val[j]).toList := by
      suffices bkt = bkts.val[j] by rwa [this] at hAb
      have := @List.get_append _ _ (bkts.val[i] :: bs₂) j hJ
      dsimp at this
      rw [← hEq, ← this, ← get_of_eq hTgt ⟨j, _⟩]
      rfl
    rwa [hLen, ← H.hash_self _ _ _ this] at hJ

theorem toListModel_reinsertAux (tgt : Buckets α β) (a : α) (b : β) :
    (reinsertAux tgt a b).toListModel ~ (a, b) :: tgt.toListModel := by
  unfold reinsertAux
  have ⟨l₁, l₂, hTgt, hUpd⟩ :=
    haveI := mkIdx (hash a) tgt.property
    tgt.exists_of_toListModel_update this.1 (.cons a b (tgt.1[this.1.toNat]'this.2)) this.2
  simp [hTgt, hUpd, perm_middle]

theorem toListModel_foldl_reinsertAux (bkt : List (α × β)) (tgt : Buckets α β) :
    (bkt.foldl (init := tgt) fun acc x => reinsertAux acc x.fst x.snd).toListModel
    ~ tgt.toListModel ++ bkt := by
  induction bkt generalizing tgt with
  | nil => simp [Perm.refl]
  | cons p ps ih =>
    refine Perm.trans (ih _) ?_
    refine Perm.trans (Perm.append_right ps (toListModel_reinsertAux _ _ _)) ?_
    rw [cons_append]
    refine Perm.trans (Perm.symm perm_middle) ?_
    apply Perm.append_left _ (Perm.refl _)

theorem toListModel_expand (size : Nat) (bkts : Buckets α β) :
    (expand size bkts).buckets.toListModel ~ bkts.toListModel := by
  refine (go _ _ _).trans ?_
  rw [toListModel_mk, toListModel_eq]
  simp [Perm.refl]
where
  go (i : Nat) (src : Array (AssocList α β)) (target : Buckets α β) :
      (expand.go i src target).toListModel
      ~ (src.data.drop i).foldl (init := target.toListModel) (fun a b => a ++ b.toList) := by
    unfold expand.go; split
    case inl hI =>
      refine (go (i +1) _ _).trans ?_
      have h₀ : (src.data.set i AssocList.nil).drop (i + 1) = src.data.drop (i + 1) := by
        apply drop_ext
        intro j hJ
        apply get?_set_ne _ _ (Nat.ne_of_lt <| Nat.lt_of_succ_le hJ)
      have h₁ : (drop i src.data).bind (·.toList) = src.data[i].toList
          ++ (drop (i + 1) src.data).bind (·.toList) := by
        have : i < src.data.length := by simp [hI]
        simp [drop_eq_cons_get _ _ this]
      simp [h₀, h₁]
      rw [← append_assoc]
      refine Perm.append ?_ (Perm.refl _)
      refine Perm.trans (toListModel_foldl_reinsertAux (AssocList.toList src[i]) _) ?_
      exact Perm.refl _
    case inr hI =>
      have : src.data.length ≤ i := by simp [Nat.le_of_not_lt, hI]
      simp [Perm.refl, drop_eq_nil_of_le this]
    termination_by _ i src _ => src.size - i

end Buckets

theorem findEntry?_eq (m : Imp α β) (H : m.buckets.WF) (a : α)
    : m.findEntry? a = m.buckets.toListModel.find? (·.1 == a) := by
  have hPairwiseBkt :
      haveI := mkIdx (hash a) m.buckets.property
      Pairwise (fun p q => p.1 == a → q.1 != a) (m.buckets.val[this.1]'this.2).toList :=
    by apply Buckets.Pairwise_bne_bucket' m.buckets H
  apply Option.ext
  intro (a', b)
  simp only [Option.mem_def, findEntry?, Imp.findEntry?, AssocList.findEntry?_eq,
    find?_eq_some_of_unique (Buckets.Pairwise_bne_toListModel' m.buckets H a),
    find?_eq_some_of_unique hPairwiseBkt,
    and_congr_left_iff]
  intro hBeq
  have : hash a' = hash a := LawfulHashable.hash_eq hBeq
  simp [Buckets.mem_toListModel_iff_mem_bucket m.buckets H, mkIdx, this]

theorem eraseP_toListModel_of_not_contains (m : Imp α β) (H : m.buckets.WF) (a : α) :
    haveI := mkIdx (hash a) m.buckets.property
    ¬(m.buckets.val[this.1.toNat]'this.2).contains a →
    m.buckets.toListModel.eraseP (·.1 == a) = m.buckets.toListModel := by
  intro hContains
  apply eraseP_of_forall_not
  intro ab hMem hEq
  have :
      haveI := mkIdx (hash a) m.buckets.property
      (m.buckets.val[this.1.toNat]'this.2).contains a := by
    simp only [AssocList.contains_eq, List.any_eq_true, mkIdx, ← LawfulHashable.hash_eq hEq]
    exact ⟨ab, (Buckets.mem_toListModel_iff_mem_bucket m.buckets H ab).mp hMem, hEq⟩
  contradiction

theorem toListModel_insert_perm (m : Imp α β) (H : m.buckets.WF) (a : α) (b : β) :
    (m.insert a b).buckets.toListModel ~ (a, b) :: m.buckets.toListModel.eraseP (·.1 == a) := by
  dsimp [insert, cond]; split
  next hContains =>
    have ⟨l₁, l₂, hTgt, hUpd, hProp⟩ :=
      haveI := mkIdx (hash a) m.buckets.property
      m.buckets.exists_of_toListModel_update_WF H this.1
        ((m.buckets.1[this.1.toNat]'this.2).replace a b) this.2
    rw [hUpd, hTgt]
    have hL₁ : ∀ ab ∈ l₁, ¬(ab.fst == a) := fun ab h hEq =>
      Nat.ne_of_lt (LawfulHashable.hash_eq hEq ▸ hProp ab h) rfl
    have ⟨p, hMem, hP⟩ := any_eq_true.mp (AssocList.contains_eq a _ ▸ hContains)
    simp [eraseP_append_right _ hL₁,
      eraseP_append_left (p := fun ab => ab.fst == a) hP _ hMem]
    -- begin cursed manual proofs
    refine Perm.trans ?_ perm_middle
    refine Perm.append (Perm.refl _) ?_
    rw [← cons_append]
    refine Perm.append ?_ (Perm.refl _)
    refine Perm.trans
      (replaceF_of_unique
        (b := (a, b))
        (f := fun a_1 => bif a_1.fst == a then some (a, b) else none)
        hMem
        (by simp [hP])
        (by
          refine Pairwise.imp ?_ (Buckets.Pairwise_bne_bucket' m.buckets H _ a)
          intro p q h hSome
          dsimp at *
          cases hEq: p.fst == a with
          | false => cases hEq ▸ hSome
          | true =>
            have : (q.fst == a) = false :=
              Bool.eq_false_iff.mpr (Bool.bne_iff_not_beq.mp <| h hEq)
            simp [this]))
      ?_
    apply List.Perm.of_eq
    congr
    apply funext
    intro x
    cases h : x.fst == a <;> simp [h]
    -- end cursed manual proofs

  next hContains =>
    rw [eraseP_toListModel_of_not_contains m H a (Bool.eq_false_iff.mp hContains)]
    split
    -- TODO(WN): how to merge the two branches below? They are identical except for the initial
    -- `refine`
    next =>
      have ⟨l₁, l₂, hTgt, hUpd⟩ :=
        haveI := mkIdx (hash a) m.buckets.property
        m.buckets.exists_of_toListModel_update this.1
          ((m.buckets.1[this.1.toNat]'this.2).cons a b) this.2
      simp [hTgt, hUpd, perm_middle]
    next =>
      refine Perm.trans (Buckets.toListModel_expand _ _) ?_
      have ⟨l₁, l₂, hTgt, hUpd⟩ :=
        haveI := mkIdx (hash a) m.buckets.property
        m.buckets.exists_of_toListModel_update this.1
          ((m.buckets.1[this.1.toNat]'this.2).cons a b) this.2
      simp [hTgt, hUpd, perm_middle]

theorem toListModel_erase (m : Imp α β) (H : m.buckets.WF) (a : α) :
    (m.erase a).buckets.toListModel = m.buckets.toListModel.eraseP (·.1 == a) := by
  dsimp [erase, cond]; split
  next hContains =>
    have ⟨l₁, l₂, hTgt, hUpd, hProp⟩ :=
      haveI := mkIdx (hash a) m.buckets.property
      m.buckets.exists_of_toListModel_update_WF H this.1
        ((m.buckets.1[this.1.toNat]'this.2).erase a) this.2
    rw [hTgt, hUpd]
    have hL₁ : ∀ ab ∈ l₁, ¬(ab.fst == a) := fun ab h hEq =>
      Nat.ne_of_lt (LawfulHashable.hash_eq hEq ▸ hProp ab h) rfl
    have ⟨p, hMem, hP⟩ := any_eq_true.mp (AssocList.contains_eq a _ ▸ hContains)
    simp [eraseP_append_right _ hL₁, eraseP_append_left (p := fun ab => ab.fst == a) hP _ hMem]
  next hContains =>
    rw [eraseP_toListModel_of_not_contains m H a (Bool.eq_false_iff.mp hContains)]

theorem eraseP_toListModel (m : Imp α β) (H : m.buckets.WF) (a : α) :
    m.buckets.toListModel.eraseP (·.1 == a) = m.buckets.toListModel.filter (·.1 != a) := by
  apply List.eraseP_eq_filter_of_unique
  apply List.Pairwise.imp ?_ (Buckets.Pairwise_bne_toListModel _ H)
  intro (a₁, _) (a₂, _) hA₁Bne hA₁Beq
  rw [Bool.not_eq_true_iff_ne_true, ← Bool.bne_iff_not_beq]
  exact beq_nonsense_1 hA₁Bne hA₁Beq

theorem toListModel_insert_perm' (m : Imp α β) (H : m.buckets.WF) (a : α) (b : β) :
    (m.insert a b).buckets.toListModel ~ (a, b) :: m.buckets.toListModel.filter (·.1 != a) :=
  eraseP_toListModel m H a ▸ toListModel_insert_perm m H a b

theorem toListModel_erase' (m : Imp α β) (H : m.buckets.WF) (a : α) :
    (m.erase a).buckets.toListModel = m.buckets.toListModel.filter (·.1 != a) :=
  eraseP_toListModel m H a ▸ toListModel_erase m H a

/-! ## Useful high-level theorems -/

theorem findEntry?_insert {a a' b} {m : Imp α β} (H : m.WF) :
    a == a' → (m.insert a b).findEntry? a' = some (a, b) := by
  intro hEq
  have hWF := WF_iff.mp H |>.right
  have hInsWF : (m.insert a b).buckets.WF := H.insert.out |>.right
  rw [findEntry?_eq _ hInsWF]
  have hPerm := toListModel_insert_perm m hWF a b
  have hUniq : (insert m a b).buckets.toListModel.unique (·.1 == a') :=
    Buckets.unique_toListModel _ hInsWF a'
  simp [find?_eq_of_perm_of_unique hPerm hUniq, hEq]

theorem findEntry?_insert_of_ne {a a'} {m : Imp α β} (H : m.WF) :
    a != a' → (m.insert a b).findEntry? a' = m.findEntry? a' := by
  intro hNe
  have hWF := WF_iff.mp H |>.right
  have hInsWF : (m.insert a b).buckets.WF := H.insert.out |>.right
  have hPerm := toListModel_insert_perm' m hWF a b
  have hUniq : (insert m a b).buckets.toListModel.unique (·.1 == a') :=
    Buckets.unique_toListModel _ hInsWF a'
  rw [findEntry?_eq _ hWF, findEntry?_eq _ hInsWF,
    find?_eq_of_perm_of_unique hPerm hUniq,
    find?_cons_of_neg _ ?ne]
  case ne => exact Bool.bne_iff_not_beq.mp hNe
  exact find?_filter _ _ _ fun _ => beq_nonsense_3 hNe

theorem findEntry?_erase {a a'} {m : Imp α β} (H : m.WF) :
    a == a' → (m.erase a).findEntry? a' = none := by
  intro hEq
  have hWF := WF_iff.mp H |>.right
  have hErsWF : (m.erase a).buckets.WF := H.erase.out |>.right
  rw [findEntry?_eq _ hErsWF, toListModel_erase' m hWF a,
    find?_filter' _ _ _ ?ne]
  case ne =>
    intro _ h
    simp only [Bool.bnot_eq_to_not_eq, Bool.not_eq_true, Bool.bne_eq_false]
    exact PartialEquivBEq.trans h (PartialEquivBEq.symm hEq)

end Imp

theorem toList_eq_reverse_toListModel (m : HashMap α β) :
    m.toList = m.val.buckets.toListModel.reverse := by
  simp only [toList, Imp.Buckets.toListModel, fold, Imp.fold, Array.foldl_eq_foldl_data,
    AssocList.foldl_eq, List.foldl_cons_fn]
  suffices ∀ (l₁ : List (AssocList α β)) (l₂ : List (α × β)),
      l₁.foldl (init := l₂.reverse) (fun d b => b.toList.reverse ++ d) =
      (l₁.foldl (init := l₂) fun acc bkt => acc ++ bkt.toList).reverse by
    apply this (l₂ := [])
  intro l₁
  induction l₁ with
  | nil => intro; rfl
  | cons a as ih =>
    intro l₂
    simp only [List.foldl, ← List.reverse_append, ih]

/-! `empty` -/

theorem isEmpty_empty : (HashMap.empty : HashMap α β).isEmpty :=
  sorry

/-! `findEntry?` -/

@[simp]
theorem findEntry?_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.findEntry? a = none :=
  sorry

@[simp]
theorem findEntry?_empty (a : α) : (HashMap.empty : HashMap α β).findEntry? a = none :=
  findEntry?_of_isEmpty _ a isEmpty_empty

theorem findEntry?_insert {a a'} (m : HashMap α β) (b) :
    a == a' → (m.insert a b).findEntry? a' = some (a, b) :=
  m.val.findEntry?_insert m.property

theorem findEntry?_insert_of_ne {a a'} (m : HashMap α β) (b) :
    a != a' → (m.insert a b).findEntry? a' = m.findEntry? a' :=
  m.val.findEntry?_insert_of_ne m.property

theorem findEntry?_erase {a a'} (m : HashMap α β) : a == a' → (m.erase a).findEntry? a' = none :=
  m.val.findEntry?_erase m.property

theorem ext_findEntry? (m₁ m₂ : HashMap α β) : (∀ a, m₁.findEntry? a = m₂.findEntry? a) → m₁ = m₂ :=
  sorry

/-! `find?` -/

theorem find?_eq (m : HashMap α β) (a : α) : m.find? a = (m.findEntry? a).map (·.2) :=
  AssocList.find?_eq_findEntry? _ _

theorem find?_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.find? a = none :=
  sorry

@[simp]
theorem find?_empty (a : α) : (HashMap.empty : HashMap α β).find? a = none :=
  find?_of_isEmpty _ a isEmpty_empty

theorem find?_insert {a a'} (m : HashMap α β) (b) : a == a' → (m.insert a b).find? a' = some b :=
  fun h => by simp [find?_eq, findEntry?_insert m b h]

theorem find?_insert_of_ne {a a'} (m : HashMap α β) (b) :
    a != a' → (m.insert a b).find? a' = m.find? a' :=
  fun h => by simp [find?_eq, findEntry?_insert_of_ne m b h]

theorem find?_erase {a a'} (m : HashMap α β) : a == a' → (m.erase a).find? a' = none :=
  fun h => by simp [find?_eq, findEntry?_erase m h]

/-! `insert` -/

theorem insert_comm [LawfulBEq α] (m : HashMap α β) (a₁ a₂ : α) (b : β) :
    (m.insert a₁ b).insert a₂ b = (m.insert a₂ b).insert a₁ b := by
  apply ext_findEntry?
  intro a
  cases Bool.beq_or_bne a₁ a <;> cases Bool.beq_or_bne a₂ a <;>
    simp_all [findEntry?_insert, findEntry?_insert_of_ne]

/-! `contains` -/

theorem contains_iff (m : HashMap α β) (a : α) :
    m.contains a ↔ ∃ b, m.find? a = some b :=
  sorry

theorem not_contains_iff (m : HashMap α β) (a : α) :
    m.contains a = false ↔ m.find? a = none := by
  have := contains_iff m a
  apply Iff.intro
  . intro h; cases h' : find? m a <;> simp_all
  . intro h; simp_all

theorem not_contains_of_isEmpty (m : HashMap α β) (a : α) : m.isEmpty → m.contains a = false :=
  fun h => not_contains_iff _ _ |>.mpr (find?_of_isEmpty m a h)

@[simp]
theorem not_contains_empty (β) (a : α) : (empty : HashMap α β).contains a = false :=
  not_contains_of_isEmpty _ a isEmpty_empty

theorem contains_insert (m : HashMap α β) (a a' : α) (b : β) :
    (m.insert a b).contains a' ↔ (m.contains a' ∨ a == a') := by
  simp only [contains_iff]
  refine ⟨?mp, fun h => h.elim ?mpr₁ ?mpr₂⟩
  case mp =>
    intro ⟨b, hFind⟩
    cases Bool.beq_or_bne a a'
    case inl h =>
      exact Or.inr h
    case inr h =>
      rw [find?_insert_of_ne _ _ h] at hFind
      exact Or.inl ⟨b, hFind⟩
  case mpr₁ =>
    intro ⟨b, hFind⟩
    cases Bool.beq_or_bne a a'
    case inl h =>
      rw [find?_insert _ _ h]
      exact ⟨_, rfl⟩
    case inr h =>
      rw [find?_insert_of_ne _ _ h]
      exact ⟨_, hFind⟩
  case mpr₂ =>
    intro hEq
    rw [find?_insert _ _ hEq]
    exact ⟨_, rfl⟩

/-! `fold` -/

/-- If an entry appears in the map, it will appear "last" in a commutative `fold` over the map. -/
theorem fold_of_mapsTo_of_comm [LawfulBEq α] (m : HashMap α β) (f : δ → α → β → δ) (init : δ) :
    m.find? a = some b →
    -- NOTE: This could be strengthened by assuming m.find? a₁ = some b₁
    -- and ditto for a₂, b₂ in the ∀ hypothesis
    (∀ d a₁ b₁ a₂ b₂, f (f d a₁ b₁) a₂ b₂ = f (f d a₂ b₂) a₁ b₁) →
    -- TODO: Might also have to assume assoc
    ∃ d, m.fold f init = f d a b :=
  sorry

/-- Analogous to `List.foldlRecOn`. -/
def foldRecOn {C : δ → Sort _} (m : HashMap α β) (f : δ → α → β → δ) (init : δ) (hInit : C init)
    (hf : ∀ d a b, C d → m.find? a = some b → C (f d a b)) : C (m.fold f init) :=
  sorry

end HashMap


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.data.fin.basic

open nat
def unsigned_sz : nat := succ 4294967295

def unsigned := fin unsigned_sz

namespace unsigned
/- We cannot use tactic dec_trivial here because the tactic framework has not been defined yet. -/
private lemma zero_lt_unsigned_sz : 0 < unsigned_sz :=
zero_lt_succ _

/- Later, we define of_nat using mod, the following version is used to define the metaprogramming system. -/
protected def of_nat' (n : nat) : unsigned :=
if h : n < unsigned_sz then ⟨n, h⟩ else ⟨0, zero_lt_unsigned_sz⟩

def to_nat (c : unsigned) : nat := c.val

end unsigned

instance : decidable_eq unsigned :=
have decidable_eq (fin unsigned_sz), from fin.decidable_eq _,
this


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import category_theory.natural_isomorphism
import category_theory.eq_to_hom

/-!
# Quotient category

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

Constructs the quotient of a category by an arbitrary family of relations on its hom-sets,
by introducing a type synonym for the objects, and identifying homs as necessary.

This is analogous to 'the quotient of a group by the normal closure of a subset', rather
than 'the quotient of a group by a normal subgroup'. When taking the quotient by a congruence
relation, `functor_map_eq_iff` says that no unnecessary identifications have been made.
-/

/-- A `hom_rel` on `C` consists of a relation on every hom-set. -/
@[derive inhabited]
def hom_rel (C) [quiver C] := Π ⦃X Y : C⦄, (X ⟶ Y) → (X ⟶ Y) → Prop

namespace category_theory

variables {C : Type*} [category C] (r : hom_rel C)

include r

/-- A `hom_rel` is a congruence when it's an equivalence on every hom-set, and it can be composed
from left and right. -/
class congruence : Prop :=
(is_equiv : ∀ {X Y}, is_equiv _ (@r X Y))
(comp_left : ∀ {X Y Z} (f : X ⟶ Y) {g g' : Y ⟶ Z}, r g g' → r (f ≫ g) (f ≫ g'))
(comp_right : ∀ {X Y Z} {f f' : X ⟶ Y} (g : Y ⟶ Z), r f f' → r (f ≫ g) (f' ≫ g))

attribute [instance] congruence.is_equiv

/-- A type synonym for `C`, thought of as the objects of the quotient category. -/
@[ext]
structure quotient := (as : C)

instance [inhabited C] : inhabited (quotient r) := ⟨ { as := default } ⟩

namespace quotient

/-- Generates the closure of a family of relations w.r.t. composition from left and right. -/
inductive comp_closure ⦃s t : C⦄ : (s ⟶ t) → (s ⟶ t) → Prop
| intro {a b} (f : s ⟶ a) (m₁ m₂ : a ⟶ b) (g : b ⟶ t) (h : r m₁ m₂) :
  comp_closure (f ≫ m₁ ≫ g) (f ≫ m₂ ≫ g)

lemma comp_closure.of {a b} (m₁ m₂ : a ⟶ b) (h : r m₁ m₂) : comp_closure r m₁ m₂ :=
by simpa using comp_closure.intro (𝟙 _) m₁ m₂ (𝟙 _) h

lemma comp_left {a b c : C} (f : a ⟶ b) : Π (g₁ g₂ : b ⟶ c) (h : comp_closure r g₁ g₂),
  comp_closure r (f ≫ g₁) (f ≫ g₂)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro (f ≫ x) m₁ m₂ y h

lemma comp_right {a b c : C} (g : b ⟶ c) : Π (f₁ f₂ : a ⟶ b) (h : comp_closure r f₁ f₂),
  comp_closure r (f₁ ≫ g) (f₂ ≫ g)
| _ _ ⟨x, m₁, m₂, y, h⟩ := by simpa using comp_closure.intro x m₁ m₂ (y ≫ g) h

/-- Hom-sets of the quotient category. -/
def hom (s t : quotient r) := quot $ @comp_closure C _ r s.as t.as

instance (a : quotient r) : inhabited (hom r a a) := ⟨quot.mk _ (𝟙 a.as)⟩

/-- Composition in the quotient category. -/
def comp ⦃a b c : quotient r⦄ : hom r a b → hom r b c → hom r a c :=
λ hf hg, quot.lift_on hf ( λ f, quot.lift_on hg (λ g, quot.mk _ (f ≫ g))
  (λ g₁ g₂ h, quot.sound $ comp_left r f g₁ g₂ h) )
  (λ f₁ f₂ h, quot.induction_on hg $ λ g, quot.sound $ comp_right r g f₁ f₂ h)

@[simp]
lemma comp_mk {a b c : quotient r} (f : a.as ⟶ b.as) (g : b.as ⟶ c.as) :
  comp r (quot.mk _ f) (quot.mk _ g) = quot.mk _ (f ≫ g) := rfl

instance category : category (quotient r) :=
{ hom := hom r,
  id := λ a, quot.mk _ (𝟙 a.as),
  comp := comp r }

/-- The functor from a category to its quotient. -/
@[simps]
def functor : C ⥤ quotient r :=
{ obj := λ a, { as := a },
  map := λ _ _ f, quot.mk _ f }

noncomputable instance : full (functor r) :=
{ preimage := λ X Y f, quot.out f, }

instance : ess_surj (functor r) :=
{ mem_ess_image := λ Y, ⟨Y.as, ⟨eq_to_iso (by { ext, refl, })⟩⟩ }

protected lemma induction {P : Π {a b : quotient r}, (a ⟶ b) → Prop}
  (h : ∀ {x y : C} (f : x ⟶ y), P ((functor r).map f)) :
  ∀ {a b : quotient r} (f : a ⟶ b), P f :=
by { rintros ⟨x⟩ ⟨y⟩ ⟨f⟩, exact h f, }

protected lemma sound {a b : C} {f₁ f₂ : a ⟶ b} (h : r f₁ f₂) :
  (functor r).map f₁ = (functor r).map f₂ :=
by simpa using quot.sound (comp_closure.intro (𝟙 a) f₁ f₂ (𝟙 b) h)

variables {D : Type*} [category D]
  (F : C ⥤ D)
  (H : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂)
include H

/-- The induced functor on the quotient category. -/
@[simps]
def lift : quotient r ⥤ D :=
{ obj := λ a, F.obj a.as,
  map := λ a b hf, quot.lift_on hf (λ f, F.map f)
    (by { rintro _ _ ⟨_, _, _, _, h⟩, simp [H _ _ _ _ h], }),
  map_id' := λ a, F.map_id a.as,
  map_comp' := by { rintros a b c ⟨f⟩ ⟨g⟩, exact F.map_comp f g, } }

lemma lift_spec : (functor r) ⋙ lift r F H = F :=
begin
  apply functor.ext, rotate,
  { rintro X, refl, },
  { rintro X Y f, simp, },
end

lemma lift_unique (Φ : quotient r ⥤ D) (hΦ : (functor r) ⋙ Φ = F) : Φ = lift r F H :=
begin
  subst_vars,
  apply functor.hext,
  { rintro X, dsimp [lift, functor], congr, ext, refl, },
  { rintro X Y f,
    dsimp [lift, functor],
    apply quot.induction_on f,
    rintro ff,
    simp only [quot.lift_on_mk, functor.comp_map],
    congr; ext; refl, },
end

/-- The original functor factors through the induced functor. -/
def lift.is_lift : (functor r) ⋙ lift r F H ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

@[simp]
lemma lift.is_lift_hom (X : C) : (lift.is_lift r F H).hom.app X = 𝟙 (F.obj X) :=
rfl
@[simp]
lemma lift.is_lift_inv (X : C) : (lift.is_lift r F H).inv.app X = 𝟙 (F.obj X) :=
rfl

lemma lift_map_functor_map {X Y : C} (f : X ⟶ Y) :
  (lift r F H).map ((functor r).map f) = F.map f :=
by { rw ←(nat_iso.naturality_1 (lift.is_lift r F H)), dsimp, simp, }

end quotient

end category_theory


import hott.init hott.types.sigma hott.types.nat
set_option pp.notation false
#print hott.univalence

namespace hott

local infix ` = `:50 := hott.eq

@[hott] lemma X : bool = bool := eq.refl _

@[hott] def Y (a b : unit) : ∀ (x y : a = b), x = y :=
punit.rec_on a (λ x, @eq.rec_on _ _ (λ b h, ∀ y, eq h y) _ _ $
  λ y, @eq.rec_on unit () (λ a, punit.rec_on a (eq (eq.refl ()))) () y (eq.refl _))

#print nat.no_confusion

@[hott] lemma eq.symm {α : Sort*} {x y : α} (h : x = y) : y = x := eq.rec_on h rfl

@[hott] example (a b : ℕ) : ∀ (x y : a = b), x = y :=
begin
  assume x,
  hinduction x,
  assume y,
  hinduction a,
  exact @eq.rec_on ℕ 0 begin end _ _ _ _,

end

@[hott] def bool_not : equiv bool bool :=
equiv.mk bnot $ is_equiv.mk _ bnot
  (λ b, bool.rec_on b rfl rfl) (λ b, bool.rec_on b rfl rfl)
    (λ b, bool.rec_on b rfl rfl)

axiom choice : Π {α : Sort*}, trunc 0 α → α

noncomputable example : empty :=
let b := choice (trunc.tr tt) in
let e : bool = bool := ua bool_not in
let b' : bool := eq.cast e b in
have hb' : b' = choice (trunc.tr ff), from sorry,
have h : b' = bnot b, from cast_ua bool_not b,
have h' : b' = b, from @eq.rec_on _
  (choice (trunc.tr ff)) (λ c _, b' = c) _
    (@eq.rec_on _ (choice (trunc.tr tt)) (λ c _, c = b) _
      (@eq.rec_on _ (trunc.tr ff) (λ c _, choice c = choice (trunc.tr ff)) _
        sorry
        rfl)
      rfl)
    hb',

end hott


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

! This file was ported from Lean 3 source module category_theory.grothendieck
! leanprover-community/mathlib commit 14b69e9f3c16630440a2cbd46f1ddad0d561dee7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Category.Cat
import Mathbin.CategoryTheory.Elements

/-!
# The Grothendieck construction

Given a functor `F : C ⥤ Cat`, the objects of `grothendieck F`
consist of dependent pairs `(b, f)`, where `b : C` and `f : F.obj c`,
and a morphism `(b, f) ⟶ (b', f')` is a pair `β : b ⟶ b'` in `C`, and
`φ : (F.map β).obj f ⟶ f'`

Categories such as `PresheafedSpace` are in fact examples of this construction,
and it may be interesting to try to generalize some of the development there.

## Implementation notes

Really we should treat `Cat` as a 2-category, and allow `F` to be a 2-functor.

There is also a closely related construction starting with `G : Cᵒᵖ ⥤ Cat`,
where morphisms consists again of `β : b ⟶ b'` and `φ : f ⟶ (F.map (op β)).obj f'`.

## References

See also `category_theory.functor.elements` for the category of elements of functor `F : C ⥤ Type`.

* https://stacks.math.columbia.edu/tag/02XV
* https://ncatlab.org/nlab/show/Grothendieck+construction

-/

universe u

namespace CategoryTheory

variable {C D : Type _} [Category C] [Category D]

variable (F : C ⥤ Cat)

/--
The Grothendieck construction (often written as `∫ F` in mathematics) for a functor `F : C ⥤ Cat`
gives a category whose
* objects `X` consist of `X.base : C` and `X.fiber : F.obj base`
* morphisms `f : X ⟶ Y` consist of
  `base : X.base ⟶ Y.base` and
  `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`
-/
@[nolint has_nonempty_instance]
structure Grothendieck where
  base : C
  fiber : F.obj base
#align category_theory.grothendieck CategoryTheory.Grothendieck

namespace Grothendieck

variable {F}

/-- A morphism in the Grothendieck category `F : C ⥤ Cat` consists of
`base : X.base ⟶ Y.base` and `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`.
-/
structure Hom (X Y : Grothendieck F) where
  base : X.base ⟶ Y.base
  fiber : (F.map base).obj X.fiber ⟶ Y.fiber
#align category_theory.grothendieck.hom CategoryTheory.Grothendieck.Hom

@[ext]
theorem ext {X Y : Grothendieck F} (f g : Hom X Y) (w_base : f.base = g.base)
    (w_fiber : eqToHom (by rw [w_base]) ≫ f.fiber = g.fiber) : f = g :=
  by
  cases f <;> cases g
  congr
  dsimp at w_base
  induction w_base
  rfl
  dsimp at w_base
  induction w_base
  simpa using w_fiber
#align category_theory.grothendieck.ext CategoryTheory.Grothendieck.ext

/-- The identity morphism in the Grothendieck category.
-/
@[simps]
def id (X : Grothendieck F) : Hom X X where
  base := 𝟙 X.base
  fiber := eqToHom (by erw [CategoryTheory.Functor.map_id, functor.id_obj X.fiber])
#align category_theory.grothendieck.id CategoryTheory.Grothendieck.id

instance (X : Grothendieck F) : Inhabited (Hom X X) :=
  ⟨id X⟩

/-- Composition of morphisms in the Grothendieck category.
-/
@[simps]
def comp {X Y Z : Grothendieck F} (f : Hom X Y) (g : Hom Y Z) : Hom X Z
    where
  base := f.base ≫ g.base
  fiber :=
    eqToHom (by erw [functor.map_comp, functor.comp_obj]) ≫ (F.map g.base).map f.fiber ≫ g.fiber
#align category_theory.grothendieck.comp CategoryTheory.Grothendieck.comp

attribute [local simp] eq_to_hom_map

instance : Category (Grothendieck F)
    where
  Hom X Y := Grothendieck.Hom X Y
  id X := Grothendieck.id X
  comp X Y Z f g := Grothendieck.comp f g
  comp_id' X Y f := by
    ext
    · dsimp
      -- We need to turn `F.map_id` (which is an equation between functors)
      -- into a natural isomorphism.
      rw [← nat_iso.naturality_2 (eq_to_iso (F.map_id Y.base)) f.fiber]
      simp
    · simp
  id_comp' X Y f := by ext <;> simp
  assoc' W X Y Z f g h := by
    ext; swap
    · simp
    · dsimp
      rw [← nat_iso.naturality_2 (eq_to_iso (F.map_comp _ _)) f.fiber]
      simp
      rfl

@[simp]
theorem id_fiber' (X : Grothendieck F) :
    Hom.fiber (𝟙 X) = eqToHom (by erw [CategoryTheory.Functor.map_id, functor.id_obj X.fiber]) :=
  id_fiber X
#align category_theory.grothendieck.id_fiber' CategoryTheory.Grothendieck.id_fiber'

theorem congr {X Y : Grothendieck F} {f g : X ⟶ Y} (h : f = g) :
    f.fiber = eqToHom (by subst h) ≫ g.fiber :=
  by
  subst h
  dsimp
  simp
#align category_theory.grothendieck.congr CategoryTheory.Grothendieck.congr

section

variable (F)

/-- The forgetful functor from `grothendieck F` to the source category. -/
@[simps]
def forget : Grothendieck F ⥤ C where
  obj X := X.1
  map X Y f := f.1
#align category_theory.grothendieck.forget CategoryTheory.Grothendieck.forget

end

universe w

variable (G : C ⥤ Type w)

/-- Auxiliary definition for `grothendieck_Type_to_Cat`, to speed up elaboration. -/
@[simps]
def grothendieckTypeToCatFunctor : Grothendieck (G ⋙ typeToCat) ⥤ G.Elements
    where
  obj X := ⟨X.1, X.2.as⟩
  map X Y f := ⟨f.1, f.2.1.1⟩
#align category_theory.grothendieck.grothendieck_Type_to_Cat_functor CategoryTheory.Grothendieck.grothendieckTypeToCatFunctor

/-- Auxiliary definition for `grothendieck_Type_to_Cat`, to speed up elaboration. -/
@[simps]
def grothendieckTypeToCatInverse : G.Elements ⥤ Grothendieck (G ⋙ typeToCat)
    where
  obj X := ⟨X.1, ⟨X.2⟩⟩
  map X Y f := ⟨f.1, ⟨⟨f.2⟩⟩⟩
#align category_theory.grothendieck.grothendieck_Type_to_Cat_inverse CategoryTheory.Grothendieck.grothendieckTypeToCatInverse

/-- The Grothendieck construction applied to a functor to `Type`
(thought of as a functor to `Cat` by realising a type as a discrete category)
is the same as the 'category of elements' construction.
-/
@[simps]
def grothendieckTypeToCat : Grothendieck (G ⋙ typeToCat) ≌ G.Elements
    where
  Functor := grothendieckTypeToCatFunctor G
  inverse := grothendieckTypeToCatInverse G
  unitIso :=
    NatIso.ofComponents
      (fun X => by
        rcases X with ⟨_, ⟨⟩⟩
        exact iso.refl _)
      (by
        rintro ⟨_, ⟨⟩⟩ ⟨_, ⟨⟩⟩ ⟨base, ⟨⟨f⟩⟩⟩
        dsimp at *
        subst f
        ext
        simp)
  counitIso :=
    NatIso.ofComponents
      (fun X => by
        cases X
        exact iso.refl _)
      (by
        rintro ⟨⟩ ⟨⟩ ⟨f, e⟩
        dsimp at *
        subst e
        ext
        simp)
  functor_unitIso_comp' := by
    rintro ⟨_, ⟨⟩⟩
    dsimp
    simp
    rfl
#align category_theory.grothendieck.grothendieck_Type_to_Cat CategoryTheory.Grothendieck.grothendieckTypeToCat

end Grothendieck

end CategoryTheory


/- Author: E.W.Ayers
   This should be in mathlib. Some simp and extensionality lemmas for comma and over. -/
import category_theory.comma

namespace category_theory

section

universes v₁ v₂ v₃ u₁ u₂ u₃ -- declare the `v`'s first; see `category_theory.category` for an explanation
variables {A : Type u₁} [𝒜 : category.{v₁} A]
variables {B : Type u₂} [ℬ : category.{v₂} B]
variables {T : Type u₃} [𝒯 : category.{v₃} T]
include 𝒜 ℬ 𝒯

variables {L : A ⥤ T} {R : B ⥤ T}

lemma comma.ext : Π {l₁ l₂ : comma L R} (pl : l₁.left = l₂.left) (pr : l₁.right = l₂.right) (pf : l₁.hom == l₂.hom), l₁ = l₂ :=
begin
  rintros ⟨_,_,_⟩ ⟨_,_,_⟩ pl pr pf, cases pl, cases pr, cases pf, refl,
end

end

section

open over

universes u v
variables  {C : Type u} [𝒞 : category.{v} C] {X : C}
include 𝒞

@[ext] lemma over.ext : Π {o₁ o₂ : over X} (px : o₁.left = o₂.left) (p : o₁.hom == o₂.hom), o₁ = o₂ :=
begin
  intros _ _ _ _,
  apply comma.ext,
  assumption,
  rw over.over_right, rw over.over_right,
  assumption
end

@[simp] lemma over.mk_hom_id {f : over X} : over.mk(f.hom) = f :=
begin ext, refl, refl, end

end
end category_theory