/-
Copyright (c) 2021 Lu-Ming Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Lu-Ming Zhang.
-/
import linear_algebra.matrix.trace
import linear_algebra.matrix.to_lin
import linear_algebra.matrix.nonsingular_inverse
import data.complex.basic

/-!
This file supplements things about `matrix`, that are current missing in mathlib,
in particular those that will be used for the implementation of the Kronecker product and the constructions of Hadamard matrices.

## Main definitions

Here only lists main definitions that are used for the implementation of the Kronecker product and Hadamard matrices.
- `matrix.all_one`: the matrix whose entries are all `1`s.
- `matrix.is_sym`: a Proposition. Matrix `A` is symmetric `A.is_sym` means `Aᵀ = A`.
-/

variables {α β γ I J K L M N: Type*}
variables {R : Type*}
variables [fintype I] [fintype J] [fintype K] [fintype L] [fintype M] [fintype N]

/- ## reindex and coercion -/
instance prod_assoc : has_coe ((α × β) × γ) (α × β × γ) := ⟨λ ⟨⟨a,b⟩,c⟩, ⟨a,b,c⟩⟩
instance matrix.prod_assoc : has_coe (matrix (I × J × K) (L × M × N) α) (matrix ((I × J) × K) ((L × M) × N) α):=
⟨λ M ⟨⟨a,b⟩,c⟩ ⟨⟨d,e⟩,f⟩, M ⟨a,b,c⟩ ⟨d,e,f⟩⟩
/-- `matrix.reindex_prod_assoc` constructs a natural equivalence between `matrix ((I × J) × K) ((L × M) × N) α` and `matrix (I × J × K) (L × M × N) α`. -/
def matrix.reindex_prod_assoc : matrix ((I × J) × K) ((L × M) × N) α ≃ matrix (I × J × K) (L × M × N) α :=
matrix.reindex (equiv.prod_assoc _ _ _) (equiv.prod_assoc _ _ _)
/-- `matrix.reindex_prod_comm_fst` constructs a natural equivalence between `matrix I (J × K) α` and `matrix I (K × J) α`. -/
def matrix.reindex_prod_comm_fst : matrix I (J × K) α ≃ matrix I (K × J) α :=
matrix.reindex (equiv.refl _) (equiv.prod_comm _ _)
/-- `matrix.reindex_prod_comm_snd` constructs a natural equivalence between `matrix (I × J) K α` and `matrix (J × I) K α`. -/
def matrix.reindex_prod_comm_snd : matrix (I × J) K α ≃ matrix (J × I) K α :=
matrix.reindex (equiv.prod_comm _ _) (equiv.refl _)
/-- `matrix.reindex_prod_comm` constructs a natural equivalence between `matrix (I × J) (K × L) α` and `matrix (J × I) (L × K) α`. -/
def matrix.reindex_prod_comm : matrix (I × J) (K × L) α ≃ matrix (J × I) (L × K) α :=
matrix.reindex (equiv.prod_comm _ _) (equiv.prod_comm _ _)
/- ## end reindex and coercion -/

/- ## perm matrix -/
/-- `equiv.perm.to_matrix σ` is the permutation matrix given by a permutation `σ : equiv.perm I` on the index tpye `I`. -/
def equiv.perm.to_matrix [decidable_eq I] (α) [has_zero α] [has_one α] (σ : equiv.perm I) : matrix I I α
| i j := if σ i = j then 1 else 0

/-- Proves `(σ.to_pequiv.to_matrix : matrix I I α)= σ.to_matrix α`. -/
lemma equiv.perm.to_matrix_eq_to_prequiv_to_matrix [decidable_eq I] [has_zero α] [has_one α] (σ : equiv.perm I) :
(σ.to_pequiv.to_matrix : matrix I I α)= σ.to_matrix α:=
by ext i j; simp [pequiv.to_matrix, equiv.perm.to_matrix,equiv.to_pequiv]
/- ## end perm matrix -/
----------------------------------------------------------------------------------

namespace matrix
open_locale matrix big_operators
open complex

/- ## one -/
section one
variables [mul_one_class α] [add_comm_monoid α] [non_assoc_semiring β]

open_locale big_operators

@[simp] lemma dot_product_one (v : I → α) : dot_product v 1 = ∑ i, v i :=
by simp [dot_product]

@[simp] lemma dot_product_one' (v : I → α) : dot_product v (λ i, 1) = ∑ i, v i :=
by simp [dot_product]

@[simp] lemma one_dot_product (v : I → α) : dot_product 1 v = ∑ i, v i :=
by simp [dot_product]

@[simp] lemma one_dot_product' (v : I → α) : dot_product (λ i, 1 : I → α) v = ∑ i, v i :=
by simp [dot_product]

lemma one_dot_one_eq_card : dot_product (1 : I → α) 1 = fintype.card I :=
by simp [dot_product, fintype.card]

lemma one_dot_one_eq_card' : dot_product (λ i, 1 : I → α) (λ i, 1) = fintype.card I :=
by simp [dot_product, fintype.card]

@[simp] lemma mul_vector_one (A : matrix I J β) :
mul_vec A 1 = λ i, ∑ j, A i j :=
by ext; simp [mul_vec, dot_product]

@[simp] lemma mul_vector_one' (A : matrix I J β) :
mul_vec A (λ i, 1) = λ i, ∑ j, A i j :=
by ext; simp [mul_vec, dot_product]

@[simp] lemma vector_one_mul (A : matrix I J β) :
vec_mul 1 A = λ j, ∑ i, A i j :=
by ext; simp [vec_mul, dot_product]

@[simp] lemma vector_one_mul' (A : matrix I J β) :
vec_mul (λ j, 1 : I → β) A = λ j, ∑ i, A i j :=
by ext; simp [vec_mul, dot_product]

end one

section all_one_matrix

/-- `matrix.all_one` is the matrix whose entries are all `1`s. -/
def all_one [has_one α]: matrix I J α := λ i, 1

localized "notation 𝟙 := matrix.all_one" in matrix

/-- `matrix.row sum A i` is the sum of entries of the row indexed by `i` of matrix `A`. -/
def row_sum [add_comm_monoid α] (A : matrix I J α) (i : I) := ∑ j, A i j

/-- `matrix.col_sum A j` is the sum of entries of the column indexed by `j` of matrix `A`. -/
def col_sum [add_comm_monoid α] (A : matrix I J α) (j : J) := ∑ i, A i j

lemma col_one_mul_row_one [non_assoc_semiring α] :
col (1 : I → α) ⬝ row (1 : I → α) = 𝟙 :=
by ext; simp [matrix.mul, all_one]

lemma row_one_mul_col_one [non_assoc_semiring α] :
row (1 : I → α) ⬝ col (1 : I → α) = fintype.card I • 1 :=
by {ext, simp [mul_apply, one_apply], congr,}

end all_one_matrix

/- ## end one -/

/- ## trace section -/
section trace
/-- The "trace" of a matrix.
    A different version of "trace" is defined in `trace.lean` as `matrix.trace`.
    One advantage of `matrix.tr` is that this definition is more elementary,
    which only requires α to be a `add_comm_monoid`; whilst `matrix.trace` requires
    `[semiring β] [add_comm_monoid α] [module β α]`.
    The equivalence can be easily established when `α` is indeed a `β-module`.
    Another advantage is that `matrix.tr` is more convenient for users to explore lemmas/theorems
    involving "trace" from a combinatorial aspect.-/
def tr [add_comm_monoid α] (A : matrix I I α) : α := ∑ i : I, A i i

/-- Establishes that `matrix.trace` is equivalent to `matrix.tr`. -/
lemma trace_eq_tr [semiring β] [add_comm_monoid α] [module β α] (A : matrix I I α)
: trace I β α A = tr A := rfl
end trace
/- ## end trace -/

/- ## conjugate transpose and symmetric -/
section conjugate_transpose

@[simp] lemma star_vec [has_star α] (v : I → α) (i : I) : star v i = star (v i) := rfl

lemma trans_col_eq_row (A : matrix I J α) (i : I) : (λ j, Aᵀ j i) = A i :=
by simp [transpose]

lemma trans_row_eq_col (A : matrix I J α) (j : J) : Aᵀ j = (λ i, A i j):=
by ext; simp [transpose]

lemma eq_of_transpose_eq {A B : matrix I J α} : Aᵀ = Bᵀ → A = B :=
begin
  intros h, ext i j,
  have h':= congr_fun (congr_fun h j) i,
  simp [transpose] at h',
  assumption
end

/-

/-- The conjugate transpose of a matrix defined in term of `star`. -/
def conj_transpose [has_star α] (M : matrix I J α) : matrix J I α
| x y := star (M y x)

localized "postfix `ᴴ`:1500 := matrix.conj_transpose" in matrix

@[simp] lemma conj_transpose_apply [has_star α] (M : matrix m n α) (i j) :
  M.conj_transpose j i = star (M i j) := rfl

@[simp] lemma conj_transpose_conj_transpose [has_involutive_star α] (M : matrix m n α) :
  Mᴴᴴ = M :=
by ext; simp

@[simp] lemma conj_transpose_zero [semiring α] [star_ring α] : (0 : matrix m n α)ᴴ = 0 :=
by ext i j; simp

@[simp] lemma conj_transpose_one [decidable_eq n] [semiring α] [star_ring α]:
  (1 : matrix n n α)ᴴ = 1 :=
by simp [conj_transpose]

@[simp] lemma conj_transpose_add
[semiring α] [star_ring α] (M : matrix m n α) (N : matrix m n α) :
  (M + N)ᴴ = Mᴴ + Nᴴ  := by ext i j; simp

@[simp] lemma conj_transpose_sub [ring α] [star_ring α] (M : matrix m n α) (N : matrix m n α) :
  (M - N)ᴴ = Mᴴ - Nᴴ  := by ext i j; simp

@[simp] lemma conj_transpose_smul [comm_monoid α] [star_monoid α] (c : α) (M : matrix m n α) :
  (c • M)ᴴ = (star c) • Mᴴ :=
by ext i j; simp [mul_comm]

@[simp] lemma conj_transpose_mul [semiring α] [star_ring α] (M : matrix m n α) (N : matrix n l α) :
  (M ⬝ N)ᴴ = Nᴴ ⬝ Mᴴ  := by ext i j; simp [mul_apply]

@[simp] lemma conj_transpose_neg [ring α] [star_ring α] (M : matrix m n α) :
  (- M)ᴴ = - Mᴴ  := by ext i j; simp

section star

/-- When `α` has a star operation, square matrices `matrix n n α` have a star
operation equal to `matrix.conj_transpose`. -/
instance [has_star α] : has_star (matrix n n α) := {star := conj_transpose}

lemma star_eq_conj_transpose [has_star α] (M : matrix m m α) : star M = Mᴴ := rfl

@[simp] lemma star_apply [has_star α] (M : matrix n n α) (i j) :
  (star M) i j = star (M j i) := rfl

instance [has_involutive_star α] : has_involutive_star (matrix n n α) :=
{ star_involutive := conj_transpose_conj_transpose }

/-- When `α` is a `*`-(semi)ring, `matrix.has_star` is also a `*`-(semi)ring. -/
instance [decidable_eq n] [semiring α] [star_ring α] : star_ring (matrix n n α) :=
{ star_add := conj_transpose_add,
  star_mul := conj_transpose_mul, }

/-- A version of `star_mul` for `⬝` instead of `*`. -/
lemma star_mul [semiring α] [star_ring α] (M N : matrix n n α) :
  star (M ⬝ N) = star N ⬝ star M := conj_transpose_mul _ _

end star

@[simp] lemma conj_transpose_minor
  [has_star α] (A : matrix m n α) (r_reindex : l → m) (c_reindex : o → n) :
  (A.minor r_reindex c_reindex)ᴴ = Aᴴ.minor c_reindex r_reindex :=
ext $ λ _ _, rfl

lemma conj_transpose_reindex [has_star α] (eₘ : m ≃ l) (eₙ : n ≃ o) (M : matrix m n α) :
  (reindex eₘ eₙ M)ᴴ = (reindex eₙ eₘ Mᴴ) :=
rfl

-/

/-- Proposition `matrix.is_sym`. `A.is_sym` means `Aᵀ = A`. -/
def is_sym (A : matrix I I α) : Prop := Aᵀ = A

/-- Proposition `matrix.is_skewsym`. `A.is_skewsym` means `-Aᵀ = A` if `[has_neg α]`. -/
def is_skewsym [has_neg α] (A : matrix I I α) : Prop := -Aᵀ = A

/-- Proposition `matrix.is_Hermitian`. `A.is_Hermitian` means `Aᴴ = A` if `[has_star α]`. -/
def is_Hermitian [has_star α] (A : matrix I I α) : Prop := Aᴴ = A

end conjugate_transpose
/- ## end conjugate transpose and symmetric-/

/- ## definite section -/
section definite
open_locale complex_order

/-- Proposition `matrix.is_pos_def`. -/
def is_pos_def (M : matrix I I ℂ):= M.is_Hermitian ∧ ∀ v : I → ℂ, v ≠ 0 → 0 < dot_product v (M.mul_vec v)

/-- Proposition `matrix.is_pos_semidef`. -/
def is_pos_semidef (M : matrix I I ℂ):= M.is_Hermitian∧ ∀ v : I → ℂ, 0 ≤ dot_product v (M.mul_vec v)

/-- Proposition `matrix.is_neg_def`. -/
def is_neg_def (M : matrix I I ℂ):= M.is_Hermitian ∧ ∀ v : I → ℂ, v ≠ 0 → dot_product v (M.mul_vec v) < 0

/-- Proposition `matrix.is_neg_semidef`. -/
def is_neg_semidef (M : matrix I I ℂ):= M.is_Hermitian ∧ ∀ v : I → ℂ, dot_product v (M.mul_vec v) ≤ 0

end definite
/- ## end definite -/

/- ## matrix rank section  -/
section rank
variables [decidable_eq J] [field α]
/-- `rank A` is the rank of matrix `A`, defined as the rank of `A.to_lin'`. -/
noncomputable def rank (A : matrix I J α) := rank A.to_lin'
end rank
/- ## end matrix rank -/

/- ## orthogonal section  -/
section orthogonal
variable [decidable_eq I]

/-- Proposition `matrix.is_ortho`.
    `A` is orthogonal `A.is_ortho` means `Aᵀ ⬝ A = 1`, where `A : matrix I I ℝ`. -/
def is_ortho (A : matrix I I ℝ) : Prop := Aᵀ ⬝ A = 1

/-- Proposition `matrix.is_uni`.
    `A` is unitray `A.is_uni` means `Aᴴ ⬝ A = 1`, where `A : matrix I I ℂ`. -/
def is_uni (A : matrix I I ℂ) : Prop := Aᴴ ⬝ A = 1

lemma is_ortho_left_right (A : matrix I I ℝ) : A.is_ortho ↔ A ⬝ Aᵀ = 1 := ⟨nonsing_inv_right_left, nonsing_inv_left_right⟩

lemma is_uni_left_right (A : matrix I I ℂ) : A.is_uni ↔ A ⬝ Aᴴ = 1 := ⟨nonsing_inv_right_left, nonsing_inv_left_right⟩

/-- A matrix `A` is orthogonal iff `A` has orthonormal columns. -/
lemma is_ortho_iff_orthonormal_cols (A : matrix I I ℝ) :
matrix.is_ortho A ↔ ∀ j₁ j₂, dot_product (λ i, A i j₁) (λ i, A i j₂) = ite (j₁ = j₂) 1 0 :=
begin
  simp [matrix.is_ortho,matrix.mul,has_one.one, diagonal],
  split,
  { intros h j₁ j₂,
    exact congr_fun (congr_fun h j₁) j₂,
  },
  { intros h, ext, apply h _ _},
end

/-- A matrix `A` is orthogonal iff `A` has orthonormal rows. -/
lemma is_ortho_iff_orthonormal_row (A : matrix I I ℝ) :
matrix.is_ortho A ↔ ∀ i₁ i₂, dot_product (A i₁) (A i₂) = ite (i₁ = i₂) 1 0 :=
begin
  rw is_ortho_left_right,
  simp [matrix.is_ortho,matrix.mul,has_one.one, diagonal],
  split,
  { intros h i₁ i₂,
    exact congr_fun (congr_fun h i₁) i₂,
  },
  { intros h, ext, apply h _ _},
