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

namespace set

variables {α : Type*} {s t : set α}

lemma disjoint_iff_subset_compl_right :
  disjoint s t ↔ s ⊆ tᶜ :=
disjoint_left

lemma disjoint_iff_subset_compl_left :
  disjoint s t ↔ t ⊆ sᶜ :=
disjoint_right

lemma subset_singleton_iff' (s : set α) (a : α) : s ⊆ {a} ↔ s = ∅ ∨ s = {a} :=
begin
  obtain (rfl | hs) := s.eq_empty_or_nonempty,
  { simp only [forall_false_left, mem_empty_eq, subset_singleton_iff, implies_true_iff, true_or, eq_self_iff_true]},
  { simp [eq_singleton_iff_nonempty_unique_mem, hs, ne_empty_iff_nonempty.2 hs] }
end

lemma ssubset_singleton_iff_eq_empty (x : α) (X : set α) : X ⊂ {x} ↔ X = ∅ :=
begin
  rw [ssubset_iff_subset_ne, subset_singleton_iff', or_and_distrib_right],
  simp only [or_false, and_iff_left_iff_imp, and_not_self],
  rintro rfl,
  rw [ne_comm, ne_empty_iff_nonempty],
  apply singleton_nonempty,
end

theorem sdiff_union_of_subset {s₁ s₂ : set α} (h : s₁ ⊆ s₂) :
  (s₂ \ s₁) ∪ s₁ = s₂ :=
set.ext $ λ x, by simpa [em, or_comm, or_and_distrib_left] using or_iff_right_of_imp (@h x)

end set


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Aaron Anderson, Yakov Pechersky
-/
import data.finset.card
import data.fintype.basic
import group_theory.perm.basic

/-!
# Support of a permutation

## Main definitions

In the following, `f g : equiv.perm α`.

* `equiv.perm.disjoint`: two permutations `f` and `g` are `disjoint` if every element is fixed
  either by `f`, or by `g`.
  Equivalently, `f` and `g` are `disjoint` iff their `support` are disjoint.
* `equiv.perm.is_swap`: `f = swap x y` for `x ≠ y`.
* `equiv.perm.support`: the elements `x : α` that are not fixed by `f`.

-/

open equiv finset

namespace equiv.perm

variables {α : Type*}
section disjoint

/-- Two permutations `f` and `g` are `disjoint` if their supports are disjoint, i.e.,
every element is fixed either by `f`, or by `g`. -/
def disjoint (f g : perm α) := ∀ x, f x = x ∨ g x = x

variables {f g h : perm α}

@[symm] lemma disjoint.symm : disjoint f g → disjoint g f :=
by simp only [disjoint, or.comm, imp_self]

lemma disjoint.symmetric : symmetric (@disjoint α) :=
λ _ _, disjoint.symm

lemma disjoint_comm : disjoint f g ↔ disjoint g f :=
⟨disjoint.symm, disjoint.symm⟩

lemma disjoint.commute (h : disjoint f g) : commute f g :=
equiv.ext $ λ x, (h x).elim
  (λ hf, (h (g x)).elim (λ hg, by simp [mul_apply, hf, hg])
    (λ hg, by simp [mul_apply, hf, g.injective hg]))
  (λ hg, (h (f x)).elim (λ hf, by simp [mul_apply, f.injective hf, hg])
    (λ hf, by simp [mul_apply, hf, hg]))

@[simp] lemma disjoint_one_left (f : perm α) : disjoint 1 f := λ _, or.inl rfl

@[simp] lemma disjoint_one_right (f : perm α) : disjoint f 1 := λ _, or.inr rfl

lemma disjoint_iff_eq_or_eq : disjoint f g ↔ ∀ (x : α), f x = x ∨ g x = x := iff.rfl

@[simp] lemma disjoint_refl_iff : disjoint f f ↔ f = 1 :=
begin
  refine ⟨λ h, _, λ h, h.symm ▸ disjoint_one_left 1⟩,
  ext x,
  cases h x with hx hx;
  simp [hx]
end

lemma disjoint.inv_left (h : disjoint f g) : disjoint f⁻¹ g :=
begin
  intro x,
  rw [inv_eq_iff_eq, eq_comm],
  exact h x
end

lemma disjoint.inv_right (h : disjoint f g) : disjoint f g⁻¹ :=
h.symm.inv_left.symm

@[simp] lemma disjoint_inv_left_iff : disjoint f⁻¹ g ↔  disjoint f g :=
begin
  refine ⟨λ h, _, disjoint.inv_left⟩,
  convert h.inv_left,
  exact (inv_inv _).symm
end

@[simp] lemma disjoint_inv_right_iff : disjoint f g⁻¹ ↔ disjoint f g :=
by rw [disjoint_comm, disjoint_inv_left_iff, disjoint_comm]

lemma disjoint.mul_left (H1 : disjoint f h) (H2 : disjoint g h) :
  disjoint (f * g) h :=
λ x, by cases H1 x; cases H2 x; simp *

lemma disjoint.mul_right (H1 : disjoint f g) (H2 : disjoint f h) :
  disjoint f (g * h) :=
by { rw disjoint_comm, exact H1.symm.mul_left H2.symm }

lemma disjoint_prod_right (l : list (perm α))
  (h : ∀ g ∈ l, disjoint f g) : disjoint f l.prod :=
begin
  induction l with g l ih,
  { exact disjoint_one_right _ },
  { rw list.prod_cons,
    exact (h _ (list.mem_cons_self _ _)).mul_right (ih (λ g hg, h g (list.mem_cons_of_mem _ hg))) }
end

lemma disjoint_prod_perm {l₁ l₂ : list (perm α)} (hl : l₁.pairwise disjoint)
  (hp : l₁ ~ l₂) : l₁.prod = l₂.prod :=
hp.prod_eq' $ hl.imp $ λ f g, disjoint.commute

lemma pow_apply_eq_self_of_apply_eq_self {x : α} (hfx : f x = x) :
  ∀ n : ℕ, (f ^ n) x = x
| 0     := rfl
| (n+1) := by rw [pow_succ', mul_apply, hfx, pow_apply_eq_self_of_apply_eq_self]

lemma zpow_apply_eq_self_of_apply_eq_self {x : α} (hfx : f x = x) :
  ∀ n : ℤ, (f ^ n) x = x
| (n : ℕ) := pow_apply_eq_self_of_apply_eq_self hfx n
| -[1+ n] := by rw [zpow_neg_succ_of_nat, inv_eq_iff_eq, pow_apply_eq_self_of_apply_eq_self hfx]

lemma pow_apply_eq_of_apply_apply_eq_self {x : α} (hffx : f (f x) = x) :
  ∀ n : ℕ, (f ^ n) x = x ∨ (f ^ n) x = f x
| 0     := or.inl rfl
| (n+1) := (pow_apply_eq_of_apply_apply_eq_self n).elim
  (λ h, or.inr (by rw [pow_succ, mul_apply, h]))
  (λ h, or.inl (by rw [pow_succ, mul_apply, h, hffx]))

lemma zpow_apply_eq_of_apply_apply_eq_self {x : α} (hffx : f (f x) = x) :
  ∀ i : ℤ, (f ^ i) x = x ∨ (f ^ i) x = f x
| (n : ℕ) := pow_apply_eq_of_apply_apply_eq_self hffx n
| -[1+ n] := by { rw [zpow_neg_succ_of_nat, inv_eq_iff_eq, ← f.injective.eq_iff, ← mul_apply,
    ← pow_succ, eq_comm, inv_eq_iff_eq, ← mul_apply, ← pow_succ', @eq_comm _ x, or.comm],
  exact pow_apply_eq_of_apply_apply_eq_self hffx _ }

lemma disjoint.mul_apply_eq_iff {σ τ : perm α} (hστ : disjoint σ τ) {a : α} :
  (σ * τ) a = a ↔ σ a = a ∧ τ a = a :=
begin
  refine ⟨λ h, _, λ h, by rw [mul_apply, h.2, h.1]⟩,
  cases hστ a with hσ hτ,
  { exact ⟨hσ, σ.injective (h.trans hσ.symm)⟩ },
  { exact ⟨(congr_arg σ hτ).symm.trans h, hτ⟩ },
end

lemma disjoint.mul_eq_one_iff {σ τ : perm α} (hστ : disjoint σ τ) :
  σ * τ = 1 ↔ σ = 1 ∧ τ = 1 :=
by simp_rw [ext_iff, one_apply, hστ.mul_apply_eq_iff, forall_and_distrib]

lemma disjoint.zpow_disjoint_zpow {σ τ : perm α} (hστ : disjoint σ τ) (m n : ℤ) :
  disjoint (σ ^ m) (τ ^ n) :=
λ x, or.imp (λ h, zpow_apply_eq_self_of_apply_eq_self h m)
  (λ h, zpow_apply_eq_self_of_apply_eq_self h n) (hστ x)

lemma disjoint.pow_disjoint_pow {σ τ : perm α} (hστ : disjoint σ τ) (m n : ℕ) :
  disjoint (σ ^ m) (τ ^ n) :=
hστ.zpow_disjoint_zpow m n

end disjoint

section is_swap

variable [decidable_eq α]

/-- `f.is_swap` indicates that the permutation `f` is a transposition of two elements. -/
def is_swap (f : perm α) : Prop := ∃ x y, x ≠ y ∧ f = swap x y

lemma is_swap.of_subtype_is_swap {p : α → Prop} [decidable_pred p]
  {f : perm (subtype p)} (h : f.is_swap) : (of_subtype f).is_swap :=
let ⟨⟨x, hx⟩, ⟨y, hy⟩, hxy⟩ := h in
⟨x, y, by { simp only [ne.def] at hxy, exact hxy.1 },
  equiv.ext $ λ z, begin
    rw [hxy.2, of_subtype],
    simp only [swap_apply_def, coe_fn_mk, swap_inv, subtype.mk_eq_mk, monoid_hom.coe_mk],
    split_ifs;
    rw subtype.coe_mk <|> cc,
  end⟩

lemma ne_and_ne_of_swap_mul_apply_ne_self {f : perm α} {x y : α}
  (hy : (swap x (f x) * f) y ≠ y) : f y ≠ y ∧ y ≠ x :=
begin
  simp only [swap_apply_def, mul_apply, f.injective.eq_iff] at *,
  by_cases h : f y = x,
  { split; intro; simp only [*, if_true, eq_self_iff_true, not_true, ne.def] at * },
  { split_ifs at hy; cc }
end

end is_swap

section support

section set

variables (p q : perm α)

lemma set_support_inv_eq :
  {x | p⁻¹ x ≠ x} = {x | p x ≠ x} :=
begin
  ext x,
  simp only [set.mem_set_of_eq, ne.def],
  rw [inv_def, symm_apply_eq, eq_comm]
end

lemma set_support_apply_mem {p : perm α} {a : α} :
  p a ∈ {x | p x ≠ x} ↔ a ∈ {x | p x ≠ x} :=
by simp

lemma set_support_zpow_subset (n : ℤ) :
  {x | (p ^ n) x ≠ x} ⊆ {x | p x ≠ x} :=
begin
  intros x,
  simp only [set.mem_set_of_eq, ne.def],
  intros hx H,
  simpa [zpow_apply_eq_self_of_apply_eq_self H] using hx
end

lemma set_support_mul_subset :
  {x | (p * q) x ≠ x} ⊆ {x | p x ≠ x} ∪ {x | q x ≠ x} :=
begin
  intro x,
  simp only [perm.coe_mul, function.comp_app, ne.def, set.mem_union_eq, set.mem_set_of_eq],
  by_cases hq : q x = x;
  simp [hq]
end

end set

variables [decidable_eq α] [fintype α] {f g : perm α}

/-- The `finset` of nonfixed points of a permutation. -/
def support (f : perm α) : finset α := univ.filter (λ x, f x ≠ x)

@[simp] lemma mem_support {x : α} : x ∈ f.support ↔ f x ≠ x :=
by rw [support, mem_filter, and_iff_right (mem_univ x)]

lemma not_mem_support {x : α} : x ∉ f.support ↔ f x = x := by simp

lemma coe_support_eq_set_support (f : perm α) :
  (f.support : set α) = {x | f x ≠ x} :=
by { ext, simp }

@[simp] lemma support_eq_empty_iff {σ : perm α} : σ.support = ∅ ↔ σ = 1 :=
by simp_rw [finset.ext_iff, mem_support, finset.not_mem_empty, iff_false, not_not,
  equiv.perm.ext_iff, one_apply]

@[simp] lemma support_one : (1 : perm α).support = ∅ :=
by rw support_eq_empty_iff

@[simp] lemma support_refl : support (equiv.refl α) = ∅ := support_one

lemma support_congr (h : f.support ⊆ g.support)
  (h' : ∀ x ∈ g.support, f x = g x) : f = g :=
begin
  ext x,
  by_cases hx : x ∈ g.support,
  { exact h' x hx },
  { rw [not_mem_support.mp hx, ←not_mem_support],
    exact λ H, hx (h H) }
end

lemma support_mul_le (f g : perm α) :
  (f * g).support ≤ f.support ⊔ g.support :=
λ x, begin
  rw [sup_eq_union, mem_union, mem_support, mem_support,
    mem_support, mul_apply, ←not_and_distrib, not_imp_not],
  rintro ⟨hf, hg⟩,
  rw [hg, hf]
end

lemma exists_mem_support_of_mem_support_prod {l : list (perm α)} {x : α}
  (hx : x ∈ l.prod.support) :
  ∃ f : perm α, f ∈ l ∧ x ∈ f.support :=
begin
  contrapose! hx,
  simp_rw [mem_support, not_not] at hx ⊢,
  induction l with f l ih generalizing hx,
  { refl },
  { rw [list.prod_cons, mul_apply, ih (λ g hg, hx g (or.inr hg)), hx f (or.inl rfl)] },
end

lemma support_pow_le (σ : perm α) (n : ℕ) :
  (σ ^ n).support ≤ σ.support :=
λ x h1, mem_support.mpr (λ h2, mem_support.mp h1 (pow_apply_eq_self_of_apply_eq_self h2 n))

@[simp] lemma support_inv (σ : perm α) : support (σ⁻¹) = σ.support :=
by simp_rw [finset.ext_iff, mem_support, not_iff_not,
  (inv_eq_iff_eq).trans eq_comm, iff_self, imp_true_iff]

@[simp]
lemma apply_mem_support {x : α} :
  f x ∈ f.support ↔ x ∈ f.support :=
by rw [mem_support, mem_support, ne.def, ne.def, not_iff_not, apply_eq_iff_eq]

@[simp]
lemma pow_apply_mem_support {n : ℕ} {x : α} :
  (f ^ n) x ∈ f.support ↔ x ∈ f.support :=
begin
  induction n with n ih,
  { refl },
  rw [pow_succ, perm.mul_apply, apply_mem_support, ih]
end

@[simp]
lemma zpow_apply_mem_support {n : ℤ} {x : α} :
  (f ^ n) x ∈ f.support ↔ x ∈ f.support :=
begin
  cases n,
  { rw [int.of_nat_eq_coe, zpow_coe_nat, pow_apply_mem_support] },
  { rw [zpow_neg_succ_of_nat, ← support_inv, ← inv_pow, pow_apply_mem_support] }
end

lemma pow_eq_on_of_mem_support (h : ∀ (x ∈ f.support ∩ g.support), f x = g x)
  (k : ℕ) : ∀ (x ∈ f.support ∩ g.support), (f ^ k) x = (g ^ k) x :=
begin
  induction k with k hk,
  { simp },
  { intros x hx,
    rw [pow_succ', mul_apply, pow_succ', mul_apply, h _ hx, hk],
    rwa [mem_inter, apply_mem_support, ←h _ hx, apply_mem_support, ←mem_inter] }
end

lemma disjoint_iff_disjoint_support :
  disjoint f g ↔ _root_.disjoint f.support g.support :=
by simp [disjoint_iff_eq_or_eq, disjoint_iff, finset.ext_iff, not_and_distrib]

lemma disjoint.disjoint_support (h : disjoint f g) :
  _root_.disjoint f.support g.support :=
disjoint_iff_disjoint_support.1 h

lemma disjoint.support_mul (h : disjoint f g) :
  (f * g).support = f.support ∪ g.support :=
begin
  refine le_antisymm (support_mul_le _ _) (λ a, _),
  rw [mem_union, mem_support, mem_support, mem_support, mul_apply, ←not_and_distrib, not_imp_not],
  exact (h a).elim (λ hf h, ⟨hf, f.apply_eq_iff_eq.mp (h.trans hf.symm)⟩)
    (λ hg h, ⟨(congr_arg f hg).symm.trans h, hg⟩),
end

lemma support_prod_of_pairwise_disjoint (l : list (perm α)) (h : l.pairwise disjoint) :
  l.prod.support = (l.map support).foldr (⊔) ⊥ :=
begin
  induction l with hd tl hl,
  { simp },
  { rw [list.pairwise_cons] at h,
    have : disjoint hd tl.prod := disjoint_prod_right _ h.left,
    simp [this.support_mul, hl h.right] }
end

lemma support_prod_le (l : list (perm α)) :
  l.prod.support ≤ (l.map support).foldr (⊔) ⊥ :=
begin
  induction l with hd tl hl,
  { simp },
  { rw [list.prod_cons, list.map_cons, list.foldr_cons],
    refine (support_mul_le hd tl.prod).trans _,
    exact sup_le_sup le_rfl hl }
end

lemma support_zpow_le (σ : perm α) (n : ℤ) :
  (σ ^ n).support ≤ σ.support :=
λ x h1, mem_support.mpr (λ h2, mem_support.mp h1 (zpow_apply_eq_self_of_apply_eq_self h2 n))

@[simp] lemma support_swap {x y : α} (h : x ≠ y) : support (swap x y) = {x, y} :=
begin
  ext z,
  by_cases hx : z = x,
  any_goals { simpa [hx] using h.symm },
  by_cases hy : z = y;
  { simp [swap_apply_of_ne_of_ne, hx, hy]; cc }
end

lemma support_swap_iff (x y : α) :
  support (swap x y) = {x, y} ↔ x ≠ y :=
begin
  refine ⟨λ h H, _, support_swap⟩,
  subst H,
  simp only [swap_self, support_refl, insert_singleton_self_eq] at h,
  have : x ∈ ∅,
  { rw h,
    exact mem_singleton.mpr rfl },
  simpa
end

lemma support_swap_mul_swap {x y z : α} (h : list.nodup [x, y, z]) :
  support (swap x y * swap y z) = {x, y, z} :=
begin
  simp only [list.not_mem_nil, and_true, list.mem_cons_iff, not_false_iff, list.nodup_cons,
             list.mem_singleton, and_self, list.nodup_nil] at h,
  push_neg at h,
  apply le_antisymm,
  { convert support_mul_le _ _,
    rw [support_swap h.left.left, support_swap h.right],
    ext,
    simp [or.comm, or.left_comm] },
  { intro,
    simp only [mem_insert, mem_singleton],
    rintro (rfl | rfl | rfl | _);
    simp [swap_apply_of_ne_of_ne, h.left.left, h.left.left.symm, h.left.right, h.left.right.symm,
          h.right.symm] }
end

lemma support_swap_mul_ge_support_diff (f : perm α) (x y : α) :
  f.support \ {x, y} ≤ (swap x y * f).support :=
begin
  intro,
  simp only [and_imp, perm.coe_mul, function.comp_app, ne.def, mem_support, mem_insert, mem_sdiff,
             mem_singleton],
  push_neg,
  rintro ha ⟨hx, hy⟩ H,
  rw [swap_apply_eq_iff, swap_apply_of_ne_of_ne hx hy] at H,
  exact ha H
end

lemma support_swap_mul_eq (f : perm α) (x : α) (h : f (f x) ≠ x) :
  (swap x (f x) * f).support = f.support \ {x} :=
begin
  by_cases hx : f x = x,
  { simp [hx, sdiff_singleton_eq_erase, not_mem_support.mpr hx, erase_eq_of_not_mem] },
  ext z,
  by_cases hzx : z = x,
  { simp [hzx] },
  by_cases hzf : z = f x,
  { simp [hzf, hx, h, swap_apply_of_ne_of_ne], },
  by_cases hzfx : f z = x,
  { simp [ne.symm hzx, hzx, ne.symm hzf, hzfx] },
  { simp [ne.symm hzx, hzx, ne.symm hzf, hzfx, f.injective.ne hzx, swap_apply_of_ne_of_ne] }
end

lemma mem_support_swap_mul_imp_mem_support_ne {x y : α}
  (hy : y ∈ support (swap x (f x) * f)) : y ∈ support f ∧ y ≠ x :=
begin
  simp only [mem_support, swap_apply_def, mul_apply, f.injective.eq_iff] at *,
  by_cases h : f y = x,
  { split; intro; simp only [*, if_true, eq_self_iff_true, not_true, ne.def] at * },
  { split_ifs at hy; cc }
end

lemma disjoint.mem_imp (h : disjoint f g) {x : α} (hx : x ∈ f.support) :
  x ∉ g.support :=
λ H, h.disjoint_support (mem_inter_of_mem hx H)

lemma eq_on_support_mem_disjoint {l : list (perm α)} (h : f ∈ l) (hl : l.pairwise disjoint) :
  ∀ (x ∈ f.support), f x = l.prod x :=
begin
  induction l with hd tl IH,
  { simpa using h },
  { intros x hx,
    rw list.pairwise_cons at hl,
    rw list.mem_cons_iff at h,
    rcases h with rfl|h,
    { rw [list.prod_cons, mul_apply, not_mem_support.mp
          ((disjoint_prod_right tl hl.left).mem_imp hx)] },
    { rw [list.prod_cons, mul_apply, ←IH h hl.right _ hx, eq_comm, ←not_mem_support],
      refine (hl.left _ h).symm.mem_imp _,
      simpa using hx } }
end

lemma disjoint.mono {x y : perm α} (h : disjoint f g)
  (hf : x.support ≤ f.support) (hg : y.support ≤ g.support) :
  disjoint x y :=
begin
  rw disjoint_iff_disjoint_support at h ⊢,
  intros a ha,
  exact h (mem_inter_of_mem (hf (mem_of_mem_inter_left ha)) (hg (mem_of_mem_inter_right ha)))
end

lemma support_le_prod_of_mem {l : list (perm α)} (h : f ∈ l) (hl : l.pairwise disjoint) :
  f.support ≤ l.prod.support :=
begin
  intros x hx,
  rwa [mem_support, ←eq_on_support_mem_disjoint h hl _ hx, ←mem_support],
end

section extend_domain
variables {β : Type*} [decidable_eq β] [fintype β] {p : β → Prop} [decidable_pred p]

@[simp]
lemma support_extend_domain (f : α ≃ subtype p) {g : perm α} :
  support (g.extend_domain f) = g.support.map f.as_embedding :=
begin
  ext b,
  simp only [exists_prop, function.embedding.coe_fn_mk, to_embedding_apply, mem_map, ne.def,
    function.embedding.trans_apply, mem_support],
  by_cases pb : p b,
  { rw [extend_domain_apply_subtype _ _ pb],
    split,
    { rintro h,
      refine ⟨f.symm ⟨b, pb⟩, _, by simp⟩,
      contrapose! h,
      simp [h] },
    { rintro ⟨a, ha, hb⟩,
      contrapose! ha,
      obtain rfl : a = f.symm ⟨b, pb⟩,
      { rw eq_symm_apply,
        exact subtype.coe_injective hb },
      rw eq_symm_apply,
      exact subtype.coe_injective ha } },
  { rw [extend_domain_apply_not_subtype _ _ pb],
    simp only [not_exists, false_iff, not_and, eq_self_iff_true, not_true],
    rintros a ha rfl,
    exact pb (subtype.prop _) }
end

lemma card_support_extend_domain (f : α ≃ subtype p) {g : perm α} :
  (g.extend_domain f).support.card = g.support.card :=
by simp

end extend_domain

section card

@[simp]
lemma card_support_eq_zero {f : perm α} :
  f.support.card = 0 ↔ f = 1 :=
by rw [finset.card_eq_zero, support_eq_empty_iff]

lemma one_lt_card_support_of_ne_one {f : perm α} (h : f ≠ 1) :
  1 < f.support.card :=
begin
  simp_rw [one_lt_card_iff, mem_support, ←not_or_distrib],
  contrapose! h,
  ext a,
  specialize h (f a) a,
  rwa [apply_eq_iff_eq, or_self, or_self] at h,
end

lemma card_support_ne_one (f : perm α) : f.support.card ≠ 1 :=
begin
  by_cases h : f = 1,
  { exact ne_of_eq_of_ne (card_support_eq_zero.mpr h) zero_ne_one },
  { exact ne_of_gt (one_lt_card_support_of_ne_one h) },
end

@[simp] lemma card_support_le_one {f : perm α} : f.support.card ≤ 1 ↔ f = 1 :=
by rw [le_iff_lt_or_eq, nat.lt_succ_iff, nat.le_zero_iff, card_support_eq_zero,
  or_iff_not_imp_right, imp_iff_right f.card_support_ne_one]

lemma two_le_card_support_of_ne_one {f : perm α} (h : f ≠ 1) :
  2 ≤ f.support.card :=
one_lt_card_support_of_ne_one h

lemma card_support_swap_mul {f : perm α} {x : α}
  (hx : f x ≠ x) : (swap x (f x) * f).support.card < f.support.card :=
finset.card_lt_card
  ⟨λ z hz, (mem_support_swap_mul_imp_mem_support_ne hz).left,
    λ h, absurd (h (mem_support.2 hx)) (mt mem_support.1 (by simp))⟩

lemma card_support_swap {x y : α} (hxy : x ≠ y) : (swap x y).support.card = 2 :=
show (swap x y).support.card = finset.card ⟨x ::ₘ y ::ₘ 0, by simp [hxy]⟩,
from congr_arg card $ by simp [support_swap hxy, *, finset.ext_iff]

@[simp]
lemma card_support_eq_two {f : perm α} : f.support.card = 2 ↔ is_swap f :=
begin
  split; intro h,
  { obtain ⟨x, t, hmem, hins, ht⟩ := card_eq_succ.1 h,
    obtain ⟨y, rfl⟩ := card_eq_one.1 ht,
    rw mem_singleton at hmem,
    refine ⟨x, y, hmem, _⟩,
    ext a,
    have key : ∀ b, f b ≠ b ↔ _ := λ b, by rw [←mem_support, ←hins, mem_insert, mem_singleton],
    by_cases ha : f a = a,
    { have ha' := not_or_distrib.mp (mt (key a).mpr (not_not.mpr ha)),
      rw [ha, swap_apply_of_ne_of_ne ha'.1 ha'.2] },
    { have ha' := (key (f a)).mp (mt f.apply_eq_iff_eq.mp ha),
      obtain rfl | rfl := ((key a).mp ha),
      { rw [or.resolve_left ha' ha, swap_apply_left] },
      { rw [or.resolve_right ha' ha, swap_apply_right] } } },
  { obtain ⟨x, y, hxy, rfl⟩ := h,
    exact card_support_swap hxy }
end

lemma disjoint.card_support_mul (h : disjoint f g) :
  (f * g).support.card = f.support.card + g.support.card :=
begin
  rw ←finset.card_disjoint_union,
  { congr,
    ext,
    simp [h.support_mul] },
  { simpa using h.disjoint_support }
end

lemma card_support_prod_list_of_pairwise_disjoint {l : list (perm α)}
  (h : l.pairwise disjoint) :
  l.prod.support.card = (l.map (finset.card ∘ support)).sum :=
begin
  induction l with a t ih,
  { exact card_support_eq_zero.mpr rfl, },
  { obtain ⟨ha, ht⟩ := list.pairwise_cons.1 h,
    rw [list.prod_cons, list.map_cons, list.sum_cons, ←ih ht],
    exact (disjoint_prod_right _ ha).card_support_mul }
end

end card

end support

end equiv.perm


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Heather Macbeth
-/
import topology.algebra.order.basic
import topology.algebra.order.left_right

/-!
# Continuity of monotone functions

In this file we prove the following fact: if `f` is a monotone function on a neighborhood of `a`
and the image of this neighborhood is a neighborhood of `f a`, then `f` is continuous at `a`, see
`continuous_at_of_monotone_on_of_image_mem_nhds`, as well as several similar facts.

We also prove that an `order_iso` is continuous.

## Tags

continuous, monotone
-/

open set filter
open_locale topological_space

section linear_order
variables {α β : Type*} [linear_order α] [topological_space α] [order_topology α]
variables [linear_order β] [topological_space β] [order_topology β]

/-- If `f` is a function strictly monotone on a right neighborhood of `a` and the
image of this neighborhood under `f` meets every interval `(f a, b]`, `b > f a`, then `f` is
continuous at `a` from the right.

The assumption `hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b` is required because otherwise the
function `f : ℝ → ℝ` given by `f x = if x ≤ 0 then x else x + 1` would be a counter-example at
`a = 0`. -/
lemma strict_mono_on.continuous_at_right_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b) :
  continuous_within_at f (Ici a) a :=
begin
  have ha : a ∈ Ici a := left_mem_Ici,
  have has : a ∈ s := mem_of_mem_nhds_within ha hs,
  refine tendsto_order.2 ⟨λ b hb, _, λ b hb, _⟩,
  { filter_upwards [hs, self_mem_nhds_within] with _ hxs hxa
      using hb.trans_le ((h_mono.le_iff_le has hxs).2 hxa) },
  { rcases hfs b hb with ⟨c, hcs, hac, hcb⟩,
    rw [h_mono.lt_iff_lt has hcs] at hac,
    filter_upwards [hs, Ico_mem_nhds_within_Ici (left_mem_Ico.2 hac)],
    rintros x hx ⟨hax, hxc⟩,
    exact ((h_mono.lt_iff_lt hx hcs).2 hxc).trans_le hcb }
end

/-- If `f` is a monotone function on a right neighborhood of `a` and the image of this neighborhood
under `f` meets every interval `(f a, b)`, `b > f a`, then `f` is continuous at `a` from the right.

The assumption `hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioo (f a) b` cannot be replaced by the weaker
assumption `hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b` we use for strictly monotone functions
because otherwise the function `ceil : ℝ → ℤ` would be a counter-example at `a = 0`. -/
lemma continuous_at_right_of_monotone_on_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : monotone_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioo (f a) b) :
  continuous_within_at f (Ici a) a :=
begin
  have ha : a ∈ Ici a := left_mem_Ici,
  have has : a ∈ s := mem_of_mem_nhds_within ha hs,
  refine tendsto_order.2 ⟨λ b hb, _, λ b hb, _⟩,
  { filter_upwards [hs, self_mem_nhds_within] with _ hxs hxa
      using hb.trans_le (h_mono has hxs hxa) },
  { rcases hfs b hb with ⟨c, hcs, hac, hcb⟩,
    have : a < c, from not_le.1 (λ h, hac.not_le $ h_mono hcs has h),
    filter_upwards [hs, Ico_mem_nhds_within_Ici (left_mem_Ico.2 this)],
    rintros x hx ⟨hax, hxc⟩,
    exact (h_mono hx hcs hxc.le).trans_lt hcb }
end

/-- If a function `f` with a densely ordered codomain is monotone on a right neighborhood of `a` and
the closure of the image of this neighborhood under `f` is a right neighborhood of `f a`, then `f`
is continuous at `a` from the right. -/
lemma continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : monotone_on f s)
  (hs : s ∈ 𝓝[≥] a) (hfs : closure (f '' s) ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
begin
  refine continuous_at_right_of_monotone_on_of_exists_between h_mono hs (λ b hb, _),
  rcases (mem_nhds_within_Ici_iff_exists_mem_Ioc_Ico_subset hb).1 hfs with ⟨b', ⟨hab', hbb'⟩, hb'⟩,
  rcases exists_between hab' with ⟨c', hc'⟩,
  rcases mem_closure_iff.1 (hb' ⟨hc'.1.le, hc'.2⟩) (Ioo (f a) b') is_open_Ioo hc'
    with ⟨_, hc, ⟨c, hcs, rfl⟩⟩,
  exact ⟨c, hcs, hc.1, hc.2.trans_le hbb'⟩
end

/-- If a function `f` with a densely ordered codomain is monotone on a right neighborhood of `a` and
the image of this neighborhood under `f` is a right neighborhood of `f a`, then `f` is continuous at
`a` from the right. -/
lemma continuous_at_right_of_monotone_on_of_image_mem_nhds_within [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : monotone_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : f '' s ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within h_mono hs $
  mem_of_superset hfs subset_closure

/-- If a function `f` with a densely ordered codomain is strictly monotone on a right neighborhood
of `a` and the closure of the image of this neighborhood under `f` is a right neighborhood of `f a`,
then `f` is continuous at `a` from the right. -/
lemma strict_mono_on.continuous_at_right_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : closure (f '' s) ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within
  (λ x hx y hy, (h_mono.le_iff_le hx hy).2) hs hfs

/-- If a function `f` with a densely ordered codomain is strictly monotone on a right neighborhood
of `a` and the image of this neighborhood under `f` is a right neighborhood of `f a`, then `f` is
continuous at `a` from the right. -/
lemma strict_mono_on.continuous_at_right_of_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a)
  (hfs : f '' s ∈ 𝓝[≥] (f a)) :
  continuous_within_at f (Ici a) a :=
h_mono.continuous_at_right_of_closure_image_mem_nhds_within hs
  (mem_of_superset hfs subset_closure)

/-- If a function `f` is strictly monotone on a right neighborhood of `a` and the image of this
neighborhood under `f` includes `Ioi (f a)`, then `f` is continuous at `a` from the right. -/
lemma strict_mono_on.continuous_at_right_of_surj_on {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≥] a) (hfs : surj_on f s (Ioi (f a))) :
  continuous_within_at f (Ici a) a :=
h_mono.continuous_at_right_of_exists_between hs $ λ b hb, let ⟨c, hcs, hcb⟩ := hfs hb in
⟨c, hcs, hcb.symm ▸ hb, hcb.le⟩

/-- If `f` is a strictly monotone function on a left neighborhood of `a` and the image of this
neighborhood under `f` meets every interval `[b, f a)`, `b < f a`, then `f` is continuous at `a`
from the left.

The assumption `hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)` is required because otherwise the
function `f : ℝ → ℝ` given by `f x = if x < 0 then x else x + 1` would be a counter-example at
`a = 0`. -/
lemma strict_mono_on.continuous_at_left_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_exists_between hs $
  λ b hb, let ⟨c, hcs, hcb, hca⟩ := hfs b hb in ⟨c, hcs, hca, hcb⟩

/-- If `f` is a monotone function on a left neighborhood of `a` and the image of this neighborhood
under `f` meets every interval `(b, f a)`, `b < f a`, then `f` is continuous at `a` from the left.

The assumption `hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ioo b (f a)` cannot be replaced by the weaker
assumption `hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)` we use for strictly monotone functions
because otherwise the function `floor : ℝ → ℤ` would be a counter-example at `a = 0`. -/
lemma continuous_at_left_of_monotone_on_of_exists_between {f : α → β} {s : set α} {a : α}
  (hf : monotone_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : ∀ b < f a, ∃ c ∈ s, f c ∈ Ioo b (f a)) :
  continuous_within_at f (Iic a) a :=
@continuous_at_right_of_monotone_on_of_exists_between (order_dual α) (order_dual β) _ _ _ _ _ _
  f s a hf.dual hs $
  λ b hb, let ⟨c, hcs, hcb, hca⟩ := hfs b hb in ⟨c, hcs, hca, hcb⟩

/-- If a function `f` with a densely ordered codomain is monotone on a left neighborhood of `a` and
the closure of the image of this neighborhood under `f` is a left neighborhood of `f a`, then `f` is
continuous at `a` from the left -/
lemma continuous_at_left_of_monotone_on_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (hf : monotone_on f s)
  (hs : s ∈ 𝓝[≤] a) (hfs : closure (f '' s) ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
@continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within (order_dual α) (order_dual β)
  _ _ _ _ _ _ _ f s a hf.dual hs hfs

/-- If a function `f` with a densely ordered codomain is monotone on a left neighborhood of `a` and
the image of this neighborhood under `f` is a left neighborhood of `f a`, then `f` is continuous at
`a` from the left. -/
lemma continuous_at_left_of_monotone_on_of_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : monotone_on f s)
  (hs : s ∈ 𝓝[≤] a) (hfs : f '' s ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
continuous_at_left_of_monotone_on_of_closure_image_mem_nhds_within h_mono hs
  (mem_of_superset hfs subset_closure)

/-- If a function `f` with a densely ordered codomain is strictly monotone on a left neighborhood of
`a` and the closure of the image of this neighborhood under `f` is a left neighborhood of `f a`,
then `f` is continuous at `a` from the left. -/
lemma strict_mono_on.continuous_at_left_of_closure_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : closure (f '' s) ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_closure_image_mem_nhds_within hs hfs

/-- If a function `f` with a densely ordered codomain is strictly monotone on a left neighborhood of
`a` and the image of this neighborhood under `f` is a left neighborhood of `f a`, then `f` is
continuous at `a` from the left. -/
lemma strict_mono_on.continuous_at_left_of_image_mem_nhds_within [densely_ordered β]
  {f : α → β} {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a)
  (hfs : f '' s ∈ 𝓝[≤] (f a)) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_image_mem_nhds_within hs hfs

/-- If a function `f` is strictly monotone on a left neighborhood of `a` and the image of this
neighborhood under `f` includes `Iio (f a)`, then `f` is continuous at `a` from the left. -/
lemma strict_mono_on.continuous_at_left_of_surj_on {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝[≤] a) (hfs : surj_on f s (Iio (f a))) :
  continuous_within_at f (Iic a) a :=
h_mono.dual.continuous_at_right_of_surj_on hs hfs

/-- If a function `f` is strictly monotone on a neighborhood of `a` and the image of this
neighborhood under `f` meets every interval `[b, f a)`, `b < f a`, and every interval
`(f a, b]`, `b > f a`, then `f` is continuous at `a`. -/
lemma strict_mono_on.continuous_at_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝 a)
  (hfs_l : ∀ b < f a, ∃ c ∈ s, f c ∈ Ico b (f a)) (hfs_r : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioc (f a) b) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨h_mono.continuous_at_left_of_exists_between (mem_nhds_within_of_mem_nhds hs) hfs_l,
   h_mono.continuous_at_right_of_exists_between (mem_nhds_within_of_mem_nhds hs) hfs_r⟩

/-- If a function `f` with a densely ordered codomain is strictly monotone on a neighborhood of `a`
and the closure of the image of this neighborhood under `f` is a neighborhood of `f a`, then `f` is
continuous at `a`. -/
lemma strict_mono_on.continuous_at_of_closure_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝 a)
  (hfs : closure (f '' s) ∈ 𝓝 (f a)) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨h_mono.continuous_at_left_of_closure_image_mem_nhds_within (mem_nhds_within_of_mem_nhds hs)
     (mem_nhds_within_of_mem_nhds hfs),
   h_mono.continuous_at_right_of_closure_image_mem_nhds_within (mem_nhds_within_of_mem_nhds hs)
     (mem_nhds_within_of_mem_nhds hfs)⟩

/-- If a function `f` with a densely ordered codomain is strictly monotone on a neighborhood of `a`
and the image of this set under `f` is a neighborhood of `f a`, then `f` is continuous at `a`. -/
lemma strict_mono_on.continuous_at_of_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : strict_mono_on f s) (hs : s ∈ 𝓝 a) (hfs : f '' s ∈ 𝓝 (f a)) :
  continuous_at f a :=
h_mono.continuous_at_of_closure_image_mem_nhds hs (mem_of_superset hfs subset_closure)

/-- If `f` is a monotone function on a neighborhood of `a` and the image of this neighborhood under
`f` meets every interval `(b, f a)`, `b < f a`, and every interval `(f a, b)`, `b > f a`, then `f`
is continuous at `a`. -/
lemma continuous_at_of_monotone_on_of_exists_between {f : α → β} {s : set α} {a : α}
  (h_mono : monotone_on f s) (hs : s ∈ 𝓝 a)
  (hfs_l : ∀ b < f a, ∃ c ∈ s, f c ∈ Ioo b (f a)) (hfs_r : ∀ b > f a, ∃ c ∈ s, f c ∈ Ioo (f a) b) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨continuous_at_left_of_monotone_on_of_exists_between h_mono
     (mem_nhds_within_of_mem_nhds hs) hfs_l,
   continuous_at_right_of_monotone_on_of_exists_between h_mono
     (mem_nhds_within_of_mem_nhds hs) hfs_r⟩

/-- If a function `f` with a densely ordered codomain is monotone on a neighborhood of `a` and the
closure of the image of this neighborhood under `f` is a neighborhood of `f a`, then `f` is
continuous at `a`. -/
lemma continuous_at_of_monotone_on_of_closure_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : monotone_on f s) (hs : s ∈ 𝓝 a)
  (hfs : closure (f '' s) ∈ 𝓝 (f a)) :
  continuous_at f a :=
continuous_at_iff_continuous_left_right.2
  ⟨continuous_at_left_of_monotone_on_of_closure_image_mem_nhds_within h_mono
     (mem_nhds_within_of_mem_nhds hs) (mem_nhds_within_of_mem_nhds hfs),
   continuous_at_right_of_monotone_on_of_closure_image_mem_nhds_within h_mono
     (mem_nhds_within_of_mem_nhds hs) (mem_nhds_within_of_mem_nhds hfs)⟩

/-- If a function `f` with a densely ordered codomain is monotone on a neighborhood of `a` and the
image of this neighborhood under `f` is a neighborhood of `f a`, then `f` is continuous at `a`. -/
lemma continuous_at_of_monotone_on_of_image_mem_nhds [densely_ordered β] {f : α → β}
  {s : set α} {a : α} (h_mono : monotone_on f s) (hs : s ∈ 𝓝 a)
  (hfs : f '' s ∈ 𝓝 (f a)) :
  continuous_at f a :=
continuous_at_of_monotone_on_of_closure_image_mem_nhds h_mono hs
  (mem_of_superset hfs subset_closure)

/-- A monotone function with densely ordered codomain and a dense range is continuous. -/
lemma monotone.continuous_of_dense_range [densely_ordered β] {f : α → β}
  (h_mono : monotone f) (h_dense : dense_range f) :
  continuous f :=
continuous_iff_continuous_at.mpr $ λ a,
  continuous_at_of_monotone_on_of_closure_image_mem_nhds (λ x hx y hy hxy, h_mono hxy)
    univ_mem $ by simp only [image_univ, h_dense.closure_eq, univ_mem]

/-- A monotone surjective function with a densely ordered codomain is continuous. -/
lemma monotone.continuous_of_surjective [densely_ordered β] {f : α → β} (h_mono : monotone f)
  (h_surj : function.surjective f) :
  continuous f :=
h_mono.continuous_of_dense_range h_surj.dense_range

end linear_order

/-!
### Continuity of order isomorphisms

In this section we prove that an `order_iso` is continuous, hence it is a `homeomorph`. We prove
this for an `order_iso` between to partial orders with order topology.
-/

namespace order_iso

variables {α β : Type*} [partial_order α] [partial_order β] [topological_space α]
  [topological_space β] [order_topology α] [order_topology β]

protected lemma continuous (e : α ≃o β) : continuous e :=
begin
  rw [‹order_topology β›.topology_eq_generate_intervals],
  refine continuous_generated_from (λ s hs, _),
  rcases hs with ⟨a, rfl|rfl⟩,
  { rw e.preimage_Ioi, apply is_open_lt' },
  { rw e.preimage_Iio, apply is_open_gt' }
end

/-- An order isomorphism between two linear order `order_topology` spaces is a homeomorphism. -/
def to_homeomorph (e : α ≃o β) : α ≃ₜ β :=
{ continuous_to_fun := e.continuous,
  continuous_inv_fun := e.symm.continuous,
  .. e }

@[simp] lemma coe_to_homeomorph (e : α ≃o β) : ⇑e.to_homeomorph = e := rfl
@[simp] lemma coe_to_homeomorph_symm (e : α ≃o β) : ⇑e.to_homeomorph.symm = e.symm := rfl

end order_iso


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot
-/
import topology.uniform_space.separation
/-!
# Compact separated uniform spaces

## Main statements

* `compact_space_uniformity`: On a separated compact uniform space, the topology determines the
  uniform structure, entourages are exactly the neighborhoods of the diagonal.
* `uniform_space_of_compact_t2`: every compact T2 topological structure is induced by a uniform
  structure. This uniform structure is described in the previous item.
* Heine-Cantor theorem: continuous functions on compact separated uniform spaces with values in
  uniform spaces are automatically uniformly continuous. There are several variations, the main one
  is `compact_space.uniform_continuous_of_continuous`.

## Implementation notes

The construction `uniform_space_of_compact_t2` is not declared as an instance, as it would badly
loop.

## tags

uniform space, uniform continuity, compact space
-/

open_locale classical uniformity topological_space filter
open filter uniform_space set

variables {α β : Type*} [uniform_space α] [uniform_space β]

/-!
### Uniformity on compact separated spaces
-/

/-- On a separated compact uniform space, the topology determines the uniform structure, entourages
are exactly the neighborhoods of the diagonal. -/
lemma compact_space_uniformity [compact_space α] [separated_space α] : 𝓤 α = ⨆ x : α, 𝓝 (x, x) :=
begin
  symmetry, refine le_antisymm supr_nhds_le_uniformity _,
  by_contra H,
  obtain ⟨V, hV, h⟩ : ∃ V : set (α × α), (∀ x : α, V ∈ 𝓝 (x, x)) ∧ 𝓤 α ⊓ 𝓟 Vᶜ ≠ ⊥,
  { simpa [le_iff_forall_inf_principal_compl] using H },
  let F := 𝓤 α ⊓ 𝓟 Vᶜ,
  haveI : ne_bot F := ⟨h⟩,
  obtain ⟨⟨x, y⟩, hx⟩ : ∃ (p : α × α), cluster_pt p F :=
    cluster_point_of_compact F,
  have : cluster_pt (x, y) (𝓤 α) :=
    hx.of_inf_left,
  have hxy : x = y := eq_of_uniformity_inf_nhds this,
  subst hxy,
  have : cluster_pt (x, x) (𝓟 Vᶜ) :=
   hx.of_inf_right,
  have : (x, x) ∉ interior V,
  { have : (x, x) ∈ closure Vᶜ, by rwa mem_closure_iff_cluster_pt,
    rwa closure_compl at this },
  have : (x, x) ∈ interior V,
  { rw mem_interior_iff_mem_nhds,
    exact hV x },
  contradiction
end

lemma unique_uniformity_of_compact_t2 {α : Type*} [t : topological_space α] [compact_space α]
[t2_space α] {u u' : uniform_space α}
(h : u.to_topological_space = t) (h' : u'.to_topological_space = t) : u = u' :=
begin
  apply uniform_space_eq,
  change uniformity _ = uniformity _,
  haveI : @compact_space α u.to_topological_space := by rw h ; assumption,
  haveI : @compact_space α u'.to_topological_space := by rw h' ; assumption,
  haveI : @separated_space α u := by rwa [separated_iff_t2, h],
  haveI : @separated_space α u' :=  by rwa [separated_iff_t2, h'],
  rw [compact_space_uniformity, compact_space_uniformity, h, h']
end

/-- The unique uniform structure inducing a given compact Hausdorff topological structure. -/
def uniform_space_of_compact_t2 {α : Type*} [topological_space α] [compact_space α] [t2_space α] :
  uniform_space α :=
{ uniformity := ⨆ x, 𝓝 (x, x),
  refl := begin
    simp_rw [filter.principal_le_iff, mem_supr_sets],
    rintros V V_in ⟨x, _⟩ ⟨⟩,
    exact mem_of_nhds (V_in x),
  end,
  symm := begin
    refine le_of_eq _,
    rw map_supr,
    congr' with x : 1,
    erw [nhds_prod_eq, ← prod_comm],
  end,
  comp := begin
    /-
    This is the difficult part of the proof. We need to prove that, for each neighborhood W
    of the diagonal Δ, W ○ W is still a neighborhood of the diagonal.
    -/
    set 𝓝Δ := ⨆ x : α, 𝓝 (x, x), -- The filter of neighborhoods of Δ
    set F := 𝓝Δ.lift' (λ (s : set (α × α)), s ○ s), -- Compositions of neighborhoods of Δ
    -- If this weren't true, then there would be V ∈ 𝓝Δ such that F ⊓ 𝓟 Vᶜ ≠ ⊥
    rw le_iff_forall_inf_principal_compl,
    intros V V_in,
    by_contra H,
    haveI : ne_bot (F ⊓ 𝓟 Vᶜ) := ⟨H⟩,
    -- Hence compactness would give us a cluster point (x, y) for F ⊓ 𝓟 Vᶜ
    obtain ⟨⟨x, y⟩, hxy⟩ : ∃ (p : α × α), cluster_pt p (F ⊓ 𝓟 Vᶜ) := cluster_point_of_compact _,
    -- In particular (x, y) is a cluster point of 𝓟 Vᶜ, hence is not in the interior of V,
    -- and a fortiori not in Δ, so x ≠ y
    have clV : cluster_pt (x, y) (𝓟 $ Vᶜ) := hxy.of_inf_right,
    have : (x, y) ∉ interior V,
    { have : (x, y) ∈ closure (Vᶜ), by rwa mem_closure_iff_cluster_pt,
      rwa closure_compl at this },
    have diag_subset : diagonal α ⊆ interior V,
    { rw subset_interior_iff_nhds,
      rintros ⟨x, x⟩ ⟨⟩,
      exact (mem_supr_sets.mp V_in : _) x },
    have x_ne_y : x ≠ y,
    { intro h,
      apply this,
      apply diag_subset,
      simp [h] },
    -- Since α is compact and Hausdorff, it is normal, hence regular.
    haveI : normal_space α := normal_of_compact_t2,
    -- So there are closed neighboords V₁ and V₂ of x and y contained in disjoint open neighborhoods
    -- U₁ and U₂.
    obtain
      ⟨U₁, V₁, U₁_in, V₁_in, U₂, V₂, U₂_in₂, V₂_in, V₁_cl, V₂_cl, U₁_op, U₂_op, VU₁, VU₂, hU₁₂⟩ :
        ∃ (U₁ V₁ ∈ 𝓝 x) (U₂ V₂ ∈ 𝓝 y),
          is_closed V₁ ∧ is_closed V₂ ∧ is_open U₁ ∧ is_open U₂ ∧ V₁ ⊆ U₁ ∧ V₂ ⊆ U₂ ∧ U₁ ∩ U₂ = ∅ :=
       disjoint_nested_nhds x_ne_y,
    -- We set U₃ := (V₁ ∪ V₂)ᶜ so that W := (U₁.prod U₁) ∪ (U₂.prod U₂) ∪ (U₃.prod U₃) is an open
    -- neighborhood of Δ.
    let U₃ := (V₁ ∪ V₂)ᶜ,
    have U₃_op : is_open U₃ :=
      is_open_compl_iff.mpr (is_closed_union V₁_cl V₂_cl),
    let W := (U₁.prod U₁) ∪ (U₂.prod U₂) ∪ (U₃.prod U₃),
    have W_in : W ∈ 𝓝Δ,
    { rw mem_supr_sets,
      intros x,
      apply mem_nhds_sets (is_open_union (is_open_union _ _) _),
      { by_cases hx : x ∈ V₁ ∪ V₂,
        { left,
          cases hx with hx hx ; [left, right] ; split ; tauto },
        { right,
          rw mem_prod,
          tauto }, },
      all_goals { simp only [is_open.prod, *] } },
    -- So W ○ W ∈ F by definition of F
    have : W ○ W ∈ F, by simpa only using mem_lift' W_in,
    -- And V₁.prod V₂ ∈ 𝓝 (x, y)
    have hV₁₂ : V₁.prod V₂ ∈ 𝓝 (x, y) := prod_mem_nhds_sets V₁_in V₂_in,
    -- But (x, y) is also a cluster point of F so (V₁.prod V₂) ∩ (W ○ W) ≠ ∅
    have clF : cluster_pt (x, y) F := hxy.of_inf_left,
    obtain ⟨p, p_in⟩ : ∃ p, p ∈ (V₁.prod V₂) ∩ (W ○ W) :=
      cluster_pt_iff.mp clF hV₁₂ this,
    -- However the construction of W implies (V₁.prod V₂) ∩ (W ○ W) = ∅.
    -- Indeed assume for contradiction there is some (u, v) in the intersection.
    -- So u ∈ V₁, v ∈ V₂, and there exists some w such that (u, w) ∈ W and (w ,v) ∈ W.
    -- Because u is in V₁ which is disjoint from U₂ and U₃, (u, w) ∈ W forces (u, w) ∈ U₁.prod U₁.
    -- Similarly, because v ∈ V₂, (w ,v) ∈ W forces (w, v) ∈ U₂.prod U₂.
    -- Hence w ∈ U₁ ∩ U₂ which is empty.
    have inter_empty : (V₁.prod V₂) ∩ (W ○ W) = ∅,
    { rw eq_empty_iff_forall_not_mem,
      rintros ⟨u, v⟩ ⟨⟨u_in, v_in⟩, w, huw, hwv⟩,
      have uw_in : (u, w) ∈ U₁.prod U₁ :=
        set.mem_prod.2 ((huw.resolve_right (λ h, (h.1 $ or.inl u_in))).resolve_right
        (λ h, have u ∈ U₁ ∩ U₂, from ⟨VU₁ u_in, h.1⟩, by rwa hU₁₂ at this)),
      have wv_in : (w, v) ∈ U₂.prod U₂ :=
        set.mem_prod.2 ((hwv.resolve_right (λ h, (h.2 $ or.inr v_in))).resolve_left
        (λ h, have v ∈ U₁ ∩ U₂, from ⟨h.2, VU₂ v_in⟩, by rwa hU₁₂ at this)),
      have : w ∈ U₁ ∩ U₂ := ⟨uw_in.2, wv_in.1⟩,
      rwa hU₁₂ at this },
    -- So we have a contradiction
    rwa inter_empty at p_in,
  end,
  is_open_uniformity := begin
    -- Here we need to prove the topology induced by the constructed uniformity is the
    -- topology we started with.
    suffices : ∀ x : α,  comap (prod.mk x) (⨆ y, 𝓝 (y ,y)) = 𝓝 x,
    { intros s,
      change is_open s ↔ _,
      simp_rw [is_open_iff_mem_nhds, nhds_eq_comap_uniformity_aux, this] },
    intros x,
    simp_rw [comap_supr, nhds_prod_eq, comap_prod,
             show prod.fst ∘ prod.mk x = λ y : α, x, by ext ; simp,
             show prod.snd ∘ (prod.mk x) = (id : α → α), by ext ; refl, comap_id],
    rw [supr_split_single _ x, comap_const_of_mem (λ V, mem_of_nhds)],
    suffices : ∀ y ≠ x, comap (λ (y : α), x) (𝓝 y) ⊓ 𝓝 y ≤ 𝓝 x,
      by simpa,
    intros y hxy,
    simp [comap_const_of_not_mem (compl_singleton_mem_nhds hxy) (by simp)],
  end }

/-!
### Heine-Cantor theorem
-/

/-- Heine-Cantor: a continuous function on a compact separated uniform space is uniformly
continuous. -/
lemma compact_space.uniform_continuous_of_continuous [compact_space α] [separated_space α]
  {f : α → β} (h : continuous f) : uniform_continuous f :=
calc
map (prod.map f f) (𝓤 α) = map (prod.map f f) (⨆ x, 𝓝 (x, x))  : by rw compact_space_uniformity
                     ... =  ⨆ x, map (prod.map f f) (𝓝 (x, x)) : by rw map_supr
                     ... ≤ ⨆ x, 𝓝 (f x, f x)     : supr_le_supr (λ x, (h.prod_map h).continuous_at)
                     ... ≤ ⨆ y, 𝓝 (y, y)         : supr_comp_le (λ y, 𝓝 (y, y)) f
                     ... ≤ 𝓤 β                   : supr_nhds_le_uniformity

/-- Heine-Cantor: a continuous function on a compact separated set of a uniform space is
uniformly continuous. -/
lemma is_compact.uniform_continuous_on_of_continuous' {s : set α} {f : α → β}
  (hs : is_compact s) (hs' : is_separated s) (hf : continuous_on f s) : uniform_continuous_on f s :=
begin
  rw uniform_continuous_on_iff_restrict,
  rw is_separated_iff_induced at hs',
  rw compact_iff_compact_space at hs,
  rw continuous_on_iff_continuous_restrict at hf,
  resetI,
  exact compact_space.uniform_continuous_of_continuous hf,
end

/-- Heine-Cantor: a continuous function on a compact set of a separated uniform space
is uniformly continuous. -/
lemma is_compact.uniform_continuous_on_of_continuous [separated_space α] {s : set α} {f : α → β}
  (hs : is_compact s) (hf : continuous_on f s) : uniform_continuous_on f s :=
hs.uniform_continuous_on_of_continuous' (is_separated_of_separated_space s) hf


/-
Copyright (c) 2020 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne
-/
import measure_theory.integral.lebesgue
import analysis.mean_inequalities
import analysis.mean_inequalities_pow
import measure_theory.function.special_functions.basic

/-!
# Mean value inequalities for integrals

In this file we prove several inequalities on integrals, notably the Hölder inequality and
the Minkowski inequality. The versions for finite sums are in `analysis.mean_inequalities`.

## Main results

Hölder's inequality for the Lebesgue integral of `ℝ≥0∞` and `ℝ≥0` functions: we prove
`∫ (f * g) ∂μ ≤ (∫ f^p ∂μ) ^ (1/p) * (∫ g^q ∂μ) ^ (1/q)` for `p`, `q` conjugate real exponents
and `α→(e)nnreal` functions in two cases,
* `ennreal.lintegral_mul_le_Lp_mul_Lq` : ℝ≥0∞ functions,
* `nnreal.lintegral_mul_le_Lp_mul_Lq`  : ℝ≥0 functions.

Minkowski's inequality for the Lebesgue integral of measurable functions with `ℝ≥0∞` values:
we prove `(∫ (f + g)^p ∂μ) ^ (1/p) ≤ (∫ f^p ∂μ) ^ (1/p) + (∫ g^p ∂μ) ^ (1/p)` for `1 ≤ p`.
-/

section lintegral
/-!
### Hölder's inequality for the Lebesgue integral of ℝ≥0∞ and nnreal functions

We prove `∫ (f * g) ∂μ ≤ (∫ f^p ∂μ) ^ (1/p) * (∫ g^q ∂μ) ^ (1/q)` for `p`, `q`
conjugate real exponents and `α→(e)nnreal` functions in several cases, the first two being useful
only to prove the more general results:
* `ennreal.lintegral_mul_le_one_of_lintegral_rpow_eq_one` : ℝ≥0∞ functions for which the
    integrals on the right are equal to 1,
* `ennreal.lintegral_mul_le_Lp_mul_Lq_of_ne_zero_of_ne_top` : ℝ≥0∞ functions for which the
    integrals on the right are neither ⊤ nor 0,
* `ennreal.lintegral_mul_le_Lp_mul_Lq` : ℝ≥0∞ functions,
* `nnreal.lintegral_mul_le_Lp_mul_Lq`  : nnreal functions.
-/

noncomputable theory
open_locale classical big_operators nnreal ennreal
open measure_theory
variables {α : Type*} [measurable_space α] {μ : measure α}

namespace ennreal

lemma lintegral_mul_le_one_of_lintegral_rpow_eq_one {p q : ℝ} (hpq : p.is_conjugate_exponent q)
  {f g : α → ℝ≥0∞} (hf : ae_measurable f μ) (hf_norm : ∫⁻ a, (f a)^p ∂μ = 1)
  (hg_norm : ∫⁻ a, (g a)^q ∂μ = 1) :
  ∫⁻ a, (f * g) a ∂μ ≤ 1 :=
begin
  calc ∫⁻ (a : α), ((f * g) a) ∂μ
      ≤ ∫⁻ (a : α), ((f a)^p / ennreal.of_real p + (g a)^q / ennreal.of_real q) ∂μ :
    lintegral_mono (λ a, young_inequality (f a) (g a) hpq)
  ... = 1 :
  begin
    simp only [div_eq_mul_inv],
    rw lintegral_add_left',
    { rw [lintegral_mul_const'' _ (hf.pow_const p), lintegral_mul_const', hf_norm, hg_norm,
        ← div_eq_mul_inv, ← div_eq_mul_inv, hpq.inv_add_inv_conj_ennreal],
      simp [hpq.symm.pos], },
    { exact (hf.pow_const _).mul_const _, },
  end
end

/-- Function multiplied by the inverse of its p-seminorm `(∫⁻ f^p ∂μ) ^ 1/p`-/
def fun_mul_inv_snorm (f : α → ℝ≥0∞) (p : ℝ) (μ : measure α) : α → ℝ≥0∞ :=
λ a, (f a) * ((∫⁻ c, (f c) ^ p ∂μ) ^ (1 / p))⁻¹

lemma fun_eq_fun_mul_inv_snorm_mul_snorm {p : ℝ} (f : α → ℝ≥0∞)
  (hf_nonzero : ∫⁻ a, (f a) ^ p ∂μ ≠ 0) (hf_top : ∫⁻ a, (f a) ^ p ∂μ ≠ ⊤) {a : α} :
  f a = (fun_mul_inv_snorm f p μ a) * (∫⁻ c, (f c)^p ∂μ)^(1/p) :=
by simp [fun_mul_inv_snorm, mul_assoc, ennreal.inv_mul_cancel, hf_nonzero, hf_top]

lemma fun_mul_inv_snorm_rpow {p : ℝ} (hp0 : 0 < p) {f : α → ℝ≥0∞} {a : α} :
  (fun_mul_inv_snorm f p μ a) ^ p = (f a)^p * (∫⁻ c, (f c) ^ p ∂μ)⁻¹ :=
begin
  rw [fun_mul_inv_snorm, mul_rpow_of_nonneg _ _ (le_of_lt hp0)],
  suffices h_inv_rpow : ((∫⁻ (c : α), f c ^ p ∂μ) ^ (1 / p))⁻¹ ^ p = (∫⁻ (c : α), f c ^ p ∂μ)⁻¹,
    by rw h_inv_rpow,
  rw [inv_rpow, ← rpow_mul, one_div_mul_cancel hp0.ne', rpow_one]
end

lemma lintegral_rpow_fun_mul_inv_snorm_eq_one {p : ℝ} (hp0_lt : 0 < p) {f : α → ℝ≥0∞}
  (hf_nonzero : ∫⁻ a, (f a)^p ∂μ ≠ 0) (hf_top : ∫⁻ a, (f a)^p ∂μ ≠ ⊤) :
  ∫⁻ c, (fun_mul_inv_snorm f p μ c)^p ∂μ = 1 :=
begin
  simp_rw fun_mul_inv_snorm_rpow hp0_lt,
  rw [lintegral_mul_const', ennreal.mul_inv_cancel hf_nonzero hf_top],
  rwa inv_ne_top
end

/-- Hölder's inequality in case of finite non-zero integrals -/
lemma lintegral_mul_le_Lp_mul_Lq_of_ne_zero_of_ne_top {p q : ℝ} (hpq : p.is_conjugate_exponent q)
  {f g : α → ℝ≥0∞} (hf : ae_measurable f μ)
  (hf_nontop : ∫⁻ a, (f a)^p ∂μ ≠ ⊤) (hg_nontop : ∫⁻ a, (g a)^q ∂μ ≠ ⊤)
  (hf_nonzero : ∫⁻ a, (f a)^p ∂μ ≠ 0) (hg_nonzero : ∫⁻ a, (g a)^q ∂μ ≠ 0) :
  ∫⁻ a, (f * g) a ∂μ ≤ (∫⁻ a, (f a)^p ∂μ)^(1/p) * (∫⁻ a, (g a)^q ∂μ)^(1/q) :=
begin
  let npf := (∫⁻ (c : α), (f c) ^ p ∂μ) ^ (1/p),
  let nqg := (∫⁻ (c : α), (g c) ^ q ∂μ) ^ (1/q),
  calc ∫⁻ (a : α), (f * g) a ∂μ
    = ∫⁻ (a : α), ((fun_mul_inv_snorm f p μ * fun_mul_inv_snorm g q μ) a)
      * (npf * nqg) ∂μ :
  begin
    refine lintegral_congr (λ a, _),
    rw [pi.mul_apply, fun_eq_fun_mul_inv_snorm_mul_snorm f hf_nonzero hf_nontop,
      fun_eq_fun_mul_inv_snorm_mul_snorm g hg_nonzero hg_nontop, pi.mul_apply],
    ring,
  end
  ... ≤ npf * nqg :
  begin
    rw lintegral_mul_const' (npf * nqg) _
      (by simp [hf_nontop, hg_nontop, hf_nonzero, hg_nonzero, ennreal.mul_eq_top]),
    refine mul_le_of_le_one_left' _,
    have hf1 := lintegral_rpow_fun_mul_inv_snorm_eq_one hpq.pos hf_nonzero hf_nontop,
    have hg1 := lintegral_rpow_fun_mul_inv_snorm_eq_one hpq.symm.pos hg_nonzero hg_nontop,
    exact lintegral_mul_le_one_of_lintegral_rpow_eq_one hpq (hf.mul_const _) hf1 hg1,
  end
end

lemma ae_eq_zero_of_lintegral_rpow_eq_zero {p : ℝ} (hp0 : 0 ≤ p) {f : α → ℝ≥0∞}
  (hf : ae_measurable f μ) (hf_zero : ∫⁻ a, (f a)^p ∂μ = 0) :
  f =ᵐ[μ] 0 :=
begin
  rw lintegral_eq_zero_iff' (hf.pow_const p) at hf_zero,
  refine filter.eventually.mp hf_zero (filter.eventually_of_forall (λ x, _)),
  dsimp only,
  rw [pi.zero_apply, ← not_imp_not],
  exact λ hx, (rpow_pos_of_nonneg (pos_iff_ne_zero.2 hx) hp0).ne'
end

lemma lintegral_mul_eq_zero_of_lintegral_rpow_eq_zero {p : ℝ} (hp0 : 0 ≤ p)
  {f g : α → ℝ≥0∞} (hf : ae_measurable f μ) (hf_zero : ∫⁻ a, (f a)^p ∂μ = 0) :
  ∫⁻ a, (f * g) a ∂μ = 0 :=
begin
  rw ←@lintegral_zero_fun α _ μ,
  refine lintegral_congr_ae _,
  suffices h_mul_zero : f * g =ᵐ[μ] 0 * g , by rwa zero_mul at h_mul_zero,
  have hf_eq_zero : f =ᵐ[μ] 0, from ae_eq_zero_of_lintegral_rpow_eq_zero hp0 hf hf_zero,
  exact hf_eq_zero.mul (ae_eq_refl g),
end

lemma lintegral_mul_le_Lp_mul_Lq_of_ne_zero_of_eq_top {p q : ℝ} (hp0_lt : 0 < p) (hq0 : 0 ≤ q)
  {f g : α → ℝ≥0∞} (hf_top : ∫⁻ a, (f a)^p ∂μ = ⊤) (hg_nonzero : ∫⁻ a, (g a)^q ∂μ ≠ 0) :
  ∫⁻ a, (f * g) a ∂μ ≤ (∫⁻ a, (f a)^p ∂μ) ^ (1/p) * (∫⁻ a, (g a)^q ∂μ) ^ (1/q) :=
begin
  refine le_trans le_top (le_of_eq _),
  have hp0_inv_lt : 0 < 1/p, by simp [hp0_lt],
  rw [hf_top, ennreal.top_rpow_of_pos hp0_inv_lt],
  simp [hq0, hg_nonzero],
end

/-- Hölder's inequality for functions `α → ℝ≥0∞`. The integral of the product of two functions
is bounded by the product of their `ℒp` and `ℒq` seminorms when `p` and `q` are conjugate
exponents. -/
theorem lintegral_mul_le_Lp_mul_Lq (μ : measure α) {p q : ℝ} (hpq : p.is_conjugate_exponent q)
  {f g : α → ℝ≥0∞} (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ∫⁻ a, (f * g) a ∂μ ≤ (∫⁻ a, (f a)^p ∂μ) ^ (1/p) * (∫⁻ a, (g a)^q ∂μ) ^ (1/q) :=
begin
  by_cases hf_zero : ∫⁻ a, (f a) ^ p ∂μ = 0,
  { refine eq.trans_le _ (zero_le _),
    exact lintegral_mul_eq_zero_of_lintegral_rpow_eq_zero hpq.nonneg hf hf_zero, },
  by_cases hg_zero : ∫⁻ a, (g a) ^ q ∂μ = 0,
  { refine eq.trans_le _ (zero_le _),
    rw mul_comm,
    exact lintegral_mul_eq_zero_of_lintegral_rpow_eq_zero hpq.symm.nonneg hg hg_zero, },
  by_cases hf_top : ∫⁻ a, (f a) ^ p ∂μ = ⊤,
  { exact lintegral_mul_le_Lp_mul_Lq_of_ne_zero_of_eq_top hpq.pos hpq.symm.nonneg hf_top hg_zero, },
  by_cases hg_top : ∫⁻ a, (g a) ^ q ∂μ = ⊤,
  { rw [mul_comm, mul_comm ((∫⁻ (a : α), (f a) ^ p ∂μ) ^ (1 / p))],
    exact lintegral_mul_le_Lp_mul_Lq_of_ne_zero_of_eq_top hpq.symm.pos hpq.nonneg hg_top hf_zero, },
  -- non-⊤ non-zero case
  exact ennreal.lintegral_mul_le_Lp_mul_Lq_of_ne_zero_of_ne_top hpq hf hf_top hg_top hf_zero hg_zero
end

lemma lintegral_rpow_add_lt_top_of_lintegral_rpow_lt_top {p : ℝ}
  {f g : α → ℝ≥0∞} (hf : ae_measurable f μ) (hf_top : ∫⁻ a, (f a) ^ p ∂μ < ⊤)
  (hg_top : ∫⁻ a, (g a) ^ p ∂μ < ⊤) (hp1 : 1 ≤ p) :
  ∫⁻ a, ((f + g) a) ^ p ∂μ < ⊤ :=
begin
  have hp0_lt : 0 < p, from lt_of_lt_of_le zero_lt_one hp1,
  have hp0 : 0 ≤ p, from le_of_lt hp0_lt,
  calc ∫⁻ (a : α), (f a + g a) ^ p ∂μ
    ≤ ∫⁻ a, ((2:ℝ≥0∞)^(p-1) * (f a) ^ p + (2:ℝ≥0∞)^(p-1) * (g a) ^ p) ∂ μ :
  begin
    refine lintegral_mono (λ a, _),
    dsimp only,
    have h_zero_lt_half_rpow : (0 : ℝ≥0∞) < (1 / 2) ^ p,
    { rw [←ennreal.zero_rpow_of_pos hp0_lt],
      exact ennreal.rpow_lt_rpow (by simp [zero_lt_one]) hp0_lt, },
    have h_rw : (1 / 2) ^ p * (2:ℝ≥0∞) ^ (p - 1) = 1 / 2,
    { rw [sub_eq_add_neg, ennreal.rpow_add _ _ two_ne_zero ennreal.coe_ne_top,
        ←mul_assoc, ←ennreal.mul_rpow_of_nonneg _ _ hp0, one_div,
        ennreal.inv_mul_cancel two_ne_zero ennreal.coe_ne_top, ennreal.one_rpow,
        one_mul, ennreal.rpow_neg_one], },
    rw ←ennreal.mul_le_mul_left (ne_of_lt h_zero_lt_half_rpow).symm _,
    { rw [mul_add, ← mul_assoc, ← mul_assoc, h_rw, ←ennreal.mul_rpow_of_nonneg _ _ hp0, mul_add],
      refine ennreal.rpow_arith_mean_le_arith_mean2_rpow (1/2 : ℝ≥0∞) (1/2 : ℝ≥0∞)
        (f a) (g a) _ hp1,
      rw [ennreal.div_add_div_same, one_add_one_eq_two,
        ennreal.div_self two_ne_zero ennreal.coe_ne_top], },
    { rw ← lt_top_iff_ne_top,
      refine ennreal.rpow_lt_top_of_nonneg hp0 _,
      rw [one_div, ennreal.inv_ne_top],
      exact two_ne_zero, },
  end
  ... < ⊤ :
  begin
    have h_two : (2 : ℝ≥0∞) ^ (p - 1) ≠ ⊤,
      from ennreal.rpow_ne_top_of_nonneg (by simp [hp1]) ennreal.coe_ne_top,
    rw [lintegral_add_left', lintegral_const_mul'' _ (hf.pow_const p),
      lintegral_const_mul' _ _ h_two, ennreal.add_lt_top],
    { exact ⟨ennreal.mul_lt_top h_two hf_top.ne, ennreal.mul_lt_top h_two hg_top.ne⟩ },
    { exact (hf.pow_const p).const_mul _ }
  end
end

lemma lintegral_Lp_mul_le_Lq_mul_Lr {α} [measurable_space α] {p q r : ℝ} (hp0_lt : 0 < p)
  (hpq : p < q) (hpqr : 1/p = 1/q + 1/r) (μ : measure α) {f g : α → ℝ≥0∞}
  (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  (∫⁻ a, ((f * g) a)^p ∂μ) ^ (1/p) ≤ (∫⁻ a, (f a)^q ∂μ) ^ (1/q) * (∫⁻ a, (g a)^r ∂μ) ^ (1/r) :=
begin
  have hp0_ne : p ≠ 0, from (ne_of_lt hp0_lt).symm,
  have hp0 : 0 ≤ p, from le_of_lt hp0_lt,
  have hq0_lt : 0 < q, from lt_of_le_of_lt hp0 hpq,
  have hq0_ne : q ≠ 0, from (ne_of_lt hq0_lt).symm,
  have h_one_div_r : 1/r = 1/p - 1/q, by simp [hpqr],
  have hr0_ne : r ≠ 0,
  { have hr_inv_pos : 0 < 1/r,
    by rwa [h_one_div_r, sub_pos, one_div_lt_one_div hq0_lt hp0_lt],
    rw [one_div, _root_.inv_pos] at hr_inv_pos,
    exact (ne_of_lt hr_inv_pos).symm, },
  let p2 := q/p,
  let q2 := p2.conjugate_exponent,
  have hp2q2 : p2.is_conjugate_exponent q2,
  from real.is_conjugate_exponent_conjugate_exponent (by simp [lt_div_iff, hpq, hp0_lt]),
  calc (∫⁻ (a : α), ((f * g) a) ^ p ∂μ) ^ (1 / p)
      = (∫⁻ (a : α), (f a)^p * (g a)^p ∂μ) ^ (1 / p) :
  by simp_rw [pi.mul_apply, ennreal.mul_rpow_of_nonneg _ _ hp0]
  ... ≤ ((∫⁻ a, (f a)^(p * p2) ∂ μ)^(1/p2) * (∫⁻ a, (g a)^(p * q2) ∂ μ)^(1/q2)) ^ (1/p) :
  begin
    refine ennreal.rpow_le_rpow _ (by simp [hp0]),
    simp_rw ennreal.rpow_mul,
    exact ennreal.lintegral_mul_le_Lp_mul_Lq μ hp2q2 (hf.pow_const _) (hg.pow_const _)
  end
  ... = (∫⁻ (a : α), (f a) ^ q ∂μ) ^ (1 / q) * (∫⁻ (a : α), (g a) ^ r ∂μ) ^ (1 / r) :
  begin
    rw [@ennreal.mul_rpow_of_nonneg _ _ (1/p) (by simp [hp0]), ←ennreal.rpow_mul,
      ←ennreal.rpow_mul],
    have hpp2 : p * p2 = q,
    { symmetry, rw [mul_comm, ←div_eq_iff hp0_ne], },
    have hpq2 : p * q2 = r,
    { rw [← inv_inv r, ← one_div, ← one_div, h_one_div_r],
      field_simp [q2, real.conjugate_exponent, p2, hp0_ne, hq0_ne] },
    simp_rw [div_mul_div_comm, mul_one, mul_comm p2, mul_comm q2, hpp2, hpq2],
  end
end

lemma lintegral_mul_rpow_le_lintegral_rpow_mul_lintegral_rpow {p q : ℝ}
  (hpq : p.is_conjugate_exponent q) {f g : α → ℝ≥0∞}
  (hf : ae_measurable f μ) (hg : ae_measurable g μ) (hf_top : ∫⁻ a, (f a) ^ p ∂μ ≠ ⊤) :
  ∫⁻ a, (f a) * (g a) ^ (p - 1) ∂μ ≤ (∫⁻ a, (f a)^p ∂μ) ^ (1/p) * (∫⁻ a, (g a)^p ∂μ) ^ (1/q) :=
begin
  refine le_trans (ennreal.lintegral_mul_le_Lp_mul_Lq μ hpq hf (hg.pow_const _)) _,
  by_cases hf_zero_rpow : (∫⁻ (a : α), (f a) ^ p ∂μ) ^ (1 / p) = 0,
  { rw [hf_zero_rpow, zero_mul],
    exact zero_le _, },
  have hf_top_rpow : (∫⁻ (a : α), (f a) ^ p ∂μ) ^ (1 / p) ≠ ⊤,
  { by_contra h,
    refine hf_top _,
    have hp_not_neg : ¬ p < 0, by simp [hpq.nonneg],
    simpa [hpq.pos, hp_not_neg] using h, },
  refine (ennreal.mul_le_mul_left hf_zero_rpow hf_top_rpow).mpr (le_of_eq _),
  congr,
  ext1 a,
  rw [←ennreal.rpow_mul, hpq.sub_one_mul_conj],
end

lemma lintegral_rpow_add_le_add_snorm_mul_lintegral_rpow_add {p q : ℝ}
  (hpq : p.is_conjugate_exponent q) {f g : α → ℝ≥0∞} (hf : ae_measurable f μ)
  (hf_top : ∫⁻ a, (f a) ^ p ∂μ ≠ ⊤) (hg : ae_measurable g μ) (hg_top : ∫⁻ a, (g a) ^ p ∂μ ≠ ⊤) :
  ∫⁻ a, ((f + g) a)^p ∂ μ
    ≤ ((∫⁻ a, (f a)^p ∂μ) ^ (1/p) + (∫⁻ a, (g a)^p ∂μ) ^ (1/p))
      * (∫⁻ a, (f a + g a)^p ∂μ) ^ (1/q) :=
begin
  calc ∫⁻ a, ((f+g) a) ^ p ∂μ ≤ ∫⁻ a, ((f + g) a) * ((f + g) a) ^ (p - 1) ∂μ :
  begin
    refine lintegral_mono (λ a, _),
    dsimp only,
    by_cases h_zero : (f + g) a = 0,
    { rw [h_zero, ennreal.zero_rpow_of_pos hpq.pos],
      exact zero_le _, },
    by_cases h_top : (f + g) a = ⊤,
    { rw [h_top, ennreal.top_rpow_of_pos hpq.sub_one_pos, ennreal.top_mul_top],
      exact le_top, },
    refine le_of_eq _,
    nth_rewrite 1 ←ennreal.rpow_one ((f + g) a),
    rw [←ennreal.rpow_add _ _ h_zero h_top, add_sub_cancel'_right],
  end
    ... = ∫⁻ (a : α), f a * (f + g) a ^ (p - 1) ∂μ + ∫⁻ (a : α), g a * (f + g) a ^ (p - 1) ∂μ :
  begin
    have h_add_m : ae_measurable (λ (a : α), ((f + g) a) ^ (p-1)) μ,
      from (hf.add hg).pow_const _,
    have h_add_apply : ∫⁻ (a : α), (f + g) a * (f + g) a ^ (p - 1) ∂μ
      = ∫⁻ (a : α), (f a + g a) * (f + g) a ^ (p - 1) ∂μ,
    from rfl,
    simp_rw [h_add_apply, add_mul],
    rw lintegral_add_left' (hf.mul h_add_m),
  end
    ... ≤ ((∫⁻ a, (f a)^p ∂μ) ^ (1/p) + (∫⁻ a, (g a)^p ∂μ) ^ (1/p))
      * (∫⁻ a, (f a + g a)^p ∂μ) ^ (1/q) :
  begin
    rw add_mul,
    exact add_le_add
      (lintegral_mul_rpow_le_lintegral_rpow_mul_lintegral_rpow hpq hf (hf.add hg) hf_top)
      (lintegral_mul_rpow_le_lintegral_rpow_mul_lintegral_rpow hpq hg (hf.add hg) hg_top),
  end
end

private lemma lintegral_Lp_add_le_aux {p q : ℝ}
  (hpq : p.is_conjugate_exponent q) {f g : α → ℝ≥0∞} (hf : ae_measurable f μ)
  (hf_top : ∫⁻ a, (f a) ^ p ∂μ ≠ ⊤) (hg : ae_measurable g μ) (hg_top : ∫⁻ a, (g a) ^ p ∂μ ≠ ⊤)
  (h_add_zero : ∫⁻ a, ((f+g) a) ^ p ∂ μ ≠ 0) (h_add_top : ∫⁻ a, ((f+g) a) ^ p ∂ μ ≠ ⊤) :
  (∫⁻ a, ((f + g) a)^p ∂ μ) ^ (1/p) ≤ (∫⁻ a, (f a)^p ∂μ) ^ (1/p) + (∫⁻ a, (g a)^p ∂μ) ^ (1/p) :=
begin
  have hp_not_nonpos : ¬ p ≤ 0, by simp [hpq.pos],
  have htop_rpow : (∫⁻ a, ((f+g) a) ^ p ∂μ)^(1/p) ≠ ⊤,
  { by_contra h,
    exact h_add_top (@ennreal.rpow_eq_top_of_nonneg _ (1/p) (by simp [hpq.nonneg]) h), },
  have h0_rpow : (∫⁻ a, ((f+g) a) ^ p ∂ μ) ^ (1/p) ≠ 0,
  by simp [h_add_zero, h_add_top, hpq.nonneg, hp_not_nonpos, -pi.add_apply],
  suffices h : 1 ≤ (∫⁻ (a : α), ((f+g) a)^p ∂μ) ^ -(1/p)
    * ((∫⁻ (a : α), (f a)^p ∂μ) ^ (1/p) + (∫⁻ (a : α), (g a)^p ∂μ) ^ (1/p)),
  by rwa [←mul_le_mul_left h0_rpow htop_rpow, ←mul_assoc, ←rpow_add _ _ h_add_zero h_add_top,
    ←sub_eq_add_neg, _root_.sub_self, rpow_zero, one_mul, mul_one] at h,
  have h : ∫⁻ (a : α), ((f+g) a)^p ∂μ
    ≤ ((∫⁻ (a : α), (f a)^p ∂μ) ^ (1/p) + (∫⁻ (a : α), (g a)^p ∂μ) ^ (1/p))
      * (∫⁻ (a : α), ((f+g) a)^p ∂μ) ^ (1/q),
  from lintegral_rpow_add_le_add_snorm_mul_lintegral_rpow_add hpq hf hf_top hg hg_top,
  have h_one_div_q : 1/q = 1 - 1/p, by { nth_rewrite 1 ←hpq.inv_add_inv_conj, ring, },
  simp_rw [h_one_div_q, sub_eq_add_neg 1 (1/p), ennreal.rpow_add _ _ h_add_zero h_add_top,
    rpow_one] at h,
  nth_rewrite 1 mul_comm at h,
  nth_rewrite 0 ←one_mul (∫⁻ (a : α), ((f+g) a) ^ p ∂μ) at h,
  rwa [←mul_assoc, ennreal.mul_le_mul_right h_add_zero h_add_top, mul_comm] at h,
end

/-- Minkowski's inequality for functions `α → ℝ≥0∞`: the `ℒp` seminorm of the sum of two
functions is bounded by the sum of their `ℒp` seminorms. -/

end ennreal

/-- Hölder's inequality for functions `α → ℝ≥0`. The integral of the product of two functions
is bounded by the product of their `ℒp` and `ℒq` seminorms when `p` and `q` are conjugate
exponents. -/
theorem nnreal.lintegral_mul_le_Lp_mul_Lq {p q : ℝ} (hpq : p.is_conjugate_exponent q)
  {f g : α → ℝ≥0} (hf : ae_measurable f μ) (hg : ae_measurable g μ) :
  ∫⁻ a, (f * g) a ∂μ ≤ (∫⁻ a, (f a)^p ∂μ)^(1/p) * (∫⁻ a, (g a)^q ∂μ)^(1/q) :=
begin
  simp_rw [pi.mul_apply, ennreal.coe_mul],
  exact ennreal.lintegral_mul_le_Lp_mul_Lq μ hpq hf.coe_nnreal_ennreal hg.coe_nnreal_ennreal,
end

end lintegral


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.pempty
import Mathlib.category_theory.limits.limits
import Mathlib.PostPort

universes u v u₂

namespace Mathlib

/-!
# Initial and terminal objects in a category.

## References
* [Stacks: Initial and final objects](https://stacks.math.columbia.edu/tag/002B)
-/

namespace category_theory.limits

/-- Construct a cone for the empty diagram given an object. -/
/-- Construct a cocone for the empty diagram given an object. -/
@[simp] theorem as_empty_cone_π_app {C : Type u} [category C] (X : C) :
    ∀ (X_1 : discrete pempty),
        nat_trans.app (cone.π (as_empty_cone X)) X_1 = as_empty_cone._aux_1 X X_1 :=
  fun (X_1 : discrete pempty) => Eq.refl (nat_trans.app (cone.π (as_empty_cone X)) X_1)

@[simp] theorem as_empty_cocone_ι_app {C : Type u} [category C] (X : C) :
    ∀ (X_1 : discrete pempty),
        nat_trans.app (cocone.ι (as_empty_cocone X)) X_1 = as_empty_cocone._aux_1 X X_1 :=
  fun (X_1 : discrete pempty) => Eq.refl (nat_trans.app (cocone.ι (as_empty_cocone X)) X_1)

/-- `X` is terminal if the cone it induces on the empty diagram is limiting. -/
/-- `X` is initial if the cocone it induces on the empty diagram is colimiting. -/
def is_terminal {C : Type u} [category C] (X : C) := is_limit (as_empty_cone X)

def is_initial {C : Type u} [category C] (X : C) := is_colimit (as_empty_cocone X)

/-- Give the morphism to a terminal object from any other. -/
def is_terminal.from {C : Type u} [category C] {X : C} (t : is_terminal X) (Y : C) : Y ⟶ X :=
  is_limit.lift t (as_empty_cone Y)

/-- Any two morphisms to a terminal object are equal. -/
theorem is_terminal.hom_ext {C : Type u} [category C] {X : C} {Y : C} (t : is_terminal X)
    (f : Y ⟶ X) (g : Y ⟶ X) : f = g :=
  sorry

/-- Give the morphism from an initial object to any other. -/
def is_initial.to {C : Type u} [category C] {X : C} (t : is_initial X) (Y : C) : X ⟶ Y :=
  is_colimit.desc t (as_empty_cocone Y)

/-- Any two morphisms from an initial object are equal. -/
theorem is_initial.hom_ext {C : Type u} [category C] {X : C} {Y : C} (t : is_initial X) (f : X ⟶ Y)
    (g : X ⟶ Y) : f = g :=
  sorry

/-- Any morphism from a terminal object is mono. -/
theorem is_terminal.mono_from {C : Type u} [category C] {X : C} {Y : C} (t : is_terminal X)
    (f : X ⟶ Y) : mono f :=
  mono.mk fun (Z : C) (g h : Z ⟶ X) (eq : g ≫ f = h ≫ f) => is_terminal.hom_ext t g h

/-- Any morphism to an initial object is epi. -/
theorem is_initial.epi_to {C : Type u} [category C] {X : C} {Y : C} (t : is_initial X) (f : Y ⟶ X) :
    epi f :=
  epi.mk fun (Z : C) (g h : X ⟶ Z) (eq : f ≫ g = f ≫ h) => is_initial.hom_ext t g h

/--
A category has a terminal object if it has a limit over the empty diagram.
Use `has_terminal_of_unique` to construct instances.
-/
/--
def has_terminal (C : Type u) [category C] := has_limits_of_shape (discrete pempty) C

A category has an initial object if it has a colimit over the empty diagram.
Use `has_initial_of_unique` to construct instances.
-/
def has_initial (C : Type u) [category C] := has_colimits_of_shape (discrete pempty) C

/--
An arbitrary choice of terminal object, if one exists.
You can use the notation `⊤_ C`.
This object is characterized by having a unique morphism from any object.
-/
/--
def terminal (C : Type u) [category C] [has_terminal C] : C := limit (functor.empty C)

An arbitrary choice of initial object, if one exists.
You can use the notation `⊥_ C`.
This object is characterized by having a unique morphism to any object.
-/
def initial (C : Type u) [category C] [has_initial C] : C := colimit (functor.empty C)

prefix:20 "⊤_" => Mathlib.category_theory.limits.terminal

prefix:20 "⊥_" => Mathlib.category_theory.limits.initial

/-- We can more explicitly show that a category has a terminal object by specifying the object,
and showing there is a unique morphism to it from any other object. -/
theorem has_terminal_of_unique {C : Type u} [category C] (X : C) [h : (Y : C) → unique (Y ⟶ X)] :
    has_terminal C :=
  sorry

/-- We can more explicitly show that a category has an initial object by specifying the object,
and showing there is a unique morphism from it to any other object. -/
theorem has_initial_of_unique {C : Type u} [category C] (X : C) [h : (Y : C) → unique (X ⟶ Y)] :
    has_initial C :=
  sorry

/-- The map from an object to the terminal object. -/
def terminal.from {C : Type u} [category C] [has_terminal C] (P : C) : P ⟶ ⊤_C :=
  limit.lift (functor.empty C) (as_empty_cone P)

/-- The map to an object from the initial object. -/
def initial.to {C : Type u} [category C] [has_initial C] (P : C) : ⊥_C ⟶ P :=
  colimit.desc (functor.empty C) (as_empty_cocone P)

protected instance unique_to_terminal {C : Type u} [category C] [has_terminal C] (P : C) :
    unique (P ⟶ ⊤_C) :=
  unique.mk { default := terminal.from P } sorry

protected instance unique_from_initial {C : Type u} [category C] [has_initial C] (P : C) :
    unique (⊥_C ⟶ P) :=
  unique.mk { default := initial.to P } sorry

/-- A terminal object is terminal. -/
def terminal_is_terminal {C : Type u} [category C] [has_terminal C] : is_terminal (⊤_C) :=
  is_limit.mk fun (s : cone (functor.empty C)) => terminal.from (cone.X s)

/-- An initial object is initial. -/
def initial_is_initial {C : Type u} [category C] [has_initial C] : is_initial (⊥_C) :=
  is_colimit.mk fun (s : cocone (functor.empty C)) => initial.to (cocone.X s)

/-- Any morphism from a terminal object is mono. -/
protected instance terminal.mono_from {C : Type u} [category C] {Y : C} [has_terminal C]
    (f : ⊤_C ⟶ Y) : mono f :=
  is_terminal.mono_from terminal_is_terminal f

/-- Any morphism to an initial object is epi. -/
protected instance initial.epi_to {C : Type u} [category C] {Y : C} [has_initial C] (f : Y ⟶ ⊥_C) :
    epi f :=
  is_initial.epi_to initial_is_initial f

/-- An initial object is terminal in the opposite category. -/
def terminal_op_of_initial {C : Type u} [category C] {X : C} (t : is_initial X) :
    is_terminal (opposite.op X) :=
  is_limit.mk
    fun (s : cone (functor.empty (Cᵒᵖ))) =>
      has_hom.hom.op (is_initial.to t (opposite.unop (cone.X s)))

/-- An initial object in the opposite category is terminal in the original category. -/
def terminal_unop_of_initial {C : Type u} [category C] {X : Cᵒᵖ} (t : is_initial X) :
    is_terminal (opposite.unop X) :=
  is_limit.mk
    fun (s : cone (functor.empty C)) => has_hom.hom.unop (is_initial.to t (opposite.op (cone.X s)))

/-- A terminal object is initial in the opposite category. -/
def initial_op_of_terminal {C : Type u} [category C] {X : C} (t : is_terminal X) :
    is_initial (opposite.op X) :=
  is_colimit.mk
    fun (s : cocone (functor.empty (Cᵒᵖ))) =>
      has_hom.hom.op (is_terminal.from t (opposite.unop (cocone.X s)))

/-- A terminal object in the opposite category is initial in the original category. -/
def initial_unop_of_terminal {C : Type u} [category C] {X : Cᵒᵖ} (t : is_terminal X) :
    is_initial (opposite.unop X) :=
  is_colimit.mk
    fun (s : cocone (functor.empty C)) =>
      has_hom.hom.unop (is_terminal.from t (opposite.op (cocone.X s)))

/-- From a functor `F : J ⥤ C`, given an initial object of `J`, construct a cone for `J`.
In `limit_of_diagram_initial` we show it is a limit cone. -/
@[simp] theorem cone_of_diagram_initial_π_app {C : Type u} [category C] {J : Type v}
    [small_category J] {X : J} (tX : is_initial X) (F : J ⥤ C) (j : J) :
    nat_trans.app (cone.π (cone_of_diagram_initial tX F)) j = functor.map F (is_initial.to tX j) :=
  Eq.refl (nat_trans.app (cone.π (cone_of_diagram_initial tX F)) j)

/-- From a functor `F : J ⥤ C`, given an initial object of `J`, show the cone
`cone_of_diagram_initial` is a limit. -/
def limit_of_diagram_initial {C : Type u} [category C] {J : Type v} [small_category J] {X : J}
    (tX : is_initial X) (F : J ⥤ C) : is_limit (cone_of_diagram_initial tX F) :=
  is_limit.mk fun (s : cone F) => nat_trans.app (cone.π s) X

-- This is reducible to allow usage of lemmas about `cone_point_unique_up_to_iso`.

/-- For a functor `F : J ⥤ C`, if `J` has an initial object then the image of it is isomorphic
to the limit of `F`. -/
def limit_of_initial {C : Type u} [category C] {J : Type v} [small_category J] (F : J ⥤ C)
    [has_initial J] [has_limit F] : limit F ≅ functor.obj F (⊥_J) :=
  is_limit.cone_point_unique_up_to_iso (limit.is_limit F)
    (limit_of_diagram_initial initial_is_initial F)

/-- From a functor `F : J ⥤ C`, given a terminal object of `J`, construct a cocone for `J`.
In `colimit_of_diagram_terminal` we show it is a colimit cocone. -/
@[simp] theorem cocone_of_diagram_terminal_X {C : Type u} [category C] {J : Type v}
    [small_category J] {X : J} (tX : is_terminal X) (F : J ⥤ C) :
    cocone.X (cocone_of_diagram_terminal tX F) = functor.obj F X :=
  Eq.refl (cocone.X (cocone_of_diagram_terminal tX F))

/-- From a functor `F : J ⥤ C`, given a terminal object of `J`, show the cocone
`cocone_of_diagram_terminal` is a colimit. -/
def colimit_of_diagram_terminal {C : Type u} [category C] {J : Type v} [small_category J] {X : J}
    (tX : is_terminal X) (F : J ⥤ C) : is_colimit (cocone_of_diagram_terminal tX F) :=
  is_colimit.mk fun (s : cocone F) => nat_trans.app (cocone.ι s) X

-- This is reducible to allow usage of lemmas about `cocone_point_unique_up_to_iso`.

/-- For a functor `F : J ⥤ C`, if `J` has a terminal object then the image of it is isomorphic
to the colimit of `F`. -/
def colimit_of_terminal {C : Type u} [category C] {J : Type v} [small_category J] (F : J ⥤ C)
    [has_terminal J] [has_colimit F] : colimit F ≅ functor.obj F (⊤_J) :=
  is_colimit.cocone_point_unique_up_to_iso (colimit.is_colimit F)
    (colimit_of_diagram_terminal terminal_is_terminal F)

/--
The comparison morphism from the image of a terminal object to the terminal object in the target
category.
-/
-- TODO: Show this is an isomorphism if and only if `G` preserves terminal objects.

def terminal_comparison {C : Type u} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    [has_terminal C] [has_terminal D] : functor.obj G (⊤_C) ⟶ ⊤_D :=
  terminal.from (functor.obj G (⊤_C))

/--
The comparison morphism from the initial object in the target category to the image of the initial
object.
-/
-- TODO: Show this is an isomorphism if and only if `G` preserves initial objects.

def initial_comparison {C : Type u} [category C] {D : Type u₂} [category D] (G : C ⥤ D)
    [has_initial C] [has_initial D] : ⊥_D ⟶ functor.obj G (⊥_C) :=
  initial.to (functor.obj G (⊥_C))

end Mathlib


/-
Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Violeta Hernández Palacios
-/
import set_theory.ordinal_arithmetic
import topology.algebra.order.basic

/-!
### Topology of ordinals

We prove some miscellaneous results involving the order topology of ordinals.

### Main results

* `ordinal.is_closed_iff_sup` / `ordinal.is_closed_iff_bsup`: A set of ordinals is closed iff it's
  closed under suprema.
* `ordinal.is_normal_iff_strict_mono_and_continuous`: A characterization of normal ordinal
  functions.
* `ordinal.enum_ord_is_normal_iff_is_closed`: The function enumerating the ordinals of a set is
  normal iff the set is closed.
-/

noncomputable theory

universes u v

open cardinal

namespace ordinal

instance : topological_space ordinal.{u} :=
preorder.topology ordinal.{u}

instance : order_topology ordinal.{u} :=
⟨rfl⟩

theorem is_open_singleton_iff {o : ordinal} : is_open ({o} : set ordinal) ↔ ¬ is_limit o :=
begin
  refine ⟨λ h ho, _, λ ho, _⟩,
  { obtain ⟨a, b, hab, hab'⟩ := (mem_nhds_iff_exists_Ioo_subset'
      ⟨0, ordinal.pos_iff_ne_zero.2 ho.1⟩ ⟨_, lt_succ_self o⟩).1 (h.mem_nhds rfl),
    have hao := ho.2 a hab.1,
    exact hao.ne (hab' ⟨lt_succ_self a, hao.trans hab.2⟩) },
  { rcases zero_or_succ_or_limit o with rfl | ⟨a, ha⟩ | ho',
    { convert is_open_gt' (1 : ordinal),
      ext,
      exact ordinal.lt_one_iff_zero.symm },
    { convert @is_open_Ioo _ _ _ _ a (o + 1),
      ext b,
      refine ⟨λ hb, _, _⟩,
      { rw set.mem_singleton_iff.1 hb,
        refine ⟨_, lt_succ_self o⟩,
        rw ha,
        exact lt_succ_self a },
      { rintro ⟨hb, hb'⟩,
        apply le_antisymm (lt_succ.1 hb'),
        rw ha,
        exact ordinal.succ_le.2 hb } },
    { exact (ho ho').elim } }
end

theorem is_open_iff (s : set ordinal) :
  is_open s ↔ (∀ o ∈ s, is_limit o → ∃ a < o, set.Ioo a o ⊆ s) :=
begin
  classical,
  refine ⟨_, λ h, _⟩,
  { rw is_open_iff_generate_intervals,
    intros h o hos ho,
    have ho₀ := ordinal.pos_iff_ne_zero.2 ho.1,
    induction h with t ht t u ht hu ht' hu' t ht H,
    { rcases ht with ⟨a, rfl | rfl⟩,
      { exact ⟨a, hos, λ b hb, hb.1⟩ },
      { exact ⟨0, ho₀, λ b hb, hb.2.trans hos⟩ } },
    { exact ⟨0, ho₀, λ b _, set.mem_univ b⟩ },
    { rcases ht' hos.1 with ⟨a, ha, ha'⟩,
      rcases hu' hos.2 with ⟨b, hb, hb'⟩,
      exact ⟨_, max_lt ha hb, λ c hc, ⟨
        ha' ⟨(le_max_left a b).trans_lt hc.1, hc.2⟩,
        hb' ⟨(le_max_right a b).trans_lt hc.1, hc.2⟩⟩⟩ },
    { rcases hos with ⟨u, hu, hu'⟩,
      rcases H u hu hu' with ⟨a, ha, ha'⟩,
      exact ⟨a, ha, λ b hb, ⟨u, hu, ha' hb⟩⟩ } },
  { let f : s → set ordinal := λ o,
      if ho : is_limit o.val
      then set.Ioo (classical.some (h o.val o.prop ho)) (o + 1)
      else {o.val},
    have : ∀ a, is_open (f a) := λ a, begin
      change is_open (dite _ _ _),
      split_ifs,
      { exact is_open_Ioo },
      { rwa is_open_singleton_iff }
    end,
    convert is_open_Union this,
    ext o,
    refine ⟨λ ho, set.mem_Union.2 ⟨⟨o, ho⟩, _⟩, _⟩,
    { split_ifs with ho',
      { refine ⟨_, lt_succ_self o⟩,
        cases classical.some_spec (h o ho ho') with H,
        exact H },
      { exact set.mem_singleton o } },
    { rintro ⟨t, ⟨a, ht⟩, hoa⟩,
      change dite _ _ _ = t at ht,
      split_ifs at ht with ha;
      subst ht,
      { cases classical.some_spec (h a.val a.prop ha) with H has,
        rcases lt_or_eq_of_le (lt_succ.1 hoa.2) with hoa' | rfl,
        { exact has ⟨hoa.1, hoa'⟩ },
        { exact a.prop } },
      { convert a.prop } } }
end

theorem mem_closure_iff_sup {s : set ordinal.{u}} {a : ordinal.{u}} :
  a ∈ closure s ↔ ∃ {ι : Type u} [nonempty ι] (f : ι → ordinal.{u}),
  (∀ i, f i ∈ s) ∧ sup.{u u} f = a :=
begin
  refine mem_closure_iff.trans ⟨λ h, _, _⟩,
  { by_cases has : a ∈ s,
    { exact ⟨punit, by apply_instance, λ _, a, λ _, has, sup_const a⟩ },
    { have H := λ b (hba : b < a), h _ (@is_open_Ioo _ _ _ _ b (a + 1)) ⟨hba, lt_succ_self a⟩,
      let f : a.out.α → ordinal := λ i, classical.some (H (typein (<) i) (typein_lt_self i)),
      have hf : ∀ i, f i ∈ set.Ioo (typein (<) i) (a + 1) ∩ s :=
        λ i, classical.some_spec (H _ _),
      rcases eq_zero_or_pos a with rfl | ha₀,
      { rcases h _ (is_open_singleton_iff.2 not_zero_is_limit) rfl with ⟨b, hb, hb'⟩,
        rw set.mem_singleton_iff.1 hb at *,
        exact (has hb').elim },
      refine ⟨_, out_nonempty_iff_ne_zero.2 (ordinal.pos_iff_ne_zero.1 ha₀), f,
        λ i, (hf i).2, le_antisymm (sup_le (λ i, lt_succ.1 (hf i).1.2)) _⟩,
      by_contra' h,
      cases H _ h with b hb,
      rcases eq_or_lt_of_le (lt_succ.1 hb.1.2) with rfl | hba,
      { exact has hb.2 },
      { have : b < f (enum (<) b (by rwa type_lt)) := begin
          have := (hf (enum (<) b (by rwa type_lt))).1.1,
          rwa typein_enum at this
        end,
        have : b ≤ sup.{u u} f := this.le.trans (le_sup f _),
        exact this.not_lt hb.1.1 } } },
  { rintro ⟨ι, ⟨i⟩, f, hf, rfl⟩ t ht hat,
    cases eq_zero_or_pos (sup.{u u} f) with ha₀ ha₀,
    { rw ha₀ at hat,
      use [0, hat],
      convert hf i,
      exact (sup_eq_zero_iff.1 ha₀ i).symm },
    rcases (mem_nhds_iff_exists_Ioo_subset' ⟨0, ha₀⟩ ⟨_, lt_succ_self _⟩).1 (ht.mem_nhds hat) with
      ⟨b, c, ⟨hab, hac⟩, hbct⟩,
    cases lt_sup.1 hab with i hi,
    exact ⟨_, hbct ⟨hi, (le_sup.{u u} f i).trans_lt hac⟩, hf i⟩ }
end

theorem mem_closed_iff_sup {s : set ordinal.{u}} {a : ordinal.{u}} (hs : is_closed s) :
  a ∈ s ↔ ∃ {ι : Type u} (hι : nonempty ι) (f : ι → ordinal.{u}),
  (∀ i, f i ∈ s) ∧ sup.{u u} f = a :=
by rw [←mem_closure_iff_sup, hs.closure_eq]

theorem mem_closure_iff_bsup {s : set ordinal.{u}} {a : ordinal.{u}} :
  a ∈ closure s ↔ ∃ {o : ordinal} (ho : o ≠ 0) (f : Π a < o, ordinal.{u}),
  (∀ i hi, f i hi ∈ s) ∧ bsup.{u u} o f = a :=
mem_closure_iff_sup.trans ⟨
  λ ⟨ι, ⟨i⟩, f, hf, ha⟩, ⟨_, λ h, (type_eq_zero_iff_is_empty.1 h).elim i, bfamily_of_family f,
    λ i hi, hf _, by rwa bsup_eq_sup⟩,
  λ ⟨o, ho, f, hf, ha⟩, ⟨_, out_nonempty_iff_ne_zero.2 ho, family_of_bfamily o f,
    λ i, hf _ _, by rwa sup_eq_bsup⟩⟩

theorem mem_closed_iff_bsup {s : set ordinal.{u}} {a : ordinal.{u}} (hs : is_closed s) :
  a ∈ s ↔ ∃ {o : ordinal} (ho : o ≠ 0) (f : Π a < o, ordinal.{u}),
  (∀ i hi, f i hi ∈ s) ∧ bsup.{u u} o f = a :=
by rw [←mem_closure_iff_bsup, hs.closure_eq]

theorem is_closed_iff_sup {s : set ordinal.{u}} :
  is_closed s ↔ ∀ {ι : Type u} (hι : nonempty ι) (f : ι → ordinal.{u}),
  (∀ i, f i ∈ s) → sup.{u u} f ∈ s :=
begin
  use λ hs ι hι f hf, (mem_closed_iff_sup hs).2 ⟨ι, hι, f, hf, rfl⟩,
  rw ←closure_subset_iff_is_closed,
  intros h x hx,
  rcases mem_closure_iff_sup.1 hx with ⟨ι, hι, f, hf, rfl⟩,
  exact h hι f hf
end

theorem is_closed_iff_bsup {s : set ordinal.{u}} :
  is_closed s ↔ ∀ {o : ordinal.{u}} (ho : o ≠ 0) (f : Π a < o, ordinal.{u}),
  (∀ i hi, f i hi ∈ s) → bsup.{u u} o f ∈ s :=
begin
  rw is_closed_iff_sup,
  refine ⟨λ H o ho f hf, H (out_nonempty_iff_ne_zero.2 ho) _ _, λ  H ι hι f hf, _⟩,
  { exact λ i, hf _ _ },
  { rw ←bsup_eq_sup,
    apply H (type_ne_zero_iff_nonempty.2 hι),
    exact λ i hi, hf _ }
end

theorem is_limit_of_mem_frontier {s : set ordinal} {o : ordinal} (ho : o ∈ frontier s) :
  is_limit o :=
begin
  simp only [frontier_eq_closure_inter_closure, set.mem_inter_iff, mem_closure_iff] at ho,
  by_contra h,
  rw ←is_open_singleton_iff at h,
  rcases ho.1 _ h rfl with ⟨a, ha, ha'⟩,
  rcases ho.2 _ h rfl with ⟨b, hb, hb'⟩,
  rw set.mem_singleton_iff at *,
  subst ha, subst hb,
  exact hb' ha'
end

theorem is_normal_iff_strict_mono_and_continuous (f : ordinal.{u} → ordinal.{u}) :
  is_normal f ↔ (strict_mono f ∧ continuous f) :=
begin
  refine ⟨λ h, ⟨h.strict_mono, _⟩, _⟩,
  { rw continuous_def,
    intros s hs,
    rw is_open_iff at *,
    intros o ho ho',
    rcases hs _ ho (h.is_limit ho') with ⟨a, ha, has⟩,
    rw [←is_normal.bsup_eq.{u u} h ho', lt_bsup] at ha,
    rcases ha with ⟨b, hb, hab⟩,
    exact ⟨b, hb, λ c hc,
      set.mem_preimage.2 (has ⟨hab.trans (h.strict_mono hc.1), h.strict_mono hc.2⟩)⟩ },
  { rw is_normal_iff_strict_mono_limit,
    rintro ⟨h, h'⟩,
    refine ⟨h, λ o ho a h, _⟩,
    suffices : o ∈ (f ⁻¹' set.Iic a), from set.mem_preimage.1 this,
    rw mem_closed_iff_sup (is_closed.preimage h' (@is_closed_Iic _ _ _ _  a)),
    exact ⟨_, out_nonempty_iff_ne_zero.2 ho.1, typein (<),
      λ i, h _ (typein_lt_self i), sup_typein_limit ho.2⟩ }
end

theorem enum_ord_is_normal_iff_is_closed {S : set ordinal.{u}} (hS : S.unbounded (<)) :
  is_normal (enum_ord S) ↔ is_closed S :=
begin
  have HS := enum_ord_strict_mono hS,
  refine ⟨λ h, is_closed_iff_sup.2 (λ ι hι f hf, _),
    λ h, (is_normal_iff_strict_mono_limit _).2 ⟨HS, λ a ha o H, _⟩⟩,
  { let g : ι → ordinal.{u} := λ i, (enum_ord_order_iso hS).symm ⟨_, hf i⟩,
    suffices : enum_ord S (sup.{u u} g) = sup.{u u} f,
    { rw ←this, exact enum_ord_mem hS _ },
    rw is_normal.sup.{u u u} h g hι,
    congr, ext,
    change ((enum_ord_order_iso hS) _).val = f x,
    rw order_iso.apply_symm_apply },
  { rw is_closed_iff_bsup at h,
    suffices : enum_ord S a ≤ bsup.{u u} a (λ b < a, enum_ord S b), from this.trans (bsup_le H),
    cases enum_ord_surjective hS _ (h ha.1 (λ b hb, enum_ord S b) (λ b hb, enum_ord_mem hS b))
      with b hb,
    rw ←hb,
    apply HS.monotone,
    by_contra' hba,
    apply (HS (lt_succ_self b)).not_le,
    rw hb,
    exact le_bsup.{u u} _ _ (ha.2 _ hba) }
end

end ordinal


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.kernel_pair
! leanprover-community/mathlib commit 8ef6f08ff8c781c5c07a8b12843710e1a0d8a688
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.Equalizers
import Mathbin.CategoryTheory.Limits.Shapes.CommSq
import Mathbin.CategoryTheory.Limits.Shapes.RegularMono

/-!
# Kernel pairs

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

This file defines what it means for a parallel pair of morphisms `a b : R ⟶ X` to be the kernel pair
for a morphism `f`.
Some properties of kernel pairs are given, namely allowing one to transfer between
the kernel pair of `f₁ ≫ f₂` to the kernel pair of `f₁`.
It is also proved that if `f` is a coequalizer of some pair, and `a`,`b` is a kernel pair for `f`
then it is a coequalizer of `a`,`b`.

## Implementation

The definition is essentially just a wrapper for `is_limit (pullback_cone.mk _ _ _)`, but the
constructions given here are useful, yet awkward to present in that language, so a basic API
is developed here.

## TODO

- Internal equivalence relations (or congruences) and the fact that every kernel pair induces one,
  and the converse in an effective regular category (WIP by b-mehta).

-/

universe v u u₂

namespace CategoryTheory

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

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

variable {R X Y Z : C} (f : X ⟶ Y) (a b : R ⟶ X)

#print CategoryTheory.IsKernelPair /-
/-- `is_kernel_pair f a b` expresses that `(a, b)` is a kernel pair for `f`, i.e. `a ≫ f = b ≫ f`
and the square
  R → X
  ↓   ↓
  X → Y
is a pullback square.
This is just an abbreviation for `is_pullback a b f f`.
-/
abbrev IsKernelPair :=
  IsPullback a b f f
#align category_theory.is_kernel_pair CategoryTheory.IsKernelPair
-/

namespace IsKernelPair

/-- The data expressing that `(a, b)` is a kernel pair is subsingleton. -/
instance : Subsingleton (IsKernelPair f a b) :=
  ⟨fun P Q => by
    cases P
    cases Q
    congr ⟩

#print CategoryTheory.IsKernelPair.id_of_mono /-
/-- If `f` is a monomorphism, then `(𝟙 _, 𝟙 _)`  is a kernel pair for `f`. -/
theorem id_of_mono [Mono f] : IsKernelPair f (𝟙 _) (𝟙 _) :=
  ⟨⟨rfl⟩, ⟨PullbackCone.isLimitMkIdId _⟩⟩
#align category_theory.is_kernel_pair.id_of_mono CategoryTheory.IsKernelPair.id_of_mono
-/

instance [Mono f] : Inhabited (IsKernelPair f (𝟙 _) (𝟙 _)) :=
  ⟨id_of_mono f⟩

variable {f a b}

#print CategoryTheory.IsKernelPair.lift' /-
/--
Given a pair of morphisms `p`, `q` to `X` which factor through `f`, they factor through any kernel
pair of `f`.
-/
noncomputable def lift' {S : C} (k : IsKernelPair f a b) (p q : S ⟶ X) (w : p ≫ f = q ≫ f) :
    { t : S ⟶ R // t ≫ a = p ∧ t ≫ b = q } :=
  PullbackCone.IsLimit.lift' k.IsLimit _ _ w
#align category_theory.is_kernel_pair.lift' CategoryTheory.IsKernelPair.lift'
-/

#print CategoryTheory.IsKernelPair.cancel_right /-
/--
If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `a ≫ f₁ = b ≫ f₁`, then `(a,b)` is a kernel pair for
just `f₁`.
That is, to show that `(a,b)` is a kernel pair for `f₁` it suffices to only show the square
commutes, rather than to additionally show it's a pullback.
-/
theorem cancel_right {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} (comm : a ≫ f₁ = b ≫ f₁)
    (big_k : IsKernelPair (f₁ ≫ f₂) a b) : IsKernelPair f₁ a b :=
  { w := comm
    is_limit' :=
      ⟨PullbackCone.isLimitAux' _ fun s =>
          by
          let s' : pullback_cone (f₁ ≫ f₂) (f₁ ≫ f₂) :=
            pullback_cone.mk s.fst s.snd (s.condition_assoc _)
          refine'
            ⟨big_k.is_limit.lift s', big_k.is_limit.fac _ walking_cospan.left,
              big_k.is_limit.fac _ walking_cospan.right, fun m m₁ m₂ => _⟩
          apply big_k.is_limit.hom_ext
          refine' (pullback_cone.mk a b _ : pullback_cone (f₁ ≫ f₂) _).equalizer_ext _ _
          apply m₁.trans (big_k.is_limit.fac s' walking_cospan.left).symm
          apply m₂.trans (big_k.is_limit.fac s' walking_cospan.right).symm⟩ }
#align category_theory.is_kernel_pair.cancel_right CategoryTheory.IsKernelPair.cancel_right
-/

#print CategoryTheory.IsKernelPair.cancel_right_of_mono /-
/-- If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `f₂` is mono, then `(a,b)` is a kernel pair for
just `f₁`.
The converse of `comp_of_mono`.
-/
theorem cancel_right_of_mono {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [Mono f₂]
    (big_k : IsKernelPair (f₁ ≫ f₂) a b) : IsKernelPair f₁ a b :=
  cancel_right (by rw [← cancel_mono f₂, assoc, assoc, big_k.w]) big_k
#align category_theory.is_kernel_pair.cancel_right_of_mono CategoryTheory.IsKernelPair.cancel_right_of_mono
-/

#print CategoryTheory.IsKernelPair.comp_of_mono /-
/--
If `(a,b)` is a kernel pair for `f₁` and `f₂` is mono, then `(a,b)` is a kernel pair for `f₁ ≫ f₂`.
The converse of `cancel_right_of_mono`.
-/
theorem comp_of_mono {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [Mono f₂] (small_k : IsKernelPair f₁ a b) :
    IsKernelPair (f₁ ≫ f₂) a b :=
  { w := by rw [small_k.w_assoc]
    is_limit' :=
      ⟨PullbackCone.isLimitAux' _ fun s => by
          refine' ⟨_, _, _, _⟩
          apply (pullback_cone.is_limit.lift' small_k.is_limit s.fst s.snd _).1
          rw [← cancel_mono f₂, assoc, s.condition, assoc]
          apply (pullback_cone.is_limit.lift' small_k.is_limit s.fst s.snd _).2.1
          apply (pullback_cone.is_limit.lift' small_k.is_limit s.fst s.snd _).2.2
          intro m m₁ m₂
          apply small_k.is_limit.hom_ext
          refine' (pullback_cone.mk a b _ : pullback_cone f₁ _).equalizer_ext _ _
          · exact m₁.trans (pullback_cone.is_limit.lift' small_k.is_limit s.fst s.snd _).2.1.symm
          · exact m₂.trans (pullback_cone.is_limit.lift' small_k.is_limit s.fst s.snd _).2.2.symm⟩ }
#align category_theory.is_kernel_pair.comp_of_mono CategoryTheory.IsKernelPair.comp_of_mono
-/

#print CategoryTheory.IsKernelPair.toCoequalizer /-
/--
If `(a,b)` is the kernel pair of `f`, and `f` is a coequalizer morphism for some parallel pair, then
`f` is a coequalizer morphism of `a` and `b`.
-/
def toCoequalizer (k : IsKernelPair f a b) [r : RegularEpi f] : IsColimit (Cofork.ofπ f k.w) :=
  by
  let t := k.is_limit.lift (pullback_cone.mk _ _ r.w)
  have ht : t ≫ a = r.left := k.is_limit.fac _ walking_cospan.left
  have kt : t ≫ b = r.right := k.is_limit.fac _ walking_cospan.right
  apply cofork.is_colimit.mk _ _ _ _
  · intro s
    apply (cofork.is_colimit.desc' r.is_colimit s.π _).1
    rw [← ht, assoc, s.condition, reassoc_of kt]
  · intro s
    apply (cofork.is_colimit.desc' r.is_colimit s.π _).2
  · intro s m w
    apply r.is_colimit.hom_ext
    rintro ⟨⟩
    change (r.left ≫ f) ≫ m = (r.left ≫ f) ≫ _
    rw [assoc, assoc]
    congr 1
    erw [(cofork.is_colimit.desc' r.is_colimit s.π _).2]
    apply w
    erw [(cofork.is_colimit.desc' r.is_colimit s.π _).2]
    apply w
#align category_theory.is_kernel_pair.to_coequalizer CategoryTheory.IsKernelPair.toCoequalizer
-/

#print CategoryTheory.IsKernelPair.pullback /-
/-- If `a₁ a₂ : A ⟶ Y` is a kernel pair for `g : Y ⟶ Z`, then `a₁ ×[Z] X` and `a₂ ×[Z] X`
(`A ×[Z] X ⟶ Y ×[Z] X`) is a kernel pair for `Y ×[Z] X ⟶ X`. -/
protected theorem pullback {X Y Z A : C} {g : Y ⟶ Z} {a₁ a₂ : A ⟶ Y} (h : IsKernelPair g a₁ a₂)
    (f : X ⟶ Z) [HasPullback f g] [HasPullback f (a₁ ≫ g)] :
    IsKernelPair (pullback.fst : pullback f g ⟶ X)
      (pullback.map f _ f _ (𝟙 X) a₁ (𝟙 Z) (by simp) <| Category.comp_id _)
      (pullback.map _ _ _ _ (𝟙 X) a₂ (𝟙 Z) (by simp) <| (Category.comp_id _).trans h.1.1) :=
  by
  refine' ⟨⟨_⟩, ⟨_⟩⟩
  · rw [pullback.lift_fst, pullback.lift_fst]
  · fapply pullback_cone.is_limit_aux'
    intro s
    refine'
      ⟨pullback.lift (s.fst ≫ pullback.fst)
          (h.lift' (s.fst ≫ pullback.snd) (s.snd ≫ pullback.snd) _).1 _,
        _, _, _⟩
    · simp_rw [category.assoc, ← pullback.condition, ← category.assoc, s.condition]
    · rw [← category.assoc, (h.lift' _ _ _).2.1, category.assoc, category.assoc, pullback.condition]
    · rw [limits.pullback_cone.mk_fst]
      ext <;>
        simp only [category.assoc, pullback.lift_fst, pullback.lift_snd, pullback.lift_snd_assoc,
          category.comp_id, (h.lift' _ _ _).2.1]
    · rw [limits.pullback_cone.mk_snd]
      ext <;>
        simp only [category.assoc, pullback.lift_fst, pullback.lift_snd, pullback.lift_snd_assoc,
          category.comp_id, (h.lift' _ _ _).2.2, s.condition]
    · intro m h₁ h₂
      ext
      · rw [pullback.lift_fst]
        conv_rhs => rw [← h₁, category.assoc, pullback_cone.mk_fst]
        congr 1
        refine' ((pullback.lift_fst _ _ _).trans <| category.comp_id _).symm
      · rw [pullback.lift_snd]
        apply pullback_cone.is_limit.hom_ext h.is_limit <;>
            dsimp only [is_pullback.cone, comm_sq.cone] <;>
          simp only [pullback_cone.mk_fst, pullback_cone.mk_snd, category.assoc,
            (h.lift' _ _ _).2.1, (h.lift' _ _ _).2.2]
        · conv_rhs => rw [← h₁, category.assoc, pullback_cone.mk_fst, pullback.lift_snd]
        · conv_rhs => rw [← h₂, category.assoc, pullback_cone.mk_snd, pullback.lift_snd]
#align category_theory.is_kernel_pair.pullback CategoryTheory.IsKernelPair.pullback
-/

#print CategoryTheory.IsKernelPair.mono_of_isIso_fst /-
theorem mono_of_isIso_fst (h : IsKernelPair f a b) [IsIso a] : Mono f :=
  by
  obtain ⟨l, h₁, h₂⟩ := limits.pullback_cone.is_limit.lift' h.is_limit (𝟙 _) (𝟙 _) (by simp [h.w])
  rw [is_pullback.cone_fst, ← is_iso.eq_comp_inv, category.id_comp] at h₁
  rw [h₁, is_iso.inv_comp_eq, category.comp_id] at h₂
  constructor
  intro Z g₁ g₂ e
  obtain ⟨l', rfl, rfl⟩ := limits.pullback_cone.is_limit.lift' h.is_limit _ _ e
  rw [is_pullback.cone_fst, h₂]
#align category_theory.is_kernel_pair.mono_of_is_iso_fst CategoryTheory.IsKernelPair.mono_of_isIso_fst
-/

#print CategoryTheory.IsKernelPair.isIso_of_mono /-
theorem isIso_of_mono (h : IsKernelPair f a b) [Mono f] : IsIso a :=
  by
  rw [←
    show _ = a from
      (category.comp_id _).symm.trans
        ((is_kernel_pair.id_of_mono f).IsLimit.conePointUniqueUpToIso_inv_comp h.is_limit
          walking_cospan.left)]
  infer_instance
#align category_theory.is_kernel_pair.is_iso_of_mono CategoryTheory.IsKernelPair.isIso_of_mono
-/

#print CategoryTheory.IsKernelPair.of_isIso_of_mono /-
theorem of_isIso_of_mono [IsIso a] [Mono f] : IsKernelPair f a a :=
  by
  delta is_kernel_pair
  convert_to is_pullback a (a ≫ 𝟙 X) (𝟙 X ≫ f) f
  · rw [category.comp_id]; · rw [category.id_comp]
  exact (is_pullback.of_horiz_is_iso ⟨rfl⟩).paste_vert (is_kernel_pair.id_of_mono f)
#align category_theory.is_kernel_pair.of_is_iso_of_mono CategoryTheory.IsKernelPair.of_isIso_of_mono
-/

end IsKernelPair

end CategoryTheory


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

import algebra.ring.equiv
import group_theory.group_action.group
import ring_theory.subring.basic

/-!
# Group action on rings

This file defines the typeclass of monoid acting on semirings `mul_semiring_action M R`,
and the corresponding typeclass of invariant subrings.

Note that `algebra` does not satisfy the axioms of `mul_semiring_action`.

## Implementation notes

There is no separate typeclass for group acting on rings, group acting on fields, etc.
They are all grouped under `mul_semiring_action`.

## Tags

group action, invariant subring

-/

universes u v
open_locale big_operators

/-- Typeclass for multiplicative actions by monoids on semirings.

This combines `distrib_mul_action` with `mul_distrib_mul_action`. -/
class mul_semiring_action (M : Type u) (R : Type v) [monoid M] [semiring R]
  extends distrib_mul_action M R :=
(smul_one : ∀ (g : M), (g • 1 : R) = 1)
(smul_mul : ∀ (g : M) (x y : R), g • (x * y) = (g • x) * (g • y))

section semiring

variables (M G : Type u) [monoid M] [group G]
variables (A R S F : Type v) [add_monoid A] [semiring R] [comm_semiring S] [division_ring F]

-- note we could not use `extends` since these typeclasses are made with `old_structure_cmd`
@[priority 100]
instance mul_semiring_action.to_mul_distrib_mul_action [h : mul_semiring_action M R] :
  mul_distrib_mul_action M R :=
{ ..h }

/-- Each element of the monoid defines a semiring homomorphism. -/
@[simps]
def mul_semiring_action.to_ring_hom [mul_semiring_action M R] (x : M) : R →+* R :=
{ .. mul_distrib_mul_action.to_monoid_hom R x,
  .. distrib_mul_action.to_add_monoid_hom R x }

theorem to_ring_hom_injective [mul_semiring_action M R] [has_faithful_smul M R] :
  function.injective (mul_semiring_action.to_ring_hom M R) :=
λ m₁ m₂ h, eq_of_smul_eq_smul $ λ r, ring_hom.ext_iff.1 h r

/-- Each element of the group defines a semiring isomorphism. -/
@[simps]
def mul_semiring_action.to_ring_equiv [mul_semiring_action G R] (x : G) : R ≃+* R :=
{ .. distrib_mul_action.to_add_equiv R x,
  .. mul_semiring_action.to_ring_hom G R x }

section
variables {M G R}

/-- A stronger version of `submonoid.distrib_mul_action`. -/
instance submonoid.mul_semiring_action [mul_semiring_action M R] (H : submonoid M) :
  mul_semiring_action H R :=
{ smul := (•),
  .. H.mul_distrib_mul_action,
  .. H.distrib_mul_action }

/-- A stronger version of `subgroup.distrib_mul_action`. -/
instance subgroup.mul_semiring_action [mul_semiring_action G R] (H : subgroup G) :
  mul_semiring_action H R :=
H.to_submonoid.mul_semiring_action

/-- A stronger version of `subsemiring.distrib_mul_action`. -/
instance subsemiring.mul_semiring_action {R'} [semiring R'] [mul_semiring_action R' R]
  (H : subsemiring R') :
  mul_semiring_action H R :=
H.to_submonoid.mul_semiring_action

/-- A stronger version of `subring.distrib_mul_action`. -/
instance subring.mul_semiring_action {R'} [ring R'] [mul_semiring_action R' R]
  (H : subring R') :
  mul_semiring_action H R :=
H.to_subsemiring.mul_semiring_action

end

section simp_lemmas

variables {M G A R F}

attribute [simp] smul_one smul_mul' smul_zero smul_add

/-- Note that `smul_inv'` refers to the group case, and `smul_inv` has an additional inverse
on `x`. -/
@[simp] lemma smul_inv'' [mul_semiring_action M F] (x : M) (m : F) : x • m⁻¹ = (x • m)⁻¹ :=
(mul_semiring_action.to_ring_hom M F x).map_inv _

end simp_lemmas

end semiring

section ring

variables (M : Type u) [monoid M] {R : Type v} [ring R] [mul_semiring_action M R]
variables (S : subring R)
open mul_action

/-- A typeclass for subrings invariant under a `mul_semiring_action`. -/
class is_invariant_subring : Prop :=
(smul_mem : ∀ (m : M) {x : R}, x ∈ S → m • x ∈ S)

instance is_invariant_subring.to_mul_semiring_action [is_invariant_subring M S] :
  mul_semiring_action M S :=
{ smul := λ m x, ⟨m • x, is_invariant_subring.smul_mem m x.2⟩,
  one_smul := λ s, subtype.eq $ one_smul M s,
  mul_smul := λ m₁ m₂ s, subtype.eq $ mul_smul m₁ m₂ s,
  smul_add := λ m s₁ s₂, subtype.eq $ smul_add m s₁ s₂,
  smul_zero := λ m, subtype.eq $ smul_zero m,
  smul_one := λ m, subtype.eq $ smul_one m,
  smul_mul := λ m s₁ s₂, subtype.eq $ smul_mul' m s₁ s₂ }

end ring