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

! This file was ported from Lean 3 source module algebra.homology.image_to_kernel
! leanprover-community/mathlib commit 618ea3d5c99240cd7000d8376924906a148bf9ff
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Subobject.Limits

/-!
# Image-to-kernel comparison maps

Whenever `f : A ⟶ B` and `g : B ⟶ C` satisfy `w : f ≫ g = 0`,
we have `image_le_kernel f g w : image_subobject f ≤ kernel_subobject g`
(assuming the appropriate images and kernels exist).

`image_to_kernel f g w` is the corresponding morphism between objects in `C`.

We define `homology f g w` of such a pair as the cokernel of `image_to_kernel f g w`.
-/

universe v u

open CategoryTheory CategoryTheory.Limits

variable {ι : Type _}

variable {V : Type u} [Category.{v} V] [HasZeroMorphisms V]

open Classical

noncomputable section

section

variable {A B C : V} (f : A ⟶ B) [HasImage f] (g : B ⟶ C) [HasKernel g]

theorem image_le_kernel (w : f ≫ g = 0) : imageSubobject f ≤ kernelSubobject g :=
  imageSubobject_le_mk _ _ (kernel.lift _ _ w) (by simp)
#align image_le_kernel image_le_kernel

/-- The canonical morphism `image_subobject f ⟶ kernel_subobject g` when `f ≫ g = 0`.
-/
def imageToKernel (w : f ≫ g = 0) : (imageSubobject f : V) ⟶ (kernelSubobject g : V) :=
  Subobject.ofLe _ _ (image_le_kernel _ _ w)deriving Mono
#align image_to_kernel imageToKernel

/-- Prefer `image_to_kernel`. -/
@[simp]
theorem subobject_ofLe_as_imageToKernel (w : f ≫ g = 0) (h) :
    Subobject.ofLe (imageSubobject f) (kernelSubobject g) h = imageToKernel f g w :=
  rfl
#align subobject_of_le_as_image_to_kernel subobject_ofLe_as_imageToKernel

@[simp, reassoc.1, elementwise]
theorem imageToKernel_arrow (w : f ≫ g = 0) :
    imageToKernel f g w ≫ (kernelSubobject g).arrow = (imageSubobject f).arrow := by
  simp [imageToKernel]
#align image_to_kernel_arrow imageToKernel_arrow

-- This is less useful as a `simp` lemma than it initially appears,
-- as it "loses" the information the morphism factors through the image.
theorem factorThruImageSubobject_comp_imageToKernel (w : f ≫ g = 0) :
    factorThruImageSubobject f ≫ imageToKernel f g w = factorThruKernelSubobject g f w :=
  by
  ext
  simp
#align factor_thru_image_subobject_comp_image_to_kernel factorThruImageSubobject_comp_imageToKernel

end

section

variable {A B C : V} (f : A ⟶ B) (g : B ⟶ C)

@[simp]
theorem imageToKernel_zero_left [HasKernels V] [HasZeroObject V] {w} :
    imageToKernel (0 : A ⟶ B) g w = 0 := by
  ext
  simp
#align image_to_kernel_zero_left imageToKernel_zero_left

theorem imageToKernel_zero_right [HasImages V] {w} :
    imageToKernel f (0 : B ⟶ C) w =
      (imageSubobject f).arrow ≫ inv (kernelSubobject (0 : B ⟶ C)).arrow :=
  by
  ext
  simp
#align image_to_kernel_zero_right imageToKernel_zero_right

section

variable [HasKernels V] [HasImages V]

theorem imageToKernel_comp_right {D : V} (h : C ⟶ D) (w : f ≫ g = 0) :
    imageToKernel f (g ≫ h) (by simp [reassoc_of w]) =
      imageToKernel f g w ≫ Subobject.ofLe _ _ (kernelSubobject_comp_le g h) :=
  by
  ext
  simp
#align image_to_kernel_comp_right imageToKernel_comp_right

theorem imageToKernel_comp_left {Z : V} (h : Z ⟶ A) (w : f ≫ g = 0) :
    imageToKernel (h ≫ f) g (by simp [w]) =
      Subobject.ofLe _ _ (imageSubobject_comp_le h f) ≫ imageToKernel f g w :=
  by
  ext
  simp
#align image_to_kernel_comp_left imageToKernel_comp_left

@[simp]
theorem imageToKernel_comp_mono {D : V} (h : C ⟶ D) [Mono h] (w) :
    imageToKernel f (g ≫ h) w =
      imageToKernel f g ((cancel_mono h).mp (by simpa using w : (f ≫ g) ≫ h = 0 ≫ h)) ≫
        (Subobject.isoOfEq _ _ (kernelSubobject_comp_mono g h)).inv :=
  by
  ext
  simp
#align image_to_kernel_comp_mono imageToKernel_comp_mono

@[simp]
theorem imageToKernel_epi_comp {Z : V} (h : Z ⟶ A) [Epi h] (w) :
    imageToKernel (h ≫ f) g w =
      Subobject.ofLe _ _ (imageSubobject_comp_le h f) ≫
        imageToKernel f g ((cancel_epi h).mp (by simpa using w : h ≫ f ≫ g = h ≫ 0)) :=
  by
  ext
  simp
#align image_to_kernel_epi_comp imageToKernel_epi_comp

end

@[simp]
theorem imageToKernel_comp_hom_inv_comp [HasEqualizers V] [HasImages V] {Z : V} {i : B ≅ Z} (w) :
    imageToKernel (f ≫ i.Hom) (i.inv ≫ g) w =
      (imageSubobjectCompIso _ _).Hom ≫
        imageToKernel f g (by simpa using w) ≫ (kernelSubobjectIsoComp i.inv g).inv :=
  by
  ext
  simp
#align image_to_kernel_comp_hom_inv_comp imageToKernel_comp_hom_inv_comp

open ZeroObject

/-- `image_to_kernel` for `A --0--> B --g--> C`, where `g` is a mono is itself an epi
(i.e. the sequence is exact at `B`).
-/
instance imageToKernel_epi_of_zero_of_mono [HasKernels V] [HasZeroObject V] [Mono g] :
    Epi (imageToKernel (0 : A ⟶ B) g (by simp)) :=
  epi_of_target_iso_zero _ (kernelSubobjectIso g ≪≫ kernel.ofMono g)
#align image_to_kernel_epi_of_zero_of_mono imageToKernel_epi_of_zero_of_mono

/-- `image_to_kernel` for `A --f--> B --0--> C`, where `g` is an epi is itself an epi
(i.e. the sequence is exact at `B`).
-/
instance imageToKernel_epi_of_epi_of_zero [HasImages V] [Epi f] :
    Epi (imageToKernel f (0 : B ⟶ C) (by simp)) :=
  by
  simp only [imageToKernel_zero_right]
  haveI := epi_image_of_epi f
  rw [← image_subobject_arrow]
  refine' @epi_comp _ _ _ _ _ _ (epi_comp _ _) _ _
#align image_to_kernel_epi_of_epi_of_zero imageToKernel_epi_of_epi_of_zero

end

section

variable {A B C : V} (f : A ⟶ B) [HasImage f] (g : B ⟶ C) [HasKernel g]

/-- The homology of a pair of morphisms `f : A ⟶ B` and `g : B ⟶ C` satisfying `f ≫ g = 0`
is the cokernel of the `image_to_kernel` morphism for `f` and `g`.
-/
def homology {A B C : V} (f : A ⟶ B) [HasImage f] (g : B ⟶ C) [HasKernel g] (w : f ≫ g = 0)
    [HasCokernel (imageToKernel f g w)] : V :=
  cokernel (imageToKernel f g w)
#align homology homology

section

variable (w : f ≫ g = 0) [HasCokernel (imageToKernel f g w)]

/-- The morphism from cycles to homology. -/
def homology.π : (kernelSubobject g : V) ⟶ homology f g w :=
  cokernel.π _
#align homology.π homology.π

@[simp]
theorem homology.condition : imageToKernel f g w ≫ homology.π f g w = 0 :=
  cokernel.condition _
#align homology.condition homology.condition

/-- To construct a map out of homology, it suffices to construct a map out of the cycles
which vanishes on boundaries.
-/
def homology.desc {D : V} (k : (kernelSubobject g : V) ⟶ D) (p : imageToKernel f g w ≫ k = 0) :
    homology f g w ⟶ D :=
  cokernel.desc _ k p
#align homology.desc homology.desc

@[simp, reassoc.1, elementwise]
theorem homology.π_desc {D : V} (k : (kernelSubobject g : V) ⟶ D)
    (p : imageToKernel f g w ≫ k = 0) : homology.π f g w ≫ homology.desc f g w k p = k := by
  simp [homology.π, homology.desc]
#align homology.π_desc homology.π_desc