end

end orthogonal
/- ## end orthogonal -/

/- ## permutation matrix -/
section perm
open equiv

variables [decidable_eq I] [has_zero α] [has_one α]

/-- `P.is_perm` if matrix `P` is induced by some permutation `σ`. -/
def is_perm (P : matrix I I α) : Prop :=
∃ σ : equiv.perm I, P = perm.to_matrix α σ

/-- `P.is_perfect_shuffle` if matrix `P` is induced by some permutation `σ`, and `∀ i : I, σ i ≠ i`. -/
def is_perfect_shuffle (P : matrix I I α) : Prop :=
∃ σ : equiv.perm I, (P = perm.to_matrix α σ ∧ ∀ i : I, σ i ≠ i)

/-- A permutation matrix is a perfect shuffle. -/
lemma is_perm_of_is_perfect_shuffle (P : matrix I I α) : P.is_perfect_shuffle → P.is_perm :=
by {intro h, rcases h with ⟨σ, rfl, h2⟩, use σ}

/-
def is_perm' (P : matrix I I α) : Prop :=
(∀ i, ∃! j, ∀ j', ite (j' = j) (P i j' = 1) (P i j' = 0)) ∧
(∀ j, ∃! i, ∀ i', ite (i' = i) (P i' j = 1) (P i' j = 0))
lemma is_perm_of_is_perm' {P : matrix I I α} (h : P.is_perm'): P.is_perm := sorry
lemma is_perm'_of_is_perm {P : matrix I I α} (h : P.is_perm): P.is_perm' := sorry
lemma is_perm_iff_is_perm' (P : matrix I I α) : P.is_perm ↔ P.is_perm' := ⟨is_perm'_of_is_perm, is_perm_of_is_perm'⟩

def std := {v : I → α| ∃! (i : I), ∀ j : I, ite (j = i) (v j = 1) (v j = 0)}

lemma bij_on_std_of_is_perm {α} [non_assoc_semiring α] [decidable_eq I] (P : matrix I I α) (h : P.is_perm) :
set.bij_on (λ v, P.mul_vec v) std std :=
begin
  rcases h with ⟨σ, rfl⟩,
  split,
  {
    intros v hv,
    simp [std, perm.to_matrix, mul_vec, dot_product] at *,
    rcases hv with ⟨i, ⟨h1, h2⟩⟩,
    use σ.inv_fun i,
    sorry
  },
  sorry
end
-/
end perm
/- ## end permutation -/

/- ## matrix similarity section  -/
section similarity
variables [comm_ring α] [decidable_eq I]

/-- `matrix.similar_to` defines the proposition that matrix `A` is similar to `B`, denoted as `A ∼ B`. -/
def similar_to (A B : matrix I I α) := ∃ (P : matrix I I α), is_unit P.det ∧ B = P⁻¹ ⬝ A ⬝ P
localized "notation `∼`:50 := matrix.similar_to" in matrix

/-- An equivalent definition of matrix similarity `similar_to`. -/
def similar_to' (A B : matrix I I α) := ∃ (P : matrix I I α), is_unit P ∧ B = P⁻¹ ⬝ A ⬝ P

/-- `matrix.perm_similar_to` defines the proposition that matrix `A` is permutation-similar to `B`, denoted as `A ∼ₚ B`.-/
def perm_similar_to (A B : matrix I I α) := ∃ (P : matrix I I α), P.is_perm ∧ B = P⁻¹ ⬝ A ⬝ P
localized "notation `∼ₚ`:50 := matrix.perm_similar_to" in matrix

/-- Proves the equivalence of `matrix.similar_to` and `matrix.similar_to'`. -/
lemma similar_to_iff_similar_to' (A B : matrix I I α) : similar_to A B ↔ similar_to' A B :=
⟨ by {rintros ⟨P ,h1, h2⟩, rw ←is_unit_iff_is_unit_det at h1, use⟨P ,h1, h2⟩},
  by {rintros ⟨P ,h1, h2⟩, rw is_unit_iff_is_unit_det at h1, use⟨P ,h1, h2⟩} ⟩

end similarity
/- ## end matrix similarity -/

/- ## others -/
/-- Two empties matrices are equal. -/
lemma eq_of_empty [c: is_empty I] (M N: matrix I I α) : M = N :=
by {ext, exfalso, apply is_empty_iff.mp c i}

/-- `matrix.dot_product_block'` splits the `dot_product` of two block vectors into a sum of two `Σ` sums. -/
lemma dot_product_block' [has_mul α] [add_comm_monoid α] (v w : I ⊕ J → α) :
dot_product v w = ∑ i, v (sum.inl i) * w (sum.inl i) + ∑ j, v (sum.inr j) * w (sum.inr j) :=
begin
  rw [dot_product, ←fintype.sum_sum_elim],
  congr,
  ext (i | j); simp
end

/-- `matrix.dot_product_block` splits the `dot_product` of two block vectors into a sum of two `dot_product` . -/
lemma dot_product_block [has_mul α] [add_comm_monoid α] (v w : I ⊕ J → α) :
dot_product v w = dot_product (λ i, v (sum.inl i))  (λ i, w (sum.inl i)) + dot_product (λ j, v (sum.inr j))  (λ j, w (sum.inr j)) :=
by simp [dot_product, dot_product_block']
/- ## end others -/

end matrix


/-quotient.lean -- Quotient Structures and Homomorphic Images

  Author: William DeMeo <williamdemeo@gmail.com>
  Date: 30 Nov 2018

  References
  [1] Avigad, et al, "Theorem Proving in Lean," 2018
      url: https://leanprover.github.io/theorem_proving_in_lean/theorem_proving_in_lean.pdf
  [2] Bergman, Clifford, "Universal algebra," CRC Press, 2012

  Copyright (c) 2018 William DeMeo
  See LICENSE file at https://github.com/UniversalAlgebra/lean-ualib/blob/master/LICENSE
-/

import basic
import data.fintype
universes u v

  /-Reference: Chapter 11 of Theorem Proving in Lean [1].
    Let α be any type, and let r be an equivalence relation on α. It is
    Then the *quotient* α / r is the type of equivalence classes of α modulo r.

    Let f : α → β be any (unary) function and let r : α → α → Prop be a binary relation on α.
    The Lean standard library takes "f respects r" to mean the following:

    ∀ x y : α, r x y → f x = f y.

    But, for us, it seems the consequent f x = f y is unnecessarily strong.
    Instead, we would prefer if the notion of a function f "respecting" a relation r
    to require only that `r x y` implies `r (f x) (f y)`.

    In any case, when f respects r (in the appropriate sense), then f should "lift" to
    a function on the classes, f' : α / r → α / r, defined on each equivalence
    class ⟦x⟧ by f' ⟦x⟧ = ⟦f x⟧.

    Because of the distinction between our notion of "respects" and that of the std lib,
    we will roll our own quotient.
  -/

namespace ualib_quotient
  --EXAMPLES:
  -- We have the quotient for unary functions f : α → α ↦ f' : α/r → α/r  working fine.
  section unary
  parameters {α : Type*} {ρ : Type*}

  -- The equivalence class of r containing a will be denoted by a/r.
  local notation a`/`r := quot.mk r a

  lemma equiv_elem (r : α → α → Prop) (f : (ρ → α) → α) :
  ∀ (a b : ρ → α), r (f a) (f b)  → (f a)/r = (f b)/r := assume (a: ρ → α) (b: ρ → α),
  assume h : r (f a) (f b), show (f a)/r = (f b)/r, from quot.sound h

  -- (πᵤ f) a == (f a)/r.
  local notation a`/`r := quot.mk r a
  def πᵤ (f : α → α) (r : α → α → Prop) : α → quot r := λ a, (f a) / r

  def compatible_unary (f : α → α) (r : α → α → Prop) := ∀ a b, r a b → r (f a) (f b)

  lemma proj_of_compatible_unary_respects
  (f : α → α) (r : α → α → Prop) (h : compatible_unary f r) :
  ∀ a b, r a b → (f a)/r = (f b)/r :=
  assume a b (h₀ : r a b),
  have h₃ : r (f a) (f b), from h a b h₀,
  show (f a)/r = (f b)/r, from quot.sound h₃

  def lift_proj (f : α → α) (r : α → α → Prop) (h : compatible_unary f r) : quot r → quot r :=
  quot.lift (πᵤ  f r) (proj_of_compatible_unary_respects f r h)

  end unary

  -- Unfortunately, we haven't got the quotient for higher-ary functions
  -- f : (ρ → α) → α ↦ f' : (ρ → α/r) → α/r  working just yet.
  -- Also, it's probably only possible to get this working when ρ : fintype.

  section higher_arity
    parameters {α : Type*} {ρ : Type*}

    -- The equivalence class of r containing a will be denoted by a/r.
    local notation a`/`r := quot.mk r a

    def liftR (r : α → α → Prop) : (ρ → α) → (ρ → α) → Prop :=
    λ a b, ∀ i, r (a i) (b i)
    -- liftR a b  takes tuples a, b and returns true iff each pair (a i, b i) of i-th coordinates is r-related.
    variable r : α → α → Prop

    local notation `⟦`r`⟧` := liftR r
    -- If a and b are tuples from ρ → α, and R is a binary relation on α, then
    -- ⟦R⟧ a b   ↔   ∀ i, R (a i) (b i)

    def compatible (f : (ρ → α) → α) (r : α → α → Prop) :=
    ∀ (a b : ρ → α), ⟦r⟧ a b → r (f a) (f b)

    def compatible' (f : (ρ → α) → α) (r : α → α → Prop) :=
    ∀ (a b : ρ → α), ⟦r⟧ a b → (f a)/r = (f b)/r

    def ker {α : Type*} {ρ : Type*} (f : (ρ → α) → α) : (ρ → α) → (ρ → α) → Prop :=
    λ a b, f a = f b

    lemma proj_of_compatible_respects
    (f : (ρ → α) → α) (r : α → α → Prop) (h : compatible f r) :
    ∀ (a b : ρ → α), ⟦r⟧  a b  →  (f a)/r = (f b)/r :=
    assume a b (h₀ : ⟦r⟧ a b),
    have h₃ : r (f a) (f b), from h a b h₀,
    show (f a)/r = (f b)/r, from quot.sound h₃

    def π (f : (ρ → α) → α) (r : α → α → Prop) : (ρ → α) → quot r :=
    λ (a : ρ → α) , (f a) / r

    -- Recall, if f : (ρ → α) → α, then  π f : (ρ → α) → quot r := λ a, (f a) / r
    -- attribute [reducible, elab_as_eliminator]
    -- def lift_gen (f : (ρ → α) → α ) (r : α → α → Prop) (h : compatible f r) :
    -- quot r → quot r :=
    -- quot.lift ((π f) r) (proj_of_compatible_respects f r h)
    --(quot.mk (λ (a b : ρ → α), ⟦ r ⟧ a b) i)
    -- λ (i : ρ → α), (quot.lift ((π f) r) (proj_of_compatible_respects f r h) )(quot.mk (λ (a b : ρ → α), ⟦ r ⟧ a b) i)

  end higher_arity

end ualib_quotient

namespace other_attempts
    private definition rr {α : Type*} {ρ : Type*}
    (r : α → α → Prop) :
    (ρ → α) → (ρ → α) → Prop :=
    λ (a b : ρ → α) , ∀ (i : ρ), r (a i) (b i)

    infix ` ⟦r⟧ `:50 := rr

    private theorem rr.refl {α : Type*} {ρ : Type*}
    (r : α → α → Prop) (r_is_equiv : equivalence r):
    ∀ (a : ρ → α), rr r a a := assume a,
    show ∀ (i : ρ), r (a i) (a i), from
    assume (i : ρ), r_is_equiv.left (a i)

    private theorem rr.symm {α : Type*} {ρ : Type*}
    (r : α → α → Prop) (r_is_equiv : equivalence r):
    ∀ (a b : ρ → α), rr r a b → rr r b a := assume a b (h₀ : rr r a b), show
    rr r b a, from assume i,
    have h₁ : r (a i) (b i), from h₀ i,
    r_is_equiv.right.left h₁

    private theorem rr.trans  {α : Type*} {ρ : Type*}
    (r : α → α → Prop) (r_is_equiv : equivalence r):
    ∀ (a b c : ρ → α), rr r a b → rr r b c → rr r a c :=
    assume a b c (h₀ : rr r a b) (h₁ : rr r b c), show  rr r a c, from
    assume i,
    have h₂ : r (a i) (b i), from h₀ i,
    have h₃ : r (b i) (c i), from h₁ i,
    r_is_equiv.right.right h₂ h₃

    private theorem rr_is_equiv {α : Type*} {ρ : Type*}
    (r : α → α → Prop) (r_is_equiv: equivalence r) :
    equivalence (@rr α ρ r) := and.intro (rr.refl r r_is_equiv)
    (and.intro (rr.symm r r_is_equiv) (rr.trans r r_is_equiv) )

    --parameters {α : Type*} {ρ : Type*} (r : α → α → Prop)

    instance rr.setoid (α : Type*) (ρ : Type*)
    (r : α → α → Prop) (r_is_equiv: equivalence r) :
    setoid (ρ → α) :=
    setoid.mk (@rr α ρ r) (@rr_is_equiv α ρ r r_is_equiv)

    definition quot_struct (α : Type*) (ρ : Type*)
    (r : α → α → Prop) (r_is_equiv: equivalence r) : Type* :=
    quotient (rr.setoid α ρ r r_is_equiv)

    namespace quot_struct
      open quot_struct
      definition mk {α : Type*} {ρ : Type*}
      (r: α → α → Prop) (r_is_equiv : equivalence r)
      (a : ρ → α) : (ρ → α) → Prop :=
      λ (b : ρ → α), ∀ i, r (a i) (b i)  -- (quot_struct α ρ r r_is_equiv) a
    end quot_struct

    section
      parameters {α : Type*} {ρ : Type*}
      variables (r : α → α → Prop) (r_is_equiv: equivalence r)
    -- This doesn't work:
    --  theorem soundness (a b : ρ → α)
    --  (R : quot_struct α ρ r r_is_equiv)
    --  (a b :ρ → α) (h : R) : ∀ (i : ρ), a i = b i
    end

end other_attempts

section ualib_quotient_algebra

  parameters {S : signature} {A : algebra S} {B : algebra S} (h : A → B)
  variables (hh : homomorphic h)

  def kernel {A : algebra S} {B : algebra S} (f : A → B) :
  A → A → Prop := λ a a', f a = f a'

  def kerh := kernel h

  -- A relation is compatible with A iff it is preserved by the ops of A
  def compatible (r: A → A → Prop) : Prop :=
  ∀ (f : S.F) (a : S.ρ f → A.fst) (b : S.ρ f → A.fst),
  ∀ i, r (a i) (b i) → r (A f a) (A f b)

  def rel_on_A := A.fst → A.fst → Prop

  def rel_on_tuples_of_A_of_length (β :Type*) := (β → A.fst) → (β → A.fst) → Prop

  -- A congruence relation on A is a compatible equivalence relation
  def congruence (r: A.fst → A.fst → Prop) : Prop := equivalence r ∧ compatible r

    variables (α : Type*) (β : Type*) (r : α → α → Prop) (f : α → α)
    variables (h' : ∀ a₁ a₂, r a₁ a₂ → r (f a₁) (f a₂))

    -- #check (quot.lift f h' : quot r → β) -- the corresponding function on quot r

  -- def lift {A : algebra S} (f : S.F) (r: A.fst → A.fst → Prop) : ((S.ρ f) → (quot r)) → (quot r) :=
  -- λ aa, ∀ i,
  -- (quot.mk r a), A f a

  -- lemma lift_beta {α : Sort u} {r : α → α → Prop} {β : Sort v}
  -- (f : α → β) --(c : ∀ a b, r a b → f a = f b)
  -- (a : α) : lift f c (quot.mk r a) = f a := rfl

  -- If K is the kernel of a hom h, then we have
  -- h (A f a) = B f (h ∘ a), and if ∀ i, (kernel h) (a i) (b i),
  -- then ∀ i, h (a i) = h (b i), which implies h ∘ a = h ∘ b, which implies
  -- h (A f a) = B f (h ∘ a) = B f (h ∘ b) = h (A f b)

  --def quotient_algebra {A : algebra S} (r : A.fst → A.fst → Prop) (h₁ : congruence r)
  --: algebra S := ⟨ quot r, Π (f : S.F), quot.lift f

  lemma cong_iff_hom_ker (r :  A → A → Prop) :
  congruence r ↔ ∃ B : algebra S, ∃ h : A → B,
                 homomorphic h ∧ ((kernel h) = r) :=
  iff.intro
  (assume h₁ : congruence r,
  show ∃ (B : algebra S) (h : A → B), homomorphic h ∧ (kernel h) = r, from sorry)
  (sorry)

  def image (f : A → B) : set B := λ b, ∃ a, f a = b

  def ker (f : α → β) : α → α → Prop := λ a a', f a = f a'

end ualib_quotient_algebra

  /-Notes from Ch. 11. Theorem Proving in Lean.

    In its most basic form, the quotient construction does not require
    r be an equivalence relation. The following are built into Lean
    as constants:
  -/

  #check @quot  --form the type quot r given a type α by any binary relation r on α.
  --constant quot : Π {α : Sort u}, (α → α → Prop) → Sort u

  #check @quot.mk   -- map α to quot α; if r : α → α → Prop and a : α, then
                    -- quot.mk r a ∈ quot r.
  --constant quot.mk : Π {α : Sort u} (r : α → α → Prop), α → quot r

  #check @quot.ind  --says that each element of quot.mk r a is of the form quot.mk r a.
  --axiom quot.ind : ∀ {α : Sort u} {r : α → α → Prop} {β : quot r → Prop},
  --(∀ a, β (quot.mk r a)) → ∀ (q : quot r), β q

  #check @quot.lift --given a function f : α → β, if h is a proof that f respects r,
                    -- then quot.lift f h
                    -- is the corresponding function on quot r.  -/
  --constant quot.lift : Π {α : Sort u} {r : α → α → Prop} {β : Sort u}
  --(f : α → β), (∀ a b, r a b → f a = f b) → quot r → β

  -- What makes quot into a bonafide quotient is the following additional axiom:
  #check @quot.sound
  -- axiom quot.sound: ∀ {α: Type u} {r: α → α → Prop} {a b: α}, r a b → quot.mk r a = quot.mk r b

  -- If a thm or def uses quot.sound, it will show up in #print axioms.
  --The quotient is most commonly used when r is an equivalence relation.
  --Given r as above, define r' as follows: ∀ a b, r' a b ↔ quot.mk r a = quot.mk r b,
  --Then it's clear that r' is an equivalence relation. Indeed, r' is the *kernel* of
  --the function a ↦ quot.mk r.  The axiom quot.sound says that r a b implies r' a b.
  --Using quot.lift and quot.ind, we can show that r' is the smallest equivalence
  --containing r. If r was already an equivalence, then ∀ a b, r a b ↔ r' a b.

  --To support this common use case, the std lib defines the notion of a *setoid*, which is
  --simply a type with an associated equivalence relation:

  #print setoid    --class setoid (α : Type u) := (r : α → α → Prop) (iseqv : equivalence r)


import tactic.by_contra
import tactic.interactive

example : 1 < 2 :=
begin
  by_contra' h,
  guard_hyp' h : 2 ≤ 1,
  revert h,
  exact dec_trivial
end

example : 1 < 2 :=
begin
  by_contra' h : 2 ≤ 1,
  guard_hyp' h : 2 ≤ 1, -- this is not defeq to `¬ 1 < 2`
  revert h,
  exact dec_trivial
end

example : 1 < 2 :=
begin
  by_contra' h : ¬ 1 < 2,
  guard_hyp' h : ¬ 1 < 2, -- this is not defeq to `2 ≤ 1`
  revert h,
  exact dec_trivial
end

example : 1 < 2 :=
begin
  by_contra' : 2 ≤ 1,
  guard_hyp' this : 2 ≤ 1, -- this is not defeq to `¬ 1 < 2`
  revert this,
  exact dec_trivial
end


import ch6_cont
universe u
namespace Set

local attribute [irreducible] mem
local attribute [instance] classical.prop_decidable

lemma finite_lin_order_is_well_order {A R : Set.{u}} (Afin : A.is_finite) (lin : A.lin_order R) : A.well_order R :=
begin
  rw well_order_iff_not_exists_desc_chain lin, rintro ⟨f, finto, hd⟩,
  refine nat_infinite (finite_of_dominated_by_finite Afin ⟨_, finto, _⟩),
  have h : ∀ {n : Set.{u}}, n ∈ nat.{u} → ∀ {m : Set}, m ∈ nat.{u} → n ∈ m → (f.fun_value m).pair (f.fun_value n) ∈ R,
    intros n nω m mω nm, rw lt_iff nω mω at nm, rcases nm with ⟨k, kω, nkm⟩, subst nkm, clear mω, revert k,
    refine @induction _ _ _,
      rw [add_ind nω zero_nat, add_base nω], exact hd nω,
    intros k kω ind,
    have kω' := nat_induct.succ_closed kω,
    rw add_ind nω kω', exact lin.trans (hd (add_into_nat nω kω')) ind,
  apply one_to_one_of finto.left, rw finto.right.left,
  intros m mω n nω mn fmn,
  obtain (mln|nlm) := nat_order_conn mω nω mn,
    specialize h mω nω mln, rw fmn at h, exact lin.irrefl h,
  specialize h nω mω nlm, rw fmn at h, exact lin.irrefl h,
