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

/-!
# Augmentation and truncation of `ℕ`-indexed (co)chain complexes.
-/

noncomputable theory

open category_theory
open category_theory.limits
open homological_complex

universes v u

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

namespace chain_complex

/--
The truncation of a `ℕ`-indexed chain complex,
deleting the object at `0` and shifting everything else down.
-/
@[simps]
def truncate [has_zero_morphisms V] : chain_complex V ℕ ⥤ chain_complex V ℕ :=
{ obj := λ C,
  { X := λ i, C.X (i+1),
    d := λ i j, C.d (i+1) (j+1),
    shape' := λ i j w, by { apply C.shape, simpa }, },
  map := λ C D f,
  { f := λ i, f.f (i+1), }, }

/--
There is a canonical chain map from the truncation of a chain map `C` to
the "single object" chain complex consisting of the truncated object `C.X 0` in degree 0.
The components of this chain map are `C.d 1 0` in degree 0, and zero otherwise.
-/
def truncate_to [has_zero_object V] [has_zero_morphisms V] (C : chain_complex V ℕ) :
  truncate.obj C ⟶ (single₀ V).obj (C.X 0) :=
(to_single₀_equiv (truncate.obj C) (C.X 0)).symm ⟨C.d 1 0, by tidy⟩

-- PROJECT when `V` is abelian (but not generally?)
-- `[∀ n, exact (C.d (n+2) (n+1)) (C.d (n+1) n)] [epi (C.d 1 0)]` iff `quasi_iso (C.truncate_to)`

variables [has_zero_morphisms V]

/--
We can "augment" a chain complex by inserting an arbitrary object in degree zero
(shifting everything else up), along with a suitable differential.
-/
def augment (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) :
  chain_complex V ℕ :=
{ X := λ i, match i with
  | 0 := X
  | (i+1) := C.X i
  end,
  d := λ i j, match i, j with
  | 1, 0 := f
  | (i+1), (j+1) := C.d i j
  | _, _ := 0
  end,
  shape' := λ i j s, begin
    simp at s,
    rcases i with _|_|i; cases j; unfold_aux; try { simp },
    { simpa using s, },
    { rw [C.shape], simpa [← ne.def, nat.succ_ne_succ] using s },
  end,
  d_comp_d' := λ i j k hij hjk, begin
    rcases i with _|_|i; rcases j with _|_|j; cases k; unfold_aux; try { simp },
    cases i,
    { exact w, },
    { rw [C.shape, zero_comp],
      simpa using i.succ_succ_ne_one.symm },
  end, }

@[simp] lemma augment_X_zero (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) :
  (augment C f w).X 0 = X := rfl

@[simp]

@[simp] lemma augment_d_one_zero
  (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) :
  (augment C f w).d 1 0 = f := rfl

@[simp] lemma augment_d_succ_succ
  (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) (i j : ℕ) :
  (augment C f w).d (i+1) (j+1) = C.d i j :=
by { dsimp [augment], rcases i with _|i, refl, refl, }

/--
Truncating an augmented chain complex is isomorphic (with components the identity)
to the original complex.
-/
def truncate_augment (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) :
  truncate.obj (augment C f w) ≅ C :=
{ hom :=
  { f := λ i, 𝟙 _, },
  inv :=
  { f := λ i, by { exact 𝟙 _, },
    comm' := λ i j, by { cases j; { dsimp, simp, }, }, },
  hom_inv_id' := by { ext i, cases i; { dsimp, simp, }, },
  inv_hom_id' := by { ext i, cases i; { dsimp, simp, }, }, }.

@[simp] lemma truncate_augment_hom_f
  (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) (i : ℕ) :
  (truncate_augment C f w).hom.f i = 𝟙 (C.X i) := rfl
@[simp] lemma truncate_augment_inv_f
  (C : chain_complex V ℕ) {X : V} (f : C.X 0 ⟶ X) (w : C.d 1 0 ≫ f = 0) (i : ℕ) :
  (truncate_augment C f w).inv.f i = 𝟙 ((truncate.obj (augment C f w)).X i) :=
rfl

@[simp] lemma chain_complex_d_succ_succ_zero (C : chain_complex V ℕ) (i : ℕ) :
  C.d (i+2) 0 = 0 :=
by { rw C.shape, simpa using i.succ_succ_ne_one.symm }

/--
Augmenting a truncated complex with the original object and morphism is isomorphic
(with components the identity) to the original complex.
-/
def augment_truncate (C : chain_complex V ℕ) :
  augment (truncate.obj C) (C.d 1 0) (C.d_comp_d _ _ _) ≅ C :=
{ hom :=
  { f := λ i, by { cases i; exact 𝟙 _, },
    comm' := λ i j, by { rcases i with _|_|i; cases j; { dsimp, simp, }, }, },
  inv :=
  { f := λ i, by { cases i; exact 𝟙 _, },
    comm' := λ i j, by { rcases i with _|_|i; cases j; { dsimp, simp, }, }, },
  hom_inv_id' := by { ext i, cases i; { dsimp, simp, }, },
  inv_hom_id' := by { ext i, cases i; { dsimp, simp, }, }, }.

@[simp] lemma augment_truncate_hom_f_zero (C : chain_complex V ℕ) :
  (augment_truncate C).hom.f 0 = 𝟙 (C.X 0) :=
rfl
@[simp] lemma augment_truncate_hom_f_succ (C : chain_complex V ℕ) (i : ℕ) :
  (augment_truncate C).hom.f (i+1) = 𝟙 (C.X (i+1)) :=
rfl
@[simp] lemma augment_truncate_inv_f_zero (C : chain_complex V ℕ) :
  (augment_truncate C).inv.f 0 = 𝟙 (C.X 0) :=
rfl
@[simp] lemma augment_truncate_inv_f_succ (C : chain_complex V ℕ) (i : ℕ) :
  (augment_truncate C).inv.f (i+1) = 𝟙 (C.X (i+1)) :=
rfl

/--
A chain map from a chain complex to a single object chain complex in degree zero
can be reinterpreted as a chain complex.

Ths is the inverse construction of `truncate_to`.
-/
def to_single₀_as_complex
  [has_zero_object V] (C : chain_complex V ℕ) (X : V) (f : C ⟶ (single₀ V).obj X) :
  chain_complex V ℕ :=
let ⟨f, w⟩ := to_single₀_equiv C X f in augment C f w

end chain_complex

namespace cochain_complex

/--
The truncation of a `ℕ`-indexed cochain complex,
deleting the object at `0` and shifting everything else down.
-/
@[simps]
def truncate [has_zero_morphisms V] : cochain_complex V ℕ ⥤ cochain_complex V ℕ :=
{ obj := λ C,
  { X := λ i, C.X (i+1),
    d := λ i j, C.d (i+1) (j+1),
    shape' := λ i j w, by { apply C.shape, simpa }, },
  map := λ C D f,
  { f := λ i, f.f (i+1), }, }

/--
There is a canonical chain map from the truncation of a cochain complex `C` to
the "single object" cochain complex consisting of the truncated object `C.X 0` in degree 0.
The components of this chain map are `C.d 0 1` in degree 0, and zero otherwise.
-/
def to_truncate [has_zero_object V] [has_zero_morphisms V] (C : cochain_complex V ℕ) :
  (single₀ V).obj (C.X 0) ⟶ truncate.obj C :=
(from_single₀_equiv (truncate.obj C) (C.X 0)).symm ⟨C.d 0 1, by tidy⟩

variables [has_zero_morphisms V]

/--
We can "augment" a cochain complex by inserting an arbitrary object in degree zero
(shifting everything else up), along with a suitable differential.
-/
def augment (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) :
  cochain_complex V ℕ :=
{ X := λ i, match i with
  | 0 := X
  | (i+1) := C.X i
  end,
  d := λ i j, match i, j with
  | 0, 1 := f
  | (i+1), (j+1) := C.d i j
  | _, _ := 0
  end,
  shape' := λ i j s, begin
    simp at s,
    rcases j with _|_|j; cases i; unfold_aux; try { simp },
    { simpa using s, },
    { rw [C.shape], simp only [complex_shape.up_rel], contrapose! s, rw ←s },
  end,
  d_comp_d' := λ i j k hij hjk, begin
    rcases k with _|_|k; rcases j with _|_|j; cases i; unfold_aux; try { simp },
    cases k,
    { exact w, },
    { rw [C.shape, comp_zero],
      simp only [nat.nat_zero_eq_zero, complex_shape.up_rel, zero_add],
      exact (nat.one_lt_succ_succ _).ne },
  end, }

@[simp] lemma augment_X_zero
  (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) :
  (augment C f w).X 0 = X := rfl

@[simp] lemma augment_X_succ
  (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) (i : ℕ) :
  (augment C f w).X (i+1) = C.X i := rfl

@[simp] lemma augment_d_zero_one
  (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) :
  (augment C f w).d 0 1 = f := rfl

@[simp] lemma augment_d_succ_succ
  (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) (i j : ℕ) :
  (augment C f w).d (i+1) (j+1) = C.d i j :=
rfl

/--
Truncating an augmented cochain complex is isomorphic (with components the identity)
to the original complex.
-/
def truncate_augment (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) :
  truncate.obj (augment C f w) ≅ C :=
{ hom :=
  { f := λ i, 𝟙 _, },
  inv :=
  { f := λ i, by { exact 𝟙 _, },
    comm' := λ i j, by { cases j; { dsimp, simp, }, }, },
  hom_inv_id' := by { ext i, cases i; { dsimp, simp, }, },
  inv_hom_id' := by { ext i, cases i; { dsimp, simp, }, }, }.

@[simp] lemma truncate_augment_hom_f
  (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) (i : ℕ) :
  (truncate_augment C f w).hom.f i = 𝟙 (C.X i) := rfl
@[simp] lemma truncate_augment_inv_f
  (C : cochain_complex V ℕ) {X : V} (f : X ⟶ C.X 0) (w : f ≫ C.d 0 1 = 0) (i : ℕ) :
  (truncate_augment C f w).inv.f i = 𝟙 ((truncate.obj (augment C f w)).X i) :=
rfl

@[simp] lemma cochain_complex_d_succ_succ_zero (C : cochain_complex V ℕ) (i : ℕ) :
  C.d 0 (i+2) = 0 :=
by { rw C.shape, simp only [complex_shape.up_rel, zero_add], exact (nat.one_lt_succ_succ _).ne }

/--
Augmenting a truncated complex with the original object and morphism is isomorphic
(with components the identity) to the original complex.
-/
def augment_truncate (C : cochain_complex V ℕ) :
  augment (truncate.obj C) (C.d 0 1) (C.d_comp_d _ _ _) ≅ C :=
{ hom :=
  { f := λ i, by { cases i; exact 𝟙 _, },
    comm' := λ i j, by { rcases j with _|_|j; cases i; { dsimp, simp, }, }, },
  inv :=
  { f := λ i, by { cases i; exact 𝟙 _, },
    comm' := λ i j, by { rcases j with _|_|j; cases i; { dsimp, simp, }, }, },
  hom_inv_id' := by { ext i, cases i; { dsimp, simp, }, },
  inv_hom_id' := by { ext i, cases i; { dsimp, simp, }, }, }.

@[simp] lemma augment_truncate_hom_f_zero (C : cochain_complex V ℕ) :
  (augment_truncate C).hom.f 0 = 𝟙 (C.X 0) :=
rfl
@[simp] lemma augment_truncate_hom_f_succ (C : cochain_complex V ℕ) (i : ℕ) :
  (augment_truncate C).hom.f (i+1) = 𝟙 (C.X (i+1)) :=
rfl
@[simp] lemma augment_truncate_inv_f_zero (C : cochain_complex V ℕ) :
  (augment_truncate C).inv.f 0 = 𝟙 (C.X 0) :=
rfl
@[simp] lemma augment_truncate_inv_f_succ (C : cochain_complex V ℕ) (i : ℕ) :
  (augment_truncate C).inv.f (i+1) = 𝟙 (C.X (i+1)) :=
rfl

/--
A chain map from a single object cochain complex in degree zero to a cochain complex
can be reinterpreted as a cochain complex.

Ths is the inverse construction of `to_truncate`.
-/
def from_single₀_as_complex
  [has_zero_object V] (C : cochain_complex V ℕ) (X : V) (f : (single₀ V).obj X ⟶ C) :
  cochain_complex V ℕ :=
let ⟨f, w⟩ := from_single₀_equiv C X f in augment C f w

end cochain_complex


/-
Copyright (c) 2019 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import topology.uniform_space.cauchy
import topology.uniform_space.separation

/-!
# Indexed product of uniform spaces
-/

noncomputable theory

open_locale uniformity topological_space

section
open filter uniform_space
universe u
variables {ι : Type*} (α : ι → Type u) [U : Πi, uniform_space (α i)]
include U

instance Pi.uniform_space : uniform_space (Πi, α i) :=
uniform_space.of_core_eq
  (⨅i, uniform_space.comap (λ a : Πi, α i, a i) (U i)).to_core
  Pi.topological_space $ eq.symm to_topological_space_infi

lemma Pi.uniformity :
  𝓤 (Π i, α i) = ⨅ i : ι, filter.comap (λ a, (a.1 i, a.2 i)) $ 𝓤 (α i) :=
infi_uniformity

variable {α}

lemma uniform_continuous_pi {β : Type*} [uniform_space β] {f : β → Π i, α i} :
  uniform_continuous f ↔ ∀ i, uniform_continuous (λ x, f x i) :=
by simp only [uniform_continuous, Pi.uniformity, tendsto_infi, tendsto_comap_iff]

variable (α)

lemma Pi.uniform_continuous_proj (i : ι) : uniform_continuous (λ (a : Π (i : ι), α i), a i) :=
uniform_continuous_pi.1 uniform_continuous_id i

instance Pi.complete [∀ i, complete_space (α i)] : complete_space (Π i, α i) :=
⟨begin
  intros f hf,
  haveI := hf.1,
  have : ∀ i, ∃ x : α i, filter.map (λ a : Πi, α i, a i) f ≤ 𝓝 x,
  { intro i,
    have key : cauchy (map (λ (a : Π (i : ι), α i), a i) f),
      from hf.map (Pi.uniform_continuous_proj α i),
    exact cauchy_iff_exists_le_nhds.1 key },
  choose x hx using this,
  use x,
  rwa [nhds_pi, le_pi],
end⟩

instance Pi.separated [∀ i, separated_space (α i)] : separated_space (Π i, α i) :=
separated_def.2 $ assume x y H,
begin
  ext i,
  apply eq_of_separated_of_uniform_continuous (Pi.uniform_continuous_proj α i),
  apply H,
end
end


open Classical

variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : (∃ _ : α, r) → r :=
fun h1 : ∃ _ : α, r => Exists.elim h1
  (fun _ : α => fun hr : r => hr)

example : (∃ _ : α, r) → r :=
fun h1 : ∃ _ : α, r => Exists.elim h1
  (fun _ : α => fun hr : r => hr)

example (a : α) : r → (∃ _ : α, r) :=
fun hr : r => Exists.intro a hr

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r := Iff.intro
(fun h1: ∃ x, p x ∧ r => And.intro
  (Exists.elim h1 (fun x : α =>
    fun h2 : p x ∧ r => Exists.intro x h2.left))
  (Exists.elim h1 (fun x : α =>
    fun h2 : p x ∧ r => h2.right)))
(fun h1: (∃ x, p x) ∧ r => Exists.elim h1.left
  (fun x : α =>
    fun hp : p x =>
      have h2 : p x ∧ r := And.intro hp h1.right
      Exists.intro x h2))

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) := Iff.intro
(fun h1 : ∃ x, p x ∨ q x => Exists.elim h1
  fun y : α =>
    fun h2 : p y ∨ q y => Or.elim h2
      (fun hp : p y =>
        have h3 : ∃ x, p x := Exists.intro y hp
        Or.intro_left (∃ x, q x) h3)
      (fun hq : q y =>
        have h3 : ∃ x, q x := Exists.intro y hq
        Or.intro_right (∃ x, p x) h3))
(fun h1 : (∃ x, p x) ∨ (∃ x, q x) => Or.elim h1
  (fun h2 : ∃ x, p x => Exists.elim h2
    fun y : α =>
      fun hp : p y =>
        have h3 : p y ∨ q y := Or.intro_left (q y) hp
        Exists.intro y h3)
  (fun h2 : ∃ x, q x => Exists.elim h2
    fun y : α =>
      fun hq : q y =>
        have h3 : p y ∨ q y := Or.intro_right (p y) hq
        Exists.intro y h3))

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) := Iff.intro
(fun h1 : ∀ x, p x =>
  fun h2 : ∃ x, ¬ p x => Exists.elim h2
    fun y : α =>
      fun hpf : ¬ p y => show False from hpf (h1 y))
(fun h1 : ¬ ∃ x, ¬ p x =>
  fun y : α => show p y from byContradiction
    fun hpf : ¬ p y =>
      have h3 : ∃ x, ¬ p x := Exists.intro y hpf
      show False from h1 h3)

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) := Iff.intro
(fun h1 : ∀ x, p x =>
  fun h2 : ∃ x, ¬ p x => Exists.elim h2
    fun y : α =>
      fun hpf : ¬ p y =>
        have hp : p y := h1 y
        show False from hpf hp)
(fun h1 : ¬ (∃ x, ¬ p x) =>
  fun y : α => show p y from byContradiction
    fun hpf : ¬ p y =>
      have h2 : ∃ x, ¬ p x := Exists.intro y hpf
      show False from h1 h2)

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) := Iff.intro
(fun h1 : ∃ x, p x =>
  fun h2 : ∀ x, ¬ p x => Exists.elim h1
    fun y : α =>
      fun hp : p y =>
        have hpf : ¬ p y := h2 y
        show False from hpf hp)
(fun h1 : ¬ (∀ x, ¬ p x) => show ∃ x, p x from byContradiction
  fun h2 : ¬ ∃ x, p x => h1
    fun y : α =>
      fun hp : p y => h2 (Exists.intro y hp))

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) := Iff.intro
(fun h1 : ¬ ∃ x, p x =>
  fun y : α =>
    fun hp : p y => h1 (Exists.intro y hp))
(fun h1 : ∀ x, ¬ p x =>
  fun h2 : ∃ x, p x => Exists.elim h2
  (fun y : α =>
    fun hp : p y => (h1 y) hp))

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) := Iff.intro
(fun h1 : ¬ ∀ x, p x => show ∃ x, ¬ p x from byContradiction
  fun h2 : ¬ ∃ x, ¬ p x => h1
    fun y : α => show p y from byContradiction
      fun hpf : ¬ p y => h2 (Exists.intro y hpf))
(fun h1 : ∃ x, ¬ p x =>
  fun h2 : ∀ x, p x => Exists.elim h1
    fun y : α =>
      fun hpf : ¬ p y => hpf (h2 y))

example : (∀ x, p x → r) ↔ (∃ x, p x) → r := Iff.intro
(fun h1 : ∀ x, p x → r =>
  fun h2 : ∃ x, p x => Exists.elim h2
    fun y : α =>
      fun hp : p y => (h1 y) hp)
(fun h1 : (∃ x, p x) → r =>
  fun y : α =>
    fun hp : p y => h1 (Exists.intro y hp))

example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r := Iff.intro
(fun h1 : ∃ x, p x → r =>
  fun h2 : ∀ x, p x => Exists.elim h1
    fun y : α =>
      fun h3 : p y → r => h3 (h2 y))
(fun h1 : (∀ x, p x) → r => Or.elim (em r)
  (fun hr : r =>
    have h2 : p a → r := fun _ : p a => hr
    show ∃ x, p x → r from (Exists.intro a h2))
  (fun h2 : ¬ r => show ∃ x, p x → r from byContradiction
    fun h3 : ¬ ∃ x, p x → r => h2
      (show r from h1 (fun y : α => show p y from byContradiction
          fun hpf : ¬ p y => h3
            (have h4 : p y → r := fun hp : p y => False.elim (hpf hp)
            show (∃ x, p x → r) from (Exists.intro y h4))))))

example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) := Iff.intro
(fun h1 : ∃ x, r → p x =>
  fun hr : r => Exists.elim h1
    (fun y : α =>
      fun h2 : r → p y =>
        have hp : p y := h2 hr
        Exists.intro y hp))
(fun h1 : r → ∃ x, p x => Or.elim (em r)
  (fun hr : r =>
    have h2 : ∃ x, p x := h1 hr
    Exists.elim h2 (fun y : α =>
      fun hp : p y =>
        have h3 : r → p y := fun _ : r => hp
        Exists.intro y h3))
  (fun hrf : r → False =>
    have h2 : r → p a := fun hr : r => False.elim (hrf hr)
    Exists.intro a h2))

example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) := Iff.intro
(fun h1 : ∀ x, p x ∧ q x => And.intro
  (fun y : α => (h1 y).left)
  (fun y : α => (h1 y).right))
(fun h1 : (∀ x, p x) ∧ (∀ x, q x) =>
  fun y : α => And.intro (h1.left y) (h1.right y))

example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) :=
fun h1 : ∀ x, p x → q x =>
  fun h2 : ∀ x, p x =>
    fun y : α => (h1 y) (h2 y)

example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x :=
fun h1 : (∀ x, p x) ∨ (∀ x, q x) =>
  fun y : α => Or.elim h1
    (fun h2 : ∀ x, p x => Or.intro_left (q y) (h2 y))
    (fun h2 : ∀ x, q x => Or.intro_right (p y) (h2 y))

example : α → ((∀ _ : α, r) ↔ r) :=
fun a : α => Iff.intro
  (fun h1 : (∀ _ : α, r) => h1 a)
  (fun h1 : r =>
    fun _ : α => h1)

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r := Iff.intro
(fun h1 : ∀ x, p x ∨ r => Or.elim (em r)
  (fun hr : r => Or.intro_right (∀ x, p x) hr)
  (fun hrf : ¬ r => suffices h2 : ∀ x, p x from Or.intro_left r h2
    fun y : α =>
      have h3 : p y ∨ r := h1 y
      Or.elim h3
      (fun hp : p y => hp)
      (fun hr : r => show p y from False.elim (hrf hr))))
(fun h1 : (∀ x, p x) ∨ r =>
  fun y : α => Or.elim h1
    (fun h2 : ∀ x, p x => Or.intro_left r (h2 y))
    (fun hr : r => Or.intro_right (p y) hr))

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) := Iff.intro
(fun h1 : ∀ x, r → p x =>
  fun hr : r =>
    fun y : α => (h1 y) hr)
(fun h1 : r → ∀ x, p x =>
  fun y : α =>
    fun hr : r => (h1 hr) y)

variable (men : Type) (barber : men)
variable (shaves : men → men → Prop)

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : False :=
have hb : shaves barber barber ↔ ¬ shaves barber barber := h barber
have hf : ¬ shaves barber barber := fun ht : shaves barber barber => (hb.mp ht) ht
show False from hf (hb.mpr hf)


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Scott Morrison
-/
import data.monoid_algebra
import ring_theory.algebra
import algebra.invertible
import algebra.char_p
import linear_algebra.basis

/-!
# Maschke's theorem

We prove Maschke's theorem for finite groups,
in the formulation that every submodule of a `k[G]` module has a complement,
when `k` is a field with `¬(ring_char k ∣ fintype.card G)`.

We do the core computation in greater generality.
For any `[comm_ring k]` in which  `[invertible (fintype.card G : k)]`,
and a `k[G]`-linear map `i : V → W` which admits a `k`-linear retraction `π`,
we produce a `k[G]`-linear retraction by
taking the average over `G` of the conjugates of `π`.

## Future work
It's not so far to give the usual statement, that every finite dimensional representation
of a finite group is semisimple (i.e. a direct sum of irreducibles).
-/

universes u

noncomputable theory
open module
open monoid_algebra
open_locale big_operators

section

-- At first we work with any `[comm_ring k]`, and add the assumption that
-- `[invertible (fintype.card G : k)]` when it is required.
variables {k : Type u} [comm_ring k] {G : Type u} [group G]

variables {V : Type u} [add_comm_group V] [module (monoid_algebra k G) V]
variables {W : Type u} [add_comm_group W] [module (monoid_algebra k G) W]

/-!
We now do the key calculation in Maschke's theorem.

Given `V → W`, an inclusion of `k[G]` modules,,
assume we have some retraction `π` (i.e. `∀ v, π (i v) = v`),
just as a `k`-linear map.
(When `k` is a field, this will be available cheaply, by choosing a basis.)

We now construct a retraction of the inclusion as a `k[G]`-linear map,
by the formula
$$ \frac{1}{|G|} \sum_{g \mem G} g⁻¹ • π(g • -). $$
-/

variables (π : (restrict_scalars k (monoid_algebra k G) W) →ₗ[k]
               (restrict_scalars k (monoid_algebra k G) V))
include π

/--
We define the conjugate of `π` by `g`, as a `k`-linear map.
-/
def conjugate (g : G) :
  (restrict_scalars k (monoid_algebra k G) W) →ₗ[k] (restrict_scalars k (monoid_algebra k G) V) :=
((group_smul.linear_map k V g⁻¹).comp π).comp (group_smul.linear_map k W g)

variables (i : V →ₗ[monoid_algebra k G] W) (h : ∀ v : V, π (i v) = v)

section
include h

lemma conjugate_i (g : G) (v : V) : (conjugate π g) (i v) = v :=
begin
  dsimp [conjugate],
  simp only [←i.map_smul, h, ←mul_smul, single_mul_single, mul_one, mul_left_inv],
  change (1 : monoid_algebra k G) • v = v,
  simp,
end
end

variables [fintype G]

/--
The sum of the conjugates of `π` by each element `g : G`, as a `k`-linear map.

(We postpone dividing by the size of the group as long as possible.)
-/
def sum_of_conjugates :
  (restrict_scalars k (monoid_algebra k G) W) →ₗ[k] (restrict_scalars k (monoid_algebra k G) V) :=
∑ g : G, conjugate π g

/--
In fact, the sum over `g : G` of the conjugate of `π` by `g` is a `k[G]`-linear map.
-/
def sum_of_conjugates_equivariant :
  W →ₗ[monoid_algebra k G] V :=
monoid_algebra.equivariant_of_linear_of_comm (sum_of_conjugates π) (λ g v,
begin
  dsimp [sum_of_conjugates],
  simp only [linear_map.sum_apply, finset.smul_sum],
  dsimp [conjugate],
  conv_lhs {
    rw [←finset.univ_map_embedding (mul_right_embedding g⁻¹)],
    simp only [mul_right_embedding],
  },
  simp only [←mul_smul, single_mul_single, mul_inv_rev, mul_one, function.embedding.coe_fn_mk,
    finset.sum_map, inv_inv, inv_mul_cancel_right],
end)

section
variables [inv : invertible (fintype.card G : k)]
include inv

section
local attribute [instance] linear_map_algebra_module
/--
We construct our `k[G]`-linear retraction of `i` as
$$ \frac{1}{|G|} \sum_{g \mem G} g⁻¹ • π(g • -). $$
-/
def equivariant_projection :
  W →ₗ[monoid_algebra k G] V :=
⅟(fintype.card G : k) • (sum_of_conjugates_equivariant π)
end

include h

lemma equivariant_projection_condition (v : V) : (equivariant_projection π) (i v) = v :=
begin
  rw [equivariant_projection, linear_map_algebra_module.smul_apply, sum_of_conjugates_equivariant,
    equivariant_of_linear_of_comm_apply, sum_of_conjugates],
  rw [linear_map.sum_apply],
  simp only [conjugate_i π i h],
  rw [finset.sum_const, finset.card_univ,
    @semimodule.nsmul_eq_smul k _
      (restrict_scalars k (monoid_algebra k G) V) _ _ (fintype.card G) v,
    ←mul_smul, invertible.inv_of_mul_self, one_smul],
end
end
end

-- Now we work over a `[field k]`, and replace the assumption `[invertible (fintype.card G : k)]`
-- with `¬(ring_char k ∣ fintype.card G)`.
variables {k : Type u} [field k] {G : Type u} [fintype G] [group G]
variables {V : Type u} [add_comm_group V] [module (monoid_algebra k G) V]
variables {W : Type u} [add_comm_group W] [module (monoid_algebra k G) W]

lemma monoid_algebra.exists_left_inverse_of_injective
  (not_dvd : ¬(ring_char k ∣ fintype.card G))
  (f : V →ₗ[monoid_algebra k G] W) (hf_inj : f.ker = ⊥) :
  ∃ (g : W →ₗ[monoid_algebra k G] V), g.comp f = linear_map.id :=
begin
  let E := linear_map.exists_left_inverse_of_injective
    (by convert f.restrict_scalars k) (by simp [hf_inj]),
  fsplit,
  haveI : invertible (fintype.card G : k) :=
    invertible_of_ring_char_not_dvd not_dvd,
  exact equivariant_projection (classical.some E),
  { ext v,
    apply equivariant_projection_condition,
    intro v,
    have := classical.some_spec E,
    have := congr_arg linear_map.to_fun this,
    exact congr_fun this v, }
end

lemma monoid_algebra.submodule.exists_is_compl
  (not_dvd : ¬(ring_char k ∣ fintype.card G)) (p : submodule (monoid_algebra k G) V) :
  ∃ q : submodule (monoid_algebra k G) V, is_compl p q :=
let ⟨f, hf⟩ := monoid_algebra.exists_left_inverse_of_injective not_dvd p.subtype p.ker_subtype in
⟨f.ker, linear_map.is_compl_of_proj $ linear_map.ext_iff.1 hf⟩

/-- An `R`-module `M` is irreducible if every invariant submodule is either `⊥` or `⊤`. -/

variables (i : V →ₗ[monoid_algebra k G] W)

def is_zero_map : Prop := ∀ v : V, i v = 0

lemma check_zero : is_zero_map (0 • i) := begin unfold is_zero_map, intro, simp [i.map_smul] end

def invariant_submodule (N : submodule (monoid_algebra k G) W) : Prop :=
  ∀ v : W, ∀ g : G, (group_smul.linear_map k W g) v = v

def irreducible (M : Type u) [add_comm_group M] [module (monoid_algebra k G) M] : Prop :=
∀ N : submodule (monoid_algebra k G) M, N = ⊥ ∨ N = ⊤

#print irreducible

lemma schur (i : V →ₗ[monoid_algebra k G] W) : irreducible V ∧ irreducible W → (function.bijective i ↔ ¬ is_zero_map i) :=
sorry


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

import tactic.linarith
import category_theory.skeletal
import data.fintype.sort
import order.category.NonemptyFinLinOrd
import category_theory.functor.reflects_isomorphisms

/-! # The simplex category

We construct a skeletal model of the simplex category, with objects `ℕ` and the
morphism `n ⟶ m` being the monotone maps from `fin (n+1)` to `fin (m+1)`.

We show that this category is equivalent to `NonemptyFinLinOrd`.

## Remarks

The definitions `simplex_category` and `simplex_category.hom` are marked as irreducible.

We provide the following functions to work with these objects:
1. `simplex_category.mk` creates an object of `simplex_category` out of a natural number.
  Use the notation `[n]` in the `simplicial` locale.
2. `simplex_category.len` gives the "length" of an object of `simplex_category`, as a natural.
3. `simplex_category.hom.mk` makes a morphism out of a monotone map between `fin`'s.
4. `simplex_category.hom.to_order_hom` gives the underlying monotone map associated to a
  term of `simplex_category.hom`.

-/

universe v

open category_theory category_theory.limits

/-- The simplex category:
* objects are natural numbers `n : ℕ`
* morphisms from `n` to `m` are monotone functions `fin (n+1) → fin (m+1)`
-/
@[derive inhabited, irreducible]
def simplex_category := ℕ

namespace simplex_category

section
local attribute [semireducible] simplex_category

-- TODO: Make `mk` irreducible.
/-- Interpet a natural number as an object of the simplex category. -/
def mk (n : ℕ) : simplex_category := n

localized "notation (name := simplex_category.mk) `[`n`]` := simplex_category.mk n" in simplicial

-- TODO: Make `len` irreducible.
/-- The length of an object of `simplex_category`. -/
def len (n : simplex_category) : ℕ := n

@[ext] lemma ext (a b : simplex_category) : a.len = b.len → a = b := id
@[simp] lemma len_mk (n : ℕ) : [n].len = n := rfl
@[simp] lemma mk_len (n : simplex_category) : [n.len] = n := rfl

/-- A recursor for `simplex_category`. Use it as `induction Δ using simplex_category.rec`. -/
protected def rec {F : Π (Δ : simplex_category), Sort*} (h : ∀ (n : ℕ), F [n]) :
  Π X, F X := λ n, h n.len

/-- Morphisms in the simplex_category. -/
@[irreducible, nolint has_nonempty_instance]
protected def hom (a b : simplex_category) := fin (a.len + 1) →o fin (b.len + 1)

namespace hom

local attribute [semireducible] simplex_category.hom

/-- Make a moprhism in `simplex_category` from a monotone map of fin's. -/
def mk {a b : simplex_category} (f : fin (a.len + 1) →o fin (b.len + 1)) :
  simplex_category.hom a b := f

/-- Recover the monotone map from a morphism in the simplex category. -/
def to_order_hom {a b : simplex_category} (f : simplex_category.hom a b) :
  fin (a.len + 1) →o fin (b.len + 1) := f

@[ext] lemma ext {a b : simplex_category} (f g : simplex_category.hom a b) :
  f.to_order_hom = g.to_order_hom → f = g := id

@[simp] lemma mk_to_order_hom {a b : simplex_category}
  (f : simplex_category.hom a b) : mk (f.to_order_hom) = f := rfl

@[simp] lemma to_order_hom_mk {a b : simplex_category}
  (f : fin (a.len + 1) →o fin (b.len + 1)) : (mk f).to_order_hom = f := rfl

lemma mk_to_order_hom_apply {a b : simplex_category}
  (f : fin (a.len + 1) →o fin (b.len + 1)) (i : fin (a.len + 1)) :
  (mk f).to_order_hom i = f i := rfl

/-- Identity morphisms of `simplex_category`. -/
@[simp]
def id (a : simplex_category) :
  simplex_category.hom a a :=
mk order_hom.id

/-- Composition of morphisms of `simplex_category`. -/
@[simp]
def comp {a b c : simplex_category} (f : simplex_category.hom b c)
  (g : simplex_category.hom a b) : simplex_category.hom a c :=
mk $ f.to_order_hom.comp g.to_order_hom

end hom

@[simps]
instance small_category : small_category.{0} simplex_category :=
{ hom := λ n m, simplex_category.hom n m,
  id := λ m, simplex_category.hom.id _,
  comp := λ _ _ _ f g, simplex_category.hom.comp g f, }

/-- The constant morphism from [0]. -/
def const (x : simplex_category) (i : fin (x.len+1)) : [0] ⟶ x :=
  hom.mk $ ⟨λ _, i, by tauto⟩

@[simp]
lemma const_comp (x y : simplex_category) (i : fin (x.len + 1)) (f : x ⟶ y) :
  const x i ≫ f = const y (f.to_order_hom i) := rfl

/--
Make a morphism `[n] ⟶ [m]` from a monotone map between fin's.
This is useful for constructing morphisms beetween `[n]` directly
without identifying `n` with `[n].len`.
-/
@[simp]
def mk_hom {n m : ℕ} (f : (fin (n+1)) →o (fin (m+1))) : [n] ⟶ [m] :=
simplex_category.hom.mk f

lemma hom_zero_zero (f : [0] ⟶ [0]) : f = 𝟙 _ :=
by { ext : 2, dsimp, apply subsingleton.elim }

end

open_locale simplicial

section generators
/-!
## Generating maps for the simplex category

TODO: prove that the simplex category is equivalent to
one given by the following generators and relations.
-/

/-- The `i`-th face map from `[n]` to `[n+1]` -/
def δ {n} (i : fin (n+2)) : [n] ⟶ [n+1] :=
mk_hom (fin.succ_above i).to_order_hom

/-- The `i`-th degeneracy map from `[n+1]` to `[n]` -/
def σ {n} (i : fin (n+1)) : [n+1] ⟶ [n] := mk_hom
{ to_fun := fin.pred_above i,
  monotone' := fin.pred_above_right_monotone i }

/-- The generic case of the first simplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  δ i ≫ δ j.succ = δ j ≫ δ i.cast_succ :=
begin
  ext k,
  dsimp [δ, fin.succ_above],
  simp only [order_embedding.to_order_hom_coe,
    order_embedding.coe_of_strict_mono,
    function.comp_app,
    simplex_category.hom.to_order_hom_mk,
    order_hom.comp_coe],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  split_ifs; { simp at *; linarith },
end

lemma δ_comp_δ' {n} {i : fin (n+2)} {j : fin (n+3)} (H : i.cast_succ < j) :
  δ i ≫ δ j = δ (j.pred (λ hj, by simpa only [hj, fin.not_lt_zero] using H)) ≫ δ i.cast_succ :=
begin
  rw ← δ_comp_δ,
  { rw fin.succ_pred, },
  { simpa only [fin.le_iff_coe_le_coe, ← nat.lt_succ_iff, nat.succ_eq_add_one, ← fin.coe_succ,
      j.succ_pred, fin.lt_iff_coe_lt_coe] using H, },
end

lemma δ_comp_δ'' {n} {i : fin (n+3)} {j : fin (n+2)} (H : i ≤ j.cast_succ) :
  δ (i.cast_lt (nat.lt_of_le_of_lt (fin.le_iff_coe_le_coe.mp H) j.is_lt)) ≫ δ j.succ =
    δ j ≫ δ i :=
begin
  rw δ_comp_δ,
  { refl, },
  { exact H, },
end

/-- The special case of the first simplicial identity -/
@[reassoc]
lemma δ_comp_δ_self {n} {i : fin (n+2)} : δ i ≫ δ i.cast_succ = δ i ≫ δ i.succ :=
(δ_comp_δ (le_refl i)).symm

@[reassoc]
lemma δ_comp_δ_self' {n} {i : fin (n+2)} {j : fin (n+3)} (H : j = i.cast_succ) :
  δ i ≫ δ j = δ i ≫ δ i.succ :=
by { subst H, rw δ_comp_δ_self, }

/-- The second simplicial identity -/
@[reassoc]
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  δ i.cast_succ ≫ σ j.succ = σ j ≫ δ i :=
begin
  ext k,
  suffices : ite (j.succ.cast_succ < ite (k < i) k.cast_succ k.succ)
    (ite (k < i) (k:ℕ) (k + 1) - 1) (ite (k < i) k (k + 1)) =
      ite ((if h : (j:ℕ) < k
        then k.pred (by { rintro rfl, exact nat.not_lt_zero _ h })
        else k.cast_lt (by { cases j, cases k, simp only [len_mk], linarith })).cast_succ < i)
          (ite (j.cast_succ < k) (k - 1) k) (ite (j.cast_succ < k) (k - 1) k + 1),
  { dsimp [δ, σ, fin.succ_above, fin.pred_above],
    simp [fin.pred_above] with push_cast,
    convert rfl },
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [fin.mk_le_mk, fin.cast_succ_mk] at H,
  dsimp,
  split_ifs,
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with two of them by hand.
  swap 8,
  { exact (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) ‹_›)).symm, },
  swap 7,
  { have : k ≤ i := nat.le_of_pred_lt ‹_›, linarith, },
  -- Hope for the best from `linarith`:
  all_goals { try { refl <|> simp at * }; linarith, },
end

/-- The first part of the third simplicial identity -/
@[reassoc]
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  δ i.cast_succ ≫ σ i = 𝟙 [n] :=
begin
  ext j,
  suffices : ite (fin.cast_succ i < ite (j < i) (fin.cast_succ j) j.succ)
    (ite (j < i) (j:ℕ) (j + 1) - 1) (ite (j < i) j (j + 1)) = j,
  { dsimp [δ, σ, fin.succ_above, fin.pred_above], simpa [fin.pred_above] with push_cast },
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  dsimp,
  split_ifs; { simp at *; linarith, },
end

@[reassoc]
lemma δ_comp_σ_self' {n} {j : fin (n+2)} {i : fin (n+1)} (H : j = i.cast_succ) :
  δ j ≫ σ i = 𝟙 [n] :=
by { subst H, rw δ_comp_σ_self, }

/-- The second part of the third simplicial identity -/
@[reassoc]
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  δ i.succ ≫ σ i = 𝟙 [n] :=
begin
  ext j,
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  dsimp [δ, σ, fin.succ_above, fin.pred_above],
  simp [fin.pred_above] with push_cast,
  split_ifs; { simp at *; linarith, },
end

@[reassoc]
lemma δ_comp_σ_succ' {n} (j : fin (n+2)) (i : fin (n+1)) (H : j = i.succ) :
  δ j ≫ σ i = 𝟙 [n] :=
by { subst H, rw δ_comp_σ_succ, }

/-- The fourth simplicial identity -/
@[reassoc]
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  δ i.succ ≫ σ j.cast_succ = σ j ≫ δ i :=
begin
  ext k,
  dsimp [δ, σ, fin.succ_above, fin.pred_above],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [fin.mk_lt_mk, fin.cast_succ_mk] at H,
  suffices : ite (_ < ite (k < i + 1) _ _) _ _ =
    ite _ (ite (j < k) (k - 1) k) (ite (j < k) (k - 1) k + 1),
  { simpa [apply_dite fin.cast_succ, fin.pred_above] with push_cast, },
  split_ifs,
  -- Most of the goals can now be handled by `linarith`,
  -- but we have to deal with three of them by hand.
  swap 2,
  { simp only [fin.mk_lt_mk] at h_1,
    simp only [not_lt] at h_2,
    simp only [self_eq_add_right, one_ne_zero],
    exact lt_irrefl (k - 1) (lt_of_lt_of_le
      (nat.pred_lt (ne_of_lt (lt_of_le_of_lt (zero_le _) h_1)).symm)
      (le_trans (nat.le_of_lt_succ h) h_2)) },
  swap 4,
  { simp only [fin.mk_lt_mk] at h_1,
    simp only [not_lt] at h,
    simp only [nat.add_succ_sub_one, add_zero],
    exfalso,
    exact lt_irrefl _ (lt_of_le_of_lt (nat.le_pred_of_lt (nat.lt_of_succ_le h)) h_3), },
  swap 4,
  { simp only [fin.mk_lt_mk] at h_1,
    simp only [not_lt] at h_3,
    simp only [nat.add_succ_sub_one, add_zero],
    exact (nat.succ_pred_eq_of_pos (lt_of_le_of_lt (zero_le _) h_2)).symm, },
  -- Hope for the best from `linarith`:
  all_goals { simp at h_1 h_2 ⊢; linarith, },
end

@[reassoc]
lemma δ_comp_σ_of_gt' {n} {i : fin (n+3)} {j : fin (n+2)} (H : j.succ < i) :
  δ i ≫ σ j = σ (j.cast_lt ((add_lt_add_iff_right 1).mp (lt_of_lt_of_le
      (by simpa only [fin.val_eq_coe, ← fin.coe_succ]
        using fin.lt_iff_coe_lt_coe.mp H) i.is_le))) ≫
    δ (i.pred (λ hi, by simpa only [fin.not_lt_zero, hi] using H)) :=
begin
  rw ← δ_comp_σ_of_gt,
  { simpa only [fin.succ_pred], },
  { rw [fin.cast_succ_cast_lt, ← fin.succ_lt_succ_iff, fin.succ_pred],
    exact H, },
end

local attribute [simp] fin.pred_mk

/-- The fifth simplicial identity -/
@[reassoc]
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  σ i.cast_succ ≫ σ j = σ j.succ ≫ σ i :=
begin
  ext k,
  dsimp [σ, fin.pred_above],
  rcases i with ⟨i, _⟩,
  rcases j with ⟨j, _⟩,
  rcases k with ⟨k, _⟩,
  simp only [fin.mk_le_mk] at H,
  -- At this point `simp with push_cast` makes good progress, but neither `simp?` nor `squeeze_simp`
  -- return usable sets of lemmas.
  -- To avoid using a non-terminal simp, we make a `suffices` statement indicating the shape
  -- of the goal we're looking for, and then use `simpa with push_cast`.
  -- I'm not sure this is actually much more robust that a non-terminal simp.
  suffices : ite (_ < dite (i < k) _ _) _ _ =
    ite (_ < dite (j + 1 < k) _ _) _ _,
  { simpa [fin.pred_above] with push_cast, },
  split_ifs,
  -- `split_ifs` created 12 goals.
  -- Most of them are dealt with `by simp at *; linarith`,
  -- but we pull out two harder ones to do by hand.
  swap 3,
  { simp only [not_lt] at h_2,
    exact false.elim
    (lt_irrefl (k - 1)
      (lt_of_lt_of_le (nat.pred_lt (id (ne_of_lt (lt_of_le_of_lt (zero_le i) h)).symm))
        (le_trans h_2 (nat.succ_le_of_lt h_1)))) },
  swap 3,
  { simp only [subtype.mk_lt_mk, not_lt] at h_1,
    exact false.elim
    (lt_irrefl j (lt_of_lt_of_le (nat.pred_lt_pred (nat.succ_ne_zero j) h_2) h_1)) },
  -- Deal with the rest automatically.
  all_goals { simp at *; linarith, },
end

end generators

section skeleton

/-- The functor that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
@[simps obj map]
def skeletal_functor : simplex_category ⥤ NonemptyFinLinOrd.{v} :=
{ obj := λ a, NonemptyFinLinOrd.of $ ulift (fin (a.len + 1)),
  map := λ a b f,
    ⟨λ i, ulift.up (f.to_order_hom i.down), λ i j h, f.to_order_hom.monotone h⟩,
  map_id' := λ a, by { ext, simp, },
  map_comp' := λ a b c f g, by { ext, simp, }, }

lemma skeletal_functor.coe_map
  {Δ₁ Δ₂ : simplex_category} (f : Δ₁ ⟶ Δ₂) :
  coe_fn (skeletal_functor.{v}.map f) = ulift.up ∘ f.to_order_hom ∘ ulift.down := rfl

lemma skeletal : skeletal simplex_category :=
λ X Y ⟨I⟩,
begin
  suffices : fintype.card (fin (X.len+1)) = fintype.card (fin (Y.len+1)),
  { ext, simpa },
  { apply fintype.card_congr,
    refine equiv.ulift.symm.trans (((skeletal_functor ⋙ forget _).map_iso I).to_equiv.trans _),
    apply equiv.ulift }
end

namespace skeletal_functor

instance : full skeletal_functor.{v} :=
{ preimage := λ a b f, simplex_category.hom.mk ⟨λ i, (f (ulift.up i)).down, λ i j h, f.monotone h⟩,
  witness' := by { intros m n f, dsimp at *, ext1 ⟨i⟩, ext1, ext1, cases x, simp, } }

instance : faithful skeletal_functor.{v} :=
{ map_injective' := λ m n f g h,
  begin
    ext1, ext1, ext1 i, apply ulift.up.inj,
    change (skeletal_functor.map f) ⟨i⟩ = (skeletal_functor.map g) ⟨i⟩,
    rw h,
  end }

instance : ess_surj skeletal_functor.{v} :=
{ mem_ess_image := λ X, ⟨mk (fintype.card X - 1 : ℕ), ⟨begin
    have aux : fintype.card X = fintype.card X - 1 + 1,
    { exact (nat.succ_pred_eq_of_pos $ fintype.card_pos_iff.mpr ⟨⊥⟩).symm, },
    let f := mono_equiv_of_fin X aux,
    have hf := (finset.univ.order_emb_of_fin aux).strict_mono,
    refine
    { hom := ⟨λ i, f i.down, _⟩,
      inv := ⟨λ i, ⟨f.symm i⟩, _⟩,
      hom_inv_id' := _,
      inv_hom_id' := _ },
    { rintro ⟨i⟩ ⟨j⟩ h, show f i ≤ f j, exact hf.monotone h, },
    { intros i j h, show f.symm i ≤ f.symm j, rw ← hf.le_iff_le,
      show f (f.symm i) ≤ f (f.symm j), simpa only [order_iso.apply_symm_apply], },
    { ext1, ext1 ⟨i⟩, ext1, exact f.symm_apply_apply i },
    { ext1, ext1 i, exact f.apply_symm_apply i },
  end⟩⟩, }

noncomputable instance is_equivalence : is_equivalence (skeletal_functor.{v}) :=
equivalence.of_fully_faithfully_ess_surj skeletal_functor

end skeletal_functor

/-- The equivalence that exhibits `simplex_category` as skeleton
of `NonemptyFinLinOrd` -/
noncomputable def skeletal_equivalence : simplex_category ≌ NonemptyFinLinOrd.{v} :=
functor.as_equivalence skeletal_functor

end skeleton

/--
`simplex_category` is a skeleton of `NonemptyFinLinOrd`.
-/
noncomputable
def is_skeleton_of : is_skeleton_of NonemptyFinLinOrd simplex_category skeletal_functor.{v} :=
{ skel := skeletal,
  eqv := skeletal_functor.is_equivalence }

/-- The truncated simplex category. -/
@[derive small_category]
def truncated (n : ℕ) := full_subcategory (λ a : simplex_category, a.len ≤ n)

namespace truncated

instance {n} : inhabited (truncated n) := ⟨⟨[0],by simp⟩⟩

/--
The fully faithful inclusion of the truncated simplex category into the usual
simplex category.
-/
@[derive [full, faithful]]
def inclusion {n : ℕ} : simplex_category.truncated n ⥤ simplex_category :=
full_subcategory_inclusion _

end truncated

section concrete

instance : concrete_category.{0} simplex_category :=
{ forget :=
  { obj := λ i, fin (i.len + 1),
    map := λ i j f, f.to_order_hom },
  forget_faithful := {} }

end concrete

section epi_mono

/-- A morphism in `simplex_category` is a monomorphism precisely when it is an injective function
-/
theorem mono_iff_injective {n m : simplex_category} {f : n ⟶ m} :
  mono f ↔ function.injective f.to_order_hom :=
begin
  rw ← functor.mono_map_iff_mono skeletal_equivalence.functor.{0},
  dsimp only [skeletal_equivalence, functor.as_equivalence_functor],
  rw [NonemptyFinLinOrd.mono_iff_injective, skeletal_functor.coe_map,
    function.injective.of_comp_iff ulift.up_injective,
    function.injective.of_comp_iff' _ ulift.down_bijective],
end

/-- A morphism in `simplex_category` is an epimorphism if and only if it is a surjective function
-/
lemma epi_iff_surjective {n m : simplex_category} {f: n ⟶ m} :
  epi f ↔ function.surjective f.to_order_hom :=
begin
  rw ← functor.epi_map_iff_epi skeletal_equivalence.functor.{0},
  dsimp only [skeletal_equivalence, functor.as_equivalence_functor],
  rw [NonemptyFinLinOrd.epi_iff_surjective, skeletal_functor.coe_map,
    function.surjective.of_comp_iff' ulift.up_bijective,
    function.surjective.of_comp_iff _ ulift.down_surjective],
end

/-- A monomorphism in `simplex_category` must increase lengths-/
lemma len_le_of_mono {x y : simplex_category} {f : x ⟶ y} :
  mono f → (x.len ≤ y.len) :=
begin
  intro hyp_f_mono,
  have f_inj : function.injective f.to_order_hom.to_fun,
  { exact mono_iff_injective.elim_left (hyp_f_mono) },
  simpa using fintype.card_le_of_injective f.to_order_hom.to_fun f_inj,
end

/-- An epimorphism in `simplex_category` must decrease lengths-/
lemma len_le_of_epi {x y : simplex_category} {f : x ⟶ y} :
  epi f → y.len ≤ x.len :=
begin
  intro hyp_f_epi,
  have f_surj : function.surjective f.to_order_hom.to_fun,
  { exact epi_iff_surjective.elim_left (hyp_f_epi) },
  simpa using fintype.card_le_of_surjective f.to_order_hom.to_fun f_surj,
end

lemma le_of_epi {n m : ℕ} {f : [n] ⟶ [m]} : epi f → (m ≤ n) :=
len_le_of_epi

instance {n : ℕ} {i : fin (n+2)} : mono (δ i) :=
begin
  rw mono_iff_injective,
  exact fin.succ_above_right_injective,
end

instance {n : ℕ} {i : fin (n+1)} : epi (σ i) :=
begin
  rw epi_iff_surjective,
  intro b,
  simp only [σ, mk_hom, hom.to_order_hom_mk, order_hom.coe_fun_mk],
  by_cases b ≤ i,
  { use b,
    rw fin.pred_above_below i b (by simpa only [fin.coe_eq_cast_succ] using h),
    simp only [fin.coe_eq_cast_succ, fin.cast_pred_cast_succ], },
  { use b.succ,
    rw [fin.pred_above_above i b.succ _, fin.pred_succ],
    rw not_le at h,
    rw fin.lt_iff_coe_lt_coe at h ⊢,
    simpa only [fin.coe_succ, fin.coe_cast_succ] using nat.lt.step h, }
end

instance : reflects_isomorphisms (forget simplex_category) :=
⟨begin
  intros x y f,
  introI,
  exact is_iso.of_iso
  { hom := f,
    inv := hom.mk
    { to_fun := inv ((forget simplex_category).map f),
      monotone' :=λ y₁ y₂ h, begin
          by_cases h' : y₁ < y₂,
          { by_contradiction h'',
            have eq := λ i, congr_hom (iso.inv_hom_id (as_iso ((forget _).map f))) i,
            have ineq := f.to_order_hom.monotone' (le_of_not_ge h''),
            dsimp at ineq,
            erw [eq, eq] at ineq,
            exact not_le.mpr h' ineq, },
          { rw eq_of_le_of_not_lt h h', }
        end, },
    hom_inv_id' := by { ext1, ext1, exact iso.hom_inv_id (as_iso ((forget _).map f)), },
    inv_hom_id' := by { ext1, ext1, exact iso.inv_hom_id (as_iso ((forget _).map f)), }, },
end⟩

lemma is_iso_of_bijective {x y : simplex_category} {f : x ⟶ y}
  (hf : function.bijective (f.to_order_hom.to_fun)) : is_iso f :=
begin
  haveI : is_iso ((forget simplex_category).map f) := (is_iso_iff_bijective _).mpr hf,
  exact is_iso_of_reflects_iso f (forget simplex_category),
end

/-- An isomorphism in `simplex_category` induces an `order_iso`. -/
@[simp]
def order_iso_of_iso {x y : simplex_category} (e : x ≅ y) :
  fin (x.len+1) ≃o fin (y.len+1) :=
equiv.to_order_iso
  { to_fun    := e.hom.to_order_hom,
    inv_fun   := e.inv.to_order_hom,
    left_inv  := λ i, by simpa only using congr_arg (λ φ, (hom.to_order_hom φ) i) e.hom_inv_id',
    right_inv := λ i, by simpa only using congr_arg (λ φ, (hom.to_order_hom φ) i) e.inv_hom_id', }
  e.hom.to_order_hom.monotone e.inv.to_order_hom.monotone

lemma iso_eq_iso_refl {x : simplex_category} (e : x ≅ x) :
  e = iso.refl x :=
begin
  have h : (finset.univ : finset (fin (x.len+1))).card = x.len+1 := finset.card_fin (x.len+1),
  have eq₁ := finset.order_emb_of_fin_unique' h
    (λ i, finset.mem_univ ((order_iso_of_iso e) i)),
  have eq₂ := finset.order_emb_of_fin_unique' h
    (λ i, finset.mem_univ ((order_iso_of_iso (iso.refl x)) i)),
  ext1, ext1,
  convert congr_arg (λ φ, (order_embedding.to_order_hom φ)) (eq₁.trans eq₂.symm),
  ext1, ext1 i,
  refl,
end

lemma eq_id_of_is_iso {x : simplex_category} (f : x ⟶ x) [hf : is_iso f] : f = 𝟙 _ :=
congr_arg (λ (φ : _ ≅ _), φ.hom) (iso_eq_iso_refl (as_iso f))

lemma eq_σ_comp_of_not_injective' {n : ℕ} {Δ' : simplex_category} (θ : mk (n+1) ⟶ Δ')
  (i : fin (n+1)) (hi : θ.to_order_hom i.cast_succ = θ.to_order_hom i.succ):
  ∃ (θ' : mk n ⟶ Δ'), θ = σ i ≫ θ' :=
begin
  use δ i.succ ≫ θ,
  ext1, ext1, ext1 x,
  simp only [hom.to_order_hom_mk, function.comp_app, order_hom.comp_coe,
    hom.comp, small_category_comp, σ, mk_hom, order_hom.coe_fun_mk],
  by_cases h' : x ≤ i.cast_succ,
  { rw fin.pred_above_below i x h',
    have eq := fin.cast_succ_cast_pred (gt_of_gt_of_ge (fin.cast_succ_lt_last i) h'),
    erw fin.succ_above_below i.succ x.cast_pred _, swap,
    { rwa [eq, ← fin.le_cast_succ_iff], },
    rw eq, },
  { simp only [not_le] at h',
    let y := x.pred begin
      intro h,
      rw h at h',
      simpa only [fin.lt_iff_coe_lt_coe, nat.not_lt_zero, fin.coe_zero] using h',
    end,
    simp only [show x = y.succ, by rw fin.succ_pred] at h' ⊢,
    rw [fin.pred_above_above i y.succ h', fin.pred_succ],
    by_cases h'' : y = i,
    { rw h'',
      convert hi.symm,
      erw fin.succ_above_below i.succ _,
      exact fin.lt_succ, },
    { erw fin.succ_above_above i.succ _,
      simp only [fin.lt_iff_coe_lt_coe, fin.le_iff_coe_le_coe, fin.coe_succ,
        fin.coe_cast_succ, nat.lt_succ_iff, fin.ext_iff] at h' h'' ⊢,
      cases nat.le.dest h' with c hc,
      cases c,
      { exfalso,
        rw [add_zero] at hc,
        rw [hc] at h'',
        exact h'' rfl, },
      { rw ← hc,
        simp only [add_le_add_iff_left, nat.succ_eq_add_one,
          le_add_iff_nonneg_left, zero_le], }, }, }
end

lemma eq_σ_comp_of_not_injective {n : ℕ} {Δ' : simplex_category} (θ : mk (n+1) ⟶ Δ')
  (hθ : ¬function.injective θ.to_order_hom) :
  ∃ (i : fin (n+1)) (θ' : mk n ⟶ Δ'), θ = σ i ≫ θ' :=
begin
  simp only [function.injective, exists_prop, not_forall] at hθ,
  -- as θ is not injective, there exists `x<y` such that `θ x = θ y`
  -- and then, `θ x = θ (x+1)`
  have hθ₂ : ∃ (x y : fin (n+2)), (hom.to_order_hom θ) x = (hom.to_order_hom θ) y ∧ x<y,
  { rcases hθ with ⟨x, y, ⟨h₁, h₂⟩⟩,
    by_cases x<y,
    { exact ⟨x, y, ⟨h₁, h⟩⟩, },
    { refine ⟨y, x, ⟨h₁.symm, _⟩⟩,
      cases lt_or_eq_of_le (not_lt.mp h) with h' h',
      { exact h', },
      { exfalso,
        exact h₂ h'.symm, }, }, },
  rcases hθ₂ with ⟨x, y, ⟨h₁, h₂⟩⟩,
  let z := x.cast_pred,
  use z,
  simp only [← (show z.cast_succ = x,
    by exact fin.cast_succ_cast_pred (lt_of_lt_of_le h₂ (fin.le_last y)))] at h₁ h₂,
  apply eq_σ_comp_of_not_injective',
  rw fin.cast_succ_lt_iff_succ_le at h₂,
  apply le_antisymm,
  { exact θ.to_order_hom.monotone (le_of_lt (fin.cast_succ_lt_succ z)), },
  { rw h₁,
    exact θ.to_order_hom.monotone h₂, },
end

lemma eq_comp_δ_of_not_surjective' {n : ℕ} {Δ : simplex_category} (θ : Δ ⟶ mk (n+1))
  (i : fin (n+2)) (hi : ∀ x, θ.to_order_hom x ≠ i) :
  ∃ (θ' : Δ ⟶ (mk n)), θ = θ' ≫ δ i :=
begin
  by_cases i < fin.last (n+1),
  { use θ ≫ σ (fin.cast_pred i),
    ext1, ext1, ext1 x,
    simp only [hom.to_order_hom_mk, function.comp_app,
      order_hom.comp_coe, hom.comp, small_category_comp],
    by_cases h' : θ.to_order_hom x ≤ i,
    { simp only [σ, mk_hom, hom.to_order_hom_mk, order_hom.coe_fun_mk],
      rw fin.pred_above_below (fin.cast_pred i) (θ.to_order_hom x)
        (by simpa [fin.cast_succ_cast_pred h] using h'),
      erw fin.succ_above_below i, swap,
      { simp only [fin.lt_iff_coe_lt_coe, fin.coe_cast_succ],
        exact lt_of_le_of_lt (fin.coe_cast_pred_le_self _)
          (fin.lt_iff_coe_lt_coe.mp ((ne.le_iff_lt (hi x)).mp h')), },
      rw fin.cast_succ_cast_pred,
      apply lt_of_le_of_lt h' h, },
    { simp only [not_le] at h',
      simp only [σ, mk_hom, hom.to_order_hom_mk, order_hom.coe_fun_mk,
        fin.pred_above_above (fin.cast_pred i) (θ.to_order_hom x)
        (by simpa only [fin.cast_succ_cast_pred h] using h')],
      erw [fin.succ_above_above i _, fin.succ_pred],
      simpa only [fin.le_iff_coe_le_coe, fin.coe_cast_succ, fin.coe_pred]
          using nat.le_pred_of_lt (fin.lt_iff_coe_lt_coe.mp h'), }, },
  { obtain rfl := le_antisymm (fin.le_last i) (not_lt.mp h),
    use θ ≫ σ (fin.last _),
    ext1, ext1, ext1 x,
    simp only [hom.to_order_hom_mk, function.comp_app, order_hom.comp_coe, hom.comp,
      small_category_comp, σ, δ, mk_hom, order_hom.coe_fun_mk,
      order_embedding.to_order_hom_coe, fin.pred_above_last, fin.succ_above_last,
      fin.cast_succ_cast_pred ((ne.le_iff_lt (hi x)).mp (fin.le_last _))], },
end

lemma eq_comp_δ_of_not_surjective {n : ℕ} {Δ : simplex_category} (θ : Δ ⟶ mk (n+1))
  (hθ : ¬function.surjective θ.to_order_hom) :
  ∃ (i : fin (n+2)) (θ' : Δ ⟶ (mk n)), θ = θ' ≫ δ i :=
begin
  cases not_forall.mp hθ with i hi,
  use i,
  exact eq_comp_δ_of_not_surjective' θ i (not_exists.mp hi),
end

lemma eq_id_of_mono {x : simplex_category} (i : x ⟶ x) [mono i] : i = 𝟙 _ :=
begin
  suffices : is_iso i,
  { haveI := this, apply eq_id_of_is_iso, },
  apply is_iso_of_bijective,
  dsimp,
  rw [fintype.bijective_iff_injective_and_card i.to_order_hom, ← mono_iff_injective,
    eq_self_iff_true, and_true],
  apply_instance,
end

lemma eq_id_of_epi {x : simplex_category} (i : x ⟶ x) [epi i] : i = 𝟙 _ :=
begin
  suffices : is_iso i,
  { haveI := this, apply eq_id_of_is_iso, },
  apply is_iso_of_bijective,
  dsimp,
  rw [fintype.bijective_iff_surjective_and_card i.to_order_hom, ← epi_iff_surjective,
    eq_self_iff_true, and_true],
  apply_instance,
end

lemma eq_σ_of_epi {n : ℕ} (θ : mk (n+1) ⟶ mk n) [epi θ] : ∃ (i : fin (n+1)), θ = σ i :=
begin
  rcases eq_σ_comp_of_not_injective θ _ with ⟨i, θ', h⟩, swap,
  { by_contradiction,
    simpa only [nat.one_ne_zero, add_le_iff_nonpos_right, nonpos_iff_eq_zero]
      using le_of_mono (mono_iff_injective.mpr h), },
  use i,
  haveI : epi (σ i ≫ θ') := by { rw ← h, apply_instance, },
  haveI := category_theory.epi_of_epi (σ i) θ',
  rw [h, eq_id_of_epi θ', category.comp_id],
end

lemma eq_δ_of_mono {n : ℕ} (θ : mk n ⟶ mk (n+1)) [mono θ] : ∃ (i : fin (n+2)), θ = δ i :=
begin
  rcases eq_comp_δ_of_not_surjective θ _ with ⟨i, θ', h⟩, swap,
  { by_contradiction,
    simpa only [add_le_iff_nonpos_right, nonpos_iff_eq_zero]
      using le_of_epi (epi_iff_surjective.mpr h), },
  use i,
  haveI : mono (θ' ≫ δ i) := by { rw ← h, apply_instance, },
  haveI := category_theory.mono_of_mono θ' (δ i),
  rw [h, eq_id_of_mono θ', category.id_comp],
end

lemma len_lt_of_mono {Δ' Δ : simplex_category} (i : Δ' ⟶ Δ) [hi : mono i]
  (hi' : Δ ≠ Δ') : Δ'.len < Δ.len :=
begin
  cases lt_or_eq_of_le (len_le_of_mono hi),
  { exact h, },
  { exfalso,
    exact hi' (by { ext, exact h.symm,}), },
end

noncomputable instance : split_epi_category simplex_category :=
skeletal_equivalence.{0}.inverse.split_epi_category_imp_of_is_equivalence

instance : has_strong_epi_mono_factorisations simplex_category :=
functor.has_strong_epi_mono_factorisations_imp_of_is_equivalence
  simplex_category.skeletal_equivalence.{0}.inverse

instance : has_strong_epi_images simplex_category :=
  limits.has_strong_epi_images_of_has_strong_epi_mono_factorisations

instance (Δ Δ' : simplex_category) (θ : Δ ⟶ Δ') : epi (factor_thru_image θ) := strong_epi.epi

lemma image_eq {Δ Δ' Δ'' : simplex_category } {φ : Δ ⟶ Δ''}
  {e : Δ ⟶ Δ'} [epi e] {i : Δ' ⟶ Δ''} [mono i] (fac : e ≫ i = φ) :
  image φ = Δ' :=
begin
  haveI := strong_epi_of_epi e,
  let e := image.iso_strong_epi_mono e i fac,
  ext,
  exact le_antisymm (len_le_of_epi (infer_instance : epi e.hom))
    (len_le_of_mono (infer_instance : mono e.hom)),
end

lemma image_ι_eq {Δ Δ'' : simplex_category } {φ : Δ ⟶ Δ''}
  {e : Δ ⟶ image φ} [epi e] {i : image φ ⟶ Δ''} [mono i] (fac : e ≫ i = φ) :
  image.ι φ = i :=
begin
  haveI := strong_epi_of_epi e,
  rw [← image.iso_strong_epi_mono_hom_comp_ι e i fac,
    simplex_category.eq_id_of_is_iso (image.iso_strong_epi_mono e i fac).hom, category.id_comp],
end

lemma factor_thru_image_eq {Δ Δ'' : simplex_category } {φ : Δ ⟶ Δ''}
  {e : Δ ⟶ image φ} [epi e] {i : image φ ⟶ Δ''} [mono i] (fac : e ≫ i = φ) :
  factor_thru_image φ = e :=
by rw [← cancel_mono i, fac, ← image_ι_eq fac, image.fac]

end epi_mono

/-- This functor `simplex_category ⥤ Cat` sends `[n]` (for `n : ℕ`)
to the category attached to the ordered set `{0, 1, ..., n}` -/
@[simps obj map]
def to_Cat : simplex_category ⥤ Cat.{0} :=
simplex_category.skeletal_functor ⋙ forget₂ NonemptyFinLinOrd LinOrd ⋙
  forget₂ LinOrd Lat ⋙ forget₂ Lat PartOrd ⋙ forget₂ PartOrd Preord ⋙ Preord_to_Cat

end simplex_category


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

! This file was ported from Lean 3 source module category_theory.limits.filtered_colimit_commutes_finite_limit
! leanprover-community/mathlib commit 3f409bd9df181d26dd223170da7b6830ece18442
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.ColimitLimit
import Mathbin.CategoryTheory.Limits.Preserves.FunctorCategory
import Mathbin.CategoryTheory.Limits.Preserves.Finite
import Mathbin.CategoryTheory.Limits.Shapes.FiniteLimits
import Mathbin.CategoryTheory.Limits.Preserves.Filtered
import Mathbin.CategoryTheory.ConcreteCategory.Basic

/-!
# Filtered colimits commute with finite limits.

We show that for a functor `F : J × K ⥤ Type v`, when `J` is finite and `K` is filtered,
the universal morphism `colimit_limit_to_limit_colimit F` comparing the
colimit (over `K`) of the limits (over `J`) with the limit of the colimits is an isomorphism.

(In fact, to prove that it is injective only requires that `J` has finitely many objects.)

## References
* Borceux, Handbook of categorical algebra 1, Theorem 2.13.4
* [Stacks: Filtered colimits](https://stacks.math.columbia.edu/tag/002W)
-/

universe v u

open CategoryTheory

open CategoryTheory.Category

open CategoryTheory.Limits.Types

open CategoryTheory.Limits.Types.FilteredColimit

namespace CategoryTheory.Limits

variable {J K : Type v} [SmallCategory J] [SmallCategory K]

variable (F : J × K ⥤ Type v)

open CategoryTheory.prod

variable [IsFiltered K]

section

/-!
Injectivity doesn't need that we have finitely many morphisms in `J`,
only that there are finitely many objects.
-/

variable [Finite J]

/-- This follows this proof from
* Borceux, Handbook of categorical algebra 1, Theorem 2.13.4
-/
theorem colimitLimitToLimitColimit_injective : Function.Injective (colimitLimitToLimitColimit F) :=
  by
  classical
    cases nonempty_fintype J
    -- Suppose we have two terms `x y` in the colimit (over `K`) of the limits (over `J`),
    -- and that these have the same image under `colimit_limit_to_limit_colimit F`.
    intro x y h
    -- These elements of the colimit have representatives somewhere:
    obtain ⟨kx, x, rfl⟩ := jointly_surjective'.{v, v} x
    obtain ⟨ky, y, rfl⟩ := jointly_surjective'.{v, v} y
    dsimp at x y
    -- Since the images of `x` and `y` are equal in a limit, they are equal componentwise
    -- (indexed by `j : J`),
    replace h := fun j => congr_arg (limit.π (curry.obj F ⋙ colim) j) h
    -- and they are equations in a filtered colimit,
    -- so for each `j` we have some place `k j` to the right of both `kx` and `ky`
    simp [colimit_eq_iff.{v, v}] at h
    let k j := (h j).some
    let f : ∀ j, kx ⟶ k j := fun j => (h j).choose_spec.some
    let g : ∀ j, ky ⟶ k j := fun j => (h j).choose_spec.choose_spec.some
    -- where the images of the components of the representatives become equal:
    have w :
      ∀ j,
        F.map ((𝟙 j, f j) : (j, kx) ⟶ (j, k j)) (limit.π ((curry.obj (swap K J ⋙ F)).obj kx) j x) =
          F.map ((𝟙 j, g j) : (j, ky) ⟶ (j, k j))
            (limit.π ((curry.obj (swap K J ⋙ F)).obj ky) j y) :=
      fun j => (h j).choose_spec.choose_spec.choose_spec
    -- We now use that `K` is filtered, picking some point to the right of all these
    -- morphisms `f j` and `g j`.
    let O : Finset K := finset.univ.image k ∪ {kx, ky}
    have kxO : kx ∈ O := finset.mem_union.mpr (Or.inr (by simp))
    have kyO : ky ∈ O := finset.mem_union.mpr (Or.inr (by simp))
    have kjO : ∀ j, k j ∈ O := fun j => finset.mem_union.mpr (Or.inl (by simp))
    let H : Finset (Σ'(X Y : K)(mX : X ∈ O)(mY : Y ∈ O), X ⟶ Y) :=
      (Finset.univ.image fun j : J =>
          ⟨kx, k j, kxO, finset.mem_union.mpr (Or.inl (by simp)), f j⟩) ∪
        Finset.univ.image fun j : J => ⟨ky, k j, kyO, finset.mem_union.mpr (Or.inl (by simp)), g j⟩
    obtain ⟨S, T, W⟩ := is_filtered.sup_exists O H
    have fH : ∀ j, (⟨kx, k j, kxO, kjO j, f j⟩ : Σ'(X Y : K)(mX : X ∈ O)(mY : Y ∈ O), X ⟶ Y) ∈ H :=
      fun j =>
      finset.mem_union.mpr
        (Or.inl
          (by
            simp only [true_and_iff, Finset.mem_univ, eq_self_iff_true, exists_prop_of_true,
              Finset.mem_image, heq_iff_eq]
            refine' ⟨j, rfl, _⟩
            simp only [heq_iff_eq]
            exact ⟨rfl, rfl, rfl⟩))
    have gH : ∀ j, (⟨ky, k j, kyO, kjO j, g j⟩ : Σ'(X Y : K)(mX : X ∈ O)(mY : Y ∈ O), X ⟶ Y) ∈ H :=
      fun j =>
      finset.mem_union.mpr
        (Or.inr
          (by
            simp only [true_and_iff, Finset.mem_univ, eq_self_iff_true, exists_prop_of_true,
              Finset.mem_image, heq_iff_eq]
            refine' ⟨j, rfl, _⟩
            simp only [heq_iff_eq]
            exact ⟨rfl, rfl, rfl⟩))
    -- Our goal is now an equation between equivalence classes of representatives of a colimit,
    -- and so it suffices to show those representative become equal somewhere, in particular at `S`.
    apply colimit_sound'.{v, v} (T kxO) (T kyO)
    -- We can check if two elements of a limit (in `Type`) are equal by comparing them componentwise.
    ext
    -- Now it's just a calculation using `W` and `w`.
    simp only [functor.comp_map, limit.map_π_apply, curry_obj_map_app, swap_map]
    rw [← W _ _ (fH j)]
    rw [← W _ _ (gH j)]
    simp [w]
#align category_theory.limits.colimit_limit_to_limit_colimit_injective CategoryTheory.Limits.colimitLimitToLimitColimit_injective

end

variable [FinCategory J]

/-- This follows this proof from
* Borceux, Handbook of categorical algebra 1, Theorem 2.13.4
although with different names.
-/
theorem colimitLimitToLimitColimit_surjective :
    Function.Surjective (colimitLimitToLimitColimit F) := by
  classical
    -- We begin with some element `x` in the limit (over J) over the colimits (over K),
    intro x
    -- This consists of some coherent family of elements in the various colimits,
    -- and so our first task is to pick representatives of these elements.
    have z := fun j => jointly_surjective'.{v, v} (limit.π (curry.obj F ⋙ limits.colim) j x)
    -- `k : J ⟶ K` records where the representative of the element in the `j`-th element of `x` lives
    let k : J → K := fun j => (z j).some
    -- `y j : F.obj (j, k j)` is the representative
    let y : ∀ j, F.obj (j, k j) := fun j => (z j).choose_spec.some
    -- and we record that these representatives, when mapped back into the relevant colimits,
    -- are actually the components of `x`.
    have e :
      ∀ j, colimit.ι ((curry.obj F).obj j) (k j) (y j) = limit.π (curry.obj F ⋙ limits.colim) j x :=
      fun j => (z j).choose_spec.choose_spec
    clear_value k y
    -- A little tidying up of things we no longer need.
    clear z
    -- As a first step, we use that `K` is filtered to pick some point `k' : K` above all the `k j`
    let k' : K := is_filtered.sup (finset.univ.image k) ∅
    -- and name the morphisms as `g j : k j ⟶ k'`.
    have g : ∀ j, k j ⟶ k' := fun j => is_filtered.to_sup (finset.univ.image k) ∅ (by simp)
    clear_value k'
    -- Recalling that the components of `x`, which are indexed by `j : J`, are "coherent",
    -- in other words preserved by morphisms in the `J` direction,
    -- we see that for any morphism `f : j ⟶ j'` in `J`,
    -- the images of `y j` and `y j'`, when mapped to `F.obj (j', k')` respectively by
    -- `(f, g j)` and `(𝟙 j', g j')`, both represent the same element in the colimit.
    have w :
      ∀ {j j' : J} (f : j ⟶ j'),
        colimit.ι ((curry.obj F).obj j') k' (F.map ((𝟙 j', g j') : (j', k j') ⟶ (j', k')) (y j')) =
          colimit.ι ((curry.obj F).obj j') k' (F.map ((f, g j) : (j, k j) ⟶ (j', k')) (y j)) :=
      by
      intro j j' f
      have t :
        (f, g j) = (((f, 𝟙 (k j)) : (j, k j) ⟶ (j', k j)) ≫ (𝟙 j', g j) : (j, k j) ⟶ (j', k')) := by
        simp only [id_comp, comp_id, prod_comp]
      erw [colimit.w_apply', t, functor_to_types.map_comp_apply, colimit.w_apply', e, ←
        limit.w_apply' f, ← e]
      simp
    -- Because `K` is filtered, we can restate this as saying that
    -- for each such `f`, there is some place to the right of `k'`
    -- where these images of `y j` and `y j'` become equal.
    simp_rw [colimit_eq_iff.{v, v}] at w
    -- We take a moment to restate `w` more conveniently.
    let kf : ∀ {j j'} (f : j ⟶ j'), K := fun _ _ f => (w f).some
    let gf : ∀ {j j'} (f : j ⟶ j'), k' ⟶ kf f := fun _ _ f => (w f).choose_spec.some
    let hf : ∀ {j j'} (f : j ⟶ j'), k' ⟶ kf f := fun _ _ f => (w f).choose_spec.choose_spec.some
    have wf :
      ∀ {j j'} (f : j ⟶ j'),
        F.map ((𝟙 j', g j' ≫ gf f) : (j', k j') ⟶ (j', kf f)) (y j') =
          F.map ((f, g j ≫ hf f) : (j, k j) ⟶ (j', kf f)) (y j) :=
      fun j j' f =>
      by
      have q :
        ((curry.obj F).obj j').map (gf f) (F.map _ (y j')) =
          ((curry.obj F).obj j').map (hf f) (F.map _ (y j)) :=
        (w f).choose_spec.choose_spec.choose_spec
      dsimp at q
      simp_rw [← functor_to_types.map_comp_apply] at q
      convert q <;> simp only [comp_id]
    clear_value kf gf hf
    -- and clean up some things that are no longer needed.
    clear w
    -- We're now ready to use the fact that `K` is filtered a second time,
    -- picking some place to the right of all of
    -- the morphisms `gf f : k' ⟶ kh f` and `hf f : k' ⟶ kf f`.
    -- At this point we're relying on there being only finitely morphisms in `J`.
    let O :=
      (finset.univ.bUnion fun j => finset.univ.bUnion fun j' => finset.univ.image (@kf j j')) ∪ {k'}
    have kfO : ∀ {j j'} (f : j ⟶ j'), kf f ∈ O := fun j j' f =>
      finset.mem_union.mpr
        (Or.inl
          (by
            rw [Finset.mem_bunionᵢ]
            refine' ⟨j, Finset.mem_univ j, _⟩
            rw [Finset.mem_bunionᵢ]
            refine' ⟨j', Finset.mem_univ j', _⟩
            rw [Finset.mem_image]
            refine' ⟨f, Finset.mem_univ _, _⟩
            rfl))
    have k'O : k' ∈ O := finset.mem_union.mpr (Or.inr (finset.mem_singleton.mpr rfl))
    let H : Finset (Σ'(X Y : K)(mX : X ∈ O)(mY : Y ∈ O), X ⟶ Y) :=
      finset.univ.bUnion fun j : J =>
        finset.univ.bUnion fun j' : J =>
          finset.univ.bUnion fun f : j ⟶ j' =>
            {⟨k', kf f, k'O, kfO f, gf f⟩, ⟨k', kf f, k'O, kfO f, hf f⟩}
    obtain ⟨k'', i', s'⟩ := is_filtered.sup_exists O H
    -- We then restate this slightly more conveniently, as a family of morphism `i f : kf f ⟶ k''`,
    -- satisfying `gf f ≫ i f = hf f' ≫ i f'`.
    let i : ∀ {j j'} (f : j ⟶ j'), kf f ⟶ k'' := fun j j' f => i' (kfO f)
    have s : ∀ {j₁ j₂ j₃ j₄} (f : j₁ ⟶ j₂) (f' : j₃ ⟶ j₄), gf f ≫ i f = hf f' ≫ i f' :=
      by
      intros
      rw [s', s']
      swap
      exact k'O
      swap
      · rw [Finset.mem_bunionᵢ]
        refine' ⟨j₁, Finset.mem_univ _, _⟩
        rw [Finset.mem_bunionᵢ]
        refine' ⟨j₂, Finset.mem_univ _, _⟩
        rw [Finset.mem_bunionᵢ]
        refine' ⟨f, Finset.mem_univ _, _⟩
        simp only [true_or_iff, eq_self_iff_true, and_self_iff, Finset.mem_insert, heq_iff_eq]
      · rw [Finset.mem_bunionᵢ]
        refine' ⟨j₃, Finset.mem_univ _, _⟩
        rw [Finset.mem_bunionᵢ]
        refine' ⟨j₄, Finset.mem_univ _, _⟩
        rw [Finset.mem_bunionᵢ]
        refine' ⟨f', Finset.mem_univ _, _⟩
        simp only [eq_self_iff_true, or_true_iff, and_self_iff, Finset.mem_insert,
          Finset.mem_singleton, heq_iff_eq]
    clear_value i
    clear s' i' H kfO k'O O
    -- We're finally ready to construct the pre-image, and verify it really maps to `x`.
    fconstructor
    · -- We construct the pre-image (which, recall is meant to be a point
      -- in the colimit (over `K`) of the limits (over `J`)) via a representative at `k''`.
      apply colimit.ι (curry.obj (swap K J ⋙ F) ⋙ limits.lim) k'' _
      dsimp
      -- This representative is meant to be an element of a limit,
      -- so we need to construct a family of elements in `F.obj (j, k'')` for varying `j`,
      -- then show that are coherent with respect to morphisms in the `j` direction.
      apply Limit.mk.{v, v}
      swap
      ·-- We construct the elements as the images of the `y j`.
        exact fun j => F.map (⟨𝟙 j, g j ≫ gf (𝟙 j) ≫ i (𝟙 j)⟩ : (j, k j) ⟶ (j, k'')) (y j)
      · -- After which it's just a calculation, using `s` and `wf`, to see they are coherent.
        dsimp
        intro j j' f
        simp only [← functor_to_types.map_comp_apply, prod_comp, id_comp, comp_id]
        calc
          F.map ((f, g j ≫ gf (𝟙 j) ≫ i (𝟙 j)) : (j, k j) ⟶ (j', k'')) (y j) =
              F.map ((f, g j ≫ hf f ≫ i f) : (j, k j) ⟶ (j', k'')) (y j) :=
            by rw [s (𝟙 j) f]
          _ =
              F.map ((𝟙 j', i f) : (j', kf f) ⟶ (j', k''))
                (F.map ((f, g j ≫ hf f) : (j, k j) ⟶ (j', kf f)) (y j)) :=
            by rw [← functor_to_types.map_comp_apply, prod_comp, comp_id, assoc]
          _ =
              F.map ((𝟙 j', i f) : (j', kf f) ⟶ (j', k''))
                (F.map ((𝟙 j', g j' ≫ gf f) : (j', k j') ⟶ (j', kf f)) (y j')) :=
            by rw [← wf f]
          _ = F.map ((𝟙 j', g j' ≫ gf f ≫ i f) : (j', k j') ⟶ (j', k'')) (y j') := by
            rw [← functor_to_types.map_comp_apply, prod_comp, id_comp, assoc]
          _ = F.map ((𝟙 j', g j' ≫ gf (𝟙 j') ≫ i (𝟙 j')) : (j', k j') ⟶ (j', k'')) (y j') := by
            rw [s f (𝟙 j'), ← s (𝟙 j') (𝟙 j')]

    -- Finally we check that this maps to `x`.
    · -- We can do this componentwise:
      apply limit_ext'
      intro j
      -- and as each component is an equation in a colimit, we can verify it by
      -- pointing out the morphism which carries one representative to the other:
      simp only [← e, colimit_eq_iff.{v, v}, curry_obj_obj_map, limit.π_mk', bifunctor.map_id_comp,
        id.def, types_comp_apply, limits.ι_colimit_limit_to_limit_colimit_π_apply]
      refine' ⟨k'', 𝟙 k'', g j ≫ gf (𝟙 j) ≫ i (𝟙 j), _⟩
      simp only [bifunctor.map_id_comp, types_comp_apply, bifunctor.map_id, types_id_apply]
#align category_theory.limits.colimit_limit_to_limit_colimit_surjective CategoryTheory.Limits.colimitLimitToLimitColimit_surjective

instance colimitLimitToLimitColimit_isIso : IsIso (colimitLimitToLimitColimit F) :=
  (isIso_iff_bijective _).mpr
    ⟨colimitLimitToLimitColimit_injective F, colimitLimitToLimitColimit_surjective F⟩
#align category_theory.limits.colimit_limit_to_limit_colimit_is_iso CategoryTheory.Limits.colimitLimitToLimitColimit_isIso

instance colimitLimitToLimitColimitCone_iso (F : J ⥤ K ⥤ Type v) :
    IsIso (colimitLimitToLimitColimitCone F) :=
  by
  have : is_iso (colimit_limit_to_limit_colimit_cone F).Hom :=
    by
    dsimp only [colimit_limit_to_limit_colimit_cone]
    infer_instance
  apply cones.cone_iso_of_hom_iso
#align category_theory.limits.colimit_limit_to_limit_colimit_cone_iso CategoryTheory.Limits.colimitLimitToLimitColimitCone_iso

noncomputable instance filteredColimPreservesFiniteLimitsOfTypes :
    PreservesFiniteLimits (colim : (K ⥤ Type v) ⥤ _) :=
  by
  apply preservesFiniteLimitsOfPreservesFiniteLimitsOfSize.{v}
  intro J _ _; skip; constructor
  intro F; constructor
  intro c hc
  apply is_limit.of_iso_limit (limit.is_limit _)
  symm; trans colim.map_cone (limit.cone F)
  exact functor.map_iso _ (hc.unique_up_to_iso (limit.is_limit F))
  exact as_iso (colimitLimitToLimitColimitCone.{v, v + 1} F)
#align category_theory.limits.filtered_colim_preserves_finite_limits_of_types CategoryTheory.Limits.filteredColimPreservesFiniteLimitsOfTypes

variable {C : Type u} [Category.{v} C] [ConcreteCategory.{v} C]

section

variable [HasLimitsOfShape J C] [HasColimitsOfShape K C]

variable [ReflectsLimitsOfShape J (forget C)] [PreservesColimitsOfShape K (forget C)]

variable [PreservesLimitsOfShape J (forget C)]

noncomputable instance filteredColimPreservesFiniteLimits :
    PreservesLimitsOfShape J (colim : (K ⥤ C) ⥤ _) :=
  haveI : preserves_limits_of_shape J ((colim : (K ⥤ C) ⥤ _) ⋙ forget C) :=
    preserves_limits_of_shape_of_nat_iso (preserves_colimit_nat_iso _).symm
  preserves_limits_of_shape_of_reflects_of_preserves _ (forget C)
#align category_theory.limits.filtered_colim_preserves_finite_limits CategoryTheory.Limits.filteredColimPreservesFiniteLimits

end

attribute [local instance] reflects_limits_of_shape_of_reflects_isomorphisms

noncomputable instance [PreservesFiniteLimits (forget C)] [PreservesFilteredColimits (forget C)]
    [HasFiniteLimits C] [HasColimitsOfShape K C] [ReflectsIsomorphisms (forget C)] :
    PreservesFiniteLimits (colim : (K ⥤ C) ⥤ _) :=
  by
  apply preservesFiniteLimitsOfPreservesFiniteLimitsOfSize.{v}
  intro J _ _; skip; infer_instance

section

variable [HasLimitsOfShape J C] [HasColimitsOfShape K C]

variable [ReflectsLimitsOfShape J (forget C)] [PreservesColimitsOfShape K (forget C)]

variable [PreservesLimitsOfShape J (forget C)]

/-- A curried version of the fact that filtered colimits commute with finite limits. -/
noncomputable def colimitLimitIso (F : J ⥤ K ⥤ C) : colimit (limit F) ≅ limit (colimit F.flip) :=
  (isLimitOfPreserves colim (limit.isLimit _)).conePointUniqueUpToIso (limit.isLimit _) ≪≫
    HasLimit.isoOfNatIso (colimitFlipIsoCompColim _).symm
#align category_theory.limits.colimit_limit_iso CategoryTheory.Limits.colimitLimitIso

@[simp, reassoc.1]
theorem ι_colimitLimitIso_limit_π (F : J ⥤ K ⥤ C) (a) (b) :
    colimit.ι (limit F) a ≫ (colimitLimitIso F).Hom ≫ limit.π (colimit F.flip) b =
      (limit.π F b).app a ≫ (colimit.ι F.flip a).app b :=
  by
  dsimp [colimit_limit_iso]
  simp only [functor.map_cone_π_app, iso.symm_hom,
    limits.limit.cone_point_unique_up_to_iso_hom_comp_assoc, limits.limit.cone_π,
    limits.colimit.ι_map_assoc, limits.colimit_flip_iso_comp_colim_inv_app, assoc,
    limits.has_limit.iso_of_nat_iso_hom_π]
  congr 1
  simp only [← category.assoc, iso.comp_inv_eq,
    limits.colimit_obj_iso_colimit_comp_evaluation_ι_app_hom,
    limits.has_colimit.iso_of_nat_iso_ι_hom, nat_iso.of_components_hom_app]
  dsimp
  simp
#align category_theory.limits.ι_colimit_limit_iso_limit_π CategoryTheory.Limits.ι_colimitLimitIso_limit_π

end

end CategoryTheory.Limits


/-
Copyright (c) 2022 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz, Junyan Xu
-/
import ring_theory.localization.localization_localization

/-!

# Localizations of domains as subalgebras of the fraction field.

Given a domain `A` with fraction field `K`, and a submonoid `S` of `A` which
does not contain zero, this file constructs the localization of `A` at `S`
as a subalgebra of the field `K` over `A`.

-/

namespace localization
open_locale non_zero_divisors
variables {A : Type*} (K : Type*) [comm_ring A] (S : submonoid A) (hS : S ≤ A⁰)

section comm_ring
variables [comm_ring K] [algebra A K] [is_fraction_ring A K]

lemma map_is_unit_of_le (hS : S ≤ A⁰) (s : S) : is_unit (algebra_map A K s) :=
by apply is_localization.map_units K (⟨s.1, hS s.2⟩ : A⁰)

/-- The canonical map from a localization of `A` at `S` to the fraction ring
  of `A`, given that `S ≤ A⁰`. -/
noncomputable
def map_to_fraction_ring (B : Type*) [comm_ring B] [algebra A B]
  [is_localization S B] (hS : S ≤ A⁰) :
  B →ₐ[A] K :=
{ commutes' := λ a, by simp,
  ..is_localization.lift (map_is_unit_of_le K S hS) }

@[simp]
lemma map_to_fraction_ring_apply {B : Type*} [comm_ring B] [algebra A B]
  [is_localization S B] (hS : S ≤ A⁰) (b : B) :
  map_to_fraction_ring K S B hS b = is_localization.lift (map_is_unit_of_le K S hS) b := rfl

lemma mem_range_map_to_fraction_ring_iff (B : Type*) [comm_ring B] [algebra A B]
  [is_localization S B] (hS : S ≤ A⁰) (x : K) :
  x ∈ (map_to_fraction_ring K S B hS).range ↔
  ∃ (a s : A) (hs : s ∈ S), x = is_localization.mk' K a ⟨s, hS hs⟩ :=
⟨ by { rintro ⟨x,rfl⟩, obtain ⟨a,s,rfl⟩ := is_localization.mk'_surjective S x,
    use [a, s, s.2], apply is_localization.lift_mk' },
  by { rintro ⟨a,s,hs,rfl⟩, use is_localization.mk' _ a ⟨s,hs⟩,
    apply is_localization.lift_mk' } ⟩

instance is_localization_range_map_to_fraction_ring (B : Type*) [comm_ring B] [algebra A B]
  [is_localization S B] (hS : S ≤ A⁰) :
  is_localization S (map_to_fraction_ring K S B hS).range :=
is_localization.is_localization_of_alg_equiv S $ show B ≃ₐ[A] _, from alg_equiv.of_bijective
(map_to_fraction_ring K S B hS).range_restrict
begin
  refine ⟨λ a b h, _, set.surjective_onto_range⟩,
  refine (is_localization.lift_injective_iff _).2 (λ a b, _) (subtype.ext_iff.1 h),
  exact ⟨λ h, congr_arg _ (is_localization.injective _ hS h),
         λ h, congr_arg _ (is_fraction_ring.injective A K h)⟩,
end

instance is_fraction_ring_range_map_to_fraction_ring
  (B : Type*) [comm_ring B] [algebra A B]
  [is_localization S B] (hS : S ≤ A⁰) :
  is_fraction_ring (map_to_fraction_ring K S B hS).range K :=
is_fraction_ring.is_fraction_ring_of_is_localization S _ _ hS

/--
Given a commutative ring `A` with fraction ring `K`, and a submonoid `S` of `A` which
contains no zero divisor, this is the localization of `A` at `S`, considered as
a subalgebra of `K` over `A`.

The carrier of this subalgebra is defined as the set of all `x : K` of the form
`is_localization.mk' K a ⟨s, _⟩`, where `s ∈ S`.
-/
noncomputable
def subalgebra (hS : S ≤ A⁰) : subalgebra A K :=
(map_to_fraction_ring K S (localization S) hS).range.copy
{ x | ∃ (a s : A) (hs : s ∈ S), x = is_localization.mk' K a ⟨s, hS hs⟩ } $
by { ext, symmetry, apply mem_range_map_to_fraction_ring_iff }

namespace subalgebra

instance is_localization_subalgebra :
  is_localization S (subalgebra K S hS) :=
by { dunfold localization.subalgebra, rw subalgebra.copy_eq, apply_instance }

instance is_fraction_ring : is_fraction_ring (subalgebra K S hS) K :=
is_fraction_ring.is_fraction_ring_of_is_localization S _ _ hS

end subalgebra
end comm_ring

section field
variables [field K] [algebra A K] [is_fraction_ring A K]
namespace subalgebra

lemma mem_range_map_to_fraction_ring_iff_of_field
  (B : Type*) [comm_ring B] [algebra A B] [is_localization S B] (x : K) :
  x ∈ (map_to_fraction_ring K S B hS).range ↔
  ∃ (a s : A) (hs : s ∈ S), x = algebra_map A K a * (algebra_map A K s)⁻¹ :=
begin
  rw mem_range_map_to_fraction_ring_iff,
  iterate 3 { congr' with }, convert iff.rfl, rw units.coe_inv, refl,
end

/--
Given a domain `A` with fraction field `K`, and a submonoid `S` of `A` which
contains no zero divisor, this is the localization of `A` at `S`, considered as
a subalgebra of `K` over `A`.

The carrier of this subalgebra is defined as the set of all `x : K` of the form
`algebra_map A K a * (algebra_map A K s)⁻¹` where `a s : A` and `s ∈ S`.
-/
noncomputable
def of_field : _root_.subalgebra A K :=
(map_to_fraction_ring K S (localization S) hS).range.copy
{ x | ∃ (a s : A) (hs : s ∈ S), x = algebra_map A K a * (algebra_map A K s)⁻¹ } $
by { ext, symmetry, apply mem_range_map_to_fraction_ring_iff_of_field }

instance is_localization_of_field :
  is_localization S (subalgebra.of_field K S hS) :=
by { dunfold localization.subalgebra.of_field, rw subalgebra.copy_eq, apply_instance }

instance is_fraction_ring_of_field : is_fraction_ring (subalgebra.of_field K S hS) K :=
is_fraction_ring.is_fraction_ring_of_is_localization S _ _ hS

end subalgebra
end field

end localization


/- bits and bobs, many of which should probably be in mathlib

by Kenny Lau
-/

import algebra.module linear_algebra.quotient_module
import tactic.ring analysis.topology.topological_space
import order.complete_lattice order.order_iso
import ring_theory.ideals group_theory.submonoid
import localization

universes u v w

lemma setoid.r_of_eq {α : Sort u} [s : setoid α] {x y : α} : x = y → x ≈ y :=
eq.rec $ setoid.refl _

namespace is_ideal

variables {α : Type u} [comm_ring α]
variables (S : set α) [is_ideal S] (x y : α)

variables {S x y}

lemma neg : x ∈ S → -x ∈ S :=
λ hx, is_submodule.neg hx

lemma of_neg : -x ∈ S → x ∈ S :=
λ hx, set.mem_of_eq_of_mem (neg_neg x).symm (is_submodule.neg hx)

lemma of_add_left : x + y ∈ S → x ∈ S → y ∈ S :=
λ hxy hx, set.mem_of_eq_of_mem (add_sub_cancel' x y).symm (is_submodule.sub hxy hx)

lemma of_add_right : x + y ∈ S → y ∈ S → x ∈ S :=
λ hxy hy, set.mem_of_eq_of_mem (add_sub_cancel x y).symm (is_submodule.sub hxy hy)

lemma of_sub_left : x - y ∈ S → x ∈ S → y ∈ S :=
λ hxy hx, set.mem_of_eq_of_mem (sub_sub_cancel x y).symm (is_submodule.sub hx hxy)

lemma of_sub_right : x - y ∈ S → y ∈ S → x ∈ S :=
λ hxy hy, set.mem_of_eq_of_mem (sub_add_cancel x y).symm (is_submodule.add hxy hy)

instance single_zero : is_ideal ({0}:set α) :=
{ ..is_submodule.single_zero }

end is_ideal

instance is_submodule.to_is_ideal {α : Type u} [comm_ring α] (S : set α)
  (H : is_submodule S) : is_ideal S :=
{ ..H }

theorem is_submodule.smul' {α : Type u} [comm_ring α] {p : set α} [c : is_submodule p]
  {x : α} (y : α) : x ∈ p → x * y ∈ p :=
λ h, calc x * y = y * x : mul_comm _ _
            ... ∈ p : is_submodule.smul y h

theorem is_proper_ideal.one_not_mem {α : Type u} [comm_ring α] {S : set α} [is_proper_ideal S] : (1:α) ∉ S :=
λ h, is_proper_ideal.ne_univ S $ is_submodule.univ_of_one_mem S h

theorem is_proper_ideal.not_mem_of_mul_right_one {α : Type u} [comm_ring α] {S : set α} [is_proper_ideal S]
  {u v : α} (huv : u * v = 1) : u ∉ S :=
λ hu, have h : (1:α) ∈ S, from huv ▸ is_ideal.mul_right hu,
is_proper_ideal.one_not_mem h

theorem is_proper_ideal.not_mem_of_mul_left_one {α : Type u} [comm_ring α] {S : set α} [is_proper_ideal S]
  {u v : α} (huv : u * v = 1) : v ∉ S :=
λ hv, have h : (1:α) ∈ S, from huv ▸ is_ideal.mul_left hv,
is_proper_ideal.one_not_mem h

local infix ^ := monoid.pow

theorem is_prime_ideal.mem_of_pow_mem {α : Type u} [comm_ring α] {S : set α} [is_prime_ideal S]
  {x : α} {n : ℕ} (hx : x^n ∈ S) : x ∈ S :=
(nat.rec_on n
   (λ h, false.elim $ is_proper_ideal.ne_univ S $
      is_submodule.univ_of_one_mem S h)
   (λ n ih h, or.cases_on
      (is_prime_ideal.mem_or_mem_of_mul_mem h)
      id ih))
hx

instance is_maximal_ideal.to_is_prime_ideal {α : Type u} [comm_ring α] {S : set α} (hs : is_maximal_ideal S) : is_prime_ideal S :=
{ mem_or_mem_of_mul_mem :=
  λ x y hxy,
  have hsx : S ⊆ span (insert x S),
  from set.subset.trans (set.subset_insert x S) subset_span,
  have hsx2 : _,
  from is_maximal_ideal.eq_or_univ_of_subset _ hsx,
  have hsy : S ⊆ span (insert y S),
  from set.subset.trans (set.subset_insert y S) subset_span,
  have hsy2 : _,
  from is_maximal_ideal.eq_or_univ_of_subset _ hsy,
  begin
    rw span_insert at hsx hsx2 hsy hsy2,
    rw [set.ext_iff, set.ext_iff] at hsx2 hsy2,
    cases hsx2 with hx hx,
    { left,
      rw ← hx x,
      exact ⟨1, 0, @@is_submodule.zero _ _ is_submodule_span, by simp⟩ },
    { cases hsy2 with hy hy,
      { right,
        rw ← hy y,
        exact ⟨1, 0, @@is_submodule.zero _ _ is_submodule_span, by simp⟩ },
      { specialize hx 1,
        specialize hy 1,
        simp at hx hy,
        rcases hx with ⟨x1, x2, hx1, hx2⟩,
        rcases hy with ⟨y1, y2, hy1, hy2⟩,
        exfalso,
        apply is_proper_ideal.ne_univ S,
        apply is_submodule.univ_of_one_mem S,
        rw @span_eq_of_is_submodule _ _ _ _ S _ at hx1 hy1,
        exact calc
        (1:α) = (x2 + x1 * x) * (y2 + y1 * y) : by simp [hx2.symm, hy2.symm]
          ... = x2 * y2 + (y1 * y) * x2 + (x1 * x) * y2 + (x1 * y1) * (x * y) : by ring
          ... ∈ S : is_submodule.add
            (is_submodule.add
               (is_submodule.add
                  (is_submodule.smul x2 hy1)
                  (is_submodule.smul (y1 * y) hx1))
               (is_submodule.smul (x1 * x) hy1))
            (is_submodule.smul _ hxy),
        repeat { apply_instance } } }
  end }

/-
theorem is_ring_hom.comp {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring α] [comm_ring β] [comm_ring γ] (f : α → β) (g : β → γ)
  [is_ring_hom f] [is_ring_hom g] : is_ring_hom (g ∘ f) :=
by refine {..}; intros; simp [is_ring_hom.map_add f, is_ring_hom.map_add g,
  is_ring_hom.map_mul f, is_ring_hom.map_mul g,
  is_ring_hom.map_one f, is_ring_hom.map_one g]
-/
structure ring_equiv (α : Type u) (β : Type v) [comm_ring α] [comm_ring β] extends equiv α β :=
(is_ring_hom : is_ring_hom to_fun)

infix ` ≃ᵣ `:25 := ring_equiv

namespace ring_equiv

variables {α : Type u} {β : Type v} {γ : Type w}
variables [comm_ring α] [comm_ring β] [comm_ring γ]

variable α

protected def refl : α ≃ᵣ α :=
{ is_ring_hom := by refine {..}; intros; refl,
  .. equiv.refl α }

variable {α}

-- Kevin needs explicit access to this
definition inv_fun_is_ring_hom (f : α ≃ᵣ β) : _root_.is_ring_hom f.inv_fun :=
{ map_add := λ x y, calc
              f.inv_fun (x + y)
            = f.inv_fun (f.to_fun (f.inv_fun x) + f.to_fun (f.inv_fun y)) : by rw [f.right_inv, f.right_inv]
        ... = f.inv_fun (f.to_fun (f.inv_fun x + f.inv_fun y)) : by simp [f.is_ring_hom.map_add]
        ... = f.inv_fun x + f.inv_fun y : f.left_inv _,
      map_mul := λ x y, calc
              f.inv_fun (x * y)
            = f.inv_fun (f.to_fun (f.inv_fun x) * f.to_fun (f.inv_fun y)) : by rw [f.right_inv, f.right_inv]
        ... = f.inv_fun (f.to_fun (f.inv_fun x * f.inv_fun y)) : by simp [f.is_ring_hom.map_mul]
        ... = f.inv_fun x * f.inv_fun y : f.left_inv _,
      map_one := calc
              f.inv_fun 1
            = f.inv_fun (f.to_fun 1) : by simp [f.is_ring_hom.map_one]
        ... = 1 : f.left_inv 1 }

protected def symm (f : α ≃ᵣ β) : β ≃ᵣ α :=
{ is_ring_hom := inv_fun_is_ring_hom f,
  .. equiv.symm f.to_equiv }

protected def trans (f : α ≃ᵣ β) (g : β ≃ᵣ γ) : α ≃ᵣ γ :=
{ is_ring_hom := @is_ring_hom.comp _ _ _ _ f.to_fun f.is_ring_hom _ _ g.to_fun g.is_ring_hom,
  .. equiv.trans f.to_equiv g.to_equiv }

end ring_equiv

def is_submodule.hom_preimage {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
(f : α → β) [is_ring_hom f] (S : set β) [is_submodule S] : is_submodule (f ⁻¹' S) :=
{ zero_ := by simpa [is_ring_hom.map_zero f] using @is_submodule.zero β β _ _ S _,
  add_  := λ x y (hx : f x ∈ S) hy, by simp [is_ring_hom.map_add f, is_submodule.add hx hy],
  smul  := λ x y (hy : f y ∈ S), by simp [is_ring_hom.map_mul f]; exact is_submodule.smul _ hy }

def is_prime_ideal.hom_preimage {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
(f : α → β) [is_ring_hom f] (S : set β) [is_prime_ideal S] :
  @is_prime_ideal α _ ((f)⁻¹' S) :=
{ (is_submodule.hom_preimage f S : is_submodule (f ⁻¹' S)) with
  ne_univ := λ h, have (1:α) ∈ f ⁻¹' S, by rw h; trivial,
   is_proper_ideal.ne_univ S $ is_submodule.univ_of_one_mem S $ by simpa [is_ring_hom.map_one f] using this,
  mem_or_mem_of_mul_mem := λ x y, by simpa [is_ring_hom.map_mul f] using @@is_prime_ideal.mem_or_mem_of_mul_mem _ _inst_4,
  .. is_submodule.hom_preimage f S }

namespace is_ideal

variables (α : Type u) [comm_ring α] (S : set α) [is_submodule S]

instance : setoid α := is_submodule.quotient_rel S

infix ` /ᵣ `:100 := quotient_module.quotient
include S

instance quotient.has_mul : has_mul (α /ᵣ S) :=
⟨quotient.lift₂ (λ m n, ⟦m * n⟧) (λ m₁ m₂ n₁ n₂ (h₁ : m₁ - n₁ ∈ S) (h₂ : m₂ - n₂ ∈ S), quot.sound $
suffices (m₁ * m₂) - (n₁ * n₂) ∈ S, from this,
calc  (m₁ * m₂) - (n₁ * n₂)
    = m₁ * (m₂ - n₂) + n₂ * (m₁ - n₁) : by ring
... ∈ S : is_submodule.add (is_submodule.smul m₁ h₂) (is_submodule.smul n₂ h₁))⟩

instance quotient.comm_ring (α : Type u) [comm_ring α] (S : set α) [is_submodule S] :
  comm_ring (α /ᵣ S) :=
by refine
{ mul            := (*),
  mul_assoc      := λ m n k, quotient.induction_on₃ m n k _,
  one            := ⟦1⟧,
  one_mul        := quotient.ind _,
  mul_one        := quotient.ind _,
  left_distrib   := λ m n k, quotient.induction_on₃ m n k _,
  right_distrib  := λ m n k, quotient.induction_on₃ m n k _,
  mul_comm       := quotient.ind₂ _,
  ..quotient_module.quotient.add_comm_group S };
{ intros; apply quotient.sound; ring }

def mk' : α → α /ᵣ S := @quotient.mk _ (is_submodule.quotient_rel S)

instance : add_comm_group (α /ᵣ S) := ring.to_add_comm_group (α /ᵣ S)
instance : add_group (α /ᵣ S) := by apply_instance
instance : has_add (α /ᵣ S) := by apply_instance
instance : comm_ring (α /ᵣ S) := by apply_instance
instance : has_mul (α /ᵣ S) := by apply_instance

def to_quotient : is_ring_hom (mk' α S) :=
by refine {..}; intros; refl

variables (x y : α)

lemma coset_eq : ⟦x⟧ = mk' α S x := rfl
@[simp] lemma add_coset : mk' α S x + mk' α S y = mk' α S (x + y) := rfl
@[simp] lemma neg_coset : -mk' α S x = mk' α S (-x) := rfl
@[simp] lemma sub_coset : mk' α S x - mk' α S y = mk' α S (x - y) := rfl
@[simp] lemma mul_coset : mk' α S x * mk' α S y = mk' α S (x * y) := rfl
@[simp] lemma one_coset : 1 = mk' α S 1 := rfl

@[simp] lemma quotient.lift_beta {β : Sort v} (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α):
quotient.lift f h (mk' α S x) = f x := rfl

@[simp] lemma quotient.lift_on_beta {β : Sort v} (f : α → β) (h : ∀ (a b : α), a ≈ b → f a = f b) (x : α):
quotient.lift_on (mk' α S x) f h = f x := rfl

end is_ideal

lemma is_ideal_span {α : Type u} [comm_ring α] {S : set α} :
  is_ideal (span S) :=
{ ..is_submodule_span }

class subring (α : Type u) [comm_ring α] (S : set α) : Prop :=
(add_mem : ∀ {x y}, x ∈ S → y ∈ S → x + y ∈ S)
(neg_mem : ∀ {x}, x ∈ S → -x ∈ S)
(mul_mem : ∀ {x y}, x ∈ S → y ∈ S → x * y ∈ S)
(one_mem : (1:α) ∈ S)

namespace subring

variables (α : Type u) [comm_ring α] (S : set α) [subring α S]

instance : comm_ring S :=
{ add            := λ ⟨x, hx⟩ ⟨y, hy⟩, ⟨x + y, add_mem hx hy⟩,
  add_assoc      := λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩, subtype.eq $ add_assoc x y z,
  zero           := ⟨0, eq.subst (add_neg_self (1:α)) $ add_mem (one_mem S) $ neg_mem $ one_mem S⟩,
  zero_add       := λ ⟨x, hx⟩, subtype.eq $ zero_add x,
  add_zero       := λ ⟨x, hx⟩, subtype.eq $ add_zero x,
  neg            := λ ⟨x, hx⟩, ⟨-x, neg_mem hx⟩,
  add_left_neg   := λ ⟨x, hx⟩, subtype.eq $ add_left_neg x,
  add_comm       := λ ⟨x, hx⟩ ⟨y, hy⟩, subtype.eq $ add_comm x y,
  mul            := λ ⟨x, hx⟩ ⟨y, hy⟩, ⟨x * y, mul_mem hx hy⟩,
  mul_assoc      := λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩, subtype.eq $ mul_assoc x y z,
  one            := ⟨1, one_mem S⟩,
  one_mul        := λ ⟨x, hx⟩, subtype.eq $ one_mul x,
  mul_one        := λ ⟨x, hx⟩, subtype.eq $ mul_one x,
  left_distrib   := λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩, subtype.eq $ left_distrib x y z,
  right_distrib  := λ ⟨x, hx⟩ ⟨y, hy⟩ ⟨z, hz⟩, subtype.eq $ right_distrib x y z,
  mul_comm       := λ ⟨x, hx⟩ ⟨y, hy⟩, subtype.eq $ mul_comm x y }

instance : add_comm_group S := ring.to_add_comm_group S
instance : has_add S := add_semigroup.to_has_add S

@[simp] lemma add (x y : α) (hx : x ∈ S) (hy : y ∈ S) :
(⟨x, hx⟩ : S) + ⟨y, hy⟩ = ⟨x + y, add_mem hx hy⟩ := rfl

@[simp] lemma mul (x y : α) (hx : x ∈ S) (hy : y ∈ S) :
(⟨x, hx⟩ : S) * ⟨y, hy⟩ = ⟨x * y, mul_mem hx hy⟩ := rfl

def is_ring_hom : is_ring_hom ((λ x, x) : S → α) :=
{ map_add := λ x y, by cases x; cases y; refl,
  map_mul := λ x y, by cases x; cases y; refl,
  map_one := rfl }

end subring

namespace is_ring_hom

variables {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
variables (f : α → β) [is_ring_hom f] {x y : α}

@[reducible] def ker : set α := f⁻¹' {0}
instance ker.is_submodule : is_submodule (ker f) := is_submodule.hom_preimage f {0}
instance ker.is_ideal : is_ideal (ker f) := { .. ker.is_submodule f}

@[reducible] def im : set β := { y | ∃ x, f x = y }
instance im.subring : subring β (im f) :=
{ add_mem := λ x y ⟨m, hm⟩ ⟨n, hn⟩, ⟨m + n, by simp [map_add f, hm, hn]⟩,
  neg_mem := λ x ⟨m, hm⟩, ⟨-m, by simp [map_neg f, hm]⟩,
  mul_mem := λ x y ⟨m, hm⟩ ⟨n, hn⟩, ⟨m * n, by simp [map_mul f, hm, hn]⟩,
  one_mem := ⟨(1:α), map_one f⟩ }

instance im.comm_ring : comm_ring (im f) := subring.comm_ring β (im f)

end is_ring_hom

noncomputable def first_isom (α : Type u) (β : Type v)
  [comm_ring α] [comm_ring β] (f : α → β) [is_ring_hom f] :
(α /ᵣ (is_ring_hom.ker f)) ≃ᵣ (is_ring_hom.im f) :=
{ to_fun := λ x, quotient.lift_on x (λ x, ⟨f x, x, rfl⟩ : α → is_ring_hom.im f) (λ x y hxy, subtype.eq $ calc
    f x = f (y + (x - y)) : by norm_num
    ... = f y + f (x - y) : is_ring_hom.map_add f
    ... = f y             : by change f(x-y)∈_ at hxy; rw set.mem_singleton_iff at hxy; rw [hxy, add_zero]),
  is_ring_hom :=
    { map_add := λ x y, quotient.induction_on₂ x y (λ m n, by simp [is_ideal.coset_eq, is_ring_hom.map_add f]; refl),
      map_mul := λ x y, quotient.induction_on₂ x y (λ m n, by simp [is_ideal.coset_eq, is_ring_hom.map_mul f]; refl),
      map_one := by simp [is_ring_hom.map_one f]; refl },
  inv_fun := λ ⟨y, hy⟩, ⟦classical.some hy⟧,
  left_inv := λ x, quotient.induction_on x $
    begin
      intro y,
      have hz := @classical.some_spec _ (λ z, f z = f y) ⟨y, rfl⟩,
      simp [first_isom._match_1, is_ideal.mk', -is_ideal.coset_eq],
      change f _ ∈ _,
      simp [is_ring_hom.map_add f, hz, is_ring_hom.map_neg f]
    end,
  right_inv := λ ⟨x, hx⟩, subtype.eq (by simp [first_isom._match_1]; simpa using classical.some_spec hx) }

def topological_space.is_topological_basis' {α : Type u} [t : topological_space α] (s : set (set α)) :=
(∀ U : set α, U ∈ s → t.is_open U) ∧
(∀ U : set α, t.is_open U → (∀ x, x ∈ U → ∃ V : set α, V ∈ s ∧ x ∈ V ∧ V ⊆ U))

lemma topological_space.generate_from_apply {α : Type u} [t : topological_space α] (s : set (set α)) (U : set α) :
  topological_space.is_open (topological_space.generate_from s) U ↔ topological_space.generate_open s U := iff.rfl

lemma basis_is_basis' {α : Type u} [t : topological_space α] (s : set (set α)) :
  topological_space.is_topological_basis s ↔ topological_space.is_topological_basis' s :=
begin
  split,
  { intro H,
    split,
    { intros U HU,
      rw H.2.2,
      exact topological_space.generate_open.basic U HU },
    { intros U HU x Hx,
      rw H.2.2 at HU,
      induction HU with U4 H5 U6 U7 H8 H9 H10 H11 UU12 H13 H14,
      { exact ⟨U4, H5, Hx, set.subset.refl U4⟩ },
      { have H5 : x ∈ ⋃₀ s,
        { rw H.2.1, trivial },
        rcases H5 with ⟨V, H6, H7⟩,
        exact ⟨V, H6, H7, set.subset_univ V⟩
      },
      { specialize H10 (set.inter_subset_left U6 U7 Hx),
        specialize H11 (set.inter_subset_right U6 U7 Hx),
        cases H10 with V12 H12,
        cases H11 with V13 H13,
        have H14 := H.1 V12 H12.1 V13 H13.1 x ⟨H12.2.1, H13.2.1⟩,
        rcases H14 with ⟨V, H15, H16⟩,
        refine ⟨V, H15, H16.1, _⟩,
        refine set.subset.trans H16.2 _,
        intro z,
        apply and.imp,
        { intro hz, exact H12.2.2 hz },
        { intro hz, exact H13.2.2 hz }
      },
      { rcases Hx with ⟨V, H15, H16⟩,
        rcases H14 V H15 H16 with ⟨W, H17, H18, H19⟩,
        exact ⟨W, H17, H18, λ z hz, ⟨V, H15, H19 hz⟩⟩
      }
    }
  },
  { intro H,
    split,
    { intros U1 H1 U2 H2 x H3,
      have H4 := H.1 U1 H1,
      have H5 := H.1 U2 H2,
      have H6 := H.2 (U1 ∩ U2) (topological_space.is_open_inter t U1 U2 H4 H5) x H3,
      rcases H6 with ⟨V, H7, H8, H9⟩,
      exact ⟨V, H7, H8, H9⟩
    },
    split,
    { apply set.ext,
      intro x,
      rw iff_true_right (set.mem_univ x),
      have H1 := H.2 set.univ (topological_space.is_open_univ t) x trivial,
      rcases H1 with ⟨V, H2, H3, H4⟩,
      existsi V,
      existsi H2,
      exact H3
    },
    { apply topological_space_eq,
      apply funext,
      intro U,
      apply propext,
      rw topological_space.generate_from_apply,
      split,
      { intro H1,
        have H2 := H.2 U H1,
        have H3 : U = ⋃₀ {V | ∃ x ∈ U, V ∈ s ∧ x ∈ V ∧ V ⊆ U},
        { apply set.ext,
          intro x,
          split,
          { intro H3,
            rcases H2 x H3 with ⟨V, H4⟩,
            exact ⟨V, ⟨x, H3, H4⟩, H4.2.1⟩
          },
          { intro H3,
            rcases H3 with ⟨U1, H3, H4⟩,
            rcases H3 with ⟨y, H3, H5, H6, H7⟩,
            exact H7 H4
          }
        },
        rw H3,
        apply topological_space.generate_open.sUnion,
        intros U1 H4,
        rcases H4 with ⟨U1, H4, H5, H6, H7⟩,
        apply topological_space.generate_open.basic,
        exact H5
      },
      { exact generate_from_le H.1 U }
    }
  }
end

namespace subrel

variables {α : Type u} [partial_order α] {p : α → Prop}

instance : partial_order {x // p x} :=
{ le := subrel (≤) p,
  le_refl := λ x, le_refl x,
  le_trans := λ x y z, le_trans,
  le_antisymm := λ x y hx hy, subtype.eq $ le_antisymm hx hy }

end subrel

namespace zorn

variables (α : Type u) [partial_order α] [inhabited α]

local attribute [instance] classical.prop_decidable

theorem zorn' (H : ∀ (c : set α) (x : α) (h1 : x ∈ c) (h2 : ∀ x y, x ∈ c → y ∈ c → x ≤ y ∨ y ≤ x), ∃ ub, ∀ x ∈ c, x ≤ ub) :
  ∃ M:α, ∀ x, M ≤ x → x = M :=
begin
  have : ∃ M:α, ∀ x, M ≤ x → x ≤ M,
  { apply zorn,
    { intros c hc,
      by_cases h : c = ∅,
      { simp [h] },
      { simp [set.not_eq_empty_iff_exists] at h,
        cases h with x hx,
        apply H c x hx,
        intros x y hx hy,
        by_cases hxy : x = y,
        { simp [hxy] },
        { exact hc x hx y hy hxy } } },
    intros x y z,
    exact le_trans },
  rcases this with ⟨M, hm⟩,
  existsi M,
  intros x hx,
  symmetry,
  exact le_antisymm hx (hm x hx)
end

end zorn