/-
Copyright (c) 2021 Julian Kuelshammer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Julian Kuelshammer
-/
import algebra.pempty_instances
import category_theory.concrete_category.bundled_hom
import category_theory.reflects_isomorphisms

/-!
# Category instances for has_mul, has_add, semigroup and add_semigroup

We introduce the bundled categories:
* `Magma`
* `AddMagma`
* `Semigroup`
* `AddSemigroup`
along with the relevant forgetful functors between them.

This closely follows `algebra.category.Mon.basic`.

## TODO

* Limits in these categories
* free/forgetful adjunctions
-/

universes u v

open category_theory

/-- The category of magmas and magma morphisms. -/
@[to_additive AddMagma]
def Magma : Type (u+1) := bundled has_mul

/-- The category of additive magmas and additive magma morphisms. -/
add_decl_doc AddMagma

namespace Magma

@[to_additive]
instance bundled_hom : bundled_hom @mul_hom :=
⟨@mul_hom.to_fun, @mul_hom.id, @mul_hom.comp, @mul_hom.coe_inj⟩

attribute [derive [large_category, concrete_category]] Magma
attribute [to_additive] Magma.large_category Magma.concrete_category

@[to_additive] instance : has_coe_to_sort Magma Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Magma` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [has_mul M] : Magma := bundled.of M

/-- Construct a bundled `AddMagma` from the underlying type and typeclass. -/
add_decl_doc AddMagma.of

/-- Typecheck a `mul_hom` as a morphism in `Magma`. -/
@[to_additive] def of_hom {X Y : Type u} [has_mul X] [has_mul Y] (f : mul_hom X Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_hom` as a morphism in `AddMagma`. -/
add_decl_doc AddMagma.of_hom

@[to_additive]
instance : inhabited Magma := ⟨Magma.of pempty⟩

@[to_additive]
instance (M : Magma) : has_mul M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [has_mul R] : (Magma.of R : Type u) = R := rfl

end Magma

/-- The category of semigroups and semigroup morphisms. -/
@[to_additive AddSemigroup]
def Semigroup : Type (u+1) := bundled semigroup

/-- The category of additive semigroups and semigroup morphisms. -/
add_decl_doc AddSemigroup

namespace Semigroup

@[to_additive]
instance : bundled_hom.parent_projection semigroup.to_has_mul := ⟨⟩

attribute [derive [large_category, concrete_category]] Semigroup
attribute [to_additive] Semigroup.large_category Semigroup.concrete_category

@[to_additive] instance : has_coe_to_sort Semigroup Type* := bundled.has_coe_to_sort

/-- Construct a bundled `Semigroup` from the underlying type and typeclass. -/
@[to_additive]
def of (M : Type u) [semigroup M] : Semigroup := bundled.of M

/-- Construct a bundled `AddSemigroup` from the underlying type and typeclass. -/
add_decl_doc AddSemigroup.of

/-- Typecheck a `mul_hom` as a morphism in `Semigroup`. -/
@[to_additive] def of_hom {X Y : Type u} [semigroup X] [semigroup Y] (f : mul_hom X Y) :
  of X ⟶ of Y := f

/-- Typecheck a `add_hom` as a morphism in `AddSemigroup`. -/
add_decl_doc AddSemigroup.of_hom

@[to_additive]
instance : inhabited Semigroup := ⟨Semigroup.of pempty⟩

@[to_additive]
instance (M : Semigroup) : semigroup M := M.str

@[simp, to_additive] lemma coe_of (R : Type u) [semigroup R] : (Semigroup.of R : Type u) = R := rfl

@[to_additive has_forget_to_AddMagma]
instance has_forget_to_Magma : has_forget₂ Semigroup Magma := bundled_hom.forget₂ _ _

end Semigroup

variables {X Y : Type u}

section
variables [has_mul X] [has_mul Y]