end

lemma exists_smallest {A R : Set} (Ane : A ≠ ∅) (Afin : A.is_finite) (lin : A.lin_order R) :
  ∃ x : Set, x ∈ A ∧ ∀ {y : Set}, y ∈ A → y ≠ x → x.pair y ∈ R :=
begin
  obtain ⟨x, xA, xle⟩ := (finite_lin_order_is_well_order Afin lin).well Ane subset_self,
  refine ⟨x, xA, λ y yA yx, _⟩, apply classical.by_contradiction, intro xy, apply xle,
  cases lin.conn yA xA yx with yx xy',
    exact ⟨_, yA, yx⟩,
  exfalso, exact xy xy',
end

noncomputable def smallest (A R : Set) : Set :=
if Ane : A ≠ ∅ then
if fin : A.is_finite then
if lin : A.lin_order R then
classical.some (exists_smallest Ane fin lin)
else ∅ else ∅ else ∅
lemma smallest_mem {A R : Set} (Ane : A ≠ ∅) (Afin : A.is_finite) (lin : A.lin_order R) :
  A.smallest R ∈ A :=
begin
  rw [smallest, dif_pos Ane, dif_pos Afin, dif_pos lin],
  obtain ⟨xA, h⟩ := classical.some_spec (exists_smallest Ane Afin lin), exact xA,
end
lemma smallest_smallest {A R : Set} (Ane : A ≠ ∅) (Afin : A.is_finite) (lin : A.lin_order R)
  {y : Set} (yA : y ∈ A) (yx : y ≠ A.smallest R) : (A.smallest R).pair y ∈ R :=
begin
  rw [smallest, dif_pos Ane, dif_pos Afin, dif_pos lin] at yx ⊢,
  obtain ⟨xA, h⟩ := classical.some_spec (exists_smallest Ane Afin lin), exact h yA yx,
end

lemma finite_lin_order_iso_nat {A : Set} (fin : A.is_finite)
  {R : Set} (Rlin : A.lin_order R) : isomorphic A.card.eps_order_struct ⟨A, R, Rlin.rel⟩ :=
