/-
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
-/
import analysis.specific_limits.basic
import data.set.intervals.iso_Ioo
import topology.algebra.order.monotone_continuity
import topology.urysohns_bounded

/-!
# Tietze extension theorem

In this file we prove a few version of the Tietze extension theorem. The theorem says that a
continuous function `s → ℝ` defined on a closed set in a normal topological space `Y` can be
extended to a continuous function on the whole space. Moreover, if all values of the original
function belong to some (finite or infinite, open or closed) interval, then the extension can be
chosen so that it takes values in the same interval. In particular, if the original function is a
bounded function, then there exists a bounded extension of the same norm.

The proof mostly follows <https://ncatlab.org/nlab/show/Tietze+extension+theorem>. We patch a small
gap in the proof for unbounded functions, see
`exists_extension_forall_exists_le_ge_of_closed_embedding`.

## Implementation notes

We first prove the theorems for a closed embedding `e : X → Y` of a topological space into a normal
topological space, then specialize them to the case `X = s : set Y`, `e = coe`.

## Tags

Tietze extension theorem, Urysohn's lemma, normal topological space
-/

variables {X Y : Type*} [topological_space X] [topological_space Y] [normal_space Y]

open metric set filter
open_locale bounded_continuous_function topology
noncomputable theory

namespace bounded_continuous_function

