/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/
import for_mathlib.homological_complex_misc
import algebra.homology.homological_complex
import algebra.homology.additive
import for_mathlib.idempotents.functor_extension2
import category_theory.idempotents.homological_complex

noncomputable theory

open category_theory
open category_theory.category
open category_theory.preadditive
open category_theory.idempotents

variables {C : Type*} [category C] [preadditive C]
variables {ι : Type*} {c : complex_shape ι}

namespace category_theory

namespace idempotents

namespace karoubi

namespace homological_complex

variables {P Q : karoubi (homological_complex C c)} (f : P ⟶ Q) (n : ι)

@[simp, reassoc]
lemma f_p_comp : P.p.f n ≫ f.f.f n = f.f.f n :=
homological_complex.congr_hom (p_comp f) n

@[simp, reassoc]
lemma f_comp_p : f.f.f n ≫ Q.p.f n = f.f.f n :=
homological_complex.congr_hom (comp_p f) n

@[reassoc]
lemma f_p_comm : P.p.f n ≫ f.f.f n = f.f.f n ≫ Q.p.f n :=
homological_complex.congr_hom (p_comm f) n

end homological_complex

end karoubi

namespace karoubi_homological_complex

namespace functor

@[simps]
def obj (P : karoubi (homological_complex C c)) : homological_complex (karoubi C) c :=
{ X := λ n, ⟨P.X.X n, P.p.f n, by simpa only [homological_complex.comp_f]
    using homological_complex.congr_hom P.idem n⟩,
  d := λ i j,
    { f := P.p.f i ≫ P.X.d i j,
      comm := begin
        have h :=  homological_complex.congr_hom P.idem j,
        simp only [homological_complex.hom.comm_assoc, assoc, homological_complex.hom.comm,
          homological_complex.comp_f] at h ⊢,
        simp only [h]
      end, },
  shape' := λ i j hij, by simp only [karoubi.hom_eq_zero_iff,
    P.X.shape i j hij, limits.comp_zero],
  d_comp_d' := λ i j k hij hjk, begin
    simp only [karoubi.hom_eq_zero_iff, karoubi.comp_f, P.p.comm j k],
    slice_lhs 2 3 { rw P.X.d_comp_d' i j k hij hjk, },
    simp only [limits.comp_zero, limits.zero_comp],
  end, }

@[simps]
def map {P Q : karoubi (homological_complex C c)} (f : P ⟶ Q) : obj P ⟶ obj Q :=
{ f:= λ n,
  { f:= f.f.f n,
    comm := by simpa only [homological_complex.comp_f]
      using homological_complex.congr_hom f.comm n, },
  comm' := λ i j hij, begin
    ext,
    simp only [karoubi.comp_f, obj_d_f, assoc, ← f.f.comm],
    simp only [← assoc],
    have eq := homological_complex.congr_hom (karoubi.p_comm f) i,
    simp only [homological_complex.comp_f] at eq,
    rw eq,
  end }

end functor

@[simps]
def functor :
  karoubi (homological_complex C c) ⥤ homological_complex (karoubi C) c :=
{ obj := functor.obj,
  map := λ P Q f, functor.map f,
  map_comp' := λ P Q R f f',
    by { ext n, simpa only [karoubi.comp_f], }, }

namespace inverse