begin
  revert A,
  have h : ∀ {n : Set}, n ∈ ω → ∀ {A : Set}, A.card = n →
    ∀ {R : Set}, ∀ (Rlin : A.lin_order R), isomorphic n.eps_order_struct ⟨A, R, Rlin.rel⟩,
    refine @induction _ _ _,
      intros A Acard R Rlin,
      have Ae := eq_empty_of_card_empty Acard, subst Ae,
      refine ⟨_, empty_corr_empty, _⟩, dsimp, intros x y xe,
      exfalso, exact mem_empty _ xe,
    intros n nω ind A Acard R Rlin,
    have Ane : A ≠ ∅, apply ne_empty_of_zero_mem_card, rw Acard, exact zero_mem_succ nω,
    have Afin : A.is_finite, rw finite_iff, exact ⟨_, nat_induct.succ_closed nω, Acard⟩,
    let x := A.smallest R,
    let B := A \ {x},
    have ABx : A = B ∪ {x} := (diff_singleton_union_eq (smallest_mem Ane Afin Rlin)).symm,
    have Bcard : B.card = n,
      have Bfin : B.is_finite := subset_finite_of_finite Afin subset_diff,
      rw finite_iff at Bfin, rcases Bfin with ⟨m, mω, Bm⟩, rw Bm,
      apply cancel_add_right mω nω one_nat,
      rw [←succ_eq_add_one nω, ←Acard, ABx,
        ←card_add_eq_ord_add ⟨_, nat_finite mω, card_nat mω⟩ ⟨_, nat_finite one_nat, card_nat one_nat⟩,
        ←Bm, ←@card_singleton x, ←card_add_spec rfl rfl],
      rw [←@self_inter_diff_empty {x} A, inter_comm],
    let S := R \ (prod {x} A),
    have Slin : B.lin_order S, split,
      { simp only [subset_def, mem_diff, mem_prod, exists_prop, mem_singleton, mem_diff],
        rintros z ⟨zR, h⟩, have zA : z ∈ A.prod A := Rlin.rel zR,
        rw mem_prod at zA, rcases zA with ⟨a, aA, b, bA, zab⟩, subst zab,
        refine ⟨_, ⟨aA, λ ax, h ⟨_, ax, _, bA, rfl⟩⟩, _, ⟨bA, λ bx, _⟩, rfl⟩,
        refine not_lt_and_gt_part (part_order_of_lin_order Rlin) ⟨zR, _⟩,
        rw bx, apply smallest_smallest Ane Afin Rlin aA, intro ax, rw [bx, ax] at zR,
        exact Rlin.irrefl zR, },
      { intros a b c ab bc, rw [mem_diff, pair_mem_prod, mem_singleton] at ab bc ⊢,
        refine ⟨Rlin.trans ab.left bc.left, _⟩, rintro ⟨ax, cA⟩, apply ab.right,
        have abA : a.pair b ∈ A.prod A := Rlin.rel ab.left,
        rw pair_mem_prod at abA, exact ⟨ax, abA.right⟩, },
      { intros x xx, rw mem_diff at xx, exact Rlin.irrefl xx.left, },
      { intros a b aB bB ab, simp only [mem_diff, pair_mem_prod, mem_singleton] at aB bB ⊢,
        cases Rlin.conn aB.left bB.left ab,
          exact or.inl ⟨h, λ h, aB.right h.left⟩,
        exact or.inr ⟨h, λ h, bB.right h.left⟩, },
    specialize ind Bcard Slin, rcases ind with ⟨f, ⟨fonto, foto⟩, fiso⟩, dsimp at fiso fonto,
    have de : (pair_sep_eq n.succ A (λ k, if k = ∅ then x else f.fun_value (pred.fun_value k))).dom = n.succ,
      apply pair_sep_eq_dom_eq, intros k kn, dsimp,
      have kω : k ∈ ω := mem_nat_of_mem_nat_of_mem (nat_induct.succ_closed nω) kn,
      by_cases kz : k = ∅,
        subst kz, rw if_pos rfl, exact smallest_mem Ane Afin Rlin,
      rw if_neg kz, obtain ⟨k', kω', kk'⟩ := or.resolve_left (exists_pred kω) kz, subst kk',
      rw pred_succ_eq_self kω',
      have fkB : f.fun_value k' ∈ B, rw ←fonto.right.right, apply fun_value_def'' fonto.left,
        rw [fonto.right.left, mem_iff_succ_mem_succ kω' nω], exact kn,
      rw mem_diff at fkB, exact fkB.left,
    refine ⟨pair_sep_eq n.succ A (λ k, if k = ∅ then x else f.fun_value (pred.fun_value k)),
      ⟨⟨pair_sep_eq_is_fun, de, pair_sep_eq_ran_eq _⟩, pair_sep_eq_oto _⟩, _⟩,
    { intros y yA, by_cases yx : y = x,
        refine ⟨_, zero_mem_succ nω, _⟩, dsimp, rw if_pos rfl, exact yx,
      have yB : y ∈ B, rw [mem_diff, mem_singleton], exact ⟨yA, yx⟩,
      rw [←fonto.right.right, mem_ran_iff fonto.left, fonto.right.left] at yB,
      rcases yB with ⟨k, kn, yk⟩,
      have kω := mem_nat_of_mem_nat_of_mem nω kn, subst yk, refine ⟨_, (mem_iff_succ_mem_succ kω nω).mp kn, _⟩,
      dsimp, rw [if_neg succ_neq_empty, pred_succ_eq_self kω], },
    { intros m mn k kn fmk,
      have kω := mem_nat_of_mem_nat_of_mem (nat_induct.succ_closed nω) kn,
      have mω := mem_nat_of_mem_nat_of_mem (nat_induct.succ_closed nω) mn,
      dsimp at fmk,
      by_cases mz : m = ∅, subst mz, rw if_pos rfl at fmk,
        by_cases kz : k = ∅, subst kz,
        rw if_neg kz at fmk, obtain ⟨k', kω', kk'⟩ := or.resolve_left (exists_pred kω) kz, subst kk',
        rw pred_succ_eq_self kω' at fmk,
        have xB : x ∈ B, rw [←fonto.right.right, mem_ran_iff fonto.left, fonto.right.left],
          use k', rw mem_iff_succ_mem_succ kω' nω, exact ⟨kn, fmk⟩,
        rw [mem_diff, mem_singleton] at xB, exfalso, exact xB.right rfl,
      rw if_neg mz at fmk, obtain ⟨m', mω', mm'⟩ := or.resolve_left (exists_pred mω) mz, subst mm',
      rw pred_succ_eq_self mω' at fmk,
      by_cases kz : k = ∅,
        subst kz, rw if_pos rfl at fmk,
        have xB : x ∈ B, rw [←fonto.right.right, mem_ran_iff fonto.left, fonto.right.left],
          use m', rw mem_iff_succ_mem_succ mω' nω, exact ⟨mn, fmk.symm⟩,
        rw [mem_diff, mem_singleton] at xB, exfalso, exact xB.right rfl,
      rw if_neg kz at fmk, obtain ⟨k', kω', kk'⟩ := or.resolve_left (exists_pred kω) kz, subst kk',
      rw pred_succ_eq_self kω' at fmk, congr,
      rw ←mem_iff_succ_mem_succ mω' nω at mn, rw ←mem_iff_succ_mem_succ kω' nω at kn,
      rw ←fonto.right.left at mn kn, exact from_one_to_one fonto.left foto mn kn fmk, },
    { rw [eps_order_struct_fld, eps_order_struct_rel], dsimp, intros m k mn kn,
      have kω := mem_nat_of_mem_nat_of_mem (nat_induct.succ_closed nω) kn,
      have mω := mem_nat_of_mem_nat_of_mem (nat_induct.succ_closed nω) mn,
      rw [pair_mem_eps_order' mn kn], rw ←de at mn kn,
      rw [pair_sep_eq_fun_value mn, pair_sep_eq_fun_value kn], dsimp, rw de at mn kn,
      by_cases kz : k = ∅,
        subst kz, rw if_pos rfl,
        by_cases mz : m = ∅,
          subst mz, rw if_pos rfl, split,
            intro ee, exfalso, exact mem_empty _ ee,
          intro xx, exfalso, exact Rlin.irrefl xx,
        rw if_neg mz, obtain ⟨m', mω', mm'⟩ := or.resolve_left (exists_pred mω) mz, subst mm',
        rw pred_succ_eq_self mω', split,
          intro mz', exfalso, exact mem_empty _ mz',
        intro fmx,
        have fmA : f.fun_value m' ∈ B, rw ←fonto.right.right,
          apply fun_value_def'' fonto.left, rw [fonto.right.left, mem_iff_succ_mem_succ mω' nω],
          exact mn,
        rw [mem_diff, mem_singleton] at fmA, exfalso,
        exact not_lt_and_gt_part (part_order_of_lin_order Rlin) ⟨fmx, smallest_smallest Ane Afin Rlin fmA.left fmA.right⟩,
      rw if_neg kz, obtain ⟨k', kω', kk'⟩ := or.resolve_left (exists_pred kω) kz, subst kk',
      rw pred_succ_eq_self kω',
      by_cases mz : m = ∅,
        subst mz, rw if_pos rfl,
        have fkB : f.fun_value k' ∈ B, rw ←fonto.right.right, apply fun_value_def'' fonto.left,
          rw [fonto.right.left, mem_iff_succ_mem_succ kω' nω], exact kn,
        rw [mem_diff, mem_singleton] at fkB, split,
          intro zk, exact smallest_smallest Ane Afin Rlin fkB.left fkB.right,
        intro xfk, exact zero_mem_succ kω',
      rw if_neg mz, obtain ⟨m', mω', mm'⟩ := or.resolve_left (exists_pred mω) mz, subst mm',
      rw [pred_succ_eq_self mω', ←mem_iff_succ_mem_succ mω' kω'],
      rw ←mem_iff_succ_mem_succ mω' nω at mn, rw ←mem_iff_succ_mem_succ kω' nω at kn,
      specialize fiso mn kn, rw [pair_mem_eps_order' mn kn, mem_diff] at fiso, rw fiso,
      simp only [pair_mem_prod, not_and, and_iff_left_iff_imp, mem_singleton],
      intros fmk fmx fkA,
      have fmB : f.fun_value m' ∈ B, rw ←fonto.right.right, apply fun_value_def'' fonto.left,
        rw fonto.right.left, exact mn,
      rw [mem_diff, mem_singleton] at fmB, exact fmB.right fmx, },
  intros A Afin Rlin,
  rw finite_iff at Afin, rcases Afin with ⟨n, nω, Acard⟩,
  rw Acard, exact h nω Acard Rlin,
end

-- problem 19 chapter 7
lemma finite_lin_order_iso {A : Set} (fin : A.is_finite)
  {R : Set} (Rlin : A.lin_order R) {S : Set} (Slin : A.lin_order S) :
  isomorphic ⟨A, R, Rlin.rel⟩ ⟨A, S, Slin.rel⟩ :=
iso_trans (iso_symm (finite_lin_order_iso_nat fin Rlin)) (finite_lin_order_iso_nat fin Slin)

-- chapter 7 exercise 20
lemma finite_of_well_orderings {A R : Set} (Rwell : A.well_order R) (Rwell' : A.well_order R.inv) : A.is_finite :=
begin
  have eg : ∀ {X : Set}, X ≠ ∅ → X ⊆ A → ∃ m : Set, m ∈ X ∧ ∀ {x : Set}, x ∈ X → R.lin_le x m,
    intros X XE XA, obtain ⟨m, mX, ge⟩ := Rwell'.well XE XA,
    rw [is_least] at ge, push_neg at ge, refine ⟨_, mX, λ x, assume xX, _⟩,
    rw le_iff_not_lt Rwell.lin (XA xX) (XA mX),
    specialize ge _ xX, rw pair_mem_inv at ge, exact ge,
  let closed := λ X : Set, ∀ {y : Set}, y ∈ X → ∀ {x : Set}, x.pair y ∈ R → x ∈ X,
  have un : ∀ {X : Set}, X ≠ ∅ → X ⊆ A → closed X → ∃ m : Set, m ∈ X ∧ X = (R.seg m) ∪ {m},
    intros X XE XA cl, obtain ⟨m, mX, ge⟩ := eg XE XA, refine ⟨m, mX, _⟩,
    apply ext, intro x, rw [mem_union, mem_singleton, mem_seg, ←lin_le], split,
      exact ge, rintro (xm|xm),
        exact cl mX xm,
      subst xm, exact mX,
  have segcl : ∀ {t : Set}, t ∈ A → closed (R.seg t), intros t tA y yt x xy,
    rw mem_seg at *, exact Rwell.lin.trans xy yt,
  have segsub : ∀ {t : Set}, t ∈ A → R.seg t ⊆ A, intros t tA x xt,
    rw mem_seg at xt, replace xt := Rwell.lin.rel xt, rw pair_mem_prod at xt,
    exact xt.left,
  have Acl : closed A, intros y yA x xy, replace xy := Rwell.lin.rel xy,
    rw pair_mem_prod at xy, exact xy.left,
  let B := {x ∈ A | (R.seg x).is_finite},
  have BA : B = A, apply transfinite_ind Rwell sep_subset,
    intros x xA ind, rw mem_sep,
    by_cases se : R.seg x = ∅,
      rw [se, ←card_finite_iff_finite, card_nat zero_nat, finite_cardinal_iff_nat],
      exact ⟨xA, zero_nat⟩,
    obtain ⟨m, mx, eq⟩ := un se (segsub xA) (@segcl _ xA), rw eq,
    specialize ind mx, rw mem_sep at ind,
    exact ⟨xA, union_finite_of_finite ind.right singleton_finite⟩,
  by_cases Ae : A = ∅,
    subst Ae, rw [←card_finite_iff_finite, card_nat zero_nat, finite_cardinal_iff_nat],
    exact zero_nat,
  obtain ⟨m, mx, eq⟩ := un Ae subset_self @Acl, rw eq, rw [←BA, mem_sep] at mx,
  exact union_finite_of_finite mx.right singleton_finite,
end

-- end of chapter 7 starting from page 199

lemma card_is_ord {κ : Set} (κcard : κ.is_cardinal) : κ.is_ordinal :=
begin
  rcases κcard with ⟨K, Kcard⟩, rw ←Kcard, exact card_is_ordinal,
end

lemma card_is_ord' {A : Set} : A.card.is_ordinal :=
card_is_ord ⟨_, rfl⟩

lemma card_lt_of_mem {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) (κμ : κ ∈ μ) : κ.card_lt μ :=
begin
  have κord := card_is_ord κcard,
  have μord := card_is_ord μcard,
  rw ord_mem_iff_ssub κord μord at κμ,
  rw card_lt, refine ⟨_, κμ.right⟩,
  rw [←card_of_cardinal_eq_self κcard, ←card_of_cardinal_eq_self μcard],
  exact card_le_of_subset κμ.left,
end

lemma not_card_lt_of_not_mem {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) (κμ : κ ∉ μ) : ¬ κ.card_lt μ :=
begin
  have κord := card_is_ord κcard,
  have μord := card_is_ord μcard,
  rw ←ord_not_le_iff_lt μord κord at κμ, push_neg at κμ,
  have μκ : μ.card_le κ, cases κμ,
      exact (card_lt_of_mem μcard κcard κμ).left,
    subst κμ, exact card_le_refl,
  intro lt,
  exact lt.right (card_eq_of_le_of_le κcard μcard lt.left μκ),
end

lemma card_lt_iff_mem {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) : κ.card_lt μ ↔ κ ∈ μ :=
⟨λ κμ, classical.by_contradiction (λ nκμ, (not_card_lt_of_not_mem κcard μcard nκμ) κμ), card_lt_of_mem κcard μcard⟩

lemma card_le_iff_le {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) : κ.card_le μ ↔ κ ≤ μ :=
by rw [card_le_iff, le_iff, card_lt_iff_mem κcard μcard]

lemma ord_dom_of_le {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal)
  (αβ : α ≤ β) : α ≼ β :=
begin
  rw ord_le_iff_sub αord βord at αβ, rw dominated_iff,
  exact ⟨_, αβ, equin_refl⟩,
end

lemma ord_lt_of_card_lt {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal)
  (lt : α.card.card_lt β.card) : α ∈ β :=
begin
  rw card_lt_iff at lt, rw ←ord_not_le_iff_lt βord αord, intro le, apply lt.right,
  exact equin_of_dom_of_dom lt.left (ord_dom_of_le βord αord le),
end

-- problem 24 lemma
lemma ord_mem_card_powerset {α : Set} (αord : α.is_ordinal) : α ∈ α.powerset.card :=
begin
  apply ord_lt_of_card_lt αord card_is_ord', rw [card_of_cardinal_eq_self ⟨_, rfl⟩, card_power],
  exact card_lt_exp ⟨_, rfl⟩,
end

-- problem 24
lemma exists_larger_card {α : Set} (αord : α.is_ordinal) : ∃ κ : Set, κ.is_cardinal ∧ α ∈ κ :=
⟨_, ⟨_, rfl⟩, ord_mem_card_powerset αord⟩

-- problem 25
lemma trans_ind_schema {φ : Set → Prop} (ind : ∀ {α : Set}, α.is_ordinal → (∀ {x : Set}, x ∈ α → φ x) → φ α)
  (α : Set) (αord : α.is_ordinal) : φ α :=
begin
  let X := {x ∈ α.succ | φ x},
  have Xα : X = α.succ,
    apply transfinite_ind (ordinal_well_ordered (succ_ord_of_ord αord)) sep_subset,
    intros t tα hi, rw mem_sep, refine ⟨tα, ind (ord_of_mem_ord (succ_ord_of_ord αord) tα) _⟩,
    intros x xt,
    suffices xX : x ∈ X, rw mem_sep at xX, exact xX.right,
    apply hi, rw [mem_seg, eps_order, pair_mem_pair_sep' (ord_mem_trans (succ_ord_of_ord αord) xt tα) tα],
    exact xt,
  suffices h : α ∈ X, rw mem_sep at h, exact h.right,
  rw Xα, exact self_mem_succ,
end

def init_ord (α : Set) : Prop := α.is_ordinal ∧ ¬ ∃ β : Set, β ∈ α ∧ α ≈ β

theorem init_iff_card {α : Set} : α.init_ord ↔ α.is_cardinal :=
begin
  split,
    intro init, use α, symmetry, apply eq_card init.left equin_refl,
    intros β βord αβ, apply classical.by_contradiction, intro le,
    rw ord_not_le_iff_lt init.left βord at le, exact init.right ⟨_, le, αβ⟩,
  intro αcard,
  have eq := card_of_cardinal_eq_self αcard, rw ←eq, refine ⟨card_is_ordinal, _⟩,
  rintro ⟨β, βA, Aβ⟩,
  have βord := ord_of_mem_ord card_is_ordinal βA,
  rw ←ord_not_le_iff_lt card_is_ordinal βord at βA,
  rw eq at Aβ, apply βA, exact card_least βord Aβ,

end

lemma omega_is_card : is_cardinal ω :=
begin
  rw ←init_iff_card, split,
    exact omega_is_ord,
  rintro ⟨n, nω, ωn⟩, exact nat_infinite ⟨_, nω, ωn⟩,
end

lemma exists_powersets (X : Set) : ∃ B : Set, ∀ (y : Set), y ∈ B ↔ ∃ x : Set, x ∈ X ∧ y = x.powerset :=
replacement'' powerset
noncomputable def powersets (X : Set.{u}) : Set.{u} := classical.some X.exists_powersets
lemma mem_powersets {X y : Set} : y ∈ X.powersets ↔ ∃ x : Set, x ∈ X ∧ y = x.powerset :=
classical.some_spec X.exists_powersets y

lemma L7Q {δ : Set} (δord : δ.is_ordinal) :
  ∃ F : Set, F.is_function ∧ F.dom = δ ∧ ∀ ⦃α : Set⦄, α ∈ δ → F.fun_value α = ((F.img α).powersets).Union :=
begin
  obtain ⟨F, Ffun, Fdom, Fspec⟩ := exists_of_exists_unique (@transfinite_rec' δ δ.eps_order (ordinal_well_ordered δord) (fun x, x.ran.powersets.Union)),
  refine ⟨_, Ffun, Fdom, λ α αδ, _⟩, specialize Fspec αδ, rw Fspec,
  dsimp, rw [restrict_ran, seg_eq_of_trans (ordinal_trans δord) αδ],
end

noncomputable def L7Q_fun (δ : Set) : Set := if δord : δ.is_ordinal then classical.some (L7Q δord) else ∅
lemma L7Q_fun_spec {δ : Set} (δord : δ.is_ordinal) :
  δ.L7Q_fun.is_function ∧ δ.L7Q_fun.dom = δ ∧ ∀ ⦃α : Set⦄, α ∈ δ → δ.L7Q_fun.fun_value α = ((δ.L7Q_fun.img α).powersets).Union :=
begin
  simp [L7Q_fun, dif_pos δord], exact classical.some_spec (L7Q δord),
end

lemma L7R : ∀ {δ : Set}, δ.is_ordinal → ∀ {ε : Set}, ε.is_ordinal →
  ∀ {α : Set}, α ∈ δ ∩ ε → δ.L7Q_fun.fun_value α = ε.L7Q_fun.fun_value α :=
begin
  have h₁ : ∀ {δ : Set}, δ.is_ordinal → ∀ {α : Set}, α ∈ δ → ∀ {z : Set}, z ∈ (δ.L7Q_fun.img α).powersets ↔ ∃ β : Set, β ∈ α ∧ z = (δ.L7Q_fun.fun_value β).powerset,
    intros δ δord α αδ z, rw mem_powersets,
    have αord : α.is_ordinal := ord_of_mem_ord δord αδ,
    rw ord_mem_iff_ssub αord δord at αδ,
    obtain ⟨δfun, δdom, -⟩ := L7Q_fun_spec δord, rw ←δdom at αδ, simp only [mem_img' δfun αδ.left], split,
      rintro ⟨y, ⟨β, βα, yfβ⟩, zy⟩, subst yfβ, exact ⟨_, βα, zy⟩,
    rintro ⟨β, βα, zf⟩, exact ⟨_, ⟨_, βα, rfl⟩, zf⟩,
  have h₂ : ∀ {δ : Set}, δ.is_ordinal → ∀ {ε : Set}, ε.is_ordinal → δ ⊆ ε → {α ∈ δ | δ.L7Q_fun.fun_value α = ε.L7Q_fun.fun_value α} = δ,
    intros δ δord ε εord δε, apply transfinite_ind (ordinal_well_ordered δord) sep_subset,
    obtain ⟨-, -, δspec⟩ := L7Q_fun_spec δord, obtain ⟨-, -, εspec⟩ := L7Q_fun_spec εord,
    intros α αδ ind, rw [mem_sep, δspec αδ, εspec (δε αδ)], refine ⟨αδ, _⟩,
    congr' 1, apply ext, simp only [h₁ δord αδ, h₁ εord (δε αδ)], intro z, apply exists_congr,
    intro β, rw and.congr_right_iff, intro βα,
    suffices hβ : β ∈ δ.eps_order.seg α, specialize ind hβ, rw mem_sep at ind, rw ind.right,
    rw [mem_seg, eps_order, pair_mem_pair_sep' (ord_mem_trans δord βα αδ) αδ], exact βα,
  intros δ δord ε εord α hα, cases ord_conn' δord εord,
    rw ord_le_iff_sub δord εord at h, rw inter_eq_of_sub h at hα,
    specialize h₂ δord εord h, rw [←h₂, mem_sep] at hα, exact hα.right,
  rw ord_le_iff_sub εord δord at h, rw [inter_comm, inter_eq_of_sub h] at hα,
  specialize h₂ εord δord h, rw [←h₂, mem_sep] at hα, exact hα.right.symm,
end

noncomputable def Veb (α : Set) : Set := α.succ.L7Q_fun.fun_value α
noncomputable def Veb_img (α : Set) : Set :=
classical.some (@replacement'' Veb α)
lemma mem_Veb_img {α V : Set} : V ∈ α.Veb_img ↔ ∃ β : Set, β ∈ α ∧ V = β.Veb :=
classical.some_spec (@replacement'' Veb α)

-- Theorem 7S
theorem Veb_eq {α : Set} (αord : α.is_ordinal) : α.Veb = α.Veb_img.powersets.Union :=
begin
  obtain ⟨f, dom, spec⟩ := L7Q_fun_spec (succ_ord_of_ord αord),
  rw [Veb, spec self_mem_succ], congr, apply ext, intro V,
  have subdom : α ⊆ α.succ.L7Q_fun.dom, rw dom, exact self_sub_succ,
  simp only [mem_img' f subdom, mem_Veb_img, Veb], apply exists_congr,
  intro β, rw and.congr_right_iff, intro βα, apply eq.congr_right,
  apply L7R (succ_ord_of_ord αord) (succ_ord_of_ord (ord_of_mem_ord αord βα)),
  rw mem_inter, refine ⟨_, self_mem_succ⟩, rw [succ, mem_union], right, exact βα,
end

lemma mem_Veb {α : Set} (αord : α.is_ordinal) {X : Set} : X ∈ α.Veb ↔ ∃ β : Set, β ∈ α ∧ X ⊆ β.Veb :=
begin
  simp only [Veb_eq αord, mem_Union, exists_prop, mem_powersets, mem_Veb_img], split,
    rintro ⟨Y, ⟨V, ⟨β, βα, Vβ⟩, YV⟩, XY⟩, subst Vβ, subst YV, rw mem_powerset at XY, exact ⟨_, βα, XY⟩,
  rintro ⟨β, βα, Xβ⟩, refine ⟨_, ⟨_, ⟨_, βα, rfl⟩, rfl⟩, _⟩, rw mem_powerset, exact Xβ,
end

-- Theorem 7T
theorem Veb_transitive : ∀ {α : Set}, α.is_ordinal → α.Veb.transitive_set :=
begin
  refine trans_ind_schema _, intros α αord hi, rw transitive_set_iff', intros X XV,
  simp only [Veb_eq αord, mem_Union, exists_prop, mem_powersets, mem_Veb_img] at XV,
  rcases XV with ⟨S, ⟨V, ⟨β, βα, Vβ⟩, SV⟩, XS⟩, subst SV, subst Vβ,
  have h := powerset_transitive (hi βα), rw transitive_set_iff' at h,
  specialize h XS, apply subset_trans h, intros Z Zβ,
  simp only [Veb_eq αord, mem_Union, exists_prop, mem_powersets, mem_Veb_img],
  exact ⟨_, ⟨_, ⟨_, βα, rfl⟩, rfl⟩, Zβ⟩,
end

structure limit_ord (α : Set) : Prop :=
(ord : α.is_ordinal)
(ne : α ≠ ∅)
(ns : ¬ ∃ β : Set, α = β.succ)

lemma succ_mem_limit {γ : Set} (γord : γ.limit_ord) {β : Set} (βγ : β ∈ γ) : β.succ ∈ γ :=
begin
  cases succ_least_upper_bound γord.ord βγ,
    exact h,
  exfalso, exact γord.ns ⟨_, h.symm⟩,
end

lemma limit_ord_of_not_bound {γ : Set} (γord : γ.is_ordinal) (γne : γ ≠ ∅)
  (h : ¬ ∃ β : Set, β ∈ γ ∧ ∀ {α : Set}, α ∈ γ → α ≤ β) : γ.limit_ord :=
begin
  refine ⟨γord, γne, _⟩, rintro ⟨β, βγ⟩, apply h, subst βγ, refine ⟨_, self_mem_succ, λ α αβ, _⟩,
  rw ←mem_succ_iff_le, exact αβ,
end

lemma limit_ord_not_bounded {γ : Set} (γord : γ.limit_ord) :
  ¬ ∃ β : Set, β ∈ γ ∧ ∀ {α : Set}, α ∈ γ → α ≤ β :=
begin
  rintro ⟨β, βγ, h⟩,
  specialize h (succ_mem_limit γord βγ),
  have βord := ord_of_mem_ord γord.ord βγ,
  rw ←ord_not_lt_iff_le βord (succ_ord_of_ord βord) at h,
  exact h self_mem_succ,
end

lemma limit_ord_inf {γ : Set} (γord : γ.limit_ord) : ¬ γ.is_finite :=
begin
  apply inf_of_sup_inf nat_infinite, rw subset_def,
  apply induction,
    rw ←ord_not_le_iff_lt γord.ord (nat_is_ord zero_nat), rintro (h|h),
      exact mem_empty _ h,
    exact γord.ne h,
  intros n nω nγ, exact succ_mem_limit γord nγ,
end

-- Theorem 7U part a
theorem Veb_sub_of_mem {β α : Set} (αord : α.is_ordinal) (βα : β ∈ α) : β.Veb ⊆ α.Veb :=
begin
  intros X Xβ, rw mem_Veb αord,
  have βord := ord_of_mem_ord αord βα,
  have trans := Veb_transitive βord, rw transitive_set_iff' at trans,
  exact ⟨_, βα, trans Xβ⟩,
end

-- Theorem 7U part b
theorem Veb_null_eq_null : Veb ∅ = ∅ :=
begin
  rw eq_empty, intros z zV, rw mem_Veb zero_is_ord at zV,
  rcases zV with ⟨β, βn, -⟩, exact mem_empty _ βn,
end

-- Theorem 7U part c
theorem Veb_succ_eq_powerset {α : Set} (αord : α.is_ordinal) : α.succ.Veb = α.Veb.powerset :=
begin
  apply ext, simp only [mem_Veb (succ_ord_of_ord αord), mem_powerset], intro X, split,
    rintro ⟨β, βα, Xβ⟩, rw [succ, mem_union, mem_singleton] at βα, cases βα,
      subst βα, exact Xβ,
    exact subset_trans Xβ (Veb_sub_of_mem αord βα),
  intro Xα, exact ⟨_, self_mem_succ, Xα⟩,
end

lemma mem_Union_Veb_img {α X : Set} : X ∈ α.Veb_img.Union ↔ ∃ β : Set, β ∈ α ∧ X ∈ β.Veb :=
begin
  simp only [mem_Union, exists_prop, mem_Veb_img], split,
    rintro ⟨V, ⟨β, βα, Vβ⟩, XV⟩, subst Vβ, exact ⟨_, βα, XV⟩,
  rintro ⟨β, βα, Xβ⟩, exact ⟨_, ⟨_, βα, rfl⟩, Xβ⟩,
end

-- Theorem 7U part d
theorem Veb_limit_ord_eq {γ : Set} (γord : γ.limit_ord) : γ.Veb = γ.Veb_img.Union :=
begin
  apply ext, simp only [mem_Veb γord.ord, mem_Union_Veb_img], intro X, split,
    rintro ⟨β, βγ, Xβ⟩, refine ⟨_, succ_mem_limit γord βγ, _⟩,
    rw [Veb_succ_eq_powerset (ord_of_mem_ord γord.ord βγ), mem_powerset], exact Xβ,
  rintro ⟨β, βγ, Xβ⟩,
  have trans := Veb_transitive (ord_of_mem_ord γord.ord βγ),
  rw transitive_set_iff' at trans, exact ⟨_, βγ, trans Xβ⟩,
end

lemma exists_least_ord_of_exists {p : Set → Prop} (h : ∃ α : Set, α.is_ordinal ∧ p α) :
  ∃ α : Set, α.is_ordinal ∧ p α ∧ ∀ {β : Set}, β.is_ordinal → p β → α ≤ β :=
begin
  rcases h with ⟨α, αord, pα⟩,
  have αord' := succ_ord_of_ord αord,
  let X := {β ∈ α.succ | p β},
  have XE : X ≠ ∅, apply ne_empty_of_inhabited, use α, rw mem_sep, exact ⟨self_mem_succ, pα⟩,
  obtain ⟨γ, γX, h⟩ := (ordinal_well_ordered αord').well XE sep_subset,
  rw mem_sep at γX, refine ⟨_, ord_of_mem_ord αord' γX.left, γX.right, λ β, assume βord pβ, _⟩,
  apply classical.by_contradiction, intro γβ, apply h, use β,
  rw ord_not_le_iff_lt (ord_of_mem_ord αord' γX.left) βord at γβ,
  have βα := ord_mem_trans αord' γβ γX.left,
  rw [mem_sep, eps_order, pair_mem_pair_sep' βα γX.left],
  exact ⟨⟨βα, pβ⟩, γβ⟩,
end

def grounded (A : Set) : Prop := ∃ α : Set, α.is_ordinal ∧ A ⊆ α.Veb

noncomputable def rank (A : Set) : Set := if h : A.grounded then classical.some (exists_least_ord_of_exists h) else ∅
lemma rank_ord_of_grounded {A : Set} (Agr : A.grounded) : A.rank.is_ordinal :=
begin
  simp only [rank, dif_pos Agr],
  obtain ⟨h, -, -⟩ := classical.some_spec (exists_least_ord_of_exists Agr),
  exact h,
end
lemma rank_sub_of_grounded {A : Set} (Agr : A.grounded) : A ⊆ A.rank.Veb :=
begin
  simp only [rank, dif_pos Agr],
  obtain ⟨-, h, -⟩ := classical.some_spec (exists_least_ord_of_exists Agr),
  exact h,
end
lemma rank_least_of_grounded {A : Set} (Agr : A.grounded) : ∀ {β : Set}, β.is_ordinal → A ⊆ β.Veb → A.rank ≤ β :=
begin
  simp only [rank, dif_pos Agr],
  obtain ⟨-, -, h⟩ := classical.some_spec (exists_least_ord_of_exists Agr),
  exact @h,
end

lemma ord_not_sub_Veb {α : Set} (αord : α.is_ordinal) : ∀ {β : Set}, β ∈ α → ¬ (α ⊆ β.Veb) :=
begin
  revert α, refine trans_ind_schema _, intros α αord ind β βα αβ,
  suffices ββ : β ∉ β.Veb,
    exact ββ (αβ βα),
  rw mem_Veb (ord_of_mem_ord αord βα), rintro ⟨δ, δβ, βδ⟩,
  exact ind βα δβ βδ,
end

lemma ord_sub_Veb_self {α : Set} (αord : α.is_ordinal) : α ⊆ α.Veb :=
begin
  revert α, refine trans_ind_schema _, intros α αord ind β βα,
  specialize ind βα, rw mem_Veb αord, exact ⟨_, βα, ind⟩,
end

-- exercise 26
theorem ord_grounded {α : Set} (αord : α.is_ordinal) : α.grounded := ⟨_, αord, ord_sub_Veb_self αord⟩
theorem rank_ord_eq_self {α : Set} (αord : α.is_ordinal) : α.rank = α :=
begin
  have h := rank_least_of_grounded (ord_grounded αord) αord (ord_sub_Veb_self αord),
  cases h,
    exfalso, exact ord_not_sub_Veb αord h (rank_sub_of_grounded (ord_grounded αord)),
  exact h,
end

-- Theorem 7V part a part 1
theorem grounded_of_mem_grounded {A : Set} (Agr : A.grounded) {a : Set} (aA : a ∈ A) : a.grounded :=
begin
  obtain ⟨α, αord, Aα⟩ := Agr,
  have trans := Veb_transitive αord, rw transitive_set_iff' at trans,
  exact ⟨_, αord, trans (Aα aA)⟩,
end

-- Theorem 7V part a part 2
theorem rank_mem_of_mem_grounded {A : Set} (Agr : A.grounded) {a : Set} (aA : a ∈ A) : a.rank ∈ A.rank :=
begin
  have h : a ∈ A.rank.Veb := (rank_sub_of_grounded Agr) aA,
  have Aord : A.rank.is_ordinal := rank_ord_of_grounded Agr,
  rw mem_Veb Aord at h, rcases h with ⟨β, βA, aβ⟩,
  apply @ord_lt_of_le_of_lt _ β _ Aord,
    exact (rank_least_of_grounded (grounded_of_mem_grounded Agr aA) (ord_of_mem_ord Aord βA) aβ),
  exact βA,
end

lemma T7V_ord {A : Set} (hA : ∀ {a : Set}, a ∈ A → a.grounded) : (A.repl_img (succ ∘ rank)).Union.is_ordinal :=
begin
  apply Union_ords_is_ord, intros β βA,
  rw mem_repl_img at βA, rcases βA with ⟨a, aA, βa⟩, subst βa,
  apply succ_ord_of_ord (rank_ord_of_grounded (hA aA)),
end

lemma T7V_sub {A : Set} (hA : ∀ {a : Set}, a ∈ A → a.grounded) : A ⊆ (A.repl_img (succ ∘ rank)).Union.Veb :=
begin
  intros a aA,
  have aa : a ∈ a.rank.succ.Veb,
    rw [Veb_succ_eq_powerset (rank_ord_of_grounded (hA aA)), mem_powerset],
    exact rank_sub_of_grounded (hA aA),
  have aα : a.rank.succ ≤ (A.repl_img (succ ∘ rank)).Union,
    rw ord_le_iff_sub (succ_ord_of_ord (rank_ord_of_grounded (hA aA))) (T7V_ord @hA),
    apply subset_Union, rw mem_repl_img, exact ⟨_, aA, rfl⟩,
  cases aα,
    exact Veb_sub_of_mem (T7V_ord @hA) aα aa,
  rw ←aα, exact aa,
end

-- Theorem 7V part b part 1
theorem grounded_of_all_mem_grounded {A : Set} (hA : ∀ {a : Set}, a ∈ A → a.grounded) : A.grounded :=
⟨_, T7V_ord @hA, T7V_sub @hA⟩

-- Theorem 7V part b part 2
theorem rank_eq_of_all_mem_grounded {A : Set} (hA : ∀ {a : Set}, a ∈ A → a.grounded) : A.rank = (A.repl_img (succ ∘ rank)).Union :=
begin
  let α := (A.repl_img (succ ∘ rank)).Union,
  have Agr := grounded_of_all_mem_grounded @hA,
  rw ord_eq_iff_le_and_le (rank_ord_of_grounded Agr) (T7V_ord @hA), split,
    exact rank_least_of_grounded Agr (T7V_ord @hA) (T7V_sub @hA),
  have h₁ : ∀ {a : Set}, a ∈ A → a.rank.succ ≤ A.rank,
    intros a aA, exact succ_least_upper_bound (rank_ord_of_grounded Agr) (rank_mem_of_mem_grounded Agr aA),
  have h₂ : ∀ {β : Set}, β.is_ordinal →  (∀ {a : Set}, a ∈ A → a.rank.succ ≤ β) → α ≤ β,
    intros β βord hβ, rw ord_le_iff_sub (T7V_ord @hA) βord,
    intro δ, simp only [mem_Union, exists_prop, mem_repl_img],
    rintro ⟨Z, ⟨a, aA, Za⟩, δZ⟩, subst Za,
    specialize hβ aA, rw ord_le_iff_sub (succ_ord_of_ord (rank_ord_of_grounded (hA aA))) βord at hβ,
    exact hβ δZ,
  exact h₂ (rank_ord_of_grounded Agr) @h₁,
end

noncomputable def cl_fun (C : Set) : Set :=
trans_rec ω nat_order (λ f, C ∪ f.ran.Union.Union)
lemma cl_fun_fun {C : Set} : C.cl_fun.is_function := trans_rec_fun nat_well_order'
lemma cl_fun_dom {C : Set} : C.cl_fun.dom = ω := trans_rec_dom nat_well_order'

-- problem 7(b)
lemma cl_fun_lemma {C n : Set} (nω : n ∈ ω) {a : Set} (an : a ∈ C.cl_fun.fun_value n) : a ⊆ C.cl_fun.fun_value n.succ :=
begin
  have nω' := nat_induct.succ_closed nω,
  rw [cl_fun, trans_rec_spec nat_well_order' nω', nat_order_seg nω', restrict_ran],
  have h : n.succ ⊆ (trans_rec ω nat_order (λ f, C ∪ f.ran.Union.Union)).dom,
    rw trans_rec_dom nat_well_order', exact subset_nat_of_mem_nat nω',
  apply subset_union_of_subset_right, apply subset_Union,
  simp only [mem_Union, exists_prop, mem_img' (trans_rec_fun nat_well_order') h],
  rw cl_fun at an, exact ⟨_, ⟨_, self_mem_succ, rfl⟩, an⟩,
end

-- problem 7(c)
noncomputable def trans_cl (C : Set) : Set := C.cl_fun.ran.Union
lemma trans_cl_sub {C : Set} : C ⊆ C.trans_cl :=
begin
  apply subset_Union, simp only [cl_fun, mem_ran_iff (trans_rec_fun nat_well_order'), trans_rec_dom nat_well_order'], use ∅,
  simp only [trans_rec_spec nat_well_order' zero_nat, nat_order_seg zero_nat, restrict_empty, ran_empty_eq_empty, union_empty_eq_empty, union_empty],
  exact ⟨zero_nat, rfl⟩,
end
lemma trans_cl_trans {C : Set} : C.trans_cl.transitive_set :=
begin
  rw transitive_set_iff', intros a aC,
  simp only [trans_cl, mem_Union, exists_prop, mem_ran_iff cl_fun_fun, cl_fun_dom] at aC,
  rcases aC with ⟨y, ⟨n, nω, yn⟩, ay⟩, subst yn,
  replace ay := cl_fun_lemma nω ay,
  apply subset_trans ay, simp only [subset_def, trans_cl, mem_Union, exists_prop, mem_ran_iff cl_fun_fun, cl_fun_dom],
  intros y yn, exact ⟨_, ⟨_, nat_induct.succ_closed nω, rfl⟩, yn⟩,
end

def reg_axiom : Prop := ∀ {A : Set}, A ≠ ∅ → ∃ m : Set, m ∈ A ∧ m ∩ A = ∅

-- Theorem 7W
theorem all_grounded_equiv_reg : (∀ {A : Set.{u}}, A.grounded) ↔ reg_axiom.{u} :=
begin
  split,
    intros gr A Ane,
    let B := A.repl_img rank,
    have Bord : ∀ x : Set, x ∈ B → x.is_ordinal, simp only [mem_repl_img],
      rintros μ ⟨x, xA, μx⟩, subst μx, exact rank_ord_of_grounded gr,
    have Bne : B ≠ ∅, apply ne_empty_of_inhabited,
      replace Ane := inhabited_of_ne_empty Ane, rcases Ane with ⟨x, xA⟩,
      use x.rank, rw mem_repl_img, exact ⟨_, xA, rfl⟩,
    obtain ⟨μ, μB, le⟩ := exists_least_ord_of_nonempty Bord Bne,
    rw mem_repl_img at μB, rcases μB with ⟨m, mA, μm⟩, subst μm,
    refine ⟨_, mA, _⟩, rw eq_empty, intros x xmA, rw mem_inter at xmA,
    apply le, use x.rank, simp only [mem_repl_img, eps_order, pair_mem_pair_sep],
    exact ⟨⟨_, xmA.right, rfl⟩, ⟨_, xmA.right, rfl⟩, ⟨_, mA, rfl⟩, rank_mem_of_mem_grounded gr xmA.left⟩,
  intros reg, apply @classical.by_contradiction (∀ {A : Set}, A.grounded), intro h,
  push_neg at h, rcases h with ⟨c, cng⟩,
  let B := trans_cl {c},
  let A : Set := {x ∈ B | ¬ x.grounded},
  have Ane : A ≠ ∅, apply ne_empty_of_inhabited, use c, rw mem_sep, refine ⟨trans_cl_sub _, cng⟩,
    rw mem_singleton,
  obtain ⟨m, mA, miA⟩ := reg Ane,
  rw mem_sep at mA, apply mA.right, apply grounded_of_all_mem_grounded,
  intros x xm,
  have trans : B.transitive_set := trans_cl_trans, rw transitive_set_iff at trans,
  have xB : x ∈ B := trans mA.left xm,
  have xA : x ∉ A, intro xA, apply mem_empty x, rw [←miA, mem_inter], exact ⟨xm, xA⟩,
  rw mem_sep at xA, push_neg at xA, exact xA xB,
end

-- A proof of the regularity axiom
theorem regularity' : reg_axiom :=
begin
  intros A Ane,
  have h := regularity _ Ane,
  simp only [exists_prop] at h, simp only [inter_comm], exact h,
end

theorem all_grounded : ∀ {x : Set}, x.grounded :=
begin
  rw all_grounded_equiv_reg, exact @regularity',
end

-- Theorem 7X(a)
theorem not_mem_self {A : Set} : A ∉ A :=
begin
  intro AA,
  obtain ⟨m, mA, miA⟩ := regularity' (@singleton_ne_empty A),
  rw mem_singleton at mA, subst mA,
  apply mem_empty m, rw [←miA, mem_inter, mem_singleton], exact ⟨AA, rfl⟩,
end

-- Theorem 7X(b)
theorem no_2_cyle {a b : Set} : ¬ (a ∈ b ∧ b ∈ a) :=
begin
  rintro ⟨ab, ba⟩,
  have abne : ({a, b} : Set) ≠ ∅, apply ne_empty_of_inhabited, use a, rw [mem_insert], left, refl,
  obtain ⟨m, mab, miab⟩ := regularity' abne,
  rw [mem_insert, mem_singleton] at mab, cases mab with ma mb,
    subst ma, apply mem_empty b, rw [←miab, mem_inter, mem_insert, mem_singleton],
    exact ⟨ba, or.inr rfl⟩,
  subst mb, apply mem_empty a, rw [←miab, mem_inter, mem_insert],
  exact ⟨ab, or.inl rfl⟩,
end

-- Theorem 7X(c)
theorem no_ω_cycle : ¬ ∃ f : Set, f.is_function ∧ f.dom = ω ∧ ∀ {n : Set}, n ∈ ω → f.fun_value n.succ ∈ f.fun_value n :=
begin
  rintro ⟨f, ffun, fdom, fspec⟩,
  have ranne : f.ran ≠ ∅, apply ne_empty_of_inhabited, use f.fun_value ∅,
    apply fun_value_def'' ffun, rw fdom, exact zero_nat,
  obtain ⟨m, mf, mif⟩ := regularity' ranne,
  rw mem_ran_iff ffun at mf, rcases mf with ⟨n, nω, mn⟩, subst mn,
  apply mem_empty (f.fun_value n.succ), rw [←mif, mem_inter, mem_ran_iff ffun],
  rw fdom at nω, refine ⟨fspec nω, _, _, rfl⟩,
  rw fdom, exact nat_induct.succ_closed nω,
end

lemma rank_le_of_subset {x : Set} (xgr : x.grounded) {y : Set} (ygr : y.grounded) (xy : x ⊆ y) : x.rank ≤ y.rank :=
rank_least_of_grounded xgr (rank_ord_of_grounded ygr) (subset_trans xy (rank_sub_of_grounded ygr))

-- exercise 30(b)
theorem ch7_p30b {a : Set} : a.powerset.rank = a.rank.succ :=
begin
  rw rank_eq_of_all_mem_grounded (λ x h, all_grounded),
  apply ext, simp only [mem_Union, exists_prop, mem_repl_img, mem_powerset], intro z, split,
    rintro ⟨w, ⟨x, xa, wx⟩, zw⟩, subst wx, rw mem_succ_iff_le,
    have zord : z.is_ordinal := ord_of_mem_ord (succ_ord_of_ord (rank_ord_of_grounded all_grounded)) zw,
    rw ←rank_ord_eq_self zord at *, rw mem_succ_iff_le at zw,
    apply ord_le_trans (rank_ord_of_grounded all_grounded) zw,
    exact rank_le_of_subset all_grounded all_grounded xa,
  intro za, exact ⟨_, ⟨_, subset_self, rfl⟩, za⟩,
end

-- exercise 30(c)
theorem ch7_p30c {a : Set} : a.Union.rank ≤ a.rank :=
begin
  apply rank_least_of_grounded all_grounded (rank_ord_of_grounded all_grounded),
  simp only [subset_def, mem_Union, exists_prop], rintro z ⟨x, xa, zx⟩,
  suffices xa₂ : x.rank.Veb ⊆ a.rank.Veb,
    apply xa₂, apply rank_sub_of_grounded all_grounded, exact zx,
  apply Veb_sub_of_mem (rank_ord_of_grounded all_grounded),
  exact rank_mem_of_mem_grounded all_grounded xa,
end

-- exercise 33
theorem ch7_p33 {D : Set} (Dt : D.transitive_set) {B : Set} (BD : ∀ {a : Set}, a ∈ D → a ⊆ B → a ∈ B) : D ⊆ B :=
begin
  suffices h : ∀ {α : Set}, α.is_ordinal → D ∩ α.Veb ⊆ B,
    obtain ⟨α, αord, Dα⟩ := @all_grounded D,
    rw ←inter_eq_of_sub Dα, exact h αord,
  apply @trans_ind_schema (λ α, D ∩ α.Veb ⊆ B), intros α αord ind x xDα,
  rw [mem_inter, mem_Veb αord] at xDα, rcases xDα with ⟨xD, β, βα, xβ⟩,
  rw transitive_set_iff' at Dt, apply BD xD,
  exact subset_trans (sub_inter_of_sub (Dt xD) xβ) (ind βα),
end

-- exercise 35
theorem succ_inj' {a b : Set} (ab : a.succ = b.succ) : a = b :=
begin
  have amb : a ∈ b.succ, rw ←ab, exact self_mem_succ,
  have bma : b ∈ a.succ, rw ab, exact self_mem_succ,
  rw [succ, mem_union, mem_singleton] at amb bma,
  cases bma,
    symmetry, exact bma,
  cases amb,
    exact amb,
  exfalso, exact no_2_cyle ⟨bma, amb⟩,
end

theorem self_ne_succ {x : Set} : x.succ ≠ x :=
begin
  intro xx, apply @not_mem_self x, nth_rewrite 1 ←xx, exact self_mem_succ,
end

lemma eq_iff_le_and_le {a b : Set} : a = b ↔ a ≤ b ∧ b ≤ a :=
begin
  split,
    intro ab, subst ab, exact ⟨or.inr rfl, or.inr rfl⟩,
  rintro ⟨ab|ab, ba|ba⟩,
        exfalso, exact no_2_cyle ⟨ab, ba⟩,
      exact ba.symm,
    exact ab,
  exact ab,
end

-- exercise 38
theorem limit_ord_eq_Union {γ : Set} (γord : γ.limit_ord) : γ = γ.Union :=
begin
  rw eq_iff_subset_and_subset, split,
    intros α αγ, rw mem_Union,
    have αγ' : α.succ ∈ γ, apply classical.by_contradiction, intro αγ', apply γord.ns,
      use α, rw eq_iff_le_and_le,
      rw ord_not_lt_iff_le (succ_ord_of_ord (ord_of_mem_ord γord.ord αγ)) γord.ord at αγ',
      exact ⟨αγ', succ_least_upper_bound γord.ord αγ⟩,
    exact ⟨_, αγ', self_mem_succ⟩,
  exact (ordinal_trans γord.ord),
end

theorem zero_ne_succ_ord {α : Set} : ∅ ≠ α.succ :=
λ h, mem_empty α (by rw h; exact self_mem_succ)

theorem zero_mem_succ_ord {α : Set} (αord : α.is_ordinal) : ∅ ∈ α.succ :=
begin
  apply classical.by_contradiction, intro zα,
  rw ord_not_lt_iff_le zero_is_ord (succ_ord_of_ord αord) at zα, cases zα,
    exact mem_empty _ zα,
  exact zero_ne_succ_ord zα.symm,
end

theorem succ_ord_not_le_self {α : Set} (αord : α.is_ordinal) : ¬ (α.succ ≤ α) :=
λ αα, ord_mem_irrefl αord (ord_lt_of_lt_of_le αord self_mem_succ αα)

theorem ord_lt_of_succ_le {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal)
  (h : α.succ ≤ β) : α ∈ β :=
begin
  apply classical.by_contradiction, intro αβ,
  rw ord_not_lt_iff_le αord βord at αβ, exact succ_ord_not_le_self αord (ord_le_trans αord h αβ),
end

theorem ord_pos_of_inhab : ∀ {α : Set}, α.is_ordinal → α.inhab → ∅ ∈ α :=
begin
  apply @trans_ind_schema (λ α, α.inhab → ∅ ∈ α),
  rintros α αord ind ⟨β, βα⟩,
  by_cases hβ : β.inhab,
    exact ord_mem_trans αord (ind βα hβ) βα,
  have βz : β = ∅, rw eq_empty, intros δ δβ, exact hβ ⟨_, δβ⟩,
  subst βz, exact βα,
end

theorem ord_succ_lt_iff : ∀ {α : Set}, α.is_ordinal → ∀ {β : Set}, β.is_ordinal →
  (α ∈ β ↔ α.succ ∈ β.succ) :=
have h : ∀ {α β : Set}, β.is_ordinal → α ∈ β → α.succ ∈ β.succ,
  from λ α β βord αβ, ord_lt_of_le_of_lt (succ_ord_of_ord βord) (succ_least_upper_bound βord αβ) self_mem_succ,
λ α αord β βord,
⟨h βord, λ αβ, classical.by_contradiction (λ βα, begin
  rw ord_not_lt_iff_le αord βord at βα, cases βα,
    exact ord_mem_irrefl (succ_ord_of_ord βord) (ord_mem_trans (succ_ord_of_ord βord) (h αord βα) αβ),
  subst βα, exact ord_mem_irrefl (succ_ord_of_ord βord) αβ,
end)⟩

theorem ord_succ_inj {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal)
  (sαβ : α.succ = β.succ) : α = β :=
begin
  apply classical.by_contradiction, intro ne,
  cases ord_conn αord βord ne with αβ βα,
    rw ord_succ_lt_iff αord βord at αβ, rw sαβ at αβ,
    exact ord_mem_irrefl (succ_ord_of_ord βord) αβ,
  rw ord_succ_lt_iff βord αord at βα, rw sαβ at βα,
  exact ord_mem_irrefl (succ_ord_of_ord βord) βα,
end

theorem ord_succ_le_iff {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal) :
  α ≤ β ↔ α.succ ≤ β.succ :=
⟨λ αβ, αβ.elim (λ h, by left; rwa ←ord_succ_lt_iff αord βord) (λ h, by right; rw h),
λ αβ, αβ.elim (λ h, by left; rwa ord_succ_lt_iff αord βord) (λ h, or.inr (ord_succ_inj αord βord h))⟩

theorem empty_le_ord {α : Set} (αord : α.is_ordinal) : ∅ ≤ α :=
(ord_le_iff_sub zero_is_ord αord).mpr empty_subset

theorem limit_ord_inhab {γ : Set} (γord : γ.limit_ord) : γ.inhab :=
inhab_of_inf (limit_ord_inf γord)

theorem limit_ord_pos {γ : Set} (γord : γ.limit_ord) : ∅ ∈ γ :=
ord_pos_of_inhab γord.ord (limit_ord_inhab γord)

theorem ord_eq_zero_of_le_zero {α : Set} (αord : α.is_ordinal) (hα : α ≤ ∅) : α = ∅ :=
or.elim hα (λ h, false.elim (mem_empty _ h)) (λ h, h)

theorem not_zero_of_pos {α : Set} (hα : ∅ ∈ α) : α ≠ ∅ :=
ne_empty_of_inhabited _ ⟨_, hα⟩

lemma ord_cases {α : Set} (αord : α.is_ordinal) : α = ∅ ∨ (∃ β : Set, α = β.succ) ∨ α.limit_ord :=
classical.by_cases (λ αz : α = ∅, or.inl αz) (λ αnz, or.inr (
  classical.by_cases (λ ex : ∃ β : Set, α = β.succ, or.inl ex) (λ nex, or.inr ⟨αord, αnz, nex⟩)))

lemma card_is_card {α : Set} : α.card.is_cardinal :=
⟨_, rfl⟩

lemma card_pos_of_inhab {A : Set} (Ain : A.inhab) : ∅ ∈ A.card :=
begin
  cases @empty_le_ord A.card (card_is_ord card_is_card),
    exact h,
  exfalso, exact @ne_empty_of_inhabited _ Ain (eq_empty_of_card_empty h.symm),
end

lemma card_ge_one_of_inhab {A : Set} (Ain : A.inhab) : one ≤ A.card :=
succ_least_upper_bound (card_is_ord card_is_card) (card_pos_of_inhab Ain)

lemma ne_of_mem {A B : Set} (AB : A ∈ B) : A ≠ B :=
begin
  intro h, rw h at AB, apply not_mem_self AB,
end

lemma not_succ_le_empty {α : Set} : ¬ α.succ ≤ ∅ :=
λ h, or.elim h (λ h', mem_empty _ h') (λ h', zero_ne_succ_ord h'.symm)

lemma card_succ_eq {A : Set} : A.succ.card = A.card.card_add one :=
begin
  have h : A ∩ {A} = ∅, rw eq_empty, intros z hz, rw [mem_inter, mem_singleton] at hz,
    rcases hz with ⟨zA, zA'⟩, subst zA', exact not_mem_self zA,
  rw [succ, union_comm, card_add_spec rfl rfl h, card_singleton],
end

lemma succ_imm (m : Set) : ¬ ∃ k : Set, m ∈ k ∧ k ∈ m.succ :=
begin
  rintro ⟨k, mk, km⟩, rw [succ, mem_union, mem_singleton] at km, cases km,
    subst km, exact not_mem_self mk,
  exact no_2_cyle ⟨mk, km⟩,
end

lemma card_le_conn {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) : κ.card_le μ ∨ μ.card_le κ :=
begin
  rcases κcard with ⟨K, Kcard⟩, rcases μcard with ⟨M, Mcard⟩,
  subst Kcard, subst Mcard, simp only [card_le_iff_equin'],
  cases ax_ch_5 K M with KM MK,
    left, exact KM,
  right, exact MK,
end

lemma card_not_lt_iff_le {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) :
  ¬ κ.card_lt μ ↔ μ.card_le κ :=
begin
  split,
    intro κμ, rcases card_le_conn κcard μcard with (κμ'|μκ),
      rw card_le_iff at κμ', cases κμ',
        exfalso, exact κμ κμ',
      subst κμ', rw card_le_iff, right, refl,
    exact μκ,
  intros μκ κμ, rw card_le_iff at μκ, cases μκ,
    exact not_card_lt_cycle κcard μcard ⟨κμ, μκ⟩,
  subst μκ, exact κμ.right rfl,
end

lemma card_not_le_iff_lt {κ : Set} (κcard : κ.is_cardinal) {μ : Set} (μcard : μ.is_cardinal) :
  ¬ κ.card_le μ ↔ μ.card_lt κ :=
by simp only [←card_not_lt_iff_le μcard κcard, not_not]

lemma card_le_of_ord_mem {α : Set} (αord : α.is_ordinal) {β : Set} (βα : β ∈ α) : β.card.card_le α.card :=
begin
  have βord := ord_of_mem_ord αord βα,
  rw ord_mem_iff_ssub βord αord at βα, exact card_le_of_subset βα.left,
end

lemma card_lt_iff_ord_mem {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal)
  (h : α.card.card_lt β.card) : α ∈ β :=
begin
  rcases h with ⟨le, ne⟩, rw ←ord_not_le_iff_lt βord αord, rintro (h|h),
    exact ne (card_eq_of_le_of_le card_is_card card_is_card le (card_le_of_ord_mem αord h)),
  subst h, exact ne rfl,
end

lemma card_le_of_ord_le {α : Set} (αord : α.is_ordinal) {β : Set} (βα : β ≤ α) : β.card.card_le α.card :=
begin
  cases βα,
    exact card_le_of_ord_mem αord βα,
  subst βα, exact card_le_refl,
end

lemma card_mul_lt_of_lt_of_lt {ν : Set} (hν : ν.is_cardinal) {κ : Set} (hκ : κ.is_cardinal) (κν : κ.card_lt ν)
  {μ : Set} (hμ : μ.is_cardinal) (μν : μ.card_lt ν) : (κ.card_mul μ).card_lt (ν.card_mul ν) :=
begin
  cases card_le_conn hκ hμ with κμ μκ,
    apply card_lt_of_le_of_lt (mul_cardinal hκ hμ) (mul_cardinal hμ hμ) (card_mul_le_of_le_left hκ hμ κμ hμ),
    exact card_mul_lt_mul hμ hν μν,
  apply card_lt_of_le_of_lt (mul_cardinal hκ hμ) (mul_cardinal hκ hκ) (card_mul_le_of_le_right hμ hκ μκ hκ),
  exact card_mul_lt_mul hκ hν κν,
end

end Set


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.natural_isomorphism
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l v₃ u₃

namespace Mathlib

namespace category_theory

/--
A functor `F : C ⥤ D` is full if for each `X Y : C`, `F.map` is surjective.
In fact, we use a constructive definition, so the `full F` typeclass contains data,
specifying a particular preimage of each `f : F.obj X ⟶ F.obj Y`.

See https://stacks.math.columbia.edu/tag/001C.
-/
class full {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
where
  preimage : {X Y : C} → (functor.obj F X ⟶ functor.obj F Y) → (X ⟶ Y)
  witness' : autoParam (∀ {X Y : C} (f : functor.obj F X ⟶ functor.obj F Y), functor.map F (preimage f) = f)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem full.witness {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [c : full F] {X : C} {Y : C} (f : functor.obj F X ⟶ functor.obj F Y) : functor.map F (full.preimage f) = f := sorry

/--
A functor `F : C ⥤ D` is faithful if for each `X Y : C`, `F.map` is injective.

See https://stacks.math.columbia.edu/tag/001C.
-/
class faithful {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D)
where
  map_injective' : autoParam (∀ {X Y : C}, function.injective (functor.map F))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

theorem faithful.map_injective {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [c : faithful F] {X : C} {Y : C} : function.injective (functor.map F) := sorry

namespace functor

theorem map_injective {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [faithful F] {X : C} {Y : C} : function.injective (map F) :=
  faithful.map_injective F

/-- The specified preimage of a morphism under a full functor. -/
def preimage {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [full F] {X : C} {Y : C} (f : obj F X ⟶ obj F Y) : X ⟶ Y :=
  full.preimage f

@[simp] theorem image_preimage {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [full F] {X : C} {Y : C} (f : obj F X ⟶ obj F Y) : map F (preimage F f) = f := sorry

end functor

@[simp] theorem preimage_id {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} : functor.preimage F 𝟙 = 𝟙 := sorry

@[simp] theorem preimage_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} {Y : C} {Z : C} (f : functor.obj F X ⟶ functor.obj F Y) (g : functor.obj F Y ⟶ functor.obj F Z) : functor.preimage F (f ≫ g) = functor.preimage F f ≫ functor.preimage F g := sorry

@[simp] theorem preimage_map {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} {Y : C} (f : X ⟶ Y) : functor.preimage F (functor.map F f) = f := sorry

/-- If `F : C ⥤ D` is fully faithful, every isomorphism `F.obj X ≅ F.obj Y` has a preimage. -/
def preimage_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} {Y : C} (f : functor.obj F X ≅ functor.obj F Y) : X ≅ Y :=
  iso.mk (functor.preimage F (iso.hom f)) (functor.preimage F (iso.inv f))

@[simp] theorem preimage_iso_hom {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} {Y : C} (f : functor.obj F X ≅ functor.obj F Y) : iso.hom (preimage_iso f) = functor.preimage F (iso.hom f) :=
  rfl

@[simp] theorem preimage_iso_inv {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} {Y : C} (f : functor.obj F X ≅ functor.obj F Y) : iso.inv (preimage_iso f) = functor.preimage F (iso.inv f) :=
  rfl

@[simp] theorem preimage_iso_map_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} [full F] [faithful F] {X : C} {Y : C} (f : X ≅ Y) : preimage_iso (functor.map_iso F f) = f := sorry

/--
If the image of a morphism under a fully faithful functor in an isomorphism,
then the original morphisms is also an isomorphism.
-/
def is_iso_of_fully_faithful {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [full F] [faithful F] {X : C} {Y : C} (f : X ⟶ Y) [is_iso (functor.map F f)] : is_iso f :=
  is_iso.mk (functor.preimage F (inv (functor.map F f)))

/-- If `F` is fully faithful, we have an equivalence of hom-sets `X ⟶ Y` and `F X ⟶ F Y`. -/
def equiv_of_fully_faithful {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [full F] [faithful F] {X : C} {Y : C} : (X ⟶ Y) ≃ (functor.obj F X ⟶ functor.obj F Y) :=
  equiv.mk (fun (f : X ⟶ Y) => functor.map F f) (fun (f : functor.obj F X ⟶ functor.obj F Y) => functor.preimage F f)
    sorry sorry

@[simp] theorem equiv_of_fully_faithful_apply {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [full F] [faithful F] {X : C} {Y : C} (f : X ⟶ Y) : coe_fn (equiv_of_fully_faithful F) f = functor.map F f :=
  rfl

@[simp] theorem equiv_of_fully_faithful_symm_apply {C : Type u₁} [category C] {D : Type u₂} [category D] (F : C ⥤ D) [full F] [faithful F] {X : C} {Y : C} (f : functor.obj F X ⟶ functor.obj F Y) : coe_fn (equiv.symm (equiv_of_fully_faithful F)) f = functor.preimage F f :=
  rfl

end category_theory

namespace category_theory

protected instance full.id {C : Type u₁} [category C] : full 𝟭 :=
  full.mk fun (_x _x_1 : C) (f : functor.obj 𝟭 _x ⟶ functor.obj 𝟭 _x_1) => f

protected instance faithful.id {C : Type u₁} [category C] : faithful 𝟭 :=
  faithful.mk

protected instance faithful.comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) (G : D ⥤ E) [faithful F] [faithful G] : faithful (F ⋙ G) :=
  faithful.mk

theorem faithful.of_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) (G : D ⥤ E) [faithful (F ⋙ G)] : faithful F :=
  faithful.mk

theorem faithful.of_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {F : C ⥤ D} {F' : C ⥤ D} [faithful F] (α : F ≅ F') : faithful F' :=
  faithful.mk

theorem faithful.of_comp_iso {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G ≅ H) : faithful F :=
  faithful.of_comp F G

theorem iso.faithful_of_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G ≅ H) : faithful F :=
  faithful.of_comp_iso

-- We could prove this from `faithful.of_comp_iso` using `eq_to_iso`,

-- but that would introduce a cyclic import.

theorem faithful.of_comp_eq {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G = H) : faithful F :=
  faithful.of_comp F G

theorem Mathlib.eq.faithful_of_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : D ⥤ E} {H : C ⥤ E} [ℋ : faithful H] (h : F ⋙ G = H) : faithful F :=
  faithful.of_comp_eq

/-- “Divide” a functor by a faithful functor. -/
protected def faithful.div {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ E) (G : D ⥤ E) [faithful G] (obj : C → D) (h_obj : ∀ (X : C), functor.obj G (obj X) = functor.obj F X) (map : {X Y : C} → (X ⟶ Y) → (obj X ⟶ obj Y)) (h_map : ∀ {X Y : C} {f : X ⟶ Y}, functor.map G (map f) == functor.map F f) : C ⥤ D :=
  functor.mk obj map

-- This follows immediately from `functor.hext` (`functor.hext h_obj @h_map`),

-- but importing `category_theory.eq_to_hom` causes an import loop:

-- category_theory.eq_to_hom → category_theory.opposites →

-- category_theory.equivalence → category_theory.fully_faithful

theorem faithful.div_comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G] (obj : C → D) (h_obj : ∀ (X : C), functor.obj G (obj X) = functor.obj F X) (map : {X Y : C} → (X ⟶ Y) → (obj X ⟶ obj Y)) (h_map : ∀ {X Y : C} {f : X ⟶ Y}, functor.map G (map f) == functor.map F f) : faithful.div F G obj h_obj map h_map ⋙ G = F := sorry

theorem faithful.div_faithful {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ E) [faithful F] (G : D ⥤ E) [faithful G] (obj : C → D) (h_obj : ∀ (X : C), functor.obj G (obj X) = functor.obj F X) (map : {X Y : C} → (X ⟶ Y) → (obj X ⟶ obj Y)) (h_map : ∀ {X Y : C} {f : X ⟶ Y}, functor.map G (map f) == functor.map F f) : faithful (faithful.div F G obj h_obj map h_map) :=
  eq.faithful_of_comp (faithful.div_comp F G (fun (X : C) => obj X) h_obj (fun (X Y : C) (f : X ⟶ Y) => map f) h_map)

protected instance full.comp {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] (F : C ⥤ D) (G : D ⥤ E) [full F] [full G] : full (F ⋙ G) :=
  full.mk
    fun (_x _x_1 : C) (f : functor.obj (F ⋙ G) _x ⟶ functor.obj (F ⋙ G) _x_1) => functor.preimage F (functor.preimage G f)

/--
Given a natural isomorphism between `F ⋙ H` and `G ⋙ H` for a fully faithful functor `H`, we
can 'cancel' it to give a natural iso between `F` and `G`.
-/
def fully_faithful_cancel_right {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : C ⥤ D} (H : D ⥤ E) [full H] [faithful H] (comp_iso : F ⋙ H ≅ G ⋙ H) : F ≅ G :=
  nat_iso.of_components (fun (X : C) => preimage_iso (iso.app comp_iso X)) sorry

@[simp] theorem fully_faithful_cancel_right_hom_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} [full H] [faithful H] (comp_iso : F ⋙ H ≅ G ⋙ H) (X : C) : nat_trans.app (iso.hom (fully_faithful_cancel_right H comp_iso)) X =
  functor.preimage H (nat_trans.app (iso.hom comp_iso) X) :=
  rfl

@[simp] theorem fully_faithful_cancel_right_inv_app {C : Type u₁} [category C] {D : Type u₂} [category D] {E : Type u₃} [category E] {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} [full H] [faithful H] (comp_iso : F ⋙ H ≅ G ⋙ H) (X : C) : nat_trans.app (iso.inv (fully_faithful_cancel_right H comp_iso)) X =
  functor.preimage H (nat_trans.app (iso.inv comp_iso) X) :=
  rfl


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.set_theory.cardinal_ordinal
import Mathlib.PostPort

universes u_1 u v u_2

namespace Mathlib

/-!
# Cofinality on ordinals, regular cardinals
-/

namespace order

/-- Cofinality of a reflexive order `≼`. This is the smallest cardinality
  of a subset `S : set α` such that `∀ a, ∃ b ∈ S, a ≼ b`. -/
def cof {α : Type u_1} (r : α → α → Prop) [is_refl α r] : cardinal :=
  cardinal.min sorry
    fun (S : Subtype fun (S : set α) => ∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), r a b) =>
      cardinal.mk ↥S

theorem cof_le {α : Type u_1} (r : α → α → Prop) [is_refl α r] {S : set α}
    (h : ∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), r a b) : cof r ≤ cardinal.mk ↥S :=
  sorry

theorem le_cof {α : Type u_1} {r : α → α → Prop} [is_refl α r] (c : cardinal) :
    c ≤ cof r ↔ ∀ {S : set α}, (∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), r a b) → c ≤ cardinal.mk ↥S :=
  sorry

end order

theorem rel_iso.cof.aux {α : Type u} {β : Type v} {r : α → α → Prop} {s : β → β → Prop}
    [is_refl α r] [is_refl β s] (f : r ≃r s) :
    cardinal.lift (order.cof r) ≤ cardinal.lift (order.cof s) :=
  sorry

theorem rel_iso.cof {α : Type u} {β : Type v} {r : α → α → Prop} {s : β → β → Prop} [is_refl α r]
    [is_refl β s] (f : r ≃r s) : cardinal.lift (order.cof r) = cardinal.lift (order.cof s) :=
  le_antisymm sorry sorry

def strict_order.cof {α : Type u_1} (r : α → α → Prop) [h : is_irrefl α r] : cardinal :=
  order.cof fun (x y : α) => ¬r y x

namespace ordinal

/-- Cofinality of an ordinal. This is the smallest cardinal of a
  subset `S` of the ordinal which is unbounded, in the sense
  `∀ a, ∃ b ∈ S, ¬(b > a)`. It is defined for all ordinals, but
  `cof 0 = 0` and `cof (succ o) = 1`, so it is only really
  interesting on limit ordinals (when it is an infinite cardinal). -/
def cof (o : ordinal) : cardinal := quot.lift_on o (fun (_x : Well_order) => sorry) sorry

theorem cof_type {α : Type u_1} (r : α → α → Prop) [is_well_order α r] :
    cof (type r) = strict_order.cof r :=
  rfl

theorem le_cof_type {α : Type u_1} {r : α → α → Prop} [is_well_order α r] {c : cardinal} :
    c ≤ cof (type r) ↔
        ∀ (S : set α), (∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), ¬r b a) → c ≤ cardinal.mk ↥S :=
  sorry

theorem cof_type_le {α : Type u_1} {r : α → α → Prop} [is_well_order α r] (S : set α)
    (h : ∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), ¬r b a) : cof (type r) ≤ cardinal.mk ↥S :=
  iff.mp le_cof_type (le_refl (cof (type r))) S h

theorem lt_cof_type {α : Type u_1} {r : α → α → Prop} [is_well_order α r] (S : set α)
    (hl : cardinal.mk ↥S < cof (type r)) : ∃ (a : α), ∀ (b : α), b ∈ S → r b a :=
  iff.mp not_forall_not
    fun (h : ∀ (x : α), ¬∀ (b : α), b ∈ S → r b x) =>
      not_le_of_lt hl (cof_type_le S fun (a : α) => iff.mp not_ball (h a))

theorem cof_eq {α : Type u_1} (r : α → α → Prop) [is_well_order α r] :
    ∃ (S : set α), (∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), ¬r b a) ∧ cardinal.mk ↥S = cof (type r) :=
  sorry

theorem ord_cof_eq {α : Type u_1} (r : α → α → Prop) [is_well_order α r] :
    ∃ (S : set α),
        (∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), ¬r b a) ∧
          type (subrel r S) = cardinal.ord (cof (type r)) :=
  sorry

theorem lift_cof (o : ordinal) : cardinal.lift (cof o) = cof (lift o) := sorry

theorem cof_le_card (o : ordinal) : cof o ≤ card o := sorry

theorem cof_ord_le (c : cardinal) : cof (cardinal.ord c) ≤ c := sorry

@[simp] theorem cof_zero : cof 0 = 0 := sorry

@[simp] theorem cof_eq_zero {o : ordinal} : cof o = 0 ↔ o = 0 := sorry

@[simp] theorem cof_succ (o : ordinal) : cof (succ o) = 1 := sorry

@[simp] theorem cof_eq_one_iff_is_succ {o : ordinal} : cof o = 1 ↔ ∃ (a : ordinal), o = succ a :=
  sorry

@[simp] theorem cof_add (a : ordinal) (b : ordinal) : b ≠ 0 → cof (a + b) = cof b := sorry

@[simp] theorem cof_cof (o : ordinal) : cof (cardinal.ord (cof o)) = cof o := sorry

theorem omega_le_cof {o : ordinal} : cardinal.omega ≤ cof o ↔ is_limit o := sorry

@[simp] theorem cof_omega : cof omega = cardinal.omega :=
  le_antisymm
    (eq.mpr (id (Eq._oldrec (Eq.refl (cof omega ≤ cardinal.omega)) (Eq.symm card_omega)))
      (cof_le_card omega))
    (iff.mpr omega_le_cof omega_is_limit)

theorem cof_eq' {α : Type u_1} (r : α → α → Prop) [is_well_order α r] (h : is_limit (type r)) :
    ∃ (S : set α), (∀ (a : α), ∃ (b : α), ∃ (H : b ∈ S), r a b) ∧ cardinal.mk ↥S = cof (type r) :=
  sorry

theorem cof_sup_le_lift {ι : Type u_1} (f : ι → ordinal) (H : ∀ (i : ι), f i < sup f) :
    cof (sup f) ≤ cardinal.lift (cardinal.mk ι) :=
  sorry

theorem cof_sup_le {ι : Type u} (f : ι → ordinal) (H : ∀ (i : ι), f i < sup f) :
    cof (sup f) ≤ cardinal.mk ι :=
  sorry

theorem cof_bsup_le_lift {o : ordinal} (f : (a : ordinal) → a < o → ordinal) :
    (∀ (i : ordinal) (h : i < o), f i h < bsup o f) → cof (bsup o f) ≤ cardinal.lift (card o) :=
  sorry

theorem cof_bsup_le {o : ordinal} (f : (a : ordinal) → a < o → ordinal) :
    (∀ (i : ordinal) (h : i < o), f i h < bsup o f) → cof (bsup o f) ≤ card o :=
  sorry

@[simp] theorem cof_univ : cof univ = cardinal.univ := sorry

theorem sup_lt_ord {ι : Type u} (f : ι → ordinal) {c : ordinal} (H1 : cardinal.mk ι < cof c)
    (H2 : ∀ (i : ι), f i < c) : sup f < c :=
  sorry

theorem sup_lt {ι : Type u} (f : ι → cardinal) {c : cardinal}
    (H1 : cardinal.mk ι < cof (cardinal.ord c)) (H2 : ∀ (i : ι), f i < c) : cardinal.sup f < c :=
  sorry

/-- If the union of s is unbounded and s is smaller than the cofinality, then s has an unbounded member -/
theorem unbounded_of_unbounded_sUnion {α : Type u_1} (r : α → α → Prop) [wo : is_well_order α r]
    {s : set (set α)} (h₁ : unbounded r (⋃₀s)) (h₂ : cardinal.mk ↥s < strict_order.cof r) :
    ∃ (x : set α), ∃ (H : x ∈ s), unbounded r x :=
  sorry

/-- If the union of s is unbounded and s is smaller than the cofinality, then s has an unbounded member -/
theorem unbounded_of_unbounded_Union {α : Type u} {β : Type u} (r : α → α → Prop)
    [wo : is_well_order α r] (s : β → set α) (h₁ : unbounded r (set.Union fun (x : β) => s x))
    (h₂ : cardinal.mk β < strict_order.cof r) : ∃ (x : β), unbounded r (s x) :=
  sorry

/-- The infinite pigeonhole principle-/
theorem infinite_pigeonhole {β : Type u} {α : Type u} (f : β → α)
    (h₁ : cardinal.omega ≤ cardinal.mk β)
    (h₂ : cardinal.mk α < cof (cardinal.ord (cardinal.mk β))) :
    ∃ (a : α), cardinal.mk ↥(f ⁻¹' singleton a) = cardinal.mk β :=
  sorry

/-- pigeonhole principle for a cardinality below the cardinality of the domain -/
theorem infinite_pigeonhole_card {β : Type u} {α : Type u} (f : β → α) (θ : cardinal)
    (hθ : θ ≤ cardinal.mk β) (h₁ : cardinal.omega ≤ θ) (h₂ : cardinal.mk α < cof (cardinal.ord θ)) :
    ∃ (a : α), θ ≤ cardinal.mk ↥(f ⁻¹' singleton a) :=
  sorry

theorem infinite_pigeonhole_set {β : Type u} {α : Type u} {s : set β} (f : ↥s → α) (θ : cardinal)
    (hθ : θ ≤ cardinal.mk ↥s) (h₁ : cardinal.omega ≤ θ)
    (h₂ : cardinal.mk α < cof (cardinal.ord θ)) :
    ∃ (a : α),
        ∃ (t : set β),
          ∃ (h : t ⊆ s),
            θ ≤ cardinal.mk ↥t ∧ ∀ {x : β} (hx : x ∈ t), f { val := x, property := h hx } = a :=
  sorry

end ordinal

namespace cardinal

/-- A cardinal is a limit if it is not zero or a successor
  cardinal. Note that `ω` is a limit cardinal by this definition. -/
def is_limit (c : cardinal) := c ≠ 0 ∧ ∀ (x : cardinal), x < c → succ x < c

/-- A cardinal is a strong limit if it is not zero and it is
  closed under powersets. Note that `ω` is a strong limit by this definition. -/
def is_strong_limit (c : cardinal) := c ≠ 0 ∧ ∀ (x : cardinal), x < c → bit0 1 ^ x < c

theorem is_strong_limit.is_limit {c : cardinal} (H : is_strong_limit c) : is_limit c :=
  { left := and.left H,
    right :=
      fun (x : cardinal) (h : x < c) =>
        lt_of_le_of_lt (iff.mpr succ_le (cantor x)) (and.right H x h) }

/-- A cardinal is regular if it is infinite and it equals its own cofinality. -/
def is_regular (c : cardinal) := omega ≤ c ∧ ordinal.cof (ord c) = c

theorem cof_is_regular {o : ordinal} (h : ordinal.is_limit o) : is_regular (ordinal.cof o) :=
  { left := iff.mpr ordinal.omega_le_cof h, right := ordinal.cof_cof o }

theorem omega_is_regular : is_regular omega := sorry

theorem succ_is_regular {c : cardinal} (h : omega ≤ c) : is_regular (succ c) := sorry

theorem sup_lt_ord_of_is_regular {ι : Type u} (f : ι → ordinal) {c : cardinal} (hc : is_regular c)
    (H1 : mk ι < c) (H2 : ∀ (i : ι), f i < ord c) : ordinal.sup f < ord c :=
  ordinal.sup_lt_ord (fun (i : ι) => f i)
    (eq.mpr (id (Eq._oldrec (Eq.refl (mk ι < ordinal.cof (ord c))) (and.right hc))) H1) H2

theorem sup_lt_of_is_regular {ι : Type u} (f : ι → cardinal) {c : cardinal} (hc : is_regular c)
    (H1 : mk ι < c) (H2 : ∀ (i : ι), f i < c) : sup f < c :=
  ordinal.sup_lt (fun (i : ι) => f i)
    (eq.mpr (id (Eq._oldrec (Eq.refl (mk ι < ordinal.cof (ord c))) (and.right hc))) H1) H2

theorem sum_lt_of_is_regular {ι : Type u} (f : ι → cardinal) {c : cardinal} (hc : is_regular c)
    (H1 : mk ι < c) (H2 : ∀ (i : ι), f i < c) : sum f < c :=
  lt_of_le_of_lt (sum_le_sup f) (mul_lt_of_lt (and.left hc) H1 (sup_lt_of_is_regular f hc H1 H2))

/-- A cardinal is inaccessible if it is an
  uncountable regular strong limit cardinal. -/
def is_inaccessible (c : cardinal) := omega < c ∧ is_regular c ∧ is_strong_limit c

theorem is_inaccessible.mk {c : cardinal} (h₁ : omega < c) (h₂ : c ≤ ordinal.cof (ord c))
    (h₃ : ∀ (x : cardinal), x < c → bit0 1 ^ x < c) : is_inaccessible c :=
  sorry

/- Lean's foundations prove the existence of ω many inaccessible
   cardinals -/

theorem univ_inaccessible : is_inaccessible univ := sorry

theorem lt_power_cof {c : cardinal} : omega ≤ c → c < c ^ ordinal.cof (ord c) := sorry

theorem lt_cof_power {a : cardinal} {b : cardinal} (ha : omega ≤ a) (b1 : 1 < b) :
    a < ordinal.cof (ord (b ^ a)) :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.finset.image
import data.multiset.pi

/-!
# The cartesian product of finsets

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

namespace finset
open multiset

/-! ### pi -/
section pi
variables {α : Type*}

/-- The empty dependent product function, defined on the empty set. The assumption `a ∈ ∅` is never
satisfied. -/
def pi.empty (β : α → Sort*) (a : α) (h : a ∈ (∅ : finset α)) : β a :=
multiset.pi.empty β a h

variables {β : α → Type*} {δ : α → Sort*} [decidable_eq α]

/-- Given a finset `s` of `α` and for all `a : α` a finset `t a` of `δ a`, then one can define the
finset `s.pi t` of all functions defined on elements of `s` taking values in `t a` for `a ∈ s`.
Note that the elements of `s.pi t` are only partially defined, on `s`. -/
def pi (s : finset α) (t : Πa, finset (β a)) : finset (Πa∈s, β a) :=
⟨s.1.pi (λ a, (t a).1), s.nodup.pi $ λ a _, (t a).nodup⟩

@[simp] lemma pi_val (s : finset α) (t : Πa, finset (β a)) :
  (s.pi t).1 = s.1.pi (λ a, (t a).1) := rfl

@[simp] lemma mem_pi {s : finset α} {t : Πa, finset (β a)} {f : Πa∈s, β a} :
  f ∈ s.pi t ↔ (∀a (h : a ∈ s), f a h ∈ t a) :=
mem_pi _ _ _

/-- Given a function `f` defined on a finset `s`, define a new function on the finset `s ∪ {a}`,
equal to `f` on `s` and sending `a` to a given value `b`. This function is denoted
`s.pi.cons a b f`. If `a` already belongs to `s`, the new function takes the value `b` at `a`
anyway. -/
def pi.cons (s : finset α) (a : α) (b : δ a) (f : Πa, a ∈ s → δ a) (a' : α) (h : a' ∈ insert a s) :
  δ a' :=
multiset.pi.cons s.1 a b f _ (multiset.mem_cons.2 $ mem_insert.symm.2 h)

@[simp]
lemma pi.cons_same (s : finset α) (a : α) (b : δ a) (f : Πa, a ∈ s → δ a) (h : a ∈ insert a s) :
  pi.cons s a b f a h = b :=
multiset.pi.cons_same _

lemma pi.cons_ne {s : finset α} {a a' : α} {b : δ a} {f : Πa, a ∈ s → δ a} {h : a' ∈ insert a s}
  (ha : a ≠ a') :
  pi.cons s a b f a' h = f a' ((mem_insert.1 h).resolve_left ha.symm) :=
multiset.pi.cons_ne _ _

lemma pi_cons_injective  {a : α} {b : δ a} {s : finset α} (hs : a ∉ s) :
  function.injective (pi.cons s a b) :=
assume e₁ e₂ eq,
@multiset.pi_cons_injective α _ δ a b s.1 hs _ _ $
  funext $ assume e, funext $ assume h,
  have pi.cons s a b e₁ e (by simpa only [multiset.mem_cons, mem_insert] using h) =
    pi.cons s a b e₂ e (by simpa only [multiset.mem_cons, mem_insert] using h),
  { rw [eq] },
  this

@[simp] lemma pi_empty {t : Πa:α, finset (β a)} :
  pi (∅ : finset α) t = singleton (pi.empty β) := rfl

@[simp] lemma pi_insert [∀a, decidable_eq (β a)]
  {s : finset α} {t : Πa:α, finset (β a)} {a : α} (ha : a ∉ s) :
  pi (insert a s) t = (t a).bUnion (λb, (pi s t).image (pi.cons s a b)) :=
begin
  apply eq_of_veq,
  rw ← (pi (insert a s) t).2.dedup,
  refine (λ s' (h : s' = a ::ₘ s.1), (_ : dedup (multiset.pi s' (λ a, (t a).1)) =
    dedup ((t a).1.bind $ λ b,
    dedup $ (multiset.pi s.1 (λ (a : α), (t a).val)).map $
      λ f a' h', multiset.pi.cons s.1 a b f a' (h ▸ h')))) _ (insert_val_of_not_mem ha),
  subst s', rw pi_cons,
  congr, funext b,
  refine ((pi s t).nodup.map _).dedup.symm,
  exact multiset.pi_cons_injective ha,
end

lemma pi_singletons {β : Type*} (s : finset α) (f : α → β) :
  s.pi (λ a, ({f a} : finset β)) = {λ a _, f a} :=
begin
  rw eq_singleton_iff_unique_mem,
  split,
  { simp },
  intros a ha,
  ext i hi,
  rw [mem_pi] at ha,
  simpa using ha i hi,
end

lemma pi_const_singleton {β : Type*} (s : finset α) (i : β) :
  s.pi (λ _, ({i} : finset β)) = {λ _ _, i} :=
pi_singletons s (λ _, i)

lemma pi_subset {s : finset α} (t₁ t₂ : Πa, finset (β a)) (h : ∀ a ∈ s, t₁ a ⊆ t₂ a) :
  s.pi t₁ ⊆ s.pi t₂ :=
λ g hg, mem_pi.2 $ λ a ha, h a ha (mem_pi.mp hg a ha)

lemma pi_disjoint_of_disjoint {δ : α → Type*}
  {s : finset α} (t₁ t₂ : Πa, finset (δ a)) {a : α} (ha : a ∈ s) (h : disjoint (t₁ a) (t₂ a)) :
  disjoint (s.pi t₁) (s.pi t₂) :=
disjoint_iff_ne.2 $ λ f₁ hf₁ f₂ hf₂ eq₁₂,
  disjoint_iff_ne.1 h (f₁ a ha) (mem_pi.mp hf₁ a ha) (f₂ a ha) (mem_pi.mp hf₂ a ha)
  $ congr_fun (congr_fun eq₁₂ a) ha

end pi
end finset