/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.subalgebra
import ring_theory.noetherian

/-!
# Lie submodules of a Lie algebra

In this file we define Lie submodules and Lie ideals, we construct the lattice structure on Lie
submodules and we use it to define various important operations, notably the Lie span of a subset
of a Lie module.

## Main definitions

  * `lie_submodule`
  * `lie_submodule.well_founded_of_noetherian`
  * `lie_submodule.lie_span`
  * `lie_submodule.map`
  * `lie_submodule.comap`
  * `lie_ideal`
  * `lie_ideal.map`
  * `lie_ideal.comap`

## Tags

lie algebra, lie submodule, lie ideal, lattice structure
-/

universes u v w w₁ w₂

section lie_submodule

variables (R : Type u) (L : Type v) (M : Type w)
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]

set_option old_structure_cmd true
/-- A Lie submodule of a Lie module is a submodule that is closed under the Lie bracket.
This is a sufficient condition for the subset itself to form a Lie module. -/
structure lie_submodule extends submodule R M :=
(lie_mem : ∀ {x : L} {m : M}, m ∈ carrier → ⁅x, m⁆ ∈ carrier)

attribute [nolint doc_blame] lie_submodule.to_submodule

namespace lie_submodule

variables {R L M} (N N' : lie_submodule R L M)

instance : set_like (lie_submodule R L M) M :=
{ coe := carrier,
  coe_injective' := λ N O h, by cases N; cases O; congr' }

instance : add_subgroup_class (lie_submodule R L M) M :=
{ add_mem := λ N, N.add_mem',
  zero_mem := λ N, N.zero_mem',
  neg_mem := λ N x hx, show -x ∈ N.to_submodule, from neg_mem hx }

/-- The zero module is a Lie submodule of any Lie module. -/
instance : has_zero (lie_submodule R L M) :=
⟨{ lie_mem := λ x m h, by { rw ((submodule.mem_bot R).1 h), apply lie_zero, },
   ..(0 : submodule R M)}⟩

instance : inhabited (lie_submodule R L M) := ⟨0⟩

instance coe_submodule : has_coe (lie_submodule R L M) (submodule R M) := ⟨to_submodule⟩

@[simp] lemma to_submodule_eq_coe : N.to_submodule = N := rfl

@[norm_cast]
lemma coe_to_submodule : ((N : submodule R M) : set M) = N := rfl

@[simp] lemma mem_carrier {x : M} : x ∈ N.carrier ↔ x ∈ (N : set M) :=
iff.rfl

@[simp] lemma mem_mk_iff (S : set M) (h₁ h₂ h₃ h₄) {x : M} :
  x ∈ (⟨S, h₁, h₂, h₃, h₄⟩ : lie_submodule R L M) ↔ x ∈ S :=
iff.rfl

@[simp] lemma mem_coe_submodule {x : M} : x ∈ (N : submodule R M) ↔ x ∈ N := iff.rfl

lemma mem_coe {x : M} : x ∈ (N : set M) ↔ x ∈ N := iff.rfl

@[simp] protected lemma zero_mem : (0 : M) ∈ N := zero_mem N

@[simp] lemma mk_eq_zero {x} (h : x ∈ N) : (⟨x, h⟩ : N) = 0 ↔ x = 0 := subtype.ext_iff_val

@[simp] lemma coe_to_set_mk (S : set M) (h₁ h₂ h₃ h₄) :
  ((⟨S, h₁, h₂, h₃, h₄⟩ : lie_submodule R L M) : set M) = S := rfl

@[simp] lemma coe_to_submodule_mk (p : submodule R M) (h) :
  (({lie_mem := h, ..p} : lie_submodule R L M) : submodule R M) = p :=
by { cases p, refl, }

lemma coe_submodule_injective :
  function.injective (to_submodule : lie_submodule R L M → submodule R M) :=
λ x y h, by { cases x, cases y, congr, injection h }

@[ext] lemma ext (h : ∀ m, m ∈ N ↔ m ∈ N') : N = N' := set_like.ext h

@[simp] lemma coe_to_submodule_eq_iff : (N : submodule R M) = (N' : submodule R M) ↔ N = N' :=
coe_submodule_injective.eq_iff

/-- Copy of a lie_submodule with a new `carrier` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (s : set M) (hs : s = ↑N) : lie_submodule R L M :=
{ carrier := s,
  zero_mem' := hs.symm ▸ N.zero_mem',
  add_mem'  := hs.symm ▸ N.add_mem',
  smul_mem' := hs.symm ▸ N.smul_mem',
  lie_mem   := hs.symm ▸ N.lie_mem, }

@[simp] lemma coe_copy (S : lie_submodule R L M) (s : set M) (hs : s = ↑S) :
  (S.copy s hs : set M) = s := rfl

lemma copy_eq (S : lie_submodule R L M) (s : set M) (hs : s = ↑S) : S.copy s hs = S :=
coe_submodule_injective (set_like.coe_injective hs)

instance : lie_ring_module L N :=
{ bracket     := λ (x : L) (m : N), ⟨⁅x, m.val⁆, N.lie_mem m.property⟩,
  add_lie     := by { intros x y m, apply set_coe.ext, apply add_lie, },
  lie_add     := by { intros x m n, apply set_coe.ext, apply lie_add, },
  leibniz_lie := by { intros x y m, apply set_coe.ext, apply leibniz_lie, }, }

instance module' {S : Type*} [semiring S] [has_scalar S R] [module S M] [is_scalar_tower S R M] :
  module S N :=
N.to_submodule.module'

instance : module R N := N.to_submodule.module

instance {S : Type*} [semiring S] [has_scalar S R] [has_scalar Sᵐᵒᵖ R] [module S M] [module Sᵐᵒᵖ M]
  [is_scalar_tower S R M] [is_scalar_tower Sᵐᵒᵖ R M] [is_central_scalar S M] :
  is_central_scalar S N :=
N.to_submodule.is_central_scalar

instance : lie_module R L N :=
{ lie_smul := by { intros t x y, apply set_coe.ext, apply lie_smul, },
  smul_lie := by { intros t x y, apply set_coe.ext, apply smul_lie, }, }

@[simp, norm_cast] lemma coe_zero : ((0 : N) : M) = (0 : M) := rfl

@[simp, norm_cast] lemma coe_add (m m' : N) : (↑(m + m') : M) = (m : M) + (m' : M) := rfl

@[simp, norm_cast] lemma coe_neg (m : N) : (↑(-m) : M) = -(m : M) := rfl

@[simp, norm_cast] lemma coe_sub (m m' : N) : (↑(m - m') : M) = (m : M) - (m' : M) := rfl

@[simp, norm_cast] lemma coe_smul (t : R) (m : N) : (↑(t • m) : M) = t • (m : M) := rfl

@[simp, norm_cast] lemma coe_bracket (x : L) (m : N) : (↑⁅x, m⁆ : M) = ⁅x, ↑m⁆ := rfl

end lie_submodule

section lie_ideal

variables (L)

/-- An ideal of a Lie algebra is a Lie submodule of the Lie algebra as a Lie module over itself. -/
abbreviation lie_ideal := lie_submodule R L L

lemma lie_mem_right (I : lie_ideal R L) (x y : L) (h : y ∈ I) : ⁅x, y⁆ ∈ I := I.lie_mem h

lemma lie_mem_left (I : lie_ideal R L) (x y : L) (h : x ∈ I) : ⁅x, y⁆ ∈ I :=
 by { rw [←lie_skew, ←neg_lie], apply lie_mem_right, assumption, }

/-- An ideal of a Lie algebra is a Lie subalgebra. -/
def lie_ideal_subalgebra (I : lie_ideal R L) : lie_subalgebra R L :=
{ lie_mem' := by { intros x y hx hy, apply lie_mem_right, exact hy, },
  ..I.to_submodule, }

instance : has_coe (lie_ideal R L) (lie_subalgebra R L) := ⟨λ I, lie_ideal_subalgebra R L I⟩

@[norm_cast] lemma lie_ideal.coe_to_subalgebra (I : lie_ideal R L) :
  ((I : lie_subalgebra R L) : set L) = I := rfl

@[norm_cast] lemma lie_ideal.coe_to_lie_subalgebra_to_submodule (I : lie_ideal R L) :
  ((I : lie_subalgebra R L) : submodule R L) = I := rfl

end lie_ideal

variables {R M}

lemma submodule.exists_lie_submodule_coe_eq_iff (p : submodule R M) :
  (∃ (N : lie_submodule R L M), ↑N = p) ↔ ∀ (x : L) (m : M), m ∈ p → ⁅x, m⁆ ∈ p :=
begin
  split,
  { rintros ⟨N, rfl⟩, exact N.lie_mem, },
  { intros h, use { lie_mem := h, ..p }, exact lie_submodule.coe_to_submodule_mk p _, },
end

namespace lie_subalgebra

variables {L} (K : lie_subalgebra R L)

/-- Given a Lie subalgebra `K ⊆ L`, if we view `L` as a `K`-module by restriction, it contains
a distinguished Lie submodule for the action of `K`, namely `K` itself. -/
def to_lie_submodule : lie_submodule R K L :=
{ lie_mem := λ x y hy, K.lie_mem x.property hy,
  .. (K : submodule R L) }

@[simp] lemma coe_to_lie_submodule :
  (K.to_lie_submodule : submodule R L) = K :=
by { rcases K with ⟨⟨⟩⟩, refl, }

variables {K}

@[simp] lemma mem_to_lie_submodule (x : L) :
  x ∈ K.to_lie_submodule ↔ x ∈ K :=
iff.rfl

lemma exists_lie_ideal_coe_eq_iff :
  (∃ (I : lie_ideal R L), ↑I = K) ↔ ∀ (x y : L), y ∈ K → ⁅x, y⁆ ∈ K :=
begin
  simp only [← coe_to_submodule_eq_iff, lie_ideal.coe_to_lie_subalgebra_to_submodule,
    submodule.exists_lie_submodule_coe_eq_iff L],
  exact iff.rfl,
end

lemma exists_nested_lie_ideal_coe_eq_iff {K' : lie_subalgebra R L} (h : K ≤ K') :
  (∃ (I : lie_ideal R K'), ↑I = of_le h) ↔ ∀ (x y : L), x ∈ K' → y ∈ K → ⁅x, y⁆ ∈ K :=
begin
  simp only [exists_lie_ideal_coe_eq_iff, coe_bracket, mem_of_le],
  split,
  { intros h' x y hx hy, exact h' ⟨x, hx⟩ ⟨y, h hy⟩ hy, },
  { rintros h' ⟨x, hx⟩ ⟨y, hy⟩ hy', exact h' x y hx hy', },
end

end lie_subalgebra

end lie_submodule

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [add_comm_group M] [module R M]
variables [lie_ring_module L M] [lie_module R L M]
variables (N N' : lie_submodule R L M) (I J : lie_ideal R L)

section lattice_structure

open set

lemma coe_injective : function.injective (coe : lie_submodule R L M → set M) :=
set_like.coe_injective

@[simp, norm_cast] lemma coe_submodule_le_coe_submodule : (N : submodule R M) ≤ N' ↔ N ≤ N' :=
iff.rfl

instance : has_bot (lie_submodule R L M) := ⟨0⟩

@[simp] lemma bot_coe : ((⊥ : lie_submodule R L M) : set M) = {0} := rfl

@[simp] lemma bot_coe_submodule : ((⊥ : lie_submodule R L M) : submodule R M) = ⊥ := rfl

@[simp] lemma mem_bot (x : M) : x ∈ (⊥ : lie_submodule R L M) ↔ x = 0 := mem_singleton_iff

instance : has_top (lie_submodule R L M) :=
⟨{ lie_mem := λ x m h, mem_univ ⁅x, m⁆,
   ..(⊤ : submodule R M) }⟩

@[simp] lemma top_coe : ((⊤ : lie_submodule R L M) : set M) = univ := rfl

@[simp] lemma top_coe_submodule : ((⊤ : lie_submodule R L M) : submodule R M) = ⊤ := rfl

@[simp] lemma mem_top (x : M) : x ∈ (⊤ : lie_submodule R L M) := mem_univ x

instance : has_inf (lie_submodule R L M) :=
⟨λ N N', { lie_mem := λ x m h, mem_inter (N.lie_mem h.1) (N'.lie_mem h.2),
            ..(N ⊓ N' : submodule R M) }⟩

instance : has_Inf (lie_submodule R L M) :=
⟨λ S, { lie_mem := λ x m h, by
        { simp only [submodule.mem_carrier, mem_Inter, submodule.Inf_coe, mem_set_of_eq,
            forall_apply_eq_imp_iff₂, exists_imp_distrib] at *,
          intros N hN, apply N.lie_mem (h N hN), },
        ..Inf {(s : submodule R M) | s ∈ S} }⟩

@[simp] theorem inf_coe : (↑(N ⊓ N') : set M) = N ∩ N' := rfl

@[simp] lemma Inf_coe_to_submodule (S : set (lie_submodule R L M)) :
  (↑(Inf S) : submodule R M) = Inf {(s : submodule R M) | s ∈ S} := rfl

@[simp] lemma Inf_coe (S : set (lie_submodule R L M)) : (↑(Inf S) : set M) = ⋂ s ∈ S, (s : set M) :=
begin
  rw [← lie_submodule.coe_to_submodule, Inf_coe_to_submodule, submodule.Inf_coe],
  ext m,
  simpa only [mem_Inter, mem_set_of_eq, forall_apply_eq_imp_iff₂, exists_imp_distrib],
end

lemma Inf_glb (S : set (lie_submodule R L M)) : is_glb S (Inf S) :=
begin
  have h : ∀ (N N' : lie_submodule R L M), (N : set M) ≤ N' ↔ N ≤ N', { intros, refl },
  apply is_glb.of_image h,
  simp only [Inf_coe],
  exact is_glb_binfi
end

/-- The set of Lie submodules of a Lie module form a complete lattice.

We provide explicit values for the fields `bot`, `top`, `inf` to get more convenient definitions
than we would otherwise obtain from `complete_lattice_of_Inf`.  -/
instance : complete_lattice (lie_submodule R L M) :=
{ le           := (≤),
  lt           := (<),
  bot          := ⊥,
  bot_le       := λ N _ h, by { rw mem_bot at h, rw h, exact N.zero_mem', },
  top          := ⊤,
  le_top       := λ _ _ _, trivial,
  inf          := (⊓),
  le_inf       := λ N₁ N₂ N₃ h₁₂ h₁₃ m hm, ⟨h₁₂ hm, h₁₃ hm⟩,
  inf_le_left  := λ _ _ _, and.left,
  inf_le_right := λ _ _ _, and.right,
  ..set_like.partial_order,
  ..complete_lattice_of_Inf _ Inf_glb }

instance : add_comm_monoid (lie_submodule R L M) :=
{ add       := (⊔),
  add_assoc := λ _ _ _, sup_assoc,
  zero      := ⊥,
  zero_add  := λ _, bot_sup_eq,
  add_zero  := λ _, sup_bot_eq,
  add_comm  := λ _ _, sup_comm, }

@[simp] lemma add_eq_sup : N + N' = N ⊔ N' := rfl

@[norm_cast, simp] lemma sup_coe_to_submodule :
  (↑(N ⊔ N') : submodule R M) = (N : submodule R M) ⊔ (N' : submodule R M) :=
begin
  have aux : ∀ (x : L) m, m ∈ (N ⊔ N' : submodule R M) → ⁅x,m⁆ ∈ (N ⊔ N' : submodule R M),
  { simp only [submodule.mem_sup],
    rintro x m ⟨y, hy, z, hz, rfl⟩,
    refine ⟨⁅x, y⁆, N.lie_mem hy, ⁅x, z⁆, N'.lie_mem hz, (lie_add _ _ _).symm⟩ },
  refine le_antisymm (Inf_le ⟨{ lie_mem := aux, ..(N ⊔ N' : submodule R M) }, _⟩) _,
  { simp only [exists_prop, and_true, mem_set_of_eq, eq_self_iff_true, coe_to_submodule_mk,
      ← coe_submodule_le_coe_submodule, and_self, le_sup_left, le_sup_right] },
  { simp, },
end

@[norm_cast, simp] lemma inf_coe_to_submodule :
  (↑(N ⊓ N') : submodule R M) = (N : submodule R M) ⊓ (N' : submodule R M) := rfl

@[simp] lemma mem_inf (x : M) : x ∈ N ⊓ N' ↔ x ∈ N ∧ x ∈ N' :=
by rw [← mem_coe_submodule, ← mem_coe_submodule, ← mem_coe_submodule, inf_coe_to_submodule,
  submodule.mem_inf]

lemma mem_sup (x : M) : x ∈ N ⊔ N' ↔ ∃ (y ∈ N) (z ∈ N'), y + z = x :=
by { rw [← mem_coe_submodule, sup_coe_to_submodule, submodule.mem_sup], exact iff.rfl, }

lemma eq_bot_iff : N = ⊥ ↔ ∀ (m : M), m ∈ N → m = 0 :=
by { rw eq_bot_iff, exact iff.rfl, }

-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_submodule R L ↥(⊥ : lie_submodule R L M)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, lie_submodule.mem_bot],
end

instance : is_modular_lattice (lie_submodule R L M) :=
{ sup_inf_le_assoc_of_le := λ N₁ N₂ N₃,
    by { simp only [← coe_submodule_le_coe_submodule, sup_coe_to_submodule, inf_coe_to_submodule],
         exact is_modular_lattice.sup_inf_le_assoc_of_le ↑N₂, }, }

variables (R L M)

lemma well_founded_of_noetherian [is_noetherian R M] :
  well_founded ((>) : lie_submodule R L M → lie_submodule R L M → Prop) :=

let f : ((>) : lie_submodule R L M → lie_submodule R L M → Prop) →r
        ((>) : submodule R M → submodule R M → Prop) :=
{ to_fun       := coe,
  map_rel' := λ N N' h, h, }
in rel_hom_class.well_founded f (is_noetherian_iff_well_founded.mp infer_instance)

@[simp] lemma subsingleton_iff : subsingleton (lie_submodule R L M) ↔ subsingleton M :=
have h : subsingleton (lie_submodule R L M) ↔ subsingleton (submodule R M),
{ rw [← subsingleton_iff_bot_eq_top, ← subsingleton_iff_bot_eq_top, ← coe_to_submodule_eq_iff,
    top_coe_submodule, bot_coe_submodule], },
h.trans $ submodule.subsingleton_iff R

@[simp] lemma nontrivial_iff : nontrivial (lie_submodule R L M) ↔ nontrivial M :=
not_iff_not.mp (
  (not_nontrivial_iff_subsingleton.trans $ subsingleton_iff R L M).trans
  not_nontrivial_iff_subsingleton.symm)

instance [nontrivial M] : nontrivial (lie_submodule R L M) := (nontrivial_iff R L M).mpr ‹_›

lemma nontrivial_iff_ne_bot {N : lie_submodule R L M} : nontrivial N ↔ N ≠ ⊥ :=
begin
  split;
  contrapose!,
  { rintros rfl ⟨⟨m₁, h₁ : m₁ ∈ (⊥ : lie_submodule R L M)⟩,
                 ⟨m₂, h₂ : m₂ ∈ (⊥ : lie_submodule R L M)⟩, h₁₂⟩,
    simpa [(lie_submodule.mem_bot _).mp h₁, (lie_submodule.mem_bot _).mp h₂] using h₁₂, },
  { rw [not_nontrivial_iff_subsingleton, lie_submodule.eq_bot_iff],
    rintros ⟨h⟩ m hm,
    simpa using h ⟨m, hm⟩ ⟨_, N.zero_mem⟩, },
end

variables {R L M}

section inclusion_maps

/-- The inclusion of a Lie submodule into its ambient space is a morphism of Lie modules. -/
def incl : N →ₗ⁅R,L⁆ M :=
{ map_lie' := λ x m, rfl,
  ..submodule.subtype (N : submodule R M) }

@[simp] lemma incl_coe : (N.incl : N →ₗ[R] M) = (N : submodule R M).subtype := rfl

@[simp] lemma incl_apply (m : N) : N.incl m = m := rfl

lemma incl_eq_val : (N.incl : N → M) = subtype.val := rfl

variables {N N'} (h : N ≤ N')

/-- Given two nested Lie submodules `N ⊆ N'`, the inclusion `N ↪ N'` is a morphism of Lie modules.-/
def hom_of_le : N →ₗ⁅R,L⁆ N' :=
{ map_lie' := λ x m, rfl,
  ..submodule.of_le (show N.to_submodule ≤ N'.to_submodule, from h) }

@[simp] lemma coe_hom_of_le (m : N) : (hom_of_le h m : M) = m := rfl

lemma hom_of_le_apply (m : N) : hom_of_le h m = ⟨m.1, h m.2⟩ := rfl

lemma hom_of_le_injective : function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

end inclusion_maps

section lie_span

variables (R L) (s : set M)
/-- The `lie_span` of a set `s ⊆ M` is the smallest Lie submodule of `M` that contains `s`. -/
def lie_span : lie_submodule R L M := Inf {N | s ⊆ N}

variables {R L s}

lemma mem_lie_span {x : M} : x ∈ lie_span R L s ↔ ∀ N : lie_submodule R L M, s ⊆ N → x ∈ N :=
by { change x ∈ (lie_span R L s : set M) ↔ _, erw Inf_coe, exact mem_Inter₂, }

lemma subset_lie_span : s ⊆ lie_span R L s :=
by { intros m hm, erw mem_lie_span, intros N hN, exact hN hm, }

lemma submodule_span_le_lie_span : submodule.span R s ≤ lie_span R L s :=
by { rw submodule.span_le, apply subset_lie_span, }

lemma lie_span_le {N} : lie_span R L s ≤ N ↔ s ⊆ N :=
begin
  split,
  { exact subset.trans subset_lie_span, },
  { intros hs m hm, rw mem_lie_span at hm, exact hm _ hs, },
end

lemma lie_span_mono {t : set M} (h : s ⊆ t) : lie_span R L s ≤ lie_span R L t :=
by { rw lie_span_le, exact subset.trans h subset_lie_span, }

lemma lie_span_eq : lie_span R L (N : set M) = N :=
le_antisymm (lie_span_le.mpr rfl.subset) subset_lie_span

lemma coe_lie_span_submodule_eq_iff {p : submodule R M} :
  (lie_span R L (p : set M) : submodule R M) = p ↔ ∃ (N : lie_submodule R L M), ↑N = p :=
begin
  rw p.exists_lie_submodule_coe_eq_iff L, split; intros h,
  { intros x m hm, rw [← h, mem_coe_submodule], exact lie_mem _ (subset_lie_span hm), },
  { rw [← coe_to_submodule_mk p h, coe_to_submodule, coe_to_submodule_eq_iff, lie_span_eq], },
end

variables (R L M)

/-- `lie_span` forms a Galois insertion with the coercion from `lie_submodule` to `set`. -/
protected def gi : galois_insertion (lie_span R L : set M → lie_submodule R L M) coe :=
{ choice    := λ s _, lie_span R L s,
  gc        := λ s t, lie_span_le,
  le_l_u    := λ s, subset_lie_span,
  choice_eq := λ s h, rfl }

@[simp] lemma span_empty : lie_span R L (∅ : set M) = ⊥ :=
(lie_submodule.gi R L M).gc.l_bot

@[simp] lemma span_univ : lie_span R L (set.univ : set M) = ⊤ :=
eq_top_iff.2 $ set_like.le_def.2 $ subset_lie_span

lemma lie_span_eq_bot_iff : lie_span R L s = ⊥ ↔ ∀ (m ∈ s), m = (0 : M) :=
by rw [_root_.eq_bot_iff, lie_span_le, bot_coe, subset_singleton_iff]

variables {M}

lemma span_union (s t : set M) : lie_span R L (s ∪ t) = lie_span R L s ⊔ lie_span R L t :=
(lie_submodule.gi R L M).gc.l_sup

lemma span_Union {ι} (s : ι → set M) : lie_span R L (⋃ i, s i) = ⨆ i, lie_span R L (s i) :=
(lie_submodule.gi R L M).gc.l_supr

end lie_span

end lattice_structure

end lie_submodule

section lie_submodule_map_and_comap

variables {R : Type u} {L : Type v} {L' : Type w₂} {M : Type w} {M' : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] [lie_ring L'] [lie_algebra R L']
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group M'] [module R M'] [lie_ring_module L M'] [lie_module R L M']

namespace lie_submodule

variables (f : M →ₗ⁅R,L⁆ M') (N N₂ : lie_submodule R L M) (N' : lie_submodule R L M')

/-- A morphism of Lie modules `f : M → M'` pushes forward Lie submodules of `M` to Lie submodules
of `M'`. -/
def map : lie_submodule R L M' :=
{ lie_mem := λ x m' h, by
  { rcases h with ⟨m, hm, hfm⟩, use ⁅x, m⁆, split,
    { apply N.lie_mem hm, },
    { norm_cast at hfm, simp [hfm], }, },
  ..(N : submodule R M).map (f : M →ₗ[R] M') }

@[simp] lemma coe_submodule_map :
  (N.map f : submodule R M') = (N : submodule R M).map (f : M →ₗ[R] M') :=
rfl

/-- A morphism of Lie modules `f : M → M'` pulls back Lie submodules of `M'` to Lie submodules of
`M`. -/
def comap : lie_submodule R L M :=
{ lie_mem := λ x m h, by { suffices : ⁅x, f m⁆ ∈ N', { simp [this], }, apply N'.lie_mem h, },
  ..(N' : submodule R M').comap (f : M →ₗ[R] M') }

@[simp] lemma coe_submodule_comap :
  (N'.comap f : submodule R M) = (N' : submodule R M').comap (f : M →ₗ[R] M') :=
rfl

variables {f N N₂ N'}

lemma map_le_iff_le_comap : map f N ≤ N' ↔ N ≤ comap f N' :=
set.image_subset_iff

variables (f)

lemma gc_map_comap : galois_connection (map f) (comap f) :=
λ N N', map_le_iff_le_comap

variables {f}

@[simp] lemma map_sup : (N ⊔ N₂).map f = N.map f ⊔ N₂.map f :=
(gc_map_comap f).l_sup

lemma mem_map (m' : M') : m' ∈ N.map f ↔ ∃ m, m ∈ N ∧ f m = m' :=
submodule.mem_map

@[simp] lemma mem_comap {m : M} : m ∈ comap f N' ↔ f m ∈ N' := iff.rfl

lemma comap_incl_eq_top : N₂.comap N.incl = ⊤ ↔ N ≤ N₂ :=
by simpa only [← lie_submodule.coe_to_submodule_eq_iff, lie_submodule.coe_submodule_comap,
  lie_submodule.incl_coe, lie_submodule.top_coe_submodule, submodule.comap_subtype_eq_top]

end lie_submodule

namespace lie_ideal

variables (f : L →ₗ⁅R⁆ L') (I I₂ : lie_ideal R L) (J : lie_ideal R L')

@[simp] lemma top_coe_lie_subalgebra : ((⊤ : lie_ideal R L) : lie_subalgebra R L) = ⊤ := rfl

/-- A morphism of Lie algebras `f : L → L'` pushes forward Lie ideals of `L` to Lie ideals of `L'`.

Note that unlike `lie_submodule.map`, we must take the `lie_span` of the image. Mathematically
this is because although `f` makes `L'` into a Lie module over `L`, in general the `L` submodules of
`L'` are not the same as the ideals of `L'`. -/
def map : lie_ideal R L' := lie_submodule.lie_span R L' $ (I : submodule R L).map (f : L →ₗ[R] L')

/-- A morphism of Lie algebras `f : L → L'` pulls back Lie ideals of `L'` to Lie ideals of `L`.

Note that `f` makes `L'` into a Lie module over `L` (turning `f` into a morphism of Lie modules)
and so this is a special case of `lie_submodule.comap` but we do not exploit this fact. -/
def comap : lie_ideal R L :=
{ lie_mem := λ x y h, by { suffices : ⁅f x, f y⁆ ∈ J, { simp [this], }, apply J.lie_mem h, },
  ..(J : submodule R L').comap (f : L →ₗ[R] L') }

@[simp] lemma map_coe_submodule (h : ↑(map f I) = f '' I) :
  (map f I : submodule R L') = (I : submodule R L).map (f : L →ₗ[R] L') :=
by { rw [set_like.ext'_iff, lie_submodule.coe_to_submodule, h, submodule.map_coe], refl, }

@[simp] lemma comap_coe_submodule :
  (comap f J : submodule R L) = (J : submodule R L').comap (f : L →ₗ[R] L') := rfl

lemma map_le : map f I ≤ J ↔ f '' I ⊆ J := lie_submodule.lie_span_le

variables {f I I₂ J}

lemma mem_map {x : L} (hx : x ∈ I) : f x ∈ map f I :=
by { apply lie_submodule.subset_lie_span, use x, exact ⟨hx, rfl⟩, }

@[simp] lemma mem_comap {x : L} : x ∈ comap f J ↔ f x ∈ J := iff.rfl

lemma map_le_iff_le_comap : map f I ≤ J ↔ I ≤ comap f J :=
by { rw map_le, exact set.image_subset_iff, }

variables (f)

lemma gc_map_comap : galois_connection (map f) (comap f) :=
λ I I', map_le_iff_le_comap

variables {f}

@[simp] lemma map_sup : (I ⊔ I₂).map f = I.map f ⊔ I₂.map f :=
(gc_map_comap f).l_sup

lemma map_comap_le : map f (comap f J) ≤ J :=
by { rw map_le_iff_le_comap, exact le_rfl, }

/-- See also `lie_ideal.map_comap_eq`. -/
lemma comap_map_le : I ≤ comap f (map f I) :=
by { rw ← map_le_iff_le_comap, exact le_rfl, }

@[mono] lemma map_mono : monotone (map f) :=
λ I₁ I₂ h,
by { rw set_like.le_def at h, apply lie_submodule.lie_span_mono (set.image_subset ⇑f h), }

@[mono] lemma comap_mono : monotone (comap f) :=
λ J₁ J₂ h, by { rw ← set_like.coe_subset_coe at h ⊢, exact set.preimage_mono h, }

lemma map_of_image (h : f '' I = J) : I.map f = J :=
begin
  apply le_antisymm,
  { erw [lie_submodule.lie_span_le, submodule.map_coe, h], },
  { rw [← set_like.coe_subset_coe, ← h], exact lie_submodule.subset_lie_span, },
end

/-- Note that this is not a special case of `lie_submodule.subsingleton_of_bot`. Indeed, given
`I : lie_ideal R L`, in general the two lattices `lie_ideal R I` and `lie_submodule R L I` are
different (though the latter does naturally inject into the former).

In other words, in general, ideals of `I`, regarded as a Lie algebra in its own right, are not the
same as ideals of `L` contained in `I`. -/
-- TODO[gh-6025]: make this an instance once safe to do so
lemma subsingleton_of_bot : subsingleton (lie_ideal R ↥(⊥ : lie_ideal R L)) :=
begin
  apply subsingleton_of_bot_eq_top,
  ext ⟨x, hx⟩, change x ∈ ⊥ at hx, rw submodule.mem_bot at hx, subst hx,
  simp only [true_iff, eq_self_iff_true, submodule.mk_eq_zero, lie_submodule.mem_bot],
end

end lie_ideal

namespace lie_hom

variables (f : L →ₗ⁅R⁆ L') (I : lie_ideal R L) (J : lie_ideal R L')

/-- The kernel of a morphism of Lie algebras, as an ideal in the domain. -/
def ker : lie_ideal R L := lie_ideal.comap f ⊥

/-- The range of a morphism of Lie algebras as an ideal in the codomain. -/
def ideal_range : lie_ideal R L' := lie_submodule.lie_span R L' f.range

lemma ideal_range_eq_lie_span_range :
  f.ideal_range = lie_submodule.lie_span R L' f.range := rfl

lemma ideal_range_eq_map :
  f.ideal_range = lie_ideal.map f ⊤ :=
by { ext, simp only [ideal_range, range_eq_map], refl }

/-- The condition that the image of a morphism of Lie algebras is an ideal. -/
def is_ideal_morphism : Prop := (f.ideal_range : lie_subalgebra R L') = f.range

@[simp] lemma is_ideal_morphism_def :
  f.is_ideal_morphism ↔ (f.ideal_range : lie_subalgebra R L') = f.range := iff.rfl

lemma is_ideal_morphism_iff :
  f.is_ideal_morphism ↔ ∀ (x : L') (y : L), ∃ (z : L), ⁅x, f y⁆ = f z :=
begin
  simp only [is_ideal_morphism_def, ideal_range_eq_lie_span_range,
    ← lie_subalgebra.coe_to_submodule_eq_iff, ← f.range.coe_to_submodule,
    lie_ideal.coe_to_lie_subalgebra_to_submodule, lie_submodule.coe_lie_span_submodule_eq_iff,
    lie_subalgebra.mem_coe_submodule, mem_range, exists_imp_distrib,
    submodule.exists_lie_submodule_coe_eq_iff],
  split,
  { intros h x y, obtain ⟨z, hz⟩ := h x (f y) y rfl, use z, exact hz.symm, },
  { intros h x y z hz, obtain ⟨w, hw⟩ := h x z, use w, rw [← hw, hz], },
end

lemma range_subset_ideal_range : (f.range : set L') ⊆ f.ideal_range := lie_submodule.subset_lie_span

lemma map_le_ideal_range : I.map f ≤ f.ideal_range :=
begin
  rw f.ideal_range_eq_map,
  exact lie_ideal.map_mono le_top,
end

lemma ker_le_comap : f.ker ≤ J.comap f := lie_ideal.comap_mono bot_le

@[simp] lemma ker_coe_submodule : (ker f : submodule R L) = (f : L →ₗ[R] L').ker := rfl

@[simp] lemma mem_ker {x : L} : x ∈ ker f ↔ f x = 0 :=
show x ∈ (f.ker : submodule R L) ↔ _,
by simp only [ker_coe_submodule, linear_map.mem_ker, coe_to_linear_map]

lemma mem_ideal_range {x : L} : f x ∈ ideal_range f :=
begin
  rw ideal_range_eq_map,
  exact lie_ideal.mem_map (lie_submodule.mem_top x)
end

@[simp]

lemma le_ker_iff : I ≤ f.ker ↔ ∀ x, x ∈ I → f x = 0 :=
begin
  split; intros h x hx,
  { specialize h hx, rw mem_ker at h, exact h, },
  { rw mem_ker, apply h x hx, },
end

lemma ker_eq_bot : f.ker = ⊥ ↔ function.injective f :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, ker_coe_submodule, lie_submodule.bot_coe_submodule,
  linear_map.ker_eq_bot, coe_to_linear_map]

@[simp] lemma range_coe_submodule : (f.range : submodule R L') = (f : L →ₗ[R] L').range := rfl

lemma range_eq_top : f.range = ⊤ ↔ function.surjective f :=
begin
  rw [← lie_subalgebra.coe_to_submodule_eq_iff, range_coe_submodule,
    lie_subalgebra.top_coe_submodule],
  exact linear_map.range_eq_top,
end

@[simp] lemma ideal_range_eq_top_of_surjective (h : function.surjective f) : f.ideal_range = ⊤ :=
begin
  rw ← f.range_eq_top at h,
  rw [ideal_range_eq_lie_span_range, h, ← lie_subalgebra.coe_to_submodule,
    ← lie_submodule.coe_to_submodule_eq_iff, lie_submodule.top_coe_submodule,
      lie_subalgebra.top_coe_submodule, lie_submodule.coe_lie_span_submodule_eq_iff],
  use ⊤,
  exact lie_submodule.top_coe_submodule,
end

lemma is_ideal_morphism_of_surjective (h : function.surjective f) : f.is_ideal_morphism :=
by rw [is_ideal_morphism_def, f.ideal_range_eq_top_of_surjective h, f.range_eq_top.mpr h,
    lie_ideal.top_coe_lie_subalgebra]

end lie_hom

namespace lie_ideal

variables {f : L →ₗ⁅R⁆ L'} {I : lie_ideal R L} {J : lie_ideal R L'}

@[simp] lemma map_eq_bot_iff : I.map f = ⊥ ↔ I ≤ f.ker :=
by { rw ← le_bot_iff, exact lie_ideal.map_le_iff_le_comap }

lemma coe_map_of_surjective (h : function.surjective f) :
  (I.map f : submodule R L') = (I : submodule R L).map (f : L →ₗ[R] L') :=
begin
  let J : lie_ideal R L' :=
  { lie_mem := λ x y hy,
    begin
      have hy' : ∃ (x : L), x ∈ I ∧ f x = y, { simpa [hy], },
      obtain ⟨z₂, hz₂, rfl⟩ := hy',
      obtain ⟨z₁, rfl⟩ := h x,
      simp only [lie_hom.coe_to_linear_map, set_like.mem_coe, set.mem_image,
        lie_submodule.mem_coe_submodule, submodule.mem_carrier, submodule.map_coe],
      use ⁅z₁, z₂⁆,
      exact ⟨I.lie_mem hz₂, f.map_lie z₁ z₂⟩,
    end,
    ..(I : submodule R L).map (f : L →ₗ[R] L'), },
  erw lie_submodule.coe_lie_span_submodule_eq_iff,
  use J,
  apply lie_submodule.coe_to_submodule_mk,
end

lemma mem_map_of_surjective {y : L'} (h₁ : function.surjective f) (h₂ : y ∈ I.map f) :
  ∃ (x : I), f x = y :=
begin
  rw [← lie_submodule.mem_coe_submodule, coe_map_of_surjective h₁, submodule.mem_map] at h₂,
  obtain ⟨x, hx, rfl⟩ := h₂,
  use ⟨x, hx⟩,
  refl,
end

lemma bot_of_map_eq_bot {I : lie_ideal R L} (h₁ : function.injective f) (h₂ : I.map f = ⊥) :
  I = ⊥ :=
begin
  rw ← f.ker_eq_bot at h₁, change comap f ⊥ = ⊥ at h₁,
  rw [eq_bot_iff, map_le_iff_le_comap, h₁] at h₂,
  rw eq_bot_iff, exact h₂,
end

/-- Given two nested Lie ideals `I₁ ⊆ I₂`, the inclusion `I₁ ↪ I₂` is a morphism of Lie algebras. -/
def hom_of_le {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) : I₁ →ₗ⁅R⁆ I₂ :=
{ map_lie' := λ x y, rfl,
  ..submodule.of_le (show I₁.to_submodule ≤ I₂.to_submodule, from h), }

@[simp] lemma coe_hom_of_le {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) (x : I₁) :
  (hom_of_le h x : L) = x := rfl

lemma hom_of_le_apply {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) (x : I₁) :
  hom_of_le h x = ⟨x.1, h x.2⟩ := rfl

lemma hom_of_le_injective {I₁ I₂ : lie_ideal R L} (h : I₁ ≤ I₂) :
  function.injective (hom_of_le h) :=
λ x y, by simp only [hom_of_le_apply, imp_self, subtype.mk_eq_mk, set_like.coe_eq_coe,
  subtype.val_eq_coe]

@[simp] lemma map_sup_ker_eq_map : lie_ideal.map f (I ⊔ f.ker) = lie_ideal.map f I :=
begin
  suffices : lie_ideal.map f (I ⊔ f.ker) ≤ lie_ideal.map f I,
  { exact le_antisymm this (lie_ideal.map_mono le_sup_left), },
  apply lie_submodule.lie_span_mono,
  rintros x ⟨y, hy₁, hy₂⟩, rw ← hy₂,
  erw lie_submodule.mem_sup at hy₁, obtain ⟨z₁, hz₁, z₂, hz₂, hy⟩ := hy₁, rw ← hy,
  rw [f.coe_to_linear_map, f.map_add, f.mem_ker.mp hz₂, add_zero], exact ⟨z₁, hz₁, rfl⟩,
end

@[simp] lemma map_comap_eq (h : f.is_ideal_morphism) : map f (comap f J) = f.ideal_range ⊓ J :=
begin
  apply le_antisymm,
  { rw le_inf_iff, exact ⟨f.map_le_ideal_range _, map_comap_le⟩, },
  { rw f.is_ideal_morphism_def at h,
    rw [← set_like.coe_subset_coe, lie_submodule.inf_coe, ← coe_to_subalgebra, h],
    rintros y ⟨⟨x, h₁⟩, h₂⟩, rw ← h₁ at h₂ ⊢, exact mem_map h₂, },
end

@[simp] lemma comap_map_eq (h : ↑(map f I) = f '' I) : comap f (map f I) = I ⊔ f.ker :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, comap_coe_submodule, I.map_coe_submodule f h,
  lie_submodule.sup_coe_to_submodule, f.ker_coe_submodule, submodule.comap_map_eq]

variables (f I J)

/-- Regarding an ideal `I` as a subalgebra, the inclusion map into its ambient space is a morphism
of Lie algebras. -/
def incl : I →ₗ⁅R⁆ L := (I : lie_subalgebra R L).incl

@[simp] lemma incl_range : I.incl.range = I := (I : lie_subalgebra R L).incl_range

@[simp] lemma incl_apply (x : I) : I.incl x = x := rfl

@[simp] lemma incl_coe : (I.incl : I →ₗ[R] L) = (I : submodule R L).subtype := rfl

@[simp] lemma comap_incl_self : comap I.incl I = ⊤ :=
by { rw ← lie_submodule.coe_to_submodule_eq_iff, exact submodule.comap_subtype_self _, }

@[simp] lemma ker_incl : I.incl.ker = ⊥ :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, I.incl.ker_coe_submodule,
  lie_submodule.bot_coe_submodule, incl_coe, submodule.ker_subtype]

@[simp] lemma incl_ideal_range : I.incl.ideal_range = I :=
begin
  rw [lie_hom.ideal_range_eq_lie_span_range, ← lie_subalgebra.coe_to_submodule,
    ← lie_submodule.coe_to_submodule_eq_iff, incl_range, coe_to_lie_subalgebra_to_submodule,
    lie_submodule.coe_lie_span_submodule_eq_iff],
  use I,
end

lemma incl_is_ideal_morphism : I.incl.is_ideal_morphism :=
begin
  rw [I.incl.is_ideal_morphism_def, incl_ideal_range],
  exact (I : lie_subalgebra R L).incl_range.symm,
end

end lie_ideal

end lie_submodule_map_and_comap

namespace lie_module_hom

variables {R : Type u} {L : Type v} {M : Type w} {N : Type w₁}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables [add_comm_group N] [module R N] [lie_ring_module L N] [lie_module R L N]
variables (f : M →ₗ⁅R,L⁆ N)

/-- The kernel of a morphism of Lie algebras, as an ideal in the domain. -/
def ker : lie_submodule R L M := lie_submodule.comap f ⊥

@[simp] lemma ker_coe_submodule : (f.ker : submodule R M) = (f : M →ₗ[R] N).ker := rfl

lemma ker_eq_bot : f.ker = ⊥ ↔ function.injective f :=
by rw [← lie_submodule.coe_to_submodule_eq_iff, ker_coe_submodule, lie_submodule.bot_coe_submodule,
  linear_map.ker_eq_bot, coe_to_linear_map]

variables {f}

@[simp] lemma mem_ker (m : M) : m ∈ f.ker ↔ f m = 0 := iff.rfl

@[simp] lemma ker_id : (lie_module_hom.id : M →ₗ⁅R,L⁆ M).ker = ⊥ := rfl

@[simp] lemma comp_ker_incl : f.comp f.ker.incl = 0 :=
by { ext ⟨m, hm⟩, exact (mem_ker m).mp hm, }

lemma le_ker_iff_map (M' : lie_submodule R L M) :
  M' ≤ f.ker ↔ lie_submodule.map f M' = ⊥ :=
by rw [ker, eq_bot_iff, lie_submodule.map_le_iff_le_comap]

variables (f)

/-- The range of a morphism of Lie modules `f : M → N` is a Lie submodule of `N`.
See Note [range copy pattern]. -/
def range : lie_submodule R L N :=
(lie_submodule.map f ⊤).copy (set.range f) set.image_univ.symm

@[simp] lemma coe_range : (f.range : set N) = set.range f := rfl

@[simp] lemma coe_submodule_range : (f.range : submodule R N) = (f : M →ₗ[R] N).range := rfl

@[simp] lemma mem_range (n : N) : n ∈ f.range ↔ ∃ m, f m = n :=
iff.rfl

lemma map_top : lie_submodule.map f ⊤ = f.range :=
by { ext, simp [lie_submodule.mem_map], }

end lie_module_hom

namespace lie_submodule

variables {R : Type u} {L : Type v} {M : Type w}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]
variables [add_comm_group M] [module R M] [lie_ring_module L M] [lie_module R L M]
variables (N : lie_submodule R L M)

@[simp] lemma ker_incl : N.incl.ker = ⊥ :=
by simp [← lie_submodule.coe_to_submodule_eq_iff]

@[simp] lemma range_incl : N.incl.range = N :=
by simp [← lie_submodule.coe_to_submodule_eq_iff]

@[simp] lemma comap_incl_self : comap N.incl N = ⊤ :=
by simp [← lie_submodule.coe_to_submodule_eq_iff]

end lie_submodule

section top_equiv

variables {R : Type u} {L : Type v}
variables [comm_ring R] [lie_ring L] [lie_algebra R L]

/-- The natural equivalence between the 'top' Lie subalgebra and the enclosing Lie algebra.

This is the Lie subalgebra version of `submodule.top_equiv`. -/
def lie_subalgebra.top_equiv : (⊤ : lie_subalgebra R L) ≃ₗ⁅R⁆ L :=
{ inv_fun   := λ x, ⟨x, set.mem_univ x⟩,
  left_inv  := λ x, by { ext, refl, },
  right_inv := λ x, rfl,
  ..(⊤ : lie_subalgebra R L).incl, }

@[simp] lemma lie_subalgebra.top_equiv_apply (x : (⊤ : lie_subalgebra R L)) :
  lie_subalgebra.top_equiv x = x := rfl

/-- The natural equivalence between the 'top' Lie ideal and the enclosing Lie algebra.

This is the Lie ideal version of `submodule.top_equiv`. -/
def lie_ideal.top_equiv : (⊤ : lie_ideal R L) ≃ₗ⁅R⁆ L :=
lie_subalgebra.top_equiv

@[simp] lemma lie_ideal.top_equiv_apply (x : (⊤ : lie_ideal R L)) :
  lie_ideal.top_equiv x = x := rfl

end top_equiv


import ch4
universe u
namespace Set

local attribute [irreducible] mem

reserve infix ` ≈ `:50
reserve infix ` ≉ `:50
reserve infix ` ≼ `:50

structure correspondence (A B f : Set) : Prop :=
(onto : f.onto_fun A B)
(oto : f.one_to_one)

lemma id_corr {A : Set} : A.correspondence A A.id :=
⟨id_onto, id_oto⟩

lemma empty_corr_empty : correspondence ∅ ∅ ∅ :=
⟨empty_onto, empty_oto⟩

def equinumerous (A B : Set) : Prop := ∃ f : Set, A.correspondence B f
infix ≈ := equinumerous
infix ≉ := (λ A B : Set, ¬(A ≈ B))

lemma empty_of_equin_empty {A : Set} (Ae : A ≈ ∅) : A = ∅ :=
begin
  rcases Ae with ⟨f, fonto, foto⟩, rw [←fonto.right.left, eq_empty],
  intros x xf, rw mem_dom at xf, rcases xf with ⟨y, xyf⟩, apply mem_empty y,
  rw ←fonto.right.right, rw mem_ran, exact ⟨_, xyf⟩,
end

def nat_prod_nat_equin_nat : prod nat.{u} nat.{u} ≈ nat.{u} :=
begin
  let f : Set := pair_sep_eq (prod ω ω) ω (λ z, pred.fun_value (two ^ z.fst * (two * z.snd).succ)),
  refine ⟨f, ⟨pair_sep_eq_is_fun, pair_sep_eq_dom_eq _, pair_sep_eq_ran_eq _⟩, pair_sep_eq_oto _⟩,
  { intros z hz, rw mem_prod at hz, rcases hz with ⟨m, hm, n, hn, he⟩, subst he, simp only [fst_congr, snd_congr],
    rw ←pred_onto_fun.right.right, apply fun_value_def'' pred_onto_fun.left, rw pred_onto_fun.right.left,
    exact mul_into_nat (exp_into_nat two_nat hm) (nat_induct.succ_closed (mul_into_nat two_nat hn)), },
  { intros k hk,
    have hmod2 := mod2_fun_value_mem hk,
    simp [bool] at hmod2, cases hmod2,
      obtain ⟨n, hn, he⟩ := mod2_spec_zero hk hmod2, subst he,
      use pair ∅ n, split,
        rw pair_mem_prod, exact ⟨zero_nat, hn⟩,
      dsimp, rw [fst_congr, snd_congr, exp_base two_nat, one_mul (nat_induct.succ_closed hk), pred_succ_eq_self hk],
    obtain ⟨q, hq, he⟩ := mod2_spec_one' hk hmod2,
    obtain ⟨n, hn, l, hl, hlo, he'⟩ := nonzero_nat_factor_two (nat_induct.succ_closed hq) succ_neq_empty,
    obtain ⟨m, hm, he''⟩ := mod2_spec_one hl hlo,
    rw [he', two_pow_lemma hn hl, he''] at he, subst he, use n.succ.pair m, dsimp,
    rw [pair_mem_prod, fst_congr, snd_congr],
    exact ⟨⟨nat_induct.succ_closed hn, hm⟩, rfl⟩, },
  {
    have hnez : ∀ {n : Set.{u}}, n ∈ nat.{u} → ∀ {m : Set}, m ∈ nat.{u} → two.{u} ^ n * (two * m).succ ≠ ∅,
      intros n hn m hm he, apply mem_empty ∅, nth_rewrite 1 ←he,
      rw ←zero_mul (nat_induct.succ_closed (mul_into_nat two_nat hm)),
      rw ←mul_lt_mul_of_lt zero_nat (exp_into_nat two_nat hn) (nat_induct.succ_closed (mul_into_nat two_nat hm)) succ_neq_empty,
      exact nonzero_exp_positive two_nat zero_ne_two.symm hn,
    have hnmnat : ∀ {n : Set.{u}}, n ∈ nat.{u} → ∀ {m : Set}, m ∈ nat.{u} → two.{u} ^ n * (two * m).succ ∈ nat.{u},
      intros n hn m hm,
      exact mul_into_nat (exp_into_nat two_nat hn) (nat_induct.succ_closed (mul_into_nat two_nat hm)),
    have hcases : ∀ {n : Set.{u}}, n ∈ nat.{u} → ∀ {m : Set}, m ∈ nat.{u} →
      ∀ {n' : Set.{u}}, n' ∈ nat.{u} → ∀ {m' : Set}, m' ∈ nat.{u} → two ^ n * (two * m).succ = two.{u} ^ n' * (two * m').succ → n ∈ n' → false,
      intros n hn m hm n' hn' m' hm' he hnn',
      rw lt_iff hn hn' at hnn', rcases hnn' with ⟨k, hk, hke⟩, rw ←hke at he,
      rw exp_add two_nat hn (nat_induct.succ_closed hk) at he,
      have two_exp_n := exp_into_nat two_nat hn,
      have two_mul_m' := nat_induct.succ_closed (mul_into_nat two_nat hm'),
      rw ←mul_assoc two_exp_n (exp_into_nat two_nat (nat_induct.succ_closed hk)) two_mul_m' at he,
      have two_exp_n_nz : (two.{u} ^ n) ≠ ∅, intro h, apply mem_empty ∅, nth_rewrite 1 ←h,
        refine nonzero_exp_positive two_nat zero_ne_two.symm hn,
      replace he := cancel_mul_left (nat_induct.succ_closed (mul_into_nat two_nat hm)) (hnmnat (nat_induct.succ_closed hk) hm') two_exp_n two_exp_n_nz he,
      rw exp_ind two_nat hk at he,
      have two_exp_k := exp_into_nat two_nat hk,
      rw [mul_comm two_exp_k two_nat, ←mul_assoc two_nat two_exp_k two_mul_m', mul_comm two_nat (mul_into_nat two_exp_k two_mul_m')] at he,
      have two_mul_m := mul_into_nat two_nat hm,
      rw succ_eq_add_one two_mul_m at he,
      have tdo : two.divides one, apply mod2_of_sum_mod2_of_mod2 two_mul_m one_nat,
          rw he, refine ⟨_, mul_into_nat two_exp_k two_mul_m', rfl⟩,
        refine ⟨_, hm, _⟩, rw mul_comm two_nat hm,
      exact not_two_divides_one tdo,
    simp only [mem_prod], rintros z ⟨n, hn, m, hm, hz⟩ z' ⟨n', hn', m', hm', hz'⟩ he, subst hz, subst hz',
    simp only [fst_congr, snd_congr] at he,
    replace he := pred_oto (hnmnat hn hm) (hnez hn hm) (hnmnat hn' hm') (hnez hn' hm') he,
    have hnn' : n = n', apply classical.by_contradiction, intro hnn',
      replace hnn' := nat_order_conn hn hn' hnn', cases hnn',
        exact hcases hn hm hn' hm' he hnn',
      exact hcases hn' hm' hn hm he.symm hnn',
    rw ←hnn' at he,
    have two_exp_n_nz : two.{u} ^ n ≠ ∅, intro h, apply mem_empty ∅, nth_rewrite 1 ←h,
      refine nonzero_exp_positive two_nat zero_ne_two.symm hn,
    replace he := cancel_mul_left (nat_induct.succ_closed (mul_into_nat two_nat hm)) (nat_induct.succ_closed (mul_into_nat two_nat hm')) (exp_into_nat two_nat hn) two_exp_n_nz he,
    replace he := succ_inj (mul_into_nat two_nat hm) (mul_into_nat two_nat hm') he,
    replace he := cancel_mul_left hm hm' two_nat zero_ne_two.symm he,
    congr,
      exact hnn',
    exact he, },
end

local attribute [instance] classical.prop_decidable

def char_fun (B A : Set) : Set := pair_sep (λ b c, c = if b ∈ A then one else ∅) B two

lemma char_fun_into_fun {B A : Set} : (B.char_fun A).into_fun B two :=
begin
  refine ⟨pair_sep_eq_is_fun, pair_sep_eq_dom_eq _, pair_sep_eq_ran_sub⟩,
  intros b hb, simp only [hb, if_true, two, succ, mem_union, one, mem_singleton], finish,
end

lemma char_fun_value {B A x : Set} (hx : x ∈ B) : (B.char_fun A).fun_value x = if x ∈ A then one else ∅ :=
begin
  symmetry, apply fun_value_def (is_function_of_into char_fun_into_fun),
  simp only [char_fun, pair_mem_pair_sep], refine ⟨hx, _, rfl⟩,
  by_cases h : x ∈ A,
  { simp only [h, if_true, two, succ, mem_union, mem_singleton], finish, },
  { simp only [h, if_false, two, succ, mem_union, one, mem_singleton], finish, },
end

lemma char_fun_value' {B A x : Set} (hx : x ∈ B) : (B.char_fun A).fun_value x = one ↔ x ∈ A :=
begin
  rw char_fun_value hx, by_cases h : x ∈ A,
  { simp only [h, if_true, eq_self_iff_true], },
  { simp only [h, if_false, iff_false], intro he,
    simp only [one, succ] at he, apply mem_empty ∅,
    nth_rewrite 1 he, rw [mem_union, mem_singleton], finish, },
end

def powerset_corr (B : Set) : Set := pair_sep (λ A f, f = B.char_fun A) B.powerset (B.into_funs two)

lemma powerset_corr_onto {B : Set.{u}} : B.powerset_corr.onto_fun B.powerset (B.into_funs two) :=
begin
  refine ⟨pair_sep_eq_is_fun, pair_sep_eq_dom_eq _, pair_sep_eq_ran_eq _⟩,
  { intros A hA, rw mem_into_funs, exact char_fun_into_fun, },
  { intros f hf,
    let A := {b ∈ B | f.fun_value b = one}, refine ⟨A, _, _⟩,
    { simp only [mem_powerset], intro a, rw mem_sep, finish, }, rw mem_into_funs at hf,
      apply fun_ext (is_function_of_into hf) (is_function_of_into char_fun_into_fun),
      { rw [dom_eq_of_into hf, dom_eq_of_into char_fun_into_fun], },
      { intros x hx, apply fun_value_def (is_function_of_into char_fun_into_fun),
        simp only [char_fun, pair_mem_pair_sep], refine ⟨_, _, _⟩,
        { rw ←dom_eq_of_into hf, assumption, },
        { apply ran_sub_of_into hf, exact fun_value_def'' (is_function_of_into hf) hx, },
        by_cases h : x ∈ A,
        { simp only [h, if_true], rw [mem_sep] at h, finish, },
        { simp only [h, if_false],
          have hor : (f.fun_value x) ∈ two.{u},
            apply ran_sub_of_into hf, exact fun_value_def'' (is_function_of_into hf) hx,
          rw dom_eq_of_into hf at hx,
          simp only [two, succ, mem_union, mem_singleton] at hor, conv at hor {
            find (f.fun_value x ∈ one.{u}) { rw one },
          }, simp only [succ, mem_union, mem_singleton, iff_false_intro (mem_empty (f.fun_value x)), or_false] at hor,
          rw mem_sep at h,
          cases hor,
          { exfalso, apply h, finish, },
          { finish, }, }, }, },
end

lemma powerset_corr_fun_value {B A : Set} (hB : A ⊆ B) : B.powerset_corr.fun_value A = B.char_fun A :=
begin
  symmetry, apply fun_value_def pair_sep_eq_is_fun, simp only [pair_mem_pair_sep, mem_powerset, mem_into_funs],
  exact ⟨hB, char_fun_into_fun, rfl⟩,
end

lemma powerset_corr_oto {B : Set} : B.powerset_corr.one_to_one :=
begin
  apply one_to_one_of (is_function_of_into (into_of_onto powerset_corr_onto)),
  intros A hA A' hA' hne he, apply hne,
  simp only [dom_eq_of_into (into_of_onto powerset_corr_onto), mem_powerset] at hA hA',
  rw [powerset_corr_fun_value hA, powerset_corr_fun_value hA'] at he,
  apply ext, intro x,
  split,
  { intro hx, rw ←char_fun_value' (hA hx), rw ←he, rw char_fun_value' (hA hx), assumption, },
  { intro hx, rw ←char_fun_value' (hA' hx), rw he, rw char_fun_value' (hA' hx), assumption, },
end

lemma powerset_corr_corr {A : Set} : A.powerset.correspondence (A.into_funs two) A.powerset_corr
:= ⟨powerset_corr_onto, powerset_corr_oto⟩

-- example on page 131
theorem powerset_equinumerous_into_funs {A : Set} : A.powerset.equinumerous (A.into_funs two) := ⟨_, powerset_corr_corr⟩

-- Theorem 6A part a
theorem equin_refl {A : Set} : A.equinumerous A := ⟨_, id_onto, id_oto⟩

lemma corr_symm {A B f : Set} (h : correspondence A B f) : correspondence B A f.inv :=
begin
  split,
    split,
      rw T3F_a, exact h.oto,
    rw [T3E_a, T3E_b], exact ⟨h.onto.right.right, h.onto.right.left⟩,
  rw ←T3F_b h.onto.left.left, exact h.onto.left,
end

-- Theorem 6A part b
theorem equin_symm {A B : Set} (heq : A.equinumerous B) : B.equinumerous A :=
begin
  rcases heq with ⟨F, hF⟩, exact ⟨F.inv, corr_symm hF⟩,
end

lemma corr_trans {A B C f g : Set} (hAB : correspondence A B f) (hBC : correspondence B C g) :
  correspondence A C (g.comp f) :=
begin
  have hfun : (g.comp f).is_function := T3H_a hBC.onto.left hAB.onto.left,
  have hdom : (g.comp f).dom = f.dom,
    rw T3H_b hBC.onto.left hAB.onto.left, apply ext, intro x,
    rw [mem_sep, hBC.onto.right.left, hAB.onto.right.left, and_iff_left_iff_imp, ←hAB.onto.right.left, ←hAB.onto.right.right],
    exact fun_value_def'' hAB.onto.left,
  refine ⟨⟨hfun, _, _⟩, _⟩,
  { rw hdom, exact hAB.onto.right.left, },
  { apply ext, intro z,
    simp only [mem_ran_iff hfun, ←hBC.onto.right.right, mem_ran_iff hBC.onto.left, hBC.onto.right.left, ←hAB.onto.right.right, mem_ran_iff hAB.onto.left, hdom], split,
    { rintro ⟨x, hx, he⟩, refine ⟨f.fun_value x, ⟨_, hx, rfl⟩, _⟩, rw ←T3H_c hBC.onto.left hAB.onto.left, assumption, rw hdom, assumption, },
    { rintro ⟨y, ⟨x, hx, he⟩, he'⟩, refine ⟨x, hx, _⟩, rw T3H_c hBC.onto.left hAB.onto.left, rw ←he, assumption, rw hdom, assumption, }, },
  { apply one_to_one_of hfun, intros x hx x' hx' hne he, apply hne,
    rw [T3H_c hBC.onto.left hAB.onto.left hx, T3H_c hBC.onto.left hAB.onto.left hx'] at he,
    apply from_one_to_one hAB.onto.left hAB.oto, rw ←hdom, assumption, rw ←hdom, assumption,
    apply from_one_to_one hBC.onto.left hBC.oto,
    { rw [hBC.onto.right.left, ←hAB.onto.right.right], apply fun_value_def'' hAB.onto.left, rw ←hdom, assumption, },
    { rw [hBC.onto.right.left, ←hAB.onto.right.right], apply fun_value_def'' hAB.onto.left, rw ←hdom, assumption, },
    assumption, },
end

-- Theorem 6A part c
theorem equin_trans {A B C : Set} (hAB : A.equinumerous B) (hBC : B.equinumerous C) : A.equinumerous C :=
begin
  rcases hAB with ⟨F, hF⟩, rcases hBC with ⟨G, hG⟩, exact ⟨G.comp F, corr_trans hF hG⟩,
end

-- Prove that omega.times omega is equinumerous to omega
-- Porve that the set of nats is equinumerous to the set of rational numbers
-- Prove Theorem 6A part a (omega is not equinumerous to the set of real numbers)

-- Theorem 6B part b
theorem not_equin_powerset {A : Set} : ¬ A.equinumerous A.powerset :=
begin
  rintro ⟨g, gonto, goto⟩,
  let B := { x ∈ A | x ∉ g.fun_value x },
  have hB : B ∈ g.ran,
    rw [gonto.right.right, mem_powerset], intro x, rw [mem_sep], intro h, finish,
  rw [mem_ran_iff gonto.left, gonto.right.left] at hB, rcases hB with ⟨x, hx, he⟩,
  have h : x ∈ B ↔ x ∉ g.fun_value x,
    simp only [mem_sep, hx, true_and],
  rw he at h, exact (iff_not_self _).mp h,
end

def is_finite (A : Set) : Prop := ∃ n : Set, n ∈ ω ∧ A.equinumerous n

lemma inhab_of_inf {X : Set} (Xinf : ¬ X.is_finite) : X.inhab :=
begin
  apply classical.by_contradiction, intro Xi, apply Xinf, refine ⟨_, zero_nat, _⟩,
  rw inhab at Xi, push_neg at Xi,
  rw (eq_empty _).mpr Xi, exact equin_refl,
end

lemma finite_of_equin_finite {A : Set} (hA : A.is_finite) {B : Set} (hAB : A ≈ B) : B.is_finite :=
begin
  rcases hA with ⟨n, hn, hAn⟩, exact ⟨_, hn, equin_trans (equin_symm hAB) hAn⟩,
end

theorem pigeonhole : ∀ {n : Set}, n ∈ ω → ∀ {A : Set}, A ⊂ n → ¬ n.equinumerous A :=
begin
  suffices h : ∀ {n : Set}, n ∈ ω → ∀ {f : Set}, f.into_fun n n → f.one_to_one → f.ran = n,
    rintros n hn A hA ⟨f, fonto, foto⟩, simp at hA,
    have h : A = n, rw ←fonto.right.right,
      have hinto : f.into_fun n n, refine ⟨fonto.left, fonto.right.left, _⟩,
        rw fonto.right.right, exact hA.left,
      exact h hn hinto foto,
    exact hA.right h,
  apply @induction (λ n, ∀ {f : Set}, f.into_fun n n → f.one_to_one → f.ran = n),
  { intros f hinto foto, simp only [←mem_into_funs, ex2, mem_singleton] at hinto, rw hinto, apply ext, intro y,
    simp only [mem_ran, iff_false_intro (mem_empty _), exists_false], },
  { intros k hk hi,
    have hcaseI : ∀ {f : Set}, f.into_fun k.succ k.succ → f.one_to_one → (∀ {n : Set}, n ∈ k → f.fun_value n ∈ k) → f.ran = k.succ,
      intros f hinto hoto hc,
      have hf : {k.pair (f.fun_value k)} ∪ f.restrict k = f,
        have hd : k ∈ f.dom, rw hinto.right.left, exact self_mem_succ,
        rw ←restrict_singleton_eq hinto.left hd, apply restrict_combine hinto.left.left,
        rw [hinto.right.left, succ],
      have hd : k ⊆ f.dom, rw [hinto.right.left], exact self_sub_succ,
      have hf' : (f.restrict k).ran = k,
        have hr : (f.restrict k).ran ⊆ k,
          intro n, rw [mem_ran_iff (restrict_is_function hinto.left), restrict_dom hd],
          rintro ⟨x, hx, he⟩, rw he, rw restrict_fun_value hinto.left hd hx, exact hc hx,
        rw eq_iff_subset_and_subset, refine ⟨hr, _⟩,
        have frinto : (f.restrict k).into_fun k k, refine ⟨restrict_is_function hinto.left, restrict_dom hd, hr⟩,
        have froto: (f.restrict k).one_to_one := restrict_one_to_one hinto.left hoto hd,
        rw hi frinto froto, exact subset_self,
      have hf'' : ({k.pair (f.fun_value k)} : Set).ran = {k}, rw ran_singleton, rw singleton_eq,
        have ho : f.fun_value k ∈ k ∨ f.fun_value k = k, rw [←le_iff, ←mem_succ_iff_le],
          apply hinto.right.right, apply fun_value_def'' hinto.left, rw hinto.right.left, exact self_mem_succ,
        cases ho,
        { exfalso, nth_rewrite 1 ←hf' at ho, rw [mem_ran_iff, restrict_dom hd] at ho,
          rcases ho with ⟨n, hn, he⟩, rw restrict_fun_value hinto.left hd hn at he,
          have h : k = n, apply from_one_to_one hinto.left hoto,
            { rw hinto.right.left, exact self_mem_succ, },
            { rw hinto.right.left, exact lt_trans ((mem_nat_iff hk).mp hn).left hk (nat_induct.succ_closed hk) hn self_mem_succ, },
            { exact he, },
          rw ←h at hn, exact nat_not_mem_self hk hn,
          exact restrict_is_function hinto.left, },
        { assumption, },
      rw [←hf, ran_union, hf', hf'', succ],
    intros f hinto hoto, by_cases hc : ∃ n : Set, n ∈ k ∧ f.fun_value n = k,
    { rcases hc with ⟨p, hp, he⟩,
      let f' : Set := {p.pair (f.fun_value k), k.pair k} ∪ (f \ {p.pair k, k.pair (f.fun_value k)}),
      have hps : p ∈ k.succ := self_sub_succ hp,
      have hr : ∀ {x : Set}, x ∈ k.succ → f.fun_value x ∈ k.succ, intros x hx,
        apply hinto.right.right, rw ←hinto.right.left at hx, exact fun_value_def'' hinto.left hx,
      have f'into : f'.into_fun k.succ k.succ, rw fun_def_equiv, refine ⟨λ z hz, _, λ x hx, _⟩,
        { simp only [mem_union, mem_insert, mem_singleton, mem_diff] at hz,
          simp only [mem_prod], rcases hz with (hz|hz)|⟨hm,hz⟩,
          { exact ⟨_, hps, _, hr self_mem_succ, hz⟩, },
          { exact ⟨_, self_mem_succ, _, self_mem_succ, hz⟩, },
          { rw fun_def_equiv at hinto, replace hinto := hinto.left hm, rw mem_prod at hinto, assumption, }, },
        { rw fun_def_equiv at hinto, simp only [mem_union, mem_insert, mem_singleton, mem_diff],
          by_cases hep : x = p,
          { rw hep, refine ⟨_, or.inl (or.inl rfl), _⟩, rintros y ((hz|hz)|⟨hm,hz⟩),
            { exact (pair_inj hz).right, },
            { rw [←(pair_inj hz).left, (pair_inj hz).right, he], },
            { rw ←fun_def_equiv at hinto, exfalso, apply hz, left, rw ←he,
              rw fun_value_def hinto.left hm, }, },
          { rw [mem_succ_iff_le, le_iff] at hx, cases hx,
            { rw ←fun_def_equiv at hinto, refine ⟨f.fun_value x, or.inr ⟨fun_value_def' hinto.left _, _⟩, _⟩,
              { rw hinto.right.left, exact self_sub_succ hx, },
              { rintro (hpe|hpe),
                { exact hep (pair_inj hpe).left, },
                { rw (pair_inj hpe).left at hx, exact nat_not_mem_self hk hx, }, },
              { rintros y ((hz|hz)|⟨hm,hz⟩),
                { exfalso, exact hep (pair_inj hz).left, },
                { exfalso, rw (pair_inj hz).left at hx, exact nat_not_mem_self hk hx, },
                { exact fun_value_def hinto.left hm, }, }, },
            { rw hx, refine ⟨_, or.inl (or.inr rfl), _⟩, rintros y ((hz|hz)|⟨hm,hz⟩),
              { exfalso, rw (pair_inj hz).left at hx, exact hep hx, },
              { exact (pair_inj hz).right, },
              { exfalso, apply hz, right, rw ←fun_def_equiv at hinto, rw fun_value_def hinto.left hm, }, }, }, },
      have hfp : f'.fun_value p = f.fun_value k, symmetry, apply fun_value_def f'into.left,
        simp only [mem_union, mem_insert, mem_singleton], finish,
      have hfk : f'.fun_value k = k, symmetry, apply fun_value_def f'into.left,
        simp only [mem_union, mem_insert, mem_singleton], finish,
      have hfo : ∀ {n : Set}, n ≠ p → n ∈ k → f'.fun_value n = f.fun_value n,
        intros l hlp hlk, symmetry, apply fun_value_def f'into.left,
        simp only [mem_union, mem_insert, mem_singleton, mem_diff],
        refine or.inr ⟨fun_value_def' hinto.left _, _⟩,
        { rw hinto.right.left, exact self_sub_succ hlk, },
        { rintro (hor|hor),
          { exact hlp (pair_inj hor).left, },
          { apply nat_not_mem_self hk,
            suffices hlke : l = k,
              nth_rewrite 0 ←hlke, exact hlk,
            apply from_one_to_one hinto.left hoto,
            { rw hinto.right.left, exact self_sub_succ hlk, },
            { rw hinto.right.left, exact self_mem_succ, },
            exact (pair_inj hor).right, }, },
      have hor : ∀ {n : Set}, n ∈ k.succ → n = p ∨ n = k ∨ n ≠ p ∧ n ∈ k,
        intros m hmk, by_cases ho : m = p,
        { exact or.inl ho, },
        { rw [mem_succ_iff_le, le_iff] at hmk, cases hmk,
          { exact or.inr (or.inr ⟨ho, hmk⟩), },
          { exact or.inr (or.inl hmk), }, },
      have f'oto : f'.one_to_one,
        apply one_to_one_of f'into.left, simp only [f'into.right.left],
        intros m hm n hn hne hmn, apply hne,
        obtain (horm|horm|horm) := hor hm; obtain (horn|horn|horn) := hor hn,
        { rw [horm, horn], },
        { exfalso, apply nat_not_mem_self hk,
          suffices hkp : k = p,
            nth_rewrite 0 hkp, exact hp,
          apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact self_mem_succ, },
          { rw [hinto.right.left, ←horm], exact hm, },
          rw [←hfp, ←horm, hmn, horn, hfk, ←he, horm], },
        { exfalso, apply nat_not_mem_self hk,
          suffices hkn : k = n,
            nth_rewrite 0 hkn, exact horn.right,
          apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact self_mem_succ, },
          { rw hinto.right.left, exact hn, },
          rw [←hfp, ←horm, hmn, hfo horn.left horn.right], },
        { exfalso, apply nat_not_mem_self hk,
          suffices hkp : k = p,
            nth_rewrite 0 hkp, exact hp,
          apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact self_mem_succ, },
          { rw [hinto.right.left, ←horn], exact hn, },
          rw [←hfp, ←horn, ←hmn, horm, hfk, ←he, horn], },
        { rw [horm, horn], },
        { exfalso, apply horn.left,
          apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact hn, },
          { rw hinto.right.left, exact self_sub_succ hp, },
          rw [he, ←hfk, ←horm, hmn, hfo horn.left horn.right], },
        { exfalso, apply nat_not_mem_self hk,
          suffices hkn : k = m,
            nth_rewrite 0 hkn, exact horm.right,
          apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact self_mem_succ, },
          { rw hinto.right.left, exact hm, },
          rw [←hfp, ←horn, ←hmn, hfo horm.left horm.right], },
        { exfalso, apply horm.left,
          apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact hm, },
          { rw hinto.right.left, exact self_sub_succ hp, },
          rw [he, ←hfk, ←horn, ←hmn, hfo horm.left horm.right], },
        { apply from_one_to_one hinto.left hoto,
          { rw hinto.right.left, exact hm, },
          { rw hinto.right.left, exact hn, },
          rw [←hfo horm.left horm.right, ←hfo horn.left horn.right, hmn], },
      have f'cl : ∀ {n : Set}, n ∈ k → f'.fun_value n ∈ k,
        intros n hnk, by_cases hnp : n = p,
        { rw [hnp, hfp], specialize hr self_mem_succ, rw [mem_succ_iff_le, le_iff] at hr, cases hr,
          { exact hr, },
          { exfalso, nth_rewrite 1 ←he at hr,
            suffices hkp : k = p, rw ←hkp at hp, exact nat_not_mem_self hk hp,
            apply from_one_to_one hinto.left hoto,
            { rw hinto.right.left, exact self_mem_succ, },
            { rw hinto.right.left, exact self_sub_succ hp, },
            exact hr, }, },
        { rw hfo hnp hnk, specialize hr (self_sub_succ hnk), rw [mem_succ_iff_le, le_iff] at hr, cases hr,
          { exact hr, },
          { exfalso, rw ←he at hr, apply hnp, apply from_one_to_one hinto.left hoto,
            { rw hinto.right.left, exact self_sub_succ hnk, },
            { rw hinto.right.left, exact hps, },
            exact hr, }, },
      have freq : f'.ran = f.ran, rw eq_iff_subset_and_subset, split,
      { intro y, simp only [mem_ran_iff hinto.left, mem_ran_iff f'into.left, hinto.right.left, f'into.right.left],
        rintro ⟨n, hn, hm⟩, obtain (hnp|hnk|⟨hnp,hnk⟩) := hor hn,
        { rw [hnp, hfp] at hm, exact ⟨_, self_mem_succ, hm⟩, },
        { rw [hnk, hfk, ←he] at hm, exact ⟨_, self_sub_succ hp, hm⟩, },
        { rw hfo hnp hnk at hm, exact ⟨_, hn, hm⟩, }, },
      { rw hcaseI f'into f'oto @f'cl, exact hinto.right.right, },
      rw ←freq, exact hcaseI f'into f'oto @f'cl, },
    { replace hc : ∀ {n : Set}, n ∈ k → f.fun_value n ∈ k,
        intros n hn,
        have ho : f.fun_value n ∈ k ∨ f.fun_value n = k, rw [←le_iff, ←mem_succ_iff_le],
          apply hinto.right.right, apply fun_value_def'' hinto.left, rw hinto.right.left,
          rw [mem_succ_iff_le, le_iff], finish,
        cases ho,
        { assumption, },
        { exfalso, exact hc ⟨_, hn, ho⟩, },
      exact hcaseI hinto hoto @hc, }, },
end

-- Corollary 6C
theorem pigeonhole' : ¬ ∃ A : Set, A.is_finite ∧ ∃ B : Set, B ⊂ A ∧ A.equinumerous B :=
begin
  rintro ⟨A, ⟨n, hn, g, hfin⟩, B, hBA, f, heq⟩,
  let H : Set := g.comp (f.comp g.inv),
  have Hoto : H.one_to_one, refine comp_one_to_one hfin.oto (comp_one_to_one heq.oto _),
    rw ←T3F_b hfin.onto.left.left, exact hfin.onto.left,
  have Hdom : H.dom = n,
    have h : g.inv.ran = f.dom, rw [T3E_b, heq.onto.right.left, hfin.onto.right.left],
    have hl : g.inv.ran ⊆ f.dom, rw h, exact subset_self,
    have hr : f.dom ⊆ g.inv.ran, rw h, exact subset_self,
    have h' : (f.comp g.inv).ran ⊆ g.dom, rw [ran_comp hr, heq.onto.right.right, hfin.onto.right.left], exact hBA.left,
    rw [dom_comp h', dom_comp hl, T3E_a, hfin.onto.right.right],
  have Hran : H.ran ⊆ n, rw ←hfin.onto.right.right, exact ran_comp_sub,
  have Hfun : H.is_function, apply T3H_a hfin.onto.left, apply T3H_a heq.onto.left,
    rw T3F_a, exact hfin.oto,
  have hr : H.ran ⊂ n, refine ⟨Hran, λ he, _⟩,
    have hex : ∃ x, x ∈ A ∧ x ∉ B, apply classical.by_contradiction, intro h, apply hBA.right,
      rw eq_iff_subset_and_subset, refine ⟨hBA.left, λ x hx, _⟩,
      apply classical.by_contradiction, intro hnx, apply h,
      exact ⟨_, hx, hnx⟩,
    rcases hex with ⟨a, hA, hB⟩,
    have h : g.fun_value a ∉ H.ran, intro h, apply hB, rw mem_ran_iff Hfun at h, rcases h with ⟨x, hn, ho⟩,
      rw T3H_c hfin.onto.left (T3H_a heq.onto.left (T3F_a.mpr hfin.oto)) _ at ho,
      have h : (f.comp g.inv).ran = B, rw ←heq.onto.right.right, apply ran_comp,
        rw [T3E_b, hfin.onto.right.left, heq.onto.right.left], exact subset_self,
      have hax : a = (f.comp g.inv).fun_value x, apply from_one_to_one hfin.onto.left hfin.oto,
        { rw hfin.onto.right.left, exact hA, },
        { rw hfin.onto.right.left,
          have h : (f.comp g.inv).ran = B, rw ←heq.onto.right.right, apply ran_comp,
            rw [T3E_b, hfin.onto.right.left, heq.onto.right.left], exact subset_self,
          apply hBA.left, rw ←h, apply fun_value_def'' (T3H_a heq.onto.left (T3F_a.mpr hfin.oto)),
          rw dom_comp, rw [T3E_a, hfin.onto.right.right], rw ←Hdom, exact hn,
          rw [T3E_b, hfin.onto.right.left, heq.onto.right.left], exact subset_self, },
        exact ho,
      rw [hax, ←h], apply fun_value_def'' (T3H_a heq.onto.left (T3F_a.mpr hfin.oto)),
      rw dom_comp, rw [T3E_a, hfin.onto.right.right], rw ←Hdom, exact hn,
      rw [T3E_b, hfin.onto.right.left, heq.onto.right.left], exact subset_self,
      exact hn,
      apply h, rw he, rw ←hfin.onto.right.right, apply fun_value_def'' hfin.onto.left, rw hfin.onto.right.left, exact hA,
  apply pigeonhole hn hr,
  exact ⟨H, ⟨Hfun, Hdom, rfl⟩, Hoto⟩,
end

-- Corollary 6D part a
theorem pigeonhole'' {A B : Set} (hBA : B ⊂ A) (heq : A.equinumerous B) : ¬ A.is_finite :=
begin
  intro hf, apply pigeonhole', exact ⟨A, hf, B, hBA, heq⟩,
end

-- Corollary 6D part b
theorem nat_infinite : ¬ (ω : Set).is_finite :=
begin
  have h : ∅ ∉ succ_fun.ran := succ_not_onto,
  have hr : succ_fun.ran ⊂ ω, refine ⟨succ_fun_into_fun.right.right, _⟩,
    intro he, apply h, rw he, exact nat_induct.zero,
  exact pigeonhole'' hr ⟨succ_fun, ⟨succ_fun_into_fun.left, succ_fun_into_fun.right.left, rfl⟩, succ_one_to_one⟩,
end

-- Corollary 6D part c
theorem exists_unique_equiv_nat_of_finite {A : Set} (hf : A.is_finite) : ∃! n : Set, n ∈ ω ∧ A.equinumerous n :=
begin
  apply exists_unique_of_exists_of_unique hf, rintros n m ⟨hn, hAn⟩ ⟨hm, hAm⟩,
  have hnmeq : n.equinumerous m := equin_trans (equin_symm hAn) hAm,
  apply classical.by_contradiction, intro hne,
  cases nat_order_lin.conn hn hm hne with hnm hnm; rw [nat_order, pair_mem_pair_sep] at hnm; rcases hnm with ⟨-, -, hnm⟩,
  { rw ←nat_ssub_iff_mem hn hm at hnm, exact pigeonhole'' hnm (equin_symm hnmeq) ⟨_, hm, equin_refl⟩, },
  { rw ←nat_ssub_iff_mem hm hn at hnm, exact pigeonhole'' hnm hnmeq ⟨_, hn, equin_refl⟩, },
end

-- problem 20
theorem exists_desc_chain_of_no_least {A : Set} (hA : A ≠ ∅) {R : Set} (hR : R.is_rel) (h : ∀ x ∈ A, ∃ y : Set, y ∈ A ∧ y.pair x ∈ R) :
∃ f : Set, f.into_fun ω A ∧ ∀ ⦃n : Set⦄, n ∈ ω → (f.fun_value n.succ).pair (f.fun_value n) ∈ R :=
begin
  let S : Set := pair_sep (λ x y : Set, y.pair x ∈ R) A A,
  have domS : S.dom = A, rw eq_iff_subset_and_subset, split,
      exact pair_sep_dom_sub,
    intros x hx, obtain ⟨y, hy, hyx⟩ := h _ hx, rw mem_dom, use y, rw pair_mem_pair_sep,
    exact ⟨hx, hy, hyx⟩,
  obtain ⟨g, gfun, gsub, gdom⟩ := @ax_ch_1 S pair_sep_is_rel,
  have ginto : g.into_fun A A, refine ⟨gfun, _, _⟩,
      rw [gdom, domS],
    intro y, rw mem_ran, rintro ⟨x, hxy⟩, replace hxy := gsub hxy, rw pair_mem_pair_sep at hxy,
    exact hxy.right.left,
  obtain ⟨a, ha⟩ := inhabited_of_ne_empty hA,
  let f : Set := A.rec_fun a g,
  refine ⟨f, rec_fun_into_fun ha ginto, λ n hn, _⟩,
  have he := (recursion_thm ha ginto).right _ hn, rw he,
  suffices h : (f.fun_value n).pair (g.fun_value ((A.rec_fun a g).fun_value n)) ∈ S,
    rw pair_mem_pair_sep at h, exact h.right.right,
  apply gsub, apply fun_value_def' ginto.left, rw [gdom, domS], apply @rec_fun_ran A a g,
  apply fun_value_def'' (rec_fun_is_fun ha), rw rec_fun_dom_eq_nat ha ginto, exact hn,
end

def dominated (A B : Set) : Prop := ∃ f : Set, f.into_fun A B ∧ f.one_to_one
infix ≼ := dominated
lemma dominated_iff {A B : Set} : A ≼ B ↔ ∃ C : Set, C ⊆ B ∧ A.equinumerous C :=
begin
  split,
  { rintro ⟨f, finto, foto⟩, exact ⟨_, finto.right.right, _, onto_ran_of_into finto, foto⟩, },
  { rintro ⟨C, hCB, f, fonto, foto⟩, exact ⟨_, into_of_onto_ran_sub hCB fonto, foto⟩, },
end

end Set


/-
Copyright (c) 2021 Tianchen Zhao. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tianchen Zhao
-/
import congruence.ang_lt

/-!
# Right angles and perpendicularity

This file defines right angles using `supplementary` and how two lines
are perpendicular, proves that all right angles are congruent

## Main definitions

* `is_right_ang` defines a right angle.

* `perpendicular` means two lines intersects at 90°.

## References

* See [Geometry: Euclid and Beyond]

-/

open incidence_geometry incidence_order_geometry hilbert_plane

variables [C : hilbert_plane]

include C

/--An ang is a right ang if it is congruent to its supplementary ang. -/
def is_right_ang (α : ang) : Prop :=
ang_proper α ∧ ∀ β : ang, supplementary α β → (α ≅ₐ β)

lemma supplementary_exist {α : ang} (haob : ang_proper α) :
∃ β : ang, supplementary α β :=
begin
  rcases ang_three_pt α with ⟨a, b, h⟩,
  rw h, rw [h, ang_proper_iff_noncol] at haob, set o := α.vertex,
  have hob := (noncol_neq haob).2.2,
  cases between_extend hob.symm with c hboc,
  have hoc := (between_neq hboc).2.2,
  use (∠ a o c), rw three_pt_ang_supplementary,
  split, exact hboc,
  split, exact haob,
  exact noncol132 (col_noncol (col12 (between_col hboc))
    (noncol123 haob) hoc),
end

lemma right_ang_congr {α β : ang} :
(α ≅ₐ β) → is_right_ang α → ang_proper β → is_right_ang β :=
begin
  intros hαβ hα hβ,
  split, exact hβ,
  intros β' hββ',
  cases supplementary_exist hα.1 with α' hαα',
  exact ang_congr_trans (ang_congr_trans (ang_congr_symm hαβ) (hα.2 α' hαα'))
    (supplementary_congr hαα' hββ' hαβ),
end

lemma three_pt_ang_is_right_ang {a o b c : pts} (hboc : between b o c) :
is_right_ang (∠ a o b) ↔ ((∠ a o b) ≅ₐ (∠ a o c)) ∧ ang_proper (∠ a o b) :=
begin
  unfold is_right_ang,
  split; intro h, split,
  apply h.2, rw three_pt_ang_supplementary,
  have haob := ang_proper_iff_noncol.1 h.1,
  split, exact hboc, split, exact haob,
  exact noncol132 (col_noncol (col12 (between_col hboc))
    (noncol12 (noncol13 haob)) (between_neq hboc).2.2),
  exact h.1,
  split, exact h.2,
  intros β hβ, rcases hβ.1 with ⟨o', a', b', c', haoba'ob', ha'oc', hb'oc'⟩,
  have haob := ang_proper_iff_noncol.1 h.2,
  have haoc := noncol132 (col_noncol (col12 (between_col hboc))
    (noncol12 (noncol13 haob)) (between_neq hboc).2.2),
  have hoo' := ((three_pt_ang_eq_iff haob).1 haoba'ob').1, rw ←hoo' at *,
  cases ((three_pt_ang_eq_iff haob).1 haoba'ob').2 with H H,
  rw ha'oc',
  have : (∠ a o c) = (∠ a' o c'),
    rw three_pt_ang_eq_iff haoc, simp, left,
    split, exact H.1,
    apply diff_side_pt_cancel (between_diff_side_pt.1 hboc),
    rw between_diff_side_pt at hb'oc',
    exact diff_side_pt_symm (diff_same_side_pt hb'oc' (same_side_pt_symm H.2)),
  rw ←this, exact h.1,
  rw ha'oc', apply ang_congr_trans h.1, rw ang_symm,
  refine vertical_ang_congr _ _ _,
  exact noncol13 haoc,
  rw between_diff_side_pt, rw between_diff_side_pt at hboc,
  exact diff_same_side_pt hboc H.2,
  rw between_diff_side_pt, rw between_diff_side_pt at hb'oc',
  exact diff_side_pt_symm (diff_same_side_pt hb'oc' (same_side_pt_symm H.1))
end

lemma right_supplementary_right {α β : ang} (hα : is_right_ang α) (hαβ : supplementary α β) :
is_right_ang β :=
begin
  apply right_ang_congr,
  apply hα.2,
  exact hαβ,
  exact hα,
  exact hαβ.2.2
end

lemma all_right_ang_congr {α β : ang}
(hα : is_right_ang α) (hβ : is_right_ang β) : α ≅ₐ β :=
begin
  have wlog : ∀ α β : ang, is_right_ang α → is_right_ang β → (α <ₐ β) → false,
    intros x y hx hy hxy,
    rcases ang_three_pt y with ⟨a, b, haob⟩,
    set o := y.vertex, rw haob at hxy,
    rw haob at hy,
    have hbo := (noncol_neq (ang_proper_iff_noncol.1 hy.1)).2.2.symm,
    rw [ang_symm, three_pt_ang_lt] at hxy,
    rcases hxy with ⟨p, hpin, hp⟩,
    have hboa := ang_proper_iff_noncol.1 (inside_ang_proper hpin),
    rw inside_three_pt_ang at hpin,
    cases between_extend hbo with c hboc,
    have hco := (between_neq hboc).2.2.symm,
    rw three_pt_ang_is_right_ang hboc at hy,
    have h₁ : supplementary (∠ p o b) (∠ p o c),
      rw three_pt_ang_supplementary,
      split, exact hboc,
      have : noncol p o b,
        intro hpob,
        exact (same_side_line_notin hpin.1).2 (col_in23 hpob hbo.symm),
      split, exact this,
      exact noncol132 (col_noncol (col12 (between_col hboc))
        (noncol123 this) hco.symm),
    have h₂ : supplementary (∠ a o b) (∠ a o c),
      rw three_pt_ang_supplementary,
      split, exact hboc,
      split, exact noncol13 hboa,
      exact noncol132 ((col_noncol (col12 (between_col hboc))
        (noncol12 hboa)) hco.symm),
    have hf₁ : ((∠ p o c) <ₐ (∠ a o c)),
      have hbop : noncol b o p,
        intro hbop, rw line_symm at hpin,
        exact (same_side_line_notin hpin.1).2 (col_in12 hbop hbo),
      replace hbop := right_ang_congr (ang_congr_symm hp) hx
        (ang_proper_iff_noncol.2 hbop),
      rw ang_symm at hbop,
      have : ((∠ p o b) <ₐ (∠ a o b)),
        rw [ang_symm, ang_symm a o b, three_pt_ang_lt],
        exact ⟨p, inside_three_pt_ang.2 hpin, ang_congr_refl _⟩,
      replace h₁ := hbop.2 _ h₁,
      replace h₂ := hy.1,
      apply (ang_lt_congr h₁).1, apply (ang_lt_congr h₂).2,
      rw ang_proper_iff_noncol,
      exact noncol132 (col_noncol (col12 (between_col hboc))
        (noncol12 hboa) hco.symm),
      exact this,
    have hf₂ : ((∠ a o c) <ₐ (∠ p o c)),
      rw [ang_symm, ang_symm p o c, three_pt_ang_lt],
      use a, split,
      rw ang_symm, exact inside_ang_trans' hboc (by {rw ang_symm,
        exact inside_three_pt_ang.2 hpin}),
      exact ang_congr_refl _,
    exact (ang_tri h₁.2.2 h₂.2.2).2.2.1 ⟨hf₁, hf₂⟩,
  rcases (ang_tri hα.1 hβ.1).1 with h | h | h,
  exfalso, exact wlog α β hα hβ h,
  exact h,
  exfalso, exact wlog β α hβ hα h
end

/--Two lines are perpendicular if they form a right ang. -/
def perpendicular (l₁ l₂ : set pts) : Prop :=
(∃ (a b c : pts), a ∈ l₁ ∧ b ∈ l₂ ∧ c ∈ l₁ ∩ l₂ ∧ is_right_ang (∠ a c b))
∧ l₁ ∈ lines ∧ l₂ ∈ lines

lemma perpendicular_symm (l₁ l₂ : set pts) :
perpendicular l₁ l₂ → perpendicular l₂ l₁ :=
begin
  rintros ⟨⟨a, b, c, hal₁, hbl₂, hcl, hr⟩, hl⟩,
  rw ang_symm at hr, rw set.inter_comm at hcl, rw and_comm at hl,
  use [b, a, c],
  exact ⟨hbl₂, hal₁, hcl, hr⟩, exact hl
end

localized "notation a `⊥` b := perpendicular a b" in perp_notation


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.category.basic
import category_theory.equivalence
import category_theory.eq_to_hom

/-!
# Basic API for ulift

This file contains a very basic API for working with the categorical
instance on `ulift C` where `C` is a type with a category instance.

1. `category_theory.ulift.up` is the functorial version of the usual `ulift.up`.
2. `category_theory.ulift.down` is the functorial version of the usual `ulift.down`.
3. `category_theory.ulift.equivalence` is the categorical equivalence between
  `C` and `ulift C`.

# ulift_hom

Given a type `C : Type u`, `ulift_hom.{w} C` is just an alias for `C`.
If we have `category.{v} C`, then `ulift_hom.{w} C` is endowed with a category instance
whose morphisms are obtained by applying `ulift.{w}` to the morphisms from `C`.

This is a category equivalent to `C`. The forward direction of the equivalence is `ulift_hom.up`,
the backward direction is `ulift_hom.donw` and the equivalence is `ulift_hom.equiv`.

# as_small

This file also contains a construction which takes a type `C : Type u` with a
category instance `category.{v} C` and makes a small category
`as_small.{w} C : Type (max w v u)` equivalent to `C`.

The forward direction of the equivalence, `C ⥤ as_small C`, is denoted `as_small.up`
and the backward direction is `as_small.down`. The equivalence itself is `as_small.equiv`.
-/

universes w₁ v₁ v₂ u₁ u₂

namespace category_theory

variables {C : Type u₁} [category.{v₁} C]

/-- The functorial version of `ulift.up`. -/
@[simps]
def ulift.up_functor : C ⥤ (ulift.{u₂} C) :=
{ obj := ulift.up,
  map := λ X Y f, f }

/-- The functorial version of `ulift.down`. -/
@[simps]
def ulift.down_functor : (ulift.{u₂} C) ⥤ C :=
{ obj := ulift.down,
  map := λ X Y f, f }

/-- The categorical equivalence between `C` and `ulift C`. -/
@[simps]
def ulift.equivalence : C ≌ (ulift.{u₂} C) :=
{ functor := ulift.up_functor,
  inverse := ulift.down_functor,
  unit_iso :=
  { hom := 𝟙 _,
    inv := 𝟙 _ },
  counit_iso :=
  { hom :=
    { app := λ X, 𝟙 _,
      naturality' := λ X Y f, by {change f ≫ 𝟙 _ = 𝟙 _ ≫ f, simp} },
    inv :=
    { app := λ X, 𝟙 _,
      naturality' := λ X Y f, by {change f ≫ 𝟙 _ = 𝟙 _ ≫ f, simp} },
  hom_inv_id' := by {ext, change (𝟙 _) ≫ (𝟙 _) = 𝟙 _, simp},
  inv_hom_id' := by {ext, change (𝟙 _) ≫ (𝟙 _) = 𝟙 _, simp} },
  functor_unit_iso_comp' := λ X, by {change (𝟙 X) ≫ (𝟙 X) = 𝟙 X, simp} }

section ulift_hom

/-- `ulift_hom.{w} C` is an alias for `C`, which is endowed with a category instance
  whose morphisms are obtained by applying `ulift.{w}` to the morphisms from `C`.
-/
def {w u} ulift_hom (C : Type u) := C

instance {C} [inhabited C] : inhabited (ulift_hom C) := ⟨(arbitrary C : C)⟩

/-- The obvious function `ulift_hom C → C`. -/
def ulift_hom.obj_down {C} (A : ulift_hom C) : C := A

/-- The obvious function `C → ulift_hom C`. -/
def ulift_hom.obj_up {C} (A : C) : ulift_hom C := A

@[simp] lemma obj_down_obj_up {C} (A : C) : (ulift_hom.obj_up A).obj_down = A := rfl
@[simp] lemma obj_up_obj_down {C} (A : ulift_hom C) : ulift_hom.obj_up A.obj_down = A := rfl

instance : category.{max v₂ v₁} (ulift_hom.{v₂} C) :=
{ hom := λ A B, ulift.{v₂} $ A.obj_down ⟶ B.obj_down,
  id := λ A, ⟨𝟙 _⟩,
  comp := λ A B C f g, ⟨f.down ≫ g.down⟩}

/-- One half of the quivalence between `C` and `ulift_hom C`. -/
@[simps]
def ulift_hom.up : C ⥤ ulift_hom C :=
{ obj := ulift_hom.obj_up,
  map := λ X Y f, ⟨f⟩ }

/-- One half of the quivalence between `C` and `ulift_hom C`. -/
@[simps]
def ulift_hom.down : ulift_hom C ⥤ C :=
{ obj := ulift_hom.obj_down,
  map := λ X Y f, f.down }

/-- The equivalence between `C` and `ulift_hom C`. -/
def ulift_hom.equiv : C ≌ ulift_hom C :=
{ functor := ulift_hom.up,
  inverse := ulift_hom.down,
  unit_iso := nat_iso.of_components (λ A, eq_to_iso rfl) (by tidy),
  counit_iso := nat_iso.of_components (λ A, eq_to_iso rfl) (by tidy) }

end ulift_hom

/-- `as_small C` is a small category equivalent to `C`.
  More specifically, if `C : Type u` is endowed with `category.{v} C`, then
  `as_small.{w} C : Type (max w v u)` is endowed with an instance of a small category.

  The objects and morphisms of `as_small C` are defined by applying `ulift` to the
  objects and morphisms of `C`.

  Note: We require a category instance for this definition in order to have direct
  access to the universe level `v`.
-/
@[nolint unused_arguments]
def {w v u} as_small (C : Type u) [category.{v} C] := ulift.{max w v} C

instance : small_category (as_small.{w₁} C) :=
{ hom := λ X Y, ulift.{max w₁ u₁} $ X.down ⟶ Y.down,
  id := λ X, ⟨𝟙 _⟩,
  comp := λ X Y Z f g, ⟨f.down ≫ g.down⟩ }

/-- One half of the equivalence between `C` and `as_small C`. -/
@[simps]
def as_small.up : C ⥤ as_small C :=
{ obj := λ X, ⟨X⟩,
  map := λ X Y f, ⟨f⟩ }

/-- One half of the equivalence between `C` and `as_small C`. -/
@[simps]
def as_small.down : as_small C ⥤ C :=
{ obj := λ X, X.down,
  map := λ X Y f, f.down }

/-- The equivalence between `C` and `as_small C`. -/
@[simps]
def as_small.equiv : C ≌ as_small C :=
{ functor := as_small.up,
  inverse := as_small.down,
  unit_iso := nat_iso.of_components (λ X, eq_to_iso rfl) (by tidy),
  counit_iso := nat_iso.of_components (λ X, eq_to_iso $ by { ext, refl }) (by tidy) }

instance [inhabited C] : inhabited (as_small C) := ⟨⟨arbitrary _⟩⟩

/-- The equivalence between `C` and `ulift_hom (ulift C)`. -/
def {v' u' v u} ulift_hom_ulift_category.equiv (C : Type u) [category.{v} C] :
  C ≌ ulift_hom.{v'} (ulift.{u'} C) :=
ulift.equivalence.trans ulift_hom.equiv

end category_theory


/-
Copyright (c) 2022 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/

import analysis.specific_limits.basic
import analysis.special_functions.pow

/-!
# Results on discretized exponentials

We state several auxiliary results pertaining to sequences of the form `⌊c^n⌋₊`.

* `tendsto_div_of_monotone_of_tendsto_div_floor_pow`: If a monotone sequence `u` is such that
  `u ⌊c^n⌋₊ / ⌊c^n⌋₊` converges to a limit `l` for all `c > 1`, then `u n / n` tends to `l`.
* `sum_div_nat_floor_pow_sq_le_div_sq`: The sum of `1/⌊c^i⌋₊^2` above a threshold `j` is comparable
  to `1/j^2`, up to a multiplicative constant.
-/

open filter finset
open_locale topology big_operators

/-- If a monotone sequence `u` is such that `u n / n` tends to a limit `l` along subsequences with
exponential growth rate arbitrarily close to `1`, then `u n / n` tends to `l`. -/
lemma tendsto_div_of_monotone_of_exists_subseq_tendsto_div (u : ℕ → ℝ) (l : ℝ) (hmono : monotone u)
  (hlim : ∀ (a : ℝ), 1 < a → ∃ c : ℕ → ℕ, (∀ᶠ n in at_top, (c (n+1) : ℝ) ≤ a * c n) ∧
    tendsto c at_top at_top ∧ tendsto (λ n, u (c n) / (c n)) at_top (𝓝 l)) :
  tendsto (λ n, u n / n) at_top (𝓝 l) :=
begin
  /- To check the result up to some `ε > 0`, we use a sequence `c` for which the ratio
  `c (N+1) / c N` is bounded by `1 + ε`. Sandwiching a given `n` between two consecutive values of
  `c`, say `c N` and `c (N+1)`, one can then bound `u n / n` from above by `u (c N) / c (N - 1)`
  and from below by `u (c (N - 1)) / c N` (using that `u` is monotone), which are both comparable
  to the limit `l` up to `1 + ε`.
  We give a version of this proof by clearing out denominators first, to avoid discussing the sign
  of different quantities. -/
  have lnonneg : 0 ≤ l,
  { rcases hlim 2 one_lt_two with ⟨c, cgrowth, ctop, clim⟩,
    have : tendsto (λ n, u 0 / (c n)) at_top (𝓝 0) :=
      tendsto_const_nhds.div_at_top (tendsto_coe_nat_at_top_iff.2 ctop),
    apply le_of_tendsto_of_tendsto' this clim (λ n, _),
    simp_rw [div_eq_inv_mul],
    exact mul_le_mul_of_nonneg_left (hmono (zero_le _)) (inv_nonneg.2 (nat.cast_nonneg _)) },
  have A : ∀ (ε : ℝ), 0 < ε → ∀ᶠ n in at_top, u n - n * l ≤ (ε * (1 + ε + l)) * n,
  { assume ε εpos,
    rcases hlim (1 + ε) ((lt_add_iff_pos_right _).2 εpos) with ⟨c, cgrowth, ctop, clim⟩,
    have L : ∀ᶠ n in at_top, u (c n) - c n * l ≤ ε * c n,
    { rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ,
          asymptotics.is_o_iff] at clim,
      filter_upwards [clim εpos, ctop (Ioi_mem_at_top 0)] with n hn cnpos',
      have cnpos : 0 < c n := cnpos',
      calc u (c n) - c n * l
      = (u (c n) / c n - l) * c n:
        by simp only [cnpos.ne', ne.def, nat.cast_eq_zero, not_false_iff] with field_simps
      ... ≤ ε * c n :
        begin
          refine mul_le_mul_of_nonneg_right _ (nat.cast_nonneg _),
          simp only [mul_one, real.norm_eq_abs, abs_one] at hn,
          exact le_trans (le_abs_self _) hn,
        end },
    obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), a ≤ b → (c (b + 1) : ℝ) ≤ (1 + ε) * c b
        ∧ u (c b) - c b * l ≤ ε * c b := eventually_at_top.1 (cgrowth.and L),
    let M := ((finset.range (a+1)).image (λ i, c i)).max' (by simp),
    filter_upwards [Ici_mem_at_top M] with n hn,
    have exN : ∃ N, n < c N,
    { rcases (tendsto_at_top.1 ctop (n+1)).exists with ⟨N, hN⟩,
      exact ⟨N, by linarith only [hN]⟩ },
    let N := nat.find exN,
    have ncN : n < c N := nat.find_spec exN,
    have aN : a + 1 ≤ N,
    { by_contra' h,
      have cNM : c N ≤ M,
      { apply le_max',
        apply mem_image_of_mem,
        exact mem_range.2 h },
      exact lt_irrefl _ ((cNM.trans hn).trans_lt ncN) },
    have Npos : 0 < N := lt_of_lt_of_le (nat.succ_pos') aN,
    have cNn : c (N - 1) ≤ n,
    { have : N - 1 < N := nat.pred_lt Npos.ne',
      simpa only [not_lt] using nat.find_min exN this },
    have IcN : (c N : ℝ) ≤ (1 + ε) * (c (N - 1)),
    { have A : a ≤ N - 1, by linarith only [aN, Npos],
      have B : N - 1 + 1 = N := nat.succ_pred_eq_of_pos Npos,
      have := (ha _ A).1,
      rwa B at this },
    calc u n - n * l ≤ u (c N) - c (N - 1) * l :
      begin
        apply sub_le_sub (hmono ncN.le),
        apply mul_le_mul_of_nonneg_right (nat.cast_le.2 cNn) lnonneg,
      end
    ... = (u (c N) - c N * l) + (c N - c (N - 1)) * l : by ring
    ... ≤ ε * c N + (ε * c (N - 1)) * l :
      begin
        apply add_le_add,
        { apply (ha _ _).2,
          exact le_trans (by simp only [le_add_iff_nonneg_right, zero_le']) aN },
        { apply mul_le_mul_of_nonneg_right _ lnonneg,
          linarith only [IcN] },
      end
    ... ≤ ε * ((1 + ε) * c (N-1)) + (ε * c (N - 1)) * l :
      add_le_add (mul_le_mul_of_nonneg_left IcN εpos.le) le_rfl
    ... = (ε * (1 + ε + l)) * c (N - 1) : by ring
    ... ≤ (ε * (1 + ε + l)) * n :
      begin
        refine mul_le_mul_of_nonneg_left (nat.cast_le.2 cNn) _,
        apply mul_nonneg εpos.le,
        linarith only [εpos, lnonneg]
      end },
  have B : ∀ (ε : ℝ), 0 < ε → ∀ᶠ (n : ℕ) in at_top, (n : ℝ) * l - u n ≤ (ε * (1 + l)) * n,
  { assume ε εpos,
    rcases hlim (1 + ε) ((lt_add_iff_pos_right _).2 εpos) with ⟨c, cgrowth, ctop, clim⟩,
    have L : ∀ᶠ (n : ℕ) in at_top, (c n : ℝ) * l - u (c n) ≤ ε * c n,
    { rw [← tendsto_sub_nhds_zero_iff, ← asymptotics.is_o_one_iff ℝ,
          asymptotics.is_o_iff] at clim,
      filter_upwards [clim εpos, ctop (Ioi_mem_at_top 0)] with n hn cnpos',
      have cnpos : 0 < c n := cnpos',
      calc (c n : ℝ) * l - u (c n)
      = -(u (c n) / c n - l) * c n:
        by simp only [cnpos.ne', ne.def, nat.cast_eq_zero, not_false_iff, neg_sub] with field_simps
      ... ≤ ε * c n :
        begin
          refine mul_le_mul_of_nonneg_right _ (nat.cast_nonneg _),
          simp only [mul_one, real.norm_eq_abs, abs_one] at hn,
          exact le_trans (neg_le_abs_self _) hn,
        end },
    obtain ⟨a, ha⟩ : ∃ (a : ℕ), ∀ (b : ℕ), a ≤ b → (c (b + 1) : ℝ) ≤ (1 + ε) * c b
        ∧ (c b : ℝ) * l - u (c b) ≤ ε * c b := eventually_at_top.1 (cgrowth.and L),
    let M := ((finset.range (a+1)).image (λ i, c i)).max' (by simp),
    filter_upwards [Ici_mem_at_top M] with n hn,
    have exN : ∃ N, n < c N,
    { rcases (tendsto_at_top.1 ctop (n+1)).exists with ⟨N, hN⟩,
      exact ⟨N, by linarith only [hN]⟩ },
    let N := nat.find exN,
    have ncN : n < c N := nat.find_spec exN,
    have aN : a + 1 ≤ N,
    { by_contra' h,
      have cNM : c N ≤ M,
      { apply le_max',
        apply mem_image_of_mem,
        exact mem_range.2 h },
      exact lt_irrefl _ ((cNM.trans hn).trans_lt ncN) },
    have Npos : 0 < N := lt_of_lt_of_le (nat.succ_pos') aN,
    have aN' : a ≤ N - 1 := by linarith only [aN, Npos],
    have cNn : c (N - 1) ≤ n,
    { have : N - 1 < N := nat.pred_lt Npos.ne',
      simpa only [not_lt] using nat.find_min exN this },
    calc (n : ℝ) * l - u n ≤ c N * l - u (c (N - 1)) :
      begin
        refine add_le_add (mul_le_mul_of_nonneg_right (nat.cast_le.2 ncN.le) lnonneg) _,
        exact neg_le_neg (hmono cNn),
      end
    ... ≤ ((1 + ε) * c (N - 1)) * l - u (c (N - 1)) :
      begin
        refine add_le_add (mul_le_mul_of_nonneg_right _ lnonneg) le_rfl,
        have B : N - 1 + 1 = N := nat.succ_pred_eq_of_pos Npos,
        have := (ha _ aN').1,
        rwa B at this,
      end
    ... = (c (N - 1) * l - u (c (N - 1))) + ε * c (N - 1) * l : by ring
    ... ≤ ε * c (N - 1) + ε * c (N - 1) * l :
      add_le_add (ha _ aN').2 le_rfl
    ... = (ε * (1 + l)) * c (N - 1) : by ring
    ... ≤ (ε * (1 + l)) * n :
      begin
        refine mul_le_mul_of_nonneg_left (nat.cast_le.2 cNn) _,
        exact mul_nonneg (εpos.le) (add_nonneg zero_le_one lnonneg),
      end },
  refine tendsto_order.2 ⟨λ d hd, _, λ d hd, _⟩,
  { obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ), d + ε * (1 + l) < l ∧ 0 < ε,
    { have L : tendsto (λ ε, d + (ε * (1 + l))) (𝓝[>] 0) (𝓝 (d + 0 * (1 + l))),
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        exact tendsto_const_nhds.add (tendsto_id.mul tendsto_const_nhds) },
      simp only [zero_mul, add_zero] at L,
      exact (((tendsto_order.1 L).2 l hd).and (self_mem_nhds_within)).exists },
    filter_upwards [B ε εpos, Ioi_mem_at_top 0] with n hn npos,
    simp_rw [div_eq_inv_mul],
    calc d < (n⁻¹ * n) * (l - ε * (1 + l)) :
      begin
        rw [inv_mul_cancel, one_mul],
        { linarith only [hε] },
        { exact nat.cast_ne_zero.2 (ne_of_gt npos) }
      end
    ... = n⁻¹ * (n * l - ε * (1 + l) * n) : by ring
    ... ≤ n⁻¹ * u n :
      begin
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (nat.cast_nonneg _)),
        linarith only [hn],
      end },
  { obtain ⟨ε, hε, εpos⟩ : ∃ (ε : ℝ), l + ε * (1 + ε + l) < d ∧ 0 < ε,
    { have L : tendsto (λ ε, l + (ε * (1 + ε + l))) (𝓝[>] 0) (𝓝 (l + 0 * (1 + 0 + l))),
      { apply tendsto.mono_left _ nhds_within_le_nhds,
        exact tendsto_const_nhds.add
          (tendsto_id.mul ((tendsto_const_nhds.add tendsto_id).add tendsto_const_nhds)) },
      simp only [zero_mul, add_zero] at L,
      exact (((tendsto_order.1 L).2 d hd).and (self_mem_nhds_within)).exists },
    filter_upwards [A ε εpos, Ioi_mem_at_top 0] with n hn npos,
    simp_rw [div_eq_inv_mul],
    calc (n : ℝ)⁻¹ * u n ≤ (n : ℝ)⁻¹ * (n * l + ε * (1 + ε + l) * n) :
      begin
        refine mul_le_mul_of_nonneg_left _ (inv_nonneg.2 (nat.cast_nonneg _)),
        linarith only [hn],
      end
    ... = ((n : ℝ) ⁻¹ * n) * (l + ε * (1 + ε + l)) : by ring
    ... < d :
      begin
        rwa [inv_mul_cancel, one_mul],
        exact nat.cast_ne_zero.2 (ne_of_gt npos),
      end }
end

/-- If a monotone sequence `u` is such that `u ⌊c^n⌋₊ / ⌊c^n⌋₊` converges to a limit `l` for all
`c > 1`, then `u n / n` tends to `l`. It is even enough to have the assumption for a sequence of
`c`s converging to `1`. -/
lemma tendsto_div_of_monotone_of_tendsto_div_floor_pow
  (u : ℕ → ℝ) (l : ℝ) (hmono : monotone u)
  (c : ℕ → ℝ) (cone : ∀ k, 1 < c k) (clim : tendsto c at_top (𝓝 1))
  (hc : ∀ k, tendsto (λ (n : ℕ), u (⌊(c k) ^ n⌋₊) / ⌊(c k)^n⌋₊) at_top (𝓝 l)) :
  tendsto (λ n, u n / n) at_top (𝓝 l) :=
begin
  apply tendsto_div_of_monotone_of_exists_subseq_tendsto_div u l hmono,
  assume a ha,
  obtain ⟨k, hk⟩ : ∃ k, c k < a := ((tendsto_order.1 clim).2 a ha).exists,
  refine ⟨λ n, ⌊(c k)^n⌋₊, _,
    tendsto_nat_floor_at_top.comp (tendsto_pow_at_top_at_top_of_one_lt (cone k)), hc k⟩,
  have H : ∀ (n : ℕ), (0 : ℝ) < ⌊c k ^ n⌋₊,
  { assume n,
    refine zero_lt_one.trans_le _,
    simp only [nat.one_le_cast, nat.one_le_floor_iff, one_le_pow_of_one_le (cone k).le n] },
  have A : tendsto (λ (n : ℕ), ((⌊c k ^ (n+1)⌋₊ : ℝ) / c k ^ (n+1)) * c k /
    (⌊c k ^ n⌋₊ / c k ^ n)) at_top (𝓝 (1 * c k / 1)),
  { refine tendsto.div (tendsto.mul _ tendsto_const_nhds) _ one_ne_zero,
    { refine tendsto_nat_floor_div_at_top.comp _,
      exact (tendsto_pow_at_top_at_top_of_one_lt (cone k)).comp (tendsto_add_at_top_nat 1) },
    { refine tendsto_nat_floor_div_at_top.comp _,
      exact tendsto_pow_at_top_at_top_of_one_lt (cone k) } },
  have B : tendsto (λ (n : ℕ), (⌊c k ^ (n+1)⌋₊ : ℝ) / ⌊c k ^ n⌋₊) at_top (𝓝 (c k)),
  { simp only [one_mul, div_one] at A,
    convert A,
    ext1 n,
    simp only [(zero_lt_one.trans (cone k)).ne', ne.def, not_false_iff, (H n).ne']
      with field_simps {discharger := tactic.field_simp.ne_zero},
    ring_exp },
  filter_upwards [(tendsto_order.1 B).2 a hk] with n hn,
  exact (div_le_iff (H n)).1 hn.le
end

/-- The sum of `1/(c^i)^2` above a threshold `j` is comparable to `1/j^2`, up to a multiplicative
constant. -/
lemma sum_div_pow_sq_le_div_sq (N : ℕ) {j : ℝ} (hj : 0 < j) {c : ℝ} (hc : 1 < c) :
  ∑ i in (range N).filter (λ i, j < c ^ i), 1 / (c ^ i) ^ 2 ≤ (c^3 * (c - 1) ⁻¹) / j ^ 2 :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  have A : 0 < (c⁻¹) ^ 2 := sq_pos_of_pos (inv_pos.2 cpos),
  have B : c^2 * (1 - c⁻¹ ^ 2) ⁻¹ ≤ c^3 * (c - 1) ⁻¹,
  { rw [← div_eq_mul_inv, ← div_eq_mul_inv, div_le_div_iff _ (sub_pos.2 hc)], swap,
    { exact sub_pos.2 (pow_lt_one (inv_nonneg.2 cpos.le) (inv_lt_one hc) two_ne_zero) },
    have : c ^ 3 = c^2 * c, by ring_exp,
    simp only [mul_sub, this, mul_one, inv_pow, sub_le_sub_iff_left],
    rw [mul_assoc, mul_comm c, ← mul_assoc, mul_inv_cancel (sq_pos_of_pos cpos).ne', one_mul],
    simpa using pow_le_pow hc.le one_le_two },
  calc
  ∑ i in (range N).filter (λ i, j < c ^ i), 1/ (c ^ i) ^ 2
    ≤ ∑ i in Ico (⌊real.log j / real.log c⌋₊) N, 1 / (c ^ i) ^ 2 :
  begin
    refine sum_le_sum_of_subset_of_nonneg _ (λ i hi hident, div_nonneg zero_le_one (sq_nonneg _)),
    assume i hi,
    simp only [mem_filter, mem_range] at hi,
    simp only [hi.1, mem_Ico, and_true],
    apply nat.floor_le_of_le,
    apply le_of_lt,
    rw [div_lt_iff (real.log_pos hc), ← real.log_pow],
    exact real.log_lt_log hj hi.2
  end
  ... = ∑ i in Ico (⌊real.log j / real.log c⌋₊) N, ((c⁻¹) ^ 2) ^ i :
  begin
    congr' 1 with i,
    simp [← pow_mul, mul_comm],
  end
  ... ≤ ((c⁻¹) ^ 2) ^ (⌊real.log j / real.log c⌋₊) / (1 - (c⁻¹) ^ 2) :
  begin
    apply geom_sum_Ico_le_of_lt_one (sq_nonneg _),
    rw sq_lt_one_iff (inv_nonneg.2 (zero_le_one.trans hc.le)),
    exact inv_lt_one hc
  end
  ... ≤ ((c⁻¹) ^ 2) ^ (real.log j / real.log c - 1) / (1 - (c⁻¹) ^ 2) :
  begin
    apply div_le_div _ _ _ le_rfl,
    { apply real.rpow_nonneg_of_nonneg (sq_nonneg _) },
    { rw ← real.rpow_nat_cast,
      apply real.rpow_le_rpow_of_exponent_ge A,
      { exact pow_le_one _ (inv_nonneg.2 (zero_le_one.trans hc.le)) (inv_le_one hc.le) },
      { exact (nat.sub_one_lt_floor _).le } },
    { simpa only [inv_pow, sub_pos] using inv_lt_one (one_lt_pow hc two_ne_zero) }
  end
  ... = (c^2 * (1 - c⁻¹ ^ 2) ⁻¹) / j ^ 2 :
  begin
    have I : (c ⁻¹ ^ 2) ^ (real.log j / real.log c) = 1 / j ^ 2,
    { apply real.log_inj_on_pos (real.rpow_pos_of_pos A _),
      { rw [one_div], exact inv_pos.2 (sq_pos_of_pos hj) },
      rw real.log_rpow A,
      simp only [one_div, real.log_inv, real.log_pow, nat.cast_bit0, nat.cast_one, mul_neg,
        neg_inj],
      field_simp [(real.log_pos hc).ne'],
      ring },
    rw [real.rpow_sub A, I],
    have : c^2 - 1 ≠ 0 := (sub_pos.2 (one_lt_pow hc two_ne_zero)).ne',
    field_simp [hj.ne', (zero_lt_one.trans hc).ne'],
    ring,
  end
  ... ≤ (c^3 * (c - 1) ⁻¹) / j ^ 2 :
  begin
    apply div_le_div _ B (sq_pos_of_pos hj) le_rfl,
    exact mul_nonneg (pow_nonneg cpos.le _) (inv_nonneg.2 (sub_pos.2 hc).le),
  end
end

lemma mul_pow_le_nat_floor_pow {c : ℝ} (hc : 1 < c) (i : ℕ) :
  (1 - c⁻¹) * c ^ i ≤ ⌊c ^ i⌋₊ :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  rcases nat.eq_zero_or_pos i with rfl|hi,
  { simp only [pow_zero, nat.floor_one, nat.cast_one, mul_one, sub_le_self_iff, inv_nonneg,
      cpos.le] },
  have hident : 1 ≤ i := hi,
  calc (1 - c⁻¹) * c ^ i
      = c ^ i - c ^ i * c ⁻¹ : by ring
  ... ≤ c ^ i - 1 :
    by simpa only [←div_eq_mul_inv, sub_le_sub_iff_left, one_le_div cpos, pow_one]
      using pow_le_pow hc.le hident
  ... ≤ ⌊c ^ i⌋₊ : (nat.sub_one_lt_floor _).le
end

/-- The sum of `1/⌊c^i⌋₊^2` above a threshold `j` is comparable to `1/j^2`, up to a multiplicative
constant. -/
lemma sum_div_nat_floor_pow_sq_le_div_sq (N : ℕ) {j : ℝ} (hj : 0 < j) {c : ℝ} (hc : 1 < c) :
  ∑ i in (range N).filter (λ i, j < ⌊c ^ i⌋₊), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2
    ≤ (c ^ 5 * (c - 1) ⁻¹ ^ 3) / j ^ 2 :=
begin
  have cpos : 0 < c := zero_lt_one.trans hc,
  have A : 0 < 1 - c⁻¹ := sub_pos.2 (inv_lt_one hc),
  calc
  ∑ i in (range N).filter (λ i, j < ⌊c ^ i⌋₊), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2
      ≤ ∑ i in (range N).filter (λ i, j < c ^ i), (1 : ℝ) / ⌊c ^ i⌋₊ ^ 2 :
  begin
    apply sum_le_sum_of_subset_of_nonneg,
    { assume i hi,
      simp only [mem_filter, mem_range] at hi,
      simpa only [hi.1, mem_filter, mem_range, true_and]
        using hi.2.trans_le (nat.floor_le (pow_nonneg cpos.le _)) },
    { assume i hi hident,
      exact div_nonneg zero_le_one (sq_nonneg _), }
  end
  ... ≤ ∑ i in (range N).filter (λ i, j < c ^ i), ((1 - c⁻¹) ⁻¹) ^ 2 * (1 / (c ^ i) ^ 2) :
  begin
    apply sum_le_sum (λ i hi, _),
    rw [mul_div_assoc', mul_one, div_le_div_iff], rotate,
    { apply sq_pos_of_pos,
      refine zero_lt_one.trans_le _,
      simp only [nat.le_floor, one_le_pow_of_one_le, hc.le, nat.one_le_cast, nat.cast_one] },
    { exact sq_pos_of_pos (pow_pos cpos _) },
    rw [one_mul, ← mul_pow],
    apply pow_le_pow_of_le_left (pow_nonneg cpos.le _),
    rw [← div_eq_inv_mul, le_div_iff A, mul_comm],
    exact mul_pow_le_nat_floor_pow hc i,
  end
  ... ≤ ((1 - c⁻¹) ⁻¹) ^ 2 * (c^3 * (c - 1) ⁻¹) / j ^ 2 :
  begin
    rw [← mul_sum, ← mul_div_assoc'],
    refine mul_le_mul_of_nonneg_left _ (sq_nonneg _),
    exact sum_div_pow_sq_le_div_sq N hj hc,
  end
  ... = (c ^ 5 * (c - 1) ⁻¹ ^ 3) / j ^ 2 :
  begin
    congr' 1,
    field_simp [cpos.ne', (sub_pos.2 hc).ne'],
    ring,
  end
end