/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Mon.limits
import algebra.category.Group.preadditive
import category_theory.over
import category_theory.limits.concrete_category
import category_theory.limits.shapes.concrete_category
import group_theory.subgroup.basic

/-!
# The category of (commutative) (additive) groups has all limits

Further, these limits are preserved by the forgetful functor --- that is,
the underlying types are just the limits in the category of types.

-/

open category_theory
open category_theory.limits

universe u

noncomputable theory

variables {J : Type u} [small_category J]

namespace Group

@[to_additive]
instance group_obj (F : J ⥤ Group) (j) :
  group ((F ⋙ forget Group).obj j) :=
by { change group (F.obj j), apply_instance }

/--
The flat sections of a functor into `Group` form a subgroup of all sections.
-/
@[to_additive
  "The flat sections of a functor into `AddGroup` form an additive subgroup of all sections."]
def sections_subgroup (F : J ⥤ Group) :
  subgroup (Π j, F.obj j) :=
{ carrier := (F ⋙ forget Group).sections,
  inv_mem' := λ a ah j j' f,
  begin
    simp only [forget_map_eq_coe, functor.comp_map, pi.inv_apply, monoid_hom.map_inv, inv_inj],
    dsimp [functor.sections] at ah,
    rw ah f,
  end,
  ..(Mon.sections_submonoid (F ⋙ forget₂ Group Mon)) }

@[to_additive]
instance limit_group (F : J ⥤ Group) :
  group (types.limit_cone (F ⋙ forget Group.{u})).X :=
begin
  change group (sections_subgroup F),
  apply_instance,
end

/--
We show that the forgetful functor `Group ⥤ Mon` creates limits.