/-- One step in the proof of the Tietze extension theorem. If `e : C(X, Y)` is a closed embedding
of a topological space into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous
function, then there exists a bounded continuous function `g : Y →ᵇ ℝ` of the norm `‖g‖ ≤ ‖f‖ / 3`
such that the distance between `g ∘ e` and `f` is at most `(2 / 3) * ‖f‖`. -/
lemma tietze_extension_step (f : X →ᵇ ℝ) (e : C(X, Y)) (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, ‖g‖ ≤ ‖f‖ / 3 ∧ dist (g.comp_continuous e) f ≤ (2 / 3) * ‖f‖ :=
begin
  have h3 : (0 : ℝ) < 3 := by norm_num1,
  have h23 : 0 < (2 / 3 : ℝ) := by norm_num1,
  -- In the trivial case `f = 0`, we take `g = 0`
  rcases eq_or_ne f 0 with (rfl|hf), { use 0, simp },
  replace hf : 0 < ‖f‖ := norm_pos_iff.2 hf,
  /- Otherwise, the closed sets `e '' (f ⁻¹' (Iic (-‖f‖ / 3)))` and `e '' (f ⁻¹' (Ici (‖f‖ / 3)))`
  are disjoint, hence by Urysohn's lemma there exists a function `g` that is equal to `-‖f‖ / 3`
  on the former set and is equal to `‖f‖ / 3` on the latter set. This function `g` satisfies the
  assertions of the lemma. -/
  have hf3 : -‖f‖ / 3 < ‖f‖ / 3, from (div_lt_div_right h3).2 (left.neg_lt_self hf),
  have hc₁ : is_closed (e '' (f ⁻¹' (Iic (-‖f‖ / 3)))),
    from he.is_closed_map _ (is_closed_Iic.preimage f.continuous),
  have hc₂ : is_closed (e '' (f ⁻¹' (Ici (‖f‖ / 3)))),
    from he.is_closed_map _ (is_closed_Ici.preimage f.continuous),
  have hd : disjoint (e '' (f ⁻¹' (Iic (-‖f‖ / 3)))) (e '' (f ⁻¹' (Ici (‖f‖ / 3)))),
  { refine disjoint_image_of_injective he.inj (disjoint.preimage _ _),
    rwa [Iic_disjoint_Ici, not_le] },
  rcases exists_bounded_mem_Icc_of_closed_of_le hc₁ hc₂ hd hf3.le with ⟨g, hg₁, hg₂, hgf⟩,
  refine ⟨g, _, _⟩,
  { refine (norm_le $ div_nonneg hf.le h3.le).mpr (λ y, _),
    simpa [abs_le, neg_div] using hgf y },
  { refine (dist_le $ mul_nonneg h23.le hf.le).mpr (λ x, _),
    have hfx : -‖f‖ ≤ f x ∧ f x ≤ ‖f‖,
      by simpa only [real.norm_eq_abs, abs_le] using f.norm_coe_le_norm x,
    cases le_total (f x) (-‖f‖ / 3) with hle₁ hle₁,
    { calc |g (e x) - f x| = -‖f‖ / 3 - f x:
        by rw [hg₁ (mem_image_of_mem _ hle₁), abs_of_nonneg (sub_nonneg.2 hle₁)]
      ... ≤ (2 / 3) * ‖f‖ : by linarith },
    { cases le_total (f x) (‖f‖ / 3) with hle₂ hle₂,
      { simp only [neg_div] at *,
        calc dist (g (e x)) (f x) ≤ |g (e x)| + |f x| : dist_le_norm_add_norm _ _
        ... ≤ ‖f‖ / 3 + ‖f‖ / 3 :
          add_le_add (abs_le.2 $ hgf _) (abs_le.2 ⟨hle₁, hle₂⟩)
        ... = (2 / 3) * ‖f‖ : by linarith },
      { calc |g (e x) - f x| = f x - ‖f‖ / 3 :
          by rw [hg₂ (mem_image_of_mem _ hle₂), abs_sub_comm, abs_of_nonneg (sub_nonneg.2 hle₂)]
        ... ≤ (2 / 3) * ‖f‖ : by linarith } } }
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version with a closed
embedding and bundled composition. If `e : C(X, Y)` is a closed embedding of a topological space
into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous function, then there exists
a bounded continuous function `g : Y →ᵇ ℝ` of the same norm such that `g ∘ e = f`. -/
lemma exists_extension_norm_eq_of_closed_embedding' (f : X →ᵇ ℝ) (e : C(X, Y))
  (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, ‖g‖ = ‖f‖ ∧ g.comp_continuous e = f :=
begin
  /- For the proof, we iterate `tietze_extension_step`. Each time we apply it to the difference
  between the previous approximation and `f`. -/
  choose F hF_norm hF_dist using λ f : X →ᵇ ℝ, tietze_extension_step f e he,
  set g : ℕ → Y →ᵇ ℝ := λ n, (λ g, g + F (f - g.comp_continuous e))^[n] 0,
  have g0 : g 0 = 0 := rfl,
  have g_succ : ∀ n, g (n + 1) = g n + F (f - (g n).comp_continuous e),
    from λ n, function.iterate_succ_apply' _ _ _,
  have hgf : ∀ n, dist ((g n).comp_continuous e) f ≤ (2 / 3) ^ n * ‖f‖,
  { intro n, induction n with n ihn,
    { simp [g0] },
    { rw [g_succ n, add_comp_continuous, ← dist_sub_right, add_sub_cancel', pow_succ, mul_assoc],
      refine (hF_dist _).trans (mul_le_mul_of_nonneg_left _ (by norm_num1)),
      rwa ← dist_eq_norm' } },
  have hg_dist : ∀ n, dist (g n) (g (n + 1)) ≤ 1 / 3 * ‖f‖ * (2 / 3) ^ n,
  { intro n,
    calc dist (g n) (g (n + 1)) = ‖F (f - (g n).comp_continuous e)‖ :
      by rw [g_succ, dist_eq_norm', add_sub_cancel']
    ... ≤ ‖f - (g n).comp_continuous e‖ / 3 : hF_norm _
    ... = (1 / 3) * dist ((g n).comp_continuous e) f :
      by rw [dist_eq_norm', one_div, div_eq_inv_mul]
    ... ≤ (1 / 3) * ((2 / 3) ^ n * ‖f‖) :
      mul_le_mul_of_nonneg_left (hgf n) (by norm_num1)
    ... = 1 / 3 * ‖f‖ * (2 / 3) ^ n : by ac_refl },
  have hg_cau : cauchy_seq g, from cauchy_seq_of_le_geometric _ _ (by norm_num1) hg_dist,
  have : tendsto (λ n, (g n).comp_continuous e) at_top (𝓝 $ (lim at_top g).comp_continuous e),
    from ((continuous_comp_continuous e).tendsto _).comp hg_cau.tendsto_lim,
  have hge : (lim at_top g).comp_continuous e = f,
  { refine tendsto_nhds_unique this (tendsto_iff_dist_tendsto_zero.2 _),
    refine squeeze_zero (λ _, dist_nonneg) hgf _,
    rw ← zero_mul (‖f‖),
    refine (tendsto_pow_at_top_nhds_0_of_lt_1 _ _).mul tendsto_const_nhds; norm_num1 },
  refine ⟨lim at_top g, le_antisymm _ _, hge⟩,
  { rw [← dist_zero_left, ← g0],
    refine (dist_le_of_le_geometric_of_tendsto₀ _ _ (by norm_num1)
      hg_dist hg_cau.tendsto_lim).trans_eq _,
    field_simp [show (3 - 2 : ℝ) = 1, by norm_num1] },
  { rw ← hge, exact norm_comp_continuous_le _ _ }
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version with a closed
embedding and unbundled composition. If `e : C(X, Y)` is a closed embedding of a topological space
into a normal topological space and `f : X →ᵇ ℝ` is a bounded continuous function, then there exists
a bounded continuous function `g : Y →ᵇ ℝ` of the same norm such that `g ∘ e = f`. -/
lemma exists_extension_norm_eq_of_closed_embedding (f : X →ᵇ ℝ) {e : X → Y}
  (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, ‖g‖ = ‖f‖ ∧ g ∘ e = f :=
begin
  rcases exists_extension_norm_eq_of_closed_embedding' f ⟨e, he.continuous⟩ he with ⟨g, hg, rfl⟩,
  exact ⟨g, hg, rfl⟩
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
set. If `f` is a bounded continuous real-valued function defined on a closed set in a normal
topological space, then it can be extended to a bounded continuous function of the same norm defined
on the whole space. -/
lemma exists_norm_eq_restrict_eq_of_closed {s : set Y} (f : s →ᵇ ℝ) (hs : is_closed s) :
  ∃ g : Y →ᵇ ℝ, ‖g‖ = ‖f‖ ∧ g.restrict s = f :=
exists_extension_norm_eq_of_closed_embedding' f ((continuous_map.id _).restrict s)
  (closed_embedding_subtype_coe hs)

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding and a bounded continuous function that takes values in a non-trivial closed interval.
See also `exists_extension_forall_mem_of_closed_embedding` for a more general statement that works
for any interval (finite or infinite, open or closed).

If `e : X → Y` is a closed embedding and `f : X →ᵇ ℝ` is a bounded continuous function such that
`f x ∈ [a, b]` for all `x`, where `a ≤ b`, then there exists a bounded continuous function
`g : Y →ᵇ ℝ` such that `g y ∈ [a, b]` for all `y` and `g ∘ e = f`. -/
lemma exists_extension_forall_mem_Icc_of_closed_embedding (f : X →ᵇ ℝ) {a b : ℝ} {e : X → Y}
  (hf : ∀ x, f x ∈ Icc a b) (hle : a ≤ b) (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ Icc a b) ∧ g ∘ e = f :=
begin
  rcases exists_extension_norm_eq_of_closed_embedding (f - const X ((a + b) / 2)) he
    with ⟨g, hgf, hge⟩,
  refine ⟨const Y ((a + b) / 2) + g, λ y, _, _⟩,
  { suffices : ‖f - const X ((a + b) / 2)‖ ≤ (b - a) / 2,
      by simpa [real.Icc_eq_closed_ball, add_mem_closed_ball_iff_norm]
        using (norm_coe_le_norm g y).trans (hgf.trans_le this),
    refine (norm_le $ div_nonneg (sub_nonneg.2 hle) zero_le_two).2 (λ x, _),
    simpa only [real.Icc_eq_closed_ball] using hf x },
  { ext x,
    have : g (e x) = f x - (a + b) / 2 := congr_fun hge x,
    simp [this] }
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a bounded continuous real-valued function on `X`. Then there
exists a bounded continuous function `g : Y →ᵇ ℝ` such that `g ∘ e = f` and each value `g y` belongs
to a closed interval `[f x₁, f x₂]` for some `x₁` and `x₂`.  -/
lemma exists_extension_forall_exists_le_ge_of_closed_embedding [nonempty X] (f : X →ᵇ ℝ) {e : X → Y}
  (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, (∀ y, ∃ x₁ x₂, g y ∈ Icc (f x₁) (f x₂)) ∧ g ∘ e = f :=
begin
  inhabit X,
  -- Put `a = ⨅ x, f x` and `b = ⨆ x, f x`
  obtain ⟨a, ha⟩ : ∃ a, is_glb (range f) a,
    from ⟨_, is_glb_cinfi (real.bounded_iff_bdd_below_bdd_above.1 f.bounded_range).1⟩,
  obtain ⟨b, hb⟩ : ∃ b, is_lub (range f) b,
    from ⟨_, is_lub_csupr (real.bounded_iff_bdd_below_bdd_above.1 f.bounded_range).2⟩,
  -- Then `f x ∈ [a, b]` for all `x`
  have hmem : ∀ x, f x ∈ Icc a b, from λ x, ⟨ha.1 ⟨x, rfl⟩, hb.1 ⟨x, rfl⟩⟩,
  -- Rule out the trivial case `a = b`
  have hle : a ≤ b := (hmem default).1.trans (hmem default).2,
  rcases hle.eq_or_lt with (rfl|hlt),
  { have : ∀ x, f x = a, by simpa using hmem,
    use const Y a, simp [this, function.funext_iff] },
  -- Put `c = (a + b) / 2`. Then `a < c < b` and `c - a = b - c`.
  set c := (a + b) / 2,
  have hac : a < c := left_lt_add_div_two.2 hlt,
  have hcb : c < b := add_div_two_lt_right.2 hlt,
  have hsub : c - a = b - c, by { simp only [c], field_simp, ring },
  /- Due to `exists_extension_forall_mem_Icc_of_closed_embedding`, there exists an extension `g`
  such that `g y ∈ [a, b]` for all `y`. However, if `a` and/or `b` do not belong to the range of
  `f`, then we need to ensure that these points do not belong to the range of `g`. This is done
  in two almost identical steps. First we deal with the case `∀ x, f x ≠ a`. -/
  obtain ⟨g, hg_mem, hgf⟩ : ∃ g : Y →ᵇ ℝ, (∀ y, ∃ x, g y ∈ Icc (f x) b) ∧ g ∘ e = f,
  { rcases exists_extension_forall_mem_Icc_of_closed_embedding f hmem hle he
      with ⟨g, hg_mem, hgf⟩,
    -- If `a ∈ range f`, then we are done.
    rcases em (∃ x, f x = a) with ⟨x, rfl⟩|ha',
    { exact ⟨g, λ y, ⟨x, hg_mem _⟩, hgf⟩ },
    /- Otherwise, `g ⁻¹' {a}` is disjoint with `range e ∪ g ⁻¹' (Ici c)`, hence there exists a
    function `dg : Y → ℝ` such that `dg ∘ e = 0`, `dg y = 0` whenever `c ≤ g y`, `dg y = c - a`
    whenever `g y = a`, and `0 ≤ dg y ≤ c - a` for all `y`.  -/
    have hd : disjoint (range e ∪ g ⁻¹' (Ici c)) (g ⁻¹' {a}),
    { refine disjoint_union_left.2 ⟨_, disjoint.preimage _ _⟩,
      { rw set.disjoint_left,
        rintro _ ⟨x, rfl⟩ (rfl : g (e x) = a),
        exact ha' ⟨x, (congr_fun hgf x).symm⟩ },
      { exact set.disjoint_singleton_right.2 hac.not_le } },
    rcases exists_bounded_mem_Icc_of_closed_of_le
      (he.closed_range.union $ is_closed_Ici.preimage g.continuous)
      (is_closed_singleton.preimage g.continuous) hd (sub_nonneg.2 hac.le)
      with ⟨dg, dg0, dga, dgmem⟩,
    replace hgf : ∀ x, (g + dg) (e x) = f x,
    { intro x, simp [dg0 (or.inl $ mem_range_self _), ← hgf] },
    refine ⟨g + dg, λ y, _, funext hgf⟩,
    { have hay : a < (g + dg) y,
      { rcases (hg_mem y).1.eq_or_lt with rfl|hlt,
        { refine (lt_add_iff_pos_right _).2 _,
          calc 0 < c - g y : sub_pos.2 hac
             ... = dg y    : (dga rfl).symm },
        { exact hlt.trans_le ((le_add_iff_nonneg_right _).2 $ (dgmem y).1) } },
      rcases ha.exists_between hay with ⟨_, ⟨x, rfl⟩, hax, hxy⟩,
      refine ⟨x, hxy.le, _⟩,
      cases le_total c (g y) with hc hc,
      { simp [dg0 (or.inr hc), (hg_mem y).2] },
      { calc g y + dg y ≤ c + (c - a) : add_le_add hc (dgmem _).2
                    ... = b           : by rw [hsub, add_sub_cancel'_right] } } },
  /- Now we deal with the case `∀ x, f x ≠ b`. The proof is the same as in the first case, with
  minor modifications that make it hard to deduplicate code. -/
  choose xl hxl hgb using hg_mem,
  rcases em (∃ x, f x = b) with ⟨x, rfl⟩|hb',
  { exact ⟨g, λ y, ⟨xl y, x, hxl y, hgb y⟩, hgf⟩ },
  have hd : disjoint (range e ∪ g ⁻¹' (Iic c)) (g ⁻¹' {b}),
  { refine disjoint_union_left.2 ⟨_, disjoint.preimage _ _⟩,
    { rw set.disjoint_left,
      rintro _ ⟨x, rfl⟩ (rfl : g (e x) = b),
      exact hb' ⟨x, (congr_fun hgf x).symm⟩ },
    { exact set.disjoint_singleton_right.2 hcb.not_le } },
  rcases exists_bounded_mem_Icc_of_closed_of_le
    (he.closed_range.union $ is_closed_Iic.preimage g.continuous)
    (is_closed_singleton.preimage g.continuous) hd (sub_nonneg.2 hcb.le)
    with ⟨dg, dg0, dgb, dgmem⟩,
  replace hgf : ∀ x, (g - dg) (e x) = f x,
  { intro x, simp [dg0 (or.inl $ mem_range_self _), ← hgf] },
  refine ⟨g - dg, λ y, _, funext hgf⟩,
  { have hyb : (g - dg) y < b,
    { rcases (hgb y).eq_or_lt with rfl|hlt,
      { refine (sub_lt_self_iff _).2 _,
        calc 0 < g y - c : sub_pos.2 hcb
           ... = dg y    : (dgb rfl).symm },
      { exact ((sub_le_self_iff _).2 (dgmem _).1).trans_lt hlt } },
    rcases hb.exists_between hyb with ⟨_, ⟨xu, rfl⟩, hyxu, hxub⟩,
    cases lt_or_le c (g y) with hc hc,
    { rcases em (a ∈ range f) with ⟨x, rfl⟩|ha',
      { refine ⟨x, xu, _, hyxu.le⟩,
        calc f x = c - (b - c) : by rw [← hsub, sub_sub_cancel]
             ... ≤ g y - dg y  : sub_le_sub hc.le (dgmem _).2 },
      { have hay : a < (g - dg) y,
        { calc a = c - (b - c)   : by rw [← hsub, sub_sub_cancel]
             ... < g y - (b - c) : sub_lt_sub_right hc _
             ... ≤ g y - dg y    : sub_le_sub_left (dgmem _).2 _ },
        rcases ha.exists_between hay with ⟨_, ⟨x, rfl⟩, ha, hxy⟩,
        exact ⟨x, xu, hxy.le, hyxu.le⟩ } },
    { refine ⟨xl y, xu, _, hyxu.le⟩,
      simp [dg0 (or.inr hc), hxl] } },
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a bounded continuous real-valued function on `X`. Let `t` be
a nonempty convex set of real numbers (we use `ord_connected` instead of `convex` to automatically
deduce this argument by typeclass search) such that `f x ∈ t` for all `x`. Then there exists
a bounded continuous real-valued function `g : Y →ᵇ ℝ` such that `g y ∈ t` for all `y` and
`g ∘ e = f`. -/
lemma exists_extension_forall_mem_of_closed_embedding (f : X →ᵇ ℝ) {t : set ℝ} {e : X → Y}
  [hs : ord_connected t] (hf : ∀ x, f x ∈ t) (hne : t.nonempty) (he : closed_embedding e) :
  ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ t) ∧ g ∘ e = f :=
begin
  casesI is_empty_or_nonempty X,
  { rcases hne with ⟨c, hc⟩,
    refine ⟨const Y c, λ y, hc, funext $ λ x, is_empty_elim x⟩ },
  rcases exists_extension_forall_exists_le_ge_of_closed_embedding f he with ⟨g, hg, hgf⟩,
  refine ⟨g, λ y, _, hgf⟩,
  rcases hg y with ⟨xl, xu, h⟩,
  exact hs.out (hf _) (hf _) h
end

/-- **Tietze extension theorem** for real-valued bounded continuous maps, a version for a closed
set. Let `s` be a closed set in a normal topological space `Y`. Let `f` be a bounded continuous
real-valued function on `s`. Let `t` be a nonempty convex set of real numbers (we use
`ord_connected` instead of `convex` to automatically deduce this argument by typeclass search) such
that `f x ∈ t` for all `x : s`. Then there exists a bounded continuous real-valued function
`g : Y →ᵇ ℝ` such that `g y ∈ t` for all `y` and `g.restrict s = f`. -/
lemma exists_forall_mem_restrict_eq_of_closed {s : set Y} (f : s →ᵇ ℝ) (hs : is_closed s)
  {t : set ℝ} [ord_connected t] (hf : ∀ x, f x ∈ t) (hne : t.nonempty) :
  ∃ g : Y →ᵇ ℝ, (∀ y, g y ∈ t) ∧ g.restrict s = f :=
begin
  rcases exists_extension_forall_mem_of_closed_embedding f hf hne (closed_embedding_subtype_coe hs)
    with ⟨g, hg, hgf⟩,
  exact ⟨g, hg, fun_like.coe_injective hgf⟩
end

end bounded_continuous_function

namespace continuous_map

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a continuous real-valued function on `X`. Let `t` be a nonempty
convex set of real numbers (we use `ord_connected` instead of `convex` to automatically deduce this
argument by typeclass search) such that `f x ∈ t` for all `x`. Then there exists a continuous
real-valued function `g : C(Y, ℝ)` such that `g y ∈ t` for all `y` and `g ∘ e = f`. -/
lemma exists_extension_forall_mem_of_closed_embedding (f : C(X, ℝ)) {t : set ℝ} {e : X → Y}
  [hs : ord_connected t] (hf : ∀ x, f x ∈ t) (hne : t.nonempty) (he : closed_embedding e) :
  ∃ g : C(Y, ℝ), (∀ y, g y ∈ t) ∧ g ∘ e = f :=
begin
  have h : ℝ ≃o Ioo (-1 : ℝ) 1 := order_iso_Ioo_neg_one_one ℝ,
  set F : X →ᵇ ℝ :=
  { to_fun := coe ∘ (h ∘ f),
    continuous_to_fun := continuous_subtype_coe.comp (h.continuous.comp f.continuous),
    map_bounded' := bounded_range_iff.1 ((bounded_Ioo (-1 : ℝ) 1).mono $
      forall_range_iff.2 $ λ x, (h (f x)).2) },
  set t' : set ℝ := (coe ∘ h) '' t,
  have ht_sub : t' ⊆ Ioo (-1 : ℝ) 1 := image_subset_iff.2 (λ x hx, (h x).2),
  haveI : ord_connected t',
  { constructor, rintros _ ⟨x, hx, rfl⟩ _ ⟨y, hy, rfl⟩ z hz,
    lift z to Ioo (-1 : ℝ) 1 using (Icc_subset_Ioo (h x).2.1 (h y).2.2 hz),
    change z ∈ Icc (h x) (h y) at hz, rw [← h.image_Icc] at hz,
    rcases hz with ⟨z, hz, rfl⟩,
    exact ⟨z, hs.out hx hy hz, rfl⟩ },
  have hFt : ∀ x, F x ∈ t', from λ x, mem_image_of_mem _ (hf x),
  rcases F.exists_extension_forall_mem_of_closed_embedding hFt (hne.image _) he
    with ⟨G, hG, hGF⟩,
  set g : C(Y, ℝ) := ⟨h.symm ∘ cod_restrict G _ (λ y, ht_sub (hG y)), h.symm.continuous.comp $
    G.continuous.subtype_mk _⟩,
  have hgG : ∀ {y a}, g y = a ↔ G y = h a,
    from λ y a, h.to_equiv.symm_apply_eq.trans subtype.ext_iff,
  refine ⟨g, λ y, _, _⟩,
  { rcases hG y with ⟨a, ha, hay⟩,
    convert ha,
    exact hgG.2 hay.symm },
  { ext x, exact hgG.2 (congr_fun hGF _) }
end

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed
embedding. Let `e` be a closed embedding of a nonempty topological space `X` into a normal
topological space `Y`. Let `f` be a continuous real-valued function on `X`. Then there exists a
continuous real-valued function `g : C(Y, ℝ)` such that `g ∘ e = f`. -/
lemma exists_extension_of_closed_embedding (f : C(X, ℝ)) (e : X → Y) (he : closed_embedding e) :
  ∃ g : C(Y, ℝ), g ∘ e = f :=
(exists_extension_forall_mem_of_closed_embedding f (λ x, mem_univ _) univ_nonempty he).imp $
  λ g, and.right

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed set. Let
`s` be a closed set in a normal topological space `Y`. Let `f` be a continuous real-valued function
on `s`. Let `t` be a nonempty convex set of real numbers (we use `ord_connected` instead of `convex`
to automatically deduce this argument by typeclass search) such that `f x ∈ t` for all `x : s`. Then
there exists a continuous real-valued function `g : C(Y, ℝ)` such that `g y ∈ t` for all `y` and
`g.restrict s = f`. -/
lemma exists_restrict_eq_forall_mem_of_closed {s : set Y} (f : C(s, ℝ)) {t : set ℝ}
  [ord_connected t] (ht : ∀ x, f x ∈ t) (hne : t.nonempty) (hs : is_closed s) :
  ∃ g : C(Y, ℝ), (∀ y, g y ∈ t) ∧ g.restrict s = f :=
let ⟨g, hgt, hgf⟩ := exists_extension_forall_mem_of_closed_embedding f ht hne
  (closed_embedding_subtype_coe hs)
in ⟨g, hgt, coe_injective hgf⟩

/-- **Tietze extension theorem** for real-valued continuous maps, a version for a closed set. Let
`s` be a closed set in a normal topological space `Y`. Let `f` be a continuous real-valued function
on `s`. Then there exists a continuous real-valued function `g : C(Y, ℝ)` such that
`g.restrict s = f`. -/
lemma exists_restrict_eq_of_closed {s : set Y} (f : C(s, ℝ)) (hs : is_closed s) :
  ∃ g : C(Y, ℝ), g.restrict s = f :=
let ⟨g, hg, hgf⟩ := exists_restrict_eq_forall_mem_of_closed f (λ _, mem_univ _) univ_nonempty hs
in ⟨g, hgf⟩

end continuous_map


/-
Copyright (c) 2021 Sara Díaz Real. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sara Díaz Real
-/
import data.int.basic
import tactic.linarith
import tactic.ring
import algebra.associated

/-!
# IMO 2001 Q6
Let $a$, $b$, $c$, $d$ be integers with $a > b > c > d > 0$. Suppose that

$$
a*c + b*d = (b*d + a*c) * (b*d + a*c).
$$

Prove that $a*b + c*d$ is not prime.
-/

/-!
The main idea of this formalization is by contradiction,
that is, we are going to suppose that the number
$a*b+c*d$  is prime.

However, firstly we have to prove some auxiliary results that
will be used in the final theorem.
-/

variables {a b c d : ℤ}

/-!
## Intermediate lemmas
-/

lemma equivalent_sums
  (h : a*c + b*d = (a + b - c + d) * (-a + b + c + d)) :
  b^2 + b*d + d^2 = a^2 - a*c + c^2 :=
begin
  have h1 : (a + b - c + d) * (-a + b + c + d) =
           -a^2  + b^2  + a*c - c^2 + b*d + d^2 + a*c + b*d,
    by ring,
  by nlinarith,
end

lemma equivalent_products
  (h : a*c + b*d = (a + b - c + d) * (-a + b + c + d)) :
  (a*c + b*d) * (b^2 + b*d + d^2) = (a*b + c*d) * (a*d + b*c) :=
begin
  have h1 : (a*c + b*d) * (b^2 + b*d + d^2) =
           a*c * (b^2 + b*d + d^2) + b*d * (b^2 + b*d + d^2),
    by ring,
  have h2 : a*c * (b^2 + b*d + d^2) + b*d * (b^2 + b*d + d^2) =
           a*c * (b^2 + b*d + d^2) + b*d * (a^2 - a*c + c^2),
    by rw equivalent_sums h,
  by nlinarith,
end

lemma auxiliary_inequality1
  (hba : b < a)
  (hcb : c < b)
  (hdc : d < c)
  (h : a*c + b*d = (a + b - c + d) * (-a + b + c + d)) :
  a*c + b*d < a*b + c*d :=
by nlinarith

lemma auxiliary_inequality2
  (hba : b < a)
  (hdc : d < c)
  (h : a*c + b*d = (a + b - c + d)*(-a + b + c + d)) :
  a*d + b*c < a*c + b*d :=
by nlinarith

lemma auxiliary_split
  (h : a*c + b*d = (a + b - c + d) * (-a + b + c + d)) :
  a*c + b*d ∣ (a*b+c*d) * (a*d+b*c) :=
by exact ⟨b^2 + b*d +d^2, by nlinarith [equivalent_products h]⟩

/-!
## The question
-/

theorem imo2001_q6
  (hd  : 0 < d)
  (hdc : d < c)
  (hcb : c < b)
  (hba : b < a)
  (h : a*c + b*d = (a + b - c + d)*(-a + b + c + d)) :
  ¬ prime (a*b + c*d) :=
begin
  intro h1,
  have ha : 0 < a, by linarith,
  have hb : 0 < b, by linarith,
  have hc : 0 < c, by linarith,
  have h2 : (a*c + b*d) * (b^2 + b*d + d^2) =
            (a*b + c*d) * (a*d + b*c),
    from equivalent_products h,
  have h3 : a*c + b*d ∣ (a*b + c*d) * (a*d + b*c),
    from auxiliary_split h,
  have h4 : (a*b + c*d ∣ a*c + b*d) ∨ (a*c + b*d  ∣ a*d + b*c),
    from left_dvd_or_dvd_right_of_dvd_prime_mul h1 h3,
  cases h4 with hj hk,
  { have hj1 : a*b + c*d > a*c + b*d,
      from auxiliary_inequality1 hba hcb hdc h,
    have hpj : 0 < a*c + b*d,
      from add_pos (mul_pos ha hc) (mul_pos hb hd),
    have hj2 : a*b + c*d ≤ a*c + b*d,
      from int.le_of_dvd hpj hj,
    have hj3 : ¬ (a*b + c*d ≤ a*c + b*d),
      from not_le.mpr hj1,
    exact hj3 hj2, },
  { have hk1 : a*c + b*d > a*d + b*c,
      from auxiliary_inequality2 hba hdc h,
    have hpk : 0 < a*d + b*c,
      from add_pos (mul_pos ha hd) (mul_pos hb hc),
    have hk2 : a*c + b*d ≤ a*d + b*c,
      from int.le_of_dvd hpk hk,
    have hk3 : ¬ (a*c+b*d ≤  a*d+b*c),
      from not_le.mpr hk1,
    exact hk3 hk2, },
end


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module logic.denumerable
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Lattice
import Mathbin.Data.List.MinMax
import Mathbin.Data.Nat.Order.Lemmas
import Mathbin.Logic.Encodable.Basic

/-!
# Denumerable types

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

This file defines denumerable (countably infinite) types as a typeclass extending `encodable`. This
is used to provide explicit encode/decode functions from and to `ℕ`, with the information that those
functions are inverses of each other.

## Implementation notes

This property already has a name, namely `α ≃ ℕ`, but here we are interested in using it as a
typeclass.
-/

variable {α β : Type _}

#print Denumerable /-
/-- A denumerable type is (constructively) bijective with `ℕ`. Typeclass equivalent of `α ≃ ℕ`. -/
class Denumerable (α : Type _) extends Encodable α where
  decode_inv : ∀ n, ∃ a ∈ decode n, encode a = n
#align denumerable Denumerable
-/

open Nat

namespace Denumerable

section

variable [Denumerable α] [Denumerable β]

open Encodable

#print Denumerable.decode_isSome /-
theorem decode_isSome (α) [Denumerable α] (n : ℕ) : (decode α n).isSome :=
  Option.isSome_iff_exists.2 <| (decode_inv n).imp fun a => Exists.fst
#align denumerable.decode_is_some Denumerable.decode_isSome
-/

#print Denumerable.ofNat /-
/-- Returns the `n`-th element of `α` indexed by the decoding. -/
def ofNat (α) [f : Denumerable α] (n : ℕ) : α :=
  Option.get (decode_isSome α n)
#align denumerable.of_nat Denumerable.ofNat
-/

#print Denumerable.decode_eq_ofNat /-
@[simp]
theorem decode_eq_ofNat (α) [Denumerable α] (n : ℕ) : decode α n = some (ofNat α n) :=
  Option.eq_some_of_isSome _
#align denumerable.decode_eq_of_nat Denumerable.decode_eq_ofNat
-/

#print Denumerable.ofNat_of_decode /-
@[simp]
theorem ofNat_of_decode {n b} (h : decode α n = some b) : ofNat α n = b :=
  Option.some.inj <| (decode_eq_ofNat _ _).symm.trans h
#align denumerable.of_nat_of_decode Denumerable.ofNat_of_decode
-/

#print Denumerable.encode_ofNat /-
@[simp]
theorem encode_ofNat (n) : encode (ofNat α n) = n :=
  by
  let ⟨a, h, e⟩ := decode_inv n
  rwa [of_nat_of_decode h]
#align denumerable.encode_of_nat Denumerable.encode_ofNat
-/

#print Denumerable.ofNat_encode /-
@[simp]
theorem ofNat_encode (a) : ofNat α (encode a) = a :=
  ofNat_of_decode (encodek _)
#align denumerable.of_nat_encode Denumerable.ofNat_encode
-/

#print Denumerable.eqv /-
/-- A denumerable type is equivalent to `ℕ`. -/
def eqv (α) [Denumerable α] : α ≃ ℕ :=
  ⟨encode, ofNat α, ofNat_encode, encode_ofNat⟩
#align denumerable.eqv Denumerable.eqv
-/

-- See Note [lower instance priority]
instance (priority := 100) : Infinite α :=
  Infinite.of_surjective _ (eqv α).Surjective

#print Denumerable.mk' /-
/-- A type equivalent to `ℕ` is denumerable. -/
def mk' {α} (e : α ≃ ℕ) : Denumerable α where
  encode := e
  decode := some ∘ e.symm
  encodek a := congr_arg some (e.symm_apply_apply _)
  decode_inv n := ⟨_, rfl, e.apply_symm_apply _⟩
#align denumerable.mk' Denumerable.mk'
-/

#print Denumerable.ofEquiv /-
/-- Denumerability is conserved by equivalences. This is transitivity of equivalence the denumerable
way. -/
def ofEquiv (α) {β} [Denumerable α] (e : β ≃ α) : Denumerable β :=
  { Encodable.ofEquiv _ e with decode_inv := fun n => by simp }
#align denumerable.of_equiv Denumerable.ofEquiv
-/

/- warning: denumerable.of_equiv_of_nat -> Denumerable.ofEquiv_ofNat is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) {β : Type.{u2}} [_inst_3 : Denumerable.{u1} α] (e : Equiv.{succ u2, succ u1} β α) (n : Nat), Eq.{succ u2} β (Denumerable.ofNat.{u2} β (Denumerable.ofEquiv.{u1, u2} α β _inst_3 e) n) (coeFn.{max 1 (max (succ u1) (succ u2)) (succ u2) (succ u1), max (succ u1) (succ u2)} (Equiv.{succ u1, succ u2} α β) (fun (_x : Equiv.{succ u1, succ u2} α β) => α -> β) (Equiv.hasCoeToFun.{succ u1, succ u2} α β) (Equiv.symm.{succ u2, succ u1} β α e) (Denumerable.ofNat.{u1} α _inst_3 n))
but is expected to have type
  forall (α : Type.{u2}) {β : Type.{u1}} [_inst_3 : Denumerable.{u2} α] (e : Equiv.{succ u1, succ u2} β α) (n : Nat), Eq.{succ u1} β (Denumerable.ofNat.{u1} β (Denumerable.ofEquiv.{u2, u1} α β _inst_3 e) n) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Equiv.{succ u2, succ u1} α β) α (fun (_x : α) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : α) => β) _x) (Equiv.instFunLikeEquiv.{succ u2, succ u1} α β) (Equiv.symm.{succ u1, succ u2} β α e) (Denumerable.ofNat.{u2} α _inst_3 n))
Case conversion may be inaccurate. Consider using '#align denumerable.of_equiv_of_nat Denumerable.ofEquiv_ofNatₓ'. -/
@[simp]
theorem ofEquiv_ofNat (α) {β} [Denumerable α] (e : β ≃ α) (n) :
    @ofNat β (ofEquiv _ e) n = e.symm (ofNat α n) := by
  apply of_nat_of_decode <;> show Option.map _ _ = _ <;> simp
#align denumerable.of_equiv_of_nat Denumerable.ofEquiv_ofNat

#print Denumerable.equiv₂ /-
/-- All denumerable types are equivalent. -/
def equiv₂ (α β) [Denumerable α] [Denumerable β] : α ≃ β :=
  (eqv α).trans (eqv β).symm
#align denumerable.equiv₂ Denumerable.equiv₂
-/

#print Denumerable.nat /-
instance nat : Denumerable ℕ :=
  ⟨fun n => ⟨_, rfl, rfl⟩⟩
#align denumerable.nat Denumerable.nat
-/

#print Denumerable.ofNat_nat /-
@[simp]
theorem ofNat_nat (n) : ofNat ℕ n = n :=
  rfl
#align denumerable.of_nat_nat Denumerable.ofNat_nat
-/

#print Denumerable.option /-
/-- If `α` is denumerable, then so is `option α`. -/
instance option : Denumerable (Option α) :=
  ⟨fun n => by
    cases n
    · refine' ⟨none, _, encode_none⟩
      rw [decode_option_zero, Option.mem_def]
    refine' ⟨some (of_nat α n), _, _⟩
    · rw [decode_option_succ, decode_eq_of_nat, Option.map_some', Option.mem_def]
    rw [encode_some, encode_of_nat]⟩
#align denumerable.option Denumerable.option
-/

#print Denumerable.sum /-
/-- If `α` and `β` are denumerable, then so is their sum. -/
instance sum : Denumerable (Sum α β) :=
  ⟨fun n =>
    by
    suffices ∃ a ∈ @decode_sum α β _ _ n, encode_sum a = bit (bodd n) (div2 n) by simpa [bit_decomp]
    simp [decode_sum] <;> cases bodd n <;> simp [decode_sum, bit, encode_sum]⟩
#align denumerable.sum Denumerable.sum
-/

section Sigma

variable {γ : α → Type _} [∀ a, Denumerable (γ a)]

#print Denumerable.sigma /-
/-- A denumerable collection of denumerable types is denumerable. -/
instance sigma : Denumerable (Sigma γ) :=
  ⟨fun n => by simp [decode_sigma] <;> exact ⟨_, _, ⟨rfl, HEq.rfl⟩, by simp⟩⟩
#align denumerable.sigma Denumerable.sigma
-/

/- warning: denumerable.sigma_of_nat_val -> Denumerable.sigma_ofNat_val is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Denumerable.{u1} α] {γ : α -> Type.{u2}} [_inst_3 : forall (a : α), Denumerable.{u2} (γ a)] (n : Nat), Eq.{succ (max u1 u2)} (Sigma.{u1, u2} α γ) (Denumerable.ofNat.{max u1 u2} (Sigma.{u1, u2} α γ) (Denumerable.sigma.{u1, u2} α _inst_1 γ (fun (a : α) => _inst_3 a)) n) (Sigma.mk.{u1, u2} α γ (Denumerable.ofNat.{u1} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n))) (Denumerable.ofNat.{u2} (γ (Denumerable.ofNat.{u1} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n)))) (_inst_3 (Denumerable.ofNat.{u1} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n)))) (Prod.snd.{0, 0} Nat Nat (Nat.unpair n))))
but is expected to have type
  forall {α : Type.{u2}} [_inst_1 : Denumerable.{u2} α] {γ : α -> Type.{u1}} [_inst_3 : forall (a : α), Denumerable.{u1} (γ a)] (n : Nat), Eq.{max (succ u2) (succ u1)} (Sigma.{u2, u1} α γ) (Denumerable.ofNat.{max u1 u2} (Sigma.{u2, u1} α γ) (Denumerable.sigma.{u2, u1} α _inst_1 γ (fun (a : α) => _inst_3 a)) n) (Sigma.mk.{u2, u1} α γ (Denumerable.ofNat.{u2} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n))) (Denumerable.ofNat.{u1} (γ (Denumerable.ofNat.{u2} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n)))) (_inst_3 (Denumerable.ofNat.{u2} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n)))) (Prod.snd.{0, 0} Nat Nat (Nat.unpair n))))