@[simps]
def obj (K : homological_complex (karoubi C) c) : karoubi (homological_complex C c) :=
{ X :=
  { X := λ n, (K.X n).X,
    d := λ i j, (K.d i j).f,
    shape' := λ i j hij, karoubi.hom_eq_zero_iff.mp (K.shape' i j hij),
    d_comp_d' := λ i j k hij hjk, by simpa only [karoubi.comp_f]
      using karoubi.hom_eq_zero_iff.mp (K.d_comp_d' i j k hij hjk), },
  p :=
    { f := λ n, (K.X n).p,
      comm' := λ i j hij, karoubi.p_comm (K.d i j), },
  idem := by { ext n, simpa only [karoubi.comp_f] using (K.X n).idem, }, }

@[simps]
def map {K L : homological_complex (karoubi C) c} (f : K ⟶ L) : obj K ⟶ obj L :=
{ f:=
  { f := λ n, (f.f n).f,
    comm' := λ i j hij, by simpa only [karoubi.comp_f]
      using karoubi.hom_ext.mp (f.comm' i j hij), },
  comm := by { ext n, exact (f.f n).comm, }, }

end inverse

@[simps]
def inverse :
  homological_complex (karoubi C) c ⥤ karoubi (homological_complex C c) :=
{ obj := inverse.obj,
  map := λ K L f, inverse.map f,
  map_comp' := λ K L M f g, by { ext n,
    simp only [karoubi.comp_f, homological_complex.comp_f, inverse.map_f_f], }, }

def counit_eq : inverse ⋙ functor = 𝟭 (homological_complex (karoubi C) c) :=
begin
  apply functor.ext,
  { intros K L f,
    ext n,
    dsimp [functor.map, inverse.map],
    simp only [karoubi.eq_to_hom_f, functor.obj_X_p, homological_complex.eq_to_hom_f,
      eq_to_hom_refl, comp_id, karoubi.comp_f, inverse.obj_p_f],
    rw [← karoubi.hom.comm], },
  { intro P,
    apply homological_complex.ext,
    { intros i j hij,
      simp [homological_complex.eq_to_hom_f],
      refl, },
    { ext n,
      { simpa only [id_comp, eq_to_hom_refl, comp_id], },
      { refl, }, }, },
end

@[simps]
def unit_iso : 𝟭 (karoubi (homological_complex C c)) ≅ functor ⋙ inverse :=
{ hom :=
  { app := λ P,
    { f :=
      { f := λ n, P.p.f n,
        comm' := λ i j hij, begin
          dsimp,
          have h := homological_complex.congr_hom P.idem i,
          simp only [homological_complex.comp_f] at h,
          slice_lhs 1 2 { erw h, },
          exact P.p.comm' i j hij,
        end },
      comm := begin
        ext n,
        have h := homological_complex.congr_hom P.idem n,
        simp only [homological_complex.comp_f] at h,
        dsimp,
        rw [h, h],
      end },
    naturality' := λ X Y f, begin
      ext n,
      have h := homological_complex.congr_hom ((karoubi.p_comm f).symm) n,
      simpa only [functor.map_f_f, homological_complex.comp_f,
        inverse.map_f_f, karoubi.comp_f] using h,
    end },
  inv :=
  { app := λ P,
    { f :=
      { f := λ n, P.p.f n,
        comm' := λ i j hij, begin
          dsimp,
          slice_rhs 2 3 { rw ← P.p.comm' i j hij, },
          rw ← assoc,
          have h := homological_complex.congr_hom P.idem i,
          simp only [homological_complex.comp_f] at h,
          rw h,
        end },
      comm := begin
        ext n,
        have h := homological_complex.congr_hom P.idem n,
        simp only [homological_complex.comp_f] at h,
        dsimp,
        rw [h, h],
      end },
    naturality' := λ P Q f, begin
      ext n,
      have h := homological_complex.congr_hom (karoubi.p_comm f).symm n,
      simpa only [functor_map, functor.map_f_f, functor.id_map, functor.comp_map,
        homological_complex.comp_f, inverse.map_f_f, inverse_map, karoubi.comp_f]
        using h,
    end },
  hom_inv_id' := begin
    ext P n,
    dsimp,
    simpa only [homological_complex.comp_f, karoubi.id_eq, karoubi.comp_f]
      using homological_complex.congr_hom P.idem n,
  end,
  inv_hom_id' := begin
    ext P n,
    dsimp [inverse.obj, functor.obj],
    simpa only [homological_complex.comp_f, karoubi.id_eq, karoubi.comp_f]
      using homological_complex.congr_hom P.idem n,
  end, }

end karoubi_homological_complex

variables (C) (c)

/-@[simps]
def karoubi_homological_complex_equivalence :
  karoubi (homological_complex C c) ≌ homological_complex (karoubi C) c :=
{ functor    := karoubi_homological_complex.functor,
  inverse    := karoubi_homological_complex.inverse,
  unit_iso   := karoubi_homological_complex.unit_iso,
  counit_iso := eq_to_iso karoubi_homological_complex.counit_eq,
  functor_unit_iso_comp' := λ P, begin
    ext n,
    dsimp,
    have h := homological_complex.congr_hom P.idem n,
    simpa only [karoubi_homological_complex.unit_iso_hom_app_f_f,
      homological_complex.eq_to_hom_f,
      eq_to_hom_app, karoubi_homological_complex.functor.obj_X_p,
      karoubi_homological_complex.inverse.obj_p_f, eq_to_hom_refl,
      karoubi.id_eq, karoubi_homological_complex.functor.map_f_f,
      karoubi.comp_f] using h,
  end }-/

lemma functor.map_homological_complex_id {D : Type*} [category D] [preadditive D] :
  functor.map_homological_complex (𝟭 D) c = 𝟭 _ :=
begin
  apply functor.ext,
  { intros X Y f,
    ext n,
    dsimp,
    simp only [homological_complex.eq_to_hom_f, eq_to_hom_refl],
    erw [id_comp, comp_id], },
  { intro X,
    apply homological_complex.ext,
    { intros i j hij,
      erw [comp_id, id_comp],
      refl, },
    { refl, }, },
end

@[simps]
def nat_iso.map_homological_complex {D E : Type*} [category D] [category E] [preadditive D] [preadditive E]
  {F G : D ⥤ E} [F.additive] [G.additive] (e : F ≅ G) :
    functor.map_homological_complex F c ≅ functor.map_homological_complex G c :=
{ hom := nat_trans.map_homological_complex e.hom c,
  inv := nat_trans.map_homological_complex e.inv c,
  hom_inv_id' := by simpa only [← nat_trans.map_homological_complex_comp, e.hom_inv_id],
  inv_hom_id' := by simpa only [← nat_trans.map_homological_complex_comp, e.inv_hom_id], }

def equivalence.map_homological_complex {D E : Type*} [category D] [category E] [preadditive D] [preadditive E]
(e : D ≌ E) [e.functor.additive] : homological_complex D c ≌ homological_complex E c :=
{ functor := functor.map_homological_complex e.functor c,
  inverse := functor.map_homological_complex e.inverse c,
  unit_iso := eq_to_iso (functor.map_homological_complex_id c).symm ≪≫
      nat_iso.map_homological_complex c e.unit_iso,
  counit_iso := nat_iso.map_homological_complex c e.counit_iso ≪≫
      eq_to_iso (functor.map_homological_complex_id c),
  functor_unit_iso_comp' := λ K, begin
    ext n,
    dsimp,
    simp only [eq_to_hom_app, homological_complex.eq_to_hom_f, eq_to_hom_refl],
    erw [id_comp, comp_id, e.functor_unit_iso_comp],
  end, }

instance [is_idempotent_complete C] : is_idempotent_complete (homological_complex C c) :=
begin
  haveI := (to_karoubi_is_equivalence C),
  let e := (functor.as_equivalence (to_karoubi C)),
  let h : (to_karoubi C).additive := by apply_instance,
  haveI : e.functor.additive := h,
  rw is_idempotent_complete_iff_of_equivalence (equivalence.map_homological_complex c e),
  rw ← is_idempotent_complete_iff_of_equivalence (karoubi_homological_complex_equivalence C c),
  apply_instance,
end

variables (α : Type*) [add_right_cancel_semigroup α] [has_one α]

/-@[simps]
def karoubi_chain_complex_equivalence :
  karoubi (chain_complex C α) ≌
    chain_complex (karoubi C) α :=
karoubi_homological_complex_equivalence C (complex_shape.down α)

@[simps]
def karoubi_cochain_complex_equivalence :
  karoubi (cochain_complex C α) ≌
    cochain_complex (karoubi C) α :=
karoubi_homological_complex_equivalence C (complex_shape.up α)-/

end idempotents

namespace functor

variables {D : Type*} [category D] [preadditive D]

@[simps]
def map_karoubi_homological_complex (F : C ⥤ D) [F.additive] (c : complex_shape ι) :
  karoubi (homological_complex C c) ⥤ karoubi (homological_complex D c) :=
(functor_extension₂ _ _).obj (functor.map_homological_complex F c)

lemma map_homological_complex_karoubi_compatibility
  (F : C ⥤ D) [F.additive] (c : complex_shape ι) :
  to_karoubi _ ⋙ F.map_karoubi_homological_complex c =
  F.map_homological_complex c ⋙ to_karoubi _ :=
begin
  apply functor.ext,
  { intros X Y f,
    ext n,
    dsimp [to_karoubi],
    simp only [karoubi.comp_f, karoubi.eq_to_hom_f, eq_to_hom_refl, comp_id,
      homological_complex.comp_f, map_karoubi_homological_complex_obj_p_f,
      homological_complex.id_f, map_id, map_homological_complex_map_f],
    erw id_comp, },
  { intro X,
    ext1,
    { erw [id_comp, comp_id],
      ext n,
      dsimp,
      simpa only [F.map_id, homological_complex.id_f], },
    { refl, }, },
end

end functor

end category_theory


import algebra.homology.exact
import algebra.category.Module.abelian
import category_theory.limits.shapes.images

import .defs
import .ideal_and_fg_ideal
import .right_exact
import .ses

open category_theory category_theory.limits category_theory.monoidal_category
open Module character_module
open_locale tensor_product zero_object big_operators

universe u

namespace module

variables (R : Type u) [comm_ring R]
variables (M : Type u) [add_comm_group M] [module R M]

namespace flat

section defs

/--
0 ---> N₁ ----> N₂ ----> N₃ ----> 0
-/
@[reducible]
protected def ses : Prop :=
(tensor_right (Module.of R M)).is_exact

/--
    l12      l23
N1 ----> N2 -----> N3 is exact

we have 0 ---> ker l23 ---> N2 ---> coker l23 ---> 0 exact

ker l23 ⊗ M ⟶ N2 ⊗ M is injective

Want to show
        l12 ⊗ 1      l23 ⊗ 1
N1 ⊗ M --------> N2 --------> N3

-/
protected def exact : Prop :=
∀ ⦃N1 N2 N3 : Module.{u} R⦄ (l12 : N1 ⟶ N2) (l23 : N2 ⟶ N3)
  (he : exact l12 l23),
  exact ((tensor_right $ Module.of R M).map l12)
    ((tensor_right $ Module.of R M).map l23)

protected def inj : Prop :=
∀ ⦃N N' : Module.{u} R⦄ (L : N ⟶ N'),
  function.injective L →
  function.injective ((tensor_right (Module.of R M)).map L)

protected def ideal : Prop :=
∀ (I : ideal R), function.injective (tensor_embedding M I)

protected def fg_ideal : Prop :=
∀ (I : ideal R), I.fg → function.injective (tensor_embedding M I)

end defs

section ses_iff_inj

lemma ses_of_inj (H : module.flat.inj R M) :  module.flat.ses R M := -- λ N1 N2 N3 l12 l23 he1 he2 he3,
{ map_exact :=
  begin
    rintros ⟨N1, N2, N3, l12, l23⟩ ⟨he1, he2, he3⟩,
    dsimp only at *,
    have inj1 : function.injective (tensor_product.map l12 linear_map.id),
    { rw ←mono_iff_exact_zero_left at he1,
      rw concrete_category.mono_iff_injective_of_preserves_pullback at he1,
      exact H l12 he1, },

    obtain ⟨e1, e2⟩ := @@tensor_product.right_exact R _ M _ _ N1 N2 N3 l12 l23 he2 he3,
    refine ⟨_, e1, e2⟩,
    { rw ←mono_iff_exact_zero_left,
      rwa concrete_category.mono_iff_injective_of_preserves_pullback, },
  end }

lemma inj_of_ses (H : module.flat.ses R M) : module.flat.inj R M := λ N1 N2 l hl,
begin
  resetI,
  obtain ⟨e1, e2, e3⟩ := @@functor.is_exact.map_exact _ _ _ _ H ⟨_, _, _, l, (cokernel.π l)⟩ ⟨_, _, _⟩,
  { rwa [←mono_iff_exact_zero_left, Module.mono_iff_injective] at e1, },
  { rwa [←mono_iff_exact_zero_left, Module.mono_iff_injective], },
  { exact abelian.exact_cokernel l, },
  exact @@exact_epi_zero _ _ _ _ _ _ _,
end

end ses_iff_inj

lemma ideal_of_fg_ideal (H : module.flat.fg_ideal R M) : module.flat.ideal R M :=
λ I, by classical; exact tensor_embedding_inj_of_fg_inj M I H

section inj_of_ideal

lemma module.Baer_iff :
  module.Baer.{u u} R M ↔
  ∀ I, function.surjective (restrict_to_ideal R M I) :=
begin
  split,
  { intros h I g,
    obtain ⟨g', hg'⟩ := h I g,
    refine ⟨g', _⟩,
    rw restrict_to_ideal_apply,
    ext1,
    rw linear_map.dom_restrict_apply,
    rw hg' x x.2, congr, ext, refl,  },
  { intros h I g,
    obtain ⟨g', hg'⟩ := h I g,
    refine ⟨g', λ x hx, _⟩,
    rw ←hg',
    rw restrict_to_ideal_apply,
    rw linear_map.dom_restrict_apply,
    congr, },
end

lemma Lambek : category_theory.injective (Module.of R $ character_module M) → module.flat.inj R M :=
begin
  intros h_injective A B L hL,
  haveI : mono L := by rwa concrete_category.mono_iff_injective_of_preserves_pullback,
  rw ←linear_map.ker_eq_bot at ⊢,
  rw eq_bot_iff at ⊢,
  rintros z hz,
  rw submodule.mem_bot,
  rw linear_map.mem_ker at hz,
  by_cases rid : z = 0,
  { exact rid },
  exfalso,
  obtain ⟨g, hg⟩ := character_module.non_zero (A ⊗[R] M) rid,
  set f : A →ₗ[R] (character_module M) :=
  { to_fun := λ a, { to_fun := λ m, g (a ⊗ₜ m), map_add' := _, map_smul' := _ },
    map_add' := _, map_smul' := _ } with f_eq,
  work_on_goal 2 { intros m m', rw [tensor_product.tmul_add, map_add], },
  work_on_goal 2 { intros zz m, rw [ring_hom.id_apply, ←tensor_product.smul_tmul,
    ←tensor_product.smul_tmul', map_zsmul], },
  work_on_goal 2 { intros a a', ext1 t, simp only [linear_map.coe_mk, linear_map.add_apply,
    tensor_product.add_tmul, map_add], },
  work_on_goal 2 { intros r a, ext1 t, simp only [linear_map.coe_mk, linear_map.smul_apply,
    character_module.smul_apply, ring_hom.id_apply, tensor_product.smul_tmul], },
  obtain ⟨f' : B →ₗ[R] (character_module M), hf'⟩ := h_injective.factors f L,
  set g' : (character_module $ B ⊗[R] M) := character_module.hom_equiv _ _ f' with g'_eq,
  obtain ⟨ι, a, m, s, rfl⟩ := tensor_product.exists_rep _ z,
  have EQ : g' (∑ i in s, L (a i) ⊗ₜ m i) = 0,
  { simp only [tensor_right_map, linear_map.map_sum, monoidal_category.hom_apply,
      Module.id_apply] at hz,
    rw [hz, map_zero], },
  refine hg _,
  rw map_sum,
  simp_rw [map_sum, g'_eq, hom_equiv_apply, add_monoid_hom.coe_to_int_linear_map,
      tensor_product.to_add_comm_group'.apply_tmul] at EQ,
  convert EQ using 1,
  refine finset.sum_congr rfl (λ i hi, _),
  erw fun_like.congr_fun hf',
  rw f_eq,
  refl,
end

lemma flat'_of_baer : module.Baer.{u u} R (character_module M) → module.flat.inj R M :=
λ h, Lambek _ _ $ (module.injective_iff_injective_object.{u u} R
    (character_module M)).mp (module.Baer.injective h)

lemma flat'_of_surj :
  (∀ I, function.surjective (restrict_to_ideal R (character_module M) I)) → module.flat.inj R M :=
λ h, flat'_of_baer _ _ ((module.Baer_iff _ _).mpr h)

variables {I : ideal R} (hI : function.injective (tensor_embedding M I))

lemma surj1 : function.surjective (character_module.map (tensor_embedding M I)) :=
character_module.map_inj _ hI

lemma injective_character (hIs : ∀ (I : ideal R), function.injective (tensor_embedding M I)) :
  module.Baer.{u u} R (character_module M) :=
begin
  rw module.Baer_iff,
  intros I l,
  obtain ⟨F, hF⟩ := surj1 _ _ (hIs I) (character_module.hom_equiv _ _ l),
  refine ⟨(character_module.hom_equiv _ _).symm F, _⟩,
  ext i m : 2,
  simp only [restrict_to_ideal_apply, linear_map.dom_restrict_apply, character_module.hom_equiv,
    equiv.coe_fn_symm_mk, linear_map.coe_mk],
  have EQ := fun_like.congr_fun hF (i ⊗ₜ m),
  simpa only [character_module.hom_equiv_apply, add_monoid_hom.coe_to_int_linear_map,
    tensor_product.to_add_comm_group'.apply_tmul] using EQ,
end

/--
`tensor_embedding M I` is the canonical map `I ⊗ M ⟶ R ⊗ M`
-/
lemma inj_of_ideal (hIs : module.flat.ideal R M) :
  module.flat.inj R M :=
begin
  apply flat'_of_baer,
  apply injective_character,
  assumption
end

end inj_of_ideal

lemma fg_ideal_of_inj (H : module.flat.inj R M) : module.flat.fg_ideal R M :=
begin
  intros I hI,
  refine @H ⟨I⟩ ⟨R⟩ ⟨coe, λ _ _, rfl, λ _ _, rfl⟩ _,
  intros z z' h,
  ext1,
  simpa only [linear_map.coe_mk] using h,
end

lemma exact_of_ses (H : module.flat.ses R M) :
  module.flat.exact R M :=
λ N1 N2 N3 l12 l23 he, functor.map_exact _ _ _ he

lemma inj_of_exact (H : module.flat.exact R M) :
  module.flat.inj R M :=
λ N1 N2 l h,
begin
  have e0 : exact (0 : (0 : Module.{u} R) ⟶ _) l,
  { rw ←Module.mono_iff_injective at h,
    resetI,
    apply exact_zero_left_of_mono, },
  specialize H (0 : (0 : Module.{u} R) ⟶ N1) l e0,
  have eq1 : ((tensor_right (Module.of R M)).map 0) =
    (_ : Module.of R ((0 : Module.{u} R) ⊗ M) ⟶ 0) ≫ (0 : (0 : Module.{u} R) ⟶ Module.of R (N1 ⊗ M)),
  work_on_goal 3
  { refine tensor_product.lift 0, },
  { refine linear_map.ext (λ z, z.induction_on _ (λ z m, _) (λ x y hx hy, _)),
    { simp only [map_zero] },
    { simp only [tensor_right_map, monoidal_preadditive.zero_tensor, comp_zero], },
    { rw [map_add, hx, hy, map_add], }, },
  rw eq1 at H,
  rw abelian.exact_epi_comp_iff at H,
  rw ←mono_iff_exact_zero_left at H,
  rwa Module.mono_iff_injective at H,
end

lemma equiv_defs : tfae
  [module.flat.ses R M
  , module.flat.inj R M
  , module.flat.ideal R M
  , module.flat.fg_ideal R M
  , module.flat.exact R M] :=
begin
  tfae_have : 1 → 2, { apply inj_of_ses },
  tfae_have : 2 → 1, { apply ses_of_inj },
  tfae_have : 3 → 2, { apply inj_of_ideal },
  tfae_have : 4 → 3, { apply ideal_of_fg_ideal },
  tfae_have : 2 → 4, { apply fg_ideal_of_inj },
  tfae_have : 5 → 2, { apply inj_of_exact },
  tfae_have : 1 → 5, { apply exact_of_ses },
  tfae_finish,
end

end flat

end module


import for_mathlib.category_theory.functor.shift
import category_theory.triangulated.pretriangulated
import for_mathlib.category_theory.triangulated.pretriangulated_misc
import for_mathlib.category_theory.triangulated.yoneda

open category_theory category_theory.category category_theory.limits
  category_theory.pretriangulated

noncomputable theory

namespace category_theory

namespace functor

variables {C D E : Type*} [category C] [category D] [category E]
  [has_shift C ℤ] [has_shift D ℤ] [has_shift E ℤ]
  [preadditive C] [preadditive D] [preadditive E]
  (F : C ⥤ D) [F.has_comm_shift ℤ] (G : D ⥤ E) [G.has_comm_shift ℤ]

@[simps]
def map_triangle : pretriangulated.triangle C ⥤ pretriangulated.triangle D :=
{ obj := λ T, pretriangulated.triangle.mk (F.map T.mor₁) (F.map T.mor₂)
    (F.map T.mor₃ ≫ (F.comm_shift_iso (1 : ℤ)).hom.app T.obj₁),
  map := λ S T f,
  { hom₁ := F.map f.hom₁,
    hom₂ := F.map f.hom₂,
    hom₃ := F.map f.hom₃,
    comm₁' := by { dsimp, simp only [← F.map_comp, f.comm₁], },
    comm₂' := by { dsimp, simp only [← F.map_comp, f.comm₂], },
    comm₃' := begin
      dsimp,
      erw [category.assoc, ←nat_trans.naturality],
      simp only [functor.comp_map, ← F.map_comp_assoc, f.comm₃],
    end, }, }

instance [faithful F] : faithful F.map_triangle :=
⟨λ K L f₁ f₂ hf, begin
  ext; apply F.map_injective,
  { change (F.map_triangle.map f₁).hom₁ = (F.map_triangle.map f₂).hom₁, rw hf, },
  { change (F.map_triangle.map f₁).hom₂ = (F.map_triangle.map f₂).hom₂, rw hf, },
  { change (F.map_triangle.map f₁).hom₃ = (F.map_triangle.map f₂).hom₃, rw hf, },
end⟩

instance [full F] [faithful F] : full F.map_triangle :=
full_of_surjective _ (λ K L f, begin
  refine
  ⟨{ hom₁ := F.preimage f.hom₁,
    hom₂ := F.preimage f.hom₂,
    hom₃ := F.preimage f.hom₃,
    comm₁' := F.map_injective (by simpa only [F.map_comp, image_preimage] using f.comm₁),
    comm₂' := F.map_injective (by simpa only [F.map_comp, image_preimage] using f.comm₂),
    comm₃' := F.map_injective (begin
      have eq := f.comm₃,
      dsimp at eq,
      simp only [map_comp, image_preimage, assoc,
        ← cancel_mono ((F.comm_shift_iso (1 : ℤ)).hom.app L.obj₁), ← eq],
      erw (F.comm_shift_iso (1 : ℤ)).hom.naturality (F.preimage f.hom₁),
      simp only [comp_map, image_preimage],
    end), }, by tidy⟩,
end)

@[simps]
def map_triangle_rotate [functor.additive F] :
  F.map_triangle ⋙ pretriangulated.rotate D ≅
    pretriangulated.rotate C ⋙ F.map_triangle :=
nat_iso.of_components (λ T, triangle.mk_iso _ _ (iso.refl _) (iso.refl _)
  ((F.comm_shift_iso (1 : ℤ)).symm.app _) (by tidy) (by tidy) begin
    dsimp,
    simp only [map_id, preadditive.neg_comp, comp_id,
      map_neg, preadditive.comp_neg, neg_inj],
    erw ← nat_trans.naturality_assoc,
    simp only [comp_map, iso.inv_hom_id_app, comp_id],
  end)
  (λ X Y f, begin
    ext,
    { dsimp, simp, },
    { dsimp, simp, },
    { dsimp, erw ← nat_trans.naturality, refl, },
  end)

@[simps]
def map_triangle_inv_rotate [functor.additive F]
  [∀ (n : ℤ), (shift_functor C n).additive]
  [∀ (n : ℤ), (shift_functor D n).additive] :
  F.map_triangle ⋙ pretriangulated.inv_rotate D ≅
    pretriangulated.inv_rotate C ⋙ F.map_triangle :=
calc F.map_triangle ⋙ inv_rotate D ≅ _ : (functor.left_unitor _).symm
... ≅ _ : iso_whisker_right (pretriangulated.triangle_rotation C).counit_iso.symm _
... ≅ _ : functor.associator _ _ _
... ≅ _ : iso_whisker_left _ (functor.associator _ _ _).symm
... ≅ _ : iso_whisker_left _ (iso_whisker_right (map_triangle_rotate F).symm _)
... ≅ _ : iso_whisker_left _ (functor.associator _ _ _)
... ≅ _ : iso_whisker_left _ (iso_whisker_left _ (pretriangulated.triangle_rotation D).unit_iso.symm)
... ≅ _: iso_whisker_left _ (functor.right_unitor _)

variable (C)

@[simps]
def map_triangle_id : (𝟭 C).map_triangle ≅ 𝟭 _ :=
nat_iso.of_components (λ T, pretriangulated.triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _)
  (by tidy) (by tidy) (by tidy)) (by tidy)

variable {C}

@[simps]
def map_triangle_comp : (F ⋙ G).map_triangle ≅ F.map_triangle ⋙ G.map_triangle :=
nat_iso.of_components (λ T, pretriangulated.triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _)
  (by tidy) (by tidy) (by { dsimp, simp, })) (λ T₁ T₂ f, by { ext; dsimp; simp, })

variables {F}

@[simps]
def map_triangle_nat_trans {F' : C ⥤ D} [F'.has_comm_shift ℤ] (τ : F ⟶ F')
  [τ.respects_comm_shift ℤ] :
  F.map_triangle ⟶ F'.map_triangle :=
{ app := λ X,
  { hom₁ := τ.app _,
    hom₂ := τ.app _,
    hom₃ := τ.app _,
    comm₃' := begin
      dsimp,
      simp only [assoc, nat_trans.respects_comm_shift.comm_app τ (1 : ℤ),
        nat_trans.naturality_assoc],
    end, }, }

@[simps]
def map_triangle_nat_iso {F' : C ⥤ D} [F'.has_comm_shift ℤ] (e : F ≅ F')
  [e.hom.respects_comm_shift ℤ] : F.map_triangle ≅ F'.map_triangle :=
nat_iso.of_components
  (λ T, pretriangulated.triangle.mk_iso _ _ (e.app _) (e.app _) (e.app _) (by tidy) (by tidy)
  begin
    dsimp,
    simp only [assoc, nat_trans.respects_comm_shift.comm_app e.hom (1 : ℤ),
      nat_trans.naturality_assoc],
  end) (by tidy)

variables (F) [∀ (n : ℤ), (shift_functor C n).additive]
  [∀ (n : ℤ), (shift_functor D n).additive]
  [∀ (n : ℤ), (shift_functor E n).additive]
  [has_zero_object C] [has_zero_object D] [has_zero_object E]
  [pretriangulated C] [pretriangulated D] [pretriangulated E]

@[protected]
class is_triangulated : Prop :=
(map_distinguished' [] : ∀ (T : pretriangulated.triangle C)
  (hT : T ∈ dist_triang C), F.map_triangle.obj T ∈ dist_triang D)

lemma map_distinguished [F.is_triangulated] (T : pretriangulated.triangle C)
  (hT : T ∈ dist_triang C) : F.map_triangle.obj T ∈ dist_triang D :=
is_triangulated.map_distinguished' F T hT

instance id_is_triangulated : (𝟭 C).is_triangulated :=
{ map_distinguished' :=
    λ T hT, pretriangulated.isomorphic_distinguished _ hT _ ((map_triangle_id C).app T), }

instance comp_is_triangulated [F.is_triangulated] [G.is_triangulated] :
  (F ⋙ G).is_triangulated :=
{ map_distinguished' := λ T hT, pretriangulated.isomorphic_distinguished _
    (G.map_distinguished _ (F.map_distinguished _ hT)) _ ((map_triangle_comp F G).app T), }

lemma reflects_distinguished [F.is_triangulated] [full F] [faithful F]
  (T : pretriangulated.triangle C) (hT : F.map_triangle.obj T ∈ dist_triang D) :
  T ∈ dist_triang C :=
begin
  obtain ⟨Z, g, h, mem⟩ := distinguished_cocone_triangle _ _ T.mor₁,
  exact pretriangulated.isomorphic_distinguished _ mem _
    (F.map_triangle.preimage_iso (pretriangulated.iso_triangle_of_distinguished_of_is_iso₁₂ _ _ hT
    (F.map_distinguished _ mem) (iso.refl _) (iso.refl _) (by tidy))),
end

variable {F}

lemma is_triangulated.of_iso {G : C ⥤ D} (e : F ≅ G) [F.is_triangulated] [G.has_comm_shift ℤ]
  [e.hom.respects_comm_shift ℤ] : G.is_triangulated :=
⟨λ T hT, pretriangulated.isomorphic_distinguished _
  (F.map_distinguished _ hT) _ ((map_triangle_nat_iso e).symm.app T)⟩

end functor

namespace pretriangulated

variables {C : Type*} [category C] [has_shift C ℤ] [preadditive C]
  (S : set C) [S.is_stable_by_shift ℤ]

variables (T : pretriangulated.triangle C)
  (h₁ : T.obj₁ ∈ S) (h₂ : T.obj₂ ∈ S) (h₃ : T.obj₃ ∈ S)

@[simps]
def full_subcategory_lift_triangle :
  pretriangulated.triangle (full_subcategory S) :=
{ obj₁ := ⟨T.obj₁, h₁⟩,
  obj₂ := ⟨T.obj₂, h₂⟩,
  obj₃ := ⟨T.obj₃, h₃⟩,
  mor₁ := T.mor₁,
  mor₂ := T.mor₂,
  mor₃ := T.mor₃, }

def full_subcategory_lift_triangle_iso :
  (full_subcategory_inclusion S).map_triangle.obj
    (full_subcategory_lift_triangle S T h₁ h₂ h₃) ≅ T :=
triangle.mk_iso _ _ (iso.refl _) (iso.refl _) (iso.refl _) (by tidy) (by tidy) begin
  dsimp,
  simp only [functor.map_id, comp_id, id_comp],
  erw comp_id,
end

end pretriangulated

end category_theory


import graphs.ext

lemma eq_mor_eq_vmap {G H : graph} (α : G ↦ H) (β : G ↦ H) (hyp : α = β) : α.vertex_map = β.vertex_map :=
begin
  cases α,
  cases β,
  rw morphism.mk.inj_eq at hyp,
  exact hyp.1,
end

lemma eq_mor_eq_emap {G H : graph} (α : G ↦ H) (β : G ↦ H) (hyp : α = β) : α.edge_map = β.edge_map :=
begin
  cases α,
  cases β,
  rw morphism.mk.inj_eq at hyp,
  exact hyp.2,
end


import measure_theory.constructions.borel_space

variables (α : Type*) [topological_space α]

localized "attribute [instance] borel" in borelize

lemma borel_space_borel : @borel_space α _ (borel α) := ⟨rfl⟩

localized "attribute [instance] borel_space_borel" in borelize


/-
The problem is originally presented in:
A. Pease, G. Sutcliffe, N. Siegel, and S. Trac, “Large Theory
Reasoning with SUMO at CASC,” pp. 1–8, Jul. 2009.
Here we present the natural deduction proof in Lean.
-/

constant U : Type

constants SetOrClass Set Class Object Entity NullList_m List
          CorpuscularObject Invertebrate Vertebrate Animal SpinalColumn
          Organism Agent Physical Abstract
          subclass_m TransitiveRelation PartialOrderingRelation Relation : U
constant BananaSlug10 : U

constants exhaustiveDecomposition3 disjointDecomposition3 partition3 : U → U → U → Prop
constant ins : U → U → Prop
constant subclass : U → U → Prop
constant disjoint : U → U → Prop
constant component : U → U → Prop
constant part : U → U → Prop
constant inList : U → U → Prop
constant ConsFn : U → U → U
constant ListFn1 : U → U
constant ListFn2 : U → U → U
constant ListFn3 : U → U → U → U

/- SUMO axioms -/

variable a13 : ins subclass_m PartialOrderingRelation

variable a15 : ∀ x y z : U, ins x SetOrClass ∧ ins y SetOrClass →
 (subclass x y ∧ ins z x → ins z y)

/- EDITED (see https://github.com/own-pt/cl-krr/issues/23) -/
variable a72773 : ∀ a : U, ((ins a Animal) ∧ (¬ ∃ p : U, ins p SpinalColumn ∧ part p a))
  → ¬ ins a Vertebrate

/- EDITED -/
variable a72774 : ¬ ∃ s : U, ins s SpinalColumn ∧ part s BananaSlug10

variable a72761 : ∀ x row0 row1 : U, ins row0 Entity ∧ ins row1 Entity ∧ ins x Entity →
 (ListFn3 x row0 row1 = ConsFn x (ListFn2 row0 row1))

variable a72767 : ∀ x y : U, (ins x Entity ∧ ins y Entity) →
 ((ListFn2 x y) = (ConsFn x (ConsFn y NullList_m)))

variable a72768 : ∀ x : U, ins x Entity → (ListFn1 x = ConsFn x NullList_m)

variable a72769 : ∀ x : U, ins x Entity → ¬ inList x NullList_m

variable a72770 : ∀ L x y : U, (ins x Entity ∧ ins y Entity ∧ ins L List) →
 ((inList x (ConsFn y L)) ↔ ((x = y) ∨ inList x L))

variable a67959 : ins NullList_m List

variable a67958 : ins List SetOrClass
variable a72772 : ins BananaSlug10 Animal
variable a72771 : ins Animal SetOrClass
variable a72778 : ins Invertebrate SetOrClass
variable a71402 : ins Vertebrate SetOrClass
variable a71371 : ins Organism SetOrClass
variable a71872 : ins Agent SetOrClass
variable a71669 : ins Object SetOrClass
variable a69763 : ins Physical SetOrClass
variable a67331 : ins Entity SetOrClass
variable a67448 : ins SetOrClass SetOrClass
variable a68771 : ins Abstract SetOrClass
variable a68763 : ins Relation SetOrClass
variable a71844 : ins TransitiveRelation SetOrClass
variable a72180 : ins PartialOrderingRelation SetOrClass

variable a71370 : partition3 Animal Vertebrate Invertebrate

variable a67131 : ∀ (c row0 row1 : U), (ins c Class ∧ ins row0 Class ∧  ins row1 Class) →
 (partition3 c row0 row1 ↔ (exhaustiveDecomposition3 c row0 row1 ∧ disjointDecomposition3 c row0 row1))

-- EDITED (see https://github.com/own-pt/cl-krr/issues/22)
variable a67115 :
  ∀ (row0 row1 c obj : U),
    ∃ (item : U),
      ins item SetOrClass ∧
        (ins obj Entity →
          ins c SetOrClass ∧ ins c Class ∧
          ins row0 Class ∧ ins row0 Entity ∧
          ins row1 Class ∧ ins row1 Entity →
            exhaustiveDecomposition3 c row0 row1 → ins obj c →
              inList item (ListFn2 row0 row1) ∧ ins obj item)

variable a67447 : partition3 SetOrClass Set Class
variable a67172 : ∃ x : U, ins x Entity
variable a67173 : ∀ c : U, ins c Class ↔ subclass c Entity
variable a67818 : subclass PartialOrderingRelation TransitiveRelation

variable a67809 : ∀ x y z : U, ins x SetOrClass ∧ ins y SetOrClass ∧ ins z SetOrClass →
  ins subclass_m TransitiveRelation → (subclass x y ∧ subclass y z → subclass x z)

variable a71382 : subclass Vertebrate Animal
variable a71383 : subclass Invertebrate Animal
variable a71369 : subclass Animal Organism
variable a71340 : subclass Organism Agent
variable a67315 : subclass Agent Object
variable a67177 : subclass Object Physical
variable a67174 : subclass Physical Entity
variable a67446 : subclass SetOrClass Abstract
variable a67332 : subclass Abstract Entity
variable a67954 : subclass List Relation
variable a67450 : subclass Relation Abstract

-- commented in list.kif
variable novo1 : ∀ (x L : U), ins L Entity → ins L List → ins (ConsFn x L) List

-- some initial tests

include a15 a71382 a71383 a71402 a72771
lemma VertebrateAnimal : ∀ (x : U), ins x Vertebrate → ins x Animal :=
begin
 intros a h,
 have h1, from a15 Vertebrate Animal a,
 apply h1,
 exact (and.intro a71402 a72771),
 exact (and.intro a71382 h)
end
omit a15 a71382 a71383 a71402 a72771

include a15 a72180 a71844 a67818 a13
lemma subclass_TransitiveRelation : ins subclass_m TransitiveRelation :=
begin
 specialize a15 PartialOrderingRelation TransitiveRelation subclass_m,
 apply a15,
 exact ⟨ a72180, a71844 ⟩,
 exact ⟨ a67818, a13 ⟩,
end
omit a15 a72180 a71844 a67818 a13

include a15 a72180 a71383 a71844 a13 a67818 a71402 a72771 a71371 a71382
        a71369 a67809

lemma VertebrateOrganism : ∀ (x : U), ins x Vertebrate → ins x Organism :=
begin
 intros a h,
 have h1, from a15 Animal Organism a,
 apply h1,
 exact and.intro a72771 a71371,
 have h0 : ∀ x, ins x Vertebrate → ins x Animal, apply VertebrateAnimal; assumption,
 have h2, from h0 a h,
 exact and.intro a71369 h2,
end

lemma VertebrateOrganism' : ∀ (x : U), ins x Vertebrate → ins x Organism :=
begin
  intros a h,
  have h₁ : ins subclass_m TransitiveRelation,
    specialize a15 PartialOrderingRelation TransitiveRelation subclass_m,
    apply a15,
    exact ⟨a72180, a71844⟩,
    exact ⟨a67818, a13⟩,
  have h₂ : subclass Vertebrate Organism,
    apply a67809 _ Animal _,
    exact ⟨a71402, ⟨a72771, a71371⟩⟩,
    exact h₁,
    exact ⟨a71382, a71369⟩,
  apply a15 Vertebrate _ _,
  exact ⟨a71402, a71371⟩,
  exact ⟨h₂, h⟩
end
omit a15 a72180 a71383 a71844 a13 a67818 a71402 a72771 a71371 a71382
     a71369 a67809

include a15 a72180 a71844 a13 a67818 a71402 a72771 a71371
        a71369 a67809 a71382 a67174 a69763 a67331 a71669 a71340
        a67315 a67177 a71872

lemma VertebrateEntity : ∀ (x : U), ins x Vertebrate → ins x Entity :=
begin
  intros a h,
  have h1, apply subclass_TransitiveRelation; assumption,
  have h2 : subclass Vertebrate Organism,
    apply a67809 _ Animal _,
    exact ⟨a71402, ⟨ a72771, a71371 ⟩⟩,
    exact h1,
    exact ⟨a71382, a71369⟩,
  have h3 : subclass Vertebrate Agent,
    apply a67809 _ Organism _,
    exact ⟨a71402, ⟨ a71371, a71872 ⟩⟩,
    exact h1,
    exact ⟨h2, a71340⟩,
  have h4 : subclass Vertebrate Object,
    apply a67809 _ Agent _,
    exact ⟨a71402, ⟨ a71872, a71669 ⟩⟩,
    exact h1,
    exact ⟨h3, a67315⟩,
  have h5 : subclass Vertebrate Physical,
    apply a67809 _ Object _,
    exact ⟨a71402, ⟨ a71669, a69763 ⟩⟩,
    exact h1,
    exact ⟨h4, a67177⟩,
  have h6 : subclass Vertebrate Entity,
    apply a67809 _ Physical _,
    exact ⟨a71402, ⟨ a69763, a67331 ⟩⟩,
    exact h1,
    exact ⟨ h5, a67174 ⟩,
  apply a15 Vertebrate _ _,
  exact ⟨a71402, a67331⟩,
  exact ⟨h6, h⟩
end
omit a15 a72180 a71844 a13 a67818 a71402 a72771 a71371
     a71369 a67809 a71382 a67174 a69763 a67331 a71669 a71340
     a67315 a67177 a71872

-- start proofs

include a72767 a72768 a72769 a72770 a67959 a15 novo1 a67954 a67332 a67331
        a68771 a68763 a67958 a67450

lemma listLemma (hne : nonempty U) : ∀ x y z : U,
  ins x Entity ∧ ins y Entity ∧ ins z Entity →
  inList x (ListFn2 y z) → x = y ∨ x = z :=
begin
  intros x y z h h1,
    rw (a72767 y z ⟨h.right.left, h.right.right⟩) at h1,
    have h2 : x = y ∨ inList x (ConsFn z NullList_m),
      rw ←(a72770 (ConsFn z NullList_m) x y),
      exact h1,
      simp *,
      apply novo1 z NullList_m,
         apply a15 Abstract Entity NullList_m;
           simp *,
           apply a15 Relation Abstract NullList_m;
             simp *,
             apply a15 List Relation NullList_m;
               simp *,
               assumption,
      cases h2,
        exact or.inl h2,
        have h3 : x = z ∨ inList x NullList_m,
          rw ←(a72770 NullList_m x z),
          exact h2,
          exact ⟨h.1, ⟨h.2.2, a67959⟩⟩,
          cases h3,
            exact or.inr h3,
            apply false.elim,
              exact ((a72769 x) h.left) h3
end

omit a72767 a72768 a72769 a72770 a67959 a15 novo1 a67954 a67332 a67331
     a68771 a68763 a67958 a67450

include a67131 a67115 a67809 a67448 a68771 a67331 a15 a72180 a71844 a67818 a13
        a67446 a67332 a72767 a72768 a72769 a72770 a67959  novo1 a67954 a68763
        a67958 a67450

lemma lX (hne : nonempty U) : ∀ x c c1 c2,
  (ins c SetOrClass ∧ ins c1 SetOrClass ∧ ins c2 SetOrClass) →
  (ins c Class ∧ ins c1 Class ∧ ins c2 Class ∧ ins x Entity) →
    (partition3 c c1 c2 ∧ ins x c ∧ ¬ ins x c1) → ins x c2 :=
begin
  intros a c c1 c2 h1 h2 h3,
  specialize a67131 c c1 c2,
  specialize a67115 c1 c2 c a,
  have h₃, from a67131 ⟨ h2.1, ⟨h2.2.1, h2.2.2.1 ⟩⟩,
  have h4, from iff.elim_left h₃ h3.1,
  cases h4 with h4a h4b,
  cases a67115 with b h5,
  have h7, from h5.right,
  have h8, from h2.right.right.right,
  specialize h7 h8,
  have h9 : subclass SetOrClass Entity,
    apply (a67809 _ Abstract _),
      exact ⟨a67448, ⟨a68771, a67331⟩⟩,
      apply subclass_TransitiveRelation; assumption,
      exact ⟨a67446, a67332⟩,
  have h10 : ins c1 Entity,
    apply (a15 SetOrClass _ _),
      exact ⟨a67448, a67331⟩,
      exact ⟨h9, h1.2.1⟩,
  have h11 : ins c2 Entity,
    apply (a15 SetOrClass _ _),
      exact ⟨a67448, a67331⟩,
      exact ⟨h9, h1.2.2⟩,
  specialize h7 ⟨h1.1, ⟨h2.1, ⟨h2.2.1, ⟨h10, ⟨h2.2.2.1, h11⟩⟩⟩⟩⟩,
  specialize h7 h4a,
  specialize h7 h3.right.left,
  have h12 : b = c1 ∨ b = c2,
    apply listLemma,
      repeat { assumption },
      split,
        apply a15 SetOrClass _ _,
          exact ⟨a67448, a67331⟩,
          exact ⟨h9, h5.left⟩,
      exact ⟨h10, h11⟩,
      exact h7.left,
  cases h12,
    rw h12 at h7,
    apply false.elim,
      exact h3.right.right h7.right,
    rw ←h12,
    exact h7.right
 end

include a72771 a71371 a71872 a71369 a71340 a71669 a67315 a69763 a67177
        a67174

lemma subclass_animal_entity : subclass Animal Entity :=
begin
  have h1, apply subclass_TransitiveRelation; assumption,
  have h2 : subclass Animal Agent,
    apply a67809 _ Organism _,
    exact ⟨a72771, ⟨ a71371, a71872 ⟩⟩,
    exact h1,
    exact ⟨a71369, a71340⟩,
  have h3 : subclass Animal Object,
    apply a67809 _ Agent _,
    exact ⟨a72771, ⟨ a71872, a71669 ⟩⟩,
    exact h1,
    exact ⟨h2, a67315⟩,
  have h4 : subclass Animal Physical,
    apply a67809 _ Object _,
    exact ⟨a72771, ⟨ a71669, a69763 ⟩⟩,
    exact h1,
    exact ⟨h3, a67177⟩,
  apply a67809 _ Physical _,
  exact ⟨a72771, ⟨ a69763, a67331 ⟩⟩,
  exact h1,
  exact ⟨ h4, a67174 ⟩,
end

include a71402 a71382

lemma subclass_vertebrate_entity : subclass Vertebrate Entity :=
begin
  have h1, apply subclass_TransitiveRelation; assumption,
  have h2 : subclass Vertebrate Organism,
    apply a67809 _ Animal _,
    exact ⟨a71402, ⟨ a72771, a71371 ⟩⟩,
    exact h1,
    exact ⟨a71382, a71369⟩,
  have h3 : subclass Vertebrate Agent,
    apply a67809 _ Organism _,
    exact ⟨a71402, ⟨ a71371, a71872 ⟩⟩,
    exact h1,
    exact ⟨h2, a71340⟩,
  have h4 : subclass Vertebrate Object,
    apply a67809 _ Agent _,
    exact ⟨a71402, ⟨ a71872, a71669 ⟩⟩,
    exact h1,
    exact ⟨h3, a67315⟩,
  have h5 : subclass Vertebrate Physical,
    apply a67809 _ Object _,
    exact ⟨a71402, ⟨ a71669, a69763 ⟩⟩,
    exact h1,
    exact ⟨h4, a67177⟩,
  apply a67809 _ Physical _,
  exact ⟨a71402, ⟨ a69763, a67331 ⟩⟩,
  exact h1,
  exact ⟨ h5, a67174 ⟩,
end

include a72778 a71383

lemma subclass_invertebrate_entity : subclass Invertebrate Entity :=
begin
  have h1, apply subclass_TransitiveRelation; assumption,
  have h2 : subclass Invertebrate Organism,
    apply a67809 _ Animal _,
    exact ⟨a72778, ⟨ a72771, a71371 ⟩⟩,
    exact h1,
    exact ⟨a71383, a71369⟩,
  have h3 : subclass Invertebrate Agent,
    apply a67809 _ Organism _,
    exact ⟨a72778, ⟨ a71371, a71872 ⟩⟩,
    exact h1,
    exact ⟨h2, a71340⟩,
  have h4 : subclass Invertebrate Object,
    apply a67809 _ Agent _,
    exact ⟨a72778, ⟨ a71872, a71669 ⟩⟩,
    exact h1,
    exact ⟨h3, a67315⟩,
  have h5 : subclass Invertebrate Physical,
    apply a67809 _ Object _,
    exact ⟨a72778, ⟨ a71669, a69763 ⟩⟩,
    exact h1,
    exact ⟨h4, a67177⟩,
  apply a67809 _ Physical _,
  exact ⟨a72778, ⟨ a69763, a67331 ⟩⟩,
  exact h1,
  exact ⟨ h5, a67174 ⟩,
end

include a72772 a72774

lemma ins_banana_entity : ins BananaSlug10 Entity :=
begin
 have h1, apply subclass_TransitiveRelation; assumption,
 have h2 : ins BananaSlug10 Organism,
  specialize a15 Animal Organism BananaSlug10,
  apply a15,
  exact and.intro a72771 a71371,
  exact and.intro a71369 a72772,
 have h3 : ins BananaSlug10 Agent,
  specialize a15 Organism Agent BananaSlug10,
  apply a15,
  exact and.intro a71371 a71872,
  exact and.intro a71340 h2,
 have h4 : ins BananaSlug10 Object,
  specialize a15 Agent Object BananaSlug10,
  apply a15,
  exact and.intro a71872 a71669,
  exact and.intro a67315 h3,
 have h5 : ins BananaSlug10 Physical,
  specialize a15 Object Physical BananaSlug10,
  apply a15,
  exact and.intro a71669 a69763,
  exact and.intro a67177 h4,
 specialize a15 Physical Entity BananaSlug10,
 apply a15,
 exact and.intro a69763 a67331,
 exact and.intro a67174 h5,
end

include a67173

lemma ins_animal_class : ins Animal Class :=
begin
 have h0 : subclass Animal Entity,
  apply subclass_animal_entity; assumption,
 have h1, from (a67173 Animal),
 exact h1.2 h0,
end

include a71370 a72773

lemma l0' (hne : nonempty U) : ¬(ins BananaSlug10 Vertebrate) := by simp *
lemma l0  (hne : nonempty U) : ¬(ins BananaSlug10 Vertebrate) :=
begin
  specialize a72773 BananaSlug10,
  exact a72773 (and.intro a72772 a72774)
end

theorem Banana_Invertebrate (hne: nonempty U) : ins BananaSlug10 Invertebrate :=
begin
 have h1 : ¬ ins BananaSlug10 Vertebrate,
  apply l0; assumption,
 have h2 : ∀ x c c1 c2,
  (ins c SetOrClass ∧ ins c1 SetOrClass ∧ ins c2 SetOrClass) →
  (ins c Class ∧ ins c1 Class ∧ ins c2 Class ∧ ins x Entity) →
   (partition3 c c1 c2 ∧ ins x c ∧ ¬ ins x c1) → ins x c2,
   apply lX; assumption,
 have h3, from h2 BananaSlug10 Animal Vertebrate Invertebrate,
 apply h3,
 exact ⟨ a72771, ⟨ a71402, a72778 ⟩⟩,
 have h₁ : subclass Animal Entity,
   apply subclass_animal_entity; assumption,
 have h₂ : ins Animal Class,
   rw a67173, exact h₁,
 have h₃ : subclass Vertebrate Entity,
   apply subclass_vertebrate_entity; assumption,
 have h₄ : ins Vertebrate Class,
   rw a67173, exact h₃,
 have h₅ : subclass Invertebrate Entity,
   apply subclass_invertebrate_entity; assumption,
 have h₆ : ins Invertebrate Class,
  rw a67173, exact h₅,
 have h₇ : ins BananaSlug10 Entity,
  apply ins_banana_entity; assumption,
 exact and.intro h₂ (and.intro h₄ (and.intro h₆ h₇)),
 exact and.intro a71370 (and.intro a72772 h1),
end

example (X Y C : U) (h : partition3 C X Y) : subclass X C ∧ subclass Y C := sorry

example (h : ins SetOrClass SetOrClass) : false := sorry


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import logic.is_empty
import tactic.basic
import logic.relator

/-!
# Option of a type

This file develops the basic theory of option types.

If `α` is a type, then `option α` can be understood as the type with one more element than `α`.
`option α` has terms `some a`, where `a : α`, and `none`, which is the added element.
This is useful in multiple ways:
* It is the prototype of addition of terms to a type. See for example `with_bot α` which uses
  `none` as an element smaller than all others.
* It can be used to define failsafe partial functions, which return `some the_result_we_expect`
  if we can find `the_result_we_expect`, and `none` if there is no meaningful result. This forces
  any subsequent use of the partial function to explicitly deal with the exceptions that make it
  return `none`.
* `option` is a monad. We love monads.

`part` is an alternative to `option` that can be seen as the type of `true`/`false` values
along with a term `a : α` if the value is `true`.

## Implementation notes

`option` is currently defined in core Lean, but this will change in Lean 4.
-/

namespace option
variables {α : Type*} {β : Type*} {γ : Type*}

lemma coe_def : (coe : α → option α) = some := rfl

lemma some_ne_none (x : α) : some x ≠ none := λ h, option.no_confusion h

protected lemma «forall» {p : option α → Prop} : (∀ x, p x) ↔ p none ∧ ∀ x, p (some x) :=
⟨λ h, ⟨h _, λ x, h _⟩, λ h x, option.cases_on x h.1 h.2⟩

protected lemma «exists» {p : option α → Prop} : (∃ x, p x) ↔ p none ∨ ∃ x, p (some x) :=
⟨λ ⟨x, hx⟩, (option.cases_on x or.inl $ λ x hx, or.inr ⟨x, hx⟩) hx,
  λ h, h.elim (λ h, ⟨_, h⟩) (λ ⟨x, hx⟩, ⟨_, hx⟩)⟩

@[simp] theorem get_mem : ∀ {o : option α} (h : is_some o), option.get h ∈ o
| (some a) _ := rfl

theorem get_of_mem {a : α} : ∀ {o : option α} (h : is_some o), a ∈ o → option.get h = a
| _ _ rfl := rfl

@[simp] lemma not_mem_none (a : α) : a ∉ (none : option α) :=
λ h, option.no_confusion h

@[simp] lemma some_get : ∀ {x : option α} (h : is_some x), some (option.get h) = x
| (some x) hx := rfl

@[simp] lemma get_some (x : α) (h : is_some (some x)) : option.get h = x := rfl

@[simp] lemma get_or_else_some (x y : α) : option.get_or_else (some x) y = x := rfl

@[simp] lemma get_or_else_none (x : α) : option.get_or_else none x = x := rfl

@[simp] lemma get_or_else_coe (x y : α) : option.get_or_else ↑x y = x := rfl

lemma get_or_else_of_ne_none {x : option α} (hx : x ≠ none) (y : α) : some (x.get_or_else y) = x :=
by cases x; [contradiction, rw get_or_else_some]

theorem mem_unique {o : option α} {a b : α} (ha : a ∈ o) (hb : b ∈ o) : a = b :=
option.some.inj $ ha.symm.trans hb

theorem mem.left_unique : relator.left_unique ((∈) : α → option α → Prop) :=
λ a o b, mem_unique

theorem some_injective (α : Type*) : function.injective (@some α) :=
λ _ _, some_inj.mp

/-- `option.map f` is injective if `f` is injective. -/
theorem map_injective {f : α → β} (Hf : function.injective f) : function.injective (option.map f)
| none      none      H := rfl
| (some a₁) (some a₂) H := by rw Hf (option.some.inj H)

@[ext] theorem ext : ∀ {o₁ o₂ : option α}, (∀ a, a ∈ o₁ ↔ a ∈ o₂) → o₁ = o₂
| none     none     H := rfl
| (some a) o        H := ((H _).1 rfl).symm
| o        (some b) H := (H _).2 rfl

theorem eq_none_iff_forall_not_mem {o : option α} :
  o = none ↔ (∀ a, a ∉ o) :=
⟨λ e a h, by rw e at h; cases h, λ h, ext $ by simpa⟩

@[simp] theorem none_bind {α β} (f : α → option β) : none >>= f = none := rfl

@[simp] theorem some_bind {α β} (a : α) (f : α → option β) : some a >>= f = f a := rfl

@[simp] theorem none_bind' (f : α → option β) : none.bind f = none := rfl

@[simp] theorem some_bind' (a : α) (f : α → option β) : (some a).bind f = f a := rfl

@[simp] theorem bind_some : ∀ x : option α, x >>= some = x :=
@bind_pure α option _ _

@[simp] theorem bind_eq_some {α β} {x : option α} {f : α → option β} {b : β} :
  x >>= f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_some' {x : option α} {f : α → option β} {b : β} :
  x.bind f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_none' {o : option α} {f : α → option β} :
  o.bind f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
by simp only [eq_none_iff_forall_not_mem, not_exists, not_and, mem_def, bind_eq_some']

@[simp] theorem bind_eq_none {α β} {o : option α} {f : α → option β} :
  o >>= f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
bind_eq_none'

lemma bind_comm {α β γ} {f : α → β → option γ} (a : option α) (b : option β) :
  a.bind (λx, b.bind (f x)) = b.bind (λy, a.bind (λx, f x y)) :=
by cases a; cases b; refl

lemma bind_assoc (x : option α) (f : α → option β) (g : β → option γ) :
  (x.bind f).bind g = x.bind (λ y, (f y).bind g) := by cases x; refl

lemma join_eq_some {x : option (option α)} {a : α} : x.join = some a ↔ x = some (some a) := by simp

lemma join_ne_none {x : option (option α)} : x.join ≠ none ↔ ∃ z, x = some (some z) := by simp

lemma join_ne_none' {x : option (option α)} : ¬(x.join = none) ↔ ∃ z, x = some (some z) := by simp

lemma join_eq_none {o : option (option α)} : o.join = none ↔ o = none ∨ o = some none :=
by rcases o with _|_|_; simp

lemma bind_id_eq_join {x : option (option α)} : x >>= id = x.join := by simp

lemma join_eq_join : mjoin = @join α :=
funext (λ x, by rw [mjoin, bind_id_eq_join])

lemma bind_eq_bind {α β : Type*} {f : α → option β} {x : option α} :
  x >>= f = x.bind f := rfl

@[simp] lemma map_eq_map {α β} {f : α → β} :
  (<$>) f = option.map f := rfl

theorem map_none {α β} {f : α → β} : f <$> none = none := rfl

theorem map_some {α β} {a : α} {f : α → β} : f <$> some a = some (f a) := rfl

@[simp] theorem map_none' {f : α → β} : option.map f none = none := rfl

@[simp] theorem map_some' {a : α} {f : α → β} : option.map f (some a) = some (f a) := rfl

theorem map_eq_some {α β} {x : option α} {f : α → β} {b : β} :
  f <$> x = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

@[simp] theorem map_eq_some' {x : option α} {f : α → β} {b : β} :
  x.map f = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

lemma map_eq_none {α β} {x : option α} {f : α → β} :
  f <$> x = none ↔ x = none :=
by { cases x; simp only [map_none, map_some, eq_self_iff_true] }

@[simp] lemma map_eq_none' {x : option α} {f : α → β} :
  x.map f = none ↔ x = none :=
by { cases x; simp only [map_none', map_some', eq_self_iff_true] }

lemma map_congr {f g : α → β} {x : option α} (h : ∀ a ∈ x, f a = g a) :
  option.map f x = option.map g x :=
by { cases x; simp only [map_none', map_some', h, mem_def] }

@[simp] theorem map_id' : option.map (@id α) = id := map_id

@[simp] lemma map_map (h : β → γ) (g : α → β) (x : option α) :
  option.map h (option.map g x) = option.map (h ∘ g) x :=
by { cases x; simp only [map_none', map_some'] }

lemma comp_map (h : β → γ) (g : α → β) (x : option α) :
  option.map (h ∘ g) x = option.map h (option.map g x) := (map_map _ _ _).symm

@[simp] lemma map_comp_map (f : α → β) (g : β → γ) :
  option.map g ∘ option.map f = option.map (g ∘ f) :=
by { ext x, rw comp_map }

lemma mem_map_of_mem {α β : Type*} {a : α} {x : option α} (g : α → β) (h : a ∈ x) : g a ∈ x.map g :=
mem_def.mpr ((mem_def.mp h).symm ▸ map_some')

lemma bind_map_comm {α β} {x : option (option α) } {f : α → β} :
  x >>= option.map f = x.map (option.map f) >>= id :=
by { cases x; simp }

lemma join_map_eq_map_join {f : α → β} {x : option (option α)} :
  (x.map (option.map f)).join = x.join.map f :=
by { rcases x with _ | _ | x; simp }

lemma join_join {x : option (option (option α))} :
  x.join.join = (x.map join).join :=
by { rcases x with _ | _ | _ | x; simp }

lemma mem_of_mem_join {a : α} {x : option (option α)} (h : a ∈ x.join) : some a ∈ x :=
mem_def.mpr ((mem_def.mp h).symm ▸ join_eq_some.mp h)

section pmap

variables {p : α → Prop} (f : Π (a : α), p a → β) (x : option α)

@[simp] lemma pbind_eq_bind (f : α → option β) (x : option α) :
  x.pbind (λ a _, f a) = x.bind f :=
by { cases x; simp only [pbind, none_bind', some_bind'] }

lemma map_bind {α β γ} (f : β → γ) (x : option α) (g : α → option β) :
  option.map f (x >>= g) = (x >>= λ a, option.map f (g a)) :=
by simp_rw [←map_eq_map, ←bind_pure_comp_eq_map,is_lawful_monad.bind_assoc]

lemma map_bind' (f : β → γ) (x : option α) (g : α → option β) :
  option.map f (x.bind g) = x.bind (λ a, option.map f (g a)) :=
by { cases x; simp }

lemma map_pbind (f : β → γ) (x : option α) (g : Π a, a ∈ x → option β) :
  option.map f (x.pbind g) = (x.pbind (λ a H, option.map f (g a H))) :=
by { cases x; simp only [pbind, map_none'] }

lemma pbind_map (f : α → β) (x : option α) (g : Π (b : β), b ∈ x.map f → option γ) :
  pbind (option.map f x) g = x.pbind (λ a h, g (f a) (mem_map_of_mem _ h)) :=
by { cases x; refl }

@[simp] lemma pmap_none (f : Π (a : α), p a → β) {H} : pmap f (@none α) H = none := rfl

@[simp] lemma pmap_some (f : Π (a : α), p a → β) {x : α} (h : p x) :
  pmap f (some x) = λ _, some (f x h) := rfl

lemma mem_pmem {a : α} (h : ∀ a ∈ x, p a) (ha : a ∈ x) :
  f a (h a ha) ∈ pmap f x h :=
by { rw mem_def at ha ⊢, subst ha, refl }

lemma pmap_map (g : γ → α) (x : option γ) (H) :
  pmap f (x.map g) H = pmap (λ a h, f (g a) h) x (λ a h, H _ (mem_map_of_mem _ h)) :=
by { cases x; simp only [map_none', map_some', pmap] }

lemma map_pmap (g : β → γ) (f : Π a, p a → β) (x H) :
  option.map g (pmap f x H) = pmap (λ a h, g (f a h)) x H :=
by { cases x; simp only [map_none', map_some', pmap] }

@[simp] lemma pmap_eq_map (p : α → Prop) (f : α → β) (x H) :
  @pmap _ _ p (λ a _, f a) x H = option.map f x :=
by { cases x; simp only [map_none', map_some', pmap] }

lemma bind_pmap {α β γ} {p : α → Prop} (f : Π a, p a → β) (x : option α) (g : β → option γ) (H) :
  (pmap f x H) >>= g = x.pbind (λ a h, g (f a (H _ h))) :=
by { cases x; simp only [pmap, none_bind, some_bind, pbind] }

variables {f x}

lemma pbind_eq_none {f : Π (a : α), a ∈ x → option β}
  (h' : ∀ a ∈ x, f a H = none → x = none) :
  x.pbind f = none ↔ x = none :=
begin
  cases x,
  { simp },
  { simp only [pbind, iff_false],
    intro h,
    cases h' x rfl h }
end

lemma pbind_eq_some {f : Π (a : α), a ∈ x → option β} {y : β} :
  x.pbind f = some y ↔ ∃ (z ∈ x), f z H = some y :=
begin
  cases x,
  { simp },
  { simp only [pbind],
    split,
    { intro h,
      use x,
      simpa only [mem_def, exists_prop_of_true] using h },
    { rintro ⟨z, H, hz⟩,
      simp only [mem_def] at H,
      simpa only [H] using hz } }
end

@[simp] lemma pmap_eq_none_iff {h} :
  pmap f x h = none ↔ x = none :=
by { cases x; simp }

@[simp] lemma pmap_eq_some_iff {hf} {y : β} :
  pmap f x hf = some y ↔ ∃ (a : α) (H : x = some a), f a (hf a H) = y :=
begin
  cases x,
  { simp only [not_mem_none, exists_false, pmap, not_false_iff, exists_prop_of_false] },
  { split,
    { intro h,
      simp only [pmap] at h,
      exact ⟨x, rfl, h⟩ },
    { rintro ⟨a, H, rfl⟩,
      simp only [mem_def] at H,
      simp only [H, pmap] } }
end

@[simp] lemma join_pmap_eq_pmap_join {f : Π a, p a → β} {x : option (option α)} (H) :
  (pmap (pmap f) x H).join = pmap f x.join (λ a h, H (some a) (mem_of_mem_join h) _ rfl) :=
by { rcases x with _ | _ | x; simp }

end pmap

@[simp] theorem seq_some {α β} {a : α} {f : α → β} : some f <*> some a = some (f a) := rfl

@[simp] theorem some_orelse' (a : α) (x : option α) : (some a).orelse x = some a := rfl

@[simp] theorem some_orelse (a : α) (x : option α) : (some a <|> x) = some a := rfl

@[simp] theorem none_orelse' (x : option α) : none.orelse x = x :=
by cases x; refl

@[simp] theorem none_orelse (x : option α) : (none <|> x) = x := none_orelse' x

@[simp] theorem orelse_none' (x : option α) : x.orelse none = x :=
by cases x; refl

@[simp] theorem orelse_none (x : option α) : (x <|> none) = x := orelse_none' x

@[simp] theorem is_some_none : @is_some α none = ff := rfl

@[simp] theorem is_some_some {a : α} : is_some (some a) = tt := rfl

theorem is_some_iff_exists {x : option α} : is_some x ↔ ∃ a, x = some a :=
by cases x; simp [is_some]; exact ⟨_, rfl⟩

@[simp] theorem is_none_none : @is_none α none = tt := rfl

@[simp] theorem is_none_some {a : α} : is_none (some a) = ff := rfl

@[simp] theorem not_is_some {a : option α} : is_some a = ff ↔ a.is_none = tt :=
by cases a; simp

lemma eq_some_iff_get_eq {o : option α} {a : α} :
  o = some a ↔ ∃ h : o.is_some, option.get h = a :=
by cases o; simp

lemma not_is_some_iff_eq_none {o : option α} :  ¬o.is_some ↔ o = none :=
by cases o; simp

lemma ne_none_iff_is_some {o : option α} : o ≠ none ↔ o.is_some :=
by cases o; simp

lemma ne_none_iff_exists {o : option α} : o ≠ none ↔ ∃ (x : α), some x = o :=
by {cases o; simp}

lemma ne_none_iff_exists' {o : option α} : o ≠ none ↔ ∃ (x : α), o = some x :=
ne_none_iff_exists.trans $ exists_congr $ λ _, eq_comm

lemma bex_ne_none {p : option α → Prop} :
  (∃ x ≠ none, p x) ↔ ∃ x, p (some x) :=
⟨λ ⟨x, hx, hp⟩, ⟨get $ ne_none_iff_is_some.1 hx, by rwa [some_get]⟩,
  λ ⟨x, hx⟩, ⟨some x, some_ne_none x, hx⟩⟩

lemma ball_ne_none {p : option α → Prop} :
  (∀ x ≠ none, p x) ↔ ∀ x, p (some x) :=
⟨λ h x, h (some x) (some_ne_none x),
  λ h x hx, by simpa only [some_get] using h (get $ ne_none_iff_is_some.1 hx)⟩

theorem iget_mem [inhabited α] : ∀ {o : option α}, is_some o → o.iget ∈ o
| (some a) _ := rfl

theorem iget_of_mem [inhabited α] {a : α} : ∀ {o : option α}, a ∈ o → o.iget = a
| _ rfl := rfl

@[simp] theorem guard_eq_some {p : α → Prop} [decidable_pred p] {a b : α} :
  guard p a = some b ↔ a = b ∧ p a :=
by by_cases p a; simp [option.guard, h]; intro; contradiction

@[simp] theorem guard_eq_some' {p : Prop} [decidable p] :
  ∀ u, _root_.guard p = some u ↔ p
| () := by by_cases p; simp [guard, h, pure]; intro; contradiction

theorem lift_or_get_choice {f : α → α → α} (h : ∀ a b, f a b = a ∨ f a b = b) :
  ∀ o₁ o₂, lift_or_get f o₁ o₂ = o₁ ∨ lift_or_get f o₁ o₂ = o₂
| none     none     := or.inl rfl
| (some a) none     := or.inl rfl
| none     (some b) := or.inr rfl
| (some a) (some b) := by simpa [lift_or_get] using h a b

@[simp] lemma lift_or_get_none_left {f} {b : option α} : lift_or_get f none b = b :=
by cases b; refl

@[simp] lemma lift_or_get_none_right {f} {a : option α} : lift_or_get f a none = a :=
by cases a; refl

@[simp] lemma lift_or_get_some_some {f} {a b : α} :
  lift_or_get f (some a) (some b) = f a b := rfl

/-- Given an element of `a : option α`, a default element `b : β` and a function `α → β`, apply this
function to `a` if it comes from `α`, and return `b` otherwise. -/
def cases_on' : option α → β → (α → β) → β
| none     n s := n
| (some a) n s := s a

@[simp] lemma cases_on'_none (x : β) (f : α → β) : cases_on' none x f = x := rfl

@[simp] lemma cases_on'_some (x : β) (f : α → β) (a : α) : cases_on' (some a) x f = f a := rfl

@[simp] lemma cases_on'_coe (x : β) (f : α → β) (a : α) : cases_on' (a : option α) x f = f a := rfl

@[simp] lemma cases_on'_none_coe (f : option α → β) (o : option α) :
  cases_on' o (f none) (f ∘ coe) = f o :=
by cases o; refl

@[simp] lemma get_or_else_map (f : α → β) (x : α) (o : option α) :
  get_or_else (o.map f) (f x) = f (get_or_else o x) :=
by cases o; refl

section
open_locale classical

/-- An arbitrary `some a` with `a : α` if `α` is nonempty, and otherwise `none`. -/
noncomputable def choice (α : Type*) : option α :=
if h : nonempty α then
  some h.some
else
  none

lemma choice_eq {α : Type*} [subsingleton α] (a : α) : choice α = some a :=
begin
  dsimp [choice],
  rw dif_pos (⟨a⟩ : nonempty α),
  congr,
end

lemma choice_eq_none (α : Type*) [is_empty α] : choice α = none :=
dif_neg (not_nonempty_iff_imp_false.mpr is_empty_elim)

lemma choice_is_some_iff_nonempty {α : Type*} : (choice α).is_some ↔ nonempty α :=
begin
  fsplit,
  { intro h, exact ⟨option.get h⟩, },
  { intro h,
    dsimp only [choice],
    rw dif_pos h,
    exact is_some_some },
end

end

@[simp] lemma to_list_some (a : α) : (a : option α).to_list = [a] :=
rfl

@[simp] lemma to_list_none (α : Type*) : (none : option α).to_list = [] :=
rfl

end option


import category_theory.limits.shapes.terminal

namespace category_theory.limits

open category_theory

universes v u

variables {J : Type v} [small_category J] {C : Type u} [category.{v} C] (F : J ⥤ C)

noncomputable theory

@[simps]
def is_initial.colimit_cocone {j : J} (hj : is_initial j)
  [has_colimit F] [∀ (a b : J) (f : a ⟶ b), is_iso (F.map f)] :
  cocone F :=
{ X := F.obj j,
  ι :=
  { app := λ i, inv (F.map $ hj.to _),
    naturality' := begin
      intros a b f,
      dsimp,
      simp only [is_iso.eq_inv_comp, is_iso.comp_inv_eq, category.comp_id],
      simp_rw ← F.map_comp,
      congr' 1,
      apply hj.hom_ext,
    end } }

def is_initial.is_colimit_colimit_cocone {j : J} (hj : is_initial j)
  [has_colimit F] [∀ (a b : J) (f : a ⟶ b), is_iso (F.map f)] :
  is_colimit (hj.colimit_cocone F) :=
{ desc := λ S, S.ι.app _ }

lemma is_initial.is_iso_ι {j : J} (hj : is_initial j)
  [has_colimit F] [∀ (a b : J) (f : a ⟶ b), is_iso (F.map f)] :
  is_iso (colimit.ι F j) :=
begin
  let e := (colimit.is_colimit F).cocone_point_unique_up_to_iso
    (hj.is_colimit_colimit_cocone F),
  change is_iso e.inv,
  apply_instance
end

end category_theory.limits


import Mathbin

import Mathbin.Algebra.Group.Basic

import PremiseSelection.Extractor

extract_premises_from_thm comp_assoc_right

extract_premises_from_thm ite_mul_one

theorem test (a b c : Nat) (h : a < 4) : a + 0 = a := by rfl

extract_premises_from_thm test

--extract_premises_to_files l:"Tests/labels" f:"Tests/features"


/-
Copyright (c) 2015, 2017 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Robert Y. Lewis, Johannes Hölzl, Mario Carneiro, Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.real.ennreal
import Mathlib.data.finset.intervals
import Mathlib.topology.uniform_space.uniform_embedding
import Mathlib.topology.uniform_space.pi
import Mathlib.topology.uniform_space.uniform_convergence
import Mathlib.PostPort

universes u v u_1 l u_2

namespace Mathlib

/-!
# Extended metric spaces

This file is devoted to the definition and study of `emetric_spaces`, i.e., metric
spaces in which the distance is allowed to take the value ∞. This extended distance is
called `edist`, and takes values in `ennreal`.

Many definitions and theorems expected on emetric spaces are already introduced on uniform spaces and
topological spaces. For example:
  open and closed sets, compactness, completeness, continuity and uniform continuity

The class `emetric_space` therefore extends `uniform_space` (and `topological_space`).
-/

/-- Characterizing uniformities associated to a (generalized) distance function `D`
in terms of the elements of the uniformity. -/
theorem uniformity_dist_of_mem_uniformity {α : Type u} {β : Type v} [linear_order β]
    {U : filter (α × α)} (z : β) (D : α → α → β)
    (H :
      ∀ (s : set (α × α)), s ∈ U ↔ ∃ (ε : β), ∃ (H : ε > z), ∀ {a b : α}, D a b < ε → (a, b) ∈ s) :
    U =
        infi
          fun (ε : β) =>
            infi
              fun (H : ε > z) =>
                filter.principal (set_of fun (p : α × α) => D (prod.fst p) (prod.snd p) < ε) :=
  sorry

class has_edist (α : Type u_1) where
  edist : α → α → ennreal

/-- Creating a uniform space from an extended distance. -/
def uniform_space_of_edist {α : Type u} (edist : α → α → ennreal)
    (edist_self : ∀ (x : α), edist x x = 0) (edist_comm : ∀ (x y : α), edist x y = edist y x)
    (edist_triangle : ∀ (x y z : α), edist x z ≤ edist x y + edist y z) : uniform_space α :=
  uniform_space.of_core
    (uniform_space.core.mk
      (infi
        fun (ε : ennreal) =>
          infi
            fun (H : ε > 0) =>
              filter.principal (set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε))
      sorry sorry sorry)

-- the uniform structure is embedded in the emetric space structure

-- to avoid instance diamond issues. See Note [forgetful inheritance].

/-- Extended metric spaces, with an extended distance `edist` possibly taking the
value ∞

Each emetric space induces a canonical `uniform_space` and hence a canonical `topological_space`.
This is enforced in the type class definition, by extending the `uniform_space` structure. When
instantiating an `emetric_space` structure, the uniformity fields are not necessary, they will be
filled in by default. There is a default value for the uniformity, that can be substituted
in cases of interest, for instance when instantiating an `emetric_space` structure
on a product.

Continuity of `edist` is proved in `topology.instances.ennreal`
-/
class emetric_space (α : Type u)
    extends has_edist α,
      emetric_space.to_uniform_space._default #2 #1 #0 α _to_has_edist =
        id (uniform_space_of_edist edist #0 α _to_has_edist),
      uniform_space #2, uniform_space α
    where
  edist_self : ∀ (x : α), edist x x = 0
  eq_of_edist_eq_zero : ∀ {x y : α}, edist x y = 0 → x = y
  edist_comm : ∀ (x y : α), edist x y = edist y x
  edist_triangle : ∀ (x y z : α), edist x z ≤ edist x y + edist y z
  to_uniform_space : uniform_space α
  uniformity_edist :
    autoParam
      (uniformity α =
        infi
          fun (ε : ennreal) =>
            infi
              fun (H : ε > 0) =>
                filter.principal (set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.control_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "control_laws_tac") [])

/- emetric spaces are less common than metric spaces. Therefore, we work in a dedicated
namespace, while notions associated to metric spaces are mostly in the root namespace. -/

protected instance emetric_space.to_uniform_space' {α : Type u} [emetric_space α] :
    uniform_space α :=
  emetric_space.to_uniform_space

/-- Characterize the equality of points by the vanishing of their extended distance -/
@[simp] theorem edist_eq_zero {α : Type u} [emetric_space α] {x : α} {y : α} :
    edist x y = 0 ↔ x = y :=
  { mp := eq_of_edist_eq_zero, mpr := fun (this : x = y) => this ▸ edist_self x }

@[simp] theorem zero_eq_edist {α : Type u} [emetric_space α] {x : α} {y : α} :
    0 = edist x y ↔ x = y :=
  { mp := fun (h : 0 = edist x y) => eq_of_edist_eq_zero (Eq.symm h),
    mpr := fun (this : x = y) => this ▸ Eq.symm (edist_self x) }

theorem edist_le_zero {α : Type u} [emetric_space α] {x : α} {y : α} : edist x y ≤ 0 ↔ x = y :=
  iff.trans nonpos_iff_eq_zero edist_eq_zero

/-- Triangle inequality for the extended distance -/
theorem edist_triangle_left {α : Type u} [emetric_space α] (x : α) (y : α) (z : α) :
    edist x y ≤ edist z x + edist z y :=
  eq.mpr (id (Eq._oldrec (Eq.refl (edist x y ≤ edist z x + edist z y)) (edist_comm z x)))
    (edist_triangle x z y)

theorem edist_triangle_right {α : Type u} [emetric_space α] (x : α) (y : α) (z : α) :
    edist x y ≤ edist x z + edist y z :=
  eq.mpr (id (Eq._oldrec (Eq.refl (edist x y ≤ edist x z + edist y z)) (edist_comm y z)))
    (edist_triangle x z y)

theorem edist_triangle4 {α : Type u} [emetric_space α] (x : α) (y : α) (z : α) (t : α) :
    edist x t ≤ edist x y + edist y z + edist z t :=
  le_trans (edist_triangle x z t) (add_le_add_right (edist_triangle x y z) (edist z t))

/-- The triangle (polygon) inequality for sequences of points; `finset.Ico` version. -/
theorem edist_le_Ico_sum_edist {α : Type u} [emetric_space α] (f : ℕ → α) {m : ℕ} {n : ℕ}
    (h : m ≤ n) :
    edist (f m) (f n) ≤ finset.sum (finset.Ico m n) fun (i : ℕ) => edist (f i) (f (i + 1)) :=
  sorry

/-- The triangle (polygon) inequality for sequences of points; `finset.range` version. -/
theorem edist_le_range_sum_edist {α : Type u} [emetric_space α] (f : ℕ → α) (n : ℕ) :
    edist (f 0) (f n) ≤ finset.sum (finset.range n) fun (i : ℕ) => edist (f i) (f (i + 1)) :=
  finset.Ico.zero_bot n ▸ edist_le_Ico_sum_edist f (nat.zero_le n)

/-- A version of `edist_le_Ico_sum_edist` with each intermediate distance replaced
with an upper estimate. -/
theorem edist_le_Ico_sum_of_edist_le {α : Type u} [emetric_space α] {f : ℕ → α} {m : ℕ} {n : ℕ}
    (hmn : m ≤ n) {d : ℕ → ennreal}
    (hd : ∀ {k : ℕ}, m ≤ k → k < n → edist (f k) (f (k + 1)) ≤ d k) :
    edist (f m) (f n) ≤ finset.sum (finset.Ico m n) fun (i : ℕ) => d i :=
  sorry

/-- A version of `edist_le_range_sum_edist` with each intermediate distance replaced
with an upper estimate. -/
theorem edist_le_range_sum_of_edist_le {α : Type u} [emetric_space α] {f : ℕ → α} (n : ℕ)
    {d : ℕ → ennreal} (hd : ∀ {k : ℕ}, k < n → edist (f k) (f (k + 1)) ≤ d k) :
    edist (f 0) (f n) ≤ finset.sum (finset.range n) fun (i : ℕ) => d i :=
  finset.Ico.zero_bot n ▸
    edist_le_Ico_sum_of_edist_le (zero_le n) fun (_x : ℕ) (_x_1 : 0 ≤ _x) => hd

/-- Two points coincide if their distance is `< ε` for all positive ε -/
theorem eq_of_forall_edist_le {α : Type u} [emetric_space α] {x : α} {y : α}
    (h : ∀ (ε : ennreal), ε > 0 → edist x y ≤ ε) : x = y :=
  eq_of_edist_eq_zero (eq_of_le_of_forall_le_of_dense bot_le h)

/-- Reformulation of the uniform structure in terms of the extended distance -/
theorem uniformity_edist {α : Type u} [emetric_space α] :
    uniformity α =
        infi
          fun (ε : ennreal) =>
            infi
              fun (H : ε > 0) =>
                filter.principal (set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε) :=
  emetric_space.uniformity_edist

theorem uniformity_basis_edist {α : Type u} [emetric_space α] :
    filter.has_basis (uniformity α) (fun (ε : ennreal) => 0 < ε)
        fun (ε : ennreal) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε :=
  sorry

/-- Characterization of the elements of the uniformity in terms of the extended distance -/
theorem mem_uniformity_edist {α : Type u} [emetric_space α] {s : set (α × α)} :
    s ∈ uniformity α ↔ ∃ (ε : ennreal), ∃ (H : ε > 0), ∀ {a b : α}, edist a b < ε → (a, b) ∈ s :=
  filter.has_basis.mem_uniformity_iff uniformity_basis_edist

/-- Given `f : β → ennreal`, if `f` sends `{i | p i}` to a set of positive numbers
accumulating to zero, then `f i`-neighborhoods of the diagonal form a basis of `𝓤 α`.

For specific bases see `uniformity_basis_edist`, `uniformity_basis_edist'`,
`uniformity_basis_edist_nnreal`, and `uniformity_basis_edist_inv_nat`. -/
protected theorem emetric.mk_uniformity_basis {α : Type u} [emetric_space α] {β : Type u_1}
    {p : β → Prop} {f : β → ennreal} (hf₀ : ∀ (x : β), p x → 0 < f x)
    (hf : ∀ (ε : ennreal), 0 < ε → ∃ (x : β), ∃ (hx : p x), f x ≤ ε) :
    filter.has_basis (uniformity α) p
        fun (x : β) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < f x :=
  sorry

/-- Given `f : β → ennreal`, if `f` sends `{i | p i}` to a set of positive numbers
accumulating to zero, then closed `f i`-neighborhoods of the diagonal form a basis of `𝓤 α`.

For specific bases see `uniformity_basis_edist_le` and `uniformity_basis_edist_le'`. -/
protected theorem emetric.mk_uniformity_basis_le {α : Type u} [emetric_space α] {β : Type u_1}
    {p : β → Prop} {f : β → ennreal} (hf₀ : ∀ (x : β), p x → 0 < f x)
    (hf : ∀ (ε : ennreal), 0 < ε → ∃ (x : β), ∃ (hx : p x), f x ≤ ε) :
    filter.has_basis (uniformity α) p
        fun (x : β) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) ≤ f x :=
  sorry

theorem uniformity_basis_edist_le {α : Type u} [emetric_space α] :
    filter.has_basis (uniformity α) (fun (ε : ennreal) => 0 < ε)
        fun (ε : ennreal) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) ≤ ε :=
  emetric.mk_uniformity_basis_le (fun (_x : ennreal) => id)
    fun (ε : ennreal) (ε₀ : 0 < ε) => Exists.intro ε (Exists.intro ε₀ (le_refl ε))

theorem uniformity_basis_edist' {α : Type u} [emetric_space α] (ε' : ennreal) (hε' : 0 < ε') :
    filter.has_basis (uniformity α) (fun (ε : ennreal) => ε ∈ set.Ioo 0 ε')
        fun (ε : ennreal) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε :=
  sorry

theorem uniformity_basis_edist_le' {α : Type u} [emetric_space α] (ε' : ennreal) (hε' : 0 < ε') :
    filter.has_basis (uniformity α) (fun (ε : ennreal) => ε ∈ set.Ioo 0 ε')
        fun (ε : ennreal) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) ≤ ε :=
  sorry

theorem uniformity_basis_edist_nnreal {α : Type u} [emetric_space α] :
    filter.has_basis (uniformity α) (fun (ε : nnreal) => 0 < ε)
        fun (ε : nnreal) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ↑ε :=
  sorry

theorem uniformity_basis_edist_inv_nat {α : Type u} [emetric_space α] :
    filter.has_basis (uniformity α) (fun (_x : ℕ) => True)
        fun (n : ℕ) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < (↑n⁻¹) :=
  sorry

/-- Fixed size neighborhoods of the diagonal belong to the uniform structure -/
theorem edist_mem_uniformity {α : Type u} [emetric_space α] {ε : ennreal} (ε0 : 0 < ε) :
    (set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε) ∈ uniformity α :=
  iff.mpr mem_uniformity_edist (Exists.intro ε (Exists.intro ε0 fun (a b : α) => id))

namespace emetric

theorem uniformity_has_countable_basis {α : Type u} [emetric_space α] :
    filter.is_countably_generated (uniformity α) :=
  filter.is_countably_generated_of_seq
    (Exists.intro
      (fun (i : ℕ) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < (↑i⁻¹))
      (filter.has_basis.eq_infi uniformity_basis_edist_inv_nat))

/-- ε-δ characterization of uniform continuity on a set for emetric spaces -/
theorem uniform_continuous_on_iff {α : Type u} {β : Type v} [emetric_space α] [emetric_space β]
    {f : α → β} {s : set α} :
    uniform_continuous_on f s ↔
        ∀ (ε : ennreal) (H : ε > 0),
          ∃ (δ : ennreal),
            ∃ (H : δ > 0), ∀ {a b : α}, a ∈ s → b ∈ s → edist a b < δ → edist (f a) (f b) < ε :=
  filter.has_basis.uniform_continuous_on_iff uniformity_basis_edist uniformity_basis_edist

/-- ε-δ characterization of uniform continuity on emetric spaces -/
theorem uniform_continuous_iff {α : Type u} {β : Type v} [emetric_space α] [emetric_space β]
    {f : α → β} :
    uniform_continuous f ↔
        ∀ (ε : ennreal) (H : ε > 0),
          ∃ (δ : ennreal), ∃ (H : δ > 0), ∀ {a b : α}, edist a b < δ → edist (f a) (f b) < ε :=
  filter.has_basis.uniform_continuous_iff uniformity_basis_edist uniformity_basis_edist

/-- ε-δ characterization of uniform embeddings on emetric spaces -/
theorem uniform_embedding_iff {α : Type u} {β : Type v} [emetric_space α] [emetric_space β]
    {f : α → β} :
    uniform_embedding f ↔
        function.injective f ∧
          uniform_continuous f ∧
            ∀ (δ : ennreal) (H : δ > 0),
              ∃ (ε : ennreal), ∃ (H : ε > 0), ∀ {a b : α}, edist (f a) (f b) < ε → edist a b < δ :=
  sorry

/-- A map between emetric spaces is a uniform embedding if and only if the edistance between `f x`
and `f y` is controlled in terms of the distance between `x` and `y` and conversely. -/
theorem uniform_embedding_iff' {α : Type u} {β : Type v} [emetric_space α] [emetric_space β]
    {f : α → β} :
    uniform_embedding f ↔
        (∀ (ε : ennreal) (H : ε > 0),
            ∃ (δ : ennreal), ∃ (H : δ > 0), ∀ {a b : α}, edist a b < δ → edist (f a) (f b) < ε) ∧
          ∀ (δ : ennreal) (H : δ > 0),
            ∃ (ε : ennreal), ∃ (H : ε > 0), ∀ {a b : α}, edist (f a) (f b) < ε → edist a b < δ :=
  sorry

/-- ε-δ characterization of Cauchy sequences on emetric spaces -/
protected theorem cauchy_iff {α : Type u} [emetric_space α] {f : filter α} :
    cauchy f ↔
        f ≠ ⊥ ∧
          ∀ (ε : ennreal) (H : ε > 0),
            ∃ (t : set α), ∃ (H : t ∈ f), ∀ (x y : α), x ∈ t → y ∈ t → edist x y < ε :=
  filter.has_basis.cauchy_iff uniformity_basis_edist

/-- A very useful criterion to show that a space is complete is to show that all sequences
which satisfy a bound of the form `edist (u n) (u m) < B N` for all `n m ≥ N` are
converging. This is often applied for `B N = 2^{-N}`, i.e., with a very fast convergence to
`0`, which makes it possible to use arguments of converging series, while this is impossible
to do in general for arbitrary Cauchy sequences. -/
theorem complete_of_convergent_controlled_sequences {α : Type u} [emetric_space α] (B : ℕ → ennreal)
    (hB : ∀ (n : ℕ), 0 < B n)
    (H :
      ∀ (u : ℕ → α),
        (∀ (N n m : ℕ), N ≤ n → N ≤ m → edist (u n) (u m) < B N) →
          ∃ (x : α), filter.tendsto u filter.at_top (nhds x)) :
    complete_space α :=
  uniform_space.complete_of_convergent_controlled_sequences uniformity_has_countable_basis
    (fun (n : ℕ) => set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < B n)
    (fun (n : ℕ) => edist_mem_uniformity (hB n)) H

/-- A sequentially complete emetric space is complete. -/
theorem complete_of_cauchy_seq_tendsto {α : Type u} [emetric_space α] :
    (∀ (u : ℕ → α), cauchy_seq u → ∃ (a : α), filter.tendsto u filter.at_top (nhds a)) →
        complete_space α :=
  uniform_space.complete_of_cauchy_seq_tendsto uniformity_has_countable_basis

/-- Expressing locally uniform convergence on a set using `edist`. -/
theorem tendsto_locally_uniformly_on_iff {α : Type u} {β : Type v} [emetric_space α] {ι : Type u_1}
    [topological_space β] {F : ι → β → α} {f : β → α} {p : filter ι} {s : set β} :
    tendsto_locally_uniformly_on F f p s ↔
        ∀ (ε : ennreal) (H : ε > 0) (x : β) (H : x ∈ s),
          ∃ (t : set β),
            ∃ (H : t ∈ nhds_within x s),
              filter.eventually (fun (n : ι) => ∀ (y : β), y ∈ t → edist (f y) (F n y) < ε) p :=
  sorry

/-- Expressing uniform convergence on a set using `edist`. -/
theorem tendsto_uniformly_on_iff {α : Type u} {β : Type v} [emetric_space α] {ι : Type u_1}
    {F : ι → β → α} {f : β → α} {p : filter ι} {s : set β} :
    tendsto_uniformly_on F f p s ↔
        ∀ (ε : ennreal),
          ε > 0 → filter.eventually (fun (n : ι) => ∀ (x : β), x ∈ s → edist (f x) (F n x) < ε) p :=
  sorry

/-- Expressing locally uniform convergence using `edist`. -/
theorem tendsto_locally_uniformly_iff {α : Type u} {β : Type v} [emetric_space α] {ι : Type u_1}
    [topological_space β] {F : ι → β → α} {f : β → α} {p : filter ι} :
    tendsto_locally_uniformly F f p ↔
        ∀ (ε : ennreal) (H : ε > 0) (x : β),
          ∃ (t : set β),
            ∃ (H : t ∈ nhds x),
              filter.eventually (fun (n : ι) => ∀ (y : β), y ∈ t → edist (f y) (F n y) < ε) p :=
  sorry

/-- Expressing uniform convergence using `edist`. -/
theorem tendsto_uniformly_iff {α : Type u} {β : Type v} [emetric_space α] {ι : Type u_1}
    {F : ι → β → α} {f : β → α} {p : filter ι} :
    tendsto_uniformly F f p ↔
        ∀ (ε : ennreal),
          ε > 0 → filter.eventually (fun (n : ι) => ∀ (x : β), edist (f x) (F n x) < ε) p :=
  sorry

end emetric

/-- An emetric space is separated -/
protected instance to_separated {α : Type u} [emetric_space α] : separated_space α :=
  iff.mpr separated_def
    fun (x y : α) (h : ∀ (r : set (α × α)), r ∈ uniformity α → (x, y) ∈ r) =>
      eq_of_forall_edist_le
        fun (ε : ennreal) (ε0 : ε > 0) =>
          le_of_lt
            (h (set_of fun (p : α × α) => edist (prod.fst p) (prod.snd p) < ε)
              (edist_mem_uniformity ε0))

/-- Auxiliary function to replace the uniformity on an emetric space with
a uniformity which is equal to the original one, but maybe not defeq.
This is useful if one wants to construct an emetric space with a
specified uniformity. See Note [forgetful inheritance] explaining why having definitionally
the right uniformity is often important.
-/
def emetric_space.replace_uniformity {α : Type u_1} [U : uniform_space α] (m : emetric_space α)
    (H : uniformity α = uniformity α) : emetric_space α :=
  emetric_space.mk edist_self eq_of_edist_eq_zero edist_comm edist_triangle U

/-- The extended metric induced by an injective function taking values in an emetric space. -/
def emetric_space.induced {α : Type u_1} {β : Type u_2} (f : α → β) (hf : function.injective f)
    (m : emetric_space β) : emetric_space α :=
  emetric_space.mk sorry sorry sorry sorry (uniform_space.comap f emetric_space.to_uniform_space)

/-- Emetric space instance on subsets of emetric spaces -/
protected instance subtype.emetric_space {α : Type u_1} {p : α → Prop} [t : emetric_space α] :
    emetric_space (Subtype p) :=
  emetric_space.induced coe sorry t

/-- The extended distance on a subset of an emetric space is the restriction of
the original distance, by definition -/
theorem subtype.edist_eq {α : Type u} [emetric_space α] {p : α → Prop} (x : Subtype p)
    (y : Subtype p) : edist x y = edist ↑x ↑y :=
  rfl

/-- The product of two emetric spaces, with the max distance, is an extended
metric spaces. We make sure that the uniform structure thus constructed is the one
corresponding to the product of uniform spaces, to avoid diamond problems. -/
protected instance prod.emetric_space_max {α : Type u} {β : Type v} [emetric_space α]
    [emetric_space β] : emetric_space (α × β) :=
  emetric_space.mk sorry sorry sorry sorry prod.uniform_space

theorem prod.edist_eq {α : Type u} {β : Type v} [emetric_space α] [emetric_space β] (x : α × β)
    (y : α × β) :
    edist x y = max (edist (prod.fst x) (prod.fst y)) (edist (prod.snd x) (prod.snd y)) :=
  rfl

/-- The product of a finite number of emetric spaces, with the max distance, is still
an emetric space.
This construction would also work for infinite products, but it would not give rise
to the product topology. Hence, we only formalize it in the good situation of finitely many
spaces. -/
protected instance emetric_space_pi {β : Type v} {π : β → Type u_1} [fintype β]
    [(b : β) → emetric_space (π b)] : emetric_space ((b : β) → π b) :=
  emetric_space.mk sorry sorry sorry sorry (Pi.uniform_space fun (b : β) => π b)

theorem edist_pi_def {β : Type v} {π : β → Type u_1} [fintype β] [(b : β) → emetric_space (π b)]
    (f : (b : β) → π b) (g : (b : β) → π b) :
    edist f g = finset.sup finset.univ fun (b : β) => edist (f b) (g b) :=
  rfl

@[simp] theorem edist_pi_const {α : Type u} {β : Type v} [emetric_space α] [fintype β] [Nonempty β]
    (a : α) (b : α) : (edist (fun (x : β) => a) fun (_x : β) => b) = edist a b :=
  finset.sup_const finset.univ_nonempty (edist a b)

namespace emetric

/-- `emetric.ball x ε` is the set of all points `y` with `edist y x < ε` -/
def ball {α : Type u} [emetric_space α] (x : α) (ε : ennreal) : set α :=
  set_of fun (y : α) => edist y x < ε

@[simp] theorem mem_ball {α : Type u} [emetric_space α] {x : α} {y : α} {ε : ennreal} :
    y ∈ ball x ε ↔ edist y x < ε :=
  iff.rfl

theorem mem_ball' {α : Type u} [emetric_space α] {x : α} {y : α} {ε : ennreal} :
    y ∈ ball x ε ↔ edist x y < ε :=
  eq.mpr (id (Eq._oldrec (Eq.refl (y ∈ ball x ε ↔ edist x y < ε)) (edist_comm x y)))
    (iff.refl (y ∈ ball x ε))

/-- `emetric.closed_ball x ε` is the set of all points `y` with `edist y x ≤ ε` -/
def closed_ball {α : Type u} [emetric_space α] (x : α) (ε : ennreal) : set α :=
  set_of fun (y : α) => edist y x ≤ ε

@[simp] theorem mem_closed_ball {α : Type u} [emetric_space α] {x : α} {y : α} {ε : ennreal} :
    y ∈ closed_ball x ε ↔ edist y x ≤ ε :=
  iff.rfl

theorem ball_subset_closed_ball {α : Type u} [emetric_space α] {x : α} {ε : ennreal} :
    ball x ε ⊆ closed_ball x ε :=
  fun (y : α) =>
    eq.mpr (id (imp_congr_eq (propext mem_ball) (propext mem_closed_ball)))
      fun (h : edist y x < ε) => le_of_lt h

theorem pos_of_mem_ball {α : Type u} [emetric_space α] {x : α} {y : α} {ε : ennreal}
    (hy : y ∈ ball x ε) : 0 < ε :=
  lt_of_le_of_lt (zero_le (edist y x)) hy

theorem mem_ball_self {α : Type u} [emetric_space α] {x : α} {ε : ennreal} (h : 0 < ε) :
    x ∈ ball x ε :=
  (fun (this : edist x x < ε) => this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (edist x x < ε)) (edist_self x))) h)

theorem mem_closed_ball_self {α : Type u} [emetric_space α] {x : α} {ε : ennreal} :
    x ∈ closed_ball x ε :=
  (fun (this : edist x x ≤ ε) => this)
    (eq.mpr (id (Eq._oldrec (Eq.refl (edist x x ≤ ε)) (edist_self x))) bot_le)

theorem mem_ball_comm {α : Type u} [emetric_space α] {x : α} {y : α} {ε : ennreal} :
    x ∈ ball y ε ↔ y ∈ ball x ε :=
  sorry

theorem ball_subset_ball {α : Type u} [emetric_space α] {x : α} {ε₁ : ennreal} {ε₂ : ennreal}
    (h : ε₁ ≤ ε₂) : ball x ε₁ ⊆ ball x ε₂ :=
  fun (y : α) (yx : edist y x < ε₁) => lt_of_lt_of_le yx h

theorem closed_ball_subset_closed_ball {α : Type u} [emetric_space α] {x : α} {ε₁ : ennreal}
    {ε₂ : ennreal} (h : ε₁ ≤ ε₂) : closed_ball x ε₁ ⊆ closed_ball x ε₂ :=
  fun (y : α) (yx : edist y x ≤ ε₁) => le_trans yx h

theorem ball_disjoint {α : Type u} [emetric_space α] {x : α} {y : α} {ε₁ : ennreal} {ε₂ : ennreal}
    (h : ε₁ + ε₂ ≤ edist x y) : ball x ε₁ ∩ ball y ε₂ = ∅ :=
  sorry

theorem ball_subset {α : Type u} [emetric_space α] {x : α} {y : α} {ε₁ : ennreal} {ε₂ : ennreal}
    (h : edist x y + ε₁ ≤ ε₂) (h' : edist x y < ⊤) : ball x ε₁ ⊆ ball y ε₂ :=
  sorry

theorem exists_ball_subset_ball {α : Type u} [emetric_space α] {x : α} {y : α} {ε : ennreal}
    (h : y ∈ ball x ε) : ∃ (ε' : ennreal), ∃ (H : ε' > 0), ball y ε' ⊆ ball x ε :=
  sorry

theorem ball_eq_empty_iff {α : Type u} [emetric_space α] {x : α} {ε : ennreal} :
    ball x ε = ∅ ↔ ε = 0 :=
  sorry

/-- Relation “two points are at a finite edistance” is an equivalence relation. -/
def edist_lt_top_setoid {α : Type u} [emetric_space α] : setoid α :=
  setoid.mk (fun (x y : α) => edist x y < ⊤) sorry

@[simp] theorem ball_zero {α : Type u} [emetric_space α] {x : α} : ball x 0 = ∅ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (ball x 0 = ∅)) (propext ball_eq_empty_iff))) (Eq.refl 0)

theorem nhds_basis_eball {α : Type u} [emetric_space α] {x : α} :
    filter.has_basis (nhds x) (fun (ε : ennreal) => 0 < ε) (ball x) :=
  nhds_basis_uniformity uniformity_basis_edist

theorem nhds_basis_closed_eball {α : Type u} [emetric_space α] {x : α} :
    filter.has_basis (nhds x) (fun (ε : ennreal) => 0 < ε) (closed_ball x) :=
  nhds_basis_uniformity uniformity_basis_edist_le

theorem nhds_eq {α : Type u} [emetric_space α] {x : α} :
    nhds x = infi fun (ε : ennreal) => infi fun (H : ε > 0) => filter.principal (ball x ε) :=
  filter.has_basis.eq_binfi nhds_basis_eball

theorem mem_nhds_iff {α : Type u} [emetric_space α] {x : α} {s : set α} :
    s ∈ nhds x ↔ ∃ (ε : ennreal), ∃ (H : ε > 0), ball x ε ⊆ s :=
  filter.has_basis.mem_iff nhds_basis_eball

theorem is_open_iff {α : Type u} [emetric_space α] {s : set α} :
    is_open s ↔ ∀ (x : α) (H : x ∈ s), ∃ (ε : ennreal), ∃ (H : ε > 0), ball x ε ⊆ s :=
  sorry

theorem is_open_ball {α : Type u} [emetric_space α] {x : α} {ε : ennreal} : is_open (ball x ε) :=
  iff.mpr is_open_iff fun (y : α) => exists_ball_subset_ball

theorem is_closed_ball_top {α : Type u} [emetric_space α] {x : α} : is_closed (ball x ⊤) := sorry

theorem ball_mem_nhds {α : Type u} [emetric_space α] (x : α) {ε : ennreal} (ε0 : 0 < ε) :
    ball x ε ∈ nhds x :=
  mem_nhds_sets is_open_ball (mem_ball_self ε0)

theorem ball_prod_same {α : Type u} {β : Type v} [emetric_space α] [emetric_space β] (x : α) (y : β)
    (r : ennreal) : set.prod (ball x r) (ball y r) = ball (x, y) r :=
  set.ext fun (z : α × β) => iff.symm max_lt_iff

theorem closed_ball_prod_same {α : Type u} {β : Type v} [emetric_space α] [emetric_space β] (x : α)
    (y : β) (r : ennreal) : set.prod (closed_ball x r) (closed_ball y r) = closed_ball (x, y) r :=
  set.ext fun (z : α × β) => iff.symm max_le_iff

/-- ε-characterization of the closure in emetric spaces -/
theorem mem_closure_iff {α : Type u} [emetric_space α] {x : α} {s : set α} :
    x ∈ closure s ↔ ∀ (ε : ennreal) (H : ε > 0), ∃ (y : α), ∃ (H : y ∈ s), edist x y < ε :=
  sorry

theorem tendsto_nhds {α : Type u} {β : Type v} [emetric_space α] {f : filter β} {u : β → α}
    {a : α} :
    filter.tendsto u f (nhds a) ↔
        ∀ (ε : ennreal), ε > 0 → filter.eventually (fun (x : β) => edist (u x) a < ε) f :=
  filter.has_basis.tendsto_right_iff nhds_basis_eball

theorem tendsto_at_top {α : Type u} {β : Type v} [emetric_space α] [Nonempty β] [semilattice_sup β]
    {u : β → α} {a : α} :
    filter.tendsto u filter.at_top (nhds a) ↔
        ∀ (ε : ennreal), ε > 0 → ∃ (N : β), ∀ (n : β), n ≥ N → edist (u n) a < ε :=
  sorry

/-- In an emetric space, Cauchy sequences are characterized by the fact that, eventually,
the edistance between its elements is arbitrarily small -/
theorem cauchy_seq_iff {α : Type u} {β : Type v} [emetric_space α] [Nonempty β] [semilattice_sup β]
    {u : β → α} :
    cauchy_seq u ↔
        ∀ (ε : ennreal), ε > 0 → ∃ (N : β), ∀ (m n : β), m ≥ N → n ≥ N → edist (u m) (u n) < ε :=
  filter.has_basis.cauchy_seq_iff uniformity_basis_edist

/-- A variation around the emetric characterization of Cauchy sequences -/
theorem cauchy_seq_iff' {α : Type u} {β : Type v} [emetric_space α] [Nonempty β] [semilattice_sup β]
    {u : β → α} :
    cauchy_seq u ↔ ∀ (ε : ennreal), ε > 0 → ∃ (N : β), ∀ (n : β), n ≥ N → edist (u n) (u N) < ε :=
  filter.has_basis.cauchy_seq_iff' uniformity_basis_edist

/-- A variation of the emetric characterization of Cauchy sequences that deals with
`ℝ≥0` upper bounds. -/
theorem cauchy_seq_iff_nnreal {α : Type u} {β : Type v} [emetric_space α] [Nonempty β]
    [semilattice_sup β] {u : β → α} :
    cauchy_seq u ↔ ∀ (ε : nnreal), 0 < ε → ∃ (N : β), ∀ (n : β), N ≤ n → edist (u n) (u N) < ↑ε :=
  filter.has_basis.cauchy_seq_iff' uniformity_basis_edist_nnreal

theorem totally_bounded_iff {α : Type u} [emetric_space α] {s : set α} :
    totally_bounded s ↔
        ∀ (ε : ennreal) (H : ε > 0),
          ∃ (t : set α),
            set.finite t ∧ s ⊆ set.Union fun (y : α) => set.Union fun (H : y ∈ t) => ball y ε :=
  sorry

theorem totally_bounded_iff' {α : Type u} [emetric_space α] {s : set α} :
    totally_bounded s ↔
        ∀ (ε : ennreal) (H : ε > 0),
          ∃ (t : set α),
            ∃ (H : t ⊆ s),
              set.finite t ∧ s ⊆ set.Union fun (y : α) => set.Union fun (H : y ∈ t) => ball y ε :=
  sorry

/-- A compact set in an emetric space is separable, i.e., it is the closure of a countable set -/
theorem countable_closure_of_compact {α : Type u} [emetric_space α] {s : set α}
    (hs : is_compact s) : ∃ (t : set α), ∃ (H : t ⊆ s), set.countable t ∧ s = closure t :=
  sorry

--    assume e, finite_cover_balls_of_compact hs,

protected instance topological_space.first_countable_topology (α : Type u) [emetric_space α] :
    topological_space.first_countable_topology α :=
  uniform_space.first_countable_topology uniformity_has_countable_basis

/-- A separable emetric space is second countable: one obtains a countable basis by taking
the balls centered at points in a dense subset, and with rational radii. We do not register
this as an instance, as there is already an instance going in the other direction
from second countable spaces to separable spaces, and we want to avoid loops. -/
theorem second_countable_of_separable (α : Type u) [emetric_space α]
    [topological_space.separable_space α] : topological_space.second_countable_topology α :=
  uniform_space.second_countable_of_separable uniformity_has_countable_basis

/-- The diameter of a set in an emetric space, named `emetric.diam` -/
def diam {α : Type u} [emetric_space α] (s : set α) : ennreal :=
  supr fun (x : α) => supr fun (H : x ∈ s) => supr fun (y : α) => supr fun (H : y ∈ s) => edist x y

theorem diam_le_iff_forall_edist_le {α : Type u} [emetric_space α] {s : set α} {d : ennreal} :
    diam s ≤ d ↔ ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → edist x y ≤ d :=
  sorry

/-- If two points belong to some set, their edistance is bounded by the diameter of the set -/
theorem edist_le_diam_of_mem {α : Type u} [emetric_space α] {x : α} {y : α} {s : set α} (hx : x ∈ s)
    (hy : y ∈ s) : edist x y ≤ diam s :=
  iff.mp diam_le_iff_forall_edist_le (le_refl (diam s)) x hx y hy

/-- If the distance between any two points in a set is bounded by some constant, this constant
bounds the diameter. -/
theorem diam_le_of_forall_edist_le {α : Type u} [emetric_space α] {s : set α} {d : ennreal}
    (h : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → edist x y ≤ d) : diam s ≤ d :=
  iff.mpr diam_le_iff_forall_edist_le h

/-- The diameter of a subsingleton vanishes. -/
theorem diam_subsingleton {α : Type u} [emetric_space α] {s : set α} (hs : set.subsingleton s) :
    diam s = 0 :=
  iff.mp nonpos_iff_eq_zero
    (diam_le_of_forall_edist_le
      fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ s) =>
        Eq.symm (hs hx hy) ▸ edist_self y ▸ le_refl (edist y y))

/-- The diameter of the empty set vanishes -/
@[simp] theorem diam_empty {α : Type u} [emetric_space α] : diam ∅ = 0 :=
  diam_subsingleton set.subsingleton_empty

/-- The diameter of a singleton vanishes -/
@[simp] theorem diam_singleton {α : Type u} [emetric_space α] {x : α} : diam (singleton x) = 0 :=
  diam_subsingleton set.subsingleton_singleton

theorem diam_eq_zero_iff {α : Type u} [emetric_space α] {s : set α} :
    diam s = 0 ↔ set.subsingleton s :=
  sorry

theorem diam_pos_iff {α : Type u} [emetric_space α] {s : set α} :
    0 < diam s ↔ ∃ (x : α), ∃ (H : x ∈ s), ∃ (y : α), ∃ (H : y ∈ s), x ≠ y :=
  sorry

theorem diam_insert {α : Type u} [emetric_space α] {x : α} {s : set α} :
    diam (insert x s) = max (supr fun (y : α) => supr fun (H : y ∈ s) => edist x y) (diam s) :=
  sorry

theorem diam_pair {α : Type u} [emetric_space α] {x : α} {y : α} :
    diam (insert x (singleton y)) = edist x y :=
  sorry

theorem diam_triple {α : Type u} [emetric_space α] {x : α} {y : α} {z : α} :
    diam (insert x (insert y (singleton z))) = max (max (edist x y) (edist x z)) (edist y z) :=
  sorry

/-- The diameter is monotonous with respect to inclusion -/
theorem diam_mono {α : Type u} [emetric_space α] {s : set α} {t : set α} (h : s ⊆ t) :
    diam s ≤ diam t :=
  diam_le_of_forall_edist_le
    fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ s) => edist_le_diam_of_mem (h hx) (h hy)

/-- The diameter of a union is controlled by the diameter of the sets, and the edistance
between two points in the sets. -/
theorem diam_union {α : Type u} [emetric_space α] {x : α} {y : α} {s : set α} {t : set α}
    (xs : x ∈ s) (yt : y ∈ t) : diam (s ∪ t) ≤ diam s + edist x y + diam t :=
  sorry

theorem diam_union' {α : Type u} [emetric_space α] {s : set α} {t : set α}
    (h : set.nonempty (s ∩ t)) : diam (s ∪ t) ≤ diam s + diam t :=
  sorry

theorem diam_closed_ball {α : Type u} [emetric_space α] {x : α} {r : ennreal} :
    diam (closed_ball x r) ≤ bit0 1 * r :=
  sorry

theorem diam_ball {α : Type u} [emetric_space α] {x : α} {r : ennreal} :
    diam (ball x r) ≤ bit0 1 * r :=
  le_trans (diam_mono ball_subset_closed_ball) diam_closed_ball

end Mathlib


abbrev M := ExceptT String $ StateT Nat Id

/- The following instances are not needed, but they speedup the proof -/
instance : Monad M := inferInstance
instance : LawfulMonad M := inferInstance
instance : MonadStateOf Nat M := inferInstance
instance : Bind M := inferInstance
instance : Pure M := inferInstance

syntax "bigAdd0Seq! " num : term

macro_rules
  | `(bigAdd0Seq! $n) =>
    let n := n.toNat
    if n == 0 then
      `(pure ())
    else
      `(get >>= fun n => set (0 + n) >>= fun _ => bigAdd0Seq! $(Lean.quote (n - 1)))

@[simp] theorem get_set  : (get >>= fun n => set n) = (pure () : M Unit) :=
  rfl

set_option maxRecDepth   1000000
set_option maxHeartbeats 1000000

theorem ex : (bigAdd0Seq! 40 : M Unit) = pure () := by
  simp

-- set_option pp.explicit true
-- set_option pp.notation false
-- #print ex


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import category_theory.category.Cat
import category_theory.groupoid
import category_theory.types

/-!
# Objects of a category up to an isomorphism

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

`is_isomorphic X Y := nonempty (X ≅ Y)` is an equivalence relation on the objects of a category.
The quotient with respect to this relation defines a functor from our category to `Type`.
-/

universes v u

namespace category_theory

section category

variables {C : Type u} [category.{v} C]

/-- An object `X` is isomorphic to an object `Y`, if `X ≅ Y` is not empty. -/
def is_isomorphic : C → C → Prop := λ X Y, nonempty (X ≅ Y)

variable (C)

/-- `is_isomorphic` defines a setoid. -/
def is_isomorphic_setoid : setoid C :=
{ r := is_isomorphic,
  iseqv := ⟨λ X, ⟨iso.refl X⟩, λ X Y ⟨α⟩, ⟨α.symm⟩, λ X Y Z ⟨α⟩ ⟨β⟩, ⟨α.trans β⟩⟩ }

end category

/--
The functor that sends each category to the quotient space of its objects up to an isomorphism.
-/
def isomorphism_classes : Cat.{v u} ⥤ Type u :=
{ obj := λ C, quotient (is_isomorphic_setoid C.α),
  map := λ C D F, quot.map F.obj $ λ X Y ⟨f⟩, ⟨F.map_iso f⟩ }

lemma groupoid.is_isomorphic_iff_nonempty_hom {C : Type u} [groupoid.{v} C] {X Y : C} :
  is_isomorphic X Y ↔ nonempty (X ⟶ Y) :=
(groupoid.iso_equiv_hom X Y).nonempty_congr

-- PROJECT: define `skeletal`, and show every category is equivalent to a skeletal category,
-- using the axiom of choice to pick a representative of every isomorphism class.
end category_theory