All we need to do is notice that the limit point has a `group` instance available,
and then reuse the existing limit.
-/
@[to_additive]
instance (F : J ⥤ Group) : creates_limit F (forget₂ Group Mon.{u}) :=
creates_limit_of_reflects_iso (λ c' t,
{ lifted_cone :=
  { X := Group.of (types.limit_cone (F ⋙ forget Group)).X,
    π :=
    { app := Mon.limit_π_monoid_hom (F ⋙ forget₂ Group Mon.{u}),
      naturality' := (Mon.has_limits.limit_cone (F ⋙ forget₂ _ _)).π.naturality, } },
  valid_lift := by apply is_limit.unique_up_to_iso (Mon.has_limits.limit_cone_is_limit _) t,
  makes_limit := is_limit.of_faithful (forget₂ Group Mon.{u}) (Mon.has_limits.limit_cone_is_limit _)
    (λ s, _) (λ s, rfl) })

/--
A choice of limit cone for a functor into `Group`.
(Generally, you'll just want to use `limit F`.)
-/
@[to_additive "A choice of limit cone for a functor into `Group`.
(Generally, you'll just want to use `limit F`.)"]
def limit_cone (F : J ⥤ Group) : cone F :=
lift_limit (limit.is_limit (F ⋙ (forget₂ Group Mon.{u})))

/--
The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
@[to_additive "The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)"]
def limit_cone_is_limit (F : J ⥤ Group) : is_limit (limit_cone F) :=
lifted_limit_is_limit _

/-- The category of groups has all limits. -/
@[to_additive]
instance has_limits : has_limits Group :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit_of_created F (forget₂ Group Mon) } } -- TODO use the above instead?

/--
The forgetful functor from groups to monoids preserves all limits.
(That is, the underlying monoid could have been computed instead as limits in the category
of monoids.)
-/
@[to_additive AddGroup.forget₂_AddMon_preserves_limits]
instance forget₂_Mon_preserves_limits : preserves_limits (forget₂ Group Mon) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F, by apply_instance } }

/--
The forgetful functor from groups to types preserves all limits. (That is, the underlying
types could have been computed instead as limits in the category of types.)
-/
@[to_additive]
instance forget_preserves_limits : preserves_limits (forget Group) :=
{ preserves_limits_of_shape := λ J 𝒥, by exactI
  { preserves_limit := λ F, limits.comp_preserves_limit (forget₂ Group Mon) (forget Mon) } }

end Group

namespace CommGroup

@[to_additive]
instance comm_group_obj (F : J ⥤ CommGroup) (j) :
  comm_group ((F ⋙ forget CommGroup).obj j) :=
by { change comm_group (F.obj j), apply_instance }

@[to_additive]
instance limit_comm_group (F : J ⥤ CommGroup) :
  comm_group (types.limit_cone (F ⋙ forget CommGroup.{u})).X :=
@subgroup.to_comm_group (Π j, F.obj j) _
  (Group.sections_subgroup (F ⋙ forget₂ CommGroup Group.{u}))

/--
We show that the forgetful functor `CommGroup ⥤ Group` creates limits.

All we need to do is notice that the limit point has a `comm_group` instance available,
and then reuse the existing limit.
-/
@[to_additive]
instance (F : J ⥤ CommGroup) : creates_limit F (forget₂ CommGroup Group.{u}) :=
creates_limit_of_reflects_iso (λ c' t,
{ lifted_cone :=
  { X := CommGroup.of (types.limit_cone (F ⋙ forget CommGroup)).X,
    π :=
    { app := Mon.limit_π_monoid_hom (F ⋙ forget₂ CommGroup Group.{u} ⋙ forget₂ Group Mon),
      naturality' := (Mon.has_limits.limit_cone _).π.naturality, } },
  valid_lift := by apply is_limit.unique_up_to_iso (Group.limit_cone_is_limit _) t,
  makes_limit := is_limit.of_faithful (forget₂ _ Group.{u} ⋙ forget₂ _ Mon.{u})
    (by apply Mon.has_limits.limit_cone_is_limit _) (λ s, _) (λ s, rfl) })

/--
A choice of limit cone for a functor into `CommGroup`.
(Generally, you'll just want to use `limit F`.)
-/
@[to_additive "A choice of limit cone for a functor into `CommGroup`.
(Generally, you'll just want to use `limit F`.)"]
def limit_cone (F : J ⥤ CommGroup) : cone F :=
lift_limit (limit.is_limit (F ⋙ (forget₂ CommGroup Group.{u})))

/--
The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
@[to_additive "The chosen cone is a limit cone.
(Generally, you'll just wantto use `limit.cone F`.)"]
def limit_cone_is_limit (F : J ⥤ CommGroup) : is_limit (limit_cone F) :=
lifted_limit_is_limit _

/-- The category of commutative groups has all limits. -/
@[to_additive]
instance has_limits : has_limits CommGroup :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit_of_created F (forget₂ CommGroup Group) } }

/--
The forgetful functor from commutative groups to groups preserves all limits.
(That is, the underlying group could have been computed instead as limits in the category
of groups.)
-/
@[to_additive AddCommGroup.forget₂_AddGroup_preserves_limits]
instance forget₂_Group_preserves_limits : preserves_limits (forget₂ CommGroup Group) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F, by apply_instance } }

/--
An auxiliary declaration to speed up typechecking.
-/
@[to_additive AddCommGroup.forget₂_AddCommMon_preserves_limits_aux
  "An auxiliary declaration to speed up typechecking."]
def forget₂_CommMon_preserves_limits_aux (F : J ⥤ CommGroup) :
  is_limit ((forget₂ CommGroup CommMon).map_cone (limit_cone F)) :=
CommMon.limit_cone_is_limit (F ⋙ forget₂ CommGroup CommMon)

/--
The forgetful functor from commutative groups to commutative monoids preserves all limits.
(That is, the underlying commutative monoids could have been computed instead as limits
in the category of commutative monoids.)
-/
@[to_additive AddCommGroup.forget₂_AddCommMon_preserves_limits]
instance forget₂_CommMon_preserves_limits : preserves_limits (forget₂ CommGroup CommMon) :=
{ preserves_limits_of_shape := λ J 𝒥, by exactI
  { preserves_limit := λ F, preserves_limit_of_preserves_limit_cone
    (limit_cone_is_limit F) (forget₂_CommMon_preserves_limits_aux F) } }

/--
The forgetful functor from commutative groups to types preserves all limits. (That is, the
underlying types could have been computed instead as limits in the category of types.)
-/
@[to_additive AddCommGroup.forget_preserves_limits]
instance forget_preserves_limits : preserves_limits (forget CommGroup) :=
{ preserves_limits_of_shape := λ J 𝒥, by exactI
  { preserves_limit := λ F, limits.comp_preserves_limit (forget₂ CommGroup Group) (forget Group) } }

end CommGroup

namespace AddCommGroup

/--
The categorical kernel of a morphism in `AddCommGroup`
agrees with the usual group-theoretical kernel.
-/
def kernel_iso_ker {G H : AddCommGroup} (f : G ⟶ H) :
  kernel f ≅ AddCommGroup.of f.ker :=
{ hom :=
  { to_fun := λ g, ⟨kernel.ι f g,
    begin
      -- TODO where is this `has_coe_t_aux.coe` coming from? can we prevent it appearing?
      change (kernel.ι f) g ∈ f.ker,
      simp [add_monoid_hom.mem_ker],
    end⟩,
    map_zero' := by { ext, simp, },
    map_add' := λ g g', by { ext, simp, }, },
  inv := kernel.lift f (add_subgroup.subtype f.ker) (by tidy),
  hom_inv_id' := by { apply equalizer.hom_ext _, ext, simp, },
  inv_hom_id' :=
  begin
    apply AddCommGroup.ext,
    simp only [add_monoid_hom.coe_mk, coe_id, coe_comp],
    rintro ⟨x, mem⟩,
    simp,
  end, }.

@[simp]
lemma kernel_iso_ker_hom_comp_subtype {G H : AddCommGroup} (f : G ⟶ H) :
  (kernel_iso_ker f).hom ≫ add_subgroup.subtype f.ker = kernel.ι f :=
by ext; refl

@[simp]
lemma kernel_iso_ker_inv_comp_ι {G H : AddCommGroup} (f : G ⟶ H) :
  (kernel_iso_ker f).inv ≫ kernel.ι f = add_subgroup.subtype f.ker :=
begin
  ext,
  simp [kernel_iso_ker],
end

/--
The categorical kernel inclusion for `f : G ⟶ H`, as an object over `G`,
agrees with the `subtype` map.
-/
@[simps]
def kernel_iso_ker_over {G H : AddCommGroup.{u}} (f : G ⟶ H) :
  over.mk (kernel.ι f) ≅ @over.mk _ _ G (AddCommGroup.of f.ker) (add_subgroup.subtype f.ker) :=
over.iso_mk (kernel_iso_ker f) (by simp)

end AddCommGroup


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang
-/
import algebra.direct_sum.algebra
import algebra.direct_sum.internal
import algebra.direct_sum.ring
import group_theory.subgroup.basic

/-!
# Internally-graded algebras

This file defines the typeclass `graded_algebra 𝒜`, for working with an algebra `A` that is
internally graded by a collection of submodules `𝒜 : ι → submodule R A`.
See the docstring of that typeclass for more information.

## Main definitions

* `graded_algebra 𝒜`: the typeclass, which is a combination of `set_like.graded_monoid`, and
  a constructive version of `direct_sum.submodule_is_internal 𝒜`.
* `graded_algebra.decompose : A ≃ₐ[R] ⨁ i, 𝒜 i`, which breaks apart an element of the algebra into
  its constituent pieces.
* `graded_algebra.proj 𝒜 i` is the linear map from `A` to its degree `i : ι` component, such that
  `proj 𝒜 i x = decompose 𝒜 x i`.
* `graded_algebra.support 𝒜 r` is the `finset ι` containing the `i : ι` such that the degree `i`
  component of `r` is not zero.

## Implementation notes

For now, we do not have internally-graded semirings and internally-graded rings; these can be
represented with `𝒜 : ι → submodule ℕ A` and `𝒜 : ι → submodule ℤ A` respectively, since all
`semiring`s are ℕ-algebras via `algebra_nat`, and all `ring`s are `ℤ`-algebras via `algebra_int`.

## Tags

graded algebra, graded ring, graded semiring, decomposition
-/

open_locale direct_sum big_operators

section graded_algebra

variables {ι R A : Type*}
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝒜 : ι → submodule R A)

/-- An internally-graded `R`-algebra `A` is one that can be decomposed into a collection
of `submodule R A`s indexed by `ι` such that the canonical map `A → ⨁ i, 𝒜 i` is bijective and
respects multiplication, i.e. the product of an element of degree `i` and an element of degree `j`
is an element of degree `i + j`.

Note that the fact that `A` is internally-graded, `graded_algebra 𝒜`, implies an externally-graded
algebra structure `direct_sum.galgebra R (λ i, ↥(𝒜 i))`, which in turn makes available an
`algebra R (⨁ i, 𝒜 i)` instance.
-/

class graded_algebra extends set_like.graded_monoid 𝒜 :=
(decompose' : A → ⨁ i, 𝒜 i)
(left_inv : function.left_inverse decompose' (direct_sum.submodule_coe 𝒜))
(right_inv : function.right_inverse decompose' (direct_sum.submodule_coe 𝒜))

lemma graded_algebra.is_internal [graded_algebra 𝒜] :
  direct_sum.submodule_is_internal 𝒜 :=
⟨graded_algebra.left_inv.injective, graded_algebra.right_inv.surjective⟩

/-- A helper to construct a `graded_algebra` when the `set_like.graded_monoid` structure is already
available. This makes the `left_inv` condition easier to prove, and phrases the `right_inv`
condition in a way that allows custom `@[ext]` lemmas to apply.

See note [reducible non-instances]. -/
@[reducible]
def graded_algebra.of_alg_hom [set_like.graded_monoid 𝒜] (decompose : A →ₐ[R] ⨁ i, 𝒜 i)
  (right_inv : (direct_sum.submodule_coe_alg_hom 𝒜).comp decompose = alg_hom.id R A)
  (left_inv : ∀ i (x : 𝒜 i), decompose (x : A) = direct_sum.of (λ i, ↥(𝒜 i)) i x) :
  graded_algebra 𝒜 :=
{ decompose' := decompose,
  right_inv := alg_hom.congr_fun right_inv,
  left_inv := begin
    suffices : decompose.comp (direct_sum.submodule_coe_alg_hom 𝒜) = alg_hom.id _ _,
    from alg_hom.congr_fun this,
    ext i x : 2,
    exact (decompose.congr_arg $ direct_sum.submodule_coe_alg_hom_of _ _ _).trans (left_inv i x),
  end}

variable [graded_algebra 𝒜]

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
an algebra to a direct sum of components. -/
def graded_algebra.decompose : A ≃ₐ[R] ⨁ i, 𝒜 i := alg_equiv.symm
{ to_fun := direct_sum.submodule_coe_alg_hom 𝒜,
  inv_fun := graded_algebra.decompose',
  left_inv := graded_algebra.left_inv,
  right_inv := graded_algebra.right_inv,
  map_mul' := alg_hom.map_mul _,
  map_add' := alg_hom.map_add _,
  commutes' := alg_hom.commutes _ }

@[simp] lemma graded_algebra.decompose'_def :
  graded_algebra.decompose' = graded_algebra.decompose 𝒜 := rfl

@[simp] lemma graded_algebra.decompose_symm_of {i : ι} (x : 𝒜 i) :
  (graded_algebra.decompose 𝒜).symm (direct_sum.of _ i x) = x :=
direct_sum.submodule_coe_alg_hom_of 𝒜 _ _

/-- The projection maps of graded algebra-/
def graded_algebra.proj (𝒜 : ι → submodule R A) [graded_algebra 𝒜] (i : ι) : A →ₗ[R] A :=
(𝒜 i).subtype.comp $
  (dfinsupp.lapply i).comp $
  (graded_algebra.decompose 𝒜).to_alg_hom.to_linear_map

@[simp] lemma graded_algebra.proj_apply (i : ι) (r : A) :
  graded_algebra.proj 𝒜 i r = (graded_algebra.decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

/-- The support of `r` is the `finset` where `proj R A i r ≠ 0 ↔ i ∈ r.support`-/
def graded_algebra.support [Π (i : ι) (x : 𝒜 i), decidable (x ≠ 0)]
  (r : A) : finset ι :=
(graded_algebra.decompose 𝒜 r).support

lemma graded_algebra.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_algebra.proj 𝒜 i ((graded_algebra.decompose 𝒜).symm a) =
  (graded_algebra.decompose 𝒜).symm (direct_sum.of _ i (a i)) :=
by rw [graded_algebra.proj_apply, graded_algebra.decompose_symm_of, alg_equiv.apply_symm_apply]

@[simp] lemma graded_algebra.decompose_coe {i : ι} (x : 𝒜 i) :
  graded_algebra.decompose 𝒜 x = direct_sum.of _ i x :=
by rw [←graded_algebra.decompose_symm_of, alg_equiv.apply_symm_apply]

lemma graded_algebra.decompose_of_mem {x : A} {i : ι} (hx : x ∈ 𝒜 i) :
  graded_algebra.decompose 𝒜 x = direct_sum.of _ i (⟨x, hx⟩ : 𝒜 i) :=
graded_algebra.decompose_coe _ ⟨x, hx⟩

lemma graded_algebra.decompose_of_mem_same {x : A} {i : ι} (hx : x ∈ 𝒜 i) :
  (graded_algebra.decompose 𝒜 x i : A) = x :=
by rw [graded_algebra.decompose_of_mem _ hx, direct_sum.of_eq_same, subtype.coe_mk]

lemma graded_algebra.decompose_of_mem_ne {x : A} {i j : ι} (hx : x ∈ 𝒜 i) (hij : i ≠ j):
  (graded_algebra.decompose 𝒜 x j : A) = 0 :=
by rw [graded_algebra.decompose_of_mem _ hx, direct_sum.of_eq_of_ne _ _ _ _ hij, submodule.coe_zero]

variable [Π (i : ι) (x : 𝒜 i), decidable (x ≠ 0)]

lemma graded_algebra.mem_support_iff (r : A) (i : ι) :
  i ∈ graded_algebra.support 𝒜 r ↔ graded_algebra.proj 𝒜 i r ≠ 0 :=
begin
  rw [graded_algebra.support, dfinsupp.mem_support_iff, graded_algebra.proj_apply],
  simp only [ne.def, submodule.coe_eq_zero],
end

lemma graded_algebra.sum_support_decompose (r : A) :
  ∑ i in graded_algebra.support 𝒜 r, (graded_algebra.decompose 𝒜 r i : A) = r :=
begin
  conv_rhs { rw [←(graded_algebra.decompose 𝒜).symm_apply_apply r,
    ←direct_sum.sum_support_of _ (graded_algebra.decompose 𝒜 r)] },
  rw [alg_equiv.map_sum, graded_algebra.support],
  simp_rw graded_algebra.decompose_symm_of,
end

end graded_algebra

section canonical_order

open graded_algebra set_like.graded_monoid direct_sum

variables {ι R A : Type*}
variables [comm_semiring R] [semiring A]
variables [algebra R A] [decidable_eq ι]
variables [canonically_ordered_add_monoid ι]
variables (𝒜 : ι → submodule R A) [graded_algebra 𝒜]

/--
If `A` is graded by a canonically ordered add monoid, then the projection map `x ↦ x₀` is a ring
homomorphism.
-/
@[simps]
def graded_algebra.proj_zero_ring_hom : A →+* A :=
{ to_fun := λ a, decompose 𝒜 a 0,
  map_one' := decompose_of_mem_same 𝒜 one_mem,
  map_zero' := by simp only [subtype.ext_iff_val, map_zero, zero_apply, submodule.coe_zero],
  map_add' := λ _ _, by simp [subtype.ext_iff_val, map_add, add_apply, submodule.coe_add],
  map_mul' := λ x y,
    have m : ∀ x, x ∈ supr 𝒜, from λ x, (is_internal 𝒜).supr_eq_top.symm ▸ submodule.mem_top,
    begin
    refine submodule.supr_induction 𝒜 (m x) (λ i c hc, _) _ _,
    { refine submodule.supr_induction 𝒜 (m y) (λ j c' hc', _) _ _,
      { by_cases h : i + j = 0,
        { rw [decompose_of_mem_same 𝒜 (show c * c' ∈ 𝒜 0, from h ▸ mul_mem hc hc'),
            decompose_of_mem_same 𝒜 (show c ∈ 𝒜 0, from (add_eq_zero_iff.mp h).1 ▸ hc),
            decompose_of_mem_same 𝒜 (show c' ∈ 𝒜 0, from (add_eq_zero_iff.mp h).2 ▸ hc')] },
        { rw [decompose_of_mem_ne 𝒜 (mul_mem hc hc') h],
          cases (show i ≠ 0 ∨ j ≠ 0, by rwa [add_eq_zero_iff, not_and_distrib] at h) with h' h',
          { simp only [decompose_of_mem_ne 𝒜 hc h', zero_mul] },
          { simp only [decompose_of_mem_ne 𝒜 hc' h', mul_zero] } } },
      { simp only [map_zero, zero_apply, submodule.coe_zero, mul_zero] },
      { intros _ _ hd he, simp only [mul_add, map_add, add_apply, submodule.coe_add, hd, he] } },
    { simp only [map_zero, zero_apply, submodule.coe_zero, zero_mul] },
    { rintros _ _ ha hb, simp only [add_mul, map_add, add_apply, submodule.coe_add, ha, hb] },
  end }

end canonical_order


/-
Copyright © 2018 François G. Dorais. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

namespace function
variables {α : Sort*} {β : Sort*}

definition inverse (g : β → α) (f : α → β) : Prop := ∀ x y, f x = y ↔ g y = x

definition has_inverse (f : α → β) : Prop := ∃ g : β → α, inverse f g

variables {g : β → α} {f : α → β}

-- missing from standard library?
lemma surjective_of_right_inverse : right_inverse g f → surjective f :=
λ h y, ⟨g y, h y⟩

lemma inverse_symm : inverse g f → inverse f g :=
λ h y x, iff.symm (h x y)

lemma unique_inverse {g₁ g₂ : β → α} :
inverse g₁ f → inverse g₂ f → g₁ = g₂ :=
λ h₁ h₂, funext (λ y, (h₁ (g₂ y) y).mp ((h₂ (g₂ y) y).mpr rfl))

lemma left_inverse_of_inverse : inverse g f → left_inverse g f :=
λ h x, iff.mp (h x (f x)) rfl

lemma right_inverse_of_inverse : inverse g f → right_inverse g f :=
λ h y, iff.mpr (h (g y) y) rfl

lemma inverse_of_right_inverse_of_left_inverse :
left_inverse g f → right_inverse g f → inverse g f :=
λ hl hr x y, ⟨λ hf, eq.subst hf (hl x), λ hg, eq.subst hg (hr y)⟩

lemma has_left_inverse_of_has_inverse : has_inverse f → has_left_inverse f :=
λ ⟨g, h⟩, ⟨g, right_inverse_of_inverse h⟩

lemma has_right_inverse_of_has_inverse : has_inverse f → has_right_inverse f :=
λ ⟨g, h⟩, ⟨g, left_inverse_of_inverse h⟩

lemma has_inverse_of_has_right_inverse_of_has_left_inverse :
has_left_inverse f → has_right_inverse f → has_inverse f :=
λ ⟨g, hl⟩ ⟨g', hr⟩,
have g' = g, from funext (λ y, by rw [← hr y, hl, hr]),
⟨g, inverse_of_right_inverse_of_left_inverse (eq.subst this hr) hl⟩

lemma bijective_of_inverse : inverse g f → bijective f :=
λ h,
⟨ injective_of_left_inverse (left_inverse_of_inverse h)
, surjective_of_right_inverse (right_inverse_of_inverse h)
⟩

lemma bijective_of_has_inverse : has_inverse f → bijective f :=
λ h,
⟨ injective_of_has_left_inverse (has_left_inverse_of_has_inverse h)
, surjective_of_has_right_inverse (has_right_inverse_of_has_inverse h)
⟩

end function


import number_theory.divisors
import data.fintype.basic
import tactic

/-
This file formalizes the following mathematical problem:
"Given n, count the positive natural solutions to 1/a + 1/b = 1/n".
I show that the number of such solutions is equal to the number of divisors of n^2 through the explicit equivalence.
-/

def is_solution (n a b : ℕ) := a ≠ 0 ∧ b ≠ 0 ∧ (a : ℚ)⁻¹ + (b : ℚ)⁻¹ = (n : ℚ)⁻¹

@[simp] lemma is_solution_def {n a b} :
  is_solution n a b ↔ a ≠ 0 ∧ b ≠ 0 ∧ (a : ℚ)⁻¹ + (b : ℚ)⁻¹ = (n : ℚ)⁻¹ := iff.rfl

lemma n_ne_zero_of_is_solution {n a b} (h : is_solution n a b) :
  n ≠ 0 :=
begin
  rcases h with ⟨ha, hb, h⟩,
  have : (n : ℚ)⁻¹ > 0,
  { calc (n : ℚ)⁻¹ = (a : ℚ)⁻¹ + (b : ℚ)⁻¹  : h.symm
      ...          > 0 + 0                  : add_lt_add _ _
      ...          = 0                      : add_zero _,
      all_goals { rwa [inv_pos, nat.cast_pos, pos_iff_ne_zero] } },
  rwa [gt_iff_lt, inv_pos, nat.cast_pos, pos_iff_ne_zero] at this,
end

lemma is_solution_iff_aux {n a b : ℕ} (ha : a ≠ 0) (hb : b ≠ 0) (hn : n ≠ 0) :
  (a : ℚ)⁻¹ + (b : ℚ)⁻¹ = (n : ℚ)⁻¹ ↔ (a + b) * n = a * b :=
begin
  rw @inv_add_inv ℚ _ _ _ (nat.cast_ne_zero.2 ha) (nat.cast_ne_zero.mpr hb),
  rw ←(mul_eq_one_iff_eq_inv₀ $ (@nat.cast_ne_zero ℚ _ _ _ _).2 hn),
  rw div_mul_eq_mul_div,
  rw div_eq_iff (@mul_ne_zero ℚ _ _ _ _ (nat.cast_ne_zero.2 ha) (nat.cast_ne_zero.2 hb)),
  rw one_mul,
  norm_cast,
end

lemma is_solution_mp {n a b : ℕ} (h : is_solution n a b) :
  a ≠ 0 ∧ b ≠ 0 ∧ (a + b) * n = a * b :=
begin
  have hn := n_ne_zero_of_is_solution h,
  rcases h with ⟨ha, hb, h⟩,
  exact ⟨ha, hb, (is_solution_iff_aux ha hb hn).1 h⟩,
end

lemma is_solution_mpr {n a b : ℕ} (ha : a ≠ 0) (hb : b ≠ 0) (h : (a + b) * n = a * b) :
  is_solution n a b :=
begin
  have hn : n ≠ 0 := by {rintro rfl, apply mul_ne_zero ha hb, simpa using h},
  exact ⟨ha, hb, (is_solution_iff_aux ha hb hn).2 h⟩,
end

lemma is_solution_iff {n a b : ℕ} :
  is_solution n a b ↔ a ≠ 0 ∧ b ≠ 0 ∧ (a + b) * n = a * b :=
  ⟨is_solution_mp, λ ⟨ha, hb, h⟩, is_solution_mpr ha hb h⟩

lemma n_le_a_of_is_solution {n a b : ℕ} (h : is_solution n a b) : n ≤ a :=
begin
  replace h := is_solution_mp h,
  rcases h with ⟨ha, hb, h⟩,
  nlinarith [nat.pos_of_ne_zero ha, nat.pos_of_ne_zero hb],
end

lemma n_lt_a_of_is_solution {n a b : ℕ} (h : is_solution n a b) : n < a :=
begin
  replace h := is_solution_mp h,
  rcases h with ⟨ha, hb, h⟩,
  nlinarith [nat.pos_of_ne_zero ha, nat.pos_of_ne_zero hb],
end

lemma n_le_b_of_is_solution {n a b : ℕ} (h : is_solution n a b) : n ≤ b :=
begin
  replace h := is_solution_mp h,
  rcases h with ⟨ha, hb, h⟩,
  nlinarith [nat.pos_of_ne_zero ha, nat.pos_of_ne_zero hb],
end

lemma n_lt_b_of_is_solution {n a b : ℕ} (h : is_solution n a b) : n < b :=
begin
  replace h := is_solution_mp h,
  rcases h with ⟨ha, hb, h⟩,
  nlinarith [nat.pos_of_ne_zero ha, nat.pos_of_ne_zero hb],
end

def solutions (n : ℕ) : set (ℕ × ℕ) := { p | is_solution n p.1 p.2 }

def solutions_equiv_sq_divisors (n : ℕ) [h_ne_zero : fact (n ≠ 0)] : solutions n ≃ (n*n).divisors :=
  { to_fun := λ p, ⟨p.1.1 - n,
  begin
    rcases p with ⟨⟨a, b⟩, hsol⟩,
    rw nat.mem_divisors,
    dsimp only,
    have n_le_a := n_le_a_of_is_solution hsol,
    have n_le_b := n_le_b_of_is_solution hsol,
    rw [solutions, set.mem_set_of, is_solution_iff] at hsol,
    dsimp [-ne.def] at hsol,
    refine ⟨⟨b - n, _⟩, mul_self_ne_zero.2 h_ne_zero.out⟩,
    zify [n_le_a, n_le_b] at hsol ⊢,
    rw [mul_sub, sub_mul, sub_mul],
    linarith,
  end⟩,
  inv_fun := λ d, { val := ⟨d.val + n, n*n/d.val + n⟩,
  property :=
  begin
    rcases d with ⟨d, h⟩,
    dsimp [solutions],
    rw nat.mem_divisors at h,
    rcases h with ⟨h_dvd, h_eq⟩,
    rw is_solution_iff,
    refine ⟨_, _, _⟩,
    { rw ←pos_iff_ne_zero, exact add_pos_of_nonneg_of_pos (zero_le _) (nat.pos_of_ne_zero h_ne_zero.out), },
    { rw ←pos_iff_ne_zero, exact add_pos_of_nonneg_of_pos (zero_le _) (nat.pos_of_ne_zero h_ne_zero.out), },
    have tmp : (n * n / d) * d = n * n := nat.div_mul_cancel h_dvd,
    linarith,
  end},
  left_inv := begin
    rintro ⟨⟨a, b⟩, hsol⟩,
    apply subtype.eq,
    dsimp only,
    rw [solutions, set.mem_set_of] at hsol,
    have n_le_a := n_le_a_of_is_solution hsol,
    have n_le_b := n_le_b_of_is_solution hsol,
    have n_lt_a := n_lt_a_of_is_solution hsol,
    have n_lt_b := n_lt_b_of_is_solution hsol,
    rw is_solution_iff at hsol,
    dsimp only at hsol,
    rcases hsol with ⟨ha, hb, hsol⟩,
    ext; dsimp at *,
    { exact nat.sub_add_cancel n_le_a, },
    { have n_lt_a : a - n > 0 := nat.sub_pos_of_lt n_lt_a,
      rw ←nat.add_mul_div_left _ _ n_lt_a,
      rw [nat.mul_sub_right_distrib, ←nat.add_sub_assoc (mul_le_mul_right' n_le_a n), add_comm (n * n) (a * n), nat.add_sub_cancel],
      apply nat.div_eq_of_eq_mul_left n_lt_a,
      linarith,
    },
  end,
  right_inv := begin
    rintro ⟨x, h_dvd⟩,
    apply subtype.eq,
    dsimp,
    exact nat.add_sub_cancel _ _,
  end }

instance solutions_fintype (n : ℕ) [h_ne_zero : fact (n ≠ 0)] : fintype (solutions n) :=
  fintype.of_equiv _ (solutions_equiv_sq_divisors n).symm

lemma solutions_count (n : ℕ) [h_ne_zero : fact (n ≠ 0)] : fintype.card (solutions n) = (n*n).divisors.card :=
begin
  rw fintype.of_equiv_card (solutions_equiv_sq_divisors n).symm,
  simp only [fintype.card_coe],
end

instance : fact (60 ≠ 0) := ⟨by norm_num⟩

#eval fintype.card ↥(solutions 60)


/-
Copyright (c) 2023 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin
-/
import topology.homeomorph
import topology.order.lattice
import order.hom.complete_lattice

/-!
# Lower topology

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

This file introduces the lower topology on a preorder as the topology generated by the complements
of the closed intervals to infinity.

## Main statements

- `lower_topology.t0_space` - the lower topology on a partial order is T₀
- `is_topological_basis.is_topological_basis` - the complements of the upper closures of finite
  subsets form a basis for the lower topology
- `lower_topology.to_has_continuous_inf` - the inf map is continuous with respect to the lower
  topology

## Implementation notes

A type synonym `with_lower_topology` is introduced and for a preorder `α`, `with_lower_topology α`
is made an instance of `topological_space` by the topology generated by the complements of the
closed intervals to infinity.

We define a mixin class `lower_topology` for the class of types which are both a preorder and a
topology and where the topology is generated by the complements of the closed intervals to infinity.
It is shown that `with_lower_topology α` is an instance of `lower_topology`.

## Motivation

The lower topology is used with the `Scott` topology to define the Lawson topology. The restriction
of the lower topology to the spectrum of a complete lattice coincides with the hull-kernel topology.

## References

* [Gierz et al, *A Compendium of Continuous Lattices*][GierzEtAl1980]

## Tags

lower topology, preorder
-/

variables (α β : Type*)

open set topological_space

/--
Type synonym for a preorder equipped with the lower topology
-/
def with_lower_topology := α

variables {α β}

namespace with_lower_topology

/-- `to_lower` is the identity function to the `with_lower_topology` of a type.  -/
@[pattern] def to_lower : α ≃ with_lower_topology α := equiv.refl _

/-- `of_lower` is the identity function from the `with_lower_topology` of a type.  -/
@[pattern] def of_lower : with_lower_topology α ≃ α := equiv.refl _

@[simp] lemma to_with_lower_topology_symm_eq : (@to_lower α).symm = of_lower := rfl
@[simp] lemma of_with_lower_topology_symm_eq : (@of_lower α).symm = to_lower := rfl
@[simp] lemma to_lower_of_lower (a : with_lower_topology α) : to_lower (of_lower a) = a := rfl
@[simp] lemma of_lower_to_lower (a : α) : of_lower (to_lower a) = a := rfl
@[simp] lemma to_lower_inj {a b : α} : to_lower a = to_lower b ↔ a = b := iff.rfl
@[simp] lemma of_lower_inj {a b : with_lower_topology α} : of_lower a = of_lower b ↔ a = b :=
iff.rfl

/-- A recursor for `with_lower_topology`. Use as `induction x using with_lower_topology.rec`. -/
protected def rec {β : with_lower_topology α → Sort*}
  (h : Π a, β (to_lower a)) : Π a, β a := λ a, h (of_lower a)

instance [nonempty α] : nonempty (with_lower_topology α) := ‹nonempty α›
instance [inhabited α] : inhabited (with_lower_topology α) := ‹inhabited α›

variables [preorder α]

instance : preorder (with_lower_topology α) := ‹preorder α›

instance : topological_space (with_lower_topology α) := generate_from {s | ∃ a, (Ici a)ᶜ = s}

lemma is_open_preimage_of_lower (S : set α) :
  is_open (with_lower_topology.of_lower ⁻¹' S) ↔
    (generate_from {s : set α | ∃ (a : α), (Ici a)ᶜ = s}).is_open S := iff.rfl

lemma is_open_def (T : set (with_lower_topology α)) :
  is_open T ↔ (generate_from {s : set α | ∃ (a : α), (Ici a)ᶜ = s}).is_open
    (with_lower_topology.to_lower ⁻¹' T) := iff.rfl

end with_lower_topology

/--
The lower topology is the topology generated by the complements of the closed intervals to infinity.
-/
class lower_topology (α : Type*) [t : topological_space α] [preorder α] : Prop :=
(topology_eq_lower_topology [] : t = generate_from {s | ∃ a, (Ici a)ᶜ = s})

instance [preorder α] : lower_topology (with_lower_topology α) := ⟨rfl⟩

namespace lower_topology

/-- The complements of the upper closures of finite sets are a collection of lower sets
which form a basis for the lower topology. -/
def lower_basis (α : Type*) [preorder α] :=
{s : set α | ∃ t : set α, t.finite ∧ (upper_closure t : set α)ᶜ = s}

section preorder
variables [preorder α] [topological_space α] [lower_topology α] {s : set α}

/-- If `α` is equipped with the lower topology, then it is homeomorphic to `with_lower_topology α`.
-/
def with_lower_topology_homeomorph : with_lower_topology α ≃ₜ α :=
{ continuous_to_fun := by { convert continuous_id, apply topology_eq_lower_topology },
  continuous_inv_fun := by { convert ← continuous_id, apply topology_eq_lower_topology },
  ..with_lower_topology.of_lower }

lemma is_open_iff_generate_Ici_compl : is_open s ↔ generate_open {t | ∃ a, (Ici a)ᶜ = t} s :=
by rw topology_eq_lower_topology α; refl

/-- Left-closed right-infinite intervals [a, ∞) are closed in the lower topology. -/
lemma is_closed_Ici (a : α) : is_closed (Ici a) :=
is_open_compl_iff.1 $ is_open_iff_generate_Ici_compl.2 $ generate_open.basic _ ⟨a, rfl⟩

/-- The upper closure of a finite set is closed in the lower topology. -/
lemma is_closed_upper_closure (h : s.finite) : is_closed (upper_closure s : set α) :=
begin
  simp only [← upper_set.infi_Ici, upper_set.coe_infi],
  exact is_closed_bUnion h (λ a h₁, is_closed_Ici a),
end

/-- Every set open in the lower topology is a lower set. -/
lemma is_lower_set_of_is_open (h : is_open s) : is_lower_set s :=
begin
  rw is_open_iff_generate_Ici_compl at h,
  induction h,
  case generate_open.basic : u h { obtain ⟨a, rfl⟩ := h, exact (is_upper_set_Ici a).compl },
  case univ : { exact is_lower_set_univ },
  case inter : u v hu1 hv1 hu2 hv2 { exact hu2.inter hv2 },
  case sUnion : _ _ ih { exact is_lower_set_sUnion ih },
end

/--
The closure of a singleton `{a}` in the lower topology is the left-closed right-infinite interval
[a, ∞).
-/
@[simp] lemma closure_singleton (a : α) : closure {a} = Ici a :=
subset_antisymm (closure_minimal (λ b h, h.ge) $ is_closed_Ici a) $
  (is_upper_set_of_is_closed is_closed_closure).Ici_subset $ subset_closure rfl

protected lemma is_topological_basis :
  is_topological_basis (lower_basis α) :=
begin
  convert is_topological_basis_of_subbasis (topology_eq_lower_topology α),
  simp_rw [lower_basis, coe_upper_closure, compl_Union],
  ext s,
  split,
  { rintro ⟨F, hF, rfl⟩,
    refine ⟨(λ a, (Ici a)ᶜ) '' F, ⟨hF.image _, image_subset_iff.2 $ λ _ _, ⟨_, rfl⟩⟩, _⟩,
    rw sInter_image },
  { rintro ⟨F, ⟨hF, hs⟩, rfl⟩,
    haveI := hF.to_subtype,
    rw [subset_def, subtype.forall'] at hs,
    choose f hf using hs,
    exact ⟨_, finite_range f, by simp_rw [bInter_range, hf, sInter_eq_Inter]⟩ }
end

end preorder

section partial_order
variables [partial_order α] [topological_space α] [lower_topology α]

/--
The lower topology on a partial order is T₀.
-/
@[priority 90] -- see Note [lower instance priority]
instance : t0_space α :=
(t0_space_iff_inseparable α).2 $ λ x y h, Ici_injective $
  by simpa only [inseparable_iff_closure_eq, closure_singleton] using h

end partial_order
end lower_topology

instance [preorder α] [topological_space α] [lower_topology α] [order_bot α]
  [preorder β] [topological_space β] [lower_topology β] [order_bot β] : lower_topology (α × β) :=
{ topology_eq_lower_topology :=
  begin
    refine le_antisymm (le_generate_from _) _,
    { rintro _ ⟨x, rfl⟩,
      exact ((lower_topology.is_closed_Ici _).prod $
        lower_topology.is_closed_Ici _).is_open_compl },
    rw [(lower_topology.is_topological_basis.prod
      lower_topology.is_topological_basis).eq_generate_from,
      le_generate_from_iff_subset_is_open, image2_subset_iff],
    rintro _ ⟨s, hs, rfl⟩ _ ⟨t, ht, rfl⟩,
    dsimp,
    simp_rw [coe_upper_closure, compl_Union, prod_eq, preimage_Inter, preimage_compl],
    -- Note: `refine` doesn't work here because it tries using `prod.topological_space`.
    apply (is_open_bInter hs $ λ a _, _).inter (is_open_bInter ht $ λ b _, _),
    { exact generate_open.basic _ ⟨(a, ⊥), by simp [Ici_prod_eq, prod_univ]⟩ },
    { exact generate_open.basic _ ⟨(⊥, b), by simp [Ici_prod_eq, univ_prod]⟩ },
    all_goals { apply_instance },
  end }

section complete_lattice
variables [complete_lattice α] [complete_lattice β] [topological_space α] [lower_topology α]
  [topological_space β] [lower_topology β]

lemma Inf_hom.continuous (f : Inf_hom α β) : continuous f :=
begin
  convert continuous_generated_from _,
  { exact lower_topology.topology_eq_lower_topology β },
  rintro _ ⟨b, rfl⟩,
  rw [preimage_compl, is_open_compl_iff],
  convert lower_topology.is_closed_Ici (Inf $ f ⁻¹' Ici b),
  refine subset_antisymm (λ a, Inf_le) (λ a ha, le_trans _ $ order_hom_class.mono f ha),
  simp [map_Inf],
end

@[priority 90] -- see Note [lower instance priority]
instance lower_topology.to_has_continuous_inf : has_continuous_inf α :=
⟨(inf_Inf_hom : Inf_hom (α × α) α).continuous⟩

end complete_lattice


/-
Copyright © 2019, Oracle and/or its affiliates. All rights reserved.
-/

import .setup_definition
import ..lib.util

open set
open measure_theory
open probability_measure

local attribute [instance] classical.prop_decidable

namespace stump

variables (μ: probability_measure ℍ) (target: ℍ)

lemma label_correct:
  ∀ x, (label target x).snd = tt ↔ x ≤ target :=
begin
  intros,
  split; intro,
  {
    unfold label at a,
    simp at a,
    unfold rle at a,
    tidy,
  },
  {
    unfold label,
    simp,
    unfold rle,
    tidy,
  }
end

lemma error_interval_1:
  ∀ h, h ≤ target → error μ target h = μ (Ioc h target) :=
begin
  intros,
  unfold error,
  have SETEQ: error_set h target = Ioc h target,
  {
    unfold error_set,
    unfold Ioc,
    unfold label,
    unfold rle,
    rw ext_iff,
    intro,
    simp at *,
    split; intro,
    {
      rw not_eq_prop at a_1,
      cases a_1; simp at a_1; cases a_1,
      {
        finish,
      },
      {
        split,
        {
          exact lt_of_le_of_lt a a_1_right
        },
        {
          transitivity h; assumption,
        },
      },
    },
    {
      cases a_1,
      finish,
    },
  },
  exact congr_arg μ SETEQ,
end

lemma error_interval_2:
  ∀ h, h > target → error μ target h = μ (Ioc target h) :=
begin
  intros,
  unfold error,
  have SETEQ: error_set h target = Ioc target h,
  {
    unfold error_set,
    unfold Ioc,
    unfold label,
    unfold rle,
    rw ext_iff,
    intro,
    simp at *,
    split; intro,
    {
      rw not_eq_prop at a_1,
      cases a_1; simp at a_1; cases a_1,
      {
        split,
        {
          by_contradiction,
          have FOO: target < x,
          {
            transitivity h; try {assumption},
          },
          contradiction,
        },
        {
          transitivity target; try {assumption},
          have FOO: target < h,
          {
            exact mem_Ioi.mp a,
          },
          exact le_of_lt a,
        },
      },
      {
        split,
        {
          exact mem_Ioi.mp a_1_right,
        },
        {
          assumption,
        },
      },
    },
    {
      cases a_1,
      finish,
    },
  },
  exact congr_arg μ SETEQ,
end

lemma error_mono:
  ∀ c₁, ∀ c₂,
  c₁ ≤ c₂ →
  c₂ ≤ target →
  error μ target c₂ ≤ error μ target c₁ :=
begin
  intros,
  rw error_interval_1,
  rw error_interval_1,
  apply probability_measure.prob_mono,
  exact Ioc_subset_Ioc_left a,
  transitivity c₂; assumption,
  assumption,
end

lemma error_mono_interval:
  ∀ c₁, ∀ c₂,
  c₁ ≤ c₂ →
  c₂ ≤ target →
  μ (Ioc c₂ target) ≤ μ (Ioc c₁ target) :=
begin
  intros,
  rw ← error_interval_1; try {assumption},
  rw ← error_interval_1,
  apply error_mono; try {assumption},
  transitivity c₂; try {assumption},
end

lemma error_max:
  error μ target 0 = μ (Ioc 0 target) :=
begin
  apply error_interval_1,
  tidy,
end

end stump


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Floris van Doorn, Violeta Hernández Palacios
-/

import set_theory.cardinal.ordinal
import set_theory.ordinal.fixed_point

/-!
# Cofinality

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

This file contains the definition of cofinality of an ordinal number and regular cardinals

## Main Definitions

* `ordinal.cof o` is the cofinality of the ordinal `o`.
  If `o` is the order type of the relation `<` on `α`, then `o.cof` is the smallest cardinality of a
  subset `s` of α that is *cofinal* in `α`, i.e. `∀ x : α, ∃ y ∈ s, ¬ y < x`.
* `cardinal.is_limit c` means that `c` is a (weak) limit cardinal: `c ≠ 0 ∧ ∀ x < c, succ x < c`.
* `cardinal.is_strong_limit c` means that `c` is a strong limit cardinal:
  `c ≠ 0 ∧ ∀ x < c, 2 ^ x < c`.
* `cardinal.is_regular c` means that `c` is a regular cardinal: `ℵ₀ ≤ c ∧ c.ord.cof = c`.
* `cardinal.is_inaccessible c` means that `c` is strongly inaccessible:
  `ℵ₀ < c ∧ is_regular c ∧ is_strong_limit c`.

## Main Statements

* `ordinal.infinite_pigeonhole_card`: the infinite pigeonhole principle
* `cardinal.lt_power_cof`: A consequence of König's theorem stating that `c < c ^ c.ord.cof` for
  `c ≥ ℵ₀`
* `cardinal.univ_inaccessible`: The type of ordinals in `Type u` form an inaccessible cardinal
  (in `Type v` with `v > u`). This shows (externally) that in `Type u` there are at least `u`
  inaccessible cardinals.

## Implementation Notes

* The cofinality is defined for ordinals.
  If `c` is a cardinal number, its cofinality is `c.ord.cof`.

## Tags

cofinality, regular cardinals, limits cardinals, inaccessible cardinals,
infinite pigeonhole principle
-/

noncomputable theory

open function cardinal set order
open_locale classical cardinal ordinal

universes u v w
variables {α : Type*} {r : α → α → Prop}

/-! ### Cofinality of orders -/

namespace order

/-- Cofinality of a reflexive order `≼`. This is the smallest cardinality
  of a subset `S : set α` such that `∀ a, ∃ b ∈ S, a ≼ b`. -/
def cof (r : α → α → Prop) : cardinal :=
Inf {c | ∃ S : set α, (∀ a, ∃ b ∈ S, r a b) ∧ #S = c}

/-- The set in the definition of `order.cof` is nonempty. -/
theorem cof_nonempty (r : α → α → Prop) [is_refl α r] :
  {c | ∃ S : set α, (∀ a, ∃ b ∈ S, r a b) ∧ #S = c}.nonempty :=
⟨_, set.univ, λ a, ⟨a, ⟨⟩, refl _⟩, rfl⟩

lemma cof_le (r : α → α → Prop) {S : set α} (h : ∀ a, ∃ b ∈ S, r a b) : cof r ≤ #S :=
cInf_le' ⟨S, h, rfl⟩

lemma le_cof {r : α → α → Prop} [is_refl α r] (c : cardinal) :
  c ≤ cof r ↔ ∀ {S : set α}, (∀ a, ∃ b ∈ S, r a b) → c ≤ #S :=
begin
  rw [cof, le_cInf_iff'' (cof_nonempty r)],
  use λ H S h, H _ ⟨S, h, rfl⟩,
  rintro H d ⟨S, h, rfl⟩,
  exact H h
end

end order

theorem rel_iso.cof_le_lift {α : Type u} {β : Type v} {r : α → α → Prop} {s}
  [is_refl β s] (f : r ≃r s) :
  cardinal.lift.{max u v} (order.cof r) ≤ cardinal.lift.{max u v} (order.cof s) :=
begin
  rw [order.cof, order.cof, lift_Inf, lift_Inf,
    le_cInf_iff'' (nonempty_image_iff.2 (order.cof_nonempty s))],
  rintros - ⟨-, ⟨u, H, rfl⟩, rfl⟩,
  apply cInf_le',
  refine ⟨_, ⟨f.symm '' u, λ a, _, rfl⟩,
    lift_mk_eq.{u v (max u v)}.2 ⟨((f.symm).to_equiv.image u).symm⟩⟩,
  rcases H (f a) with ⟨b, hb, hb'⟩,
  refine ⟨f.symm b, mem_image_of_mem _ hb, f.map_rel_iff.1 _⟩,
  rwa rel_iso.apply_symm_apply
end

theorem rel_iso.cof_eq_lift {α : Type u} {β : Type v} {r s}
  [is_refl α r] [is_refl β s] (f : r ≃r s) :
  cardinal.lift.{max u v} (order.cof r) = cardinal.lift.{max u v} (order.cof s) :=
(rel_iso.cof_le_lift f).antisymm (rel_iso.cof_le_lift f.symm)

theorem rel_iso.cof_le {α β : Type u} {r : α → α → Prop} {s} [is_refl β s] (f : r ≃r s) :
  order.cof r ≤ order.cof s :=
lift_le.1 (rel_iso.cof_le_lift f)

theorem rel_iso.cof_eq {α β : Type u} {r s} [is_refl α r] [is_refl β s] (f : r ≃r s) :
  order.cof r = order.cof s :=
lift_inj.1 (rel_iso.cof_eq_lift f)

/-- Cofinality of a strict order `≺`. This is the smallest cardinality of a set `S : set α` such
that `∀ a, ∃ b ∈ S, ¬ b ≺ a`. -/
def strict_order.cof (r : α → α → Prop) : cardinal :=
order.cof (swap r)ᶜ

/-- The set in the definition of `order.strict_order.cof` is nonempty. -/
theorem strict_order.cof_nonempty (r : α → α → Prop) [is_irrefl α r] :
  {c | ∃ S : set α, unbounded r S ∧ #S = c}.nonempty :=
@order.cof_nonempty α _ (is_refl.swap rᶜ)

/-! ### Cofinality of ordinals -/

namespace ordinal

/-- Cofinality of an ordinal. This is the smallest cardinal of a
  subset `S` of the ordinal which is unbounded, in the sense
  `∀ a, ∃ b ∈ S, a ≤ b`. It is defined for all ordinals, but
  `cof 0 = 0` and `cof (succ o) = 1`, so it is only really
  interesting on limit ordinals (when it is an infinite cardinal). -/
def cof (o : ordinal.{u}) : cardinal.{u} :=
o.lift_on (λ a, strict_order.cof a.r)
begin
  rintros ⟨α, r, wo₁⟩ ⟨β, s, wo₂⟩ ⟨⟨f, hf⟩⟩,
  haveI := wo₁, haveI := wo₂,
  apply @rel_iso.cof_eq _ _ _ _ _ _ ,
  { split, exact λ a b, not_iff_not.2 hf },
  { exact ⟨(is_well_order.is_irrefl r).1⟩ },
  { exact ⟨(is_well_order.is_irrefl s).1⟩ }
end

lemma cof_type (r : α → α → Prop) [is_well_order α r] : (type r).cof = strict_order.cof r := rfl

theorem le_cof_type [is_well_order α r] {c} : c ≤ cof (type r) ↔ ∀ S, unbounded r S → c ≤ #S :=
(le_cInf_iff'' (strict_order.cof_nonempty r)).trans ⟨λ H S h, H _ ⟨S, h, rfl⟩,
  by { rintros H d ⟨S, h, rfl⟩, exact H _ h }⟩

theorem cof_type_le [is_well_order α r] {S : set α} (h : unbounded r S) : cof (type r) ≤ #S :=
le_cof_type.1 le_rfl S h

theorem lt_cof_type [is_well_order α r] {S : set α} : #S < cof (type r) → bounded r S :=
by simpa using not_imp_not.2 cof_type_le

theorem cof_eq (r : α → α → Prop) [is_well_order α r] : ∃ S, unbounded r S ∧ #S = cof (type r) :=
Inf_mem (strict_order.cof_nonempty r)

theorem ord_cof_eq (r : α → α → Prop) [is_well_order α r] :
  ∃ S, unbounded r S ∧ type (subrel r S) = (cof (type r)).ord :=
let ⟨S, hS, e⟩ := cof_eq r, ⟨s, _, e'⟩ := cardinal.ord_eq S,
    T : set α := {a | ∃ aS : a ∈ S, ∀ b : S, s b ⟨_, aS⟩ → r b a} in
begin
  resetI, suffices,
  { refine ⟨T, this,
      le_antisymm _ (cardinal.ord_le.2 $ cof_type_le this)⟩,
    rw [← e, e'],
    refine (rel_embedding.of_monotone (λ a : T, (⟨a, let ⟨aS, _⟩ := a.2 in aS⟩ : S)) (λ a b h, _))
      .ordinal_type_le,
    rcases a with ⟨a, aS, ha⟩, rcases b with ⟨b, bS, hb⟩,
    change s ⟨a, _⟩ ⟨b, _⟩,
    refine ((trichotomous_of s _ _).resolve_left (λ hn, _)).resolve_left _,
    { exact asymm h (ha _ hn) },
    { intro e, injection e with e, subst b,
      exact irrefl _ h } },
  { intro a,
    have : {b : S | ¬ r b a}.nonempty := let ⟨b, bS, ba⟩ := hS a in ⟨⟨b, bS⟩, ba⟩,
    let b := (is_well_founded.wf).min _ this,
    have ba : ¬r b a := (is_well_founded.wf).min_mem _ this,
    refine ⟨b, ⟨b.2, λ c, not_imp_not.1 $ λ h, _⟩, ba⟩,
    rw [show ∀b:S, (⟨b, b.2⟩:S) = b, by intro b; cases b; refl],
    exact (is_well_founded.wf).not_lt_min _ this
      (is_order_connected.neg_trans h ba) }
end

/-! ### Cofinality of suprema and least strict upper bounds -/

private theorem card_mem_cof {o} : ∃ {ι} (f : ι → ordinal), lsub.{u u} f = o ∧ #ι = o.card :=
⟨_, _, lsub_typein o, mk_ordinal_out o⟩

/-- The set in the `lsub` characterization of `cof` is nonempty. -/
theorem cof_lsub_def_nonempty (o) :
  {a : cardinal | ∃ {ι} (f : ι → ordinal), lsub.{u u} f = o ∧ #ι = a}.nonempty :=
⟨_, card_mem_cof⟩

theorem cof_eq_Inf_lsub (o : ordinal.{u}) :
  cof o = Inf {a : cardinal | ∃ {ι : Type u} (f : ι → ordinal), lsub.{u u} f = o ∧ #ι = a} :=
begin
  refine le_antisymm (le_cInf (cof_lsub_def_nonempty o) _) (cInf_le' _),
  { rintros a ⟨ι, f, hf, rfl⟩,
    rw ←type_lt o,
    refine (cof_type_le (λ a, _)).trans (@mk_le_of_injective _ _
      (λ s : (typein ((<) : o.out.α → o.out.α → Prop))⁻¹' (set.range f), classical.some s.prop)
      (λ s t hst, let H := congr_arg f hst in by rwa [classical.some_spec s.prop,
        classical.some_spec t.prop, typein_inj, subtype.coe_inj] at H)),
    have := typein_lt_self a,
    simp_rw [←hf, lt_lsub_iff] at this,
    cases this with i hi,
    refine ⟨enum (<) (f i) _, _, _⟩,
    { rw [type_lt, ←hf], apply lt_lsub },
    { rw [mem_preimage, typein_enum], exact mem_range_self i },
    { rwa [←typein_le_typein, typein_enum] } },
  { rcases cof_eq (<) with ⟨S, hS, hS'⟩,
    let f : S → ordinal := λ s, typein (<) s.val,
    refine ⟨S, f, le_antisymm (lsub_le (λ i, typein_lt_self i)) (le_of_forall_lt (λ a ha, _)),
      by rwa type_lt o at hS'⟩,
    rw ←type_lt o at ha,
    rcases hS (enum (<) a ha) with ⟨b, hb, hb'⟩,
    rw [←typein_le_typein, typein_enum] at hb',
    exact hb'.trans_lt (lt_lsub.{u u} f ⟨b, hb⟩) }
end

@[simp] theorem lift_cof (o) : (cof o).lift = cof o.lift :=
begin
  refine induction_on o _,
  introsI α r _,
  apply le_antisymm,
  { refine le_cof_type.2 (λ S H, _),
    have : (#(ulift.up ⁻¹' S)).lift ≤ #S,
    { rw [← cardinal.lift_umax, ← cardinal.lift_id' (#S)],
      exact mk_preimage_of_injective_lift ulift.up _ ulift.up_injective },
    refine (cardinal.lift_le.2 $ cof_type_le _).trans this,
    exact λ a, let ⟨⟨b⟩, bs, br⟩ := H ⟨a⟩ in ⟨b, bs, br⟩ },
  { rcases cof_eq r with ⟨S, H, e'⟩,
    have : #(ulift.down ⁻¹' S) ≤ (#S).lift :=
     ⟨⟨λ ⟨⟨x⟩, h⟩, ⟨⟨x, h⟩⟩,
       λ ⟨⟨x⟩, h₁⟩ ⟨⟨y⟩, h₂⟩ e, by simp at e; congr; injections⟩⟩,
    rw e' at this,
    unfreezingI { refine (cof_type_le _).trans this },
    exact λ ⟨a⟩, let ⟨b, bs, br⟩ := H a in ⟨⟨b⟩, bs, br⟩ }
end

theorem cof_le_card (o) : cof o ≤ card o :=
by { rw cof_eq_Inf_lsub, exact cInf_le' card_mem_cof }

theorem cof_ord_le (c : cardinal) : c.ord.cof ≤ c :=
by simpa using cof_le_card c.ord

theorem ord_cof_le (o : ordinal.{u}) : o.cof.ord ≤ o :=
(ord_le_ord.2 (cof_le_card o)).trans (ord_card_le o)

theorem exists_lsub_cof (o : ordinal) : ∃ {ι} (f : ι → ordinal), lsub.{u u} f = o ∧ #ι = cof o :=
by { rw cof_eq_Inf_lsub, exact Inf_mem (cof_lsub_def_nonempty o) }

theorem cof_lsub_le {ι} (f : ι → ordinal) : cof (lsub.{u u} f) ≤ #ι :=
by { rw cof_eq_Inf_lsub, exact cInf_le' ⟨ι, f, rfl, rfl⟩ }

theorem cof_lsub_le_lift {ι} (f : ι → ordinal) : cof (lsub f) ≤ cardinal.lift.{v u} (#ι) :=
begin
  rw ←mk_ulift,
  convert cof_lsub_le (λ i : ulift ι, f i.down),
  exact lsub_eq_of_range_eq.{u (max u v) max u v}
    (set.ext (λ x, ⟨λ ⟨i, hi⟩, ⟨ulift.up i, hi⟩, λ ⟨i, hi⟩, ⟨_, hi⟩⟩))
end

theorem le_cof_iff_lsub {o : ordinal} {a : cardinal} :
  a ≤ cof o ↔ ∀ {ι} (f : ι → ordinal), lsub.{u u} f = o → a ≤ #ι :=
begin
  rw cof_eq_Inf_lsub,
  exact (le_cInf_iff'' (cof_lsub_def_nonempty o)).trans ⟨λ H ι f hf, H _ ⟨ι, f, hf, rfl⟩,
    λ H b ⟨ι, f, hf, hb⟩, ( by { rw ←hb, exact H _ hf} )⟩
end

theorem lsub_lt_ord_lift {ι} {f : ι → ordinal} {c : ordinal} (hι : cardinal.lift (#ι) < c.cof)
  (hf : ∀ i, f i < c) : lsub.{u v} f < c :=
lt_of_le_of_ne (lsub_le hf) (λ h, by { subst h, exact (cof_lsub_le_lift f).not_lt hι })

theorem lsub_lt_ord {ι} {f : ι → ordinal} {c : ordinal} (hι : #ι < c.cof) :
  (∀ i, f i < c) → lsub.{u u} f < c :=
lsub_lt_ord_lift (by rwa (#ι).lift_id)

theorem cof_sup_le_lift {ι} {f : ι → ordinal} (H : ∀ i, f i < sup f) : cof (sup f) ≤ (#ι).lift :=
by { rw ←sup_eq_lsub_iff_lt_sup at H, rw H, exact cof_lsub_le_lift f }

theorem cof_sup_le {ι} {f : ι → ordinal} (H : ∀ i, f i < sup.{u u} f) : cof (sup.{u u} f) ≤ #ι :=
by { rw ←(#ι).lift_id, exact cof_sup_le_lift H }

theorem sup_lt_ord_lift {ι} {f : ι → ordinal} {c : ordinal} (hι : cardinal.lift (#ι) < c.cof)
  (hf : ∀ i, f i < c) : sup.{u v} f < c :=
(sup_le_lsub.{u v} f).trans_lt (lsub_lt_ord_lift hι hf)

theorem sup_lt_ord {ι} {f : ι → ordinal} {c : ordinal} (hι : #ι < c.cof) :
  (∀ i, f i < c) → sup.{u u} f < c :=
sup_lt_ord_lift (by rwa (#ι).lift_id)

theorem supr_lt_lift {ι} {f : ι → cardinal} {c : cardinal} (hι : cardinal.lift (#ι) < c.ord.cof)
  (hf : ∀ i, f i < c) : supr f < c :=
begin
  rw [←ord_lt_ord, supr_ord (cardinal.bdd_above_range _)],
  refine sup_lt_ord_lift hι (λ i, _),
  rw ord_lt_ord,
  apply hf
end

theorem supr_lt {ι} {f : ι → cardinal} {c : cardinal} (hι : #ι < c.ord.cof) :
  (∀ i, f i < c) → supr f < c :=
supr_lt_lift (by rwa (#ι).lift_id)

theorem nfp_family_lt_ord_lift {ι} {f : ι → ordinal → ordinal} {c} (hc : ℵ₀ < cof c)
  (hc' : (#ι).lift < cof c) (hf : ∀ i (b < c), f i b < c) {a} (ha : a < c) :
  nfp_family.{u v} f a < c :=
begin
  refine sup_lt_ord_lift ((cardinal.lift_le.2 (mk_list_le_max ι)).trans_lt _) (λ l, _),
  { rw lift_max,
    apply max_lt _ hc',
    rwa cardinal.lift_aleph_0 },
  { induction l with i l H,
    { exact ha },
    { exact hf _ _ H } }
end

theorem nfp_family_lt_ord {ι} {f : ι → ordinal → ordinal} {c} (hc : ℵ₀ < cof c)
  (hc' : #ι < cof c) (hf : ∀ i (b < c), f i b < c) {a} : a < c → nfp_family.{u u} f a < c :=
nfp_family_lt_ord_lift hc (by rwa (#ι).lift_id) hf

theorem nfp_bfamily_lt_ord_lift {o : ordinal} {f : Π a < o, ordinal → ordinal} {c} (hc : ℵ₀ < cof c)
  (hc' : o.card.lift < cof c) (hf : ∀ i hi (b < c), f i hi b < c) {a} :
  a < c → nfp_bfamily.{u v} o f a < c :=
nfp_family_lt_ord_lift hc (by rwa mk_ordinal_out) (λ i, hf _ _)

theorem nfp_bfamily_lt_ord {o : ordinal} {f : Π a < o, ordinal → ordinal} {c} (hc : ℵ₀ < cof c)
  (hc' : o.card < cof c) (hf : ∀ i hi (b < c), f i hi b < c) {a} :
  a < c → nfp_bfamily.{u u} o f a < c :=
nfp_bfamily_lt_ord_lift hc (by rwa o.card.lift_id) hf

theorem nfp_lt_ord {f : ordinal → ordinal} {c} (hc : ℵ₀ < cof c) (hf : ∀ i < c, f i < c) {a} :
  a < c → nfp f a < c :=
nfp_family_lt_ord_lift hc (by simpa using cardinal.one_lt_aleph_0.trans hc) (λ _, hf)

theorem exists_blsub_cof (o : ordinal) : ∃ (f : Π a < (cof o).ord, ordinal), blsub.{u u} _ f = o :=
begin
  rcases exists_lsub_cof o with ⟨ι, f, hf, hι⟩,
  rcases cardinal.ord_eq ι with ⟨r, hr, hι'⟩,
  rw ←@blsub_eq_lsub' ι r hr at hf,
  rw [←hι, hι'],
  exact ⟨_, hf⟩
end

theorem cof_blsub_le_lift {o} (f : Π a < o, ordinal) :
  cof (blsub o f) ≤ cardinal.lift.{v u} (o.card) :=
by { convert cof_lsub_le_lift _, exact (mk_ordinal_out o).symm }

theorem cof_blsub_le {o} (f : Π a < o, ordinal) : cof (blsub.{u u} o f) ≤ o.card :=
by { rw ←(o.card).lift_id, exact cof_blsub_le_lift f }

theorem blsub_lt_ord_lift {o : ordinal} {f : Π a < o, ordinal} {c : ordinal}
  (ho : o.card.lift < c.cof) (hf : ∀ i hi, f i hi < c) : blsub.{u v} o f < c :=
lt_of_le_of_ne (blsub_le hf) (λ h, ho.not_le
  (by simpa [←supr_ord, hf, h] using cof_blsub_le_lift.{u} f))

theorem blsub_lt_ord {o : ordinal} {f : Π a < o, ordinal} {c : ordinal} (ho : o.card < c.cof)
  (hf : ∀ i hi, f i hi < c) : blsub.{u u} o f < c :=
blsub_lt_ord_lift (by rwa (o.card).lift_id) hf

theorem cof_bsup_le_lift {o : ordinal} {f : Π a < o, ordinal} (H : ∀ i h, f i h < bsup o f) :
  cof (bsup o f) ≤ o.card.lift :=
by { rw ←bsup_eq_blsub_iff_lt_bsup at H, rw H, exact cof_blsub_le_lift f }

theorem cof_bsup_le {o : ordinal} {f : Π a < o, ordinal} :
  (∀ i h, f i h < bsup.{u u} o f) → cof (bsup.{u u} o f) ≤ o.card :=
by { rw ←(o.card).lift_id, exact cof_bsup_le_lift }

theorem bsup_lt_ord_lift {o : ordinal} {f : Π a < o, ordinal} {c : ordinal}
  (ho : o.card.lift < c.cof) (hf : ∀ i hi, f i hi < c) : bsup.{u v} o f < c :=
(bsup_le_blsub f).trans_lt (blsub_lt_ord_lift ho hf)

theorem bsup_lt_ord {o : ordinal} {f : Π a < o, ordinal} {c : ordinal} (ho : o.card < c.cof) :
  (∀ i hi, f i hi < c) → bsup.{u u} o f < c :=
bsup_lt_ord_lift (by rwa (o.card).lift_id)

/-! ### Basic results -/

@[simp] theorem cof_zero : cof 0 = 0 :=
(cof_le_card 0).antisymm (cardinal.zero_le _)

@[simp] theorem cof_eq_zero {o} : cof o = 0 ↔ o = 0 :=
⟨induction_on o $ λ α r _ z, by exactI
  let ⟨S, hl, e⟩ := cof_eq r in type_eq_zero_iff_is_empty.2 $
  ⟨λ a, let ⟨b, h, _⟩ := hl a in
    (mk_eq_zero_iff.1 (e.trans z)).elim' ⟨_, h⟩⟩,
λ e, by simp [e]⟩

theorem cof_ne_zero {o} : cof o ≠ 0 ↔ o ≠ 0 := cof_eq_zero.not

@[simp] theorem cof_succ (o) : cof (succ o) = 1 :=
begin
  apply le_antisymm,
  { refine induction_on o (λ α r _, _),
    change cof (type _) ≤ _,
    rw [← (_ : #_ = 1)], apply cof_type_le,
    { refine λ a, ⟨sum.inr punit.star, set.mem_singleton _, _⟩,
      rcases a with a|⟨⟨⟨⟩⟩⟩; simp [empty_relation] },
    { rw [cardinal.mk_fintype, set.card_singleton], simp } },
  { rw [← cardinal.succ_zero, succ_le_iff],
    simpa [lt_iff_le_and_ne, cardinal.zero_le] using
      λ h, succ_ne_zero o (cof_eq_zero.1 (eq.symm h)) }
end

@[simp] theorem cof_eq_one_iff_is_succ {o} : cof.{u} o = 1 ↔ ∃ a, o = succ a :=
⟨induction_on o $ λ α r _ z, begin
  resetI,
  rcases cof_eq r with ⟨S, hl, e⟩, rw z at e,
  cases mk_ne_zero_iff.1 (by rw e; exact one_ne_zero) with a,
  refine ⟨typein r a, eq.symm $ quotient.sound
    ⟨rel_iso.of_surjective (rel_embedding.of_monotone _
      (λ x y, _)) (λ x, _)⟩⟩,
  { apply sum.rec; [exact subtype.val, exact λ _, a] },
  { rcases x with x|⟨⟨⟨⟩⟩⟩; rcases y with y|⟨⟨⟨⟩⟩⟩;
      simp [subrel, order.preimage, empty_relation],
    exact x.2 },
  { suffices : r x a ∨ ∃ (b : punit), ↑a = x, {simpa},
    rcases trichotomous_of r x a with h|h|h,
    { exact or.inl h },
    { exact or.inr ⟨punit.star, h.symm⟩ },
    { rcases hl x with ⟨a', aS, hn⟩,
      rw (_ : ↑a = a') at h, {exact absurd h hn},
      refine congr_arg subtype.val (_ : a = ⟨a', aS⟩),
      haveI := le_one_iff_subsingleton.1 (le_of_eq e),
      apply subsingleton.elim } }
end, λ ⟨a, e⟩, by simp [e]⟩

/-- A fundamental sequence for `a` is an increasing sequence of length `o = cof a` that converges at
    `a`. We provide `o` explicitly in order to avoid type rewrites. -/
def is_fundamental_sequence (a o : ordinal.{u}) (f : Π b < o, ordinal.{u}) : Prop :=
o ≤ a.cof.ord ∧ (∀ {i j} (hi hj), i < j → f i hi < f j hj) ∧ blsub.{u u} o f = a

namespace is_fundamental_sequence
variables {a o : ordinal.{u}} {f : Π b < o, ordinal.{u}}

protected theorem cof_eq (hf : is_fundamental_sequence a o f) : a.cof.ord = o :=
hf.1.antisymm' $ by { rw ←hf.2.2, exact (ord_le_ord.2 (cof_blsub_le f)).trans (ord_card_le o) }

protected theorem strict_mono (hf : is_fundamental_sequence a o f) {i j} :
  ∀ hi hj, i < j → f i hi < f j hj :=
hf.2.1

theorem blsub_eq (hf : is_fundamental_sequence a o f) : blsub.{u u} o f = a :=
hf.2.2

theorem ord_cof (hf : is_fundamental_sequence a o f) :
  is_fundamental_sequence a a.cof.ord (λ i hi, f i (hi.trans_le (by rw hf.cof_eq))) :=
by { have H := hf.cof_eq, subst H, exact hf }

theorem id_of_le_cof (h : o ≤ o.cof.ord) : is_fundamental_sequence o o (λ a _, a) :=
⟨h, λ _ _ _ _, id, blsub_id o⟩

protected theorem zero {f : Π b < (0 : ordinal), ordinal} :
  is_fundamental_sequence 0 0 f :=
⟨by rw [cof_zero, ord_zero], λ i j hi, (ordinal.not_lt_zero i hi).elim, blsub_zero f⟩

protected theorem succ : is_fundamental_sequence (succ o) 1 (λ _ _, o) :=
begin
  refine ⟨_, λ i j hi hj h, _, blsub_const ordinal.one_ne_zero o⟩,
  { rw [cof_succ, ord_one] },
  { rw lt_one_iff_zero at hi hj,
    rw [hi, hj] at h,
    exact h.false.elim }
end

protected theorem monotone (hf : is_fundamental_sequence a o f) {i j : ordinal} (hi : i < o)
  (hj : j < o) (hij : i ≤ j) : f i hi ≤ f j hj :=
begin
  rcases lt_or_eq_of_le hij with hij | rfl,
  { exact (hf.2.1 hi hj hij).le },
  { refl }
end

theorem trans {a o o' : ordinal.{u}} {f : Π b < o, ordinal.{u}}
  (hf : is_fundamental_sequence a o f) {g : Π b < o', ordinal.{u}}
  (hg : is_fundamental_sequence o o' g) :
  is_fundamental_sequence a o' (λ i hi, f (g i hi) (by { rw ←hg.2.2, apply lt_blsub })) :=
begin
  refine ⟨_, λ i j _ _ h, hf.2.1 _ _ (hg.2.1 _ _ h), _⟩,
  { rw hf.cof_eq,
    exact hg.1.trans (ord_cof_le o) },
  { rw @blsub_comp.{u u u} o _ f (@is_fundamental_sequence.monotone _ _ f hf),
    exact hf.2.2 }
end

end is_fundamental_sequence

/-- Every ordinal has a fundamental sequence. -/
theorem exists_fundamental_sequence (a : ordinal.{u}) :
  ∃ f, is_fundamental_sequence a a.cof.ord f :=
begin
  rsuffices ⟨o, f, hf⟩ : ∃ o f, is_fundamental_sequence a o f,
  { exact ⟨_, hf.ord_cof⟩ },
  rcases exists_lsub_cof a with ⟨ι, f, hf, hι⟩,
  rcases ord_eq ι with ⟨r, wo, hr⟩,
  haveI := wo,
  let r' := subrel r {i | ∀ j, r j i → f j < f i},
  let hrr' : r' ↪r r := subrel.rel_embedding _ _,
  haveI := hrr'.is_well_order,
  refine ⟨_, _, hrr'.ordinal_type_le.trans _, λ i j _ h _, (enum r' j h).prop _ _,
    le_antisymm (blsub_le (λ i hi, lsub_le_iff.1 hf.le _)) _⟩,
  { rw [←hι, hr] },
  { change r (hrr'.1 _ ) (hrr'.1 _ ),
    rwa [hrr'.2, @enum_lt_enum _ r'] },
  { rw [←hf, lsub_le_iff],
    intro i,
    rsuffices ⟨i', hi', hfg⟩ : ∃ i' hi', f i ≤ bfamily_of_family' r' (λ i, f i) i' hi',
    { exact hfg.trans_lt (lt_blsub _ _ _) },
    by_cases h : ∀ j, r j i → f j < f i,
    { refine ⟨typein r' ⟨i, h⟩, typein_lt_type _ _, _⟩,
      rw bfamily_of_family'_typein,
      refl },
    { push_neg at h,
      cases wo.wf.min_mem _ h with hji hij,
      refine ⟨typein r' ⟨_, λ k hkj, lt_of_lt_of_le _ hij⟩, typein_lt_type _ _, _⟩,
      { by_contra' H,
        exact (wo.wf.not_lt_min _ h ⟨is_trans.trans _ _ _ hkj hji, H⟩) hkj },
      { rwa bfamily_of_family'_typein } } }
end

@[simp] theorem cof_cof (a : ordinal.{u}) : cof (cof a).ord = cof a :=
begin
  cases exists_fundamental_sequence a with f hf,
  cases exists_fundamental_sequence a.cof.ord with g hg,
  exact ord_injective ((hf.trans hg).cof_eq.symm)
end

protected theorem is_normal.is_fundamental_sequence {f : ordinal.{u} → ordinal.{u}}
  (hf : is_normal f) {a o} (ha : is_limit a) {g} (hg : is_fundamental_sequence a o g) :
  is_fundamental_sequence (f a) o (λ b hb, f (g b hb)) :=
begin
  refine ⟨_, λ i j _ _ h, hf.strict_mono (hg.2.1 _ _ h), _⟩,
  { rcases exists_lsub_cof (f a) with ⟨ι, f', hf', hι⟩,
    rw [←hg.cof_eq, ord_le_ord, ←hι],
    suffices : lsub.{u u} (λ i, (Inf {b : ordinal | f' i ≤ f b})) = a,
    { rw ←this,
      apply cof_lsub_le },
    have H : ∀ i, ∃ b < a, f' i ≤ f b := λ i, begin
      have := lt_lsub.{u u} f' i,
      rwa [hf', ←is_normal.blsub_eq.{u u} hf ha, lt_blsub_iff] at this
    end,
    refine (lsub_le (λ i, _)).antisymm (le_of_forall_lt (λ b hb, _)),
    { rcases H i with ⟨b, hb, hb'⟩,
      exact lt_of_le_of_lt (cInf_le' hb') hb },
    { have := hf.strict_mono hb,
      rw [←hf', lt_lsub_iff] at this,
      cases this with i hi,
      rcases H i with ⟨b, _, hb⟩,
      exact ((le_cInf_iff'' ⟨b, hb⟩).2 (λ c hc, hf.strict_mono.le_iff_le.1 (hi.trans hc))).trans_lt
        (lt_lsub _ i) } },
  { rw @blsub_comp.{u u u} a _ (λ b _, f b) (λ i j hi hj h, hf.strict_mono.monotone h) g hg.2.2,
    exact is_normal.blsub_eq.{u u} hf ha }
end

theorem is_normal.cof_eq {f} (hf : is_normal f) {a} (ha : is_limit a) : cof (f a) = cof a :=
let ⟨g, hg⟩ := exists_fundamental_sequence a in
  ord_injective (hf.is_fundamental_sequence ha hg).cof_eq

theorem is_normal.cof_le {f} (hf : is_normal f) (a) : cof a ≤ cof (f a) :=
begin
  rcases zero_or_succ_or_limit a with rfl | ⟨b, rfl⟩ | ha,
  { rw cof_zero,
    exact zero_le _ },
  { rw [cof_succ, cardinal.one_le_iff_ne_zero, cof_ne_zero, ←ordinal.pos_iff_ne_zero],
    exact (ordinal.zero_le (f b)).trans_lt (hf.1 b) },
  { rw hf.cof_eq ha }
end

@[simp] theorem cof_add (a b : ordinal) : b ≠ 0 → cof (a + b) = cof b :=
λ h, begin
  rcases zero_or_succ_or_limit b with rfl | ⟨c, rfl⟩ | hb,
  { contradiction },
  { rw [add_succ, cof_succ, cof_succ] },
  { exact (add_is_normal a).cof_eq hb }
end

theorem aleph_0_le_cof {o} : ℵ₀ ≤ cof o ↔ is_limit o :=
begin
  rcases zero_or_succ_or_limit o with rfl|⟨o,rfl⟩|l,
  { simp [not_zero_is_limit, cardinal.aleph_0_ne_zero] },
  { simp [not_succ_is_limit, cardinal.one_lt_aleph_0] },
  { simp [l], refine le_of_not_lt (λ h, _),
    cases cardinal.lt_aleph_0.1 h with n e,
    have := cof_cof o,
    rw [e, ord_nat] at this,
    cases n,
    { simp at e, simpa [e, not_zero_is_limit] using l },
    { rw [nat_cast_succ, cof_succ] at this,
      rw [← this, cof_eq_one_iff_is_succ] at e,
      rcases e with ⟨a, rfl⟩,
      exact not_succ_is_limit _ l } }
end

@[simp] theorem aleph'_cof {o : ordinal} (ho : o.is_limit) : (aleph' o).ord.cof = o.cof :=
aleph'_is_normal.cof_eq ho

@[simp] theorem aleph_cof {o : ordinal} (ho : o.is_limit) : (aleph o).ord.cof = o.cof :=
aleph_is_normal.cof_eq ho

@[simp] theorem cof_omega : cof ω = ℵ₀ :=
(aleph_0_le_cof.2 omega_is_limit).antisymm' $ by { rw ←card_omega, apply cof_le_card }

theorem cof_eq' (r : α → α → Prop) [is_well_order α r] (h : is_limit (type r)) :
  ∃ S : set α, (∀ a, ∃ b ∈ S, r a b) ∧ #S = cof (type r) :=
let ⟨S, H, e⟩ := cof_eq r in
⟨S, λ a,
  let a' := enum r _ (h.2 _ (typein_lt_type r a)) in
  let ⟨b, h, ab⟩ := H a' in
  ⟨b, h, (is_order_connected.conn a b a' $ (typein_lt_typein r).1
    (by { rw typein_enum, exact lt_succ (typein _ _) })).resolve_right ab⟩,
e⟩

@[simp] theorem cof_univ : cof univ.{u v} = cardinal.univ :=
le_antisymm (cof_le_card _) begin
  refine le_of_forall_lt (λ c h, _),
  rcases lt_univ'.1 h with ⟨c, rfl⟩,
  rcases @cof_eq ordinal.{u} (<) _ with ⟨S, H, Se⟩,
  rw [univ, ← lift_cof, ← cardinal.lift_lift, cardinal.lift_lt, ← Se],
  refine lt_of_not_ge (λ h, _),
  cases cardinal.lift_down h with a e,
  refine quotient.induction_on a (λ α e, _) e,
  cases quotient.exact e with f,
  have f := equiv.ulift.symm.trans f,
  let g := λ a, (f a).1,
  let o := succ (sup.{u u} g),
  rcases H o with ⟨b, h, l⟩,
  refine l (lt_succ_iff.2 _),
  rw ← show g (f.symm ⟨b, h⟩) = b, by dsimp [g]; simp,
  apply le_sup
end

/-! ### Infinite pigeonhole principle -/

/-- If the union of s is unbounded and s is smaller than the cofinality,
  then s has an unbounded member -/
theorem unbounded_of_unbounded_sUnion (r : α → α → Prop) [wo : is_well_order α r] {s : set (set α)}
  (h₁ : unbounded r $ ⋃₀ s) (h₂ : #s < strict_order.cof r) : ∃ x ∈ s, unbounded r x :=
begin
  by_contra' h,
  simp_rw not_unbounded_iff at h,
  let f : s → α := λ x : s, wo.wf.sup x (h x.1 x.2),
  refine h₂.not_le (le_trans (cInf_le' ⟨range f, λ x, _, rfl⟩) mk_range_le),
  rcases h₁ x with ⟨y, ⟨c, hc, hy⟩, hxy⟩,
  exact ⟨f ⟨c, hc⟩, mem_range_self _, λ hxz, hxy (trans (wo.wf.lt_sup _ hy) hxz)⟩
end

/-- If the union of s is unbounded and s is smaller than the cofinality,
  then s has an unbounded member -/
theorem unbounded_of_unbounded_Union {α β : Type u} (r : α → α → Prop) [wo : is_well_order α r]
  (s : β → set α)
  (h₁ : unbounded r $ ⋃ x, s x) (h₂ : #β < strict_order.cof r) : ∃ x : β, unbounded r (s x) :=
begin
  rw ←sUnion_range at h₁,
  rcases unbounded_of_unbounded_sUnion r h₁ (mk_range_le.trans_lt h₂) with ⟨_, ⟨x, rfl⟩, u⟩,
  exact ⟨x, u⟩
end

/-- The infinite pigeonhole principle -/
theorem infinite_pigeonhole {β α : Type u} (f : β → α) (h₁ : ℵ₀ ≤ #β)
  (h₂ : #α < (#β).ord.cof) : ∃ a : α, #(f ⁻¹' {a}) = #β :=
begin
  have : ∃ a, #β ≤ #(f ⁻¹' {a}),
  { by_contra' h,
    apply mk_univ.not_lt,
    rw [←preimage_univ, ←Union_of_singleton, preimage_Union],
    exact mk_Union_le_sum_mk.trans_lt ((sum_le_supr _).trans_lt $ mul_lt_of_lt h₁
      (h₂.trans_le $ cof_ord_le _) (supr_lt h₂ h)) },
  cases this with x h,
  refine ⟨x, h.antisymm' _⟩,
  rw le_mk_iff_exists_set,
  exact ⟨_, rfl⟩
end

/-- Pigeonhole principle for a cardinality below the cardinality of the domain -/
theorem infinite_pigeonhole_card {β α : Type u} (f : β → α) (θ : cardinal) (hθ : θ ≤ #β)
  (h₁ : ℵ₀ ≤ θ) (h₂ : #α < θ.ord.cof) : ∃ a : α, θ ≤ #(f ⁻¹' {a}) :=
begin
  rcases le_mk_iff_exists_set.1 hθ with ⟨s, rfl⟩,
  cases infinite_pigeonhole (f ∘ subtype.val : s → α) h₁ h₂ with a ha,
  use a, rw [←ha, @preimage_comp _ _ _ subtype.val f],
  exact mk_preimage_of_injective _ _ subtype.val_injective
end

theorem infinite_pigeonhole_set {β α : Type u} {s : set β} (f : s → α) (θ : cardinal)
  (hθ : θ ≤ #s) (h₁ : ℵ₀ ≤ θ) (h₂ : #α < θ.ord.cof) :
    ∃ (a : α) (t : set β) (h : t ⊆ s), θ ≤ #t ∧ ∀ {{x}} (hx : x ∈ t), f ⟨x, h hx⟩ = a :=
begin
  cases infinite_pigeonhole_card f θ hθ h₁ h₂ with a ha,
  refine ⟨a, {x | ∃ h, f ⟨x, h⟩ = a}, _, _, _⟩,
  { rintro x ⟨hx, hx'⟩, exact hx },
  { refine ha.trans (ge_of_eq $ quotient.sound ⟨equiv.trans _
      (equiv.subtype_subtype_equiv_subtype_exists _ _).symm⟩),
    simp only [coe_eq_subtype, mem_singleton_iff, mem_preimage, mem_set_of_eq] },
  rintro x ⟨hx, hx'⟩, exact hx'
end

end ordinal

/-! ### Regular and inaccessible cardinals -/

namespace cardinal
open ordinal

local infixr (name := cardinal.pow) ^ := @pow cardinal.{u} cardinal cardinal.has_pow

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

theorem is_limit.ne_zero {c} (h : is_limit c) : c ≠ 0 :=
h.1

theorem is_limit.succ_lt {x c} (h : is_limit c) : x < c → succ x < c :=
h.2 x

theorem is_limit.aleph_0_le {c} (h : is_limit c) : ℵ₀ ≤ c :=
begin
  by_contra' h',
  rcases lt_aleph_0.1 h' with ⟨_ | n, rfl⟩,
  { exact h.1.irrefl },
  { simpa using h.2 n }
end

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

theorem is_strong_limit.ne_zero {c} (h : is_strong_limit c) : c ≠ 0 :=
h.1

theorem is_strong_limit.two_power_lt {x c} (h : is_strong_limit c) : x < c → 2 ^ x < c :=
h.2 x

theorem is_strong_limit_aleph_0 : is_strong_limit ℵ₀ :=
⟨aleph_0_ne_zero, λ x hx, begin
  rcases lt_aleph_0.1 hx with ⟨n, rfl⟩,
  exact_mod_cast nat_lt_aleph_0 (pow 2 n)
end⟩

theorem is_strong_limit.is_limit {c} (H : is_strong_limit c) : is_limit c :=
⟨H.1, λ x h, (succ_le_of_lt $ cantor x).trans_lt (H.2 _ h)⟩

theorem is_limit_aleph_0 : is_limit ℵ₀ :=
is_strong_limit_aleph_0.is_limit

theorem is_strong_limit_beth {o : ordinal} (H : ∀ a < o, succ a < o) : is_strong_limit (beth o) :=
begin
  rcases eq_or_ne o 0 with rfl | h,
  { rw beth_zero,
    exact is_strong_limit_aleph_0 },
  { refine ⟨beth_ne_zero o, λ a ha, _⟩,
    rw beth_limit ⟨h, H⟩ at ha,
    rcases exists_lt_of_lt_csupr' ha with ⟨⟨i, hi⟩, ha⟩,
    have := power_le_power_left two_ne_zero ha.le,
    rw ←beth_succ at this,
    exact this.trans_lt (beth_lt.2 (H i hi)) }
end

theorem mk_bounded_subset {α : Type*} (h : ∀ x < #α, 2 ^ x < #α) {r : α → α → Prop}
  [is_well_order α r] (hr : (#α).ord = type r) : #{s : set α // bounded r s} = #α :=
begin
  rcases eq_or_ne (#α) 0 with ha | ha,
  { rw ha,
    haveI := mk_eq_zero_iff.1 ha,
    rw mk_eq_zero_iff,
    split,
    rintro ⟨s, hs⟩,
    exact (not_unbounded_iff s).2 hs (unbounded_of_is_empty s) },
  have h' : is_strong_limit (#α) := ⟨ha, h⟩,
  have ha := h'.is_limit.aleph_0_le,
  apply le_antisymm,
  { have : {s : set α | bounded r s} = ⋃ i, 𝒫 {j | r j i} := set_of_exists _,
    rw [←coe_set_of, this],
    convert mk_Union_le_sum_mk.trans ((sum_le_supr _).trans (mul_le_max_of_aleph_0_le_left ha)),
    apply (max_eq_left _).symm, apply csupr_le' (λ i, _),
    rw mk_powerset,
    apply (h'.two_power_lt _).le,
    rw [coe_set_of, card_typein, ←lt_ord, hr],
    apply typein_lt_type },
  { refine @mk_le_of_injective α _ (λ x, subtype.mk {x} _) _,
    { apply bounded_singleton,
      rw ←hr,
      apply ord_is_limit ha },
    { intros a b hab,
      simpa only [singleton_eq_singleton_iff] using hab } }
end

theorem mk_subset_mk_lt_cof {α : Type*} (h : ∀ x < #α, 2 ^ x < #α) :
  #{s : set α // #s < cof (#α).ord} = #α :=
begin
  rcases eq_or_ne (#α) 0 with ha | ha,
  { rw ha,
    simp [λ s, (cardinal.zero_le s).not_lt] },
  have h' : is_strong_limit (#α) := ⟨ha, h⟩,
  rcases ord_eq α with ⟨r, wo, hr⟩,
  haveI := wo,
  apply le_antisymm,
  { nth_rewrite_rhs 0 ←mk_bounded_subset h hr,
    apply mk_le_mk_of_subset (λ s hs, _),
    rw hr at hs,
    exact lt_cof_type hs },
  { refine @mk_le_of_injective α _ (λ x, subtype.mk {x} _) _,
    { rw mk_singleton,
      exact one_lt_aleph_0.trans_le (aleph_0_le_cof.2 (ord_is_limit h'.is_limit.aleph_0_le)) },
    { intros a b hab,
      simpa only [singleton_eq_singleton_iff] using hab } }
end

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

lemma is_regular.aleph_0_le {c : cardinal} (H : c.is_regular) : ℵ₀ ≤ c :=
H.1

lemma is_regular.cof_eq {c : cardinal} (H : c.is_regular) : c.ord.cof = c :=
(cof_ord_le c).antisymm H.2

lemma is_regular.pos {c : cardinal} (H : c.is_regular) : 0 < c :=
aleph_0_pos.trans_le H.1

lemma is_regular.ord_pos {c : cardinal} (H : c.is_regular) : 0 < c.ord :=
by { rw cardinal.lt_ord, exact H.pos }

theorem is_regular_cof {o : ordinal} (h : o.is_limit) : is_regular o.cof :=
⟨aleph_0_le_cof.2 h, (cof_cof o).ge⟩

theorem is_regular_aleph_0 : is_regular ℵ₀ :=
⟨le_rfl, by simp⟩

theorem is_regular_succ {c : cardinal.{u}} (h : ℵ₀ ≤ c) : is_regular (succ c) :=
⟨h.trans (le_succ c), succ_le_of_lt begin
  cases quotient.exists_rep (@succ cardinal _ _ c) with α αe, simp at αe,
  rcases ord_eq α with ⟨r, wo, re⟩, resetI,
  have := ord_is_limit (h.trans (le_succ _)),
  rw [← αe, re] at this ⊢,
  rcases cof_eq' r this with ⟨S, H, Se⟩,
  rw [← Se],
  apply lt_imp_lt_of_le_imp_le (λ h, mul_le_mul_right' h c),
  rw [mul_eq_self h, ← succ_le_iff, ← αe, ← sum_const'],
  refine le_trans _ (sum_le_sum (λ x, card (typein r x)) _ (λ i, _)),
  { simp only [← card_typein, ← mk_sigma],
    exact ⟨embedding.of_surjective (λ x, x.2.1)
      (λ a, let ⟨b, h, ab⟩ := H a in ⟨⟨⟨_, h⟩, _, ab⟩, rfl⟩)⟩ },
  { rw [← lt_succ_iff, ← lt_ord, ← αe, re],
    apply typein_lt_type }
end⟩

theorem is_regular_aleph_one : is_regular (aleph 1) :=
by { rw ←succ_aleph_0, exact is_regular_succ le_rfl }

theorem is_regular_aleph'_succ {o : ordinal} (h : ω ≤ o) : is_regular (aleph' (succ o)) :=
by { rw aleph'_succ, exact is_regular_succ (aleph_0_le_aleph'.2 h) }

theorem is_regular_aleph_succ (o : ordinal) : is_regular (aleph (succ o)) :=
by { rw aleph_succ, exact is_regular_succ (aleph_0_le_aleph o) }

/--
A function whose codomain's cardinality is infinite but strictly smaller than its domain's
has a fiber with cardinality strictly great than the codomain.
-/
theorem infinite_pigeonhole_card_lt {β α : Type u} (f : β → α)
  (w : #α < #β) (w' : ℵ₀ ≤ #α) :
  ∃ a : α, #α < #(f ⁻¹' {a}) :=
begin
  simp_rw [← succ_le_iff],
  exact ordinal.infinite_pigeonhole_card f (succ (#α)) (succ_le_of_lt w)
    (w'.trans (lt_succ _).le)
    ((lt_succ _).trans_le (is_regular_succ w').2.ge),
end

/--
A function whose codomain's cardinality is infinite but strictly smaller than its domain's
has an infinite fiber.
-/
theorem exists_infinite_fiber {β α : Type*} (f : β → α)
  (w : #α < #β) (w' : _root_.infinite α) :
  ∃ a : α, _root_.infinite (f ⁻¹' {a}) :=
begin
  simp_rw [cardinal.infinite_iff] at ⊢ w',
  cases infinite_pigeonhole_card_lt f w w' with a ha,
  exact ⟨a, w'.trans ha.le⟩,
end

/--
If an infinite type `β` can be expressed as a union of finite sets,
then the cardinality of the collection of those finite sets
must be at least the cardinality of `β`.
-/
lemma le_range_of_union_finset_eq_top
  {α β : Type*} [infinite β] (f : α → finset β) (w : (⋃ a, (f a : set β)) = ⊤) :
  #β ≤ #(range f) :=
begin
  have k : _root_.infinite (range f),
  { rw infinite_coe_iff,
    apply mt (union_finset_finite_of_range_finite f),
    rw w,
    exact infinite_univ, },
  by_contradiction h,
  simp only [not_le] at h,
  let u : Π b, ∃ a, b ∈ f a := λ b, by simpa using (w.ge : _) (set.mem_univ b),
  let u' : β → range f := λ b, ⟨f (u b).some, by simp⟩,
  have v' : ∀ a, u' ⁻¹' {⟨f a, by simp⟩} ≤ f a, begin rintros a p m,
    simp at m,
    rw ←m,
    apply (λ b, (u b).some_spec),
  end,
  obtain ⟨⟨-, ⟨a, rfl⟩⟩, p⟩ := exists_infinite_fiber u' h k,
  exact (@infinite.of_injective _ _ p (inclusion (v' a)) (inclusion_injective _)).false,
end

theorem lsub_lt_ord_lift_of_is_regular {ι} {f : ι → ordinal} {c} (hc : is_regular c)
  (hι : cardinal.lift (#ι) < c) : (∀ i, f i < c.ord) → ordinal.lsub f < c.ord :=
lsub_lt_ord_lift (by rwa hc.cof_eq)

theorem lsub_lt_ord_of_is_regular {ι} {f : ι → ordinal} {c} (hc : is_regular c) (hι : #ι < c) :
  (∀ i, f i < c.ord) → ordinal.lsub f < c.ord :=
lsub_lt_ord (by rwa hc.cof_eq)

theorem sup_lt_ord_lift_of_is_regular {ι} {f : ι → ordinal} {c} (hc : is_regular c)
  (hι : cardinal.lift (#ι) < c) : (∀ i, f i < c.ord) → ordinal.sup f < c.ord :=
sup_lt_ord_lift (by rwa hc.cof_eq)

theorem sup_lt_ord_of_is_regular {ι} {f : ι → ordinal} {c} (hc : is_regular c) (hι : #ι < c) :
  (∀ i, f i < c.ord) → ordinal.sup f < c.ord :=
sup_lt_ord (by rwa hc.cof_eq)

theorem blsub_lt_ord_lift_of_is_regular {o : ordinal} {f : Π a < o, ordinal} {c} (hc : is_regular c)
  (ho : cardinal.lift o.card < c) : (∀ i hi, f i hi < c.ord) → ordinal.blsub o f < c.ord :=
blsub_lt_ord_lift (by rwa hc.cof_eq)

theorem blsub_lt_ord_of_is_regular {o : ordinal} {f : Π a < o, ordinal} {c} (hc : is_regular c)
  (ho : o.card < c) : (∀ i hi, f i hi < c.ord) → ordinal.blsub o f < c.ord :=
blsub_lt_ord (by rwa hc.cof_eq)

theorem bsup_lt_ord_lift_of_is_regular {o : ordinal} {f : Π a < o, ordinal} {c} (hc : is_regular c)
  (hι : cardinal.lift o.card < c) : (∀ i hi, f i hi < c.ord) → ordinal.bsup o f < c.ord :=
bsup_lt_ord_lift (by rwa hc.cof_eq)

theorem bsup_lt_ord_of_is_regular {o : ordinal} {f : Π a < o, ordinal} {c} (hc : is_regular c)
  (hι : o.card < c) : (∀ i hi, f i hi < c.ord) → ordinal.bsup o f < c.ord :=
bsup_lt_ord (by rwa hc.cof_eq)

theorem supr_lt_lift_of_is_regular {ι} {f : ι → cardinal} {c} (hc : is_regular c)
  (hι : cardinal.lift (#ι) < c) : (∀ i, f i < c) → supr f < c :=
supr_lt_lift (by rwa hc.cof_eq)

theorem supr_lt_of_is_regular {ι} {f : ι → cardinal} {c} (hc : is_regular c) (hι : #ι < c) :
  (∀ i, f i < c) → supr f < c :=
supr_lt (by rwa hc.cof_eq)

theorem sum_lt_lift_of_is_regular {ι : Type u} {f : ι → cardinal} {c : cardinal} (hc : is_regular c)
  (hι : cardinal.lift.{v u} (#ι) < c) (hf : ∀ i, f i < c) : sum f < c :=
(sum_le_supr_lift _).trans_lt $ mul_lt_of_lt hc.1 hι (supr_lt_lift_of_is_regular hc hι hf)

theorem sum_lt_of_is_regular {ι : Type u} {f : ι → cardinal} {c : cardinal} (hc : is_regular c)
  (hι : #ι < c) : (∀ i, f i < c) → sum f < c :=
sum_lt_lift_of_is_regular.{u u} hc (by rwa lift_id)

theorem nfp_family_lt_ord_lift_of_is_regular {ι} {f : ι → ordinal → ordinal} {c} (hc : is_regular c)
  (hι : (#ι).lift < c) (hc' : c ≠ ℵ₀) (hf : ∀ i (b < c.ord), f i b < c.ord) {a} (ha : a < c.ord) :
  nfp_family.{u v} f a < c.ord :=
by { apply nfp_family_lt_ord_lift _ _ hf ha; rwa hc.cof_eq, exact lt_of_le_of_ne hc.1 hc'.symm }

theorem nfp_family_lt_ord_of_is_regular {ι} {f : ι → ordinal → ordinal} {c} (hc : is_regular c)
  (hι : #ι < c) (hc' : c ≠ ℵ₀) {a} (hf : ∀ i (b < c.ord), f i b < c.ord) :
  a < c.ord → nfp_family.{u u} f a < c.ord :=
nfp_family_lt_ord_lift_of_is_regular hc (by rwa lift_id) hc' hf

theorem nfp_bfamily_lt_ord_lift_of_is_regular {o : ordinal} {f : Π a < o, ordinal → ordinal} {c}
  (hc : is_regular c) (ho : o.card.lift < c) (hc' : c ≠ ℵ₀)
  (hf : ∀ i hi (b < c.ord), f i hi b < c.ord) {a} : a < c.ord → nfp_bfamily.{u v} o f a < c.ord :=
nfp_family_lt_ord_lift_of_is_regular hc (by rwa mk_ordinal_out) hc' (λ i, hf _ _)

theorem nfp_bfamily_lt_ord_of_is_regular {o : ordinal} {f : Π a < o, ordinal → ordinal} {c}
  (hc : is_regular c) (ho : o.card < c) (hc' : c ≠ ℵ₀) (hf : ∀ i hi (b < c.ord), f i hi b < c.ord)
  {a} : a < c.ord → nfp_bfamily.{u u} o f a < c.ord :=
nfp_bfamily_lt_ord_lift_of_is_regular hc (by rwa lift_id) hc' hf

theorem nfp_lt_ord_of_is_regular {f : ordinal → ordinal} {c} (hc : is_regular c) (hc' : c ≠ ℵ₀)
  (hf : ∀ i < c.ord, f i < c.ord) {a} : (a < c.ord) → nfp f a < c.ord :=
nfp_lt_ord (by { rw hc.cof_eq, exact lt_of_le_of_ne hc.1 hc'.symm }) hf

theorem deriv_family_lt_ord_lift {ι} {f : ι → ordinal → ordinal} {c} (hc : is_regular c)
  (hι : (#ι).lift < c) (hc' : c ≠ ℵ₀) (hf : ∀ i (b < c.ord), f i b < c.ord) {a} :
  a < c.ord → deriv_family.{u v} f a < c.ord :=
begin
  have hω : ℵ₀ < c.ord.cof,
  { rw hc.cof_eq, exact lt_of_le_of_ne hc.1 hc'.symm },
  apply a.limit_rec_on,
  { rw deriv_family_zero,
    exact nfp_family_lt_ord_lift hω (by rwa hc.cof_eq) hf },
  { intros b hb hb',
    rw deriv_family_succ,
    exact nfp_family_lt_ord_lift hω (by rwa hc.cof_eq) hf
      ((ord_is_limit hc.1).2 _ (hb ((lt_succ b).trans hb'))) },
  { intros b hb H hb',
    rw deriv_family_limit f hb,
    exact bsup_lt_ord_of_is_regular hc (ord_lt_ord.1 ((ord_card_le b).trans_lt hb'))
      (λ o' ho', H o' ho' (ho'.trans hb')) }
end

theorem deriv_family_lt_ord {ι} {f : ι → ordinal → ordinal} {c} (hc : is_regular c)
  (hι : #ι < c) (hc' : c ≠ ℵ₀) (hf : ∀ i (b < c.ord), f i b < c.ord) {a} :
  a < c.ord → deriv_family.{u u} f a < c.ord :=
deriv_family_lt_ord_lift hc (by rwa lift_id) hc' hf

theorem deriv_bfamily_lt_ord_lift {o : ordinal} {f : Π a < o, ordinal → ordinal} {c}
  (hc : is_regular c) (hι : o.card.lift < c) (hc' : c ≠ ℵ₀)
  (hf : ∀ i hi (b < c.ord), f i hi b < c.ord) {a} :
  a < c.ord → deriv_bfamily.{u v} o f a < c.ord :=
deriv_family_lt_ord_lift hc (by rwa mk_ordinal_out) hc' (λ i, hf _ _)

theorem deriv_bfamily_lt_ord {o : ordinal} {f : Π a < o, ordinal → ordinal} {c} (hc : is_regular c)
  (hι : o.card < c) (hc' : c ≠ ℵ₀) (hf : ∀ i hi (b < c.ord), f i hi b < c.ord)
  {a} : a < c.ord → deriv_bfamily.{u u} o f a < c.ord :=
deriv_bfamily_lt_ord_lift hc (by rwa lift_id) hc' hf

theorem deriv_lt_ord {f : ordinal.{u} → ordinal} {c} (hc : is_regular c) (hc' : c ≠ ℵ₀)
  (hf : ∀ i < c.ord, f i < c.ord) {a} : a < c.ord → deriv f a < c.ord :=
deriv_family_lt_ord_lift hc
  (by simpa using cardinal.one_lt_aleph_0.trans (lt_of_le_of_ne hc.1 hc'.symm))
  hc' (λ _, hf)

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

theorem is_inaccessible.mk {c} (h₁ : ℵ₀ < c) (h₂ : c ≤ c.ord.cof) (h₃ : ∀ x < c, 2 ^ x < c) :
  is_inaccessible c :=
⟨h₁, ⟨h₁.le, h₂⟩, (aleph_0_pos.trans h₁).ne', h₃⟩

/- Lean's foundations prove the existence of ℵ₀ many inaccessible cardinals -/
theorem univ_inaccessible : is_inaccessible (univ.{u v}) :=
is_inaccessible.mk
  (by simpa using lift_lt_univ' ℵ₀)
  (by simp)
  (λ c h, begin
    rcases lt_univ'.1 h with ⟨c, rfl⟩,
    rw ← lift_two_power.{u (max (u+1) v)},
    apply lift_lt_univ'
  end)

theorem lt_power_cof {c : cardinal.{u}} : ℵ₀ ≤ c → c < c ^ cof c.ord :=
quotient.induction_on c $ λ α h, begin
  rcases ord_eq α with ⟨r, wo, re⟩, resetI,
  have := ord_is_limit h,
  rw [mk_def, re] at this ⊢,
  rcases cof_eq' r this with ⟨S, H, Se⟩,
  have := sum_lt_prod (λ a:S, #{x // r x a}) (λ _, #α) (λ i, _),
  { simp only [cardinal.prod_const, cardinal.lift_id, ← Se, ← mk_sigma, power_def] at this ⊢,
    refine lt_of_le_of_lt _ this,
    refine ⟨embedding.of_surjective _ _⟩,
    { exact λ x, x.2.1 },
    { exact λ a, let ⟨b, h, ab⟩ := H a in ⟨⟨⟨_, h⟩, _, ab⟩, rfl⟩ } },
  { have := typein_lt_type r i,
    rwa [← re, lt_ord] at this }
end

theorem lt_cof_power {a b : cardinal} (ha : ℵ₀ ≤ a) (b1 : 1 < b) :
  a < cof (b ^ a).ord :=
begin
  have b0 : b ≠ 0 := (zero_lt_one.trans b1).ne',
  apply lt_imp_lt_of_le_imp_le (power_le_power_left $ power_ne_zero a b0),
  rw [←power_mul, mul_eq_self ha],
  exact lt_power_cof (ha.trans $ (cantor' _ b1).le),
end

end cardinal


example (p q : ℕ → Prop) : (∃ x, p x) → ∃ x, p x ∨ q x :=
begin
  intro h,
  cases h with x hpx,
  existsi x, left, exact hpx
end


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_143
  (f g : ℝ → ℝ)
  (h₀ : ∀ x, f x = x + 1)
  (h₁ : ∀ x, g x = x^2 + 3) :
  f (g 2) = 8 :=
begin
  rw [h₀, h₁],
  norm_num,
end


import .Preloaded

theorem limit_unique {X : Type*} [metric_space X] {s : ℕ → X}
  (x₀ x₁ : X) (h₀ : s ⟶ x₀) (h₁ : s ⟶ x₁) :
x₀ = x₁ :=
begin
  unfold converges_to at *,
  apply eq_of_forall_dist_le,
  intros ε hεp,
  specialize h₀ (ε/3) (by linarith),
    cases h₀ with N₀ hN₀,
  specialize h₁ (ε/3) (by linarith),
    cases h₁ with N₁ hN₁,
  set N := max N₀ N₁ with hN,
    specialize hN₀ N (le_max_left _ _),
    specialize hN₁ N (le_max_right _ _),
  transitivity,
    apply dist_triangle_right _ _ (s N),
  linarith,
end


universe u v

/- *** definition of category *** -/

class Category (C: Type u) where
  Hom : C → C → Type v

  id : ∀ X: C, Hom X X

  comp : ∀ {X Y Z: C}, Hom Y Z → Hom X Y → Hom X Z

  comp_id : ∀ {X Y:C}, ∀ f: Hom X Y, comp f (id X) = f
  id_comp : ∀ {X Y:C}, ∀ f: Hom X Y, comp (id Y) f = f

  assoc : ∀ {W X Y Z: C}, ∀ f:Hom Y Z, ∀ g: Hom X Y, ∀ h:Hom W X, comp (comp f g) h = comp f (comp g h)

infixr:10 " ⟶  " => Category.Hom
infixr:80 " ⊚ " => Category.comp
notation "𝟙" => Category.id

open Category in
#check ∀ (C:Type u) [Category C] (W X Y Z: C), ∀ f:Y ⟶  Z, ∀ g: X ⟶  Y, ∀ h:W ⟶  X, (f ⊚ g) ⊚ h = f ⊚ (g ⊚ h)

namespace Category

@[simp] instance : Category (Type u) where
  Hom X Y := X → Y

  id X := fun x:X => x

  comp f g := f ∘ g

  comp_id := by intros; simp only [Function.comp]
  id_comp := by intros; simp only [Function.comp]
  assoc := by intros; simp only [Function.comp]

-- theorems for simp tactic
@[simp] theorem comp_id_thm {C:Type u} [Category C] {X Y:C} (f:X ⟶  Y) : f ⊚ 𝟙 X = f := comp_id f
@[simp] theorem id_comp_thm {C:Type u} [Category C] {X Y:C} (f:X ⟶  Y) : 𝟙 Y ⊚ f = f := id_comp f

@[simp] theorem assoc_thm {C:Type u} [Category C] {W X Y Z:C} (f:Y ⟶  Z) (g:X ⟶  Y) (h:W ⟶  X) :
  (f ⊚ g) ⊚ h = f ⊚ g ⊚ h := assoc _ _ _

/- *** definition of oposite category *** -/
def Op (C:Type u) [Category C] : Type u := C

@[simp] instance {C:Type u} [Category C] : Category (Category.Op C) where
  Hom X Y := @Category.Hom C _ Y X

  id X := @Category.id C _ X

  comp f g := @Category.comp C _ _ _ _ g f

  comp_id := by simp
  id_comp := by simp
  assoc := by simp

/-  *** definition of functor ***  -/

structure Functor (C:Type u) (D:Type v) [Category C] [Category D] where
  F : C → D

  Fmap : {X Y:C} → (f:X ⟶  Y) → ((F X) ⟶  (F Y))

  Fmap_id : {X: C} → Fmap (𝟙 X) = 𝟙 (F X)

  Fmap_comp : {X Y Z: C} → (f:Y ⟶  Z) → (g:X ⟶  Y) → Fmap (f ⊚ g) = Fmap f ⊚ Fmap g

infixr:26 " ⥤ " => Category.Functor

#check Functor.Fmap

syntax:90 term:90 " << " term:70 " >> " : term
macro_rules
  | `($F:term << $f:term >>) => `(Category.Functor.Fmap $F $f)

namespace Functor

variable {C:Type u} {D:Type v} [Category C] [Category D]
variable (F: C ⥤ D)

-- theorems for simp tactic
@[simp] theorem Fmap_id_thm {X:C} : F<<𝟙 X>> = 𝟙 (F.F X) := F.Fmap_id
@[simp] theorem Fmap_comp_thm {X Y Z:C} (f:Y ⟶  Z) (g:X ⟶  Y) : F<<f ⊚ g>> = F<<f>> ⊚ F<<g>> := F.Fmap_comp f g

-- covariant representation of an object c:C
def CovRepr {C:Type u} [Category.{u, v} C] (c:C) : C ⥤ Type v :=
  {
    F := fun X:C => c ⟶  X,
    Fmap := fun {X Y: C} (f: X ⟶  Y) (g:c ⟶  X) => f ⊚ g,
    Fmap_id := by intros; simp,
    Fmap_comp := by simp [Function.comp]
  }

def ContraRepr {C:Type u} [Category.{u, v} C] := @CovRepr (Op C) _

instance {C:Type u} {D:Type v} [Category C] [Category D] : Coe (Functor C D) (C → D) :=
  ⟨Functor.F⟩

end Functor

/- *** definition of over and under category *** -/

def Over (C:Type u) [Category C] (c:C) := Σ x:C, x ⟶  c

def Under (C:Type u) [Category C] := Over (Op C)

instance {C:Type u} [Category C] {c:C} : Category (Over C c) where
  Hom X Y := {f: X.fst ⟶  Y.fst // Y.snd ⊚ f = X.snd}

  id X := ⟨𝟙 X.fst, by simp only [comp_id]⟩

  comp f g := ⟨f.val ⊚ g.val, by simp [<-assoc, f.property, g.property]⟩

  comp_id := by intros; simp only [comp_id]
  id_comp := by intros; simp only [id_comp]
  assoc := by intros; simp only [assoc]

instance {C:Type u} [Category C] {c:C} : Category (Under C c) :=
  inferInstanceAs (Category (Over (Op C) c))

/- *** definition of isomorphism *** -/

structure Iso {C: Type u} [Category C] (X Y: C) where
  hom : X ⟶  Y
  inv : Y ⟶  X

  hom_inv : hom ⊚ inv = 𝟙 Y
  inv_hom : inv ⊚ hom = 𝟙 X

theorem IsoSymm {C:Type u} [Category C] (X Y: C) (h:Iso X Y) : Iso Y X :=
  {hom := h.inv, inv := h.hom, hom_inv := h.inv_hom, inv_hom := h.hom_inv}

def IsoFunctor {C:Type u} {D:Type v} [Category C] [Category D] (F: C ⥤ D)
  (X Y:C) (iso: Iso X Y) : Iso (F.F X) (F.F Y) :=
  {
    hom := F<<iso.hom>>,
    inv := F<<iso.inv>>,
    inv_hom := by rw [<-Functor.Fmap_comp_thm, iso.inv_hom, Functor.Fmap_id],
    hom_inv := by rw [<-Functor.Fmap_comp_thm, iso.hom_inv, Functor.Fmap_id]
  }

infixr:10 " ≅ " => Category.Iso

/- *** definition of monomorphism and epimorphism *** -/

def Monomorphism {C:Type u} [Category C] {X Y:C} (f:X ⟶  Y) : Prop :=
  ∀ W:C, ∀ h k: W ⟶  X, f ⊚ h = f ⊚ k → h = k

def Epimorphism {C:Type u} [Category C] {X Y:C} (f:X ⟶  Y) : Prop :=
  ∀ Z:C, ∀ h k: Y ⟶  Z, h ⊚ f = k ⊚ f → h = k

theorem EpiMonoFromProd {C:Type u} [Category C] {X Y:C} (f:X ⟶  Y) (g:Y ⟶  X) :
  f ⊚ g = 𝟙 Y → Epimorphism f ∧ Monomorphism g :=
by
  intro h1
  constructor
  . intro Z h k h2
    have h3 : (h ⊚ f) ⊚ g = (k ⊚ f) ⊚ g := by
      rw [h2]
    simp [h1] at h3
    assumption
  . intro W h k h2
    have h3 : (f ⊚ g) ⊚ h = (f ⊚ g) ⊚ k := by
      rw [assoc, assoc, h2]
    rw [h1, id_comp, id_comp] at h3
    assumption

theorem IsoHomEq
  {C:Type u} [Category C]
  {X Y: C} (i1 i2: X ≅ Y) (h1:i1.hom = i2.hom) :
  i1 = i2 :=
by
  suffices i1.inv = i2.inv by
    cases i1
    cases i2
    cases this
    cases h1
    simp only
  calc
    i1.inv = i1.inv ⊚ (i2.hom ⊚ i2.inv) := by rw [i2.hom_inv, comp_id]
    _      = (i1.inv ⊚ i2.hom) ⊚ i2.inv := by rw [<-assoc]
    _      = (i1.inv ⊚ i1.hom) ⊚ i2.inv := by rw [h1]
    _      = i2.inv                     := by rw [i1.inv_hom, id_comp]

/- *** definition of natural transformation and isomorphism *** -/

section

variable {C:Type u} {D:Type v} [Category C] [Category D]

structure NatTrans
  (F G: C ⥤ D) where

  map : ∀ X:C, F.F X ⟶  G.F X

  comp : (X Y: C) → (f:X ⟶  Y) → G<<f>> ⊚ map X = map Y ⊚ F<<f>>

@[simp] theorem NatTrans.eqMap (F G: C ⥤ D) : ∀ t1 t2: NatTrans F G, t1.map = t2.map ↔ t1 = t2 := by
  intro ⟨m1, c1⟩ ⟨m2, c2⟩
  constructor <;> intro h
  case mp =>
    cases h
    simp only
  case mpr =>
    cases h
    simp only

def NatTrans.id (F:C ⥤ D) : NatTrans F F where
  map X := 𝟙 (F.F X)

  comp := by simp

def NatTrans.vcomp
  (F G H:C ⥤ D) (T1:NatTrans G H) (T2:NatTrans F G) : NatTrans F H :=
  {
    map := fun X:C => T1.map X ⊚ T2.map X,
    comp := by
      intro X Y f
      simp only
      calc
        H<<f>> ⊚ map T1 X ⊚ map T2 X = (H<<f>> ⊚ map T1 X) ⊚ map T2 X := by rw [<-assoc]
        _ = (map T1 Y ⊚ G<<f>>) ⊚ map T2 X := by rw [T1.comp X Y]
        _ = map T1 Y ⊚ (map T2 Y ⊚ F<<f>>) := by rw [assoc, T2.comp X Y]
      rw [assoc]
  }

/- *** definition of functor category *** -/

instance : Category (C ⥤ D) where
  Hom F G := NatTrans F G
  id F := NatTrans.id F

  comp T₁ T₂ := NatTrans.vcomp _ _ _ T₁ T₂

  comp_id := by
    intros; simp only [NatTrans.id, NatTrans.vcomp, comp_id]

  id_comp := by
    intros; simp only [NatTrans.id, NatTrans.vcomp, id_comp]

  assoc := by
    intros; simp only [NatTrans.id, NatTrans.vcomp, assoc]

def NatIso (F G: C ⥤ D) := F ≅ G

#check Functor.CovRepr

end

/- *** definition of a representable fonctor *** -/
def Representable {C:Type u} [Category.{u, v} C] (F: C ⥤ Type v) := Σ c:C, Functor.CovRepr c ≅ F

/- *** definition of constant functor *** -/
def Functor.Constant (C:Type u) [Category C] : C ⥤ Type v where
  F _ := PUnit

  Fmap _ := fun u:PUnit => u

  Fmap_id := by
    simp

  Fmap_comp := by
    simp

def Initial (C:Type u) [Category C] := Representable <| Functor.Constant C

namespace Initial
variable {C:Type u} [Category.{u, v} C] (I:Initial C)

#print Functor.CovRepr

def getObj : C := I.fst

def getMorphism (X:C) : I.fst ⟶  X := I.snd.inv.map X PUnit.unit

def uniqueness (X:C) (f g:I.fst ⟶  X) : f = g := by
  let a := Functor.Constant C <<f>> ⊚ I.snd.hom.map I.fst
  let b := Functor.Constant C <<g>> ⊚ I.snd.hom.map I.fst
  let c := I.snd.hom.map X ⊚ Functor.CovRepr I.fst <<f>>
  let d := I.snd.hom.map X ⊚ Functor.CovRepr I.fst <<g>>

  have h1 : c = a := by
    have := I.snd.hom.comp I.fst X f
    simp only [<-this]
  have h2 : d = b := by
    have := I.snd.hom.comp I.fst X g
    simp only [<-this]

  have : Functor.CovRepr I.fst <<f>> = Functor.CovRepr I.fst <<g>> := by
    calc
      Functor.CovRepr I.fst <<f>> = (I.snd.inv ⊚ I.snd.hom).map X ⊚ Functor.CovRepr I.fst <<f>>
        := by rw [I.snd.inv_hom]; simp only [Category.id, NatTrans.id, Function.comp, Category.comp]
      _ = (I.snd.inv.map X ⊚ I.snd.hom.map X) ⊚ Functor.CovRepr I.fst <<f>>
        := by simp only [Category.comp, NatTrans.vcomp]
      _ = I.snd.inv.map X ⊚ a
        := by rw [assoc, <-h1]
      _ = I.snd.inv.map X ⊚ b
        := by simp only [Functor.Constant]
      _ = (I.snd.inv.map X ⊚ I.snd.hom.map X) ⊚ Functor.CovRepr I.fst <<g>>
        := by rw [<-h2, <-assoc]
      _ = (I.snd.inv ⊚ I.snd.hom).map X ⊚ Functor.CovRepr I.fst <<g>>
        := by simp only [Category.comp, NatTrans.vcomp]
      _ = Functor.CovRepr I.fst <<g>>
        := by rw [I.snd.inv_hom]; simp only [Category.id, NatTrans.id, Function.comp, Category.comp]

  have : Functor.Fmap (Functor.CovRepr I.fst) f (𝟙 I.fst) = Functor.Fmap (Functor.CovRepr I.fst) g (𝟙 I.fst) := by
    rw [this]
  simp only [Functor.CovRepr, comp_id_thm] at this
  assumption

end Initial

def Terminal (C:Type u) [Category C] := Initial (Op C)

end Category


import data.matrix.notation
import linear_algebra.determinant
import group_theory.perm.fin
import tactic.norm_swap

variables {α β : Type} [semiring α] [ring β]

namespace matrix

open_locale matrix

example {a a' b b' c c' d d' : α} :
  ![![a, b], ![c, d]] + ![![a', b'], ![c', d']] = ![![a + a', b + b'], ![c + c', d + d']] :=
by simp

example {a a' b b' c c' d d' : β} :
  ![![a, b], ![c, d]] - ![![a', b'], ![c', d']] = ![![a - a', b - b'], ![c - c', d - d']] :=
by simp

example {a a' b b' c c' d d' : α} :
  ![![a, b], ![c, d]] ⬝ ![![a', b'], ![c', d']] =
    ![![a * a' + b * c', a * b' + b * d'], ![c * a' + d * c', c * b' + d * d']] :=
by simp

example {a b c d x y : α} :
  mul_vec ![![a, b], ![c, d]] ![x, y] = ![a * x + b * y, c * x + d * y] :=
by simp

example {a b c d : α} : minor ![![a, b], ![c, d]] ![1, 0] ![0] = ![![c], ![a]] :=
by { ext, simp }

example {a b c : α} : ![a, b, c] 0 = a := by simp
example {a b c : α} : ![a, b, c] 1 = b := by simp
example {a b c : α} : ![a, b, c] 2 = c := by simp

example {a b c d : α} : ![a, b, c, d] 0 = a := by simp
example {a b c d : α} : ![a, b, c, d] 1 = b := by simp
example {a b c d : α} : ![a, b, c, d] 2 = c := by simp
example {a b c d : α} : ![a, b, c, d] 3 = d := by simp
example {a b c d : α} : ![a, b, c, d] 42 = c := by simp

example {a b c d e : α} : ![a, b, c, d, e] 0 = a := by simp
example {a b c d e : α} : ![a, b, c, d, e] 1 = b := by simp
example {a b c d e : α} : ![a, b, c, d, e] 2 = c := by simp
example {a b c d e : α} : ![a, b, c, d, e] 3 = d := by simp
example {a b c d e : α} : ![a, b, c, d, e] 4 = e := by simp
example {a b c d e : α} : ![a, b, c, d, e] 5 = a := by simp
example {a b c d e : α} : ![a, b, c, d, e] 6 = b := by simp
example {a b c d e : α} : ![a, b, c, d, e] 7 = c := by simp
example {a b c d e : α} : ![a, b, c, d, e] 8 = d := by simp
example {a b c d e : α} : ![a, b, c, d, e] 9 = e := by simp
example {a b c d e : α} : ![a, b, c, d, e] 123 = d := by simp
example {a b c d e : α} : ![a, b, c, d, e] 123456789 = e := by simp

example {a b c d e f g h : α} : ![a, b, c, d, e, f, g, h] 5 = f := by simp
example {a b c d e f g h : α} : ![a, b, c, d, e, f, g, h] 7 = h := by simp
example {a b c d e f g h : α} : ![a, b, c, d, e, f, g, h] 37 = f := by simp
example {a b c d e f g h : α} : ![a, b, c, d, e, f, g, h] 99 = d := by simp

example {α : Type*} [comm_ring α] {a b c d : α} :
  matrix.det ![![a, b], ![c, d]] = a * d - b * c :=
begin
  simp [matrix.det_succ_row_zero, fin.sum_univ_succ],
  /-
  Try this: simp only [matrix.det_succ_row_zero, fin.sum_univ_succ, det_fin_zero,
      finset.sum_singleton, fin.sum_univ_zero, minor_apply, cons_val_zero, cons_val_succ,
      fin.succ_above_zero, fin.coe_succ, fin.coe_zero],
  -/
  ring
end

example {α : Type*} [comm_ring α] (A : matrix (fin 3) (fin 3) α) {a b c d e f g h i : α} :
        matrix.det ![![a, b, c], ![d, e, f], ![g, h, i]] =
          a * e * i - a * f * h - b * d * i + b * f * g + c * d * h - c * e * g :=
begin
  simp [matrix.det_succ_row_zero, fin.sum_univ_succ],
  /-
  Try this: simp only [matrix.det_succ_row_zero, fin.sum_univ_succ, det_fin_zero,
      finset.sum_singleton, fin.sum_univ_zero, minor_apply, cons_val_zero, cons_val_succ,
      fin.succ_above_zero, fin.succ_succ_above_zero, fin.succ_succ_above_succ,
      fin.coe_zero, fin.coe_succ, pow_zero, pow_add],
   -/
  ring
end

end matrix


example (p q r : Prop) : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
begin
  apply iff.intro,
  { intro h,
    cases h.right with hq hr,
    { show (p ∧ q) ∨ (p ∧ r),
        exact or.inl ⟨h.left, hq⟩ },
      show (p ∧ q) ∨ (p ∧ r),
        exact or.inr ⟨h.left, hr⟩ },
    intro h,
    cases h with hpq hpr,
    { show p ∧ (q ∨ r),
        exact ⟨hpq.left, or.inl hpq.right⟩ },
      show p ∧ (q ∨ r),
        exact ⟨hpr.left, or.inr hpr.right⟩
end


namespace fol_21_22

-- Proof of equivalence for:
-- ∃ x, A x ∧ ∀ y, (A y → y = x)
-- (∃ x, A x) ∧ (∀ y y', A y ∧ A y' → y = y')

variable U : Type
variable A : U → Prop

theorem fol_21 : (∃ x, A x ∧ ∀ y, (A y → y = x)) →
  ((∃ x, A x) ∧ (∀ y y', A y ∧ A y' → y = y')) :=
assume h1: (∃ x, A x ∧ (∀ y, A y → y = x)),
exists.elim h1
  (assume t (h2: (A t ∧ ∀ y, A y → y = t)),
   have h3: A t, from and.left h2,
   have h4: ∀ y, A y → y = t, from and.right h2,
   have h5: ∀ y z , A y ∧ A z → y = z, from
    (assume s: U,
     assume k: U,
     have h6: A s → s = t, from h4 s,
     have h7: A k → k = t, from h4 k,
     assume h8: A s ∧ A k,
     have h9: A s, from and.left h8,
     have h10: A k, from and.right h8,
     have h11: s = t, from h6 h9,
     have h12: k = t, from h7 h10,
     show s = k, from eq.trans h11 (eq.symm h12)),
   and.intro (exists.intro t h3) h5)

theorem fol_22 : ((∃ x, A x) ∧ (∀ y y', A y ∧ A y' → y = y')) →
  (∃ x, A x ∧ ∀ y, (A y → y = x)) :=
assume h1: (∃ x, A x) ∧ (∀ y y', A y ∧ A y' → y = y'),
have h2: ∃ x, A x, from and.left h1,
have h3: ∀ y y', A y ∧ A y' → y = y', from and.right h1,
exists.elim h2
  (assume t (h4: A t),
   have h5: ∀ (y : U), A y → y = t, from
    (assume s (h6: A s),
     have h7: A s ∧ A t → s = t, from h3 s t,
     show s = t, from h7 (and.intro h6 h4)),
   have h8: A t ∧ ∀ (y : U), A y → y = t, from and.intro h4 h5,
   exists.intro t h8)

#check fol_21

#check fol_22

end fol_21_22


/-
Copyright (c) 2022 Tomaz Gomes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Tomaz Gomes.
-/
import data.bool
import data.list
import MergeSort.MergeSort
import InsertionSort

namespace Timed

variables {α : Type} (r : α → α → Prop) [decidable_rel r]
local infix ` ≼ ` : 50 := r

@[simp] def comparisons_insert (a : α) : list α → ℕ
| [] := 0
| (h :: t) := if a ≼ h then 1 else 1 + comparisons_insert t

#eval comparisons_insert (λ m n : ℕ , m ≤ n) 6 [1, 3, 4, 9]
-- 3

#eval comparisons_insert (λ m n : ℕ , m ≤ n) 5 [0, 2, 3, 6]
-- 3

@[simp] def remove_prefix (a : α) : list α → list α
| [] := []
| (h :: t) := if a ≼ h then h :: t
              else remove_prefix t

#eval remove_prefix (λ m n : ℕ , m ≤ n) 2 [1, 2, 3, 4]
-- [2, 3, 4]

#eval remove_prefix (λ m n : ℕ , m ≤ n) 10 [4, 6, 7, 9]
-- []

@[simp] def comparisons_merge : list α → list α → ℕ
| []        ys        := 0
| xs        []        := 0
| (x :: xs) (y :: ys) := comparisons_insert r x (y :: ys) +
                         comparisons_merge xs (remove_prefix r x ys)

def l₁ : list ℕ := [8, 1, 3]
def l₂ : list ℕ := [14, 5, 6]

#eval comparisons_merge (λ m n : ℕ, m ≤ n) l₁ l₂
#eval prod.snd (merge (λ m n : ℕ, m ≤ n) l₁ l₂)

theorem comparisons_insert_correct (a : α) : ∀ l : list α,
  (ordered_insert r a l).snd = comparisons_insert r a l :=
begin
  intro l,
  induction l,
  { simp, },
  { simp, split_ifs,
    { exact rfl, },
    { rw ← l_ih,
      cases (ordered_insert r a l_tl),
      unfold ordered_insert,
      rw add_comm,
    }
  }
end

theorem comparisons_merge_correct : ∀ l₁ l₂ : list α,
  (merge r l₁ l₂).snd = comparisons_merge r l₁ l₂
| []         []         := begin simp only [comparisons_merge], unfold merge, end
| []         (h₂ :: t₂) := begin simp only [comparisons_merge], unfold merge, end
| (h₁ :: t₁) []         := begin simp only [comparisons_merge], unfold merge, end
| (h₁ :: t₁) (h₂ :: t₂) :=
begin
  simp only [comparisons_insert, comparisons_merge, remove_prefix, merge],
  split_ifs,
  { have ih := comparisons_merge_correct t₁ (h₂ :: t₂),
    cases (merge r t₁ (h₂ :: t₂)) with _ cnt,

    unfold merge,
    simp at *,

    cases t₂,

    { simp, rw ih, simp, },
    rw ← ih,
    ring,
  },
  have ih := comparisons_merge_correct (h₁ :: t₁) t₂,
  cases (merge r (h₁ :: t₁) t₂),
  unfold merge,
  simp at *,
  rw ih,
  cases t₂,
  { simp, refl, },
  simp, ring,
end

end Timed