Case conversion may be inaccurate. Consider using '#align denumerable.sigma_of_nat_val Denumerable.sigma_ofNat_valₓ'. -/
@[simp]
theorem sigma_ofNat_val (n : ℕ) :
    ofNat (Sigma γ) n = ⟨ofNat α (unpair n).1, ofNat (γ _) (unpair n).2⟩ :=
  Option.some.inj <| by rw [← decode_eq_of_nat, decode_sigma_val] <;> simp <;> rfl
#align denumerable.sigma_of_nat_val Denumerable.sigma_ofNat_val

end Sigma

#print Denumerable.prod /-
/-- If `α` and `β` are denumerable, then so is their product. -/
instance prod : Denumerable (α × β) :=
  ofEquiv _ (Equiv.sigmaEquivProd α β).symm
#align denumerable.prod Denumerable.prod
-/

/- warning: denumerable.prod_of_nat_val -> Denumerable.prod_ofNat_val is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Denumerable.{u1} α] [_inst_2 : Denumerable.{u2} β] (n : Nat), Eq.{succ (max u1 u2)} (Prod.{u1, u2} α β) (Denumerable.ofNat.{max u1 u2} (Prod.{u1, u2} α β) (Denumerable.prod.{u1, u2} α β _inst_1 _inst_2) n) (Prod.mk.{u1, u2} α β (Denumerable.ofNat.{u1} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n))) (Denumerable.ofNat.{u2} β _inst_2 (Prod.snd.{0, 0} Nat Nat (Nat.unpair n))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Denumerable.{u2} α] [_inst_2 : Denumerable.{u1} β] (n : Nat), Eq.{max (succ u2) (succ u1)} (Prod.{u2, u1} α β) (Denumerable.ofNat.{max u1 u2} (Prod.{u2, u1} α β) (Denumerable.prod.{u2, u1} α β _inst_1 _inst_2) n) (Prod.mk.{u2, u1} α β (Denumerable.ofNat.{u2} α _inst_1 (Prod.fst.{0, 0} Nat Nat (Nat.unpair n))) (Denumerable.ofNat.{u1} β _inst_2 (Prod.snd.{0, 0} Nat Nat (Nat.unpair n))))
Case conversion may be inaccurate. Consider using '#align denumerable.prod_of_nat_val Denumerable.prod_ofNat_valₓ'. -/
@[simp]
theorem prod_ofNat_val (n : ℕ) : ofNat (α × β) n = (ofNat α (unpair n).1, ofNat β (unpair n).2) :=
  by simp <;> rfl