/-- To check two morphisms out of `homology f g w` are equal, it suffices to check on cycles. -/
@[ext]
theorem homology.ext {D : V} {k k' : homology f g w ⟶ D}
    (p : homology.π f g w ≫ k = homology.π f g w ≫ k') : k = k' :=
  by
  ext
  exact p
#align homology.ext homology.ext

/-- The cokernel of the map `Im f ⟶ Ker 0` is isomorphic to the cokernel of `f.` -/
def homologyOfZeroRight [HasCokernel (imageToKernel f (0 : B ⟶ C) comp_zero)] [HasCokernel f]
    [HasCokernel (image.ι f)] [Epi (factorThruImage f)] :
    homology f (0 : B ⟶ C) comp_zero ≅ cokernel f :=
  (cokernel.mapIso _ _ (imageSubobjectIso _) ((kernelSubobjectIso 0).trans kernelZeroIsoSource)
        (by simp)).trans
    (cokernelImageι _)
#align homology_of_zero_right homologyOfZeroRight

/-- The kernel of the map `Im 0 ⟶ Ker f` is isomorphic to the kernel of `f.` -/
def homologyOfZeroLeft [HasZeroObject V] [HasKernels V] [HasImage (0 : A ⟶ B)]
    [HasCokernel (imageToKernel (0 : A ⟶ B) g zero_comp)] :
    homology (0 : A ⟶ B) g zero_comp ≅ kernel g :=
  ((cokernelIsoOfEq <| imageToKernel_zero_left _).trans cokernelZeroIsoTarget).trans
    (kernelSubobjectIso _)
#align homology_of_zero_left homologyOfZeroLeft

/-- `homology 0 0 _` is just the middle object. -/
@[simps]
def homologyZeroZero [HasZeroObject V] [HasImage (0 : A ⟶ B)]
    [HasCokernel (imageToKernel (0 : A ⟶ B) (0 : B ⟶ C) (by simp))] :
    homology (0 : A ⟶ B) (0 : B ⟶ C) (by simp) ≅ B
    where
  Hom := homology.desc (0 : A ⟶ B) (0 : B ⟶ C) (by simp) (kernelSubobject 0).arrow (by simp)
  inv := inv (kernelSubobject 0).arrow ≫ homology.π _ _ _
#align homology_zero_zero homologyZeroZero

end

section

variable {f g} (w : f ≫ g = 0) {A' B' C' : V} {f' : A' ⟶ B'} [HasImage f'] {g' : B' ⟶ C'}
  [HasKernel g'] (w' : f' ≫ g' = 0) (α : Arrow.mk f ⟶ Arrow.mk f') [HasImageMap α]
  (β : Arrow.mk g ⟶ Arrow.mk g') {A₁ B₁ C₁ : V} {f₁ : A₁ ⟶ B₁} [HasImage f₁] {g₁ : B₁ ⟶ C₁}
  [HasKernel g₁] (w₁ : f₁ ≫ g₁ = 0) {A₂ B₂ C₂ : V} {f₂ : A₂ ⟶ B₂} [HasImage f₂] {g₂ : B₂ ⟶ C₂}
  [HasKernel g₂] (w₂ : f₂ ≫ g₂ = 0) {A₃ B₃ C₃ : V} {f₃ : A₃ ⟶ B₃} [HasImage f₃] {g₃ : B₃ ⟶ C₃}
  [HasKernel g₃] (w₃ : f₃ ≫ g₃ = 0) (α₁ : Arrow.mk f₁ ⟶ Arrow.mk f₂) [HasImageMap α₁]
  (β₁ : Arrow.mk g₁ ⟶ Arrow.mk g₂) (α₂ : Arrow.mk f₂ ⟶ Arrow.mk f₃) [HasImageMap α₂]
  (β₂ : Arrow.mk g₂ ⟶ Arrow.mk g₃)

/-- Given compatible commutative squares between
a pair `f g` and a pair `f' g'` satisfying `f ≫ g = 0` and `f' ≫ g' = 0`,
the `image_to_kernel` morphisms intertwine the induced map on kernels and the induced map on images.
-/
@[reassoc.1]
theorem imageSubobjectMap_comp_imageToKernel (p : α.right = β.left) :
    imageToKernel f g w ≫ kernelSubobjectMap β = imageSubobjectMap α ≫ imageToKernel f' g' w' :=
  by
  ext
  simp [p]
#align image_subobject_map_comp_image_to_kernel imageSubobjectMap_comp_imageToKernel

variable [HasCokernel (imageToKernel f g w)] [HasCokernel (imageToKernel f' g' w')]

variable [HasCokernel (imageToKernel f₁ g₁ w₁)]

variable [HasCokernel (imageToKernel f₂ g₂ w₂)]

variable [HasCokernel (imageToKernel f₃ g₃ w₃)]

/-- Given compatible commutative squares between
a pair `f g` and a pair `f' g'` satisfying `f ≫ g = 0` and `f' ≫ g' = 0`,
we get a morphism on homology.
-/
def homology.map (p : α.right = β.left) : homology f g w ⟶ homology f' g' w' :=
  cokernel.desc _ (kernelSubobjectMap β ≫ cokernel.π _)
    (by
      rw [imageSubobjectMap_comp_imageToKernel_assoc w w' α β p]
      simp only [cokernel.condition, comp_zero])
#align homology.map homology.map

@[simp, reassoc.1, elementwise]
theorem homology.π_map (p : α.right = β.left) :
    homology.π f g w ≫ homology.map w w' α β p = kernelSubobjectMap β ≫ homology.π f' g' w' := by
  simp only [homology.π, homology.map, cokernel.π_desc]
#align homology.π_map homology.π_map

@[simp, reassoc.1, elementwise]
theorem homology.map_desc (p : α.right = β.left) {D : V} (k : (kernelSubobject g' : V) ⟶ D)
    (z : imageToKernel f' g' w' ≫ k = 0) :
    homology.map w w' α β p ≫ homology.desc f' g' w' k z =
      homology.desc f g w (kernelSubobjectMap β ≫ k)
        (by simp only [imageSubobjectMap_comp_imageToKernel_assoc w w' α β p, z, comp_zero]) :=
  by ext <;> simp only [homology.π_desc, homology.π_map_assoc]
#align homology.map_desc homology.map_desc

@[simp]
theorem homology.map_id : homology.map w w (𝟙 _) (𝟙 _) rfl = 𝟙 _ := by
  ext <;> simp only [homology.π_map, kernel_subobject_map_id, category.id_comp, category.comp_id]
#align homology.map_id homology.map_id

/-- Auxiliary lemma for homology computations. -/
theorem homology.comp_right_eq_comp_left {V : Type _} [Category V] {A₁ B₁ C₁ A₂ B₂ C₂ A₃ B₃ C₃ : V}
    {f₁ : A₁ ⟶ B₁} {g₁ : B₁ ⟶ C₁} {f₂ : A₂ ⟶ B₂} {g₂ : B₂ ⟶ C₂} {f₃ : A₃ ⟶ B₃} {g₃ : B₃ ⟶ C₃}
    {α₁ : Arrow.mk f₁ ⟶ Arrow.mk f₂} {β₁ : Arrow.mk g₁ ⟶ Arrow.mk g₂}
    {α₂ : Arrow.mk f₂ ⟶ Arrow.mk f₃} {β₂ : Arrow.mk g₂ ⟶ Arrow.mk g₃} (p₁ : α₁.right = β₁.left)
    (p₂ : α₂.right = β₂.left) : (α₁ ≫ α₂).right = (β₁ ≫ β₂).left := by
  simp only [comma.comp_left, comma.comp_right, p₁, p₂]
#align homology.comp_right_eq_comp_left homology.comp_right_eq_comp_left

@[reassoc.1]
theorem homology.map_comp (p₁ : α₁.right = β₁.left) (p₂ : α₂.right = β₂.left) :
    homology.map w₁ w₂ α₁ β₁ p₁ ≫ homology.map w₂ w₃ α₂ β₂ p₂ =
      homology.map w₁ w₃ (α₁ ≫ α₂) (β₁ ≫ β₂) (homology.comp_right_eq_comp_left p₁ p₂) :=
  by
  ext <;>
    simp only [kernel_subobject_map_comp, homology.π_map_assoc, homology.π_map, category.assoc]
#align homology.map_comp homology.map_comp

/-- An isomorphism between two three-term complexes induces an isomorphism on homology. -/
def homology.mapIso (α : Arrow.mk f₁ ≅ Arrow.mk f₂) (β : Arrow.mk g₁ ≅ Arrow.mk g₂)
    (p : α.Hom.right = β.Hom.left) : homology f₁ g₁ w₁ ≅ homology f₂ g₂ w₂
    where
  Hom := homology.map w₁ w₂ α.Hom β.Hom p
  inv :=
    homology.map w₂ w₁ α.inv β.inv
      (by
        rw [← cancel_mono α.hom.right, ← comma.comp_right, α.inv_hom_id, comma.id_right, p, ←
          comma.comp_left, β.inv_hom_id, comma.id_left]
        rfl)
  hom_inv_id' := by
    rw [homology.map_comp]
    convert homology.map_id _ <;> rw [iso.hom_inv_id]
  inv_hom_id' := by
    rw [homology.map_comp]
    convert homology.map_id _ <;> rw [iso.inv_hom_id]
#align homology.map_iso homology.mapIso

end

end

section

variable {A B C : V} {f : A ⟶ B} {g : B ⟶ C} (w : f ≫ g = 0) {f' : A ⟶ B} {g' : B ⟶ C}
  (w' : f' ≫ g' = 0) [HasKernels V] [HasCokernels V] [HasImages V] [HasImageMaps V]

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Custom tactic to golf and speedup boring proofs in `homology.congr`. -/
private unsafe def aux_tac : tactic Unit :=
  sorry
#align aux_tac aux_tac

/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.601314589.aux_tac -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.601314589.aux_tac -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.601314589.aux_tac -/
/- ./././Mathport/Syntax/Translate/Tactic/Builtin.lean:69:18: unsupported non-interactive tactic _private.601314589.aux_tac -/
/-- `homology f g w ≅ homology f' g' w'` if `f = f'` and `g = g'`.
(Note the objects are not changing here.)
-/
@[simps]
def homology.congr (pf : f = f') (pg : g = g') : homology f g w ≅ homology f' g' w'
    where
  Hom :=
    homology.map w w'
      ⟨𝟙 _, 𝟙 _, by
        run_tac
          aux_tac⟩
      ⟨𝟙 _, 𝟙 _, by
        run_tac
          aux_tac⟩
      rfl
  inv :=
    homology.map w' w
      ⟨𝟙 _, 𝟙 _, by
        run_tac
          aux_tac⟩
      ⟨𝟙 _, 𝟙 _, by
        run_tac
          aux_tac⟩
      rfl
  hom_inv_id' := by
    cases pf; cases pg; rw [homology.map_comp, ← homology.map_id]
    congr 1 <;> exact category.comp_id _
  inv_hom_id' := by
    cases pf; cases pg; rw [homology.map_comp, ← homology.map_id]
    congr 1 <;> exact category.comp_id _
#align homology.congr homology.congr

end

/-!
We provide a variant `image_to_kernel' : image f ⟶ kernel g`,
and use this to give alternative formulas for `homology f g w`.
-/

section imageToKernel'

variable {A B C : V} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) [HasKernels V] [HasImages V]

/-- While `image_to_kernel f g w` provides a morphism
`image_subobject f ⟶ kernel_subobject g`
in terms of the subobject API,
this variant provides a morphism
`image f ⟶ kernel g`,
which is sometimes more convenient.
-/
def imageToKernel' (w : f ≫ g = 0) : image f ⟶ kernel g :=
  kernel.lift g (image.ι f)
    (by
      ext
      simpa using w)
#align image_to_kernel' imageToKernel'

@[simp]
theorem imageSubobjectIso_imageToKernel' (w : f ≫ g = 0) :
    (imageSubobjectIso f).Hom ≫ imageToKernel' f g w =
      imageToKernel f g w ≫ (kernelSubobjectIso g).Hom :=
  by
  ext
  simp [imageToKernel']
#align image_subobject_iso_image_to_kernel' imageSubobjectIso_imageToKernel'

@[simp]
theorem imageToKernel'_kernelSubobjectIso (w : f ≫ g = 0) :
    imageToKernel' f g w ≫ (kernelSubobjectIso g).inv =
      (imageSubobjectIso f).inv ≫ imageToKernel f g w :=
  by
  ext
  simp [imageToKernel']
#align image_to_kernel'_kernel_subobject_iso imageToKernel'_kernelSubobjectIso

variable [HasCokernels V]

/-- `homology f g w` can be computed as the cokernel of `image_to_kernel' f g w`.
-/
def homologyIsoCokernelImageToKernel' (w : f ≫ g = 0) :
    homology f g w ≅ cokernel (imageToKernel' f g w)
    where
  Hom :=
    cokernel.map _ _ (imageSubobjectIso f).Hom (kernelSubobjectIso g).Hom
      (by simp only [imageSubobjectIso_imageToKernel'])
  inv :=
    cokernel.map _ _ (imageSubobjectIso f).inv (kernelSubobjectIso g).inv
      (by simp only [imageToKernel'_kernelSubobjectIso])
  hom_inv_id' := by
    apply coequalizer.hom_ext
    simp only [iso.hom_inv_id_assoc, cokernel.π_desc, cokernel.π_desc_assoc, category.assoc,
      coequalizer_as_cokernel]
    exact (category.comp_id _).symm
  inv_hom_id' := by
    ext1
    simp only [iso.inv_hom_id_assoc, cokernel.π_desc, category.comp_id, cokernel.π_desc_assoc,
      category.assoc]
#align homology_iso_cokernel_image_to_kernel' homologyIsoCokernelImageToKernel'

variable [HasEqualizers V]

/-- `homology f g w` can be computed as the cokernel of `kernel.lift g f w`.
-/
def homologyIsoCokernelLift (w : f ≫ g = 0) : homology f g w ≅ cokernel (kernel.lift g f w) :=
  by
  refine' homologyIsoCokernelImageToKernel' f g w ≪≫ _
  have p : factor_thru_image f ≫ imageToKernel' f g w = kernel.lift g f w :=
    by
    ext
    simp [imageToKernel']
  exact (cokernel_epi_comp _ _).symm ≪≫ cokernel_iso_of_eq p
#align homology_iso_cokernel_lift homologyIsoCokernelLift

end imageToKernel'


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.nilpotent
import algebra.lie.tensor_product
import algebra.lie.character
import algebra.lie.engel
import algebra.lie.cartan_subalgebra
import linear_algebra.eigenspace
import ring_theory.tensor_product

/-!
# Weights and roots of Lie modules and Lie algebras

Just as a key tool when studying the behaviour of a linear operator is to decompose the space on
which it acts into a sum of (generalised) eigenspaces, a key tool when studying a representation `M`
of Lie algebra `L` is to decompose `M` into a sum of simultaneous eigenspaces of `x` as `x` ranges
over `L`. These simultaneous generalised eigenspaces are known as the weight spaces of `M`.

When `L` is nilpotent, it follows from the binomial theorem that weight spaces are Lie submodules.
Even when `L` is not nilpotent, it may be useful to study its representations by restricting them
to a nilpotent subalgebra (e.g., a Cartan subalgebra). In the particular case when we view `L` as a
module over itself via the adjoint action, the weight spaces of `L` restricted to a nilpotent
subalgebra are known as root spaces.

Basic definitions and properties of the above ideas are provided in this file.

## Main definitions

  * `lie_module.weight_space`
  * `lie_module.is_weight`
  * `lie_algebra.root_space`
  * `lie_algebra.is_root`
  * `lie_algebra.root_space_weight_space_product`
  * `lie_algebra.root_space_product`
  * `lie_algebra.zero_root_subalgebra_eq_iff_is_cartan`

## References

* [N. Bourbaki, *Lie Groups and Lie Algebras, Chapters 7--9*](bourbaki1975b)

## Tags

lie character, eigenvalue, eigenspace, weight, weight vector, root, root vector
-/

universes u v w w₁ w₂ w₃

variables {R : Type u} {L : Type v} [comm_ring R] [lie_ring L] [lie_algebra R L]
variables (H : lie_subalgebra R L) [lie_algebra.is_nilpotent R H]
variables (M : Type w) [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]

namespace lie_module

open lie_algebra
open tensor_product
open tensor_product.lie_module

open_locale big_operators
open_locale tensor_product

/-- Given a Lie module `M` over a Lie algebra `L`, the pre-weight space of `M` with respect to a
map `χ : L → R` is the simultaneous generalized eigenspace of the action of all `x : L` on `M`,
with eigenvalues `χ x`.

See also `lie_module.weight_space`. -/
def pre_weight_space (χ : L → R) : submodule R M :=
⨅ (x : L), (to_endomorphism R L M x).maximal_generalized_eigenspace (χ x)

lemma mem_pre_weight_space (χ : L → R) (m : M) :
  m ∈ pre_weight_space M χ ↔ ∀ x, ∃ (k : ℕ), ((to_endomorphism R L M x - (χ x) • 1)^k) m = 0 :=
by simp [pre_weight_space, -linear_map.pow_apply]

variables (R)

lemma exists_pre_weight_space_zero_le_ker_of_is_noetherian [is_noetherian R M] (x : L) :
  ∃ (k : ℕ), pre_weight_space M (0 : L → R) ≤ ((to_endomorphism R L M x)^k).ker :=
begin
  use (to_endomorphism R L M x).maximal_generalized_eigenspace_index 0,
  simp only [← module.End.generalized_eigenspace_zero, pre_weight_space, pi.zero_apply, infi_le,
    ← (to_endomorphism R L M x).maximal_generalized_eigenspace_eq],
end

variables {R} (L)

/-- See also `bourbaki1975b` Chapter VII §1.1, Proposition 2 (ii). -/
protected lemma weight_vector_multiplication (M₁ : Type w₁) (M₂ : Type w₂) (M₃ : Type w₃)
  [add_comm_group M₁] [module R M₁] [lie_ring_module L M₁] [lie_module R L M₁]
  [add_comm_group M₂] [module R M₂] [lie_ring_module L M₂] [lie_module R L M₂]
  [add_comm_group M₃] [module R M₃] [lie_ring_module L M₃] [lie_module R L M₃]
 (g : M₁ ⊗[R] M₂ →ₗ⁅R,L⁆ M₃) (χ₁ χ₂ : L → R) :
  ((g : M₁ ⊗[R] M₂ →ₗ[R] M₃).comp
  (map_incl (pre_weight_space M₁ χ₁) (pre_weight_space M₂ χ₂))).range ≤
    pre_weight_space M₃ (χ₁ + χ₂) :=
begin
  /- Unpack the statement of the goal. -/
  intros m₃,
  simp only [lie_module_hom.coe_to_linear_map, pi.add_apply, function.comp_app,
    mem_pre_weight_space, linear_map.coe_comp, tensor_product.map_incl, exists_imp_distrib,
    linear_map.mem_range],
  rintros t rfl x,

  /- Set up some notation. -/
  let F : module.End R M₃ := (to_endomorphism R L M₃ x) - (χ₁ x + χ₂ x) • 1,
  change ∃ k, (F^k) (g _) = 0,

  /- The goal is linear in `t` so use induction to reduce to the case that `t` is a pure tensor. -/
  apply t.induction_on,
  { use 0, simp only [linear_map.map_zero, lie_module_hom.map_zero], },
  swap,
  { rintros t₁ t₂ ⟨k₁, hk₁⟩ ⟨k₂, hk₂⟩, use max k₁ k₂,
    simp only [lie_module_hom.map_add, linear_map.map_add,
      linear_map.pow_map_zero_of_le (le_max_left k₁ k₂) hk₁,
      linear_map.pow_map_zero_of_le (le_max_right k₁ k₂) hk₂, add_zero], },

  /- Now the main argument: pure tensors. -/
  rintros ⟨m₁, hm₁⟩ ⟨m₂, hm₂⟩,
  change ∃ k, (F^k) ((g : M₁ ⊗[R] M₂ →ₗ[R] M₃) (m₁ ⊗ₜ m₂)) = 0,

  /- Eliminate `g` from the picture. -/
  let f₁ : module.End R (M₁ ⊗[R] M₂) := (to_endomorphism R L M₁ x - (χ₁ x) • 1).rtensor M₂,
  let f₂ : module.End R (M₁ ⊗[R] M₂) := (to_endomorphism R L M₂ x - (χ₂ x) • 1).ltensor M₁,
  have h_comm_square : F ∘ₗ ↑g = (g : M₁ ⊗[R] M₂ →ₗ[R] M₃).comp (f₁ + f₂),
  { ext m₁ m₂, simp only [← g.map_lie x (m₁ ⊗ₜ m₂), add_smul, sub_tmul, tmul_sub, smul_tmul,
      lie_tmul_right, tmul_smul, to_endomorphism_apply_apply, lie_module_hom.map_smul,
      linear_map.one_apply, lie_module_hom.coe_to_linear_map, linear_map.smul_apply,
      function.comp_app, linear_map.coe_comp, linear_map.rtensor_tmul, lie_module_hom.map_add,
      linear_map.add_apply, lie_module_hom.map_sub, linear_map.sub_apply, linear_map.ltensor_tmul,
      algebra_tensor_module.curry_apply, curry_apply, linear_map.to_fun_eq_coe,
      linear_map.coe_restrict_scalars_eq_coe], abel, },
  rsuffices ⟨k, hk⟩ : ∃ k, ((f₁ + f₂)^k) (m₁ ⊗ₜ m₂) = 0,
  { use k,
    rw [← linear_map.comp_apply, linear_map.commute_pow_left_of_commute h_comm_square,
      linear_map.comp_apply, hk, linear_map.map_zero], },

  /- Unpack the information we have about `m₁`, `m₂`. -/
  simp only [mem_pre_weight_space] at hm₁ hm₂,
  obtain ⟨k₁, hk₁⟩ := hm₁ x,
  obtain ⟨k₂, hk₂⟩ := hm₂ x,
  have hf₁ : (f₁^k₁) (m₁ ⊗ₜ m₂) = 0,
  { simp only [hk₁, zero_tmul, linear_map.rtensor_tmul, linear_map.rtensor_pow], },
  have hf₂ : (f₂^k₂) (m₁ ⊗ₜ m₂) = 0,
  { simp only [hk₂, tmul_zero, linear_map.ltensor_tmul, linear_map.ltensor_pow], },

  /- It's now just an application of the binomial theorem. -/
  use k₁ + k₂ - 1,
  have hf_comm : commute f₁ f₂,
  { ext m₁ m₂, simp only [linear_map.mul_apply, linear_map.rtensor_tmul, linear_map.ltensor_tmul,
      algebra_tensor_module.curry_apply, linear_map.to_fun_eq_coe, linear_map.ltensor_tmul,
      curry_apply, linear_map.coe_restrict_scalars_eq_coe], },
  rw hf_comm.add_pow',
  simp only [tensor_product.map_incl, submodule.subtype_apply, finset.sum_apply,
    submodule.coe_mk, linear_map.coe_fn_sum, tensor_product.map_tmul, linear_map.smul_apply],

  /- The required sum is zero because each individual term is zero. -/
  apply finset.sum_eq_zero,
  rintros ⟨i, j⟩ hij,

  /- Eliminate the binomial coefficients from the picture. -/
  suffices : (f₁^i * f₂^j) (m₁ ⊗ₜ m₂) = 0, { rw this, apply smul_zero, },

  /- Finish off with appropriate case analysis. -/
  cases nat.le_or_le_of_add_eq_add_pred (finset.nat.mem_antidiagonal.mp hij) with hi hj,
  { rw [(hf_comm.pow_pow i j).eq, linear_map.mul_apply, linear_map.pow_map_zero_of_le hi hf₁,
    linear_map.map_zero], },
  { rw [linear_map.mul_apply, linear_map.pow_map_zero_of_le hj hf₂, linear_map.map_zero], },
end

variables {L M}

lemma lie_mem_pre_weight_space_of_mem_pre_weight_space {χ₁ χ₂ : L → R} {x : L} {m : M}
  (hx : x ∈ pre_weight_space L χ₁) (hm : m ∈ pre_weight_space M χ₂) :
  ⁅x, m⁆ ∈ pre_weight_space M (χ₁ + χ₂) :=
begin
  apply lie_module.weight_vector_multiplication L L M M (to_module_hom R L M) χ₁ χ₂,
  simp only [lie_module_hom.coe_to_linear_map, function.comp_app, linear_map.coe_comp,
    tensor_product.map_incl, linear_map.mem_range],
  use [⟨x, hx⟩ ⊗ₜ ⟨m, hm⟩],
  simp only [submodule.subtype_apply, to_module_hom_apply, tensor_product.map_tmul],
  refl,
end

variables (M)

/-- If a Lie algebra is nilpotent, then pre-weight spaces are Lie submodules. -/
def weight_space [lie_algebra.is_nilpotent R L] (χ : L → R) : lie_submodule R L M :=
{ lie_mem := λ x m hm,
  begin
    rw ← zero_add χ,
    refine lie_mem_pre_weight_space_of_mem_pre_weight_space _ hm,
    suffices : pre_weight_space L (0 : L → R) = ⊤, { simp only [this, submodule.mem_top], },
    exact lie_algebra.infi_max_gen_zero_eigenspace_eq_top_of_nilpotent R L,
  end,
  .. pre_weight_space M χ }

lemma mem_weight_space [lie_algebra.is_nilpotent R L] (χ : L → R) (m : M) :
  m ∈ weight_space M χ ↔ m ∈ pre_weight_space M χ :=
iff.rfl

/-- See also the more useful form `lie_module.zero_weight_space_eq_top_of_nilpotent`. -/
@[simp] lemma zero_weight_space_eq_top_of_nilpotent'
  [lie_algebra.is_nilpotent R L] [is_nilpotent R L M] :
  weight_space M (0 : L → R) = ⊤ :=
begin
  rw [← lie_submodule.coe_to_submodule_eq_iff, lie_submodule.top_coe_submodule],
  exact infi_max_gen_zero_eigenspace_eq_top_of_nilpotent R L M,
end

lemma coe_weight_space_of_top [lie_algebra.is_nilpotent R L] (χ : L → R) :
  (weight_space M (χ ∘ (⊤ : lie_subalgebra R L).incl) : submodule R M) = weight_space M χ :=
begin
  ext m,
  simp only [weight_space, lie_submodule.coe_to_submodule_mk, lie_subalgebra.coe_bracket_of_module,
    function.comp_app, mem_pre_weight_space],
  split; intros h x,
  { obtain ⟨k, hk⟩ := h ⟨x, set.mem_univ x⟩, use k, exact hk, },
  { obtain ⟨k, hk⟩ := h x, use k, exact hk, },
end

@[simp] lemma zero_weight_space_eq_top_of_nilpotent
  [lie_algebra.is_nilpotent R L] [is_nilpotent R L M] :
  weight_space M (0 : (⊤ : lie_subalgebra R L) → R) = ⊤ :=
begin
  /- We use `coe_weight_space_of_top` as a trick to circumvent the fact that we don't (yet) know
    `is_nilpotent R (⊤ : lie_subalgebra R L) M` is equivalent to `is_nilpotent R L M`. -/
  have h₀ : (0 : L → R) ∘ (⊤ : lie_subalgebra R L).incl = 0, { ext, refl, },
  rw [← lie_submodule.coe_to_submodule_eq_iff, lie_submodule.top_coe_submodule, ← h₀,
    coe_weight_space_of_top, ← infi_max_gen_zero_eigenspace_eq_top_of_nilpotent R L M],
  refl,
end

/-- Given a Lie module `M` of a Lie algebra `L`, a weight of `M` with respect to a nilpotent
subalgebra `H ⊆ L` is a Lie character whose corresponding weight space is non-empty. -/
def is_weight (χ : lie_character R H) : Prop := weight_space M χ ≠ ⊥

/-- For a non-trivial nilpotent Lie module over a nilpotent Lie algebra, the zero character is a
weight with respect to the `⊤` Lie subalgebra. -/
lemma is_weight_zero_of_nilpotent
   [nontrivial M] [lie_algebra.is_nilpotent R L] [is_nilpotent R L M] :
   is_weight (⊤ : lie_subalgebra R L) M 0 :=
by { rw [is_weight, lie_hom.coe_zero, zero_weight_space_eq_top_of_nilpotent], exact top_ne_bot, }

/-- A (nilpotent) Lie algebra acts nilpotently on the zero weight space of a Noetherian Lie
module. -/
lemma is_nilpotent_to_endomorphism_weight_space_zero
  [lie_algebra.is_nilpotent R L] [is_noetherian R M] (x : L) :
  _root_.is_nilpotent $ to_endomorphism R L (weight_space M (0 : L → R)) x :=
begin
  obtain ⟨k, hk⟩ := exists_pre_weight_space_zero_le_ker_of_is_noetherian R M x,
  use k,
  ext ⟨m, hm⟩,
  rw [linear_map.zero_apply, lie_submodule.coe_zero, submodule.coe_eq_zero,
    ← lie_submodule.to_endomorphism_restrict_eq_to_endomorphism, linear_map.pow_restrict,
    ← set_like.coe_eq_coe, linear_map.restrict_apply, submodule.coe_mk, submodule.coe_zero],
  exact hk hm,
end

/-- By Engel's theorem, when the Lie algebra is Noetherian, the zero weight space of a Noetherian
Lie module is nilpotent. -/
instance [lie_algebra.is_nilpotent R L] [is_noetherian R L] [is_noetherian R M] :
  is_nilpotent R L (weight_space M (0 : L → R)) :=
is_nilpotent_iff_forall.mpr $ is_nilpotent_to_endomorphism_weight_space_zero M

end lie_module

namespace lie_algebra

open_locale tensor_product
open tensor_product.lie_module
open lie_module

/-- Given a nilpotent Lie subalgebra `H ⊆ L`, the root space of a map `χ : H → R` is the weight
space of `L` regarded as a module of `H` via the adjoint action. -/
abbreviation root_space (χ : H → R) : lie_submodule R H L := weight_space L χ

@[simp]

/-- A root of a Lie algebra `L` with respect to a nilpotent subalgebra `H ⊆ L` is a weight of `L`,
regarded as a module of `H` via the adjoint action. -/
abbreviation is_root := is_weight H L

@[simp] lemma root_space_comap_eq_weight_space (χ : H → R) :
  (root_space H χ).comap H.incl' = weight_space H χ :=
begin
  ext x,
  let f : H → module.End R L := λ y, to_endomorphism R H L y - (χ y) • 1,
  let g : H → module.End R H := λ y, to_endomorphism R H H y - (χ y) • 1,
  suffices : (∀ (y : H), ∃ (k : ℕ), ((f y)^k).comp (H.incl : H →ₗ[R] L) x = 0) ↔
              ∀ (y : H), ∃ (k : ℕ), (H.incl : H →ₗ[R] L).comp ((g y)^k) x = 0,
  { simp only [lie_hom.coe_to_linear_map, lie_subalgebra.coe_incl, function.comp_app,
      linear_map.coe_comp, submodule.coe_eq_zero] at this,
    simp only [mem_weight_space, mem_pre_weight_space,
      lie_subalgebra.coe_incl', lie_submodule.mem_comap, this], },
  have hfg : ∀ (y : H), (f y).comp (H.incl : H →ₗ[R] L) = (H.incl : H →ₗ[R] L).comp (g y),
  { rintros ⟨y, hy⟩, ext ⟨z, hz⟩,
    simp only [submodule.coe_sub, to_endomorphism_apply_apply, lie_hom.coe_to_linear_map,
      linear_map.one_apply, lie_subalgebra.coe_incl, lie_subalgebra.coe_bracket_of_module,
      lie_subalgebra.coe_bracket, linear_map.smul_apply, function.comp_app,
      submodule.coe_smul_of_tower, linear_map.coe_comp, linear_map.sub_apply], },
  simp_rw [linear_map.commute_pow_left_of_commute (hfg _)],
end

variables {H M}

lemma lie_mem_weight_space_of_mem_weight_space {χ₁ χ₂ : H → R} {x : L} {m : M}
  (hx : x ∈ root_space H χ₁) (hm : m ∈ weight_space M χ₂) : ⁅x, m⁆ ∈ weight_space M (χ₁ + χ₂) :=
begin
  apply lie_module.weight_vector_multiplication
    H L M M ((to_module_hom R L M).restrict_lie H) χ₁ χ₂,
  simp only [lie_module_hom.coe_to_linear_map, function.comp_app, linear_map.coe_comp,
    tensor_product.map_incl, linear_map.mem_range],
  use [⟨x, hx⟩ ⊗ₜ ⟨m, hm⟩],
  simp only [submodule.subtype_apply, to_module_hom_apply, submodule.coe_mk,
    lie_module_hom.coe_restrict_lie, tensor_product.map_tmul],
end

variables (R L H M)

/--
Auxiliary definition for `root_space_weight_space_product`,
which is close to the deterministic timeout limit.
-/
def root_space_weight_space_product_aux {χ₁ χ₂ χ₃ : H → R} (hχ : χ₁ + χ₂ = χ₃) :
  (root_space H χ₁) →ₗ[R] (weight_space M χ₂) →ₗ[R] (weight_space M χ₃) :=
{ to_fun    := λ x,
  { to_fun    :=
      λ m, ⟨⁅(x : L), (m : M)⁆,
            hχ ▸ (lie_mem_weight_space_of_mem_weight_space x.property m.property) ⟩,
    map_add'  := λ m n, by { simp only [lie_submodule.coe_add, lie_add], refl, },
    map_smul' := λ t m, by { conv_lhs { congr, rw [lie_submodule.coe_smul, lie_smul], }, refl, }, },
  map_add'  := λ x y, by ext m; rw [linear_map.add_apply, linear_map.coe_mk, linear_map.coe_mk,
    linear_map.coe_mk, subtype.coe_mk, lie_submodule.coe_add, lie_submodule.coe_add, add_lie,
    subtype.coe_mk, subtype.coe_mk],
  map_smul' := λ t x,
  begin
    simp only [ring_hom.id_apply],
    ext m,
    rw [linear_map.smul_apply, linear_map.coe_mk, linear_map.coe_mk,
      subtype.coe_mk, lie_submodule.coe_smul, smul_lie, lie_submodule.coe_smul, subtype.coe_mk],
  end, }

/-- Given a nilpotent Lie subalgebra `H ⊆ L` together with `χ₁ χ₂ : H → R`, there is a natural
`R`-bilinear product of root vectors and weight vectors, compatible with the actions of `H`. -/
def root_space_weight_space_product (χ₁ χ₂ χ₃ : H → R) (hχ : χ₁ + χ₂ = χ₃) :
  (root_space H χ₁) ⊗[R] (weight_space M χ₂) →ₗ⁅R,H⁆ weight_space M χ₃ :=
lift_lie R H (root_space H χ₁) (weight_space M χ₂) (weight_space M χ₃)
{ to_linear_map := root_space_weight_space_product_aux R L H M hχ,
  map_lie' := λ x y, by ext m; rw [root_space_weight_space_product_aux,
    lie_hom.lie_apply, lie_submodule.coe_sub, linear_map.coe_mk,
    linear_map.coe_mk, subtype.coe_mk, subtype.coe_mk, lie_submodule.coe_bracket,
    lie_submodule.coe_bracket, subtype.coe_mk, lie_subalgebra.coe_bracket_of_module,
    lie_subalgebra.coe_bracket_of_module, lie_submodule.coe_bracket,
    lie_subalgebra.coe_bracket_of_module, lie_lie], }

@[simp] lemma coe_root_space_weight_space_product_tmul
  (χ₁ χ₂ χ₃ : H → R) (hχ : χ₁ + χ₂ = χ₃) (x : root_space H χ₁) (m : weight_space M χ₂) :
  (root_space_weight_space_product R L H M χ₁ χ₂ χ₃ hχ (x ⊗ₜ m) : M) = ⁅(x : L), (m : M)⁆ :=
by simp only [root_space_weight_space_product, root_space_weight_space_product_aux,
  lift_apply, lie_module_hom.coe_to_linear_map,
  coe_lift_lie_eq_lift_coe, submodule.coe_mk, linear_map.coe_mk, lie_module_hom.coe_mk]

/-- Given a nilpotent Lie subalgebra `H ⊆ L` together with `χ₁ χ₂ : H → R`, there is a natural
`R`-bilinear product of root vectors, compatible with the actions of `H`. -/
def root_space_product (χ₁ χ₂ χ₃ : H → R) (hχ : χ₁ + χ₂ = χ₃) :
  (root_space H χ₁) ⊗[R] (root_space H χ₂) →ₗ⁅R,H⁆ root_space H χ₃ :=
root_space_weight_space_product R L H L χ₁ χ₂ χ₃ hχ

@[simp] lemma root_space_product_def :
  root_space_product R L H = root_space_weight_space_product R L H L :=
rfl

lemma root_space_product_tmul
  (χ₁ χ₂ χ₃ : H → R) (hχ : χ₁ + χ₂ = χ₃) (x : root_space H χ₁) (y : root_space H χ₂) :
  (root_space_product R L H χ₁ χ₂ χ₃ hχ (x ⊗ₜ y) : L) = ⁅(x : L), (y : L)⁆ :=
by simp only [root_space_product_def, coe_root_space_weight_space_product_tmul]

/-- Given a nilpotent Lie subalgebra `H ⊆ L`, the root space of the zero map `0 : H → R` is a Lie
subalgebra of `L`. -/
def zero_root_subalgebra : lie_subalgebra R L :=
{ lie_mem' := λ x y hx hy, by
  { let xy : (root_space H 0) ⊗[R] (root_space H 0) := ⟨x, hx⟩ ⊗ₜ ⟨y, hy⟩,
    suffices : (root_space_product R L H 0 0 0 (add_zero 0) xy : L) ∈ root_space H 0,
    { rwa [root_space_product_tmul, subtype.coe_mk, subtype.coe_mk] at this, },
    exact (root_space_product R L H 0 0 0 (add_zero 0) xy).property, },
  .. (root_space H 0 : submodule R L) }

@[simp] lemma coe_zero_root_subalgebra :
  (zero_root_subalgebra R L H : submodule R L) = root_space H 0 :=
rfl

lemma mem_zero_root_subalgebra (x : L) :
  x ∈ zero_root_subalgebra R L H ↔ ∀ (y : H), ∃ (k : ℕ), ((to_endomorphism R H L y)^k) x = 0 :=
by simp only [zero_root_subalgebra, mem_weight_space, mem_pre_weight_space, pi.zero_apply, sub_zero,
  set_like.mem_coe, zero_smul, lie_submodule.mem_coe_submodule, submodule.mem_carrier,
  lie_subalgebra.mem_mk_iff]

lemma to_lie_submodule_le_root_space_zero : H.to_lie_submodule ≤ root_space H 0 :=
begin
  intros x hx,
  simp only [lie_subalgebra.mem_to_lie_submodule] at hx,
  simp only [mem_weight_space, mem_pre_weight_space, pi.zero_apply, sub_zero, zero_smul],
  intros y,
  unfreezingI { obtain ⟨k, hk⟩ := (infer_instance : is_nilpotent R H) },
  use k,
  let f : module.End R H := to_endomorphism R H H y,
  let g : module.End R L := to_endomorphism R H L y,
  have hfg : g.comp (H : submodule R L).subtype = (H : submodule R L).subtype.comp f,
  { ext z, simp only [to_endomorphism_apply_apply, submodule.subtype_apply,
      lie_subalgebra.coe_bracket_of_module, lie_subalgebra.coe_bracket, function.comp_app,
      linear_map.coe_comp], },
  change (g^k).comp (H : submodule R L).subtype ⟨x, hx⟩ = 0,
  rw linear_map.commute_pow_left_of_commute hfg k,
  have h := iterate_to_endomorphism_mem_lower_central_series R H H y ⟨x, hx⟩ k,
  rw [hk, lie_submodule.mem_bot] at h,
  simp only [submodule.subtype_apply, function.comp_app, linear_map.pow_apply, linear_map.coe_comp,
    submodule.coe_eq_zero],
  exact h,
end

lemma le_zero_root_subalgebra : H ≤ zero_root_subalgebra R L H :=
begin
  rw [← lie_subalgebra.coe_submodule_le_coe_submodule, ← H.coe_to_lie_submodule,
    coe_zero_root_subalgebra, lie_submodule.coe_submodule_le_coe_submodule],
  exact to_lie_submodule_le_root_space_zero R L H,
end

@[simp] lemma zero_root_subalgebra_normalizer_eq_self :
  (zero_root_subalgebra R L H).normalizer = zero_root_subalgebra R L H :=
begin
  refine le_antisymm _ (lie_subalgebra.le_normalizer _),
  intros x hx,
  rw lie_subalgebra.mem_normalizer_iff at hx,
  rw mem_zero_root_subalgebra,
  rintros ⟨y, hy⟩,
  specialize hx y (le_zero_root_subalgebra R L H hy),
  rw mem_zero_root_subalgebra at hx,
  obtain ⟨k, hk⟩ := hx ⟨y, hy⟩,
  rw [← lie_skew, linear_map.map_neg, neg_eq_zero] at hk,
  use k + 1,
  rw [linear_map.iterate_succ, linear_map.coe_comp, function.comp_app, to_endomorphism_apply_apply,
    lie_subalgebra.coe_bracket_of_module, submodule.coe_mk, hk],
end

/-- If the zero root subalgebra of a nilpotent Lie subalgebra `H` is just `H` then `H` is a Cartan
subalgebra.

When `L` is Noetherian, it follows from Engel's theorem that the converse holds. See
`lie_algebra.zero_root_subalgebra_eq_iff_is_cartan` -/
lemma is_cartan_of_zero_root_subalgebra_eq (h : zero_root_subalgebra R L H = H) :
  H.is_cartan_subalgebra :=
{ nilpotent        := infer_instance,
  self_normalizing := by { rw ← h, exact zero_root_subalgebra_normalizer_eq_self R L H, } }

@[simp] lemma zero_root_subalgebra_eq_of_is_cartan (H : lie_subalgebra R L)
  [H.is_cartan_subalgebra] [is_noetherian R L] :
  zero_root_subalgebra R L H = H :=
begin
  refine le_antisymm _ (le_zero_root_subalgebra R L H),
  suffices : root_space H 0 ≤ H.to_lie_submodule, { exact λ x hx, this hx, },
  obtain ⟨k, hk⟩ := (root_space H 0).is_nilpotent_iff_exists_self_le_ucs.mp (by apply_instance),
  exact hk.trans (lie_submodule.ucs_le_of_normalizer_eq_self (by simp) k),
end

lemma zero_root_subalgebra_eq_iff_is_cartan [is_noetherian R L] :
  zero_root_subalgebra R L H = H ↔ H.is_cartan_subalgebra :=
⟨is_cartan_of_zero_root_subalgebra_eq R L H, by { introsI, simp, }⟩

end lie_algebra

namespace lie_module

open lie_algebra

variables {R L H}

/-- A priori, weight spaces are Lie submodules over the Lie subalgebra `H` used to define them.
However they are naturally Lie submodules over the (in general larger) Lie subalgebra
`zero_root_subalgebra R L H`. Even though it is often the case that
`zero_root_subalgebra R L H = H`, it is likely to be useful to have the flexibility not to have
to invoke this equality (as well as to work more generally). -/
def weight_space' (χ : H → R) : lie_submodule R (zero_root_subalgebra R L H) M :=
{ lie_mem := λ x m hm, by
  { have hx : (x : L) ∈ root_space H 0,
    { rw [← lie_submodule.mem_coe_submodule, ← coe_zero_root_subalgebra], exact x.property, },
    rw ← zero_add χ,
    exact lie_mem_weight_space_of_mem_weight_space hx hm, },
  .. (weight_space M χ : submodule R M) }

@[simp] lemma coe_weight_space' (χ : H → R) :
  (weight_space' M χ : submodule R M) = weight_space M χ :=
rfl

end lie_module


import Std.Util.ExtendedBinder
import Std.Tactic.GuardExpr
import Mathlib.Tactic.Choose

/-!
# Tests for the `choose` tactic
-/

example {α : Type} (h : ∀ n m : α, ∀ (h : n = m), ∃ i j : α, i ≠ j ∧ h = h) : True := by
  choose! i j _x _y using h
  trivial

example (h : ∀ n m : Nat, ∃ i j, m = n + i ∨ m + j = n) : True := by
  choose i j h using h
  guard_hyp i : Nat → Nat → Nat
  guard_hyp j : Nat → Nat → Nat
  guard_hyp h : ∀ (n m : Nat), m = n + i n m ∨ m + j n m = n
  trivial

example (h : ∀ i : Nat, i < 7 → ∃ j, i < j ∧ j < i+i) : True := by
  choose! f h h' using h
  guard_hyp f : Nat → Nat
  guard_hyp h : ∀ (i : Nat), i < 7 → i < f i
  guard_hyp h' : ∀ (i : Nat), i < 7 → f i < i + i
  trivial

/- choice -/
example (h : ∀ n m : Nat, n < m → ∃ i j, m = n + i ∨ m + j = n) : True := by
  choose i j h using h
  guard_hyp i : ∀ n m : Nat, n < m → Nat
  guard_hyp j : ∀ n m : Nat, n < m → Nat
  guard_hyp h : ∀ (n m : Nat) (h : n < m), m = n + i n m h ∨ m + j n m h = n
  trivial

-- `choose!` eliminates dependencies on props, whenever possible
example (h : ∀ n m : Nat, n < m → ∃ i j, m = n + i ∨ m + j = n) : True := by
  choose! i j h using h
  guard_hyp i : Nat → Nat → Nat
  guard_hyp j : Nat → Nat → Nat
  guard_hyp h : ∀ (n m : Nat), n < m → m = n + i n m ∨ m + j n m = n
  trivial

-- without the `using hyp` syntax, `choose` will intro the hyp first
example : (∀ m : Nat, ∃ i, ∀ n : Nat, ∃ j, m = n + i ∨ m + j = n) → True := by
  choose i j h
  guard_hyp i : Nat → Nat
  guard_hyp j : Nat → Nat → Nat
  guard_hyp h : ∀ (m k : Nat), m = k + i m ∨ m + j m k = k
  trivial

example (h : ∀ _n m : Nat, ∃ i, ∀ n:Nat, ∃ j, m = n + i ∨ m + j = n) : True := by
  choose i j h using h
  guard_hyp i : Nat → Nat → Nat
  guard_hyp j : Nat → Nat → Nat → Nat
  guard_hyp h : ∀ (n m k : Nat), m = k + i n m ∨ m + j n m k = k
  trivial

-- Test `simp only [exists_prop]` gets applied after choosing.
-- Because of this simp, we need a non-rfl goal
example (h : ∀ n, ∃ k ≥ 0, n = k) : ∀ _ : Nat, 1 = 1 := by
  choose u hu using h
  guard_hyp hu : ∀ n, u n ≥ 0 ∧ n = u n
  intro; rfl

-- test choose with conjunction
example (h : ∀ i : Nat, ∃ j, i < j ∧ j < i+i) : True := by
  choose f h h' using h
  guard_hyp f : Nat → Nat
  guard_hyp h : ∀ (i : Nat), i < f i
  guard_hyp h' : ∀ (i : Nat), f i < i + i
  trivial

instance : ∀ [Nonempty α], Nonempty (α × α) := @fun ⟨a⟩ => ⟨(a, a)⟩

-- test choose with nonempty instances
instance : ∀ [Nonempty α] [Nonempty β], Nonempty (α × β)
  | ⟨a⟩, ⟨b⟩ => ⟨(a, b)⟩

example {α : Type u} (p : α → Prop) (h : ∀ i : α, p i → ∃ j : α × α, p j.1) : True := by
  choose! f h using h
  guard_hyp f : α → α × α
  guard_hyp h : ∀ (i : α), p i → p (f i).1
  trivial


import category_theory.limits.shapes.pullbacks

/-!
Thanks to Markus Himmel for suggesting this question.
-/

open category_theory
open category_theory.limits

/-!
Let C be a category, X and Y be objects and f : X ⟶ Y be a morphism. Show that f is an epimorphism
if and only if the diagram

X --f--→ Y
|        |
f        𝟙
|        |
↓        ↓
Y --𝟙--→ Y

is a pushout.
-/

variables {C : Type*} [category C]

def pushout_of_epi {X Y : C} (f : X ⟶ Y) [epi f] :
  is_colimit (pushout_cocone.mk (𝟙 Y) (𝟙 Y) rfl : pushout_cocone f f) :=
-- Hint: you can start a proof with `fapply pushout_cocone.is_colimit.mk`
-- to save a little bit of work over just building a `is_colimit` structure directly.
sorry

theorem epi_of_pushout {X Y : C} (f : X ⟶ Y)
  (is_colim : is_colimit (pushout_cocone.mk (𝟙 Y) (𝟙 Y) rfl : pushout_cocone f f)) : epi f :=
-- Hint: You can use `pushout_cocone.mk` to conveniently construct a cocone over a cospan.
-- Hint: use `is_colim.desc` to construct the map from a colimit cocone to any other cocone.
-- Hint: use `is_colim.fac` to show that this map gives a factorisation of the cocone maps through the colimit cocone.
-- Hint: if `simp` won't correctly simplify `𝟙 X ≫ f`, try `dsimp, simp`.
sorry

/-!
There are some further hints in
`hints/category_theory/exercise6/`
-/


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

/-!
# Quotient category

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

This is analogous to 'the quotient of a group by the normal closure of a subset', rather
than 'the quotient of a group by a normal subgroup'.
-/

universes v v₁ u u₁

namespace category_theory

variables {C : Type u} [category.{v} C]
          (r : Π ⦃a b : C⦄, (a ⟶ b) → (a ⟶ b) → Prop)
include r

/-- A type synonom for `C`, thought of as the objects of the quotient category. -/
structure quotient := (as : C)

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

namespace quotient

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end quotient

end category_theory


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import analysis.normed_space.continuous_affine_map
import analysis.calculus.cont_diff

/-!
# Smooth affine maps

This file contains results about smoothness of affine maps.

## Main definitions:

 * `continuous_affine_map.cont_diff`: a continuous affine map is smooth

-/

namespace continuous_affine_map

variables {𝕜 V W : Type*} [nondiscrete_normed_field 𝕜]
variables [normed_group V] [normed_space 𝕜 V]
variables [normed_group W] [normed_space 𝕜 W]

/-- A continuous affine map between normed vector spaces is smooth. -/
lemma cont_diff {n : with_top ℕ} (f : V →A[𝕜] W) :
  cont_diff 𝕜 n f :=
begin
  rw f.decomp,
  apply f.cont_linear.cont_diff.add,
  simp only,
  exact cont_diff_const,
end

end continuous_affine_map


/-
Copyright (c) 2021 Bryan Gin-ge Chen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bryan Gin-ge Chen, Yury Kudryashov
-/
import algebra.group.hom

/-!
# Extensionality lemmas for monoid and group structures

In this file we prove extensionality lemmas for `monoid` and higher algebraic structures with one
binary operation. Extensionality lemmas for structures that are lower in the hierarchy can be found
in `algebra.group.defs`.

## Implementation details

To get equality of `npow` etc, we define a monoid homomorphism between two monoid structures on the
same type, then apply lemmas like `monoid_hom.map_div`, `monoid_hom.map_pow` etc.

## Tags
monoid, group, extensionality
-/

universe u

@[ext, to_additive]
lemma monoid.ext {M : Type u} ⦃m₁ m₂ : monoid M⦄ (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
begin
  have h₁ : (@monoid.to_mul_one_class _ m₁).one = (@monoid.to_mul_one_class _ m₂).one,
    from congr_arg (@mul_one_class.one M) (mul_one_class.ext h_mul),
  set f : @monoid_hom M M (@monoid.to_mul_one_class _ m₁) (@monoid.to_mul_one_class _ m₂) :=
    { to_fun := id, map_one' := h₁, map_mul' := λ x y, congr_fun (congr_fun h_mul x) y },
  have hpow : m₁.npow = m₂.npow, by { ext n x, exact @monoid_hom.map_pow M M m₁ m₂ f x n },
  unfreezingI { cases m₁, cases m₂ },
  congr; assumption
end

@[to_additive]
lemma comm_monoid.to_monoid_injective {M : Type u} :
  function.injective (@comm_monoid.to_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma comm_monoid.ext {M : Type*} ⦃m₁ m₂ : comm_monoid M⦄ (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
comm_monoid.to_monoid_injective $ monoid.ext h_mul

@[to_additive]
lemma left_cancel_monoid.to_monoid_injective {M : Type u} :
  function.injective (@left_cancel_monoid.to_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma left_cancel_monoid.ext {M : Type u} ⦃m₁ m₂ : left_cancel_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
left_cancel_monoid.to_monoid_injective $ monoid.ext h_mul

@[to_additive]
lemma right_cancel_monoid.to_monoid_injective {M : Type u} :
  function.injective (@right_cancel_monoid.to_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma right_cancel_monoid.ext {M : Type u} ⦃m₁ m₂ : right_cancel_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
right_cancel_monoid.to_monoid_injective $ monoid.ext h_mul

@[to_additive]
lemma cancel_monoid.to_left_cancel_monoid_injective {M : Type u} :
  function.injective (@cancel_monoid.to_left_cancel_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma cancel_monoid.ext {M : Type*} ⦃m₁ m₂ : cancel_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
cancel_monoid.to_left_cancel_monoid_injective $ left_cancel_monoid.ext h_mul

@[to_additive]
lemma cancel_comm_monoid.to_comm_monoid_injective {M : Type u} :
  function.injective (@cancel_comm_monoid.to_comm_monoid M) :=
begin
  rintros ⟨⟩ ⟨⟩ h,
  congr'; injection h,
end

@[ext, to_additive]
lemma cancel_comm_monoid.ext {M : Type*} ⦃m₁ m₂ : cancel_comm_monoid M⦄
  (h_mul : m₁.mul = m₂.mul) : m₁ = m₂ :=
cancel_comm_monoid.to_comm_monoid_injective $ comm_monoid.ext h_mul

@[ext, to_additive]
lemma div_inv_monoid.ext {M : Type*} ⦃m₁ m₂ : div_inv_monoid M⦄ (h_mul : m₁.mul = m₂.mul)
  (h_inv : m₁.inv = m₂.inv) : m₁ = m₂ :=
begin
  have h₁ : (@div_inv_monoid.to_monoid _ m₁).one = (@div_inv_monoid.to_monoid _ m₂).one,
    from congr_arg (@monoid.one M) (monoid.ext h_mul),
  set f : @monoid_hom M M (by letI := m₁; apply_instance) (by letI := m₂; apply_instance) :=
    { to_fun := id, map_one' := h₁, map_mul' := λ x y, congr_fun (congr_fun h_mul x) y },
  have hpow : (@div_inv_monoid.to_monoid _ m₁).npow = (@div_inv_monoid.to_monoid _ m₂).npow :=
    congr_arg (@monoid.npow M) (monoid.ext h_mul),
  have hzpow : m₁.zpow = m₂.zpow,
  { ext m x,
    exact @monoid_hom.map_zpow' M M m₁ m₂ f (congr_fun h_inv) x m },
  have hdiv : m₁.div = m₂.div,
  { ext a b,
    exact @monoid_hom.map_div' M M m₁ m₂ f (congr_fun h_inv) a b },
  unfreezingI { cases m₁, cases m₂ },
  congr, exacts [h_mul, h₁, hpow, h_inv, hdiv, hzpow]
end

@[ext, to_additive]
lemma group.ext {G : Type*} ⦃g₁ g₂ : group G⦄ (h_mul : g₁.mul = g₂.mul) : g₁ = g₂ :=
begin
  set f := @monoid_hom.mk' G G (by letI := g₁; apply_instance) g₂ id
    (λ a b, congr_fun (congr_fun h_mul a) b),
  exact group.to_div_inv_monoid_injective (div_inv_monoid.ext h_mul
    (funext $ @monoid_hom.map_inv G G g₁ g₂ f))
end

@[ext, to_additive]
lemma comm_group.ext {G : Type*} ⦃g₁ g₂ : comm_group G⦄
  (h_mul : g₁.mul = g₂.mul) : g₁ = g₂ :=
comm_group.to_group_injective $ group.ext h_mul


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Sébastien Gouëzel, Patrick Massot
-/
import topology.uniform_space.cauchy
import topology.uniform_space.separation
import topology.dense_embedding

/-!
# Uniform embeddings of uniform spaces.

Extension of uniform continuous functions.
-/

open filter topological_space set classical
open_locale classical uniformity topological_space filter

section
variables {α : Type*} {β : Type*} {γ : Type*}
          [uniform_space α] [uniform_space β] [uniform_space γ]
universe u

/-- A map `f : α → β` between uniform spaces is called *uniform inducing* if the uniformity filter
on `α` is the pullback of the uniformity filter on `β` under `prod.map f f`. If `α` is a separated
space, then this implies that `f` is injective, hence it is a `uniform_embedding`. -/
structure uniform_inducing (f : α → β) : Prop :=
(comap_uniformity : comap (λx:α×α, (f x.1, f x.2)) (𝓤 β) = 𝓤 α)

lemma uniform_inducing.mk' {f : α → β} (h : ∀ s, s ∈ 𝓤 α ↔
    ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s) : uniform_inducing f :=
⟨by simp [eq_comm, filter.ext_iff, subset_def, h]⟩

lemma uniform_inducing.comp {g : β → γ} (hg : uniform_inducing g)
  {f : α → β} (hf : uniform_inducing f) : uniform_inducing (g ∘ f) :=
⟨ by rw [show (λ (x : α × α), ((g ∘ f) x.1, (g ∘ f) x.2)) =
         (λ y : β × β, (g y.1, g y.2)) ∘ (λ x : α × α, (f x.1, f x.2)), by ext ; simp,
        ← filter.comap_comap, hg.1, hf.1]⟩

lemma uniform_inducing.basis_uniformity {f : α → β} (hf : uniform_inducing f)
  {ι : Sort*} {p : ι → Prop} {s : ι → set (β × β)} (H : (𝓤 β).has_basis p s) :
  (𝓤 α).has_basis p (λ i, prod.map f f ⁻¹' s i) :=
hf.1 ▸ H.comap _

/-- A map `f : α → β` between uniform spaces is a *uniform embedding* if it is uniform inducing and
injective. If `α` is a separated space, then the latter assumption follows from the former. -/
structure uniform_embedding (f : α → β) extends uniform_inducing f : Prop :=
(inj : function.injective f)

lemma uniform_embedding_subtype_val {p : α → Prop} :
  uniform_embedding (subtype.val : subtype p → α) :=
{ comap_uniformity := rfl,
  inj := subtype.val_injective }

lemma uniform_embedding_subtype_coe {p : α → Prop} :
  uniform_embedding (coe : subtype p → α) :=
uniform_embedding_subtype_val

lemma uniform_embedding_set_inclusion {s t : set α} (hst : s ⊆ t) :
  uniform_embedding (inclusion hst) :=
{ comap_uniformity :=
    by { erw [uniformity_subtype, uniformity_subtype, comap_comap], congr },
  inj := inclusion_injective hst }

lemma uniform_embedding.comp {g : β → γ} (hg : uniform_embedding g)
  {f : α → β} (hf : uniform_embedding f) : uniform_embedding (g ∘ f) :=
{ inj := hg.inj.comp hf.inj,
  ..hg.to_uniform_inducing.comp hf.to_uniform_inducing }

theorem uniform_embedding_def {f : α → β} :
  uniform_embedding f ↔ function.injective f ∧ ∀ s, s ∈ 𝓤 α ↔
    ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s :=
begin
  split,
  { rintro ⟨⟨h⟩, h'⟩,
    rw [eq_comm, filter.ext_iff] at h,
    simp [*, subset_def] },
  { rintro ⟨h, h'⟩,
    refine uniform_embedding.mk ⟨_⟩ h,
    rw [eq_comm, filter.ext_iff],
    simp [*, subset_def] }
end

theorem uniform_embedding_def' {f : α → β} :
  uniform_embedding f ↔ function.injective f ∧ uniform_continuous f ∧
    ∀ s, s ∈ 𝓤 α →
      ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s :=
by simp only [uniform_embedding_def, uniform_continuous_def]; exact
⟨λ ⟨I, H⟩, ⟨I, λ s su, (H _).2 ⟨s, su, λ x y, id⟩, λ s, (H s).1⟩,
 λ ⟨I, H₁, H₂⟩, ⟨I, λ s, ⟨H₂ s,
   λ ⟨t, tu, h⟩, mem_of_superset (H₁ t tu) (λ ⟨a, b⟩, h a b)⟩⟩⟩

/-- If the domain of a `uniform_inducing` map `f` is a `separated_space`, then `f` is injective,
hence it is a `uniform_embedding`. -/
protected theorem uniform_inducing.uniform_embedding [separated_space α] {f : α → β}
  (hf : uniform_inducing f) :
  uniform_embedding f :=
⟨hf, λ x y h, eq_of_uniformity_basis (hf.basis_uniformity (𝓤 β).basis_sets) $
  λ s hs, mem_preimage.2 $ mem_uniformity_of_eq hs h⟩

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is uniform inducing with respect to the discrete uniformity on `α`:
the preimage of `𝓤 β` under `prod.map f f` is the principal filter generated by the diagonal in
`α × α`. -/
lemma comap_uniformity_of_spaced_out {α} {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  comap (prod.map f f) (𝓤 β) = 𝓟 id_rel :=
begin
  refine le_antisymm _ (@refl_le_uniformity α (uniform_space.comap f ‹_›)),
  calc comap (prod.map f f) (𝓤 β) ≤ comap (prod.map f f) (𝓟 s) : comap_mono (le_principal_iff.2 hs)
  ... = 𝓟 (prod.map f f ⁻¹' s) : comap_principal
  ... ≤ 𝓟 id_rel : principal_mono.2 _,
  rintro ⟨x, y⟩, simpa [not_imp_not] using hf x y
end

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is a uniform embedding with respect to the discrete uniformity on `α`. -/
lemma uniform_embedding_of_spaced_out {α} {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  @uniform_embedding α β ⊥ ‹_› f :=
begin
  letI : uniform_space α := ⊥, haveI : separated_space α := separated_iff_t2.2 infer_instance,
  exact uniform_inducing.uniform_embedding ⟨comap_uniformity_of_spaced_out hs hf⟩
end

lemma uniform_inducing.uniform_continuous {f : α → β}
  (hf : uniform_inducing f) : uniform_continuous f :=
by simp [uniform_continuous, hf.comap_uniformity.symm, tendsto_comap]

lemma uniform_inducing.uniform_continuous_iff {f : α → β} {g : β → γ} (hg : uniform_inducing g) :
  uniform_continuous f ↔ uniform_continuous (g ∘ f) :=
by { dsimp only [uniform_continuous, tendsto],
  rw [← hg.comap_uniformity, ← map_le_iff_le_comap, filter.map_map] }

lemma uniform_inducing.inducing {f : α → β} (h : uniform_inducing f) : inducing f :=
begin
  refine ⟨eq_of_nhds_eq_nhds $ assume a, _ ⟩,
  rw [nhds_induced, nhds_eq_uniformity, nhds_eq_uniformity, ← h.comap_uniformity,
    comap_lift'_eq, comap_lift'_eq2];
    { refl <|> exact monotone_preimage }
end

lemma uniform_inducing.prod {α' : Type*} {β' : Type*} [uniform_space α'] [uniform_space β']
  {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_inducing e₁) (h₂ : uniform_inducing e₂) :
  uniform_inducing (λp:α×β, (e₁ p.1, e₂ p.2)) :=
⟨by simp [(∘), uniformity_prod, h₁.comap_uniformity.symm, h₂.comap_uniformity.symm,
           comap_inf, comap_comap]⟩

lemma uniform_inducing.dense_inducing {f : α → β} (h : uniform_inducing f) (hd : dense_range f) :
  dense_inducing f :=
{ dense   := hd,
  induced := h.inducing.induced }

lemma uniform_embedding.embedding {f : α → β} (h : uniform_embedding f) : embedding f :=
{ induced := h.to_uniform_inducing.inducing.induced,
  inj := h.inj }

lemma uniform_embedding.dense_embedding {f : α → β} (h : uniform_embedding f) (hd : dense_range f) :
  dense_embedding f :=
{ dense   := hd,
  inj     := h.inj,
  induced := h.embedding.induced }

lemma closed_embedding_of_spaced_out {α} [topological_space α] [discrete_topology α]
  [separated_space β] {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  closed_embedding f :=
begin
  unfreezingI { rcases (discrete_topology.eq_bot α) with rfl }, letI : uniform_space α := ⊥,
  exact { closed_range := is_closed_range_of_spaced_out hs hf,
          .. (uniform_embedding_of_spaced_out hs hf).embedding }
end

lemma closure_image_mem_nhds_of_uniform_inducing
  {s : set (α×α)} {e : α → β} (b : β)
  (he₁ : uniform_inducing e) (he₂ : dense_inducing e) (hs : s ∈ 𝓤 α) :
  ∃a, closure (e '' {a' | (a, a') ∈ s}) ∈ 𝓝 b :=
have s ∈ comap (λp:α×α, (e p.1, e p.2)) (𝓤 β),
  from he₁.comap_uniformity.symm ▸ hs,
let ⟨t₁, ht₁u, ht₁⟩ := this in
have ht₁ : ∀p:α×α, (e p.1, e p.2) ∈ t₁ → p ∈ s, from ht₁,
let ⟨t₂, ht₂u, ht₂s, ht₂c⟩ := comp_symm_of_uniformity ht₁u in
let ⟨t, htu, hts, htc⟩ := comp_symm_of_uniformity ht₂u in
have preimage e {b' | (b, b') ∈ t₂} ∈ comap e (𝓝 b),
  from preimage_mem_comap $ mem_nhds_left b ht₂u,
let ⟨a, (ha : (b, e a) ∈ t₂)⟩ := (he₂.comap_nhds_ne_bot _).nonempty_of_mem this in
have ∀b' (s' : set (β × β)), (b, b') ∈ t → s' ∈ 𝓤 β →
  ({y : β | (b', y) ∈ s'} ∩ e '' {a' : α | (a, a') ∈ s}).nonempty,
  from assume b' s' hb' hs',
  have preimage e {b'' | (b', b'') ∈ s' ∩ t} ∈ comap e (𝓝 b'),
    from preimage_mem_comap $ mem_nhds_left b' $ inter_mem hs' htu,
  let ⟨a₂, ha₂s', ha₂t⟩ := (he₂.comap_nhds_ne_bot _).nonempty_of_mem this in
  have (e a, e a₂) ∈ t₁,
    from ht₂c $ prod_mk_mem_comp_rel (ht₂s ha) $ htc $ prod_mk_mem_comp_rel hb' ha₂t,
  have e a₂ ∈ {b'':β | (b', b'') ∈ s'} ∩ e '' {a' | (a, a') ∈ s},
    from ⟨ha₂s', mem_image_of_mem _ $ ht₁ (a, a₂) this⟩,
  ⟨_, this⟩,
have ∀b', (b, b') ∈ t → ne_bot (𝓝 b' ⊓ 𝓟 (e '' {a' | (a, a') ∈ s})),
begin
  intros b' hb',
  rw [nhds_eq_uniformity, lift'_inf_principal_eq, lift'_ne_bot_iff],
  exact assume s, this b' s hb',
  exact monotone_inter monotone_preimage monotone_const
end,
have ∀b', (b, b') ∈ t → b' ∈ closure (e '' {a' | (a, a') ∈ s}),
  from assume b' hb', by rw [closure_eq_cluster_pts]; exact this b' hb',
⟨a, (𝓝 b).sets_of_superset (mem_nhds_left b htu) this⟩

lemma uniform_embedding_subtype_emb (p : α → Prop) {e : α → β} (ue : uniform_embedding e)
  (de : dense_embedding e) : uniform_embedding (dense_embedding.subtype_emb p e) :=
{ comap_uniformity := by simp [comap_comap, (∘), dense_embedding.subtype_emb,
           uniformity_subtype, ue.comap_uniformity.symm],
  inj := (de.subtype p).inj }

lemma uniform_embedding.prod {α' : Type*} {β' : Type*} [uniform_space α'] [uniform_space β']
  {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_embedding e₁) (h₂ : uniform_embedding e₂) :
  uniform_embedding (λp:α×β, (e₁ p.1, e₂ p.2)) :=
{ inj := h₁.inj.prod_map h₂.inj,
  ..h₁.to_uniform_inducing.prod h₂.to_uniform_inducing }

lemma is_complete_of_complete_image {m : α → β} {s : set α} (hm : uniform_inducing m)
  (hs : is_complete (m '' s)) : is_complete s :=
begin
  intros f hf hfs,
  rw le_principal_iff at hfs,
  obtain ⟨_, ⟨x, hx, rfl⟩, hyf⟩ : ∃ y ∈ m '' s, map m f ≤ 𝓝 y,
    from hs (f.map m) (hf.map hm.uniform_continuous)
      (le_principal_iff.2 (image_mem_map hfs)),
  rw [map_le_iff_le_comap, ← nhds_induced, ← hm.inducing.induced] at hyf,
  exact ⟨x, hx, hyf⟩
end

lemma is_complete.complete_space_coe {s : set α} (hs : is_complete s) :
  complete_space s :=
complete_space_iff_is_complete_univ.2 $
  is_complete_of_complete_image uniform_embedding_subtype_coe.to_uniform_inducing $ by simp [hs]

/-- A set is complete iff its image under a uniform inducing map is complete. -/
lemma is_complete_image_iff {m : α → β} {s : set α} (hm : uniform_inducing m) :
  is_complete (m '' s) ↔ is_complete s :=
begin
  refine ⟨is_complete_of_complete_image hm, λ c, _⟩,
  haveI : complete_space s := c.complete_space_coe,
  set m' : s → β := m ∘ coe,
  suffices : is_complete (range m'), by rwa [range_comp, subtype.range_coe] at this,
  have hm' : uniform_inducing m' := hm.comp uniform_embedding_subtype_coe.to_uniform_inducing,
  intros f hf hfm,
  rw filter.le_principal_iff at hfm,
  have cf' : cauchy (comap m' f) :=
    hf.comap' hm'.comap_uniformity.le (ne_bot.comap_of_range_mem hf.1 hfm),
  rcases complete_space.complete cf' with ⟨x, hx⟩,
  rw [hm'.inducing.nhds_eq_comap, comap_le_comap_iff hfm] at hx,
  use [m' x, mem_range_self _, hx]
end

lemma complete_space_iff_is_complete_range {f : α → β} (hf : uniform_inducing f) :
  complete_space α ↔ is_complete (range f) :=
by rw [complete_space_iff_is_complete_univ, ← is_complete_image_iff hf, image_univ]

lemma uniform_inducing.is_complete_range [complete_space α] {f : α → β}
  (hf : uniform_inducing f) :
  is_complete (range f) :=
(complete_space_iff_is_complete_range hf).1 ‹_›

lemma complete_space_congr {e : α ≃ β} (he : uniform_embedding e) :
  complete_space α ↔ complete_space β :=
by rw [complete_space_iff_is_complete_range he.to_uniform_inducing, e.range_eq_univ,
  complete_space_iff_is_complete_univ]

lemma complete_space_coe_iff_is_complete {s : set α} :
  complete_space s ↔ is_complete s :=
(complete_space_iff_is_complete_range uniform_embedding_subtype_coe.to_uniform_inducing).trans $
  by rw [subtype.range_coe]

lemma is_closed.complete_space_coe [complete_space α] {s : set α} (hs : is_closed s) :
  complete_space s :=
hs.is_complete.complete_space_coe

lemma complete_space_extension {m : β → α} (hm : uniform_inducing m) (dense : dense_range m)
  (h : ∀f:filter β, cauchy f → ∃x:α, map m f ≤ 𝓝 x) : complete_space α :=
⟨assume (f : filter α), assume hf : cauchy f,
let
  p : set (α × α) → set α → set α := λs t, {y : α| ∃x:α, x ∈ t ∧ (x, y) ∈ s},
  g := (𝓤 α).lift (λs, f.lift' (p s))
in
have mp₀ : monotone p,
  from assume a b h t s ⟨x, xs, xa⟩, ⟨x, xs, h xa⟩,
have mp₁ : ∀{s}, monotone (p s),
  from assume s a b h x ⟨y, ya, yxs⟩, ⟨y, h ya, yxs⟩,

have f ≤ g, from
  le_infi $ assume s, le_infi $ assume hs, le_infi $ assume t, le_infi $ assume ht,
  le_principal_iff.mpr $
  mem_of_superset ht $ assume x hx, ⟨x, hx, refl_mem_uniformity hs⟩,

have ne_bot g, from hf.left.mono this,

have ne_bot (comap m g), from comap_ne_bot $ assume t ht,
  let ⟨t', ht', ht_mem⟩ := (mem_lift_sets $ monotone_lift' monotone_const mp₀).mp ht in
  let ⟨t'', ht'', ht'_sub⟩ := (mem_lift'_sets mp₁).mp ht_mem in
  let ⟨x, (hx : x ∈ t'')⟩ := hf.left.nonempty_of_mem ht'' in
  have h₀ : ne_bot (𝓝[range m] x),
    from dense.nhds_within_ne_bot x,
  have h₁ : {y | (x, y) ∈ t'} ∈ 𝓝[range m] x,
    from @mem_inf_of_left α (𝓝 x) (𝓟 (range m)) _ $ mem_nhds_left x ht',
  have h₂ : range m ∈ 𝓝[range m] x,
    from @mem_inf_of_right α (𝓝 x) (𝓟 (range m)) _ $ subset.refl _,
  have {y | (x, y) ∈ t'} ∩ range m ∈ 𝓝[range m] x,
    from @inter_mem α (𝓝[range m] x) _ _ h₁ h₂,
  let ⟨y, xyt', b, b_eq⟩ := h₀.nonempty_of_mem this in
  ⟨b, b_eq.symm ▸ ht'_sub ⟨x, hx, xyt'⟩⟩,

have cauchy g, from
  ⟨‹ne_bot g›, assume s hs,
  let
    ⟨s₁, hs₁, (comp_s₁ : comp_rel s₁ s₁ ⊆ s)⟩ := comp_mem_uniformity_sets hs,
    ⟨s₂, hs₂, (comp_s₂ : comp_rel s₂ s₂ ⊆ s₁)⟩ := comp_mem_uniformity_sets hs₁,
    ⟨t, ht, (prod_t : set.prod t t ⊆ s₂)⟩ := mem_prod_same_iff.mp (hf.right hs₂)
  in
  have hg₁ : p (preimage prod.swap s₁) t ∈ g,
    from mem_lift (symm_le_uniformity hs₁) $ @mem_lift' α α f _ t ht,
  have hg₂ : p s₂ t ∈ g,
    from mem_lift hs₂ $ @mem_lift' α α f _ t ht,
  have hg : set.prod (p (preimage prod.swap s₁) t) (p s₂ t) ∈ g ×ᶠ g,
    from @prod_mem_prod α α _ _ g g hg₁ hg₂,
  (g ×ᶠ g).sets_of_superset hg
    (assume ⟨a, b⟩ ⟨⟨c₁, c₁t, hc₁⟩, ⟨c₂, c₂t, hc₂⟩⟩,
      have (c₁, c₂) ∈ set.prod t t, from ⟨c₁t, c₂t⟩,
      comp_s₁ $ prod_mk_mem_comp_rel hc₁ $
      comp_s₂ $ prod_mk_mem_comp_rel (prod_t this) hc₂)⟩,

have cauchy (filter.comap m g),
  from ‹cauchy g›.comap' (le_of_eq hm.comap_uniformity) ‹_›,

let ⟨x, (hx : map m (filter.comap m g) ≤ 𝓝 x)⟩ := h _ this in
have cluster_pt x (map m (filter.comap m g)),
  from (le_nhds_iff_adhp_of_cauchy (this.map hm.uniform_continuous)).mp hx,
have cluster_pt x g,
  from  this.mono map_comap_le,

⟨x, calc f ≤ g : by assumption
  ... ≤ 𝓝 x : le_nhds_of_cauchy_adhp ‹cauchy g› this⟩⟩

lemma totally_bounded_preimage {f : α → β} {s : set β} (hf : uniform_embedding f)
  (hs : totally_bounded s) : totally_bounded (f ⁻¹' s) :=
λ t ht, begin
  rw ← hf.comap_uniformity at ht,
  rcases mem_comap.2 ht with ⟨t', ht', ts⟩,
  rcases totally_bounded_iff_subset.1
    (totally_bounded_subset (image_preimage_subset f s) hs) _ ht' with ⟨c, cs, hfc, hct⟩,
  refine ⟨f ⁻¹' c, hfc.preimage (hf.inj.inj_on _), λ x h, _⟩,
  have := hct (mem_image_of_mem f h), simp at this ⊢,
  rcases this with ⟨z, zc, zt⟩,
  rcases cs zc with ⟨y, yc, rfl⟩,
  exact ⟨y, zc, ts (by exact zt)⟩
end

end

lemma uniform_embedding_comap {α : Type*} {β : Type*} {f : α → β} [u : uniform_space β]
  (hf : function.injective f) : @uniform_embedding α β (uniform_space.comap f u) u f :=
@uniform_embedding.mk _ _ (uniform_space.comap f u) _ _
  (@uniform_inducing.mk _ _ (uniform_space.comap f u) _ _ rfl) hf

section uniform_extension

variables {α : Type*} {β : Type*} {γ : Type*}
          [uniform_space α] [uniform_space β] [uniform_space γ]
          {e : β → α}
          (h_e : uniform_inducing e)
          (h_dense : dense_range e)
          {f : β → γ}
          (h_f : uniform_continuous f)

local notation `ψ` := (h_e.dense_inducing h_dense).extend f

lemma uniformly_extend_exists [complete_space γ] (a : α) :
  ∃c, tendsto f (comap e (𝓝 a)) (𝓝 c) :=
let de := (h_e.dense_inducing h_dense) in
have cauchy (𝓝 a), from cauchy_nhds,
have cauchy (comap e (𝓝 a)), from
  this.comap' (le_of_eq h_e.comap_uniformity) (de.comap_nhds_ne_bot _),
have cauchy (map f (comap e (𝓝 a))), from this.map h_f,
complete_space.complete this

lemma uniform_extend_subtype [complete_space γ]
  {p : α → Prop} {e : α → β} {f : α → γ} {b : β} {s : set α}
  (hf : uniform_continuous (λx:subtype p, f x.val))
  (he : uniform_embedding e) (hd : ∀x:β, x ∈ closure (range e))
  (hb : closure (e '' s) ∈ 𝓝 b) (hs : is_closed s) (hp : ∀x∈s, p x) :
  ∃c, tendsto f (comap e (𝓝 b)) (𝓝 c) :=
have de : dense_embedding e,
  from he.dense_embedding hd,
have de' : dense_embedding (dense_embedding.subtype_emb p e),
  by exact de.subtype p,
have ue' : uniform_embedding (dense_embedding.subtype_emb p e),
  from uniform_embedding_subtype_emb _ he de,
have b ∈ closure (e '' {x | p x}),
  from (closure_mono $ monotone_image $ hp) (mem_of_mem_nhds hb),
let ⟨c, (hc : tendsto (f ∘ subtype.val)
     (comap (dense_embedding.subtype_emb p e) (𝓝 ⟨b, this⟩)) (𝓝 c))⟩ :=
  uniformly_extend_exists ue'.to_uniform_inducing de'.dense hf _ in
begin
  rw [nhds_subtype_eq_comap] at hc,
  simp [comap_comap] at hc,
  change (tendsto (f ∘ @subtype.val α p) (comap (e ∘ @subtype.val α p) (𝓝 b)) (𝓝 c)) at hc,
  rw [←comap_comap, tendsto_comap'_iff] at hc,
  exact ⟨c, hc⟩,
  exact ⟨_, hb, assume x,
    begin
      change e x ∈ (closure (e '' s)) → x ∈ range subtype.val,
      rw [← closure_induced, mem_closure_iff_cluster_pt, cluster_pt, ne_bot_iff,
          nhds_induced, ← de.to_dense_inducing.nhds_eq_comap,
          ← mem_closure_iff_nhds_ne_bot, hs.closure_eq],
      exact assume hxs, ⟨⟨x, hp x hxs⟩, rfl⟩,
    end⟩
end

include h_f

lemma uniformly_extend_spec [complete_space γ] (a : α) :
  tendsto f (comap e (𝓝 a)) (𝓝 (ψ a)) :=
by simpa only [dense_inducing.extend] using tendsto_nhds_lim (uniformly_extend_exists h_e ‹_› h_f _)

lemma uniform_continuous_uniformly_extend [cγ : complete_space γ] : uniform_continuous ψ :=
assume d hd,
let ⟨s, hs, hs_comp⟩ := (mem_lift'_sets $
  monotone_comp_rel monotone_id $ monotone_comp_rel monotone_id monotone_id).mp
    (comp_le_uniformity3 hd) in
have h_pnt : ∀{a m}, m ∈ 𝓝 a → ∃c, c ∈ f '' preimage e m ∧ (c, ψ a) ∈ s ∧ (ψ a, c) ∈ s,
  from assume a m hm,
  have nb : ne_bot (map f (comap e (𝓝 a))),
    from ((h_e.dense_inducing h_dense).comap_nhds_ne_bot _).map _,
  have (f '' preimage e m) ∩ ({c | (c, ψ a) ∈ s } ∩ {c | (ψ a, c) ∈ s }) ∈ map f (comap e (𝓝 a)),
    from inter_mem (image_mem_map $ preimage_mem_comap $ hm)
      (uniformly_extend_spec h_e h_dense h_f _
        (inter_mem (mem_nhds_right _ hs) (mem_nhds_left _ hs))),
  nb.nonempty_of_mem this,
have preimage (λp:β×β, (f p.1, f p.2)) s ∈ 𝓤 β,
  from h_f hs,
have preimage (λp:β×β, (f p.1, f p.2)) s ∈ comap (λx:β×β, (e x.1, e x.2)) (𝓤 α),
  by rwa [h_e.comap_uniformity.symm] at this,
let ⟨t, ht, ts⟩ := this in
show preimage (λp:(α×α), (ψ p.1, ψ p.2)) d ∈ 𝓤 α,
  from (𝓤 α).sets_of_superset (interior_mem_uniformity ht) $
  assume ⟨x₁, x₂⟩ hx_t,
  have 𝓝 (x₁, x₂) ≤ 𝓟 (interior t),
    from is_open_iff_nhds.mp is_open_interior (x₁, x₂) hx_t,
  have interior t ∈ 𝓝 x₁ ×ᶠ 𝓝 x₂,
    by rwa [nhds_prod_eq, le_principal_iff] at this,
  let ⟨m₁, hm₁, m₂, hm₂, (hm : set.prod m₁ m₂ ⊆ interior t)⟩ := mem_prod_iff.mp this in
  let ⟨a, ha₁, _, ha₂⟩ := h_pnt hm₁ in
  let ⟨b, hb₁, hb₂, _⟩ := h_pnt hm₂ in
  have set.prod (preimage e m₁) (preimage e m₂) ⊆ preimage (λp:(β×β), (f p.1, f p.2)) s,
    from calc _ ⊆ preimage (λp:(β×β), (e p.1, e p.2)) (interior t) : preimage_mono hm
    ... ⊆ preimage (λp:(β×β), (e p.1, e p.2)) t : preimage_mono interior_subset
    ... ⊆ preimage (λp:(β×β), (f p.1, f p.2)) s : ts,
  have set.prod (f '' preimage e m₁) (f '' preimage e m₂) ⊆ s,
    from calc set.prod (f '' preimage e m₁) (f '' preimage e m₂) =
      (λp:(β×β), (f p.1, f p.2)) '' (set.prod (preimage e m₁) (preimage e m₂)) : prod_image_image_eq
    ... ⊆ (λp:(β×β), (f p.1, f p.2)) '' preimage (λp:(β×β), (f p.1, f p.2)) s : monotone_image this
    ... ⊆ s : image_subset_iff.mpr $ subset.refl _,
  have (a, b) ∈ s, from @this (a, b) ⟨ha₁, hb₁⟩,
  hs_comp $ show (ψ x₁, ψ x₂) ∈ comp_rel s (comp_rel s s),
    from ⟨a, ha₂, ⟨b, this, hb₂⟩⟩

omit h_f

variables [separated_space γ]

lemma uniformly_extend_of_ind (b : β) : ψ (e b) = f b :=
dense_inducing.extend_eq_at _ h_f.continuous.continuous_at

lemma uniformly_extend_unique {g : α → γ} (hg : ∀ b, g (e b) = f b)
  (hc : continuous g) :
  ψ = g :=
dense_inducing.extend_unique _ hg hc

end uniform_extension


import category_theory.basic
import category_theory.instances
import category_theory.universal_properties.colimit
import misc.graph
import misc.matrix

universes v u vᵢ uᵢ

open classical

namespace category

def is_product {C : Type u} [category.{v} C] {I : Type uᵢ} (f : I → C) :
  (Σ p : C, Π i : I, Mor p (f i)) → Prop
| ⟨p,j⟩ := ∀ pair : (Σ p : C, Π i : I, Mor p (f i)), ∃! φ : Mor pair.1 p, ∀ i : I, pair.2 i = (j i) ∘ₘ φ

-- the following makes is_product a little easier to work with.

theorem is_product_fn {C : Type u} [category.{v} C] {I : Type uᵢ} {f : I → C}
  {prod :Σ p : C, Π i : I, Mor p (f i)} : is_product f prod →
  ∀ pair : (Σ p : C, Π i : I, Mor p (f i)), ∃! φ : Mor pair.1 prod.1,
  ∀ i : I, pair.2 i = (prod.2 i) ∘ₘ φ :=
begin
  intro hprod,
  have hrw : prod = ⟨prod.1,prod.2⟩,
    apply sigma.eq,
    refl,
    refl,
  rw hrw at hprod,
  exact hprod,
end

theorem pi_type_product {I : Type u} {β : I → Type u}
  : is_product β ⟨Π i, β i, λ i f, f i⟩ :=
begin
  intro pair,
  cases pair with p' j',
  dsimp,
  existsi  λ x : p', λ i : I, j' i x,
  dsimp,
  split,
  intro i,
  refl,
  intros ψ hψ,
  apply funext,
  intro a,
  apply funext,
  intro i,
  rw hψ,
  rw set_comp_app,
end

theorem product_essentially_unquie {C : Type u} [category.{v} C] {I : Type uᵢ} {f : I → C}
  {p₁ p₂ :(Σ p : C, Π i : I, Mor p (f i))} : is_product f p₁ → is_product f p₂
  → ∃! φ : Mor p₁.1 p₂.1, isomorphism φ ∧ (∀ i : I, p₁.2 i = (p₂.2 i) ∘ₘ φ ):=
begin
  intros hp₁ hp₂,
  cases p₁ with p₁ j₁,
  cases p₂ with p₂ j₂,
  cases hp₂ ⟨p₁,j₁⟩ with φ₁ hφ₁,
  cases hp₁ ⟨p₂,j₂⟩ with φ₂ hφ₂,
  cases hp₁ ⟨p₁, λ i, (j₂ i) ∘ₘ φ₁⟩ with id₁ hid₁,
  cases hp₂ ⟨p₂, λ i, (j₁ i) ∘ₘ φ₂⟩ with id₂ hid₂,
  dsimp at hφ₁,
  dsimp at hφ₂,
  dsimp at hid₁,
  dsimp at hid₂,
  cases hφ₁ with hφ₁ uφ₁,
  cases hφ₂ with hφ₂ uφ₂,
  cases hid₁ with hid₁ uid₁,
  cases hid₂ with hid₂ uid₂,
  have hrw₁ : idₘ p₁ = id₁,
    apply uid₁,
    simp [id_comp_right,← hφ₁],
  have hrw₂ : idₘ p₂ = id₂,
    apply uid₂,
    simp [id_comp_right,← hφ₂],
  existsi φ₁,
  dsimp,
  split,
  split,
  existsi φ₂,
  rw [hrw₁,hrw₂],
  split,
  apply uid₂,
  simp [comp_assoc,hφ₁],
  apply uid₁,
  simp [comp_assoc,hφ₂],
  exact hφ₁,
  intros φ hφ,
  apply uφ₁,
  exact hφ.2,
end

noncomputable def prod_can_iso {C : Type u} [category.{v} C] {I : Type uᵢ} {f : I → C}
  {p₁ p₂ :(Σ p : C, Π i : I, Mor p (f i))} : is_product f p₁ → is_product f p₂
  → Mor p₁.1 p₂.1 := λ hp₁ hp₂, some (product_essentially_unquie hp₁ hp₂)

theorem prod_can_iso_property {C : Type u} [category.{v} C] {I : Type uᵢ} {f : I → C}
  {p₁ p₂ : (Σ p : C, Π i : I, Mor p (f i))} : Π (hp₁ : is_product f p₁) (hp₂ : is_product f p₂),
  (isomorphism (prod_can_iso hp₁ hp₂) ∧ ( Π i : I, p₁.2 i = p₂.2 i ∘ₘ (prod_can_iso hp₁ hp₂)))
  ∧ (∀ φ : Mor p₁.1 p₂.1, ((isomorphism φ ∧ ( Π i : I, p₁.2 i = p₂.2 i ∘ₘ φ))
  → φ = prod_can_iso hp₁ hp₂)) := λ hp₁ hp₂, some_spec (product_essentially_unquie hp₁ hp₂)

class has_products (C : Type u) [category.{v} C] :=
(all_products_exist : ∀ {I : Type uᵢ} (f : I → C) , ∃ p : (Σ p : C, Π i : I, Mor p (f i)),
  is_product f p)

noncomputable def product {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I : Type uᵢ}
  (f : I → C) : (Σ p : C, Π i : I, Mor p (f i)) := some (has_products.all_products_exist f)

prefix `Π₀`:110 := product

theorem has_product_prod_is_prod {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I : Type uᵢ}
  (f : I → C) : is_product f (Π₀ f) := some_spec (has_products.all_products_exist f)

noncomputable def into_product {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I : Type uᵢ}
  {f : I → C} {A : C} (g : Π i : I, Mor A (f i))
  : Mor A (Π₀ f).1 := some (is_product_fn (has_product_prod_is_prod f) ⟨A,g⟩)

theorem into_product_property {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I : Type uᵢ}
  {f : I → C} {A : C} (g : Π i : I, Mor A (f i)) : (∀ i : I, g i = ((Π₀f).2 i) ∘ₘ (into_product g)) ∧
  ∀ φ : Mor A (Π₀f).1, (∀ i, g i = ((Π₀f).2 i) ∘ₘ φ) → φ = into_product g
  := some_spec (is_product_fn (has_product_prod_is_prod f) ⟨A,g⟩)

theorem into_product_property_comp {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I : Type uᵢ}
  {f : I → C} {A : C} (g : Π i : I, Mor A (f i)) : ∀ i : I, g i = ((Π₀f).2 i) ∘ₘ (into_product g)
  := (into_product_property g).1

theorem into_product_property_up {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C]
  {I : Type uᵢ} {f : I → C} {A : C} (g : Π i : I, Mor A (f i))
  : ∀ φ : Mor A (Π₀f).1, (∀ i, g i = ((Π₀f).2 i) ∘ₘ φ) → φ = into_product g
  := (into_product_property g).2

theorem double_prod_prod_left {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I J : Type uᵢ}
  (f : I → J → C) : is_product (function.uncurry f) ⟨(Π₀ (λ i : I,(Π₀ (λ j : J,f i j)).1)).1,
  λ ij : I × J, (Π₀ (λ k : J, f ij.1 k)).2 ij.2 ∘ₘ (Π₀ (λ i : I,(Π₀ (λ j : J,f i j)).1)).2 ij.1⟩ :=
begin
  simp[is_product],
  intro,
  cases pair with p g,
  let φ : Mor p (Π₀ (λ i : I,(Π₀ (λ j : J,f i j)).1)).1,
    apply into_product,
    intro i,
    apply into_product,
    intro j,
    exact g (i,j),
  existsi φ,
  simp[φ],
  split,
  intro ij,
  cases ij with i j,
  rw ← comp_assoc,
  simp[← into_product_property_comp],
  intros ψ hψ,
  apply into_product_property_up,
  intro i,
  symmetry,
  apply into_product_property_up,
  intro j,
  rw hψ (i,j),
  rw comp_assoc,
end

theorem double_prod_prod_right {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I J : Type uᵢ}
  (f : I → J → C) : is_product (function.uncurry f) ⟨(Π₀ (λ j : J ,(Π₀ (λ i : I,f i j)).1)).1,
  λ ij : I × J, (Π₀ (λ k : I, f k ij.2)).2 ij.1 ∘ₘ (Π₀ (λ j : J ,(Π₀ (λ i : I,f i j)).1)).2 ij.2⟩ :=
begin
  simp[is_product],
  intro,
  cases pair with p g,
  let φ : Mor p (Π₀ (λ j : J,(Π₀ (λ i : I,f i j)).1)).1,
    apply into_product,
    intro j,
    apply into_product,
    intro i,
    exact g (i,j),
  existsi φ,
  simp[φ],
  split,
  intro ij,
  cases ij with i j,
  rw ← comp_assoc,
  simp[← into_product_property_comp],
  intros ψ hψ,
  apply into_product_property_up,
  intro j,
  symmetry,
  apply into_product_property_up,
  intro i,
  rw hψ (i,j),
  rw comp_assoc,
end

theorem product_of_morphisms_exist {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C] {I : Type uᵢ}
  {f₁ f₂ : I → C} (φ : Π i : I, Mor (f₁ i) (f₂ i)) : ∃! ψ : Mor (Π₀ f₁).1 (Π₀ f₂).1, ∀ i : I,
  (Π₀ f₂).2 i ∘ₘ ψ = φ i ∘ₘ (Π₀ f₁).2 i :=
begin
  let ψ : Mor (Π₀ f₁).1 (Π₀ f₂).1,
    apply into_product,
    intro i,
    exact φ i ∘ₘ (Π₀ f₁).2 i,
  existsi ψ,
  simp[ψ],
  split,
  simp[← into_product_property_comp],
  intros ϕ hϕ,
  apply into_product_property_up,
  simp [hϕ],
end

noncomputable def product_of_morphisms {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C]
  {I : Type uᵢ} {f₁ f₂ : I → C} (φ : Π i : I, Mor (f₁ i) (f₂ i)) : Mor (Π₀f₁).1 (Π₀f₂).1 :=
  some (product_of_morphisms_exist φ)

prefix `Πₘ`:110 := product_of_morphisms

theorem product_of_morphisms_property {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C]
  {I : Type uᵢ} {f₁ f₂ : I → C} (φ : Π i : I, Mor (f₁ i) (f₂ i))
  : (∀ i : I, (Π₀ f₂).2 i ∘ₘ Πₘ φ = φ i ∘ₘ (Π₀ f₁).2 i) ∧ (∀ ψ : Mor (Π₀f₁).1 (Π₀f₂).1,
  (∀ i : I, (Π₀ f₂).2 i ∘ₘ ψ  = φ i ∘ₘ (Π₀ f₁).2 i) → ψ = Πₘ φ)
  := some_spec (product_of_morphisms_exist φ)

theorem product_of_morphisms_property_comp {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C]
  {I : Type uᵢ} {f₁ f₂ : I → C} (φ : Π i : I, Mor (f₁ i) (f₂ i))
  : ∀ i : I, (Π₀ f₂).2 i ∘ₘ Πₘ φ = φ i ∘ₘ (Π₀ f₁).2 i := (product_of_morphisms_property φ).1

theorem product_of_morphisms_property_up {C : Type u} [category.{v} C] [has_products.{v u uᵢ} C]
  {I : Type uᵢ} {f₁ f₂ : I → C} (φ : Π i : I, Mor (f₁ i) (f₂ i))
  : ∀ ψ : Mor (Π₀f₁).1 (Π₀f₂).1, (∀ i : I, (Π₀ f₂).2 i ∘ₘ ψ  = φ i ∘ₘ (Π₀ f₁).2 i)
  → ψ = Πₘ φ := (product_of_morphisms_property φ).2

def is_equaliser {C : Type u} [category.{v} C] {A B : C} (f₁ f₂ : Mor A B) : (Σ E, Mor E A) → Prop
| ⟨E,f⟩ := f₁ ∘ₘ f = f₂ ∘ₘ f ∧ ∀ p : (Σ E, Mor E A), f₁ ∘ₘ p.2 = f₂ ∘ₘ p.2
  → ∃! φ : Mor p.1 E, p.2 = f ∘ₘ φ

end category


import NBG.SetTheory.Defs
import NBG.SetTheory.Axioms.Domain

open Classical

-- 8. AxiomMembership
axiom AxiomMembership :
  ∃E: Class, ∀z: Class,
    (z ∈ E ↔ ∃x y: Class, ∃_: Set x, ∃_: Set y,
      ∃_:x ∈ y,
        z ＝ ＜x, y＞)

-- class E
noncomputable def E: Class := choose AxiomMembership
noncomputable def E_def:
  ∀z: Class,
    (z ∈ E ↔ ∃x y: Class, ∃_: Set x, ∃_: Set y,
      ∃_:x ∈ y,
        z ＝ ＜x, y＞) :=
  choose_spec AxiomMembership

theorem EIsRelation:
  isRelation E := by {
  intro z h;
  have ⟨x,y,hx,hy,_,heq⟩ := (E_def z).1 h;
  exact ⟨x,y,hx,hy,heq⟩;
}

theorem DomEEqUniv : (Dom E) ＝ U := by {
  rw [AxiomExtensionality];
  intro z;
  rw [Dom_def];
  apply Iff.intro;
  {
    intro h;
    let h1 := choose_spec h;
    let h2 := choose_spec h1;
    let h3 := choose_spec h2;
    let h4 := choose_spec h3;
    let x := choose h;
    have set_x: Set x := choose h2;
    have heq: z ＝ x := choose_spec h4;
    exact ClassEqMenberImpMenber heq set_x.2;
  }
  {
    intro h;
    have set_z := Set.mk₂ h;
    let y := Singleton_mk z;
    have hy :=Singleton_def z;
    have set_y := Set.mk₂ hy.1;
    have z_in_y : z ∈ y := (hy.2 z).2 (ClassEq.refl _);
    have hin := (E_def ＜z,y＞).2 ⟨z,y,set_z,set_y,z_in_y,ClassEq.refl _⟩
    exists z,y,set_z,set_y,hin;
    exact ClassEq.refl _;
  }
}

-- Image type
theorem ImageClassExists (R X: Class.{u}) [hR: Relation R]:
  ∃Im: Class.{u}, ∀z: Class,
    ((z ∈ Im)
      ↔ (∃x y: Class, ∃_: Set y, ∃(hx:x ∈ X), ∃(_:(@OrdPair_mk x y (Set.mk₁ hx) _)∈ R),
        z ＝ y)) := by {
  have : Relation (R ∩ (X ✕ U)) :=
    ⟨fun z h => (hR.1 z) ((IntersectionClass_def R (X ✕ U) z).1 h).1⟩;
  let im := Rng (R ∩ (X ✕ U));
  let im_def := Rng_def (R ∩ (X ✕ U));
  have inter_def := IntersectionClass_def R (X ✕ U);
  have rel_def := hR.1;
  have prod_def := ProductClass_def X U;
  exists im;
  intro z;
  apply Iff.intro;
  {
    intro h;
    have ⟨x,y,set_x,set_y,hin,heq⟩ := (im_def z).1 h;
    have h1 := (inter_def ＜x, y＞).1 hin;
    have ⟨x2,y2,set_x2,set_y2,heq2⟩ := (rel_def ＜x, y＞) h1.1;
    have ⟨x3,y3,hx3,hy3,heq3⟩ := (prod_def ＜x, y＞).1 h1.2;
    have set_x3 := Set.mk₁ hx3;
    have set_y3 := Set.mk₁ hy3;
    rw [OrdPairEq] at heq2;
    rw [OrdPairEq] at heq3;
    exists x,y,set_y,ClassEqMenberImpMenber heq3.1 hx3;
    exists ClassEqMenberImpMenber (OrdPairEq.2 ⟨ClassEq.refl _,ClassEq.refl _⟩) h1.1;
  }
  {
    intro ⟨x,y,set_y,x_in_X,xy_in_R,heq⟩;
    have set_x := Set.mk₁ x_in_X;
    apply (im_def z).2;
    clear im_def;
    exists x,y,set_x,set_y;
    have h2 := (prod_def ＜x,y＞).2 ⟨x,y,x_in_X,set_y.2,(OrdPairEq.2 ⟨ClassEq.refl _,ClassEq.refl _⟩)⟩;
    have h3 := (inter_def ＜x,y＞).2 ⟨xy_in_R,h2⟩;
    exists h3;
  }
}
noncomputable def Im (R X: Class) [Relation R]: Class :=
  choose (ImageClassExists R X)
noncomputable def ImageClass_def (R X: Class.{u}) [Relation R]:
  ∀z: Class,
      ((z ∈ (Im R X))
        ↔ (∃x y: Class, ∃_: Set y, ∃(hx:x ∈ X), ∃(_:(@OrdPair_mk x y (Set.mk₁ hx) _)∈ R),
          z ＝ y)) :=
  choose_spec (ImageClassExists R X)

theorem PreImageClassExists (R X: Class) [Relation R]:
  ∃PreIm: Class, ∀z: Class,
    ((z ∈ PreIm)
      ↔ (∃x y: Class, ∃_: Set y, ∃(hx:x ∈ X), ∃(_:(@OrdPair_mk x y (Set.mk₁ hx) _) ∈ (RelInv R)),
        z ＝ y)) :=
  @ImageClassExists (RelInv R) X ⟨RelInvRelationIsRelation⟩

noncomputable def Apply (F x: Class) {h: x ∈ (Dom F)} : Class :=
  choose (choose_spec ((Dom_def F x).1 h))
noncomputable def Apply_def (F x: Class) {h: x ∈ (Dom F)} :=
  choose_spec ((Dom_def F x).1 h)
noncomputable def TargetIsSet (F x: Class) {h: x ∈ (Dom F)} : Set (@Apply F x h) :=
  choose (choose_spec (choose_spec (choose_spec ((Dom_def F x).1 h))))
noncomputable def SourceTargetPairIsIn (F x: Class) {h: x ∈ (Dom F)} :
  (@OrdPair_mk x (@Apply F x h) (Set.mk₁ h) (TargetIsSet F x)) ∈ F := by {
  have h1 := choose_spec ((Dom_def F x).1 h);
  have h2 := choose_spec h1;
  have h3 := choose_spec h2;
  have h4 := choose_spec h3;
  let u := choose ((Dom_def F x).1 h);
  let v := choose h1;
  have set_u : Set u := choose h2;
  have set_v : Set v := choose h3;
  have hin : ＜u,v＞ ∈ F := choose h4;
  have heq_x : x ＝ u := choose_spec h4;
  let y := @Apply F x h;
  have heq_y: y ＝ v := ClassEq.refl _;
  have set_x := Set.mk₁ h;
  have set_y := @TargetIsSet F x h;
  apply ClassEqMenberImpMenber _ hin;
  exact (@OrdPairEq x y u v set_x set_y set_u set_v).2 ⟨heq_x,heq_y⟩;
}
theorem ApplyFunctionUniqueTarget (F x x': Class) [set_x:Set x] [set_x':Set x']
    {hx: x ∈ (Dom F)} {hx': x' ∈ (Dom F)} [hF: Function F]:
      x ＝ x' →  @Apply F x hx ＝ @Apply F x' hx' := by {
  let y := @Apply F x hx;
  let y' := @Apply F x' hx';
  have set_y: Set y := @TargetIsSet F x hx;
  have set_y': Set y' := @TargetIsSet F x' hx';
  have F_def: ＜x, y＞ ∈ F → ＜x', y'＞ ∈ F
    → x ＝ x' → y ＝ y' :=
    hF.2 x x' y y' set_x set_x' set_y set_y';
  have hxy: ＜x, y＞ ∈ F := @SourceTargetPairIsIn F x hx;
  have hxy': ＜x', y'＞ ∈ F := @SourceTargetPairIsIn F x' hx';
  exact fun h => F_def hxy hxy' h;
}

-- define useful notation
noncomputable def as_map (F x: Class) [Relation F] {h: x ∈ Dom F}: Class := by
exact (@Apply F x h)
notation F"【"x"】" => as_map F x

/-- The brige theorem of image and function, namely f[ X ] = {f(x)}. -/
theorem SingleSetFunctionImageIsSingleton (F x: Class) [hx: Set x] {h: x ∈ (Dom F)} [hF: Function F]:
  Im F x ＝ @Singleton_mk (@as_map F x hF.1 h) (TargetIsSet F x) := by {
  sorry;
}

-- injective, surjective, bijective

-- Todo

-- restriction
noncomputable def Restriction (F X: Class) := F ∩ (X ✕ U)
infix:50 " ↾ "  => Restriction

-- UnionAll
noncomputable def UnionAll_mk' (X : Class) :=
  Dom (E ∩ (U ✕ X))
noncomputable instance : HasUnionAll Class where
  UnionAll := UnionAll_mk'

-- InterAll
noncomputable def InterAll_mk' (X : Class) :=
  Diff U (Dom ((Diff U₂ E) ∩ (U ✕ X)))
noncomputable instance : HasInterAll Class where
  InterAll := InterAll_mk'

-- PowerClass
noncomputable def PowerClass_mk' (X : Class) : Class :=
  Diff U (Dom ((RelInv E) ∩ (U ✕ (Diff U X))))

theorem PowerClassExists (X : Class):
  ∃PX: Class,
    ∀z: Class, ∀_: Set z,
      z ∈ PX ↔ (z ⊂ X) := by {
  let px := Diff U (Dom ((RelInv E) ∩ (U ✕ (Diff U X))));
  have px_def := Diff_def U (Dom ((RelInv E) ∩ (U ✕ (Diff U X))));
  have dom_def := Dom_def ((RelInv E) ∩ (U ✕ (Diff U X)));
  have inter_def := IntersectionClass_def (RelInv E) (U ✕ (Diff U X));
  have rel_inv_def := RelInv_def E;
  have prod_def := ProductClass_def U (Diff U X);
  have diff_def := Diff_def U X;
  have E_def := E_def;
  exists px;
  intro z set_z;
  apply Iff.intro;
  {
    intro h u hu;
    have set_u :=  (Set.mk₁ hu);
    have h1 := ((px_def z).1 h);
    have h2 := (
      ImpIffNotImpNot.1 (
        NotExistsImpForall (
          NotExistsImpForall (
            NotExistsImpForall (
              NotExistsImpForall (
                NotExistsImpForall (
                  (IffIffNotIffNot.1 (dom_def z)).2 h1.2) z) u) set_z) set_u)) (IffNotNot.1 ((ClassEq.refl _))));
    have h3 := NotAndIffNotOrNot.1 ((IffIffNotIffNot.1 (inter_def ＜z,u＞)).2 h2);
    cases h3;
    case mp.inl h3 => {
      have h4 := ImpIffNotImpNot.1 (
        ExistsIffNotForall.1 (
          ExistsIffNotForall.1 (
            ExistsIffNotForall.1 (
              ExistsIffNotForall.1 (
                ExistsIffNotForall.1 (
                  (IffIffNotIffNot.1 (rel_inv_def ＜z,u＞)).2 h3) u) z) set_u) set_z)) (IffNotNot.symm.2 (ClassEq.refl _));
      have := (E_def ＜u,z＞).2;
      have h5 := (
        ExistsIffNotForall.1 (
          ExistsIffNotForall.1 (
            ExistsIffNotForall.1 (
              ExistsIffNotForall.1 (
                ExistsIffNotForall.1 (
                  (IffIffNotIffNot.1 (E_def ＜u,z＞)).2 h4) u) z) set_u) set_z) hu);
      exact False.elim (h5 (ClassEq.refl _));
    }
    case mp.inr h3 => {
      have h4 := (@ImpIffNotImpNot (u ∈ Diff U X) (¬＜z,u＞ ＝ ＜z,u＞)).1 (
        ExistsIffNotForall.1 (
          ExistsIffNotForall.1 (
            ExistsIffNotForall.1 (
              ExistsIffNotForall.1 (
                (IffIffNotIffNot.1 (prod_def ＜z,u＞)).2 h3) z) u) set_z.2)) (IffNotNot.symm.2 (ClassEq.refl _));
      have h5 := NotAndIffNotOrNot.1 ((IffIffNotIffNot.1 (diff_def u)).2 h4);
      cases h5;
      case inl h5 => {exact False.elim (h5 set_u.2);}
      case inr h5 => {exact IffNotNot.2 h5;}
    }
  }
  {
    intro h;
    apply (px_def z).2;
    apply And.intro;
    {exact set_z.2;}
    {
      intro hn;

      -- have := (dom_def z).1 hn;
      have ⟨z1,u,set_z1,set_u,hin1,heq1⟩ := (dom_def z).1 hn;
      have h1 := (inter_def ＜z1,u＞).1 hin1;
      have ⟨u2,z2,set_u2,set_z2,hin2,heq2⟩ := (rel_inv_def ＜z1,u＞).1 h1.1;
      have ⟨u3,z3,hu3,hz3,hin3,heq3⟩ := (E_def ＜u2,z2＞).1 hin2;

      have ⟨z4,u4,hz4,hu4,heq4⟩ := (prod_def ＜z1,u＞).1 h1.2;
      have h3 := (diff_def u4).1 hu4;
      rw [OrdPairEq] at heq2;
      rw [OrdPairEq] at heq3;
      have set_z4 := Set.mk₂ hz4;
      have set_u4 := Set.mk₁ hu4;
      rw [OrdPairEq] at heq4;
      -- have heq5 := (AxiomExtensionality z z4).1 (ClassEq.trans (OrdPairEq.1 heq2).1 (OrdPairEq.1 heq'').2);
      -- have heq''''' := ClassEq.trans (ClassEq.trans (ClassEq.symm (OrdPairEq.1 heq''').2) (OrdPairEq.1 heq').2) (OrdPairEq.1 heq'').1;
      -- have := (AxiomExtensionality z z2) ;
      have u_in_z : u ∈ X := by {
        apply (h u);
        apply ((AxiomExtensionality z z3).1 (ClassEq.trans (ClassEq.trans heq1 heq2.1) heq3.2) u).2;
        apply ClassEqMenberImpMenber (ClassEq.trans heq2.2 heq3.1) hin3;
      }
      have u_not_in_z : ¬ u ∈ X := @RewiteClass (fun u => ¬ u ∈ X) u u4 ⟨heq4.2,h3.2⟩;
      contradiction;
    }
  }
}

noncomputable def PowerClass_mk (X : Class) : Class :=
  choose (PowerClassExists X)
noncomputable instance : HasPow Class where
  Pow := PowerClass_mk
noncomputable def PowerClass_def (X : Class):
  ∀z: Class, ∀_: Set z,
    z ∈ 𝒫 X ↔ (z ⊂ X) :=
  choose_spec (PowerClassExists X)
def isPowerClass (PX : Class) :=
  ∃(X: Class), ∀(Y: Class), ∀(_: Set Y), Y ∈ PX ↔ Y ⊂ X
class PowerClass (PX : Class) where
  isPowerClass: isPowerClass PX

theorem PowerClass_def'_is_PowerClass {X: Class}:
  isPowerClass (𝒫 X) := ⟨X, PowerClass_def X⟩

theorem UnivIsClosedPowerSet:
  U ＝ 𝒫 U := by {
  rw [AxiomExtensionality];
  intro z;
  apply Iff.intro;
  {
    intro h;
    rw [PowerClass_def U z (Set.mk₁ h)];
    exact AllSetSubsetU z;
  }
  {exact fun h => (Set.mk₁ h).2;}

}