/-- Build an isomorphism in the category `Magma` from a `mul_equiv` between `has_mul`s. -/
@[to_additive add_equiv.to_AddMagma_iso "Build an isomorphism in the category `AddMagma` from
an `add_equiv` between `has_add`s.", simps]
def mul_equiv.to_Magma_iso (e : X ≃* Y) : Magma.of X ≅ Magma.of Y :=
{ hom := e.to_mul_hom,
  inv := e.symm.to_mul_hom }

end

section
variables [semigroup X] [semigroup Y]

/-- Build an isomorphism in the category `Semigroup` from a `mul_equiv` between `semigroup`s. -/
@[to_additive add_equiv.to_AddSemigroup_iso "Build an isomorphism in the category
`AddSemigroup` from an `add_equiv` between `add_semigroup`s.", simps]
def mul_equiv.to_Semigroup_iso (e : X ≃* Y) : Semigroup.of X ≅ Semigroup.of Y :=
{ hom := e.to_mul_hom,
  inv := e.symm.to_mul_hom }

end

namespace category_theory.iso

/-- Build a `mul_equiv` from an isomorphism in the category `Magma`. -/
@[to_additive AddMagma_iso_to_add_equiv "Build an `add_equiv` from an isomorphism in the category
`AddMagma`."]
def Magma_iso_to_mul_equiv {X Y : Magma} (i : X ≅ Y) : X ≃* Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := begin rw function.left_inverse, simp end,
  right_inv := begin rw function.right_inverse, rw function.left_inverse, simp end,
  map_mul' := by simp }

/-- Build a `mul_equiv` from an isomorphism in the category `Semigroup`. -/
@[to_additive "Build an `add_equiv` from an isomorphism in the category
`AddSemigroup`."]
def Semigroup_iso_to_mul_equiv {X Y : Semigroup} (i : X ≅ Y) : X ≃* Y :=
{ to_fun := i.hom,
  inv_fun := i.inv,
  left_inv := begin rw function.left_inverse, simp end,
  right_inv := begin rw function.right_inverse, rw function.left_inverse, simp end,
  map_mul' := by simp }

end category_theory.iso

/-- multiplicative equivalences between `has_mul`s are the same as (isomorphic to) isomorphisms
in `Magma` -/
@[to_additive add_equiv_iso_AddMagma_iso "additive equivalences between `has_add`s are the same
as (isomorphic to) isomorphisms in `AddMagma`"]
def mul_equiv_iso_Magma_iso {X Y : Type u} [has_mul X] [has_mul Y] :
  (X ≃* Y) ≅ (Magma.of X ≅ Magma.of Y) :=
{ hom := λ e, e.to_Magma_iso,
  inv := λ i, i.Magma_iso_to_mul_equiv }

/-- multiplicative equivalences between `semigroup`s are the same as (isomorphic to) isomorphisms
in `Semigroup` -/
@[to_additive add_equiv_iso_AddSemigroup_iso "additive equivalences between `add_semigroup`s are
the same as (isomorphic to) isomorphisms in `AddSemigroup`"]
def mul_equiv_iso_Semigroup_iso {X Y : Type u} [semigroup X] [semigroup Y] :
  (X ≃* Y) ≅ (Semigroup.of X ≅ Semigroup.of Y) :=
{ hom := λ e, e.to_Semigroup_iso,
  inv := λ i, i.Semigroup_iso_to_mul_equiv }

@[to_additive]
instance Magma.forget_reflects_isos : reflects_isomorphisms (forget Magma.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Magma).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Magma_iso).1⟩,
  end }

@[to_additive]
instance Semigroup.forget_reflects_isos : reflects_isomorphisms (forget Semigroup.{u}) :=
{ reflects := λ X Y f _,
  begin
    resetI,
    let i := as_iso ((forget Semigroup).map f),
    let e : X ≃* Y := { ..f, ..i.to_equiv },
    exact ⟨(is_iso.of_iso e.to_Semigroup_iso).1⟩,
  end }

/-!
Once we've shown that the forgetful functors to type reflect isomorphisms,
we automatically obtain that the `forget₂` functors between our concrete categories
reflect isomorphisms.
-/
example : reflects_isomorphisms (forget₂ Semigroup Magma) := by apply_instance


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/
import data.W

/-!
# Polynomial functors

This file defines polynomial functors and the W-type construction as a
polynomial functor.  (For the M-type construction, see
pfunctor/M.lean.)
-/

universe u

/--
A polynomial functor `P` is given by a type `A` and a family `B` of types over `A`. `P` maps
any type `α` to a new type `P.obj α`, which is defined as the sigma type `Σ x, P.B x → α`.

An element of `P.obj α` is a pair `⟨a, f⟩`, where `a` is an element of a type `A` and
`f : B a → α`. Think of `a` as the shape of the object and `f` as an index to the relevant
elements of `α`.
-/

structure pfunctor :=
(A : Type u) (B : A → Type u)

namespace pfunctor

instance : inhabited pfunctor :=
⟨⟨default _, default _⟩⟩

variables (P : pfunctor) {α β : Type u}

/-- Applying `P` to an object of `Type` -/
def obj (α : Type*) := Σ x : P.A, P.B x → α

/-- Applying `P` to a morphism of `Type` -/
def map {α β : Type*} (f : α → β) : P.obj α → P.obj β :=
λ ⟨a, g⟩, ⟨a, f ∘ g⟩

instance obj.inhabited [inhabited P.A] [inhabited α] : inhabited (P.obj α) :=
⟨ ⟨ default _, λ _, default _ ⟩ ⟩
instance : functor P.obj := {map := @map P}

protected theorem map_eq {α β : Type*} (f : α → β) (a : P.A) (g : P.B a → α) :
  @functor.map P.obj _ _ _ f ⟨a, g⟩ = ⟨a, f ∘ g⟩ :=
rfl

protected theorem id_map {α : Type*} : ∀ x : P.obj α, id <$> x = id x :=
λ ⟨a, b⟩, rfl

protected theorem comp_map {α β γ : Type*} (f : α → β) (g : β → γ) :
  ∀ x : P.obj α, (g ∘ f) <$> x = g <$> (f <$> x) :=
λ ⟨a, b⟩, rfl

instance : is_lawful_functor P.obj :=
{id_map := @pfunctor.id_map P, comp_map := @pfunctor.comp_map P}

/-- re-export existing definition of W-types and
adapt it to a packaged definition of polynomial functor -/
def W := _root_.W_type P.B

/- inhabitants of W types is awkward to encode as an instance
assumption because there needs to be a value `a : P.A`
such that `P.B a` is empty to yield a finite tree -/
attribute [nolint has_inhabited_instance] W
variables {P}

/-- root element  of a W tree -/
def W.head : W P → P.A
| ⟨a, f⟩ := a

/-- children of the root of a W tree -/
def W.children : Π x : W P, P.B (W.head x) → W P
| ⟨a, f⟩ := f

/-- destructor for W-types -/
def W.dest : W P → P.obj (W P)
| ⟨a, f⟩ := ⟨a, f⟩

/-- constructor for W-types -/
def W.mk : P.obj (W P) → W P
| ⟨a, f⟩ := ⟨a, f⟩

@[simp] theorem W.dest_mk (p : P.obj (W P)) : W.dest (W.mk p) = p :=
by cases p; reflexivity

@[simp] theorem W.mk_dest (p : W P) : W.mk (W.dest p) = p :=
by cases p; reflexivity

variables (P)

/-- `Idx` identifies a location inside the application of a pfunctor.
For `F : pfunctor`, `x : F.obj α` and `i : F.Idx`, `i` can designate
one part of `x` or is invalid, if `i.1 ≠ x.1` -/
def Idx := Σ x : P.A, P.B x

instance Idx.inhabited [inhabited P.A] [inhabited (P.B (default _))] : inhabited P.Idx :=
⟨ ⟨default _, default _⟩ ⟩

variables {P}

/-- `x.iget i` takes the component of `x` designated by `i` if any is or returns
a default value -/
def obj.iget [decidable_eq P.A] {α} [inhabited α] (x : P.obj α) (i : P.Idx) : α :=
if h : i.1 = x.1
  then x.2 (cast (congr_arg _ h) i.2)
  else default _

@[simp]
lemma fst_map {α β : Type u} (x : P.obj α) (f : α → β) :
  (f <$> x).1 = x.1 := by { cases x; refl }

@[simp]
lemma iget_map [decidable_eq P.A] {α β : Type u} [inhabited α] [inhabited β]
  (x : P.obj α) (f : α → β) (i : P.Idx)
  (h : i.1 = x.1) :
  (f <$> x).iget i = f (x.iget i) :=
by { simp only [obj.iget, fst_map, *, dif_pos, eq_self_iff_true],
     cases x, refl }

end pfunctor

/-
Composition of polynomial functors.
-/

namespace pfunctor

/-- functor composition for polynomial functors -/
def comp (P₂ P₁ : pfunctor.{u}) : pfunctor.{u} :=
⟨ Σ a₂ : P₂.1, P₂.2 a₂ → P₁.1,
  λ a₂a₁, Σ u : P₂.2 a₂a₁.1, P₁.2 (a₂a₁.2 u) ⟩

/-- constructor for composition -/
def comp.mk (P₂ P₁ : pfunctor.{u}) {α : Type} (x : P₂.obj (P₁.obj α)) : (comp P₂ P₁).obj α :=
⟨ ⟨ x.1, sigma.fst ∘ x.2 ⟩, λ a₂a₁, (x.2 a₂a₁.1).2 a₂a₁.2  ⟩

/-- destructor for composition -/
def comp.get (P₂ P₁ : pfunctor.{u}) {α : Type} (x : (comp P₂ P₁).obj α) : P₂.obj (P₁.obj α) :=
⟨ x.1.1, λ a₂, ⟨x.1.2 a₂, λ a₁, x.2 ⟨a₂,a₁⟩ ⟩ ⟩

end pfunctor

/-
Lifting predicates and relations.
-/

namespace pfunctor
variables {P : pfunctor.{u}}
open functor

theorem liftp_iff {α : Type u} (p : α → Prop) (x : P.obj α) :
  liftp p x ↔ ∃ a f, x = ⟨a, f⟩ ∧ ∀ i, p (f i) :=
begin
  split,
  { rintros ⟨y, hy⟩, cases h : y with a f,
    refine ⟨a, λ i, (f i).val, _, λ i, (f i).property⟩,
    rw [←hy, h, pfunctor.map_eq] },
  rintros ⟨a, f, xeq, pf⟩,
  use ⟨a, λ i, ⟨f i, pf i⟩⟩,
  rw [xeq], reflexivity
end

theorem liftp_iff' {α : Type u} (p : α → Prop) (a : P.A) (f : P.B a → α) :
  @liftp.{u} P.obj _ α p ⟨a,f⟩ ↔ ∀ i, p (f i) :=
begin
  simp only [liftp_iff, sigma.mk.inj_iff]; split; intro,
  { casesm* [Exists _, _ ∧ _], subst_vars, assumption },
  repeat { constructor <|> assumption }
end

theorem liftr_iff {α : Type u} (r : α → α → Prop) (x y : P.obj α) :
  liftr r x y ↔ ∃ a f₀ f₁, x = ⟨a, f₀⟩ ∧ y = ⟨a, f₁⟩ ∧ ∀ i, r (f₀ i) (f₁ i) :=
begin
  split,
  { rintros ⟨u, xeq, yeq⟩, cases h : u with a f,
    use [a, λ i, (f i).val.fst, λ i, (f i).val.snd],
    split, { rw [←xeq, h], refl },
    split, { rw [←yeq, h], refl },
    intro i, exact (f i).property },
  rintros ⟨a, f₀, f₁, xeq, yeq, h⟩,
  use ⟨a, λ i, ⟨(f₀ i, f₁ i), h i⟩⟩,
  split,
  { rw [xeq], refl },
  rw [yeq], refl
end

open set

theorem supp_eq {α : Type u} (a : P.A) (f : P.B a → α) :
  @supp.{u} P.obj _ α  (⟨a,f⟩ : P.obj α) = f '' univ :=
begin
  ext, simp only [supp, image_univ, mem_range, mem_set_of_eq],
  split; intro h,
  { apply @h (λ x, ∃ (y : P.B a), f y = x),
    rw liftp_iff', intro, refine ⟨_,rfl⟩ },
  { simp only [liftp_iff'], cases h, subst x,
    tauto }
end

end pfunctor


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne, Yury Kudryashov.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.real.sqrt
import Mathlib.data.rat.sqrt
import Mathlib.ring_theory.int.basic
import Mathlib.data.polynomial.eval
import Mathlib.data.polynomial.degree.default
import Mathlib.tactic.interval_cases
import Mathlib.PostPort

namespace Mathlib

/-!
# Irrational real numbers

In this file we define a predicate `irrational` on `ℝ`, prove that the `n`-th root of an integer
number is irrational if it is not integer, and that `sqrt q` is irrational if and only if
`rat.sqrt q * rat.sqrt q ≠ q ∧ 0 ≤ q`.

We also provide dot-style constructors like `irrational.add_rat`, `irrational.rat_sub` etc.
-/

/-- A real number is irrational if it is not equal to any rational number. -/
def irrational (x : ℝ) :=
  ¬x ∈ set.range coe

theorem irrational_iff_ne_rational (x : ℝ) : irrational x ↔ ∀ (a b : ℤ), x ≠ ↑a / ↑b := sorry

/-!
### Irrationality of roots of integer and rational numbers
-/

/-- If `x^n`, `n > 0`, is integer and is not the `n`-th power of an integer, then
`x` is irrational. -/
theorem irrational_nrt_of_notint_nrt {x : ℝ} (n : ℕ) (m : ℤ) (hxr : x ^ n = ↑m) (hv : ¬∃ (y : ℤ), x = ↑y) (hnpos : 0 < n) : irrational x := sorry

/-- If `x^n = m` is an integer and `n` does not divide the `multiplicity p m`, then `x`
is irrational. -/
theorem irrational_nrt_of_n_not_dvd_multiplicity {x : ℝ} (n : ℕ) {m : ℤ} (hm : m ≠ 0) (p : ℕ) [hp : fact (nat.prime p)] (hxr : x ^ n = ↑m) (hv : roption.get (multiplicity (↑p) m) (iff.mpr multiplicity.finite_int_iff { left := nat.prime.ne_one hp, right := hm }) %
    n ≠
  0) : irrational x := sorry

theorem irrational_sqrt_of_multiplicity_odd (m : ℤ) (hm : 0 < m) (p : ℕ) [hp : fact (nat.prime p)] (Hpv : roption.get (multiplicity (↑p) m)
      (iff.mpr multiplicity.finite_int_iff { left := nat.prime.ne_one hp, right := ne.symm (ne_of_lt hm) }) %
    bit0 1 =
  1) : irrational (real.sqrt ↑m) := sorry

theorem nat.prime.irrational_sqrt {p : ℕ} (hp : nat.prime p) : irrational (real.sqrt ↑p) := sorry

theorem irrational_sqrt_two : irrational (real.sqrt (bit0 1)) := sorry

theorem irrational_sqrt_rat_iff (q : ℚ) : irrational (real.sqrt ↑q) ↔ rat.sqrt q * rat.sqrt q ≠ q ∧ 0 ≤ q := sorry

protected instance irrational.decidable (q : ℚ) : Decidable (irrational (real.sqrt ↑q)) :=
  decidable_of_iff' (rat.sqrt q * rat.sqrt q ≠ q ∧ 0 ≤ q) (irrational_sqrt_rat_iff q)

/-!
### Adding/subtracting/multiplying by rational numbers
-/

theorem rat.not_irrational (q : ℚ) : ¬irrational ↑q :=
  fun (h : irrational ↑q) => h (Exists.intro q rfl)

namespace irrational

theorem add_cases {x : ℝ} {y : ℝ} : irrational (x + y) → irrational x ∨ irrational y := sorry

theorem of_rat_add (q : ℚ) {x : ℝ} (h : irrational (↑q + x)) : irrational x :=
  or.elim (add_cases h) (fun (h : irrational ↑q) => absurd h (rat.not_irrational q)) id

theorem rat_add (q : ℚ) {x : ℝ} (h : irrational x) : irrational (↑q + x) :=
  of_rat_add (-q)
    (eq.mpr (id (Eq._oldrec (Eq.refl (irrational (↑(-q) + (↑q + x)))) (rat.cast_neg q)))
      (eq.mpr (id (Eq._oldrec (Eq.refl (irrational (-↑q + (↑q + x)))) (neg_add_cancel_left (↑q) x))) h))

theorem of_add_rat (q : ℚ) {x : ℝ} : irrational (x + ↑q) → irrational x :=
  add_comm (↑q) x ▸ of_rat_add q

theorem add_rat (q : ℚ) {x : ℝ} (h : irrational x) : irrational (x + ↑q) :=
  add_comm (↑q) x ▸ rat_add q h

theorem of_neg {x : ℝ} (h : irrational (-x)) : irrational x := sorry

protected theorem neg {x : ℝ} (h : irrational x) : irrational (-x) :=
  of_neg (eq.mpr (id (Eq._oldrec (Eq.refl (irrational ( --x))) (neg_neg x))) h)

theorem sub_rat (q : ℚ) {x : ℝ} (h : irrational x) : irrational (x - ↑q) := sorry

theorem rat_sub (q : ℚ) {x : ℝ} (h : irrational x) : irrational (↑q - x) :=
  eq.mpr (id ((fun (x x_1 : ℝ) (e_1 : x = x_1) => congr_arg irrational e_1) (↑q - x) (↑q + -x) (sub_eq_add_neg (↑q) x)))
    (eq.mp (Eq.refl (irrational (↑q + -x))) (rat_add q (irrational.neg h)))

theorem of_sub_rat (q : ℚ) {x : ℝ} (h : irrational (x - ↑q)) : irrational x := sorry

theorem of_rat_sub (q : ℚ) {x : ℝ} (h : irrational (↑q - x)) : irrational x := sorry

theorem mul_cases {x : ℝ} {y : ℝ} : irrational (x * y) → irrational x ∨ irrational y := sorry

theorem of_mul_rat (q : ℚ) {x : ℝ} (h : irrational (x * ↑q)) : irrational x :=
  or.elim (mul_cases h) id fun (h : irrational ↑q) => absurd h (rat.not_irrational q)

theorem mul_rat {x : ℝ} (h : irrational x) {q : ℚ} (hq : q ≠ 0) : irrational (x * ↑q) := sorry

theorem of_rat_mul (q : ℚ) {x : ℝ} : irrational (↑q * x) → irrational x :=
  mul_comm x ↑q ▸ of_mul_rat q

theorem rat_mul {x : ℝ} (h : irrational x) {q : ℚ} (hq : q ≠ 0) : irrational (↑q * x) :=
  mul_comm x ↑q ▸ mul_rat h hq

theorem of_mul_self {x : ℝ} (h : irrational (x * x)) : irrational x :=
  or.elim (mul_cases h) id id

theorem of_inv {x : ℝ} (h : irrational (x⁻¹)) : irrational x := sorry

protected theorem inv {x : ℝ} (h : irrational x) : irrational (x⁻¹) :=
  of_inv (eq.mpr (id (Eq._oldrec (Eq.refl (irrational (x⁻¹⁻¹))) (inv_inv' x))) h)

theorem div_cases {x : ℝ} {y : ℝ} (h : irrational (x / y)) : irrational x ∨ irrational y :=
  or.imp id of_inv (mul_cases h)

theorem of_rat_div (q : ℚ) {x : ℝ} (h : irrational (↑q / x)) : irrational x :=
  of_inv (of_rat_mul q h)

theorem of_one_div {x : ℝ} (h : irrational (1 / x)) : irrational x :=
  of_rat_div 1 (eq.mpr (id (Eq._oldrec (Eq.refl (irrational (↑1 / x))) rat.cast_one)) h)

theorem of_pow {x : ℝ} (n : ℕ) : irrational (x ^ n) → irrational x := sorry

theorem of_fpow {x : ℝ} (m : ℤ) : irrational (x ^ m) → irrational x := sorry

end irrational

theorem one_lt_nat_degree_of_irrational_root (x : ℝ) (p : polynomial ℤ) (hx : irrational x) (p_nonzero : p ≠ 0) (x_is_root : coe_fn (polynomial.aeval x) p = 0) : 1 < polynomial.nat_degree p := sorry

@[simp] theorem irrational_rat_add_iff {q : ℚ} {x : ℝ} : irrational (↑q + x) ↔ irrational x :=
  { mp := irrational.of_rat_add q, mpr := irrational.rat_add q }

@[simp] theorem irrational_add_rat_iff {q : ℚ} {x : ℝ} : irrational (x + ↑q) ↔ irrational x :=
  { mp := irrational.of_add_rat q, mpr := irrational.add_rat q }

@[simp] theorem irrational_rat_sub_iff {q : ℚ} {x : ℝ} : irrational (↑q - x) ↔ irrational x :=
  { mp := irrational.of_rat_sub q, mpr := irrational.rat_sub q }

@[simp] theorem irrational_sub_rat_iff {q : ℚ} {x : ℝ} : irrational (x - ↑q) ↔ irrational x :=
  { mp := irrational.of_sub_rat q, mpr := irrational.sub_rat q }

@[simp] theorem irrational_neg_iff {x : ℝ} : irrational (-x) ↔ irrational x :=
  { mp := irrational.of_neg, mpr := irrational.neg }

@[simp] theorem irrational_inv_iff {x : ℝ} : irrational (x⁻¹) ↔ irrational x :=
  { mp := irrational.of_inv, mpr := irrational.inv }


/-
Copyright (c) 2020 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.lie.basic
import Mathlib.linear_algebra.bilinear_form
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Lie algebras of skew-adjoint endomorphisms of a bilinear form

## Tags

lie algebra, skew-adjoint, bilinear form
-/

theorem bilin_form.is_skew_adjoint_bracket {R : Type u} {M : Type v} [comm_ring R]
    [add_comm_group M] [module R M] (B : bilin_form R M) (f : module.End R M) (g : module.End R M)
    (hf : f ∈ bilin_form.skew_adjoint_submodule B) (hg : g ∈ bilin_form.skew_adjoint_submodule B) :
    has_bracket.bracket f g ∈ bilin_form.skew_adjoint_submodule B :=
  sorry

/-- Given an `R`-module `M`, equipped with a bilinear form, the skew-adjoint endomorphisms form a
Lie subalgebra of the Lie algebra of endomorphisms. -/
def skew_adjoint_lie_subalgebra {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
    [module R M] (B : bilin_form R M) : lie_subalgebra R (module.End R M) :=
  lie_subalgebra.mk (submodule.carrier (bilin_form.skew_adjoint_submodule B)) sorry sorry sorry
    (bilin_form.is_skew_adjoint_bracket B)

/-- An equivalence of modules with bilinear forms gives equivalence of Lie algebras of skew-adjoint
endomorphisms. -/
def skew_adjoint_lie_subalgebra_equiv {R : Type u} {M : Type v} [comm_ring R] [add_comm_group M]
    [module R M] (B : bilin_form R M) {N : Type w} [add_comm_group N] [module R N]
    (e : linear_equiv R N M) :
    lie_algebra.equiv R ↥(skew_adjoint_lie_subalgebra (bilin_form.comp B ↑e ↑e))
        ↥(skew_adjoint_lie_subalgebra B) :=
  lie_algebra.equiv.of_subalgebras (skew_adjoint_lie_subalgebra (bilin_form.comp B ↑e ↑e))
    (skew_adjoint_lie_subalgebra B) (linear_equiv.lie_conj e) sorry

@[simp] theorem skew_adjoint_lie_subalgebra_equiv_apply {R : Type u} {M : Type v} [comm_ring R]
    [add_comm_group M] [module R M] (B : bilin_form R M) {N : Type w} [add_comm_group N]
    [module R N] (e : linear_equiv R N M)
    (f : ↥(skew_adjoint_lie_subalgebra (bilin_form.comp B ↑e ↑e))) :
    ↑(coe_fn (skew_adjoint_lie_subalgebra_equiv B e) f) = coe_fn (linear_equiv.lie_conj e) ↑f :=
  sorry

@[simp] theorem skew_adjoint_lie_subalgebra_equiv_symm_apply {R : Type u} {M : Type v} [comm_ring R]
    [add_comm_group M] [module R M] (B : bilin_form R M) {N : Type w} [add_comm_group N]
    [module R N] (e : linear_equiv R N M) (f : ↥(skew_adjoint_lie_subalgebra B)) :
    ↑(coe_fn (lie_algebra.equiv.symm (skew_adjoint_lie_subalgebra_equiv B e)) f) =
        coe_fn (linear_equiv.lie_conj (linear_equiv.symm e)) ↑f :=
  sorry

theorem matrix.lie_transpose {R : Type u} {n : Type w} [comm_ring R] [DecidableEq n] [fintype n]
    (A : matrix n n R) (B : matrix n n R) :
    matrix.transpose (has_bracket.bracket A B) =
        has_bracket.bracket (matrix.transpose B) (matrix.transpose A) :=
  sorry

theorem matrix.is_skew_adjoint_bracket {R : Type u} {n : Type w} [comm_ring R] [DecidableEq n]
    [fintype n] (J : matrix n n R) (A : matrix n n R) (B : matrix n n R)
    (hA : A ∈ skew_adjoint_matrices_submodule J) (hB : B ∈ skew_adjoint_matrices_submodule J) :
    has_bracket.bracket A B ∈ skew_adjoint_matrices_submodule J :=
  sorry

/-- The Lie subalgebra of skew-adjoint square matrices corresponding to a square matrix `J`. -/
def skew_adjoint_matrices_lie_subalgebra {R : Type u} {n : Type w} [comm_ring R] [DecidableEq n]
    [fintype n] (J : matrix n n R) : lie_subalgebra R (matrix n n R) :=
  lie_subalgebra.mk (submodule.carrier (skew_adjoint_matrices_submodule J)) sorry sorry sorry sorry

@[simp] theorem mem_skew_adjoint_matrices_lie_subalgebra {R : Type u} {n : Type w} [comm_ring R]
    [DecidableEq n] [fintype n] (J : matrix n n R) (A : matrix n n R) :
    A ∈ skew_adjoint_matrices_lie_subalgebra J ↔ A ∈ skew_adjoint_matrices_submodule J :=
  iff.rfl

/-- An invertible matrix `P` gives a Lie algebra equivalence between those endomorphisms that are
skew-adjoint with respect to a square matrix `J` and those with respect to `PᵀJP`. -/
def skew_adjoint_matrices_lie_subalgebra_equiv {R : Type u} {n : Type w} [comm_ring R]
    [DecidableEq n] [fintype n] (J : matrix n n R) (P : matrix n n R) (h : is_unit P) :
    lie_algebra.equiv R ↥(skew_adjoint_matrices_lie_subalgebra J)
        ↥(skew_adjoint_matrices_lie_subalgebra
            (matrix.mul (matrix.mul (matrix.transpose P) J) P)) :=
  lie_algebra.equiv.of_subalgebras (skew_adjoint_matrices_lie_subalgebra J)
    (skew_adjoint_matrices_lie_subalgebra (matrix.mul (matrix.mul (matrix.transpose P) J) P))
    (lie_algebra.equiv.symm (matrix.lie_conj P h)) sorry

theorem skew_adjoint_matrices_lie_subalgebra_equiv_apply {R : Type u} {n : Type w} [comm_ring R]
    [DecidableEq n] [fintype n] (J : matrix n n R) (P : matrix n n R) (h : is_unit P)
    (A : ↥(skew_adjoint_matrices_lie_subalgebra J)) :
    ↑(coe_fn (skew_adjoint_matrices_lie_subalgebra_equiv J P h) A) =
        matrix.mul (matrix.mul (P⁻¹) ↑A) P :=
  sorry

/-- An equivalence of matrix algebras commuting with the transpose endomorphisms restricts to an
equivalence of Lie algebras of skew-adjoint matrices. -/
def skew_adjoint_matrices_lie_subalgebra_equiv_transpose {R : Type u} {n : Type w} [comm_ring R]
    [DecidableEq n] [fintype n] (J : matrix n n R) {m : Type w} [DecidableEq m] [fintype m]
    (e : alg_equiv R (matrix n n R) (matrix m m R))
    (h : ∀ (A : matrix n n R), matrix.transpose (coe_fn e A) = coe_fn e (matrix.transpose A)) :
    lie_algebra.equiv R ↥(skew_adjoint_matrices_lie_subalgebra J)
        ↥(skew_adjoint_matrices_lie_subalgebra (coe_fn e J)) :=
  lie_algebra.equiv.of_subalgebras (skew_adjoint_matrices_lie_subalgebra J)
    (skew_adjoint_matrices_lie_subalgebra (coe_fn e J)) (alg_equiv.to_lie_equiv e) sorry

@[simp] theorem skew_adjoint_matrices_lie_subalgebra_equiv_transpose_apply {R : Type u} {n : Type w}
    [comm_ring R] [DecidableEq n] [fintype n] (J : matrix n n R) {m : Type w} [DecidableEq m]
    [fintype m] (e : alg_equiv R (matrix n n R) (matrix m m R))
    (h : ∀ (A : matrix n n R), matrix.transpose (coe_fn e A) = coe_fn e (matrix.transpose A))
    (A : ↥(skew_adjoint_matrices_lie_subalgebra J)) :
    ↑(coe_fn (skew_adjoint_matrices_lie_subalgebra_equiv_transpose J e h) A) = coe_fn e ↑A :=
  rfl

theorem mem_skew_adjoint_matrices_lie_subalgebra_unit_smul {R : Type u} {n : Type w} [comm_ring R]
    [DecidableEq n] [fintype n] (u : units R) (J : matrix n n R) (A : matrix n n R) :
    A ∈ skew_adjoint_matrices_lie_subalgebra (↑u • J) ↔
        A ∈ skew_adjoint_matrices_lie_subalgebra J :=
  sorry

end Mathlib


import ch8
universe u
namespace Set

local attribute [irreducible] mem

-- sections 1 and 2 are mostly skipped

lemma Aleph_le_of_le {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal) :
  α.Aleph.card_le β.Aleph ↔ α ≤ β :=
begin
  rw card_le_iff, split,
    rintro (h|h),
      left, exact Aleph_oto' αord βord h,
    right, apply Aleph_oto (succ_ord_of_ord (ord_max_ord αord βord)),
    { rw mem_succ_iff_le, exact ord_max_le_left, },
    { rw mem_succ_iff_le, exact ord_max_le_right αord βord, },
    exact h,
  rintro (h|h),
    left, exact Aleph_lt_of_mem βord h,
  subst h, right, refl,
end

lemma Aleph_oto'' {α : Set} (αord : α.is_ordinal) {β : Set} (βord : β.is_ordinal) (αβ : α.Aleph = β.Aleph) : α = β :=
begin
  refine Aleph_oto (succ_ord_of_ord (ord_max_ord αord βord)) _ _ αβ; rw mem_succ_iff_le,
    exact ord_max_le_left,
  exact ord_max_le_right αord βord,
end

lemma nat_pos_of_not_empty {n m : Set} (nm : n ∈ m) (mω : m ∈ ω) : ∅ ∈ m :=
begin
  apply classical.by_contradiction, intro h,
  obtain h₂ := le_of_not_lt zero_nat mω h, cases h₂,
    exact mem_empty _ h₂,
  subst h₂, exact mem_empty _ nm,
end

lemma ord_disj {β : Set} (βord : β.is_ordinal) : {β} ∩ β = ∅ :=
begin
  apply classical.by_contradiction, intro h,
  obtain ⟨α, hα⟩ := inhabited_of_ne_empty h, rw [mem_inter, mem_singleton] at hα,
  obtain ⟨αβ, hα⟩ := hα, subst αβ, exact ord_mem_irrefl βord hα,
end

lemma card_empty : card ∅ = ∅ :=
by rw card_nat zero_nat

lemma struct_restrict_eq {α : Set} (αord : α.is_ordinal) {S : Set} (Sα : S ⊆ α) :
  S.eps_order_struct = S.struct_restrict (α.eps_order_struct) :=
begin
  ext; dsimp,
    refl,
  refine rel_ext pair_sep_is_rel (inter_rel_is_rel pair_sep_is_rel) _,
  intros x y, simp only [eps_order, mem_inter, pair_mem_prod, pair_mem_pair_sep], split,
    rintro ⟨xS, yS, xy⟩, exact ⟨⟨Sα xS, Sα yS, xy⟩, xS, yS⟩,
  rintro ⟨⟨_, _, xy⟩, xS, yS⟩, exact ⟨xS, yS, xy⟩,
end

lemma inf_card_is_limit {κ : Set} (κcard : κ.is_cardinal) (κinf : ¬ κ.finite_cardinal) : κ.limit_ord :=
begin
  refine ⟨card_is_ord κcard, _, _⟩,
  { rw finite_cardinal_iff_nat at κinf, intro κz, subst κz, exact κinf zero_nat, },
  { rintro ⟨μ, κμ⟩, subst κμ,
    obtain ⟨κord, h⟩ := init_iff_card.mpr κcard,
    refine h ⟨_, self_mem_succ, _⟩,
    have μinf : ¬μ.card.finite_cardinal, rw finite_cardinal_iff_nat at κinf,
      intro μω, rw [card_finite_iff_finite, ord_finite (ord_of_succ_ord κord)] at μω,
      exact κinf (succ_nat_is_nat μω),
    rw [←card_equiv, card_succ_eq,
      card_add_comm card_is_card (nat_is_cardinal one_nat),
      card_add_eq_right_of_le (nat_is_cardinal one_nat) card_is_card μinf (nat_le_inf' one_nat card_is_card μinf)], },
end

lemma ord_finite_iff {α : Set} (αord : α.is_ordinal) : α.is_finite ↔ α ∈ ω :=
begin
  split,
    intro αfin, apply classical.by_contradiction, intro h,
    rw [ord_not_lt_iff_le αord omega_is_ord, ord_le_iff_sub omega_is_ord αord] at h,
    apply inf_of_sup_inf nat_infinite h αfin,
  exact nat_finite,
end

lemma exists_least_card_of_exists {p : Set → Prop} (h : ∃ κ : Set, κ.is_cardinal ∧ p κ) :
  ∃ κ : Set, κ.is_cardinal ∧ p κ ∧ ∀ {μ : Set}, μ.is_cardinal → p μ → κ ≤ μ :=
begin
  rcases h with ⟨κ, κcard, pκ⟩,
  obtain ⟨α, αord, ⟨αcard, pα⟩, h⟩ := @exists_least_ord_of_exists (λ α, α.is_cardinal ∧ p α) ⟨κ, card_is_ord κcard, κcard, pκ⟩,
  refine ⟨_, αcard, pα, _⟩, intros μ μcard pμ, exact h (card_is_ord μcard) ⟨μcard, pμ⟩,
end

def cofinal (γ S : Set) : Prop :=
S ⊆ γ ∧ γ = S.Union

lemma limit_cf_self {γ : Set} (γord : γ.limit_ord) : γ.cofinal γ :=
⟨subset_self, limit_ord_eq_Union γord⟩

lemma limit_cf_lemma {γ : Set} (γord : γ.limit_ord) : ∃ κ : Set, (∃ S : Set, γ.cofinal S ∧ S.card = κ) ∧
  ∀ {S : Set}, γ.cofinal S → κ ≤ S.card :=
begin
  obtain ⟨κ, -, h₁, h₂⟩ := @exists_least_card_of_exists (λ κ, ∃ S : Set, γ.cofinal S ∧ S.card = κ)
    ⟨_, card_is_card, _, ⟨subset_self, limit_ord_eq_Union γord⟩, rfl⟩,
  refine ⟨_, h₁, _⟩, intros S γS, exact h₂ card_is_card ⟨_, γS, rfl⟩,
end

local attribute [instance] classical.prop_decidable

noncomputable def cf (γ : Set) : Set :=
if ne : γ = ∅ then ∅
else if ex : ∃ α : Set, γ = α.succ then one
else if γord : γ.limit_ord then classical.some (limit_cf_lemma γord)
else ∅

lemma cf_zero : cf ∅ = ∅ :=
begin
  dsimp [cf], rw if_pos rfl,
end

lemma cf_succ {α : Set} : α.succ.cf = one :=
begin
  dsimp [cf], rw [if_neg succ_neq_empty, if_pos], exact ⟨_, rfl⟩,
end

lemma cf_limit {γ : Set} (γord : γ.limit_ord) : ∃ S : Set, γ.cofinal S ∧ S.card = γ.cf :=
begin
  dsimp [cf], rw [if_neg γord.ne, if_neg γord.ns, dif_pos γord],
  obtain ⟨h, -⟩ := classical.some_spec (limit_cf_lemma γord), exact h,
end

lemma cf_limit_least {γ : Set} (γord : γ.limit_ord) {S : Set} (γS : γ.cofinal S) : γ.cf ≤ S.card :=
begin
  dsimp [cf], rw [if_neg γord.ne, if_neg γord.ns, dif_pos γord],
  obtain ⟨-, h⟩ := classical.some_spec (limit_cf_lemma γord), exact h γS,
end

lemma cf_least {α : Set} (αord : α.is_ordinal) {S : Set} (αS : α.cofinal S) : α.cf ≤ S.card :=
begin
  rcases ord_cases αord with (αz|(⟨β, αβ⟩|αord')),
  { subst αz, rw cf_zero, exact empty_le_ord (card_is_ord card_is_card), },
  { subst αβ, rw cf_succ, apply card_ge_one_of_inhab,
    rcases αS with ⟨-, αS⟩,
    have βS : β ∈ S.Union, rw ←αS, exact self_mem_succ, rw mem_Union at βS,
    rcases βS with ⟨γ, γS, -⟩, exact ⟨_, γS⟩, },
  { exact cf_limit_least αord' αS, },
end

lemma cf_ord_le_card {α : Set} (αord : α.is_ordinal) : α.cf ≤ α.card :=
begin
  rcases ord_cases αord with (αz|(⟨β, αβ⟩|αord')),
  { subst αz, rw [cf_zero, card_empty], exact empty_le_ord αord, },
  { subst αβ,
    have βord : β.is_ordinal := ord_of_succ_ord αord,
    rw [cf_succ, ←card_le_iff_le (nat_is_cardinal one_nat) card_is_card, succ, card_add_spec rfl rfl (ord_disj βord), ←add_base one_nat,
      ←card_add_eq_ord_add (finite_cardinal_iff_nat.mpr one_nat) (finite_cardinal_iff_nat.mpr zero_nat),
    card_singleton], refine card_add_le_of_le_right (nat_is_cardinal zero_nat) card_is_card (zero_card_le card_is_card) (nat_is_cardinal one_nat), },
  { exact cf_limit_least αord' (limit_cf_self αord'), },
end

lemma cf_is_card {α : Set} (αord : α.is_ordinal) : α.cf.is_cardinal :=
begin
  rcases ord_cases αord with (αz|(⟨β, αβ⟩|αord')),
  { subst αz, rw [cf_zero], exact nat_is_cardinal zero_nat, },
  { subst αβ, rw [cf_succ], exact nat_is_cardinal one_nat, },
  { obtain ⟨S, -, Scard⟩ := cf_limit αord', rw ←Scard, exact card_is_card, },
end

lemma cf_card {κ : Set} (κcard : κ.is_cardinal) : κ.cf ≤ κ :=
begin
  nth_rewrite 1 ←card_of_cardinal_eq_self κcard,
  exact cf_ord_le_card (card_is_ord κcard),
end

lemma unbounded_nats_inf {S : Set} (Sω : S ⊆ ω) (Sin : S.inhab) (un : ∀ {n : Set}, n ∈ S → ∃ m : Set, m ∈ S ∧ n ∈ m) : ¬ S.is_finite :=
begin
  let R : struct := S.eps_order_struct,
  have Rwell : R.fld.well_order R.rel,
    have Re : R = S.struct_restrict (eps_order_struct ω) := struct_restrict_eq omega_is_ord Sω,
    rw Re, refine well_order_struct_restrict (ordinal_well_ordered' omega_is_ord) _, exact Sω,
  intro Sfin, rw [←card_finite_iff_finite, finite_cardinal_iff_nat] at Sfin,
  obtain ⟨α, αord, f, fcorr, iso⟩ := exists_iso_ord Rwell,
  have equin : α ≈ S := ⟨_, fcorr⟩,
  rw ←card_equiv at equin, rw [←equin, ←finite_cardinal_iff_nat, card_finite_iff_finite, ord_finite_iff αord] at Sfin,
  simp only [eps_order_struct_fld] at fcorr iso,
  rcases exists_pred Sfin with (αz|⟨m, mω, αm⟩),
    subst αz, suffices h : S = ∅, exact ne_empty_of_inhabited _ Sin h,
    rwa [←fcorr.onto.right.right, ←dom_ran_eq_empty_iff, fcorr.onto.right.left],
  subst αm,
  have fmS : f.fun_value m ∈ S, rw ←fcorr.onto.right.right, apply fun_value_def'' fcorr.onto.left,
    rw fcorr.onto.right.left, exact self_mem_succ,
  obtain ⟨n, nS, mn⟩ := un fmS, rw [←fcorr.onto.right.right, mem_ran_iff fcorr.onto.left] at nS,
  obtain ⟨k, km, nfk⟩ := nS, rw fcorr.onto.right.left at km, subst nfk,
  specialize iso self_mem_succ km,
  have fkS : f.fun_value k ∈ S, rw ←fcorr.onto.right.right, apply fun_value_def'' fcorr.onto.left,
    rwa fcorr.onto.right.left,
  simp only [pair_mem_eps_order self_mem_succ km, R, pair_mem_eps_order fmS fkS] at iso,
  exact succ_imm m ⟨_, iso.mpr mn, km⟩,
end

lemma unbounded_ords_inf {α : Set} (αord : α.is_ordinal) {S : Set} (Sα : S ⊆ α) (Sin : S.inhab) (un : ∀ {n : Set}, n ∈ S → ∃ m : Set, m ∈ S ∧ n ∈ m) : ¬ S.is_finite :=
begin
  let R : struct := S.eps_order_struct,
  have Rwell : R.fld.well_order R.rel,
    have Re : R = S.struct_restrict (eps_order_struct α) := struct_restrict_eq αord Sα,
    rw Re, refine well_order_struct_restrict (ordinal_well_ordered' αord) _, exact Sα,
  intro Sfin, rw [←card_finite_iff_finite, finite_cardinal_iff_nat] at Sfin,
  obtain ⟨α, αord, f, fcorr, iso⟩ := exists_iso_ord Rwell,
  have equin : α ≈ S := ⟨_, fcorr⟩,
  rw ←card_equiv at equin, rw [←equin, ←finite_cardinal_iff_nat, card_finite_iff_finite, ord_finite_iff αord] at Sfin,
  simp only [eps_order_struct_fld] at fcorr iso,
  rcases exists_pred Sfin with (αz|⟨m, mω, αm⟩),
    subst αz, suffices h : S = ∅, exact ne_empty_of_inhabited _ Sin h,
    rwa [←fcorr.onto.right.right, ←dom_ran_eq_empty_iff, fcorr.onto.right.left],
  subst αm,
  have fmS : f.fun_value m ∈ S, rw ←fcorr.onto.right.right, apply fun_value_def'' fcorr.onto.left,
    rw fcorr.onto.right.left, exact self_mem_succ,
  obtain ⟨n, nS, mn⟩ := un fmS, rw [←fcorr.onto.right.right, mem_ran_iff fcorr.onto.left] at nS,
  obtain ⟨k, km, nfk⟩ := nS, rw fcorr.onto.right.left at km, subst nfk,
  specialize iso self_mem_succ km,
  have fkS : f.fun_value k ∈ S, rw ←fcorr.onto.right.right, apply fun_value_def'' fcorr.onto.left,
    rwa fcorr.onto.right.left,
  simp only [pair_mem_eps_order self_mem_succ km, R, pair_mem_eps_order fmS fkS] at iso,
  exact succ_imm m ⟨_, iso.mpr mn, km⟩,
end

lemma Union_finite_nats_finite {S : Set} (Sfin : S.is_finite) (Sω : S ⊆ ω)
  (unb : ∀ {n : Set}, n ∈ S → (∃ (m : Set), m ∈ S ∧ n ∈ m)) : S.Union.is_finite :=
begin
  by_cases Sin : S.inhab,
    apply classical.by_contradiction, intro h,
    have he : S.Union = ω, refine eq_nat_of_induct_sub _ (Union_sub (λ n nS, subset_nat_of_mem_nat (Sω nS))),
      split; simp only [mem_Union, exists_prop],
        rcases Sin with ⟨n, nS⟩, obtain ⟨m, mS, nm⟩ := unb nS,
        exact ⟨_, mS, nat_pos_of_not_empty nm (Sω mS)⟩,
      rintros n ⟨m, mS, nm⟩, obtain ⟨k, kS, mk⟩ := unb mS,
      refine ⟨_, kS, nat_lt_of_le_of_lt (le_of_not_lt (Sω mS) (succ_nat_is_nat (mem_nat_of_mem_nat_of_mem (Sω mS) nm)) _) mk (Sω kS)⟩,
      intro mn, exact succ_imm n ⟨_, nm, mn⟩,
    apply @unbounded_nats_inf S Sω _ @unb Sfin,
    have zn := zero_nat, rw [←he, mem_Union] at zn, rcases zn with ⟨m, mS, -⟩,
    exact ⟨_, mS⟩,
  have Se : S = ∅ := classical.by_contradiction (λ h, Sin (inhabited_of_ne_empty h)),
  subst Se, rw Union_empty, exact nat_finite zero_nat,
end

lemma cf_omega_eq : cf ω = card ω :=
begin
  cases cf_ord_le_card omega_is_ord,
    obtain ⟨S, ⟨h₁, h₂⟩, Scard⟩ := cf_limit omega_limit_ord,
    exfalso, apply nat_infinite, rw h₂, apply Union_finite_nats_finite,
        rw [←card_finite_iff_finite, Scard, finite_cardinal_iff_nat],
        nth_rewrite 1 ←card_of_cardinal_eq_self omega_is_card, exact h,
      have zn := zero_nat, rw [h₂, mem_Union] at zn,
      rcases zn with ⟨x, xS, -⟩, exact h₁,
    intros n nS, specialize h₁ nS, rw h₂ at h₁,
    simp only [mem_Union, exists_prop] at h₁, exact h₁,
  exact h,
end

def regular (κ : Set) : Prop := κ.cf = κ
def singular (κ : Set) : Prop := κ.cf.card_lt κ

lemma sing_or_reg {κ : Set} (κcard : κ.is_cardinal) : κ.regular ∨ κ.singular :=
or.elim (cf_card κcard)
  (λ h, or.inr (card_lt_of_mem (cf_is_card (card_is_ord κcard)) κcard h))
  (λ h, or.inl h)

lemma cf_spec {α : Set} (αord : α.is_ordinal) : ∃ S : Set, S ⊆ α ∧ S.card = α.cf ∧ ∀ {β : Set}, β.is_ordinal → S ⊆ β → α ≤ β :=
begin
  rcases ord_cases αord with (αz|(⟨γ, αγ⟩|αord')),
  { subst αz, rw cf_zero, refine ⟨_, subset_self, _, λ β βord Sβ, empty_le_ord βord⟩,
    rw card_nat zero_nat, },
  { subst αγ, refine ⟨{γ}, _, _, _⟩,
    { intros γ' γγ, rw mem_singleton at γγ, subst γγ, exact self_mem_succ, },
    { rw [card_singleton, cf_succ], },
    { intros β βord γβ, apply succ_least_upper_bound βord, apply γβ,
      rw mem_singleton, }, },
  { obtain ⟨S, ⟨Sα, h⟩, Scard⟩ := cf_limit αord', subst h,
    refine ⟨_, Sα, Scard, λ β βord Sβ, _⟩, rw ←ord_not_lt_iff_le βord αord,
    intros βS, rw mem_Union at βS, rcases βS with ⟨γ, γS, βγ⟩,
    exact ord_mem_irrefl βord (ord_mem_trans βord βγ (Sβ γS)), },
end

lemma cf_least' {α : Set} (αord : α.is_ordinal) {S : Set} (Sα : S ⊆ α) (h : ∀ {β : Set}, β.is_ordinal → S ⊆ β → α ≤ β) : α.cf ≤ S.card :=
begin
  rcases ord_cases αord with (αz|(⟨γ, αγ⟩|αord')),
  { subst αz, rw cf_zero, exact empty_le_ord (card_is_ord card_is_card), },
  { subst αγ, rw cf_succ,
    have Sin : S.inhab, apply inhabited_of_ne_empty, intro Se, subst Se,
      specialize h zero_is_ord subset_self, exact not_succ_le_empty h,
    exact card_ge_one_of_inhab Sin, },
  { have αS : α = S.Union, rw eq_iff_subset_and_subset, split,
        intros β βα, simp only [mem_Union, exists_prop], apply classical.by_contradiction, intro h',
        push_neg at h', replace h' : S ⊆ β.succ :=
          λ γ γS, mem_succ_iff_le.mpr ((ord_not_lt_iff_le (ord_of_mem_ord αord βα) (ord_of_mem_ord αord (Sα γS))).mp (h' _ γS)),
        refine succ_imm β ⟨_, βα, _⟩, specialize h (succ_ord_of_ord (ord_of_mem_ord αord βα)) h', cases h,
          exact h,
        exfalso, exact αord'.ns ⟨_, h⟩,
      exact subset_trans (Union_sub_of_sub Sα) (ordinal_trans αord),
    exact cf_least αord ⟨Sα, αS⟩, },
end

lemma regular_iff_ne {κ : Set} (κcard : κ.is_cardinal) (κinf : ¬ κ.finite_cardinal) : κ.regular ↔ ∀ {S : Set}, κ.cofinal S → S.card = κ :=
begin
  split,
    intro reg, intros S κS, cases cf_least (card_is_ord κcard) κS,
      exfalso, apply @not_mem_self S.card, refine ord_mem_trans (card_is_ord card_is_card) _ h,
      dsimp [regular] at reg, rw [reg, ←card_lt_iff_mem card_is_card κcard], split,
        rcases κS with ⟨κS, -⟩,
        rw ←card_of_cardinal_eq_self κcard, exact card_le_of_subset κS,
      symmetry, apply ne_of_mem, rwa ←reg,
    dsimp [regular] at reg, rw [←reg, h],
  intro h, dsimp [regular], cases cf_card κcard with h₁ h₁,
    exfalso, apply @not_mem_self κ, obtain ⟨S, cof, Scard⟩ := cf_limit (inf_card_is_limit κcard κinf),
    rwa [←Scard, h cof] at h₁,
  exact h₁,
end

-- chapter 6, exercise 26
theorem ch6_26 {κ : Set.{u}} (κcard : κ.is_cardinal) : ∀ {A : Set.{u}}, (∀ {x : Set}, x ∈ A → x.card.card_le κ) → A.Union.card.card_le (A.card.card_mul κ) :=
begin
  rcases κcard with ⟨K, Kcard⟩, subst Kcard,
  have h₁ : ∀ {A : Set.{u}}, ∅ ∉ A → (∀ {x : Set}, x ∈ A → x.card.card_le K.card) → A.Union.card.card_le (A.card.card_mul K.card),
    intros A h₁ hA,
    by_cases Ain : A.inhab,
      let H := pair_sep_eq A (into_funs K A.Union).powerset (λ y, {g ∈ into_funs K y | g.onto_fun K y}),
      have Hfun : H.is_function := pair_sep_eq_is_fun,
      have Hdom : H.dom = A, apply pair_sep_eq_dom_eq, dsimp, intros x xA, rw mem_powerset,
        intros g hg, rw mem_sep at hg, rw mem_into_funs, refine into_of_into_ran_sub _ (into_of_onto hg.right),
        exact subset_Union_of_mem xA,
      have hH : ∀ x : Set, x ∈ A → H.fun_value x ≠ ∅, intros x xA,
        specialize hA xA, rw card_le_iff_equin' at hA,
        have xin : x ≠ ∅, intro xe, subst xe, exact h₁ xA,
        replace xin := inhabited_of_ne_empty xin,
        obtain ⟨g, gonto⟩ := exists_onto_of_dominated xin hA,
        rw ←Hdom at xA, rw pair_sep_eq_fun_value xA, dsimp, apply ne_empty_of_inhabited,
        use g, rw [mem_sep, mem_into_funs], exact ⟨into_of_onto gonto, gonto⟩,
      have memHm : ∀ {x : Set}, x ∈ A → ∀ {g : Set}, g ∈ H.fun_value x ↔ g.onto_fun K x,
        intros m mω g, rw ←Hdom at mω, rw pair_sep_eq_fun_value mω, dsimp, rw [mem_sep, mem_into_funs], split,
          rintro ⟨-, h⟩, exact h,
        intro h, exact ⟨into_of_onto h, h⟩,
      obtain ⟨F, Ffun, Fdom, hF⟩ := ax_ch_2 ⟨Hfun, Hdom, hH⟩,
      let f := pair_sep_eq (prod A K) A.Union (λ z, (F.fun_value z.fst).fun_value z.snd),
      have fonto : f.onto_fun (prod A K) A.Union, refine ⟨pair_sep_eq_is_fun, pair_sep_eq_dom_eq _, pair_sep_eq_ran_eq _⟩; dsimp,
          simp only [mem_prod, mem_Union, exists_prop], rintros z ⟨x, xA, y, yK, zxy⟩, subst zxy, rw [fst_congr, snd_congr],
          have h := (memHm xA).mp (hF _ xA),
          refine ⟨_, xA, _⟩,
          nth_rewrite 1 ←h.right.right, apply fun_value_def'' h.left, rw h.right.left, exact yK,
        simp only [mem_Union, exists_prop], rintros y ⟨B, BA, yB⟩,
        specialize hF _ BA, rw memHm BA at hF,
        rw [←hF.right.right, mem_ran_iff hF.left] at yB, rcases yB with ⟨x, xK, xe⟩, subst xe,
        rw hF.right.left at xK, use B.pair x, simp only [pair_mem_prod, fst_congr, snd_congr],
        exact ⟨⟨BA, xK⟩, rfl⟩,
      have Ain' : A.Union.inhab, rcases Ain with ⟨B, BA⟩,
        have Bin : B.inhab := classical.by_contradiction (λ Bnin,
          have Bne : B = ∅ := classical.by_contradiction (λ Bne, Bnin (inhabited_of_ne_empty Bne)),
          h₁ (Bne ▸ BA)),
        rcases Bin with ⟨x, xB⟩, use x, rw mem_Union, exact ⟨_, BA, xB⟩,
      rw [←card_mul_spec rfl rfl, card_le_iff_equin'], exact dominates_of_onto_fun ⟨f, fonto⟩,
    have h : A = ∅ := classical.by_contradiction (λ Ane, Ain (inhabited_of_ne_empty Ane)),
    subst h, rw union_empty_eq_empty, nth_rewrite 0 card_nat zero_nat,
    exact zero_card_le (mul_cardinal card_is_card card_is_card),
  intros A hA, rw Union_diff_empty_eq,
  apply @card_le_trans _ ((A \ {∅}).card.card_mul K.card) (mul_cardinal card_is_card card_is_card),
    apply h₁,
      intro h, rw [mem_diff, mem_singleton] at h, exact h.right rfl,
    intros x hx, exact hA (subset_diff hx),
  refine card_mul_le_of_le_left card_is_card card_is_card _ card_is_card, exact card_le_of_subset subset_diff,
end

-- Theorem 9M
theorem Aleph_succ_regular {α : Set} (αord : α.is_ordinal) : α.succ.Aleph.regular :=
begin
  have αord' := succ_ord_of_ord αord,
  rw regular_iff_ne (Aleph_is_card αord') (Aleph_inf αord'),
  rintros S ⟨Sα, αS⟩,
  have h : ∀ (β : Set), β ∈ S → β.card.card_le α.Aleph,
  { intros β βS, rw ←card_not_lt_iff_le (Aleph_is_card αord) card_is_card,
    intros αβ, specialize Sα βS,
    have βα : β.card.card_le α.succ.Aleph.card := card_le_of_ord_mem (card_is_ord (Aleph_is_card αord')) Sα,
    rw card_le_iff at βα, cases βα, rotate,
      rw card_equiv at βα,
      exact (init_iff_card.mpr (Aleph_is_card αord')).right ⟨_, Sα, equin_symm βα⟩,
    rw card_of_cardinal_eq_self (Aleph_is_card αord') at βα,
    apply Aleph_imm αord ⟨_, card_is_card, αβ, βα⟩, },
  replace h := ch6_26 (Aleph_is_card αord) h, apply card_eq_of_le_of_le card_is_card (Aleph_is_card αord'),
    rw ←card_of_cardinal_eq_self (Aleph_is_card αord'), exact card_le_of_subset Sα,
  rw ←card_not_lt_iff_le card_is_card (Aleph_is_card αord'), intro Sα,
  replace Sα := Aleph_le_of_lt_succ αord card_is_card Sα,
  have h₁ : α.succ.Aleph.card_le α.Aleph,
    rw [←card_of_cardinal_eq_self (Aleph_is_card αord'), αS],
    apply card_le_trans (mul_cardinal card_is_card (Aleph_is_card αord)) h,
    nth_rewrite 1 ←mul_infinite_card_eq_self (Aleph_is_card αord) (Aleph_inf αord),
    apply card_mul_le_of_le_left card_is_card (Aleph_is_card αord) Sα (Aleph_is_card αord),
  rw ←card_not_lt_iff_le (Aleph_is_card αord) (Aleph_is_card αord') at h₁,
  exact h₁ (Aleph_lt_of_mem αord' self_mem_succ),
end

lemma cf_le_of {γ : Set} (γord : γ.is_ordinal) {κ : Set} (κcard : κ.is_cardinal)
  {S : Set} (γS : γ.cofinal S) (cardS : S.card.card_le κ) : γ.cf.card_le κ :=
begin
  refine card_le_trans card_is_card _ cardS, rw card_le_iff_le (cf_is_card γord) card_is_card,
  exact cf_least γord γS,
end

lemma cf_pred {p : Set → Prop} {γ : Set} (γord : γ.limit_ord)
  (h : ∀ {S : Set}, γ.cofinal S → p S.card) : p γ.cf :=
begin
  obtain ⟨S, γS, cardS⟩ := cf_limit γord, rw ←cardS, exact h γS,
end

-- Theorem 9N
theorem cf_Aleph_limit {γ : Set} (γord : γ.limit_ord) : γ.Aleph.cf = γ.cf :=
begin
  have Aord : γ.Aleph.is_ordinal := card_is_ord (Aleph_is_card γord.ord),
  apply card_eq_of_le_of_le (cf_is_card Aord) (cf_is_card γord.ord),
  { obtain ⟨S, ⟨Sγ, γS⟩, Scard⟩ := cf_limit γord,
    have sub : repl_img Aleph S ⊆ γ.Aleph, intros A hA,
      rw mem_repl_img at hA, rcases hA with ⟨α, αS, he⟩, subst he,
      rw ←card_lt_iff_mem (Aleph_is_card (ord_of_mem_ord γord.ord (Sγ αS))) (Aleph_is_card γord.ord),
      apply Aleph_lt_of_mem γord.ord (Sγ αS),
    have hc : γ.Aleph = (repl_img Aleph S).Union, rw γS,
      change S.sup.Aleph = (repl_img Aleph S).sup,
      refine sup_norm_fun Aleph_ord_op Aleph_normal _ (λ α αS, ord_of_mem_ord γord.ord (Sγ αS)),
      refine ne_empty_of_inhabited _ (inhab_of_Union_inhab _),
      rw ←γS, exact ⟨_, limit_ord_pos γord⟩,
    apply cf_le_of Aord (cf_is_card γord.ord) ⟨sub, hc⟩,
    rw ←Scard, exact repl_img_card_le, },
  { apply cf_pred (inf_card_is_limit (Aleph_is_card γord.ord) (Aleph_inf γord.ord)),
    rintros A ⟨γA, Aγ⟩,
    let B : Set := {β ∈ γ | ∃ α : Set, α ∈ A ∧ β.Aleph = α.card},
    have Bords : ∀ ⦃β : Set⦄, β ∈ B → β.is_ordinal,
      intros β βB, rw mem_sep at βB, exact ord_of_mem_ord γord.ord βB.left,
    have h : ∀ {α : Set}, α ∈ A → ω ≤ α → ∃ β : Set, β ∈ γ ∧ β.Aleph = α.card,
      intros α αA ωα,
      have γA' := γA αA,
      simp only [Aleph_limit_ord_eq γord, mem_Union, exists_prop, mem_repl_img] at γA',
      rcases γA' with ⟨βA, ⟨β, βγ, he⟩, αβ⟩, subst he,
      have h := Aleph_is_card (ord_of_mem_ord γord.ord βγ),
      replace αβ := card_le_of_ord_mem (card_is_ord h) αβ,
      rw card_of_cardinal_eq_self h at αβ,
      have αinf : ¬ α.card.finite_cardinal, rw [card_finite_iff_finite], intro αfin,
        have αord := ord_of_mem_ord Aord (γA αA),
        rw ord_finite αord at αfin,
        exact ord_mem_irrefl αord (ord_lt_of_lt_of_le αord αfin ωα),
      obtain ⟨δ, δord, αδ⟩ := inf_card_eq_Aleph card_is_card αinf,
      rw [αδ, Aleph_le_of_le δord (ord_of_mem_ord γord.ord βγ)] at αβ,
      exact ⟨_, ord_lt_of_le_of_lt γord.ord αβ βγ, αδ.symm⟩,
    have hzA : Aleph ∅ ∈ A.Union,
      have hoA : one.Aleph ⊆ A.Union, rw [←Aγ, Aleph_limit_ord_eq γord],
        apply subset_Union_of_mem, rw mem_repl_img, refine ⟨_, succ_mem_limit γord (limit_ord_pos γord), rfl⟩,
      apply hoA, rw ←card_lt_iff_mem (Aleph_is_card zero_is_ord) (Aleph_is_card one_is_ord),
      exact Aleph_lt_of_mem one_is_ord zero_lt_one,
    have Bin : B.inhab, rw mem_Union at hzA, rcases hzA with ⟨α, αA, zα⟩,
      rw [Aleph_zero_eq, card_of_cardinal_eq_self omega_is_card] at zα,
      obtain ⟨β, βγ, βα⟩ := h αA (or.inl zα),
      use β, rw mem_sep, exact ⟨βγ, _, αA, βα⟩,
    obtain ⟨C, CB⟩ := Bin,
    have BA : B.card.card_le A.card, rw card_le_iff_equin', apply dominates_of_onto_fun,
      let f : Set := pair_sep_eq A B (λ α, if αA : α ∈ A then if ωα : ω ≤ α then classical.some (h αA ωα) else C else ∅),
      refine ⟨f, pair_sep_eq_is_fun, pair_sep_eq_dom_eq _, pair_sep_eq_ran_eq _⟩,
      { intros α αA, dsimp, rw [dif_pos αA], by_cases ωα : ω ≤ α,
          rw dif_pos ωα, obtain ⟨βγ, βα⟩ := classical.some_spec (h αA ωα),
          rw mem_sep, exact ⟨βγ, _, αA, βα⟩,
        rwa dif_neg ωα, },
      { intros β βB, rw mem_sep at βB, rcases βB with ⟨βγ, α, αA, βα⟩, refine ⟨_, αA, _⟩,
        dsimp, rw dif_pos αA,
        have αord : α.is_ordinal := ord_of_mem_ord (card_is_ord (Aleph_is_card γord.ord)) (γA αA),
        have ωα : ω ≤ α, rw [←ord_not_lt_iff_le αord omega_is_ord, ←ord_finite_iff αord,
          ←card_finite_iff_finite, ←βα], exact Aleph_inf (ord_of_mem_ord γord.ord βγ),
        rw dif_pos ωα, obtain ⟨fαγ, fαα⟩ := classical.some_spec (h αA ωα),
        apply Aleph_oto'' (ord_of_mem_ord γord.ord βγ) (ord_of_mem_ord γord.ord fαγ),
        rw [βα, fαα], },
    refine card_le_trans card_is_card _ BA,
    refine cf_le_of γord.ord card_is_card ⟨sep_subset, _⟩ card_le_refl,
    have h₁ : ∀ {α : Set}, α ∈ A → α.card.card_le B.Union.Aleph.card,
      intros α αA, by_cases ωα : ω ≤ α,
      { obtain ⟨β, βγ, βα⟩ := h αA ωα,
        rw [←βα, ←card_of_cardinal_eq_self (Aleph_is_card (ord_of_mem_ord γord.ord βγ))],
        apply card_le_of_subset,
        have h' : B.Union.Aleph = (repl_img Aleph B).Union,
          refine sup_norm_fun Aleph_ord_op Aleph_normal _ _,
            apply ne_empty_of_inhabited,
            use β, rw mem_sep, exact ⟨βγ, _, αA, βα⟩,
          intros β βB, rw mem_sep at βB, exact ord_of_mem_ord γord.ord βB.left,
        rw h', apply subset_Union_of_mem, rw mem_repl_img, refine ⟨_, _, rfl⟩, rw mem_sep,
        exact ⟨βγ, _, αA, βα⟩, },
      { have hzA : Aleph ∅ ∈ A.Union,
          have hoA : one.Aleph ⊆ A.Union, rw [←Aγ, Aleph_limit_ord_eq γord],
            apply subset_Union_of_mem, rw mem_repl_img, refine ⟨_, succ_mem_limit γord (limit_ord_pos γord), rfl⟩,
          apply hoA, rw ←card_lt_iff_mem (Aleph_is_card zero_is_ord) (Aleph_is_card one_is_ord),
          exact Aleph_lt_of_mem one_is_ord zero_lt_one,
        rw mem_Union at hzA, rcases hzA with ⟨μ, μA, zμ⟩,
        have μB := γA μA, simp only [Aleph_limit_ord_eq γord, mem_Union, exists_prop, mem_repl_img] at μB,
        rcases μB with ⟨e, ⟨β, βγ, he⟩, μβ⟩, subst he,
        have μord : μ.is_ordinal := ord_of_mem_ord (card_is_ord (Aleph_is_card γord.ord)) (γA μA),
        have μinf : ¬ μ.is_finite, rw [ord_finite_iff μord, ord_not_lt_iff_le μord omega_is_ord,
          ←card_of_cardinal_eq_self omega_is_card, ←Aleph_zero_eq], left, exact zμ,
        rw ←card_finite_iff_finite at μinf,
        obtain ⟨δ, δord, μδ⟩ := inf_card_eq_Aleph card_is_card μinf,
        have αord : α.is_ordinal := ord_of_mem_ord (card_is_ord (Aleph_is_card γord.ord)) (γA αA),
        rw ord_not_le_iff_lt omega_is_ord αord at ωα,
        apply card_le_trans (Aleph_is_card zero_is_ord),
          rw Aleph_zero_eq, exact card_le_of_ord_mem omega_is_ord ωα,
        apply card_le_trans (Aleph_is_card δord),
          rw Aleph_le_of_le zero_is_ord δord, exact empty_le_ord δord,
        rw ←card_of_cardinal_eq_self (Aleph_is_card δord), apply card_le_of_subset,
        have βord := ord_of_mem_ord γord.ord βγ,
        have δγ : δ ∈ γ, refine ord_lt_of_le_of_lt γord.ord _ βγ, rw ←Aleph_le_of_le δord βord,
          rw [←μδ, ←card_of_cardinal_eq_self (Aleph_is_card βord)],
          exact card_le_of_ord_mem (card_is_ord (Aleph_is_card βord)) μβ,
        have h' : B.Union.Aleph = (repl_img Aleph B).Union,
          refine sup_norm_fun Aleph_ord_op Aleph_normal _ _,
            apply ne_empty_of_inhabited,
            use δ, rw mem_sep, exact ⟨δγ, _, μA, μδ.symm⟩,
          intros β βB, rw mem_sep at βB, exact ord_of_mem_ord γord.ord βB.left,
        rw h', apply subset_Union_of_mem, rw mem_repl_img, refine ⟨_, _, rfl⟩, rw mem_sep,
        exact ⟨δγ, _, μA, μδ.symm⟩, },
    have γB : γ ≤ B.Union.succ,
      have Asub : A ⊆ B.Union.succ.Aleph, intros α αA,
        have αord : α.is_ordinal := ord_of_mem_ord (card_is_ord (Aleph_is_card γord.ord)) (γA αA),
        rw ←ord_not_le_iff_lt (card_is_ord (Aleph_is_card (succ_ord_of_ord (Union_ords_is_ord Bords)))) αord,
        intro h₂, replace h₂ := card_le_of_ord_le αord h₂,
        suffices h₃ : ¬ B.Union.Aleph.card_lt B.Union.succ.Aleph,
          exact h₃ (Aleph_lt_of_mem (succ_ord_of_ord (Union_ords_is_ord Bords)) self_mem_succ),
        rw [←card_of_cardinal_eq_self (Aleph_is_card (Union_ords_is_ord Bords)),
          ←card_of_cardinal_eq_self (Aleph_is_card (succ_ord_of_ord (Union_ords_is_ord Bords))),
          card_not_lt_iff_le card_is_card card_is_card],
        apply card_le_trans card_is_card h₂ (h₁ αA),
      rw [←Aleph_le_of_le γord.ord (succ_ord_of_ord (Union_ords_is_ord Bords)),
        card_le_iff_le (Aleph_is_card γord.ord) (Aleph_is_card (succ_ord_of_ord (Union_ords_is_ord Bords))),
        ord_le_iff_sub (card_is_ord (Aleph_is_card γord.ord)) (card_is_ord (Aleph_is_card (succ_ord_of_ord (Union_ords_is_ord Bords)))),
        Aγ],
      intro δ, rw [mem_Union], rintro ⟨α, αA, δα⟩,
      exact ord_mem_trans (card_is_ord (Aleph_is_card (succ_ord_of_ord (Union_ords_is_ord Bords)))) δα (Asub αA),
    cases γB, rotate,
      exfalso, exact γord.ns ⟨_, γB⟩,
    rw mem_succ_iff_le at γB, cases γB,
      simp only [mem_Union, exists_prop, mem_sep] at γB, rcases γB with ⟨β, ⟨βγ, -⟩, γβ⟩,
      exfalso, exact no_2_cyle ⟨γβ, βγ⟩,
    assumption, },
end

theorem Aleph_omega_singular : (Aleph ω).singular :=
begin
  dsimp [singular], rw [cf_Aleph_limit omega_limit_ord, cf_omega_eq],
  apply card_lt_of_mem card_is_card (Aleph_is_card omega_is_ord),
  simp only [Aleph_limit_ord_eq omega_limit_ord, ←Aleph_zero_eq, mem_Union, exists_prop, mem_repl_img],
  refine ⟨_, ⟨_, one_nat, rfl⟩, _⟩, rw ←card_lt_iff_mem (Aleph_is_card zero_is_ord) (Aleph_is_card one_is_ord),
  exact Aleph_lt_of_mem one_is_ord zero_lt_one,
end

structure inaccessible (κ : Set) : Prop :=
(a : (Aleph ∅).card_lt κ)
(b : ∀ {μ : Set}, μ.is_cardinal → μ.card_lt κ → (two.card_exp μ).card_lt κ)
(c : κ.regular)

lemma diff_fun {F : Set} (Ffun : F.is_function) {X : Set} : (F \ X).is_function :=
begin
  rw is_function_iff at Ffun ⊢, refine ⟨diff_is_rel Ffun.left, λ x y y' xy xy', _⟩,
  rw mem_diff at xy xy', exact Ffun.right _ _ _ xy.left xy'.left,
end

lemma dom_diff {F X : Set} : (F \ X).dom ⊆ F.dom :=
begin
  intro x, simp only [mem_dom, mem_diff], rintro ⟨y, xy, -⟩, exact ⟨_, xy⟩,
end

lemma ord_of_sub_ord {α : Set} (αord : α.is_ordinal) {β : Set} (βα : β ⊆ α) (βtrans : β.transitive_set) : β.is_ordinal :=
begin
  rw is_ordinal_iff, refine ⟨βtrans, _⟩,
  have h := well_order_struct_restrict (ordinal_well_ordered' αord) βα,
  have h' : α.eps_order ∩ β.prod β = β.eps_order, apply rel_ext (inter_rel_is_rel pair_sep_is_rel) pair_sep_is_rel,
    simp only [pair_mem_pair_sep, mem_inter, pair_mem_prod], intros x y, split,
      rintro ⟨⟨-, -, xy⟩, xβ, yβ⟩, exact ⟨xβ, yβ, xy⟩,
    rintro ⟨xβ, yβ, xy⟩, exact ⟨⟨βα xβ, βα yβ, xy⟩, xβ, yβ⟩,
  rwa [struct_restrict_fld, struct_restrict_rel, eps_order_struct_rel, h'] at h,
end

-- Lemma 9P
lemma exists_sub_ord_seq {f : Set.{u}} (ffun : f.is_function) (fdom : f.dom.is_ordinal)
  (ford : ∀ {δ : Set}, δ ∈ f.ran → δ.is_ordinal) :
  ∃ g : Set, g.is_function ∧ g.dom.is_ordinal ∧ g.dom ≤ f.dom ∧ (∀ {δ : Set}, δ ∈ g.ran → δ.is_ordinal)
  ∧ (∀ {η : Set}, η ∈ g.dom → ∀ {ξ : Set}, ξ ∈ η → g.fun_value ξ ∈ g.fun_value η)
  ∧ g.ran ⊆ f.ran
  ∧ f.ran.Union = g.ran.Union :=
begin
  let P : Set → Set → Prop := λ g γ : Set, γ ∈ f.dom ∧ ∀ {δ : Set}, δ ∈ g.dom → f.fun_value (g.fun_value δ) ∈ f.fun_value γ,
  have h₁ : ∀ {g : Set}, (∃ γ : Set, P g γ) → ∃ γ : Set, γ.is_ordinal ∧ P g γ :=
    λ g ex, exists.elim ex (λ γ h, ⟨_, ord_of_mem_ord fdom h.left, h⟩),
  let F' : Set → Set := λ g, if ex : ∃ γ : Set, P g γ then classical.some (exists_least_ord_of_exists (h₁ ex)) else f.dom,
  let F := trans_rec f.dom f.dom.eps_order F',
  have Ffun : F.is_function := trans_rec_fun (ordinal_well_ordered fdom),
  have Fdom : F.dom = f.dom := trans_rec_dom (ordinal_well_ordered fdom),
  have Fspec : ∀ ⦃β : Set⦄, β ∈ f.dom → F.fun_value β = F' (F.restrict β),
    intros β hβ, nth_rewrite 1 ←seg_ord fdom hβ, exact trans_rec_spec (ordinal_well_ordered fdom) hβ,
  let Q : Set → Set → Prop := λ β γ : Set.{u}, γ ∈ f.dom ∧ ∀ {δ : Set}, δ ∈ β → f.fun_value (F.fun_value δ) ∈ f.fun_value γ,
  have Fval : ∀ {β : Set.{u}}, β ∈ f.dom → ¬ (∃ γ : Set, Q β γ) → F.fun_value β = f.dom,
  { intros β hβ h,
    have h' : ¬ ∃ γ : Set, P (F.restrict β) γ,
      rintro ⟨γ, hγ, h'⟩, refine h ⟨_, hγ, λ δ δβ, _⟩,
      have βf : β ⊆ f.dom, rw ←ord_le_iff_sub (ord_of_mem_ord fdom hβ) fdom, left, exact hβ,
      rw ←Fdom at hγ βf, rw ←restrict_fun_value Ffun βf δβ, rw ←restrict_dom βf at δβ,
      exact h' δβ,
    simp only [Fspec hβ, F', P, dif_neg h'], },
  have Fval' : ∀ {β : Set.{u}}, β ∈ f.dom → (∃ γ : Set, Q β γ) → Q β (F.fun_value β) ∧ ∀ {α : Set}, Q β α → F.fun_value β ≤ α,
  { intros β hβ h,
    have βf : β ⊆ f.dom, rw ←ord_le_iff_sub (ord_of_mem_ord fdom hβ) fdom, left, exact hβ,
    rw ←Fdom at βf,
    have h' : ∃ γ : Set, P (F.restrict β) γ,
      rcases h with ⟨γ, hγ, h'⟩, refine ⟨_, hγ, λ δ δβ, _⟩,
      rw restrict_dom βf at δβ, rw restrict_fun_value Ffun βf δβ,
      exact h' δβ,
    obtain ⟨-, ⟨hP, hP'⟩, hle⟩ := classical.some_spec (exists_least_ord_of_exists (h₁ h')),
    simp only [Fspec hβ, F', dif_pos h'], refine ⟨⟨hP, _⟩, _⟩,
      rw restrict_dom βf at hP', intros δ δβ, rw ←restrict_fun_value Ffun βf δβ, exact hP' δβ,
    rintros α ⟨hα, h⟩, apply hle (ord_of_mem_ord fdom hα), dsimp [P], rw restrict_dom βf, refine ⟨hα, λ δ δβ, _⟩,
    rw restrict_fun_value Ffun βf δβ, exact h δβ, },
  let C : Set := {β ∈ f.dom | ∃ γ : Set, Q β γ},
  let h := F.restrict C,
  have hfun : h.is_function := restrict_is_function Ffun,
  have hdom' : h.dom = C,
    have C' : C = {β ∈ F.dom | ∃ γ : Set, Q β γ}, rw Fdom,
    simp only [h, C', restrict_dom sep_subset],
  have hdom : h.dom ⊆ f.dom,
    rw hdom', exact sep_subset,
  have hspec : ∀ {β : Set}, β ∈ h.dom → h.fun_value β = F.fun_value β,
    intros β hβ, rw [hdom', ←Fdom] at hdom, rw hdom' at hβ, simp only [h, restrict_fun_value Ffun hdom hβ],
  let R : Set → Set → Prop := λ β γ : Set.{u}, γ ∈ f.dom ∧ ∀ {δ : Set}, δ ∈ β → f.fun_value (h.fun_value δ) ∈ f.fun_value γ,
  have h₂ : ∀ {β : Set}, β ∈ h.dom ↔ β ∈ f.dom ∧ ∃ γ : Set, Q β γ,
    intros β, rw [hdom', mem_sep],
  have h₃ : ∀ {β : Set}, β ∈ h.dom → h.fun_value β ∈ f.dom,
    intros β hβ,
    obtain ⟨hβ', ex⟩ := h₂.mp hβ,
    obtain ⟨⟨h₃, -⟩, -⟩ := Fval' hβ' ex,
    rw hspec hβ, exact h₃,
  have h₄ : ∀ {β : Set}, β ∈ h.dom → β ⊆ h.dom,
    intros β hβ δ δβ, rw h₂ at hβ ⊢, rcases hβ with ⟨βf, γ, γf, hγ⟩,
    refine ⟨ord_mem_trans fdom δβ βf, γ, γf, _⟩,
    intros α αδ, exact hγ (ord_mem_trans (ord_of_mem_ord fdom βf) αδ δβ),
  have h₅ : ∀ {β : Set}, β ∈ h.dom → h.fun_value β = F' (h.restrict β),
    intros β hβ, have βord := ord_of_mem_ord fdom (hdom hβ), revert β βord, refine trans_ind_schema _,
    intros β βord ind hβ,
    have h₅ : h.restrict β = F.restrict β, apply fun_ext (restrict_is_function hfun) (restrict_is_function Ffun),
        rw restrict_dom (h₄ hβ), symmetry, apply restrict_dom, rw Fdom, refine subset_trans _ hdom,
        exact h₄ hβ,
      intros δ δβ, rw restrict_dom (h₄ hβ) at δβ, rw [restrict_fun_value hfun (h₄ hβ) δβ, hspec (h₄ hβ δβ)],
      symmetry, refine restrict_fun_value Ffun _ δβ,
      rw Fdom, exact subset_trans (h₄ hβ) hdom,
    rw [hspec hβ, Fspec (hdom hβ), h₅],
  have h₆ : ∀ {β : Set}, β ∈ h.dom → ∃ γ : Set, R β γ,
    intros β hβ,
    have hf := h₂.mp hβ, obtain ⟨βf, γ, γf, hγ⟩ := hf,
    refine ⟨_, γf, λ δ δβ, _⟩, rw hspec (h₄ hβ δβ), exact hγ δβ,
  have h₇ : ∀ {β : Set}, β ∈ h.dom → ∀ {γ : Set}, Q β γ ↔ R β γ,
    intros β hβ γ, dsimp [Q, R], rw and.congr_right_iff, intro γf, apply forall_congr, intro δ,
    apply imp_congr_right, intro δβ, rw hspec (h₄ hβ δβ),
  have h₈ : ∀ {β : Set}, β ∈ h.dom → R β (h.fun_value β) ∧ ∀ {α : Set}, R β α → h.fun_value β ≤ α,
    intros β hβ, simp only [←h₇ hβ, hspec hβ],
    obtain ⟨βf, hβ'⟩ := h₂.mp hβ,
    exact Fval' βf hβ',
  have hord : h.dom.is_ordinal := ord_of_sub_ord fdom hdom (transitive_set_iff'.mpr @h₄),
  let g : Set := f.comp h,
  have gfun := T3H_a ffun hfun,
  have h₉ : h.ran ⊆ f.dom, intro y, rw mem_ran_iff hfun, rintro ⟨β, hβ, he⟩, subst he, exact h₃ hβ,
  have gdom := dom_comp h₉,
  have gdom' : g.dom ≤ f.dom, rw [gdom, ord_le_iff_sub hord fdom], exact hdom,
  have gords : ∀ {δ : Set}, δ ∈ g.ran → δ.is_ordinal := λ δ hδ, ford (ran_comp_sub hδ),
  have gord : g.dom.is_ordinal, rw gdom, exact hord,
  have gval : ∀ {β : Set}, β ∈ g.dom → g.fun_value β = f.fun_value (h.fun_value β),
    intros β hβ, rw T3H_c ffun hfun hβ,
  refine ⟨_, gfun, gord, gdom', @gords, λ η hη, _, _⟩,
    rw gdom at hη, have h := (h₈ hη).left.right,
    rw ←gdom at hη, intros ξ ξη,
    rw [gval hη, gval (ord_mem_trans gord ξη hη)], exact h ξη,
  rw eq_iff_subset_and_subset, refine ⟨ran_comp_sub, _, Union_sub_of_sub ran_comp_sub⟩,
  suffices h₁₀ : ∀ {β : Set}, β ∈ f.dom → ∃ α : Set, α ∈ g.dom ∧ f.fun_value β ≤ g.fun_value α,
    intro δ, simp only [mem_Union, exists_prop, mem_ran_iff ffun],
    rintro ⟨β, ⟨β, hβ, he⟩, δβ⟩, subst he,
    obtain ⟨α, hα, βα⟩ := h₁₀ hβ,
    exact ⟨_, fun_value_def'' gfun hα, ord_lt_of_lt_of_le (gords (fun_value_def'' gfun hα)) δβ βα⟩,
  have h₁₁ : ∀ {ξ : Set}, ξ ∈ h.dom → ∀ {δ : Set}, δ ∈ f.dom → δ ≤ h.fun_value ξ → f.fun_value δ ≤ g.fun_value ξ,
    intros ξ ξh δ δf δξ, rw ←gdom at ξh,
    rw [←ord_not_lt_iff_le (gords (fun_value_def'' gfun ξh)) (ford (fun_value_def'' ffun δf)), gval ξh],
    intro h', suffices δξ' : δ = h.fun_value ξ,
      subst δξ', exact not_mem_self h',
    rw gdom at ξh,
    rw ord_eq_iff_le_and_le (ord_of_mem_ord fdom δf) (ord_of_mem_ord fdom (h₉ (fun_value_def'' hfun ξh))),
    refine ⟨δξ, _⟩, apply (h₈ ξh).right ⟨δf, λ α αξ, _⟩,
    exact ord_mem_trans (ford (fun_value_def'' ffun δf)) ((h₈ ξh).left.right αξ) h',

  have hmon : ∀ {α : Set}, α ∈ h.dom → ∀ {β : Set}, β ∈ α → h.fun_value β ∈ h.fun_value α,
    intros α αh β βα,
    have hαord : (h.fun_value α).is_ordinal := ord_of_mem_ord fdom (h₉ (fun_value_def'' hfun αh)),
    have hβord : (h.fun_value β).is_ordinal := ord_of_mem_ord fdom (h₉ (fun_value_def'' hfun (ord_mem_trans hord βα αh))),
    rw ←ord_not_le_iff_lt hαord hβord, intro αβ, cases αβ,
      refine not_mem_self (ord_lt_of_lt_of_le hαord αβ ((h₈ (ord_mem_trans hord βα αh)).right _)),
      dsimp [R], refine ⟨h₉ (fun_value_def'' hfun αh), λ δ δβ, ord_mem_trans (ford (fun_value_def'' ffun _)) ((h₈ (ord_mem_trans hord βα αh)).left.right δβ) _⟩,
        exact h₉ (fun_value_def'' hfun αh),
      exact (h₈ αh).left.right βα,
    have h' := (h₈ αh).left.right βα,
    rw αβ at h', exact not_mem_self h',
  have h₁₂ : ∀ {ξ : Set}, ξ ∈ h.dom → ξ ≤ h.fun_value ξ,
    intros ξ ξh, have ξord : ξ.is_ordinal := ord_of_mem_ord hord ξh, revert ξ ξord, refine trans_ind_schema _,
    intros ξ ξord ind ξh,
    rw ord_le_iff_sub ξord (ord_of_mem_ord fdom (h₉ (fun_value_def'' hfun ξh))),
    intros β βξ, exact ord_lt_of_le_of_lt (ord_of_mem_ord fdom (h₉ (fun_value_def'' hfun ξh))) (ind βξ (ord_mem_trans hord βξ ξh)) (hmon ξh βξ),
  have h₁₃ : ∀ {ξ : Set}, ξ ∈ g.dom → f.fun_value ξ ≤ g.fun_value ξ,
    intros ξ ξg, rw gdom at ξg, exact h₁₁ ξg (hdom ξg) (h₁₂ ξg),
  have h₁₄ : ∀ {β : Set}, β ∈ f.dom → ∀ {γ : Set}, R β γ → Q β γ,
    rintros β βf γ ⟨γf, h'⟩, refine ⟨γf, λ δ δβ, _⟩,
    by_cases h'' : δ ∈ h.dom,
      rw ←hspec h'', exact h' δβ,
    rw h₂ at h'',
    replace h'' : ¬ ∃ γ : Set, Q δ γ, intro h''', exact h'' ⟨ord_mem_trans fdom δβ βf, h'''⟩,
    rw Fval (ord_mem_trans fdom δβ βf) h'',
    have a_very_interesting_lemma : ∀ {f x : Set}, x ∉ f.dom → f.fun_value x = ∅,
      intros f x xf, rw eq_empty, dsimp [fun_value], intros z hz,
      rw mem_Union at hz, simp only [exists_prop, mem_sep] at hz,
      rcases hz with ⟨y, ⟨yf, xy⟩, zy⟩, apply xf, rw mem_dom, exact ⟨_, xy⟩,
    rw a_very_interesting_lemma not_mem_self,
    exact ord_pos_of_inhab (ford (fun_value_def'' ffun γf)) ⟨_, h' δβ⟩,
  cases gdom',
    suffices h' : ¬ ∃ γ : Set, γ ∈ f.dom ∧ R (g.dom) γ,
      dsimp [R] at h', push_neg at h', intros β βf,
      obtain ⟨δ, δg, h''⟩ := h' _ βf βf, refine ⟨_, δg, _⟩,
      rw ←ord_not_lt_iff_le (gords (fun_value_def'' gfun δg)) (ford (fun_value_def'' ffun βf)),
      rw gval δg, exact h'',
    rintros ⟨γ, γf, hR⟩,
    apply @not_mem_self g.dom, rw [gdom, h₂], rw ←gdom, exact ⟨gdom', _, h₁₄ gdom' hR⟩,
  intros β βf, rw ←gdom' at βf, exact ⟨_, βf, h₁₃ βf⟩,
end

lemma card_ord_le_self {β : Set} (βord : β.is_ordinal) : β.card ≤ β :=
card_least βord equin_refl

lemma cf_limit_inf {γ : Set} (γord : γ.limit_ord) : ¬ γ.cf.finite_cardinal :=
begin
  obtain ⟨S, ⟨Sγ, γS⟩, cardS⟩ := cf_limit γord,
  rw [←cardS, card_finite_iff_finite], apply unbounded_ords_inf γord.ord Sγ,
    apply inhabited_of_ne_empty, intro Se, subst Se, rw Union_empty at γS,
    exact ne_empty_of_inhabited _ (limit_ord_inhab γord) γS,
  refine classical.by_contradiction _, intro h, push_neg at h,
  replace h : ∃ n : Set, n ∈ S ∧ ∀ {m : Set}, m ∈ S → m ≤ n,
    rcases h with ⟨n, nS, h⟩, refine ⟨_, nS, λ m mS, _⟩,
    rw ←ord_not_lt_iff_le (ord_of_mem_ord γord.ord (Sγ nS)) (ord_of_mem_ord γord.ord (Sγ mS)),
    exact h _ mS,
  apply @not_mem_self γ, nth_rewrite 0 γS, apply Sγ,
  exact (case_exists_bound (λ x xS, ord_of_mem_ord γord.ord (Sγ xS)) h).left,
end

lemma cf_le_self {γ : Set} (γord : γ.is_ordinal) : γ.cf ≤ γ :=
ord_le_trans γord (cf_ord_le_card γord) (card_ord_le_self γord)

theorem T9Q {γ : Set} (γord : γ.limit_ord) :
  ∃ f : Set, f.into_fun γ.cf γ
  ∧ (∀ {η : Set}, η ∈ f.dom → ∀ {ξ : Set}, ξ ∈ η → f.fun_value ξ ∈ f.fun_value η)
  ∧ f.ran.Union = γ :=
begin
  have h : ∃ f : Set, f.into_fun γ.cf γ ∧ γ = f.ran.Union,
    obtain ⟨S, ⟨Sγ, γS⟩, cardS⟩ := cf_limit γord,
    rw [←card_of_cardinal_eq_self (cf_is_card γord.ord), card_equiv] at cardS,
    replace cardS := equin_symm cardS, obtain ⟨F, Fonto, Foto⟩ := cardS,
    refine ⟨_, comp_into_fun (into_of_onto Fonto) (into_of_into_ran_sub Sγ id_into), _⟩,
    suffices h : (S.id.comp F).ran = S, rwa h,
    nth_rewrite 1 ←(@id_onto S).right.right, apply ran_comp,
    rw [id_onto.right.left, Fonto.right.right], exact subset_self,
  obtain ⟨f, finto, fran⟩ := h,
  have fdom : f.dom.is_ordinal, rw finto.right.left, exact card_is_ord (cf_is_card γord.ord),
  have ford : ∀ ⦃δ : Set⦄, δ ∈ f.ran → δ.is_ordinal, intros δ δf,
    exact ord_of_mem_ord γord.ord (finto.right.right δf),
  obtain ⟨g, gfun, gord, gdom, gords, inc, gran, h⟩ := exists_sub_ord_seq finto.left fdom ford,
  rw ←fran at h,
  have gran' : g.ran ⊆ γ := subset_trans gran finto.right.right,
  have gdom' : g.dom = γ.cf, rw finto.right.left at gdom,
    rw ord_eq_iff_le_and_le gord (card_is_ord (cf_is_card γord.ord)),
    refine ⟨gdom, ord_le_trans gord (cf_limit_least γord ⟨gran', h⟩) _⟩,
    have h' : g.ran.card = g.dom.card, rw card_equiv, apply equin_symm, refine ⟨_, ⟨gfun, rfl, rfl⟩, one_to_one_of gfun (λ m hm n hn mn gmn, _)⟩,
      cases ord_conn (ord_of_mem_ord gord hm) (ord_of_mem_ord gord hn) mn with mln nlm,
        specialize inc hn mln, rw gmn at inc, exact not_mem_self inc,
      specialize inc hm nlm, rw gmn at inc, exact not_mem_self inc,
    rw h', exact card_ord_le_self gord,
  exact ⟨_, ⟨gfun, gdom', gran'⟩, @inc, h.symm⟩,
end

theorem C9R {γ : Set} (γord : γ.limit_ord) {α : Set} (αord : α.is_ordinal)
  {f : Set} (finto : f.into_fun α γ)
  (inc : ∀ {η : Set}, η ∈ f.dom → ∀ {ξ : Set}, ξ ∈ η → f.fun_value ξ ∈ f.fun_value η)
  (conv : f.ran.Union = γ) : γ.cf ≤ α :=
begin
  apply ord_le_trans αord (cf_limit_least γord ⟨finto.right.right, conv.symm⟩),
  have ford : f.dom.is_ordinal, rwa finto.right.left,
  have h : f.ran.card = f.dom.card, rw card_equiv, apply equin_symm, refine ⟨_, ⟨finto.left, rfl, rfl⟩, one_to_one_of finto.left (λ m hm n hn mn gmn, _)⟩,
    cases ord_conn (ord_of_mem_ord ford hm) (ord_of_mem_ord ford hn) mn with mln nlm,
      specialize inc hn mln, rw gmn at inc, exact not_mem_self inc,
    specialize inc hm nlm, rw gmn at inc, exact not_mem_self inc,
  rw [h, finto.right.left], exact card_ord_le_self αord,
end

-- Theorem 9S
theorem cf_ord_regular {γ : Set} (γord : γ.is_ordinal) : γ.cf.regular :=
begin
  rcases ord_cases γord with (γz|(⟨β, γβ⟩|γord')),
  { subst γz, rw cf_zero, exact cf_zero, },
  { subst γβ, rw cf_succ, exact cf_succ, },
  { rw regular_iff_ne (cf_is_card γord) (cf_limit_inf γord'),
    rintros S ⟨γS, Sγ⟩,
    suffices h : γ.cf.card_le S.card,
      refine card_eq_of_le_of_le card_is_card (cf_is_card γord) _ h,
      rw ←card_of_cardinal_eq_self (cf_is_card γord), exact card_le_of_subset γS,
    obtain ⟨f, finto, inc, fran⟩ := T9Q γord',
    have ford : f.dom.is_ordinal, rw finto.right.left, exact card_is_ord (cf_is_card γord),
    let g := f.restrict S,
    have hS : S ⊆ f.dom, rwa finto.right.left,
    have gonto : g.onto_fun S (f.img S) := ⟨restrict_is_function finto.left, restrict_dom hS, restrict_ran⟩,
    have gval : ∀ {β : Set}, β ∈ g.dom → g.fun_value β = f.fun_value β,
      intros β hβ, have hβ' : β ∈ S, rwa ←gonto.right.left, exact restrict_fun_value finto.left hS hβ',
    have gdom : g.dom ⊆ f.dom, rw gonto.right.left, exact hS,
    have h : S.card = (f.img S).card, rw card_equiv, refine ⟨_, gonto, one_to_one_of (restrict_is_function finto.left) (λ m hm n hn mn gmn, _)⟩,
      rw [gval hm, gval hn] at gmn,
      cases ord_conn (ord_of_mem_ord ford (gdom hm)) (ord_of_mem_ord ford (gdom hn)) mn with mln nlm,
        specialize inc (gdom hn) mln, rw gmn at inc, exact not_mem_self inc,
      specialize inc (gdom hm) nlm, rw gmn at inc, exact not_mem_self inc,
    rw [h, card_le_iff_le (cf_is_card γord) card_is_card],
    refine cf_limit_least γord' ⟨subset_trans img_subset_ran finto.right.right, _⟩,
    rw eq_iff_subset_and_subset, split,
    { intros α αγ, simp only [←fran, mem_Union, exists_prop, mem_ran_iff finto.left] at αγ,
      rcases αγ with ⟨fβ, ⟨β, βf, fβfβ⟩, αfβ⟩, subst fβfβ,
      rw [finto.right.left, Sγ, mem_Union] at βf, rcases βf with ⟨δ, δS, βδ⟩,
      rw mem_Union, refine ⟨_, fun_value_mem_img finto.left hS δS, ord_mem_trans _ αfβ (inc (hS δS) βδ)⟩,
      exact ord_of_mem_ord γord (finto.right.right (fun_value_def'' finto.left (hS δS))), },
    { exact Union_sub (λ y hy β βy, ord_mem_trans γord βy (subset_trans img_subset_ran finto.right.right hy)), }, },
end

-- Theorem 9T
theorem cf_inf_card {γ : Set} (γcard : γ.is_cardinal) (γinf : ¬ γ.finite_cardinal) :
  ∃ S : Set, (∀ {x : Set}, x ∈ S → x.card.card_lt γ) ∧ γ = S.Union ∧ S.card = γ.cf :=
begin
  obtain ⟨S, ⟨Sγ, γS⟩, cardS⟩ := cf_limit (inf_card_is_limit γcard γinf),
  refine ⟨_, λ α αS, card_lt_of_mem card_is_card γcard (ord_lt_of_le_of_lt (card_is_ord γcard) _ (Sγ αS)), γS, cardS⟩,
  exact card_ord_le_self (ord_of_mem_ord (card_is_ord γcard) (Sγ αS)),
end

theorem cf_inf_card_least {γ : Set} (γcard : γ.is_cardinal) (γinf : ¬ γ.finite_cardinal)
  {S : Set} (hS : ∀ {x : Set}, x ∈ S → x.card.card_lt γ) (un : γ = S.Union) : γ.cf.card_le S.card :=
begin
  let μ := (repl_img card S).Union,
  have hμ : μ.is_cardinal, apply Union_card_is_card,
    apply of_repl_img, intros α αS, exact card_is_card,
  have h : ∀ ⦃α : Set⦄, α ∈ S → α.card.card_le μ,
    intros α αS, rw [←card_of_cardinal_eq_self hμ, ←@card_of_cardinal_eq_self α.card card_is_card],
    apply card_le_of_subset, intros β βα, simp only [mem_Union, exists_prop, mem_repl_img],
    exact ⟨_, ⟨_, αS, rfl⟩, βα⟩,
  have hγ : γ.card_le (S.card.card_mul μ),
    rw [←card_of_cardinal_eq_self γcard, un], exact ch6_26 hμ h,
  by_cases hc : γ.card_le S.card,
    refine card_le_trans γcard _ hc,
    rw card_le_iff_le (cf_is_card (card_is_ord γcard)) γcard, exact cf_card γcard,
  rw card_not_le_iff_lt γcard card_is_card at hc,
  have γμ : γ = μ,
  { have μγ : μ.card_le γ, rw [←card_of_cardinal_eq_self hμ, ←card_of_cardinal_eq_self γcard],
      apply card_le_of_subset, intros α, simp only [mem_Union, exists_prop, mem_repl_img],
      rintro ⟨z, ⟨x, xS, zx⟩, αx⟩, subst zx, apply ord_mem_trans (card_is_ord γcard) αx,
      rw ←card_lt_iff_mem card_is_card γcard, exact hS xS,
    rw card_le_iff at μγ, cases μγ, rotate,
      exact μγ.symm,
    exfalso, suffices h : γ.card_lt γ, from h.right rfl,
    nth_rewrite 1 ←mul_infinite_card_eq_self γcard γinf,
    apply card_lt_of_le_of_lt γcard (mul_cardinal (@card_is_card S) hμ) hγ,
    exact card_mul_lt_of_lt_of_lt γcard card_is_card hc hμ μγ, },
  refine card_le_trans (@card_is_card (repl_img card S)) _ repl_img_card_le,
  rw card_le_iff_le (cf_is_card (card_is_ord γcard)) card_is_card,
  apply cf_limit_least (inf_card_is_limit γcard γinf) ⟨_, γμ⟩,
  intro z, rw mem_repl_img, rintro ⟨x, xS, zx⟩, subst zx,
  rw ←card_lt_iff_mem card_is_card γcard, exact hS xS,
end

-- skipped Konig's theorem and the rest because I'm now completely lost

end Set


example (x : α × β) : x = (x.1, x.2) :=
  rfl -- Should work with eta for structures

example (x : Unit) : x = ⟨⟩ :=
  rfl -- Should work with eta for structures

structure Equiv (α : Sort u) (β : Sort v) where
  toFun    : α → β
  invFun   : β → α
  left_inv  : ∀ x, invFun (toFun x) = x
  right_inv : ∀ x, toFun (invFun x) = x

infix:50 "≃" => Equiv

def Equiv.symm (e : α ≃ β) : β ≃ α :=
  { toFun     := e.invFun
    invFun    := e.toFun
    left_inv  := e.right_inv
    right_inv := e.left_inv }

theorem Equiv.symm.symm (e : α ≃ β) : e.symm.symm = e :=
  rfl -- Should work with eta for structures

structure Bla where
  x : Nat

def Bla.toNat (b : Bla) : Nat := b.x
def Nat.toBla (x : Nat) : Bla := { x }

example (b : Bla) : b.toNat.toBla = b :=
  rfl -- Should work with eta for structures

example (b : Bla) : b.toNat.toBla = b := by
  cases b
  rfl

example (x : Unit × α) : x = ((), x.2) := rfl

example (x : (_ : True ∨ False) ×' α) : x = ⟨Or.inl ⟨⟩, x.2⟩ := rfl

example (p : α × α → Prop) (h : ∀ x y, p (x, y)) : p z := h z.1 _

class TopologicalSpace (α : Type)

structure Homeomorph (α β : Type) [TopologicalSpace α] [TopologicalSpace β] extends Equiv α β where
  continuousToFun : True
  continuousInv : True

def Homeomorph.symm [TopologicalSpace α] [TopologicalSpace β] (f : Homeomorph α β) : Homeomorph β α where
  toFun           := f.invFun
  invFun          := f.toFun
  left_inv        := sorry
  right_inv       := sorry
  continuousToFun := f.continuousInv
  continuousInv   := sorry

example [TopologicalSpace α] [TopologicalSpace β] (f : Homeomorph α β) :
  f.symm.symm = f := rfl -- fails

def frob : Nat × Nat → Nat × Nat
  | (x, y) => (x + y, 42)

example (x : Nat × Nat) : (frob x).2 = 42 := rfl

example (x y : Unit) : x = y := rfl

opaque f : Nat → Unit
opaque g : Nat → Unit

example (x y : Nat) : f x = f y := rfl

example (x y : Nat) : f x = g y := rfl


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import tactic
import order.hom.basic
import data.set.lattice

universes u v

variables {α : Type u} {β : Type v}

namespace my

section
variables [partial_order α]

@[ext] class has_supremum (S : set α) :=
(supremum : α)
(upper_bound : ∀ x ∈ S, x ≤ supremum)
(least_upper_bound : ∀ (y : α), (∀ x ∈ S, x ≤ y) → supremum ≤ y)

def _root_.set.supremum (S : set α) [has_supremum S] : α :=
has_supremum.supremum S

lemma le_supremum (S : set α) [has_supremum S] {x : α} (hx : x ∈ S) : x ≤ S.supremum :=
has_supremum.upper_bound _ hx

lemma supremum_le (S : set α) [has_supremum S] {y : α} (hy : ∀ x ∈ S, x ≤ y) : S.supremum ≤ y :=
has_supremum.least_upper_bound _ hy

instance (S : set α) : subsingleton (has_supremum S) :=
⟨λ s₁ s₂, has_supremum.ext _ _ (le_antisymm
  (@has_supremum.least_upper_bound _ _ _ s₁ _ $ @has_supremum.upper_bound _ _ _ s₂)
  (@has_supremum.least_upper_bound _ _ _ s₂ _ $ @has_supremum.upper_bound _ _ _ s₁))⟩

end

class complete_partial_order (α : Type u) extends partial_order α :=
(has_supremum : ∀ (S : set α), has_supremum S)

instance complete_partial_order_has_supremum [complete_partial_order α] (S : set α) : has_supremum S :=
complete_partial_order.has_supremum _

instance : complete_partial_order (set α) :=
{ has_supremum := λ S,
  { supremum := ⋃₀ S,
    upper_bound := λ T, set.subset_sUnion_of_mem,
    least_upper_bound := λ T hT x ⟨y, ⟨hy, hy'⟩⟩, hT _ hy hy' },
  ..(infer_instance : partial_order (set α)) }

theorem knaster_tarski [complete_partial_order α] (f : α → α) (hf : monotone f) : ∃ x, f x = x :=
let s := {x | x ≤ f x}.supremum in
have s ≤ f s, from supremum_le _ $ λ x hx, le_trans hx $ hf $ le_supremum _ hx,
⟨s, le_antisymm (le_supremum _ $ hf this) this⟩

theorem cantor_schroeder_bernstein (f : α → β) (hf : function.injective f) (g : β → α) (hg : function.injective g) :
  nonempty (α ≃ β) :=
begin
  by_cases hβ : nonempty β,
  { haveI hα : nonempty α := nonempty.map g hβ,
    have h : monotone (compl ∘ set.image g ∘ compl ∘ set.image f),
    { exact (compl_antitone _).comp (set.monotone_image.comp_antitone ((compl_antitone _).comp_monotone set.monotone_image)) },
    obtain ⟨P, hP : (g '' (f '' P)ᶜ)ᶜ = P⟩ := knaster_tarski _ h,
    classical,
    refine ⟨equiv.of_bijective (P.piecewise f (function.inv_fun g)) ⟨λ x y hxy, _, _⟩⟩,
    { by_cases hx : x ∈ P,
      { rw [set.piecewise_eq_of_mem _ _ _ hx] at hxy,
        have : y ∈ P,
        { rw [←hP],
          rintro ⟨z, ⟨hz, rfl⟩⟩,
          refine hz ⟨x, ⟨hx, _⟩⟩,
          have : g z ∉ P,
          { rw [←hP, set.mem_compl_iff, not_not],
            exact set.mem_image_of_mem _ hz },
          rw [hxy, set.piecewise_eq_of_not_mem _ _ _ this, function.left_inverse_inv_fun hg] },
        rw [set.piecewise_eq_of_mem _ _ _ this] at hxy,
        exact hf hxy },
      { rw [set.piecewise_eq_of_not_mem _ _ _ hx] at hxy,
        rw [←hP, set.mem_compl_iff, not_not] at hx,
        rcases hx with ⟨z, ⟨hz, rfl⟩⟩,
        rw [function.left_inverse_inv_fun hg] at hxy,
        have hyP : y ∉ P,
        { refine λ hy, hz ⟨y, ⟨hy, _⟩⟩,
          rw [hxy, set.piecewise_eq_of_mem _ _ _ hy] },
        have := hyP,
        rw [←hP, set.mem_compl_iff, not_not] at this,
        rcases this with ⟨w, ⟨hw, rfl⟩⟩,
        rw [hxy, set.piecewise_eq_of_not_mem _ _ _ hyP, function.left_inverse_inv_fun hg] } },
    { simp only [←set.range_iff_surjective, set.range_piecewise, set.eq_univ_iff_forall, set.mem_union, or_iff_not_imp_left],
      refine λ x hx, ⟨g x, ⟨_, function.left_inverse_inv_fun hg _⟩⟩,
      rw [←hP, compl_compl],
      exact set.mem_image_of_mem _ hx } },
  { haveI := not_nonempty_iff.1 hβ,
    refine ⟨⟨f, g, λ x, false.elim (is_empty.false (f x)), λ x, false.elim (is_empty.false x)⟩⟩ }
end

end my


import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Data.String.Defs
import Mathlib.Data.String.Lemmas
import Mathlib.Data.Equiv.Basic
import Timelib.Util
import Timelib.NanoPrecision.Duration.SignedDuration
import Timelib.NanoPrecision.Duration.UnsignedDuration
import Timelib.NanoPrecision.DateTime.NaiveDateTime
import Timelib.NanoPrecision.DateTime.DateTime
import Timelib.NanoPrecision.TimeZone.Basic

structure HDateTime where
  offset : Offset
  dateTime : DateTime offset

def HDateTime.EquivSigma : Equiv HDateTime (Sigma DateTime) := {
  toFun := fun dt => ⟨dt.offset, dt.dateTime⟩
  invFun := fun sig => ⟨sig.fst, sig.snd⟩
  left_inv := by simp [Function.LeftInverse]
  right_inv := by simp [Function.RightInverse, Function.LeftInverse]
}

section HDateTimeStuff

variable (t : HDateTime)

/- Show that this is an equivalence relation -/
@[reducible]
def HDateTime.simultaneous : HDateTime → HDateTime → Prop
| ⟨_, ⟨naive_dt₁⟩⟩, ⟨_, ⟨naive_dt₂⟩⟩ => naive_dt₁ = naive_dt₂

def HDateTime.simultaneous.equivalence : Equivalence HDateTime.simultaneous :=  {
  refl := fun d => rfl
  symm := fun h => h.symm
  trans := fun h h' => Eq.trans h h'
}

instance instHDateTimeSetoid : Setoid HDateTime :=
  ⟨HDateTime.simultaneous, HDateTime.simultaneous.equivalence⟩

/--
LT compares the underlying naive DateTime.
-/
instance : LT HDateTime where
  lt := InvImage instLTNaiveDateTime.lt (fun t => t.dateTime.naive)

/--
LE compares the underlying naive DateTime
-/
instance : LE HDateTime where
  le := InvImage instLENaiveDateTime.le (fun t => t.dateTime.naive)

@[simp] theorem HDateTime.le_def (d₁ d₂ : HDateTime) : (d₁ <= d₂) = (d₁.dateTime.naive <= d₂.dateTime.naive) := rfl
@[simp] theorem HDateTime.lt_def (d₁ d₂ : HDateTime) : (d₁ < d₂) = (d₁.dateTime.naive < d₂.dateTime.naive) := rfl

instance instDecidableLTHDateTime (a b : HDateTime) : Decidable (a < b) := inferInstanceAs (Decidable (a.dateTime.naive < b.dateTime.naive))
instance instDecidableLEHDateTime (a b : HDateTime) : Decidable (a <= b) := inferInstanceAs (Decidable (a.dateTime.naive <= b.dateTime.naive))

/--
HDateTime is only a Preorder since it does not respect antisymmetry.
t₁ <= t₂ ∧ t₂ <= t₁ does not imply t₁ = t₂ since they may have different offets/timezones.
-/
instance : Preorder HDateTime where
  le_refl (a) := le_refl a.dateTime.naive
  le_trans (a b c) := Int.le_trans
  lt_iff_le_not_le (a b) := Int.lt_iff_le_not_le

instance : HAdd HDateTime SignedDuration HDateTime where
  hAdd da du := ⟨da.offset, da.dateTime + du⟩

instance : HAdd SignedDuration HDateTime HDateTime  where
  hAdd du da := da + du

theorem HDateTime.hAdd_def (d : HDateTime) (dur : SignedDuration) : d + dur = ⟨d.offset, d.dateTime  + dur⟩ := rfl

instance : HSub HDateTime SignedDuration HDateTime where
  hSub da du := ⟨da.offset, da.dateTime + -du⟩

theorem HDateTime.hSub_def (d : HDateTime) (dur : SignedDuration) : d - dur = ⟨d.offset, d.dateTime + -dur⟩ := rfl

instance : HAdd HDateTime UnsignedDuration HDateTime where
  hAdd da du := ⟨da.offset, da.dateTime + du⟩

instance : HAdd UnsignedDuration HDateTime HDateTime  where
  hAdd du da := da + du

theorem HDateTime.hAdd_def_unsigned (d : HDateTime) (dur : UnsignedDuration) : d + dur = ⟨d.offset, d.dateTime + dur⟩ := rfl

instance : HSub HDateTime UnsignedDuration HDateTime where
  hSub da du := ⟨da.offset, da.dateTime - du⟩

theorem HDateTime.hSub_def_unsigned (d : HDateTime) (dur : UnsignedDuration) : d - dur = ⟨d.offset, d.dateTime - dur⟩ := rfl


import for_mathlib.derived.defs
import for_mathlib.homology_map
import for_mathlib.has_homology

noncomputable theory

open category_theory opposite
open homotopy_category

variables {𝓐 : Type*} [category 𝓐] [abelian 𝓐]
variables {ι : Type*} {c : complex_shape ι}

def commsq.op {A B C D : 𝓐} {a : A ⟶ B} {b : B ⟶ D} {a' : A ⟶ C} {c : C ⟶ D}
  (sq : commsq a a' b c) :
  commsq c.op b.op a'.op a.op :=
begin
  apply commsq.of_eq,
  simp only [← op_comp, sq.w]
end

lemma homology_map_homology_op_iso {A₁ B₁ C₁ A₂ B₂ C₂ : 𝓐}
  (f₁ : A₁ ⟶ B₁) (g₁ : B₁ ⟶ C₁) (w₁ : f₁ ≫ g₁ = 0)
  (f₂ : A₂ ⟶ B₂) (g₂ : B₂ ⟶ C₂) (w₂ : f₂ ≫ g₂ = 0)
  (a : A₁ ⟶ A₂) (b : B₁ ⟶ B₂) (c : C₁ ⟶ C₂)
  (sq1 : commsq f₁ a b f₂) (sq2 : commsq g₁ b c g₂) :
  homology.map' _ _ sq2.op sq1.op ≫ (has_homology.homology_op_iso f₁ g₁ w₁).hom =
  (has_homology.homology_op_iso _ _ _).hom ≫ (homology.map' w₁ w₂ sq1 sq2).op :=
begin
  suffices : (homology.map' w₁ w₂ sq1 sq2).op =
    (homology.has _ _ _).op.map (homology.has _ _ _).op sq2.op sq1.op,
  { erw [this, has_homology.map_comp_map, has_homology.map_comp_map],
    apply (homology.has _ _ _).ext_π,
    apply (homology.has _ _ _).op.ext_ι,
    simp only [has_homology.π_map, has_homology.lift_comp_ι, iso.refl_hom],
    erw [has_homology.lift_comp_ι],
    congr' 2, rw [category.id_comp, category.comp_id], },
  apply (homology.has _ _ _).op.ext_π,
  apply (homology.has _ _ _).op.ext_ι,
  simp only [has_homology.π_map, has_homology.lift_comp_ι],
  dsimp only [has_homology.op, kernel_op_op_hom, cokernel_op_op_inv],
  simp only [← op_comp, homology.map', category.assoc, has_homology.π_map_assoc,
    has_homology.lift_comp_ι_assoc, limits.kernel.lift_ι_assoc, limits.cokernel.π_desc],
  simp only [op_comp, category.assoc],
  refl,
end

lemma is_quasi_iso_of_op {X Y : (chain_complex 𝓐 ℤ)ᵒᵖ} (f : X ⟶ Y)
  (h : is_quasi_iso ((quotient _ _).map (homological_complex.op_functor.map f))) :
  is_quasi_iso ((quotient _ _).map f.unop) :=
begin
  refine ⟨λ i, _⟩,
  obtain ⟨i, rfl⟩ : ∃ j, j+1=i := ⟨i-1, sub_add_cancel _ _⟩,
  rw [← homotopy_category.homology_functor_map_factors, homology_iso_map (i+1+1) (i+1) i],
  swap, {dsimp, refl}, swap, {dsimp, refl},
  apply_with is_iso.comp_is_iso {instances:=ff}, { apply_instance },
  apply_with is_iso.comp_is_iso {instances:=ff}, swap, { apply_instance },
  have aux := @is_quasi_iso.cond _ _ _ _ _ _ _ _ h (i+1),
  rw [← homotopy_category.homology_functor_map_factors, homology_iso_map i (i+1) (i+1+1)] at aux,
  swap, {dsimp, refl}, swap, {dsimp, refl},
  replace aux := @is_iso.of_is_iso_comp_left _ _ _ _ _ _ _ _ aux,
  replace aux := @is_iso.of_is_iso_comp_right _ _ _ _ _ _ _ _ aux,
  rw [← is_iso_op_iff],
  refine is_iso_of_square _ (has_homology.homology_op_iso _ _ _).hom (has_homology.homology_op_iso _ _ _).hom  _ _ aux _ _,
  swap, { apply_instance }, swap, { apply_instance },
  rw [homology.map_eq, homology.map_eq, ← homology_map_homology_op_iso],
  congr' 2,
end


import data.pfun
import plain_tree
import succ_graphs

inductive code
| left : code
| right : code
| nil : code
| id : code
| node : code → code → code
| comp : code → code → code
| case : code → code → code
| fix : code → code

@[simp] def code.eval : code → ptree →. ptree
| code.left := λ t, part.some t.left
| code.right := λ t, part.some t.right
| code.nil := λ _, part.some ptree.nil
| code.id := λ t, part.some t
| (code.node l r) := λ t, do x ← l.eval t, y ← r.eval t, part.some (ptree.node x y)
| (code.comp f g) := λ t, g.eval t >>= f.eval
| (code.case f g) := λ t, if t.left = ptree.nil then f.eval t.right else g.eval t.right
| (code.fix f) := λ x₀, execution.eval ⟨λ x, if x.left = ptree.nil then part.some none else (f.eval x).map some, x₀⟩

def code.fix_iterator (f : code) (x₀ : ptree) : execution ptree :=
⟨λ x, if x.left = ptree.nil then part.some none else (f.eval x).map some, x₀⟩

lemma code.eval_fix (f : code) (x : ptree) : f.fix.eval x = (f.fix_iterator x).eval := rfl
@[simp] lemma code.none_mem_eval_fix {f : code} {x x₀ : ptree} :
  none ∈ (f.fix_iterator x₀).next x ↔ x.left = ptree.nil :=
by { simp only [code.fix_iterator], split_ifs; simpa, }

@[simp] lemma code.some_mem_eval_fix {f : code} {x x₀ x' : ptree} :
  some x' ∈ (f.fix_iterator x₀).next x ↔ x.left ≠ ptree.nil ∧ x' ∈ f.eval x :=
by { simp only [code.fix_iterator], split_ifs; simp; tauto, }

@[simp] lemma code.fix_iterator_start (f : code) (x₀ : ptree) :
  (f.fix_iterator x₀).start = x₀ := rfl

local infixr `∘`:90 := code.comp

protected def code.const : ptree → code
| ptree.nil := code.nil
| (ptree.node l r) := code.node (code.const l) (code.const r)

@[simp] lemma const_eval (t : ptree) : (code.const t).eval = λ _, t :=
by { ext : 1, induction t with l r ihl ihr, { simp [code.const], }, simp [code.const, ihl, ihr], }

protected def code.ite (cond : code) (t : code) (f : code) : code :=
(code.case t f) ∘ (code.node cond code.id)

@[simp] lemma ite_eval (cond : code) (t : code) (f : code) (v : ptree) :
  (code.ite cond t f).eval v = (cond.eval v) >>= λ v', if v' = ptree.nil then t.eval v else f.eval v :=
begin
  simp only [code.ite, code.eval],
  by_cases h : cond.eval v = part.none, { rw h, simp, },
  simp only [part.eq_none_iff, not_forall, not_not] at h,
  rcases h with ⟨x, h⟩, rw ← part.eq_some_iff at h, rw h,
  simp,
end


/-
Copyright (c) 2021 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import data.set.pairwise

/-!
# Antichains

This file defines antichains. An antichain is a set where any two distinct elements are not related.
If the relation is `(≤)`, this corresponds to incomparability and usual order antichains. If the
relation is `G.adj` for `G : simple_graph α`, this corresponds to independent sets of `G`.

## Definitions

* `is_antichain r s`: Any two elements of `s : set α` are unrelated by `r : α → α → Prop`.
* `is_strong_antichain r s`: Any two elements of `s : set α` are not related by `r : α → α → Prop`
  to a common element.
* `is_antichain.mk r s`: Turns `s` into an antichain by keeping only the "maximal" elements.
-/

open function set

variables {α β : Type*} {r r₁ r₂ : α → α → Prop} {r' : β → β → Prop} {s t : set α} {a : α}

protected lemma symmetric.compl (h : symmetric r) : symmetric rᶜ := λ x y hr hr', hr $ h hr'

/-- An antichain is a set such that no two distinct elements are related. -/
def is_antichain (r : α → α → Prop) (s : set α) : Prop := s.pairwise rᶜ

namespace is_antichain

protected lemma subset (hs : is_antichain r s) (h : t ⊆ s) : is_antichain r t := hs.mono h

lemma mono (hs : is_antichain r₁ s) (h : r₂ ≤ r₁) : is_antichain r₂ s := hs.mono' $ compl_le_compl h

protected lemma eq (hs : is_antichain r s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) (h : r a b) :
  a = b :=
hs.eq ha hb $ not_not_intro h

protected lemma eq' (hs : is_antichain r s) {a b : α} (ha : a ∈ s) (hb : b ∈ s) (h : r b a) :
  a = b :=
(hs.eq hb ha h).symm

protected lemma is_antisymm (h : is_antichain r univ) : is_antisymm α r :=
⟨λ a b ha _, h.eq trivial trivial ha⟩

protected lemma subsingleton [is_trichotomous α r] (h : is_antichain r s) : s.subsingleton :=
begin
  rintro a ha b hb,
  obtain hab | hab | hab := trichotomous_of r a b,
  { exact h.eq ha hb hab },
  { exact hab },
  { exact h.eq' ha hb hab }
end

protected lemma flip (hs : is_antichain r s) : is_antichain (flip r) s :=
λ a ha b hb h, hs hb ha h.symm

lemma swap (hs : is_antichain r s) : is_antichain (swap r) s := hs.flip

lemma image (hs : is_antichain r s) (f : α → β) (h : ∀ ⦃a b⦄, r' (f a) (f b) → r a b) :
  is_antichain r' (f '' s) :=
begin
  rintro _ ⟨b, hb, rfl⟩ _ ⟨c, hc, rfl⟩ hbc hr,
  exact hs hb hc (ne_of_apply_ne _ hbc) (h hr),
end

lemma preimage (hs : is_antichain r s) {f : β → α} (hf : injective f)
  (h : ∀ ⦃a b⦄, r' a b → r (f a) (f b)) :
  is_antichain r' (f ⁻¹' s) :=
λ b hb c hc hbc hr, hs hb hc (hf.ne hbc) $ h hr

lemma _root_.is_antichain_insert :
  is_antichain r (insert a s) ↔ is_antichain r s ∧ ∀ ⦃b⦄, b ∈ s → a ≠ b → ¬ r a b ∧ ¬ r b a :=
set.pairwise_insert

protected lemma insert (hs : is_antichain r s) (hl : ∀ ⦃b⦄, b ∈ s → a ≠ b → ¬ r b a)
  (hr : ∀ ⦃b⦄, b ∈ s → a ≠ b → ¬ r a b) :
  is_antichain r (insert a s) :=
is_antichain_insert.2 ⟨hs, λ b hb hab, ⟨hr hb hab, hl hb hab⟩⟩

lemma _root_.is_antichain_insert_of_symmetric (hr : symmetric r) :
  is_antichain r (insert a s) ↔ is_antichain r s ∧ ∀ ⦃b⦄, b ∈ s → a ≠ b → ¬ r a b :=
pairwise_insert_of_symmetric hr.compl

lemma insert_of_symmetric (hs : is_antichain r s) (hr : symmetric r)
  (h : ∀ ⦃b⦄, b ∈ s → a ≠ b → ¬ r a b) :
  is_antichain r (insert a s) :=
(is_antichain_insert_of_symmetric hr).2 ⟨hs, h⟩

end is_antichain

lemma is_antichain_singleton (a : α) (r : α → α → Prop) : is_antichain r {a} :=
pairwise_singleton _ _

lemma set.subsingleton.is_antichain (hs : s.subsingleton) (r : α → α → Prop) : is_antichain r s :=
hs.pairwise _

section preorder
variables [preorder α]

lemma is_antichain_and_least_iff : is_antichain (≤) s ∧ is_least s a ↔ s = {a} :=
⟨λ h, eq_singleton_iff_unique_mem.2 ⟨h.2.1, λ b hb, h.1.eq' hb h.2.1 (h.2.2 hb)⟩,
  by { rintro rfl, exact ⟨is_antichain_singleton _ _, is_least_singleton⟩ }⟩

lemma is_antichain_and_greatest_iff : is_antichain (≤) s ∧ is_greatest s a ↔ s = {a} :=
⟨λ h, eq_singleton_iff_unique_mem.2 ⟨h.2.1, λ b hb, h.1.eq hb h.2.1 (h.2.2 hb)⟩,
  by { rintro rfl, exact ⟨is_antichain_singleton _ _, is_greatest_singleton⟩ }⟩

lemma is_antichain.least_iff (hs : is_antichain (≤) s) : is_least s a ↔ s = {a} :=
(and_iff_right hs).symm.trans is_antichain_and_least_iff

lemma is_antichain.greatest_iff (hs : is_antichain (≤) s) : is_greatest s a ↔ s = {a} :=
(and_iff_right hs).symm.trans is_antichain_and_greatest_iff

lemma is_least.antichain_iff (hs : is_least s a) : is_antichain (≤) s ↔ s = {a} :=
(and_iff_left hs).symm.trans is_antichain_and_least_iff

lemma is_greatest.antichain_iff (hs : is_greatest s a) : is_antichain (≤) s ↔ s = {a} :=
(and_iff_left hs).symm.trans is_antichain_and_greatest_iff

lemma is_antichain.bot_mem_iff [order_bot α] (hs : is_antichain (≤) s) : ⊥ ∈ s ↔ s = {⊥} :=
is_least_bot_iff.symm.trans hs.least_iff

lemma is_antichain.top_mem_iff [order_top α] (hs : is_antichain (≤) s) : ⊤ ∈ s ↔ s = {⊤} :=
is_greatest_top_iff.symm.trans hs.greatest_iff

end preorder

/-! ### Strong antichains -/

/-- An strong (upward) antichain is a set such that no two distinct elements are related to a common
element. -/
def is_strong_antichain (r : α → α → Prop) (s : set α) : Prop :=
s.pairwise $ λ a b, ∀ c, ¬ r a c ∨ ¬ r b c

namespace is_strong_antichain

protected lemma subset (hs : is_strong_antichain r s) (h : t ⊆ s) : is_strong_antichain r t :=
hs.mono h

lemma mono (hs : is_strong_antichain r₁ s) (h : r₂ ≤ r₁) : is_strong_antichain r₂ s :=
hs.mono' $ λ a b hab c, (hab c).imp (compl_le_compl h _ _) (compl_le_compl h _ _)

lemma eq (hs : is_strong_antichain r s) {a b c : α} (ha : a ∈ s) (hb : b ∈ s) (hac : r a c)
  (hbc : r b c) :
  a = b :=
hs.eq ha hb $ λ h, false.elim $ (h c).elim (not_not_intro hac) (not_not_intro hbc)

protected lemma is_antichain [is_refl α r] (h : is_strong_antichain r s) : is_antichain r s :=
h.imp $ λ a b hab, (hab b).resolve_right (not_not_intro $ refl _)

protected lemma subsingleton [is_directed α r] (h : is_strong_antichain r s) : s.subsingleton :=
λ a ha b hb, let ⟨c, hac, hbc⟩ := directed_of r a b in h.eq ha hb hac hbc

protected lemma flip [is_symm α r] (hs : is_strong_antichain r s) :
  is_strong_antichain (flip r) s :=
λ a ha b hb h c, (hs ha hb h c).imp (mt $ symm_of r) (mt $ symm_of r)

lemma swap [is_symm α r] (hs : is_strong_antichain r s) : is_strong_antichain (swap r) s := hs.flip

lemma image (hs : is_strong_antichain r s) {f : α → β} (hf : surjective f)
  (h : ∀ a b, r' (f a) (f b) → r a b) :
  is_strong_antichain r' (f '' s) :=
begin
  rintro _ ⟨a, ha, rfl⟩ _ ⟨b, hb, rfl⟩ hab c,
  obtain ⟨c, rfl⟩ := hf c,
  exact (hs ha hb (ne_of_apply_ne _ hab) _).imp (mt $ h _ _) (mt $ h _ _),
end

lemma preimage (hs : is_strong_antichain r s) {f : β → α} (hf : injective f)
  (h : ∀ a b, r' a b → r (f a) (f b)) :
  is_strong_antichain r' (f ⁻¹' s) :=
λ a ha b hb hab c, (hs ha hb (hf.ne hab) _).imp (mt $ h _ _) (mt $ h _ _)

lemma _root_.is_strong_antichain_insert :
  is_strong_antichain r (insert a s) ↔ is_strong_antichain r s ∧
    ∀ ⦃b⦄, b ∈ s → a ≠ b → ∀ c, ¬ r a c ∨ ¬ r b c :=
set.pairwise_insert_of_symmetric $ λ a b h c, (h c).symm

protected lemma insert (hs : is_strong_antichain r s)
  (h : ∀ ⦃b⦄, b ∈ s → a ≠ b → ∀ c, ¬ r a c ∨ ¬ r b c) :
  is_strong_antichain r (insert a s) :=
is_strong_antichain_insert.2 ⟨hs, h⟩

end is_strong_antichain

lemma set.subsingleton.is_strong_antichain (hs : s.subsingleton) (r : α → α → Prop) :
  is_strong_antichain r s :=
hs.pairwise _