#align denumerable.prod_of_nat_val Denumerable.prod_ofNat_val

#print Denumerable.prod_nat_ofNat /-
@[simp]
theorem prod_nat_ofNat : ofNat (ℕ × ℕ) = unpair := by funext <;> simp
#align denumerable.prod_nat_of_nat Denumerable.prod_nat_ofNat
-/

#print Denumerable.int /-
instance int : Denumerable ℤ :=
  Denumerable.mk' Equiv.intEquivNat
#align denumerable.int Denumerable.int
-/

#print Denumerable.pnat /-
instance pnat : Denumerable ℕ+ :=
  Denumerable.mk' Equiv.pnatEquivNat
#align denumerable.pnat Denumerable.pnat
-/

#print Denumerable.ulift /-
/-- The lift of a denumerable type is denumerable. -/
instance ulift : Denumerable (ULift α) :=
  ofEquiv _ Equiv.ulift
#align denumerable.ulift Denumerable.ulift
-/

#print Denumerable.plift /-
/-- The lift of a denumerable type is denumerable. -/
instance plift : Denumerable (PLift α) :=
  ofEquiv _ Equiv.plift
#align denumerable.plift Denumerable.plift
-/

#print Denumerable.pair /-
/-- If `α` is denumerable, then `α × α` and `α` are equivalent. -/
def pair : α × α ≃ α :=
  equiv₂ _ _
#align denumerable.pair Denumerable.pair
-/

end

end Denumerable

namespace Nat.Subtype

open Function Encodable

/-! ### Subsets of `ℕ` -/

variable {s : Set ℕ} [Infinite s]

section Classical

open Classical

#print Nat.Subtype.exists_succ /-
theorem exists_succ (x : s) : ∃ n, ↑x + n + 1 ∈ s :=
  by_contradiction fun h =>
    have : ∀ (a : ℕ) (ha : a ∈ s), a < succ x := fun a ha =>
      lt_of_not_ge fun hax => h ⟨a - (x + 1), by rwa [add_right_comm, add_tsub_cancel_of_le hax]⟩
    Fintype.false
      ⟨(((Multiset.range (succ x)).filterₓ (· ∈ s)).pmap
            (fun (y : ℕ) (hy : y ∈ s) => Subtype.mk y hy)
            (by simp [-Multiset.range_succ])).toFinset,
        by simpa [Subtype.ext_iff_val, Multiset.mem_filter, -Multiset.range_succ] ⟩
#align nat.subtype.exists_succ Nat.Subtype.exists_succ
-/

end Classical

variable [DecidablePred (· ∈ s)]

#print Nat.Subtype.succ /-
/-- Returns the next natural in a set, according to the usual ordering of `ℕ`. -/
def succ (x : s) : s :=
  have h : ∃ m, ↑x + m + 1 ∈ s := exists_succ x
  ⟨↑x + Nat.find h + 1, Nat.find_spec h⟩
#align nat.subtype.succ Nat.Subtype.succ
-/

#print Nat.Subtype.succ_le_of_lt /-
theorem succ_le_of_lt {x y : s} (h : y < x) : succ y ≤ x :=
  have hx : ∃ m, ↑y + m + 1 ∈ s := exists_succ _
  let ⟨k, hk⟩ := Nat.exists_eq_add_of_lt h
  have : Nat.find hx ≤ k := Nat.find_min' _ (hk ▸ x.2)
  show (y : ℕ) + Nat.find hx + 1 ≤ x by
    rw [hk] <;> exact add_le_add_right (add_le_add_left this _) _
#align nat.subtype.succ_le_of_lt Nat.Subtype.succ_le_of_lt
-/

#print Nat.Subtype.le_succ_of_forall_lt_le /-
theorem le_succ_of_forall_lt_le {x y : s} (h : ∀ z < x, z ≤ y) : x ≤ succ y :=
  have hx : ∃ m, ↑y + m + 1 ∈ s := exists_succ _
  show ↑x ≤ ↑y + Nat.find hx + 1 from
    le_of_not_gt fun hxy =>
      (h ⟨_, Nat.find_spec hx⟩ hxy).not_lt <|
        calc
          ↑y ≤ ↑y + Nat.find hx := le_add_of_nonneg_right (Nat.zero_le _)
          _ < ↑y + Nat.find hx + 1 := Nat.lt_succ_self _

#align nat.subtype.le_succ_of_forall_lt_le Nat.Subtype.le_succ_of_forall_lt_le
-/

#print Nat.Subtype.lt_succ_self /-
theorem lt_succ_self (x : s) : x < succ x :=
  calc
    (x : ℕ) ≤ x + _ := le_self_add
    _ < succ x := Nat.lt_succ_self (x + _)

#align nat.subtype.lt_succ_self Nat.Subtype.lt_succ_self
-/

#print Nat.Subtype.lt_succ_iff_le /-
theorem lt_succ_iff_le {x y : s} : x < succ y ↔ x ≤ y :=
  ⟨fun h => le_of_not_gt fun h' => not_le_of_gt h (succ_le_of_lt h'), fun h =>
    lt_of_le_of_lt h (lt_succ_self _)⟩
#align nat.subtype.lt_succ_iff_le Nat.Subtype.lt_succ_iff_le
-/

#print Nat.Subtype.ofNat /-
/-- Returns the `n`-th element of a set, according to the usual ordering of `ℕ`. -/
def ofNat (s : Set ℕ) [DecidablePred (· ∈ s)] [Infinite s] : ℕ → s
  | 0 => ⊥
  | n + 1 => succ (of_nat n)
#align nat.subtype.of_nat Nat.Subtype.ofNat
-/

#print Nat.Subtype.ofNat_surjective_aux /-
theorem ofNat_surjective_aux : ∀ {x : ℕ} (hx : x ∈ s), ∃ n, ofNat s n = ⟨x, hx⟩
  | x => fun hx =>
    by
    let t : List s :=
      ((List.range x).filterₓ fun y => y ∈ s).pmap (fun (y : ℕ) (hy : y ∈ s) => ⟨y, hy⟩) (by simp)
    have hmt : ∀ {y : s}, y ∈ t ↔ y < ⟨x, hx⟩ := by
      simp [List.mem_filter, Subtype.ext_iff_val, t] <;> intros <;> rfl
    have wf : ∀ m : s, List.maximum t = m → ↑m < x := fun m hmax => by
      simpa [hmt] using List.maximum_mem hmax
    cases' hmax : List.maximum t with m
    ·
      exact
        ⟨0,
          le_antisymm bot_le
            (le_of_not_gt fun h =>
              List.not_mem_nil (⊥ : s) <| by rw [← List.maximum_eq_none.1 hmax, hmt] <;> exact h)⟩
    cases' of_nat_surjective_aux m.2 with a ha
    exact
      ⟨a + 1,
        le_antisymm (by rw [of_nat] <;> exact succ_le_of_lt (by rw [ha] <;> exact wf _ hmax)) <| by
          rw [of_nat] <;>
            exact
              le_succ_of_forall_lt_le fun z hz => by
                rw [ha] <;> cases m <;> exact List.le_maximum_of_mem (hmt.2 hz) hmax⟩decreasing_by
  tauto
#align nat.subtype.of_nat_surjective_aux Nat.Subtype.ofNat_surjective_aux
-/

#print Nat.Subtype.ofNat_surjective /-
theorem ofNat_surjective : Surjective (ofNat s) := fun ⟨x, hx⟩ => ofNat_surjective_aux hx
#align nat.subtype.of_nat_surjective Nat.Subtype.ofNat_surjective
-/

#print Nat.Subtype.ofNat_range /-
@[simp]
theorem ofNat_range : Set.range (ofNat s) = Set.univ :=
  ofNat_surjective.range_eq
#align nat.subtype.of_nat_range Nat.Subtype.ofNat_range
-/

#print Nat.Subtype.coe_comp_ofNat_range /-
@[simp]
theorem coe_comp_ofNat_range : Set.range (coe ∘ ofNat s : ℕ → ℕ) = s := by
  rw [Set.range_comp coe, of_nat_range, Set.image_univ, Subtype.range_coe]
#align nat.subtype.coe_comp_of_nat_range Nat.Subtype.coe_comp_ofNat_range
-/

private def to_fun_aux (x : s) : ℕ :=
  (List.range x).countp (· ∈ s)
#align nat.subtype.to_fun_aux nat.subtype.to_fun_aux

private theorem to_fun_aux_eq (x : s) : toFunAux x = ((Finset.range x).filterₓ (· ∈ s)).card := by
  rw [to_fun_aux, List.countp_eq_length_filter] <;> rfl
#align nat.subtype.to_fun_aux_eq nat.subtype.to_fun_aux_eq

open Finset

private theorem right_inverse_aux : ∀ n, toFunAux (ofNat s n) = n
  | 0 => by
    rw [to_fun_aux_eq, card_eq_zero, eq_empty_iff_forall_not_mem]
    rintro n hn
    rw [mem_filter, of_nat, mem_range] at hn
    exact bot_le.not_lt (show (⟨n, hn.2⟩ : s) < ⊥ from hn.1)
  | n + 1 => by
    have ih : toFunAux (ofNat s n) = n := right_inverse_aux n
    have h₁ : (ofNat s n : ℕ) ∉ (range (ofNat s n)).filterₓ (· ∈ s) := by simp
    have h₂ :
      (range (succ (ofNat s n))).filterₓ (· ∈ s) =
        insert (ofNat s n) ((range (ofNat s n)).filterₓ (· ∈ s)) :=
      by
      simp only [Finset.ext_iff, mem_insert, mem_range, mem_filter]
      exact fun m =>
        ⟨fun h => by
          simp only [h.2, and_true_iff] <;>
            exact Or.symm (lt_or_eq_of_le ((@lt_succ_iff_le _ _ _ ⟨m, h.2⟩ _).1 h.1)),
          fun h =>
          h.elim (fun h => h.symm ▸ ⟨lt_succ_self _, (of_nat s n).Prop⟩) fun h =>
            ⟨h.1.trans (lt_succ_self _), h.2⟩⟩
    simp only [to_fun_aux_eq, of_nat, range_succ] at ih⊢
    conv =>
      rhs
      rw [← ih, ← card_insert_of_not_mem h₁, ← h₂]
#align nat.subtype.right_inverse_aux nat.subtype.right_inverse_aux

#print Nat.Subtype.denumerable /-
/-- Any infinite set of naturals is denumerable. -/
def denumerable (s : Set ℕ) [DecidablePred (· ∈ s)] [Infinite s] : Denumerable s :=
  Denumerable.ofEquiv ℕ
    { toFun := toFunAux
      invFun := ofNat s
      left_inv := leftInverse_of_surjective_of_rightInverse ofNat_surjective right_inverse_aux
      right_inv := right_inverse_aux }
#align nat.subtype.denumerable Nat.Subtype.denumerable
-/

end Nat.Subtype

namespace Denumerable

open Encodable

#print Denumerable.ofEncodableOfInfinite /-
/-- An infinite encodable type is denumerable. -/
def ofEncodableOfInfinite (α : Type _) [Encodable α] [Infinite α] : Denumerable α :=
  by
  letI := @decidable_range_encode α _ <;>
    letI : Infinite (Set.range (@encode α _)) :=
      Infinite.of_injective _ (Equiv.ofInjective _ encode_injective).Injective
  letI := Nat.Subtype.denumerable (Set.range (@encode α _))
  exact Denumerable.ofEquiv (Set.range (@encode α _)) (equiv_range_encode α)
#align denumerable.of_encodable_of_infinite Denumerable.ofEncodableOfInfinite
-/

end Denumerable

#print nonempty_denumerable /-
/-- See also `nonempty_encodable`, `nonempty_fintype`. -/
theorem nonempty_denumerable (α : Type _) [Countable α] [Infinite α] : Nonempty (Denumerable α) :=
  (nonempty_encodable α).map fun h => Denumerable.ofEncodableOfInfinite _
#align nonempty_denumerable nonempty_denumerable
-/

#print nonempty_equiv_of_countable /-
instance nonempty_equiv_of_countable [Countable α] [Infinite α] [Countable β] [Infinite β] :
    Nonempty (α ≃ β) := by
  cases nonempty_denumerable α
  cases nonempty_denumerable β
  exact ⟨(Denumerable.eqv _).trans (Denumerable.eqv _).symm⟩
#align nonempty_equiv_of_countable nonempty_equiv_of_countable
-/


/-
Copyright (c) 2019 Abhimanyu Pallavi Sudhir. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Abhimanyu Pallavi Sudhir
"Filterproducts" (ultraproducts on general filters), ultraproducts.
-/

import order.filter.basic

universes u v
variables {α : Type u} (β : Type v) (φ : filter α)
local attribute [instance] classical.prop_decidable

namespace filter

/-- Two sequences are bigly equal iff the kernel of their difference is in φ -/
def bigly_equal : setoid (α → β) :=
⟨ λ a b, {n | a n = b n} ∈ φ,
  λ a, by simp only [eq_self_iff_true, (set.univ_def).symm, univ_sets],
  λ a b ab, by simpa only [eq_comm],
  λ a b c ab bc, sets_of_superset φ (inter_sets φ ab bc) (λ n r, eq.trans r.1 r.2)⟩

/-- Ultraproduct, but on a general filter -/
def filterprod := quotient (bigly_equal β φ)
local notation `β*` := filterprod β φ

namespace filter_product

variables {α β φ} include φ

def of_seq : (α → β) → β* := @quotient.mk' (α → β) (bigly_equal β φ)

/-- Equivalence class containing the constant sequence of a term in β -/
def of (b : β): β* := of_seq (function.const α b)

/-- Lift function to filter product -/
def lift (f : β → β) : β* → β* :=
λ x, quotient.lift_on' x (λ a, (of_seq $ λ n, f (a n) : β*)) $
  λ a b h, quotient.sound' $ show _ ∈ _, by filter_upwards [h] λ i hi, congr_arg _ hi

/-- Lift binary operation to filter product -/
def lift₂ (f : β → β → β) : β* → β* → β* :=
λ x y, quotient.lift_on₂' x y (λ a b, (of_seq $ λ n, f (a n) (b n) : β*)) $
  λ a₁ a₂ b₁ b₂ h1 h2, quotient.sound' $ show _ ∈ _,
  by filter_upwards [h1, h2] λ i hi1 hi2, congr (congr_arg _ hi1) hi2

/-- Lift properties to filter product -/
def lift_rel (R : β → Prop) : β* → Prop :=
λ x, quotient.lift_on' x (λ a, {i : α | R (a i)} ∈ φ) $ λ a b h, propext
  ⟨ λ ha, by filter_upwards [h, ha] λ i hi hia, by simpa [hi.symm],
    λ hb, by filter_upwards [h, hb] λ i hi hib, by simpa [hi.symm.symm] ⟩

/-- Lift binary relations to filter product -/
def lift_rel₂ (R : β → β → Prop) : β* → β* → Prop :=
λ x y, quotient.lift_on₂' x y (λ a b, {i : α | R (a i) (b i)} ∈ φ) $
  λ a₁ a₂ b₁ b₂ h₁ h₂, propext
  ⟨ λ ha, by filter_upwards [h₁, h₂, ha] λ i hi1 hi2 hia, by simpa [hi1.symm, hi2.symm],
    λ hb, by filter_upwards [h₁, h₂, hb] λ i hi1 hi2 hib, by simpa [hi1.symm.symm, hi2.symm.symm] ⟩

instance coe_filterprod : has_coe β β* := ⟨ of ⟩

instance [has_add β] : has_add β* := { add := lift₂ has_add.add }

instance [has_zero β] : has_zero β* := { zero := of 0 }

instance [has_neg β] : has_neg β* :=
{ neg := lift has_neg.neg }

instance [add_semigroup β] : add_semigroup β* :=
{ add_assoc := λ x y z, quotient.induction_on₃' x y z $ λ a b c, quotient.sound' $
    show {n | _ + _ + _ = _ + (_ + _)} ∈ _, by simp only [add_assoc, eq_self_iff_true]; exact φ.univ_sets,
  ..filter_product.has_add }

instance [add_monoid β] : add_monoid β* :=
{ zero_add := λ x, quotient.induction_on' x
    (λ a, quotient.sound'(by simp only [zero_add]; apply (setoid.iseqv _).1)),
  add_zero := λ x, quotient.induction_on' x
    (λ a, quotient.sound'(by simp only [add_zero]; apply (setoid.iseqv _).1)),
  ..filter_product.add_semigroup,
  ..filter_product.has_zero }

instance [add_comm_semigroup β] : add_comm_semigroup β* :=
{ add_comm := λ x y, quotient.induction_on₂' x y
    (λ a b, quotient.sound' (by simp only [add_comm]; apply (setoid.iseqv _).1)),
  ..filter_product.add_semigroup }

instance [add_comm_monoid β] : add_comm_monoid β* :=
{ ..filter_product.add_comm_semigroup,
  ..filter_product.add_monoid }

instance [add_group β] : add_group β* :=
{ add_left_neg := λ x, quotient.induction_on' x
    (λ a, quotient.sound' (by simp only [add_left_neg]; apply (setoid.iseqv _).1)),
  ..filter_product.add_monoid,
  ..filter_product.has_neg }

instance [add_comm_group β] : add_comm_group β* :=
{ ..filter_product.add_comm_monoid,
  ..filter_product.add_group }

instance [has_mul β] : has_mul β* :=
{ mul := lift₂ has_mul.mul }

instance [has_one β] : has_one β* := { one := of 1 }

instance [has_inv β] : has_inv β* :=
{ inv := lift has_inv.inv }

instance [semigroup β] : semigroup β* :=
{ mul_assoc := λ x y z, quotient.induction_on₃' x y z $ λ a b c, quotient.sound' $
    show {n | _ * _ * _ = _ * (_ * _)} ∈ _, by simp only [mul_assoc, eq_self_iff_true]; exact φ.2,
  ..filter_product.has_mul }

instance [monoid β] : monoid β* :=
{ one_mul := λ x, quotient.induction_on' x
    (λ a, quotient.sound' (by simp only [one_mul]; apply (setoid.iseqv _).1)),
  mul_one := λ x, quotient.induction_on' x
    (λ a, quotient.sound' (by simp only [mul_one]; apply (setoid.iseqv _).1)),
  ..filter_product.semigroup,
  ..filter_product.has_one }

instance [comm_semigroup β] : comm_semigroup β* :=
{ mul_comm := λ x y, quotient.induction_on₂' x y
    (λ a b, quotient.sound' (by simp only [mul_comm]; apply (setoid.iseqv _).1)),
  ..filter_product.semigroup }

instance [comm_monoid β] : comm_monoid β* :=
{ ..filter_product.comm_semigroup,
  ..filter_product.monoid }

instance [group β] : group β* :=
{ mul_left_inv := λ x, quotient.induction_on' x
    (λ a, quotient.sound' (by simp only [mul_left_inv]; apply (setoid.iseqv _).1)),
  ..filter_product.monoid,
  ..filter_product.has_inv }

instance [comm_group β] : comm_group β* :=
{ ..filter_product.comm_monoid,
  ..filter_product.group }

instance [distrib β] : distrib β* :=
{ left_distrib := λ x y z, quotient.induction_on₃' x y z
    (λ x y z, quotient.sound' (by simp only [left_distrib]; apply (setoid.iseqv _).1)),
  right_distrib := λ x y z, quotient.induction_on₃' x y z
    (λ x y z, quotient.sound' (by simp only [right_distrib]; apply (setoid.iseqv _).1)),
  ..filter_product.has_add,
  ..filter_product.has_mul }

instance [mul_zero_class β] : mul_zero_class β* :=
{ zero_mul := λ x, quotient.induction_on' x
    (λ a, quotient.sound' (by simp only [zero_mul]; apply (setoid.iseqv _).1)),
  mul_zero := λ x, quotient.induction_on' x
    (λ a, quotient.sound' (by simp only [mul_zero]; apply (setoid.iseqv _).1)),
  ..filter_product.has_mul,
  ..filter_product.has_zero }

instance [semiring β] : semiring β* :=
{ ..filter_product.add_comm_monoid,
  ..filter_product.monoid,
  ..filter_product.distrib,
  ..filter_product.mul_zero_class }

instance [ring β] : ring β* :=
{ ..filter_product.add_comm_group,
  ..filter_product.monoid,
  ..filter_product.distrib }

instance [comm_semiring β] : comm_semiring β* :=
{ ..filter_product.semiring,
  ..filter_product.comm_monoid }

instance [comm_ring β] : comm_ring β* :=
{ ..filter_product.ring,
  ..filter_product.comm_semigroup }

instance [zero_ne_one_class β] (NT : φ ≠ ⊥) : zero_ne_one_class β* :=
{ zero_ne_one := λ c, have c' : _ := quotient.exact' c, by
  { change _ ∈ _ at c',
    simp only [set.set_of_false, zero_ne_one, empty_in_sets_eq_bot] at c',
    exact NT c' },
  ..filter_product.has_zero,
  ..filter_product.has_one }

instance [division_ring β] (U : is_ultrafilter φ) : division_ring β* :=
{ mul_inv_cancel := λ x, quotient.induction_on' x $ λ a hx, quotient.sound' $
    have hx1 : _ := (not_imp_not.mpr quotient.eq'.mpr) hx,
    have hx2 : _ := (ultrafilter_iff_compl_mem_iff_not_mem.mp U _).mpr hx1,
    have h : {n : α | ¬a n = 0} ⊆ {n : α | a n * (a n)⁻¹ = 1} :=
      by rw [set.set_of_subset_set_of]; exact λ n, division_ring.mul_inv_cancel,
    mem_sets_of_superset hx2 h,
  inv_mul_cancel := λ x, quotient.induction_on' x $ λ a hx, quotient.sound' $
    have hx1 : _ := (not_imp_not.mpr quotient.eq'.mpr) hx,
    have hx2 : _ := (ultrafilter_iff_compl_mem_iff_not_mem.mp U _).mpr hx1,
    have h : {n : α | ¬a n = 0} ⊆ {n : α | (a n)⁻¹ * a n = 1} :=
      by rw [set.set_of_subset_set_of]; exact λ n, division_ring.inv_mul_cancel,
    mem_sets_of_superset hx2 h,
  ..filter_product.ring,
  ..filter_product.has_inv,
  ..filter_product.zero_ne_one_class U.1 }

instance [field β] (U : is_ultrafilter φ) : field β* :=
{ ..filter_product.comm_ring,
  ..filter_product.division_ring U }

noncomputable instance [discrete_field β] (U : is_ultrafilter φ) : discrete_field β* :=
{ inv_zero := quotient.sound' $ by show _ ∈ _;
    simp only [inv_zero, eq_self_iff_true, (set.univ_def).symm, univ_sets],
  has_decidable_eq := by apply_instance,
  ..filter_product.field U }

instance [has_le β] : has_le β* := { le := lift_rel₂ has_le.le }

instance [preorder β] : preorder β* :=
{ le_refl := λ x, quotient.induction_on' x $ λ a, show _ ∈ _,
    by simp only [le_refl, (set.univ_def).symm, univ_sets],
  le_trans := λ x y z, quotient.induction_on₃' x y z $ λ a b c hab hbc,
    by filter_upwards [hab, hbc] λ i hiab hibc, le_trans hiab hibc,
  ..filter_product.has_le }

instance [partial_order β] : partial_order β* :=
{ le_antisymm := λ x y, quotient.induction_on₂' x y $ λ a b hab hba, quotient.sound' $
    have hI : {n | a n = b n} = _ ∩ _ := set.ext (λ n, le_antisymm_iff),
    show _ ∈ _, by rw hI; exact inter_sets _ hab hba
  ..filter_product.preorder }

instance [linear_order β] (U : is_ultrafilter φ) : linear_order β* :=
{ le_total := λ x y, quotient.induction_on₂' x y $ λ a b,
    have hS : _ ⊆ {i | b i ≤ a i} := λ i, le_of_not_le,
    or.cases_on (mem_or_compl_mem_of_ultrafilter U {i | a i ≤ b i})
      (λ h, or.inl h)
      (λ h, or.inr (sets_of_superset _ h hS))
  ..filter_product.partial_order }

theorem of_inj (NT : φ ≠ ⊥): function.injective (@of _ β φ) :=
begin
  intros r s rs, by_contra N,
  rw [of, of, of_seq, quotient.eq', bigly_equal] at rs,
  simp only [N, set.set_of_false, empty_in_sets_eq_bot] at rs,
  exact NT rs
end

theorem of_seq_fun (f g : α → β) (h : β → β) (H : {n : α | f n = h (g n) } ∈ φ) :
  of_seq f = (lift h) (@of_seq _ _ φ g) := quotient.sound' H

theorem of_seq_fun₂ (f g₁ g₂ : α → β) (h : β → β → β) (H : {n : α | f n = h (g₁ n) (g₂ n) } ∈ φ) :
  of_seq f = (lift₂ h) (@of_seq _ _ φ g₁) (@of_seq _ _ φ g₂) := quotient.sound' H

@[simp] lemma of_seq_zero [has_zero β] (f : α → β) : of_seq 0 = (0 : β*) := rfl

@[simp] lemma of_seq_add [has_add β] (f g : α → β) : of_seq (f + g) = of_seq f + (of_seq g : β*) := rfl

@[simp] lemma of_seq_neg [has_neg β] (f : α → β) : of_seq (-f) = - (of_seq f : β*) := rfl

@[simp] lemma of_seq_one [has_one β] (f : α → β) : of_seq 1 = (1 : β*) := rfl

@[simp] lemma of_seq_mul [has_mul β] (f g : α → β) : of_seq (f * g) = of_seq f * (of_seq g : β*) := rfl

@[simp] lemma of_seq_inv [has_inv β] (f : α → β) : of_seq (f⁻¹) = (of_seq f : β*)⁻¹ := rfl

lemma of_eq_coe (x : β) : of x = (↑x : β*) := rfl

@[simp] lemma of_id (x : β) : of x = (x : β*) := rfl

lemma of_eq (x y : β) (NT : φ ≠ ⊥) : x = y ↔ of x = (of y : β*) := ⟨λ h, by rw h, by apply of_inj NT⟩

lemma of_ne (x y : β) (NT : φ ≠ ⊥) : x ≠ y ↔ of x ≠ (of y : β*) := by show ¬ x = y ↔ of x ≠ of y; rwa [of_eq]

lemma of_eq_zero [has_zero β] (NT : φ ≠ ⊥) (x : β) : x = 0 ↔ of x = (0 : β*) := of_eq _ _ NT

lemma of_ne_zero [has_zero β] (NT : φ ≠ ⊥) (x : β) : x ≠ 0 ↔ of x ≠ (0 : β*) := of_ne _ _ NT

@[simp] lemma of_zero [has_zero β] : of 0 = (0 : β*) := rfl

@[simp] lemma of_add [has_add β] (x y : β) : of (x + y) = of x + (of y : β*) := rfl

@[simp] lemma of_neg [has_neg β] (x : β) : of (- x) = - (of x : β*) := rfl

@[simp] lemma of_one [has_one β] : of 1 = (1 : β*) := rfl

@[simp] lemma of_mul [has_mul β] (x y : β) : of (x * y) = of x * (of y : β*) := rfl

@[simp] lemma of_inv [has_inv β] (x : β) : of (x⁻¹) = (of x : β*)⁻¹ := rfl

lemma of_rel_of_rel (R : β → Prop) (x : β) :
  R x → (lift_rel R) (of x : β*) :=
λ hx, by show {i | R x} ∈ _; simp only [hx]; exact univ_mem_sets

lemma of_rel (R : β → Prop) (x : β) (NT: φ ≠ ⊥) :
  R x ↔ (lift_rel R) (of x : β*) :=
⟨ of_rel_of_rel _ _,
  λ hxy, by change {i | R x} ∈ _ at hxy; by_contra h;
  simp only [h, set.set_of_false, empty_in_sets_eq_bot] at hxy;
  exact NT hxy ⟩

lemma of_rel_of_rel₂ (R : β → β → Prop) (x y : β) :
  R x y → (lift_rel₂ R) (of x) (of y : β*) :=
λ hxy, by show {i | R x y} ∈ _; simp only [hxy]; exact univ_mem_sets

lemma of_rel₂ (R : β → β → Prop) (x y : β) (NT: φ ≠ ⊥) :
  R x y ↔ (lift_rel₂ R) (of x) (of y : β*) :=
⟨ of_rel_of_rel₂ _ _ _,
  λ hxy, by change {i | R x y} ∈ _ at hxy; by_contra h;
  simp only [h, set.set_of_false, empty_in_sets_eq_bot] at hxy;
  exact NT hxy ⟩

lemma of_le_of_le [has_le β] (x y : β) : x ≤ y → of x ≤ (of y : β*) := of_rel_of_rel₂ _ _ _

lemma of_le [has_le β] (x y : β) (NT: φ ≠ ⊥) : x ≤ y ↔ of x ≤ (of y : β*) := of_rel₂ _ _ _ NT

lemma lt_def [K : preorder β] (U : is_ultrafilter φ) (x y : β*) :
  (x < y) ↔ @lift_rel₂ _ _ φ K.lt x y :=
⟨ quotient.induction_on₂' x y $ λ a b ⟨hxy, hyx⟩,
  have hyx' : _ := (ultrafilter_iff_compl_mem_iff_not_mem.mp U _).mpr hyx,
  by filter_upwards [hxy, hyx'] λ i hi1 hi2, lt_iff_le_not_le.mpr ⟨hi1, hi2⟩,
  quotient.induction_on₂' x y $ λ a b hab,
  ⟨ by filter_upwards [hab] λ i, le_of_lt, λ hba,
    have hc : ∀ i : α, a i < b i ∧ b i ≤ a i → false := λ i ⟨h1, h2⟩, not_lt_of_le h2 h1,
    have h0 : ∅ = {i : α | a i < b i} ∩ {i : α | b i ≤ a i} :=
    by simp only [set.inter_def, hc, set.set_of_false, eq_self_iff_true, set.mem_set_of_eq],
    U.1 $ empty_in_sets_eq_bot.mp $ by rw [h0]; exact inter_sets _ hab hba ⟩ ⟩

lemma lt_def' [K : preorder β] (U : is_ultrafilter φ) :
  filter_product.preorder.lt = @lift_rel₂ _ _ φ K.lt :=
by ext x y; exact lt_def U x y

lemma of_lt_of_lt [preorder β] (U : is_ultrafilter φ) (x y : β) :
  x < y → of x < (of y : β*) :=
by rw lt_def U; apply of_rel_of_rel₂

lemma of_lt [preorder β] (x y : β) (U : is_ultrafilter φ) : x < y ↔ of x < (of y : β*) :=
by rw lt_def U; exact of_rel₂ _ _ _ U.1

instance [ordered_comm_group β] (U : is_ultrafilter φ) : ordered_comm_group β* :=
{ add_le_add_left := λ x y hxy z, by revert hxy; exact quotient.induction_on₃' x y z
    (λ a b c hab, by filter_upwards [hab] λ i hi, by simpa),
  add_lt_add_left := λ x y hxy z, by revert hxy; exact quotient.induction_on₃' x y z
    (λ a b c hab, by rw lt_def U at hab ⊢; filter_upwards [hab] λ i hi, add_lt_add_left hi (c i)),
  ..filter_product.partial_order, ..filter_product.add_comm_group }

instance [ordered_ring β] (U : is_ultrafilter φ) : ordered_ring β* :=
{ mul_nonneg := λ x y, quotient.induction_on₂' x y $
    λ a b ha hb, by filter_upwards [ha, hb] λ i, by simp only [set.mem_set_of_eq]; exact mul_nonneg,
  mul_pos := λ x y, quotient.induction_on₂' x y $
    λ a b ha hb, by rw lt_def U at ha hb ⊢; filter_upwards [ha, hb] λ i, mul_pos,
  ..filter_product.ring, ..filter_product.ordered_comm_group U, ..filter_product.zero_ne_one_class U.1 }

instance [linear_ordered_ring β] (U : is_ultrafilter φ) : linear_ordered_ring β* :=
{ zero_lt_one := by rw lt_def U; show {i | (0 : β) < 1} ∈ _; simp only [zero_lt_one, (set.univ_def).symm, univ_sets],
  ..filter_product.ordered_ring U, ..filter_product.linear_order U }

instance [linear_ordered_field β] (U : is_ultrafilter φ) : linear_ordered_field β* :=
{ ..filter_product.linear_ordered_ring U, ..filter_product.field U }

instance [linear_ordered_comm_ring β] (U : is_ultrafilter φ) : linear_ordered_comm_ring β* :=
{ ..filter_product.linear_ordered_ring U, ..filter_product.comm_monoid }

noncomputable instance [decidable_linear_order β] (U : is_ultrafilter φ) : decidable_linear_order β* :=
{ decidable_le := by apply_instance,
  ..filter_product.linear_order U }

noncomputable instance [decidable_linear_ordered_comm_group β] (U : is_ultrafilter φ) : decidable_linear_ordered_comm_group β* :=
{ ..filter_product.ordered_comm_group U, ..filter_product.decidable_linear_order U }

noncomputable instance [decidable_linear_ordered_comm_ring β] (U : is_ultrafilter φ) : decidable_linear_ordered_comm_ring β* :=
{ ..filter_product.linear_ordered_comm_ring U, ..filter_product.decidable_linear_ordered_comm_group U }

noncomputable instance [discrete_linear_ordered_field β] (U : is_ultrafilter φ) : discrete_linear_ordered_field β* :=
{ ..filter_product.linear_ordered_field U, ..filter_product.decidable_linear_ordered_comm_ring U, ..filter_product.discrete_field U }

end filter_product

end filter


/-
Copyright (c) 2021 Kalle Kytölä. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kalle Kytölä
-/
import data.complex.is_R_or_C
import analysis.normed_space.operator_norm

/-!
# Normed spaces over R or C

This file is about results on normed spaces over the fields `ℝ` and `ℂ`.

## Main definitions

None.

## Main theorems

* `continuous_linear_map.op_norm_bound_of_ball_bound`: A bound on the norms of values of a linear
  map in a ball yields a bound on the operator norm.

## Notes

This file exists mainly to avoid importing `is_R_or_C` in the main normed space theory files.
-/

open metric

@[simp] lemma is_R_or_C.norm_coe_norm {𝕜 : Type*} [is_R_or_C 𝕜]
  {E : Type*} [normed_group E] {z : E} : ∥(∥z∥ : 𝕜)∥ = ∥z∥ :=
by { unfold_coes, simp only [norm_algebra_map_eq, ring_hom.to_fun_eq_coe, norm_norm], }

variables {𝕜 : Type*} [is_R_or_C 𝕜] {E : Type*} [normed_group E] [normed_space 𝕜 E]

/-- Lemma to normalize a vector in a normed space `E` over either `ℂ` or `ℝ` to unit length. -/
@[simp] lemma norm_smul_inv_norm {x : E} (hx : x ≠ 0) : ∥(∥x∥⁻¹ : 𝕜) • x∥ = 1 :=
begin
  have : ∥x∥ ≠ 0 := by simp [hx],
  field_simp [norm_smul]
end

/-- Lemma to normalize a vector in a normed space `E` over either `ℂ` or `ℝ` to length `r`. -/
lemma norm_smul_inv_norm' {r : ℝ} (r_nonneg : 0 ≤ r) {x : E} (hx : x ≠ 0) :
  ∥(r * ∥x∥⁻¹ : 𝕜) • x∥ = r :=
begin
  have : ∥x∥ ≠ 0 := by simp [hx],
  field_simp [norm_smul, is_R_or_C.norm_of_real, is_R_or_C.norm_eq_abs, r_nonneg]
end

lemma linear_map.bound_of_sphere_bound
  {r : ℝ} (r_pos : 0 < r) (c : ℝ) (f : E →ₗ[𝕜] 𝕜) (h : ∀ z ∈ sphere (0 : E) r, ∥f z∥ ≤ c) (z : E) :
  ∥f z∥ ≤ c / r * ∥z∥ :=
begin
  by_cases z_zero : z = 0,
  { rw z_zero, simp only [linear_map.map_zero, norm_zero, mul_zero], },
  set z₁ := (r * ∥z∥⁻¹ : 𝕜) • z with hz₁,
  have norm_f_z₁ : ∥f z₁∥ ≤ c,
  { apply h,
    rw mem_sphere_zero_iff_norm,
    exact norm_smul_inv_norm' r_pos.le z_zero },
  have r_ne_zero : (r : 𝕜) ≠ 0 := (algebra_map ℝ 𝕜).map_ne_zero.mpr r_pos.ne.symm,
  have eq : f z = ∥z∥ / r * (f z₁),
  { rw [hz₁, linear_map.map_smul, smul_eq_mul],
    rw [← mul_assoc, ← mul_assoc, div_mul_cancel _ r_ne_zero, mul_inv_cancel, one_mul],
    simp only [z_zero, is_R_or_C.of_real_eq_zero, norm_eq_zero, ne.def, not_false_iff], },
  rw [eq, normed_field.norm_mul, normed_field.norm_div, is_R_or_C.norm_coe_norm,
      is_R_or_C.norm_of_nonneg r_pos.le, div_mul_eq_mul_div, div_mul_eq_mul_div, mul_comm],
  apply div_le_div _ _ r_pos rfl.ge,
  { exact mul_nonneg ((norm_nonneg _).trans norm_f_z₁) (norm_nonneg z), },
  apply mul_le_mul norm_f_z₁ rfl.le (norm_nonneg z) ((norm_nonneg _).trans norm_f_z₁),
end

lemma linear_map.bound_of_ball_bound {r : ℝ} (r_pos : 0 < r) (c : ℝ) (f : E →ₗ[𝕜] 𝕜)
  (h : ∀ z ∈ closed_ball (0 : E) r, ∥f z∥ ≤ c) (z : E) :
  ∥f z∥ ≤ c / r * ∥z∥ :=
f.bound_of_sphere_bound r_pos c (λ z hz, h z hz.le) z

lemma continuous_linear_map.op_norm_bound_of_ball_bound
  {r : ℝ} (r_pos : 0 < r) (c : ℝ) (f : E →L[𝕜] 𝕜) (h : ∀ z ∈ closed_ball (0 : E) r, ∥f z∥ ≤ c) :
  ∥f∥ ≤ c / r :=
begin
  apply continuous_linear_map.op_norm_le_bound,
  { apply div_nonneg _ r_pos.le,
    exact (norm_nonneg _).trans
          (h 0 (by simp only [norm_zero, mem_closed_ball, dist_zero_left, r_pos.le])), },
  apply linear_map.bound_of_ball_bound r_pos,
  exact λ z hz, h z hz,
end


/-
Copyright (c) 2021 Ashwin Iyengar. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Johan Commelin, Ashwin Iyengar, Patrick Massot
-/
import topology.algebra.ring
import topology.algebra.open_subgroup
import data.set.basic
import group_theory.subgroup

/-!
# Nonarchimedean Topology

In this file we set up the theory of nonarchimedean topological groups and rings.

A nonarchimedean group is a topological group whose topology admits a basis of
open neighborhoods of the identity element in the group consisting of open subgroups.
A nonarchimedean ring is a topological ring whose underlying topological (additive)
group is nonarchimedean.

## Definitions

- `nonarchimedean_add_group`: nonarchimedean additive group.
- `nonarchimedean_group`: nonarchimedean multiplicative group.
- `nonarchimedean_ring`: nonarchimedean ring.

-/

/-- An topological additive group is nonarchimedean if every neighborhood of 0
  contains an open subgroup. -/
class nonarchimedean_add_group (G : Type*)
  [add_group G] [topological_space G] extends topological_add_group G : Prop :=
(is_nonarchimedean : ∀ U ∈ nhds (0 : G), ∃ V : open_add_subgroup G, (V : set G) ⊆ U)

/-- A topological group is nonarchimedean if every neighborhood of 1 contains an open subgroup. -/
@[to_additive]
class nonarchimedean_group (G : Type*)
  [group G] [topological_space G] extends topological_group G : Prop :=
(is_nonarchimedean : ∀ U ∈ nhds (1 : G), ∃ V : open_subgroup G, (V : set G) ⊆ U)

/-- An topological ring is nonarchimedean if its underlying topological additive
  group is nonarchimedean. -/
class nonarchimedean_ring (R : Type*)
  [ring R] [topological_space R] extends topological_ring R : Prop :=
(is_nonarchimedean : ∀ U ∈ nhds (0 : R), ∃ V : open_add_subgroup R, (V : set R) ⊆ U)

/-- Every nonarchimedean ring is naturally a nonarchimedean additive group. -/
@[priority 100] -- see Note [lower instance priority]
instance nonarchimedean_ring.to_nonarchimedean_add_group
  (R : Type*) [ring R] [topological_space R] [t: nonarchimedean_ring R] :
nonarchimedean_add_group R := {..t}

namespace nonarchimedean_group

variables {G : Type*} [group G] [topological_space G] [nonarchimedean_group G]
variables {H : Type*} [group H] [topological_space H] [topological_group H]
variables {K : Type*} [group K] [topological_space K] [nonarchimedean_group K]

/-- If a topological group embeds into a nonarchimedean group, then it
  is nonarchimedean. -/
@[to_additive nonarchimedean_add_group.nonarchimedean_of_emb]
lemma nonarchimedean_of_emb (f : G →* H) (emb : open_embedding f) : nonarchimedean_group H :=
{ is_nonarchimedean := λ U hU, have h₁ : (f ⁻¹' U) ∈ nhds (1 : G), from
    by {apply emb.continuous.tendsto, rwa is_group_hom.map_one f},
  let ⟨V, hV⟩ := is_nonarchimedean (f ⁻¹' U) h₁ in
    ⟨{is_open' := emb.is_open_map _ V.is_open, ..subgroup.map f V},
      set.image_subset_iff.2 hV⟩ }

/-- An open neighborhood of the identity in the cartesian product of two nonarchimedean groups
  contains the cartesian product of an open neighborhood in each group. -/
@[to_additive nonarchimedean_add_group.prod_subset]
lemma prod_subset {U} (hU : U ∈ nhds (1 : G × K)) :
  ∃ (V : open_subgroup G) (W : open_subgroup K), (V : set G).prod (W : set K) ⊆ U :=
begin
  erw [nhds_prod_eq, filter.mem_prod_iff] at hU,
  rcases hU with ⟨U₁, hU₁, U₂, hU₂, h⟩,
  cases is_nonarchimedean _ hU₁ with V hV,
  cases is_nonarchimedean _ hU₂ with W hW,
  use V, use W,
  rw set.prod_subset_iff,
  intros x hX y hY,
  exact set.subset.trans (set.prod_mono hV hW) h (set.mem_sep hX hY),
end

/-- An open neighborhood of the identity in the cartesian square of a nonarchimedean group
  contains the cartesian square of an open neighborhood in the group. -/
@[to_additive nonarchimedean_add_group.prod_self_subset]
lemma prod_self_subset {U} (hU : U ∈ nhds (1 : G × G)) :
  ∃ (V : open_subgroup G), (V : set G).prod (V : set G) ⊆ U :=
let ⟨V, W, h⟩ := prod_subset hU in
  ⟨V ⊓ W, by {refine set.subset.trans (set.prod_mono _ _) ‹_›; simp}⟩

/-- The cartesian product of two nonarchimedean groups is nonarchimedean. -/
@[to_additive]
instance : nonarchimedean_group (G × K) :=
{ is_nonarchimedean := λ U hU, let ⟨V, W, h⟩ := prod_subset hU in ⟨V.prod W, ‹_›⟩ }

end nonarchimedean_group

namespace nonarchimedean_ring

open nonarchimedean_ring
open nonarchimedean_add_group

variables {R S : Type*}
variables [ring R] [topological_space R] [nonarchimedean_ring R]
variables [ring S] [topological_space S] [nonarchimedean_ring S]

/-- The cartesian product of two nonarchimedean rings is nonarchimedean. -/
instance : nonarchimedean_ring (R × S) :=
{ is_nonarchimedean := nonarchimedean_add_group.is_nonarchimedean }

/-- Given an open subgroup `U` and an element `r` of a nonarchimedean ring, there is an open
  subgroup `V` such that `r • V` is contained in `U`. -/
lemma left_mul_subset (U : open_add_subgroup R) (r : R) :
  ∃ V : open_add_subgroup R, r • (V : set R) ⊆ U :=
⟨U.comap (add_monoid_hom.mul_left r) (continuous_mul_left r),
  (U : set R).image_preimage_subset _⟩

/-- An open subgroup of a nonarchimedean ring contains the square of another one. -/
lemma mul_subset (U : open_add_subgroup R) :
  ∃ V : open_add_subgroup R, (V : set R) * V ⊆ U :=
let ⟨V, H⟩ := prod_self_subset (mem_nhds_sets (is_open.preimage continuous_mul U.is_open)
  begin
    simpa only [set.mem_preimage, open_add_subgroup.mem_coe, prod.snd_zero, mul_zero]
      using U.zero_mem,
  end) in
begin
  use V,
  rintros v ⟨a, b, ha, hb, hv⟩,
  have hy := H (set.mk_mem_prod ha hb),
  simp only [set.mem_preimage, open_add_subgroup.mem_coe] at hy,
  rwa hv at hy
end

end nonarchimedean_ring


section Chap5_3
variable (p q r : Prop)

syntax "triv_or_1" (colGt tactic) : tactic
macro_rules
  | `(tactic| triv_or_1 $p) => `(tactic| (first | apply Or.inl; $p | apply Or.inr; $p))
syntax "triv_or'" :tactic
macro_rules
  | `(tactic| triv_or') => `(tactic| triv_or_1 assumption)
syntax "triv_or" (colGt tactic) : tactic
macro_rules
  | `(tactic| triv_or $p) => `(tactic| (first | triv_or_1 $p | apply Or.inl <;> triv_or $p | apply Or.inr <;> triv_or $p))

-- commutativity of ∧ and ∨
example : p ∧ q ↔ q ∧ p := by
  apply Iff.intro <;> (intro ⟨_, _⟩; trivial)

example : p ∨ q ↔ q ∨ p := by
  apply Iff.intro <;> intro h <;> cases h <;> (rename_i hp <;> triv_or')

-- associativity of ∧ and ∨
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) := by
  apply Iff.intro
  . intro ⟨⟨_, _⟩, _⟩; trivial
  . intro ⟨_, _, _⟩; trivial

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) := by
  apply Iff.intro <;> intro h <;> cases h <;> rename_i h' <;>
  (first | triv_or (exact h') | cases h' <;> rename_i h'' <;> triv_or (exact h''))

-- distributivity
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) := by
  apply Iff.intro
  . intro ⟨hp, hqr⟩
    cases hqr
    . apply Or.inl; trivial
    . apply Or.inr; trivial
  . intro h <;> cases h <;> rename_i h' <;> match h' with
    | ⟨_, _⟩ => constructor <;> (try assumption) <;> (try triv_or')

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) := by
  apply Iff.intro
  . intro h
    (cases h <;> rename_i h' <;> try cases h') <;> constructor <;> triv_or'
  . intro ⟨hpq, hpr⟩
    cases hpq
    . triv_or'
    . cases hpr
      . triv_or'
      . apply Or.inr; trivial

-- other properties
example : (p → (q → r)) ↔ (p ∧ q → r) := by
  apply Iff.intro
  . intro h
    intro ⟨hp, hq⟩
    exact h hp hq
  . intro h hp hq
    apply h; trivial

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) := by
  apply Iff.intro
  . intro h
    constructor <;> intro <;> apply h <;> triv_or'
  . intro ⟨h1, h2⟩
    intro hpq
    cases hpq
    . apply h1; assumption
    . apply h2; assumption

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q := by
  apply Iff.intro
  . intro h
    constructor <;> (intro hp; apply h; triv_or')
  . intro ⟨_, _⟩ hpq
    cases hpq <;> contradiction

example : ¬p ∨ ¬q → ¬(p ∧ q) := by
  intro h ⟨_, _⟩
  cases h <;> contradiction

example : ¬(p ∧ ¬p) := by
  intro ⟨_, _⟩
  contradiction

example : p ∧ ¬q → ¬(p → q) := by
  intro ⟨hp, _⟩ h
  let _ := h hp
  contradiction

example : ¬p → (p → q) := by
  intro _ _
  contradiction

example : (¬p ∨ q) → (p → q) := by
  intro h hp
  cases h; contradiction; assumption

example : p ∨ False ↔ p := by
  apply Iff.intro
  . intro h
    cases h; assumption; contradiction
  . intro; triv_or'

example : p ∧ False ↔ False := by
  apply Iff.intro
  . intro ⟨_, _⟩; assumption
  . intro; constructor; contradiction; assumption

example : (p → q) → (¬q → ¬p) := by
  intro h hnq hp
  let _ := h hp
  contradiction
end Chap5_3

section Chap5_3'
variable (p q r : Prop)

example : (p → q ∨ r) → ((p → q) ∨ (p → r)) := by
  intro h
  by_cases hp : p
  . cases h hp
    . apply Or.inl; intro; assumption
    . apply Or.inr; intro; assumption
  . apply Or.inl; intro; contradiction

example : ¬(p ∧ q) → ¬p ∨ ¬q := by
  intro h
  by_cases hp : p
  . by_cases hq : q
    . let _ := And.intro hp hq; contradiction
    . triv_or'
  . triv_or'

example : ¬(p → q) → p ∧ ¬q := by
  intro h
  by_cases hp : p
  . by_cases hq : q
    . let _ := λ _: p => hq; contradiction
    . trivial
  . let _: (p → q) := λ _: p => by contradiction
    contradiction

example : (p → q) → (¬p ∨ q) := by
  intro h
  (by_cases p <;> try (rename_i hp; let _ := h hp)) <;> triv_or'

example : (¬q → ¬p) → (p → q) := by
  intro h hp
  by_cases q
  . assumption
  . rename_i hq; let _ := h hq; contradiction

example : p ∨ ¬p := by
  by_cases p <;> triv_or'

example : (((p → q) → p) → p) := by
  intros h
  by_cases p
  . trivial
  . let _ : p → q := λ p => by trivial
    apply h
    trivial

end Chap5_3'

section Chap5_4_1
variable (α : Type) (p q : α → Prop)

example : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) := by
  apply Iff.intro
  . intro h
    constructor <;> (intro h' ; let ⟨_, _⟩ := h h'; trivial)
  . intro h hw
    let _ := h.left hw
    let _ := h.right hw
    trivial

example : (∀ x, p x → q x) → (∀ x, p x) → (∀ x, q x) := by
  intro h h' hw
  let _ := (h hw) (h' hw)
  trivial

example : (∀ x, p x) ∨ (∀ x, q x) → ∀ x, p x ∨ q x := by
  intro h hw
  cases h <;> (rename_i h'; let _ := h' hw; triv_or')
end Chap5_4_1

section Chap5_4_2
variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : α → ((∀ x : α, r) ↔ r) := by
  intro ha
  apply Iff.intro
  . intro h'
    exact h' ha
  . intros; trivial

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r := by
  apply Iff.intro
  . intro h
    by_cases hr : r
    . triv_or'
    . suffices ∀ (x : α), p x by triv_or'
      intro hw
      let _ := h hw
      by_cases h' : (p hw)
      . trivial
      . let _ : ¬(p hw ∨ r) := λ h'' => h''.elim h' hr
        contradiction
  . intro h
    cases h with
    | inl h' => intro px; exact Or.inl (h' px)
    | inr _ => intro; triv_or'

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) := by
  apply Iff.intro
  . intro h hr hx
    exact h hx hr
  . intro h hx hr
    exact h hr hx
end Chap5_4_2

section Chap5_4_3
variable (men : Type) (barber : men)
variable (shaves : men → men → Prop)

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : False := by
  let h' := h barber
  let _ : ¬(shaves barber barber) := by
    intro h''
    let _ := h'.mp h''
    contradiction
  let _ : ¬¬(shaves barber barber) := by
    intro h''
    let _ := h'.mpr h''
    contradiction
  contradiction
end Chap5_4_3

section Chap5_4_4
variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : (∃ x : α, r) → r := by
  intro ⟨_, _⟩
  trivial

example (a : α) : r → (∃ x : α, r) := by
  intro hr
  exact ⟨a, hr⟩

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r := by
  apply Iff.intro
  . intro ⟨px, h⟩
    constructor; exact ⟨px, h.left⟩; exact h.right
  . intro ⟨⟨w, hw⟩, hr⟩
    exact ⟨w, ⟨hw, hr⟩⟩

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) := by
  apply Iff.intro
  . intro ⟨w, hw⟩
    cases hw with
    | inl hp => exact Or.inl (⟨w, hp⟩)
    | inr hq => exact Or.inr (⟨w, hq⟩)
  . intro h
    cases h <;> (rename_i h'; let ⟨w, _⟩ := h'; exists w; triv_or')

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) := by
  apply Iff.intro
  . intro h ⟨w, h'⟩
    let _ := h w
    contradiction
  . intro h w
    by_cases pw: (p w)
    . trivial
    . suffices ∃ x, ¬p x by contradiction
      exact ⟨w, pw⟩

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) := by
  apply Iff.intro
  . intro ⟨w, pw⟩ h
    let _ := h w; contradiction
  . intro h
    by_cases hx : (∃ x, p x)
    . trivial
    . have _ : (∀ x, ¬ p x) := by
           intro w pw; let _: (∃ x, p x):= ⟨w, pw⟩; contradiction
      contradiction

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) := by
  apply Iff.intro
  . intro h w hp
    suffices ∃ x, p x by contradiction
    exact ⟨w, hp⟩
  . intro h ⟨w, hp⟩
    suffices ¬p w by contradiction
    exact h w

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) := by
  apply Iff.intro
  . intro h
    by_cases h' : ∃ x, ¬ p x
    . trivial
    . suffices ∀ x, p x by contradiction
      intro w
      by_cases h'' : p w
      . trivial
      . suffices ∃ x, ¬p x by contradiction
        exact ⟨w, h''⟩
  . intro ⟨w, h⟩ h'
    suffices p w by contradiction
    exact h' w

example : (∀ x, p x → r) ↔ (∃ x, p x) → r := by
  apply Iff.intro
  . intro h ⟨w, hp⟩
    exact h w hp
  . intro h w hp
    apply h
    exact ⟨w, hp⟩

example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r := by
  apply Iff.intro
  . intro ⟨w, h⟩ h'
    exact h (h' w)
  . intro h
    by_cases hp: (∀ (x : α), p x)
    . exact ⟨a, λ _ => h hp⟩
    . have ⟨w, pw⟩: ∃ x, ¬ p x := by
        by_cases h': ∃ x, ¬ p x
        . trivial
        . suffices ∀ x, p x by contradiction
          intro v; by_cases hv: p v;
          . trivial
          . have _: ∃ x, ¬p x := ⟨v, hv⟩
            contradiction
      exists w
      intro; contradiction

example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) := by
  apply Iff.intro
  . intro ⟨w, h⟩ hr
    exact ⟨w, h hr⟩
  . intro h
    by_cases hr: r
    . let ⟨w, hp⟩ := h hr
      exists w; intro; trivial
    . exists a; intro; trivial
end Chap5_4_4

section Chap5_2
example (p q r : Prop) (hp : p)
  : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
    repeat (constructor; repeat (first | apply Or.inl; assumption | apply Or.inr | assumption))
end Chap5_2