/-
Copyright (c) 2022 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import measure_theory.integral.integrable_on

/-!
# Locally integrable functions

A function is called *locally integrable* (`measure_theory.locally_integrable`) if it is integrable
on a neighborhood of every point.

This file contains properties of locally integrable functions and integrability results
on compact sets.

## Main statements

* `continuous.locally_integrable`: A continuous function is locally integrable.

-/

open measure_theory measure_theory.measure set function topological_space
open_locale topology interval

variables {X Y E R : Type*} [measurable_space X] [topological_space X]
variables [measurable_space Y] [topological_space Y]
variables [normed_add_comm_group E] {f : X → E} {μ : measure X}

namespace measure_theory

/-- A function `f : X → E` is locally integrable if it is integrable on a neighborhood of every
point. In particular, it is integrable on all compact sets,
see `locally_integrable.integrable_on_is_compact`. -/
def locally_integrable (f : X → E) (μ : measure X . volume_tac) : Prop :=
∀ (x : X), integrable_at_filter f (𝓝 x) μ

lemma integrable.locally_integrable (hf : integrable f μ) : locally_integrable f μ :=
λ x, hf.integrable_at_filter _

/-- If a function is locally integrable, then it is integrable on an open neighborhood of any
compact set. -/
lemma locally_integrable.integrable_on_nhds_is_compact (hf : locally_integrable f μ) {k : set X}
  (hk : is_compact k) : ∃ u, is_open u ∧ k ⊆ u ∧ integrable_on f u μ :=
begin
  refine is_compact.induction_on hk _ _ _ _,
  { refine ⟨∅, is_open_empty, subset.rfl, integrable_on_empty⟩ },
  { rintros s t hst ⟨u, u_open, tu, hu⟩,
    exact ⟨u, u_open, hst.trans tu, hu⟩ },
  { rintros s t ⟨u, u_open, su, hu⟩ ⟨v, v_open, tv, hv⟩,
    exact ⟨u ∪ v, u_open.union v_open, union_subset_union su tv, hu.union hv⟩ },
  { assume x hx,
    rcases hf x with ⟨u, ux, hu⟩,
    rcases mem_nhds_iff.1 ux with ⟨v, vu, v_open, xv⟩,
    exact ⟨v, nhds_within_le_nhds (v_open.mem_nhds xv), v, v_open, subset.rfl, hu.mono_set vu⟩ }
end

/-- If a function is locally integrable, then it is integrable on any compact set. -/
lemma locally_integrable.integrable_on_is_compact {k : set X} (hf : locally_integrable f μ)
  (hk : is_compact k) : integrable_on f k μ :=
begin
  rcases hf.integrable_on_nhds_is_compact hk with ⟨u, u_open, ku, hu⟩,
  exact hu.mono_set ku
end

lemma locally_integrable.ae_strongly_measurable [second_countable_topology X]
  (hf : locally_integrable f μ) : ae_strongly_measurable f μ :=
begin
  have : ∀ x, ∃ u, is_open u ∧ x ∈ u ∧ integrable_on f u μ,
  { assume x,
    rcases hf x with ⟨s, hs, h's⟩,
    rcases mem_nhds_iff.1 hs with ⟨u, us, u_open, xu⟩,
    exact ⟨u, u_open, xu, h's.mono_set us⟩ },
  choose u u_open xu hu using this,
  obtain ⟨T, T_count, hT⟩ : ∃ (T : set X), T.countable ∧ (⋃ (i : T), u i) = univ,
  { have : (⋃ x, u x) = univ, from eq_univ_of_forall (λ x, mem_Union_of_mem x (xu x)),
    rw ← this,
    simp only [Union_coe_set, subtype.coe_mk],
    exact is_open_Union_countable u u_open },
  haveI : countable T, from countable_coe_iff.mpr T_count,
  rw [← @restrict_univ _ _ μ, ← hT, ae_strongly_measurable_Union_iff],
  exact λ i, (hu i).ae_strongly_measurable,
end

lemma locally_integrable_const [is_locally_finite_measure μ] (c : E) :
  locally_integrable (λ x, c) μ :=
begin
  assume x,
  rcases μ.finite_at_nhds x with ⟨U, hU, h'U⟩,
  refine ⟨U, hU, _⟩,
  simp only [h'U, integrable_on_const, or_true],
end

lemma locally_integrable.indicator (hf : locally_integrable f μ)
  {s : set X} (hs : measurable_set s) : locally_integrable (s.indicator f) μ :=
begin
  assume x,
  rcases hf x with ⟨U, hU, h'U⟩,
  exact ⟨U, hU, h'U.indicator hs⟩,
end

theorem locally_integrable_map_homeomorph [borel_space X] [borel_space Y]
  (e : X ≃ₜ Y) {f : Y → E} {μ : measure X} :
  locally_integrable f (measure.map e μ) ↔ locally_integrable (f ∘ e) μ :=
begin
  refine ⟨λ h x, _, λ h x, _⟩,
  { rcases h (e x) with ⟨U, hU, h'U⟩,
    refine ⟨e ⁻¹' U, e.continuous.continuous_at.preimage_mem_nhds hU, _⟩,
    exact (integrable_on_map_equiv e.to_measurable_equiv).1 h'U },
  { rcases h (e.symm x) with ⟨U, hU, h'U⟩,
    refine ⟨e.symm ⁻¹' U, e.symm.continuous.continuous_at.preimage_mem_nhds hU, _⟩,
    apply (integrable_on_map_equiv e.to_measurable_equiv).2,
    simp only [homeomorph.to_measurable_equiv_coe],
    convert h'U,
    ext x,
    simp only [mem_preimage, homeomorph.symm_apply_apply] }
end

section mul

variables [opens_measurable_space X] [normed_ring R] [second_countable_topology_either X R]
  {A K : set X} {g g' : X → R}

lemma integrable_on.mul_continuous_on_of_subset
  (hg : integrable_on g A μ) (hg' : continuous_on g' K)
  (hA : measurable_set A) (hK : is_compact K) (hAK : A ⊆ K) :
  integrable_on (λ x, g x * g' x) A μ :=
begin
  rcases is_compact.exists_bound_of_continuous_on hK hg' with ⟨C, hC⟩,
  rw [integrable_on, ← mem_ℒp_one_iff_integrable] at hg ⊢,
  have : ∀ᵐ x ∂(μ.restrict A), ‖g x * g' x‖ ≤ C * ‖g x‖,
  { filter_upwards [ae_restrict_mem hA] with x hx,
    refine (norm_mul_le _ _).trans _,
    rw mul_comm,
    apply mul_le_mul_of_nonneg_right (hC x (hAK hx)) (norm_nonneg _), },
  exact mem_ℒp.of_le_mul hg (hg.ae_strongly_measurable.mul $
    (hg'.mono hAK).ae_strongly_measurable hA) this,
end

lemma integrable_on.mul_continuous_on [t2_space X]
  (hg : integrable_on g K μ) (hg' : continuous_on g' K) (hK : is_compact K) :
  integrable_on (λ x, g x * g' x) K μ :=
hg.mul_continuous_on_of_subset hg' hK.measurable_set hK (subset.refl _)

lemma integrable_on.continuous_on_mul_of_subset
  (hg : continuous_on g K) (hg' : integrable_on g' A μ)
  (hK : is_compact K) (hA : measurable_set A) (hAK : A ⊆ K) :
  integrable_on (λ x, g x * g' x) A μ :=
begin
  rcases is_compact.exists_bound_of_continuous_on hK hg with ⟨C, hC⟩,
  rw [integrable_on, ← mem_ℒp_one_iff_integrable] at hg' ⊢,
  have : ∀ᵐ x ∂(μ.restrict A), ‖g x * g' x‖ ≤ C * ‖g' x‖,
  { filter_upwards [ae_restrict_mem hA] with x hx,
    refine (norm_mul_le _ _).trans _,
    apply mul_le_mul_of_nonneg_right (hC x (hAK hx)) (norm_nonneg _), },
  exact mem_ℒp.of_le_mul hg' (((hg.mono hAK).ae_strongly_measurable hA).mul
    hg'.ae_strongly_measurable) this,
end

lemma integrable_on.continuous_on_mul [t2_space X]
  (hg : continuous_on g K) (hg' : integrable_on g' K μ) (hK : is_compact K) :
  integrable_on (λ x, g x * g' x) K μ :=
hg'.continuous_on_mul_of_subset hg hK hK.measurable_set subset.rfl

end mul

end measure_theory
open measure_theory

/-- If a function is integrable at `𝓝[s] x` for each point `x` of a compact set `s`, then it is
integrable on `s`. -/
lemma is_compact.integrable_on_of_nhds_within {K : set X} (hK : is_compact K)
  (hf : ∀ x ∈ K, integrable_at_filter f (𝓝[K] x) μ) : integrable_on f K μ :=
is_compact.induction_on hK integrable_on_empty (λ s t hst ht, ht.mono_set hst)
  (λ s t hs ht, hs.union ht) hf

section borel

variables [opens_measurable_space X] [is_locally_finite_measure μ]
variables {K : set X} {a b : X}

/-- A continuous function `f` is locally integrable with respect to any locally finite measure. -/
lemma continuous.locally_integrable [second_countable_topology_either X E]
  (hf : continuous f) : locally_integrable f μ :=
hf.integrable_at_nhds

variables [metrizable_space X]

/-- A function `f` continuous on a compact set `K` is integrable on this set with respect to any
locally finite measure. -/
lemma continuous_on.integrable_on_compact (hK : is_compact K) (hf : continuous_on f K) :
  integrable_on f K μ :=
begin
  letI := metrizable_space_metric X,
  apply hK.integrable_on_of_nhds_within (λ x hx, _),
  exact hf.integrable_at_nhds_within_of_is_separable hK.measurable_set hK.is_separable hx,
end

lemma continuous_on.integrable_on_Icc [preorder X] [compact_Icc_space X]
  (hf : continuous_on f (Icc a b)) : integrable_on f (Icc a b) μ :=
hf.integrable_on_compact is_compact_Icc

lemma continuous.integrable_on_Icc [preorder X] [compact_Icc_space X] (hf : continuous f) :
  integrable_on f (Icc a b) μ :=
hf.continuous_on.integrable_on_Icc

lemma continuous.integrable_on_Ioc [preorder X] [compact_Icc_space X] (hf : continuous f) :
  integrable_on f (Ioc a b) μ :=
hf.integrable_on_Icc.mono_set Ioc_subset_Icc_self

lemma continuous_on.integrable_on_uIcc [linear_order X] [compact_Icc_space X]
  (hf : continuous_on f [a, b]) : integrable_on f [a, b] μ :=
hf.integrable_on_Icc

lemma continuous.integrable_on_uIcc [linear_order X] [compact_Icc_space X] (hf : continuous f) :
  integrable_on f [a, b] μ :=
hf.integrable_on_Icc

lemma continuous.integrable_on_uIoc [linear_order X] [compact_Icc_space X]
  (hf : continuous f) : integrable_on f (Ι a b) μ :=
hf.integrable_on_Ioc

/-- A continuous function with compact support is integrable on the whole space. -/
lemma continuous.integrable_of_has_compact_support
  (hf : continuous f) (hcf : has_compact_support f) : integrable f μ :=
(integrable_on_iff_integrable_of_support_subset (subset_tsupport f)).mp $
  hf.continuous_on.integrable_on_compact hcf

end borel

open_locale ennreal

section monotone

variables [borel_space X]
  [conditionally_complete_linear_order X] [conditionally_complete_linear_order E]
  [order_topology X] [order_topology E] [second_countable_topology E]
  {s : set X}

lemma monotone_on.integrable_on_of_measure_ne_top
  (hmono : monotone_on f s) {a b : X} (ha : is_least s a) (hb : is_greatest s b) (hs : μ s ≠ ∞)
  (h's : measurable_set s) :
  integrable_on f s μ :=
begin
  borelize E,
  obtain rfl | h := s.eq_empty_or_nonempty,
  { exact integrable_on_empty },
  have hbelow : bdd_below (f '' s) := ⟨f a, λ x ⟨y, hy, hyx⟩, hyx ▸ hmono ha.1 hy (ha.2 hy)⟩,
  have habove : bdd_above (f '' s) := ⟨f b, λ x ⟨y, hy, hyx⟩, hyx ▸ hmono hy hb.1 (hb.2 hy)⟩,
  have : metric.bounded (f '' s) := metric.bounded_of_bdd_above_of_bdd_below habove hbelow,
  rcases bounded_iff_forall_norm_le.mp this with ⟨C, hC⟩,
  have A : integrable_on (λ x, C) s μ, by simp only [hs.lt_top, integrable_on_const, or_true],
  refine integrable.mono' A
    (ae_measurable_restrict_of_monotone_on h's hmono).ae_strongly_measurable
    ((ae_restrict_iff' h's).mpr $ ae_of_all _ $
      λ y hy, hC (f y) (mem_image_of_mem f hy)),
end

lemma monotone_on.integrable_on_is_compact [is_finite_measure_on_compacts μ]
  (hs : is_compact s) (hmono : monotone_on f s) :
  integrable_on f s μ :=
begin
  obtain rfl | h := s.eq_empty_or_nonempty,
  { exact integrable_on_empty },
  { exact hmono.integrable_on_of_measure_ne_top (hs.is_least_Inf h) (hs.is_greatest_Sup h)
    hs.measure_lt_top.ne hs.measurable_set }
end

lemma antitone_on.integrable_on_of_measure_ne_top
  (hanti : antitone_on f s) {a b : X} (ha : is_least s a) (hb : is_greatest s b) (hs : μ s ≠ ∞)
  (h's : measurable_set s) :
  integrable_on f s μ :=
hanti.dual_right.integrable_on_of_measure_ne_top ha hb  hs h's

lemma antione_on.integrable_on_is_compact [is_finite_measure_on_compacts μ]
  (hs : is_compact s) (hanti : antitone_on f s) :
  integrable_on f s μ :=
hanti.dual_right.integrable_on_is_compact hs

lemma monotone.locally_integrable [is_locally_finite_measure μ] (hmono : monotone f) :
  locally_integrable f μ :=
begin
  assume x,
  rcases μ.finite_at_nhds x with ⟨U, hU, h'U⟩,
  obtain ⟨a, b, xab, hab, abU⟩ : ∃ (a b : X), x ∈ Icc a b ∧ Icc a b ∈ 𝓝 x ∧ Icc a b ⊆ U,
    from exists_Icc_mem_subset_of_mem_nhds hU,
  have ab : a ≤ b := xab.1.trans xab.2,
  refine ⟨Icc a b, hab, _⟩,
  exact (hmono.monotone_on _).integrable_on_of_measure_ne_top (is_least_Icc ab)
    (is_greatest_Icc ab) ((measure_mono abU).trans_lt h'U).ne measurable_set_Icc,
end

lemma antitone.locally_integrable [is_locally_finite_measure μ] (hanti : antitone f) :
  locally_integrable f μ :=
hanti.dual_right.locally_integrable

end monotone


import data.list.basic

namespace list

variable {α : Type*}

def shiftl_fill (l : list α) (n : ℕ) (a : α) : list α :=
list.drop n l ++ list.repeat a (min n l.length)

@[simp] lemma shiftl_fill_zero (l : list α) (a : α) : l.shiftl_fill 0 a = l :=
by simp [shiftl_fill]

@[simp] lemma shiftl_fill_nil (n : ℕ) (a : α) : shiftl_fill [] n a = [] :=
by simp [shiftl_fill]

@[simp] lemma shiftl_fill_cons_succ (l : list α) (n : ℕ) (a b : α) :
  shiftl_fill (a::l) (n+1) b = shiftl_fill l n b ++ [b] :=
by simp [shiftl_fill, min_def]; split_ifs; simp [repeat_add]

@[simp] lemma shiftl_fill_concat : Π (l : list α) (n : ℕ) (a : α),
  shiftl_fill (l ++ [a]) n a = shiftl_fill l n a ++ [a]
| [] 0 _ := by simp
| [] (n+1) _ := by simp
| (b::l) 0 _ := by simp
| (b::l) (n+1) a :=
  by rw [cons_append, shiftl_fill_cons_succ, shiftl_fill_concat, shiftl_fill_cons_succ]

@[simp] lemma shiftl_fill_append_repeat : Π (l : list α) (n m : ℕ) (a : α),
  shiftl_fill (l ++ repeat a m) n a = shiftl_fill l n a ++ repeat a m
| _ _ 0 _ := by simp
| l n (m+1) a :=
  by rw [repeat_add, ← append_assoc, repeat_succ, repeat, shiftl_fill_concat,
    shiftl_fill_append_repeat, append_assoc]

lemma shiftl_fill_add : Π (l : list α) (n m : ℕ) (a : α),
  shiftl_fill l (n + m) a = shiftl_fill (shiftl_fill l n a) m a
| []     _ _     _ := by simp
| (b::l) 0 _     _ := by simp
| (b::l) _ 0     _ := by simp
| (b::l) (nat.succ n) m a :=
  by rw [nat.succ_add, shiftl_fill_cons_succ, shiftl_fill_cons_succ, shiftl_fill_add, shiftl_fill_concat]

def shiftr_fill (l : list α) (n : ℕ) (a : α) : list α :=
repeat a (min n l.length) ++ list.take (l.length - n) l

lemma reverse_shiftl_fill (l : list α) (n : ℕ) (a : α) :
  (shiftl_fill l n a).reverse = shiftr_fill l.reverse n a :=
begin
  simp only [shiftr_fill, shiftl_fill, reverse_take, reverse_append, reverse_repeat,
    length_reverse, tsub_le_self],
  by_cases h : n ≤ l.length,
  { rw [nat.sub_sub_self h] },
  { rw [nat.sub_eq_zero_of_le (le_of_not_ge h), nat.sub_zero, min_eq_right (le_of_not_ge h)],
    simp [drop_eq_nil_of_le (le_of_not_ge h)] }
end

lemma reverse_shiftr_fill (l : list α) (n : ℕ) (a : α) :
  (shiftr_fill l n a).reverse = shiftl_fill l.reverse n a :=
begin
  have := reverse_shiftl_fill l.reverse n a,
  rw reverse_reverse at this,
  rw [← this, reverse_reverse]
end

@[simp] lemma shiftr_fill_zero (l : list α) (a : α) : l.shiftr_fill 0 a = l :=
by simp [shiftr_fill]

@[simp] lemma shiftr_fill_nil (n : ℕ) (a : α) : shiftr_fill [] n a = [] :=
by simp [shiftr_fill]

@[simp] lemma shiftr_fill_concat_succ (l : list α) (n : ℕ) (a b : α) :
  shiftr_fill (l++[a]) (n+1) b = b :: shiftr_fill l n b :=
begin
  apply reverse_injective,
  rw [reverse_shiftr_fill, reverse_append, reverse_singleton, singleton_append,
    shiftl_fill_cons_succ, reverse_cons, reverse_shiftr_fill]
end

end list


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import algebra.group_power.lemmas

/-!
# Powers of elements of groups with an adjoined zero element

In this file we define integer power functions for groups with an adjoined zero element.
This generalises the integer power function on a division ring.
-/

section zero
variables {M : Type*} [monoid_with_zero M]

@[simp] lemma zero_pow' : ∀ n : ℕ, n ≠ 0 → (0 : M) ^ n = 0
| 0     h := absurd rfl h
| (k+1) h := by { rw [pow_succ], exact zero_mul _ }

lemma ne_zero_pow {a : M} {n : ℕ} (hn : n ≠ 0) : a ^ n ≠ 0 → a ≠ 0 :=
by { contrapose!, rintro rfl, exact zero_pow' n hn }

@[simp] lemma zero_pow_eq_zero [nontrivial M] {n : ℕ} : (0 : M) ^ n = 0 ↔ 0 < n :=
begin
  split; intro h,
  { rw [pos_iff_ne_zero], rintro rfl, simpa using h },
  { exact zero_pow' n h.ne.symm }
end

lemma ring.inverse_pow (r : M) : ∀ (n : ℕ), ring.inverse r ^ n = ring.inverse (r ^ n)
| 0 := by rw [pow_zero, pow_zero, ring.inverse_one]
| (n + 1) := by rw [pow_succ, pow_succ', ring.mul_inverse_rev' ((commute.refl r).pow_left n),
                    ring.inverse_pow]

end zero

section group_with_zero
variables {G₀ : Type*} [group_with_zero G₀] {a : G₀} {m n : ℕ}

section nat_pow

@[simp, field_simps] theorem inv_pow₀ (a : G₀) (n : ℕ) : (a⁻¹) ^ n = (a ^ n)⁻¹ :=
begin
  induction n with n ih,
  { rw [pow_zero, pow_zero], exact inv_one.symm },
  { rw [pow_succ', pow_succ, ih, mul_inv_rev₀] }
end

theorem pow_sub₀ (a : G₀) {m n : ℕ} (ha : a ≠ 0) (h : n ≤ m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
have h1 : m - n + n = m, from tsub_add_cancel_of_le h,
have h2 : a ^ (m - n) * a ^ n = a ^ m, by rw [←pow_add, h1],
by simpa only [div_eq_mul_inv] using eq_div_of_mul_eq (pow_ne_zero _ ha) h2

lemma pow_sub_of_lt (a : G₀) {m n : ℕ} (h : n < m) : a ^ (m - n) = a ^ m * (a ^ n)⁻¹ :=
begin
  obtain rfl | ha := eq_or_ne a 0,
  { rw [zero_pow (tsub_pos_of_lt h), zero_pow (n.zero_le.trans_lt h), zero_mul] },
  { exact pow_sub₀ _ ha h.le }
end

theorem pow_inv_comm₀ (a : G₀) (m n : ℕ) : (a⁻¹) ^ m * a ^ n = a ^ n * (a⁻¹) ^ m :=
(commute.refl a).inv_left₀.pow_pow m n

lemma inv_pow_sub₀ (ha : a ≠ 0) (h : n ≤ m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub₀ _ (inv_ne_zero ha) h, inv_pow₀, inv_pow₀, inv_inv₀]

lemma inv_pow_sub_of_lt (a : G₀) (h : n < m) : a⁻¹ ^ (m - n) = (a ^ m)⁻¹ * a ^ n :=
by rw [pow_sub_of_lt a⁻¹ h, inv_pow₀, inv_pow₀, inv_inv₀]

end nat_pow

end group_with_zero

section zpow
open int
variables {G₀ : Type*} [group_with_zero G₀]

local attribute [ematch] le_of_lt

@[simp] theorem one_zpow₀ : ∀ (n : ℤ), (1 : G₀) ^ n = 1
| (n : ℕ) := by rw [zpow_coe_nat, one_pow]
| -[1+ n] := by rw [zpow_neg_succ_of_nat, one_pow, inv_one]

lemma zero_zpow : ∀ z : ℤ, z ≠ 0 → (0 : G₀) ^ z = 0
| (n : ℕ) h := by { rw [zpow_coe_nat, zero_pow'], simpa using h }
| -[1+n]  h := by simp

lemma zero_zpow_eq (n : ℤ) : (0 : G₀) ^ n = if n = 0 then 1 else 0 :=
begin
  split_ifs with h,
  { rw [h, zpow_zero] },
  { rw [zero_zpow _ h] }
end

@[simp] theorem zpow_neg₀ (a : G₀) : ∀ (n : ℤ), a ^ -n = (a ^ n)⁻¹
| (n+1:ℕ) := div_inv_monoid.zpow_neg' _ _
| 0       := by { change a ^ (0 : ℤ) = (a ^ (0 : ℤ))⁻¹, simp }
| -[1+ n] := by { rw [zpow_neg_succ_of_nat, inv_inv₀, ← zpow_coe_nat], refl }

lemma mul_zpow_neg_one₀ (a b : G₀) : (a * b) ^ (-1 : ℤ) = b ^ (-1 : ℤ) * a ^ (-1 : ℤ) :=
by simp only [mul_inv_rev₀, zpow_one, zpow_neg₀]

lemma zpow_neg_one₀ (x : G₀) : x ^ (-1 : ℤ) = x⁻¹ :=
by { rw [← congr_arg has_inv.inv (pow_one x), zpow_neg₀, ← zpow_coe_nat], refl }

theorem inv_zpow₀ (a : G₀) : ∀n:ℤ, a⁻¹ ^ n = (a ^ n)⁻¹
| (n : ℕ) := by rw [zpow_coe_nat, zpow_coe_nat, inv_pow₀]
| -[1+ n] := by rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat, inv_pow₀]

lemma zpow_add_one₀ {a : G₀} (ha : a ≠ 0) : ∀ n : ℤ, a ^ (n + 1) = a ^ n * a
| (n : ℕ)    := by simp [← int.coe_nat_succ, pow_succ']
| -[1+0]     := by simp [int.neg_succ_of_nat_eq, ha]
| -[1+(n+1)] := by rw [int.neg_succ_of_nat_eq, zpow_neg₀, neg_add, neg_add_cancel_right, zpow_neg₀,
  ← int.coe_nat_succ, zpow_coe_nat, zpow_coe_nat, pow_succ _ (n + 1), mul_inv_rev₀, mul_assoc,
  inv_mul_cancel ha, mul_one]

lemma zpow_sub_one₀ {a : G₀} (ha : a ≠ 0) (n : ℤ) : a ^ (n - 1) = a ^ n * a⁻¹ :=
calc a ^ (n - 1) = a ^ (n - 1) * a * a⁻¹ : by rw [mul_assoc, mul_inv_cancel ha, mul_one]
             ... = a^n * a⁻¹             : by rw [← zpow_add_one₀ ha, sub_add_cancel]

lemma zpow_add₀ {a : G₀} (ha : a ≠ 0) (m n : ℤ) : a ^ (m + n) = a ^ m * a ^ n :=
begin
  induction n using int.induction_on with n ihn n ihn,
  case hz : { simp },
  { simp only [← add_assoc, zpow_add_one₀ ha, ihn, mul_assoc] },
  { rw [zpow_sub_one₀ ha, ← mul_assoc, ← ihn, ← zpow_sub_one₀ ha, add_sub_assoc] }
end

lemma zpow_add' {a : G₀} {m n : ℤ} (h : a ≠ 0 ∨ m + n ≠ 0 ∨ m = 0 ∧ n = 0) :
  a ^ (m + n) = a ^ m * a ^ n :=
begin
  by_cases hm : m = 0, { simp [hm] },
  by_cases hn : n = 0, { simp [hn] },
  by_cases ha : a = 0,
  { subst a,
    simp only [false_or, eq_self_iff_true, not_true, ne.def, hm, hn, false_and, or_false] at h,
    rw [zero_zpow _ h, zero_zpow _ hm, zero_mul] },
  { exact zpow_add₀ ha m n }
end

theorem zpow_one_add₀ {a : G₀} (h : a ≠ 0) (i : ℤ) : a ^ (1 + i) = a * a ^ i :=
by rw [zpow_add₀ h, zpow_one]

theorem semiconj_by.zpow_right₀ {a x y : G₀} (h : semiconj_by a x y) :
  ∀ m : ℤ, semiconj_by a (x^m) (y^m)
| (n : ℕ) := by simp [h.pow_right n]
| -[1+n]  := by simp [(h.pow_right (n + 1)).inv_right₀]

theorem commute.zpow_right₀ {a b : G₀} (h : commute a b) : ∀ m : ℤ, commute a (b^m) :=
h.zpow_right₀

theorem commute.zpow_left₀ {a b : G₀} (h : commute a b) (m : ℤ) : commute (a^m) b :=
(h.symm.zpow_right₀ m).symm

theorem commute.zpow_zpow₀ {a b : G₀} (h : commute a b) (m n : ℤ) : commute (a^m) (b^n) :=
(h.zpow_left₀ m).zpow_right₀ n

theorem commute.zpow_self₀ (a : G₀) (n : ℤ) : commute (a^n) a := (commute.refl a).zpow_left₀ n

theorem commute.self_zpow₀ (a : G₀) (n : ℤ) : commute a (a^n) := (commute.refl a).zpow_right₀ n

theorem commute.zpow_zpow_self₀ (a : G₀) (m n : ℤ) : commute (a^m) (a^n) :=
(commute.refl a).zpow_zpow₀ m n

theorem zpow_bit0₀ (a : G₀) (n : ℤ) : a ^ bit0 n = a ^ n * a ^ n :=
begin
  apply zpow_add', right,
  by_cases hn : n = 0,
  { simp [hn] },
  { simp [← two_mul, hn, two_ne_zero] }
end

theorem zpow_bit1₀ (a : G₀) (n : ℤ) : a ^ bit1 n = a ^ n * a ^ n * a :=
begin
  rw [← zpow_bit0₀, bit1, zpow_add', zpow_one],
  right, left,
  apply bit1_ne_zero
end

theorem zpow_mul₀ (a : G₀) : ∀ m n : ℤ, a ^ (m * n) = (a ^ m) ^ n
| (m : ℕ) (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat, ← pow_mul, ← zpow_coe_nat], refl }
| (m : ℕ) -[1+ n] := by { rw [zpow_coe_nat, zpow_neg_succ_of_nat, ← pow_mul, coe_nat_mul_neg_succ,
    zpow_neg₀, inv_inj₀, ← zpow_coe_nat], refl }
| -[1+ m] (n : ℕ) := by { rw [zpow_coe_nat, zpow_neg_succ_of_nat, ← inv_pow₀, ← pow_mul,
    neg_succ_mul_coe_nat, zpow_neg₀, inv_pow₀, inv_inj₀, ← zpow_coe_nat], refl }
| -[1+ m] -[1+ n] := by { rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat, neg_succ_mul_neg_succ,
    inv_pow₀, inv_inv₀, ← pow_mul, ← zpow_coe_nat], refl }

theorem zpow_mul₀' (a : G₀) (m n : ℤ) : a ^ (m * n) = (a ^ n) ^ m :=
by rw [mul_comm, zpow_mul₀]

@[simp, norm_cast] lemma units.coe_zpow₀ (u : G₀ˣ) :
  ∀ (n : ℤ), ((u ^ n : G₀ˣ) : G₀) = u ^ n
| (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat], exact u.coe_pow n }
| -[1+k] := by rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat, units.coe_inv', u.coe_pow]

lemma zpow_ne_zero_of_ne_zero {a : G₀} (ha : a ≠ 0) : ∀ (z : ℤ), a ^ z ≠ 0
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_ne_zero _ ha }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_ne_zero (pow_ne_zero _ ha) }

lemma zpow_sub₀ {a : G₀} (ha : a ≠ 0) (z1 z2 : ℤ) : a ^ (z1 - z2) = a ^ z1 / a ^ z2 :=
by rw [sub_eq_add_neg, zpow_add₀ ha, zpow_neg₀, div_eq_mul_inv]

lemma commute.mul_zpow₀ {a b : G₀} (h : commute a b) :
  ∀ (i : ℤ), (a * b) ^ i = (a ^ i) * (b ^ i)
| (n : ℕ) := by simp [h.mul_pow n]
| -[1+n]  := by simp [h.mul_pow, (h.pow_pow _ _).eq, mul_inv_rev₀]

theorem zpow_bit0' (a : G₀) (n : ℤ) : a ^ bit0 n = (a * a) ^ n :=
(zpow_bit0₀ a n).trans ((commute.refl a).mul_zpow₀ n).symm

theorem zpow_bit1' (a : G₀) (n : ℤ) : a ^ bit1 n = (a * a) ^ n * a :=
by rw [zpow_bit1₀, (commute.refl a).mul_zpow₀]

lemma zpow_eq_zero {x : G₀} {n : ℤ} (h : x ^ n = 0) : x = 0 :=
classical.by_contradiction $ λ hx, zpow_ne_zero_of_ne_zero hx n h

lemma zpow_ne_zero {x : G₀} (n : ℤ) : x ≠ 0 → x ^ n ≠ 0 :=
mt zpow_eq_zero

theorem zpow_neg_mul_zpow_self (n : ℤ) {x : G₀} (h : x ≠ 0) :
  x ^ (-n) * x ^ n = 1 :=
begin
  rw [zpow_neg₀],
  exact inv_mul_cancel (zpow_ne_zero n h)
end

theorem one_div_pow {a : G₀} (n : ℕ) :
  (1 / a) ^ n = 1 / a ^ n :=
by simp only [one_div, inv_pow₀]

theorem one_div_zpow {a : G₀} (n : ℤ) :
  (1 / a) ^ n = 1 / a ^ n :=
by simp only [one_div, inv_zpow₀]

@[simp] lemma inv_zpow' {a : G₀} (n : ℤ) :
  (a ⁻¹) ^ n = a ^ (-n) :=
by { rw [inv_zpow₀, ← zpow_neg_one, ← zpow_mul₀], simp }

end zpow

section
variables {G₀ : Type*} [comm_group_with_zero G₀]

@[simp] theorem div_pow (a b : G₀) (n : ℕ) :
  (a / b) ^ n = a ^ n / b ^ n :=
by simp only [div_eq_mul_inv, mul_pow, inv_pow₀]

lemma mul_zpow₀ (a b : G₀) (m : ℤ) : (a * b) ^ m = (a ^ m) * (b ^ m) :=
(commute.all a b).mul_zpow₀ m

@[simp] theorem div_zpow₀ (a : G₀) {b : G₀} (n : ℤ) :
  (a / b) ^ n = a ^ n / b ^ n :=
by simp only [div_eq_mul_inv, mul_zpow₀, inv_zpow₀]

lemma div_sq_cancel (a b : G₀) : a ^ 2 * b / a = a * b :=
begin
  by_cases ha : a = 0,
  { simp [ha] },
  rw [sq, mul_assoc, mul_div_cancel_left _ ha]
end

/-- The `n`-th power map (`n` an integer) on a commutative group with zero, considered as a group
homomorphism. -/
def zpow_group_hom₀ (n : ℤ) : G₀ →* G₀ :=
{ to_fun := (^ n),
  map_one' := one_zpow₀ n,
  map_mul' := λ a b, mul_zpow₀ a b n }

end

/-- If a monoid homomorphism `f` between two `group_with_zero`s maps `0` to `0`, then it maps `x^n`,
`n : ℤ`, to `(f x)^n`. -/
lemma monoid_with_zero_hom.map_zpow {G₀ G₀' : Type*} [group_with_zero G₀] [group_with_zero G₀']
  (f : G₀ →*₀ G₀') (x : G₀) :
  ∀ n : ℤ, f (x ^ n) = f x ^ n
| (n : ℕ) := by { rw [zpow_coe_nat, zpow_coe_nat], exact f.to_monoid_hom.map_pow x n }
| -[1+n] := begin
    rw [zpow_neg_succ_of_nat, zpow_neg_succ_of_nat],
    exact ((f.map_inv _).trans $ congr_arg _ $ f.to_monoid_hom.map_pow x _)
  end

-- I haven't been able to find a better home for this:
-- it belongs with other lemmas on `linear_ordered_field`, but
-- we need to wait until `zpow` has been defined in this file.
section
variables {R : Type*} [linear_ordered_field R] {a : R}

lemma pow_minus_two_nonneg : 0 ≤ a^(-2 : ℤ) :=
begin
  simp only [inv_nonneg, zpow_neg₀],
  change 0 ≤ a ^ ((2 : ℕ) : ℤ),
  rw zpow_coe_nat,
  apply sq_nonneg,
end

end


/-
Copyright (c) 2019 Lucas Allen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lucas Allen, Scott Morrison
-/

import algebra.big_operators.basic
import data.finsupp.basic
import tactic.converter.apply_congr
import tactic.interactive

example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs {
    -- If we just call `congr` here, in the second goal we're helpless,
    -- because we are only given the opportunity to rewrite `f`.

    -- However `apply_congr` uses the appropriate `@[congr]` lemma,
    -- so we get to rewrite `f x`, in the presence of the crucial `H : x ∈ S` hypothesis.
    apply_congr,
    skip,
    simp [h, H], }
end

-- Again, with some `guard` statements.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs {
    apply_congr finset.sum_congr,
    -- (See the note about get_goals/set_goals inside apply_congr)
    (do ng ← tactic.num_goals, guard $ ng = 2),
    guard_target S,
    skip,
    guard_target f x,
    simp [h, H] }
end

-- Verify we can `rw` as well as `simp`.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
by conv_lhs { apply_congr, skip, rw h x H, }

-- Check that the appropriate `@[congr]` lemma is automatically selected.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.prod S f = finset.prod S g :=
by conv_lhs { apply_congr, skip, simp [h, H], }

example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.fold (+) 0 f S = finset.fold (+) 0 g S :=
begin
  -- This time, the automatically selected congruence lemma is "too good"!
  -- `finset.sum_congr` matches, and so the `conv` block actually
  -- rewrites the left hand side into a `finset.sum`.
  conv_lhs { apply_congr, skip, simp [h, H], },
  -- So we need a `refl` to identify that we're done.
  refl,
end

-- This can be avoided by selecting the congruence lemma by hand.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.fold (+) 0 f S = finset.fold (+) 0 g S :=
begin
  conv_lhs { apply_congr finset.fold_congr, simp [h, H], },
end

example (f : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = 0) :
  finset.sum S f = 0 :=
begin
  conv_lhs { apply_congr, skip, simp [h, H], },
  simp,
end

-- An example using `finsupp.sum`
open_locale classical

example {k G : Type} [semiring k] [group G]
  (g : G →₀ k) (a₁ x : G) (b₁ : k)
  (t : ∀ (a₂ : G), a₁ * a₂ = x ↔ a₁⁻¹ * x = a₂) :
  g.sum (λ (a₂ : G) (b₂ : k), ite (a₁ * a₂ = x) (b₁ * b₂) 0) = b₁ * g (a₁⁻¹ * x) :=
begin
  -- In fact, `congr` works fine here, because our rewrite works globally.
  conv_lhs { apply_congr, skip, dsimp, rw t, },
  rw finset.sum_ite_eq g.support, -- it's a pity we can't just use `simp` here.
  split_ifs,
  { refl, },
  { simp [finsupp.not_mem_support_iff.1 h], },
end

example : true :=
begin
  success_if_fail { conv { apply_congr, }, },
  trivial
end


import tactic
open classical
local attribute [instance] prop_decidable

-- The code is very very messy...

noncomputable def truthteller : Prop → bool := λ P, if P then tt else ff
noncomputable def liar : Prop → bool := λ P, if P then ff else tt

lemma aux1 (P : Prop) : liar P = ! truthteller P :=
match classical.prop_decidable P with
| (is_true hP) := by calc liar P = ff : if_pos hP
    ... = ! tt : rfl
    ... = ! truthteller P : by unfold truthteller; rw (if_pos hP)
| (is_false hnP) := by calc liar P = tt : if_neg hnP
    ... = ! ff : rfl
    ... = ! truthteller P : by unfold truthteller; rw (if_neg hnP)
end

theorem solution (f : Prop → bool) (hf : f = truthteller ∨ f = liar)
  (P : Prop) : ∃ (Q : Prop), f Q = truthteller P :=
begin
  use [f P = tt],
  by_cases P,
  { have x : truthteller P = tt := @if_pos P _ h _ tt ff,
    cases hf; rw hf,
    { have y : truthteller (truthteller P = tt) = tt := @if_pos (truthteller P = tt) _ x _ tt ff,
      exact eq.trans y (eq.symm x),},
    { have x' : ¬ liar P = tt := by rwa [aux1, bool.bnot_not_eq],
      have y : liar (liar P = tt) = tt := @if_neg (liar P = tt) _ x' _ ff tt,
      exact eq.trans y (eq.symm x)}},
  have x : truthteller P = ff := if_neg h,
  cases hf; rw hf,
  { have x' : ¬ truthteller P = tt := (@bool.not_eq_bnot (truthteller P) ff).mpr x,
    have y : truthteller (truthteller P = tt) = ff := if_neg x',
    exact eq.trans y (eq.symm x)},
  { have z : liar P = tt := if_neg h,
    have y : liar (liar P = tt) = ff := if_pos z,
    exact eq.trans y (eq.symm x)}
end


/-
Copyright (c) 2021 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca

! This file was ported from Lean 3 source module number_theory.cyclotomic.basic
! leanprover-community/mathlib commit 831c494092374cfe9f50591ed0ac81a25efc5b86
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.Polynomial.Cyclotomic.Basic
import Mathbin.NumberTheory.NumberField.Basic
import Mathbin.Algebra.CharP.Algebra
import Mathbin.FieldTheory.Galois

/-!
# Cyclotomic extensions

Let `A` and `B` be commutative rings with `algebra A B`. For `S : set ℕ+`, we define a class
`is_cyclotomic_extension S A B` expressing the fact that `B` is obtained from `A` by adding `n`-th
primitive roots of unity, for all `n ∈ S`.

## Main definitions

* `is_cyclotomic_extension S A B` : means that `B` is obtained from `A` by adding `n`-th primitive
  roots of unity, for all `n ∈ S`.
* `cyclotomic_field`: given `n : ℕ+` and a field `K`, we define `cyclotomic n K` as the splitting
  field of `cyclotomic n K`. If `n` is nonzero in `K`, it has the instance
  `is_cyclotomic_extension {n} K (cyclotomic_field n K)`.
* `cyclotomic_ring` : if `A` is a domain with fraction field `K` and `n : ℕ+`, we define
  `cyclotomic_ring n A K` as the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of
  `X ^ n - 1`. If `n` is nonzero in `A`, it has the instance
  `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`.

## Main results

* `is_cyclotomic_extension.trans` : if `is_cyclotomic_extension S A B` and
  `is_cyclotomic_extension T B C`, then `is_cyclotomic_extension (S ∪ T) A C` if
  `function.injective (algebra_map B C)`.
* `is_cyclotomic_extension.union_right` : given `is_cyclotomic_extension (S ∪ T) A B`, then
  `is_cyclotomic_extension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B`.
* `is_cyclotomic_extension.union_right` : given `is_cyclotomic_extension T A B` and `S ⊆ T`, then
  `is_cyclotomic_extension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 })`.
* `is_cyclotomic_extension.finite` : if `S` is finite and `is_cyclotomic_extension S A B`, then
  `B` is a finite `A`-algebra.
* `is_cyclotomic_extension.number_field` : a finite cyclotomic extension of a number field is a
  number field.
* `is_cyclotomic_extension.splitting_field_X_pow_sub_one` : if `is_cyclotomic_extension {n} K L`,
  then `L` is the splitting field of `X ^ n - 1`.
* `is_cyclotomic_extension.splitting_field_cyclotomic` : if `is_cyclotomic_extension {n} K L`,
  then `L` is the splitting field of `cyclotomic n K`.

## Implementation details

Our definition of `is_cyclotomic_extension` is very general, to allow rings of any characteristic
and infinite extensions, but it will mainly be used in the case `S = {n}` and for integral domains.
All results are in the `is_cyclotomic_extension` namespace.
Note that some results, for example `is_cyclotomic_extension.trans`,
`is_cyclotomic_extension.finite`, `is_cyclotomic_extension.number_field`,
`is_cyclotomic_extension.finite_dimensional`, `is_cyclotomic_extension.is_galois` and
`cyclotomic_field.algebra_base` are lemmas, but they can be made local instances. Some of them are
included in the `cyclotomic` locale.

-/

open Polynomial Algebra FiniteDimensional Set

open BigOperators

universe u v w z

variable (n : ℕ+) (S T : Set ℕ+) (A : Type u) (B : Type v) (K : Type w) (L : Type z)

variable [CommRing A] [CommRing B] [Algebra A B]

variable [Field K] [Field L] [Algebra K L]

noncomputable section

/-- Given an `A`-algebra `B` and `S : set ℕ+`, we define `is_cyclotomic_extension S A B` requiring
that there is a `n`-th primitive root of unity in `B` for all `n ∈ S` and that `B` is generated
over `A` by the roots of `X ^ n - 1`. -/
@[mk_iff]
class IsCyclotomicExtension : Prop where
  exists_prim_root {n : ℕ+} (ha : n ∈ S) : ∃ r : B, IsPrimitiveRoot r n
  adjoin_roots : ∀ x : B, x ∈ adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 }
#align is_cyclotomic_extension IsCyclotomicExtension

namespace IsCyclotomicExtension

section Basic

/-- A reformulation of `is_cyclotomic_extension` that uses `⊤`. -/
theorem iff_adjoin_eq_top :
    IsCyclotomicExtension S A B ↔
      (∀ n : ℕ+, n ∈ S → ∃ r : B, IsPrimitiveRoot r n) ∧
        adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 } = ⊤ :=
  ⟨fun h => ⟨fun _ => h.exists_prim_root, Algebra.eq_top_iff.2 h.adjoin_roots⟩, fun h =>
    ⟨h.1, Algebra.eq_top_iff.1 h.2⟩⟩
#align is_cyclotomic_extension.iff_adjoin_eq_top IsCyclotomicExtension.iff_adjoin_eq_top

/-- A reformulation of `is_cyclotomic_extension` in the case `S` is a singleton. -/
theorem iff_singleton :
    IsCyclotomicExtension {n} A B ↔
      (∃ r : B, IsPrimitiveRoot r n) ∧ ∀ x, x ∈ adjoin A { b : B | b ^ (n : ℕ) = 1 } :=
  by simp [isCyclotomicExtension_iff]
#align is_cyclotomic_extension.iff_singleton IsCyclotomicExtension.iff_singleton

/-- If `is_cyclotomic_extension ∅ A B`, then the image of `A` in `B` equals `B`. -/
theorem empty [h : IsCyclotomicExtension ∅ A B] : (⊥ : Subalgebra A B) = ⊤ := by
  simpa [Algebra.eq_top_iff, isCyclotomicExtension_iff] using h
#align is_cyclotomic_extension.empty IsCyclotomicExtension.empty

/-- If `is_cyclotomic_extension {1} A B`, then the image of `A` in `B` equals `B`. -/
theorem singleton_one [h : IsCyclotomicExtension {1} A B] : (⊥ : Subalgebra A B) = ⊤ :=
  Algebra.eq_top_iff.2 fun x => by
    simpa [adjoin_singleton_one] using ((isCyclotomicExtension_iff _ _ _).1 h).2 x
#align is_cyclotomic_extension.singleton_one IsCyclotomicExtension.singleton_one

variable {A B}

/-- If `(⊥ : subalgebra A B) = ⊤`, then `is_cyclotomic_extension ∅ A B`. -/
theorem singleton_zero_of_bot_eq_top (h : (⊥ : Subalgebra A B) = ⊤) : IsCyclotomicExtension ∅ A B :=
  by
  refine'
    (iff_adjoin_eq_top _ _ _).2 ⟨fun s hs => by simpa using hs, _root_.eq_top_iff.2 fun x hx => _⟩
  rw [← h] at hx
  simpa using hx
#align is_cyclotomic_extension.singleton_zero_of_bot_eq_top IsCyclotomicExtension.singleton_zero_of_bot_eq_top

variable (A B)

/-- Transitivity of cyclotomic extensions. -/
theorem trans (C : Type w) [CommRing C] [Algebra A C] [Algebra B C] [IsScalarTower A B C]
    [hS : IsCyclotomicExtension S A B] [hT : IsCyclotomicExtension T B C]
    (h : Function.Injective (algebraMap B C)) : IsCyclotomicExtension (S ∪ T) A C :=
  by
  refine' ⟨fun n hn => _, fun x => _⟩
  · cases hn
    · obtain ⟨b, hb⟩ := ((isCyclotomicExtension_iff _ _ _).1 hS).1 hn
      refine' ⟨algebraMap B C b, _⟩
      exact hb.map_of_injective h
    · exact ((isCyclotomicExtension_iff _ _ _).1 hT).1 hn
  · refine'
      adjoin_induction (((isCyclotomicExtension_iff _ _ _).1 hT).2 x)
        (fun c ⟨n, hn⟩ => subset_adjoin ⟨n, Or.inr hn.1, hn.2⟩) (fun b => _)
        (fun x y hx hy => Subalgebra.add_mem _ hx hy) fun x y hx hy => Subalgebra.mul_mem _ hx hy
    · let f := IsScalarTower.toAlgHom A B C
      have hb : f b ∈ (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }).map f :=
        ⟨b, ((isCyclotomicExtension_iff _ _ _).1 hS).2 b, rfl⟩
      rw [IsScalarTower.toAlgHom_apply, ← adjoin_image] at hb
      refine' adjoin_mono (fun y hy => _) hb
      obtain ⟨b₁, ⟨⟨n, hn⟩, h₁⟩⟩ := hy
      exact ⟨n, ⟨mem_union_left T hn.1, by rw [← h₁, ← AlgHom.map_pow, hn.2, AlgHom.map_one]⟩⟩
#align is_cyclotomic_extension.trans IsCyclotomicExtension.trans

@[nontriviality]
theorem subsingleton_iff [Subsingleton B] : IsCyclotomicExtension S A B ↔ S = { } ∨ S = {1} :=
  by
  constructor
  · rintro ⟨hprim, -⟩
    rw [← subset_singleton_iff_eq]
    intro t ht
    obtain ⟨ζ, hζ⟩ := hprim ht
    rw [mem_singleton_iff, ← PNat.coe_eq_one_iff]
    exact_mod_cast hζ.unique (IsPrimitiveRoot.of_subsingleton ζ)
  · rintro (rfl | rfl)
    · refine' ⟨fun _ h => h.elim, fun x => by convert(mem_top : x ∈ ⊤)⟩
    · rw [iff_singleton]
      refine' ⟨⟨0, IsPrimitiveRoot.of_subsingleton 0⟩, fun x => by convert(mem_top : x ∈ ⊤)⟩
#align is_cyclotomic_extension.subsingleton_iff IsCyclotomicExtension.subsingleton_iff

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `S ∪ T`, then `B`
is a cyclotomic extension of `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 } ` given by
roots of unity of order in `T`. -/
theorem union_right [h : IsCyclotomicExtension (S ∪ T) A B] :
    IsCyclotomicExtension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B :=
  by
  have :
    { b : B | ∃ n : ℕ+, n ∈ S ∪ T ∧ b ^ (n : ℕ) = 1 } =
      { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 } ∪
        { b : B | ∃ n : ℕ+, n ∈ T ∧ b ^ (n : ℕ) = 1 } :=
    by
    refine' le_antisymm (fun x hx => _) fun x hx => _
    · rcases hx with ⟨n, hn₁ | hn₂, hnpow⟩
      · left
        exact ⟨n, hn₁, hnpow⟩
      · right
        exact ⟨n, hn₂, hnpow⟩
    · rcases hx with (⟨n, hn⟩ | ⟨n, hn⟩)
      · exact ⟨n, Or.inl hn.1, hn.2⟩
      · exact ⟨n, Or.inr hn.1, hn.2⟩
  refine' ⟨fun n hn => ((isCyclotomicExtension_iff _ _ _).1 h).1 (mem_union_right S hn), fun b => _⟩
  replace h := ((isCyclotomicExtension_iff _ _ _).1 h).2 b
  rwa [this, adjoin_union_eq_adjoin_adjoin, Subalgebra.mem_restrictScalars] at h
#align is_cyclotomic_extension.union_right IsCyclotomicExtension.union_right

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `T` and `S ⊆ T`,
then `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }` is a cyclotomic extension of `B`
given by roots of unity of order in `S`. -/
theorem union_left [h : IsCyclotomicExtension T A B] (hS : S ⊆ T) :
    IsCyclotomicExtension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) :=
  by
  refine' ⟨fun n hn => _, fun b => _⟩
  · obtain ⟨b, hb⟩ := ((isCyclotomicExtension_iff _ _ _).1 h).1 (hS hn)
    refine' ⟨⟨b, subset_adjoin ⟨n, hn, hb.pow_eq_one⟩⟩, _⟩
    rwa [← IsPrimitiveRoot.coe_submonoidClass_iff, Subtype.coe_mk]
  · convert mem_top
    rw [← adjoin_adjoin_coe_preimage, preimage_set_of_eq]
    norm_cast
#align is_cyclotomic_extension.union_left IsCyclotomicExtension.union_left

variable {n S}

/-- If `∀ s ∈ S, n ∣ s` and `S` is not empty, then `is_cyclotomic_extension S A B` implies
`is_cyclotomic_extension (S ∪ {n}) A B`. -/
theorem of_union_of_dvd (h : ∀ s ∈ S, n ∣ s) (hS : S.Nonempty) [H : IsCyclotomicExtension S A B] :
    IsCyclotomicExtension (S ∪ {n}) A B :=
  by
  refine' (iff_adjoin_eq_top _ _ _).2 ⟨fun s hs => _, _⟩
  · rw [mem_union, mem_singleton_iff] at hs
    obtain hs | rfl := hs
    · exact H.exists_prim_root hs
    · obtain ⟨m, hm⟩ := hS
      obtain ⟨x, rfl⟩ := h m hm
      obtain ⟨ζ, hζ⟩ := H.exists_prim_root hm
      refine' ⟨ζ ^ (x : ℕ), _⟩
      convert hζ.pow_of_dvd x.ne_zero (dvd_mul_left (x : ℕ) s)
      simp only [PNat.mul_coe, Nat.mul_div_left, PNat.pos]
  · refine' _root_.eq_top_iff.2 _
    rw [← ((iff_adjoin_eq_top S A B).1 H).2]
    refine' adjoin_mono fun x hx => _
    simp only [union_singleton, mem_insert_iff, mem_set_of_eq] at hx⊢
    obtain ⟨m, hm⟩ := hx
    exact ⟨m, ⟨Or.inr hm.1, hm.2⟩⟩
#align is_cyclotomic_extension.of_union_of_dvd IsCyclotomicExtension.of_union_of_dvd

/-- If `∀ s ∈ S, n ∣ s` and `S` is not empty, then `is_cyclotomic_extension S A B` if and only if
`is_cyclotomic_extension (S ∪ {n}) A B`. -/
theorem iff_union_of_dvd (h : ∀ s ∈ S, n ∣ s) (hS : S.Nonempty) :
    IsCyclotomicExtension S A B ↔ IsCyclotomicExtension (S ∪ {n}) A B :=
  by
  refine'
    ⟨fun H => of_union_of_dvd A B h hS, fun H => (iff_adjoin_eq_top _ _ _).2 ⟨fun s hs => _, _⟩⟩
  · exact H.exists_prim_root (subset_union_left _ _ hs)
  · rw [_root_.eq_top_iff, ← ((iff_adjoin_eq_top _ A B).1 H).2]
    refine' adjoin_mono fun x hx => _
    simp only [union_singleton, mem_insert_iff, mem_set_of_eq] at hx⊢
    obtain ⟨m, rfl | hm, hxpow⟩ := hx
    · obtain ⟨y, hy⟩ := hS
      refine' ⟨y, ⟨hy, _⟩⟩
      obtain ⟨z, rfl⟩ := h y hy
      simp only [PNat.mul_coe, pow_mul, hxpow, one_pow]
    · exact ⟨m, ⟨hm, hxpow⟩⟩
#align is_cyclotomic_extension.iff_union_of_dvd IsCyclotomicExtension.iff_union_of_dvd

variable (n S)

/-- `is_cyclotomic_extension S A B` is equivalent to `is_cyclotomic_extension (S ∪ {1}) A B`. -/
theorem iff_union_singleton_one :
    IsCyclotomicExtension S A B ↔ IsCyclotomicExtension (S ∪ {1}) A B :=
  by
  obtain hS | rfl := S.eq_empty_or_nonempty.symm
  · exact iff_union_of_dvd _ _ (fun s hs => one_dvd _) hS
  rw [empty_union]
  refine' ⟨fun H => _, fun H => _⟩
  · refine' (iff_adjoin_eq_top _ _ _).2 ⟨fun s hs => ⟨1, by simp [mem_singleton_iff.1 hs]⟩, _⟩
    simp [adjoin_singleton_one, @Empty _ _ _ _ _ H]
  · refine' (iff_adjoin_eq_top _ _ _).2 ⟨fun s hs => (not_mem_empty s hs).elim, _⟩
    simp [@singleton_one A B _ _ _ H]
#align is_cyclotomic_extension.iff_union_singleton_one IsCyclotomicExtension.iff_union_singleton_one

variable {A B}

/-- If `(⊥ : subalgebra A B) = ⊤`, then `is_cyclotomic_extension {1} A B`. -/
theorem singleton_one_of_bot_eq_top (h : (⊥ : Subalgebra A B) = ⊤) :
    IsCyclotomicExtension {1} A B :=
  by
  convert(iff_union_singleton_one _ _ _).1 (singleton_zero_of_bot_eq_top h)
  simp
#align is_cyclotomic_extension.singleton_one_of_bot_eq_top IsCyclotomicExtension.singleton_one_of_bot_eq_top

/-- If `function.surjective (algebra_map A B)`, then `is_cyclotomic_extension {1} A B`. -/
theorem singleton_one_of_algebraMap_bijective (h : Function.Surjective (algebraMap A B)) :
    IsCyclotomicExtension {1} A B :=
  singleton_one_of_bot_eq_top (surjective_algebraMap_iff.1 h).symm
#align is_cyclotomic_extension.singleton_one_of_algebra_map_bijective IsCyclotomicExtension.singleton_one_of_algebraMap_bijective

variable (A B)

/-- Given `(f : B ≃ₐ[A] C)`, if `is_cyclotomic_extension S A B` then
`is_cyclotomic_extension S A C`. -/
@[protected]
theorem equiv {C : Type _} [CommRing C] [Algebra A C] [h : IsCyclotomicExtension S A B]
    (f : B ≃ₐ[A] C) : IsCyclotomicExtension S A C :=
  by
  letI : Algebra B C := f.to_alg_hom.to_ring_hom.to_algebra
  haveI : IsCyclotomicExtension {1} B C := singleton_one_of_algebra_map_bijective f.surjective
  haveI : IsScalarTower A B C := IsScalarTower.of_ring_hom f.to_alg_hom
  exact (iff_union_singleton_one _ _ _).2 (trans S {1} A B C f.injective)
#align is_cyclotomic_extension.equiv IsCyclotomicExtension.equiv

@[protected]
theorem neZero [h : IsCyclotomicExtension {n} A B] [IsDomain B] : NeZero ((n : ℕ) : B) :=
  by
  obtain ⟨⟨r, hr⟩, -⟩ := (iff_singleton n A B).1 h
  exact hr.ne_zero'
#align is_cyclotomic_extension.ne_zero IsCyclotomicExtension.neZero

@[protected]
theorem ne_zero' [IsCyclotomicExtension {n} A B] [IsDomain B] : NeZero ((n : ℕ) : A) :=
  by
  apply NeZero.nat_of_neZero (algebraMap A B)
  exact NeZero n A B
#align is_cyclotomic_extension.ne_zero' IsCyclotomicExtension.ne_zero'

end Basic

section Fintype

theorem finite_of_singleton [IsDomain B] [h : IsCyclotomicExtension {n} A B] : Module.Finite A B :=
  by
  classical
    rw [Module.finite_def, ← top_to_submodule, ← ((iff_adjoin_eq_top _ _ _).1 h).2]
    refine' fg_adjoin_of_finite _ fun b hb => _
    · simp only [mem_singleton_iff, exists_eq_left]
      have : { b : B | b ^ (n : ℕ) = 1 } = (nth_roots n (1 : B)).toFinset :=
        Set.ext fun x => ⟨fun h => by simpa using h, fun h => by simpa using h⟩
      rw [this]
      exact (nth_roots (↑n) 1).toFinset.finite_toSet
    · simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hb
      refine' ⟨X ^ (n : ℕ) - 1, ⟨monic_X_pow_sub_C _ n.pos.ne.symm, by simp [hb]⟩⟩
#align is_cyclotomic_extension.finite_of_singleton IsCyclotomicExtension.finite_of_singleton

/-- If `S` is finite and `is_cyclotomic_extension S A B`, then `B` is a finite `A`-algebra. -/
@[protected]
theorem finite [IsDomain B] [h₁ : Finite S] [h₂ : IsCyclotomicExtension S A B] :
    Module.Finite A B := by
  cases' nonempty_fintype S with h
  revert h₂ A B
  refine' Set.Finite.induction_on (Set.Finite.intro h) (fun A B => _) fun n S hn hS H A B => _
  · intro _ _ _ _ _
    refine' Module.finite_def.2 ⟨({1} : Finset B), _⟩
    simp [← top_to_submodule, ← Empty, to_submodule_bot]
  · intro _ _ _ _ h
    haveI : IsCyclotomicExtension S A (adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 }) :=
      union_left _ (insert n S) _ _ (subset_insert n S)
    haveI := H A (adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 })
    have : Module.Finite (adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 }) B :=
      by
      rw [← union_singleton] at h
      letI := @union_right S {n} A B _ _ _ h
      exact finite_of_singleton n _ _
    exact Module.Finite.trans (adjoin A { b : B | ∃ n : ℕ+, n ∈ S ∧ b ^ (n : ℕ) = 1 }) _
#align is_cyclotomic_extension.finite IsCyclotomicExtension.finite

/-- A cyclotomic finite extension of a number field is a number field. -/
theorem numberField [h : NumberField K] [Finite S] [IsCyclotomicExtension S K L] : NumberField L :=
  { to_charZero := charZero_of_injective_algebraMap (algebraMap K L).Injective
    to_finiteDimensional :=
      @Module.Finite.trans _ K L _ _ _ _
        (@algebraRat L _ (charZero_of_injective_algebraMap (algebraMap K L).Injective)) _ _
        h.to_finiteDimensional (Finite S K L) }
#align is_cyclotomic_extension.number_field IsCyclotomicExtension.numberField

scoped[Cyclotomic] attribute [instance] IsCyclotomicExtension.numberField

/-- A finite cyclotomic extension of an integral noetherian domain is integral -/
theorem integral [IsDomain B] [IsNoetherianRing A] [Finite S] [IsCyclotomicExtension S A B] :
    Algebra.IsIntegral A B :=
  isIntegral_of_noetherian <| isNoetherian_of_fg_of_noetherian' <| (Finite S A B).out
#align is_cyclotomic_extension.integral IsCyclotomicExtension.integral

/-- If `S` is finite and `is_cyclotomic_extension S K A`, then `finite_dimensional K A`. -/
theorem finiteDimensional (C : Type z) [Finite S] [CommRing C] [Algebra K C] [IsDomain C]
    [IsCyclotomicExtension S K C] : FiniteDimensional K C :=
  IsCyclotomicExtension.finite S K C
#align is_cyclotomic_extension.finite_dimensional IsCyclotomicExtension.finiteDimensional

scoped[Cyclotomic] attribute [instance] IsCyclotomicExtension.finiteDimensional

end Fintype

section

variable {A B}

theorem adjoin_roots_cyclotomic_eq_adjoin_nth_roots [DecidableEq B] [IsDomain B] {ζ : B} {n : ℕ+}
    (hζ : IsPrimitiveRoot ζ n) :
    adjoin A ↑(map (algebraMap A B) (cyclotomic n A)).roots.toFinset =
      adjoin A { b : B | ∃ a : ℕ+, a ∈ ({n} : Set ℕ+) ∧ b ^ (a : ℕ) = 1 } :=
  by
  simp only [mem_singleton_iff, exists_eq_left, map_cyclotomic]
  refine' le_antisymm (adjoin_mono fun x hx => _) (adjoin_le fun x hx => _)
  · simp only [Multiset.mem_toFinset, Finset.mem_coe, map_cyclotomic,
      mem_roots (cyclotomic_ne_zero n B)] at hx
    simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq]
    rw [isRoot_of_unity_iff n.pos]
    exact ⟨n, Nat.mem_divisors_self n n.ne_zero, hx⟩
  · simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos
    refine' SetLike.mem_coe.2 (Subalgebra.pow_mem _ (subset_adjoin _) _)
    rwa [Finset.mem_coe, Multiset.mem_toFinset, mem_roots <| cyclotomic_ne_zero n B]
    exact hζ.is_root_cyclotomic n.pos
#align is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots IsCyclotomicExtension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots

theorem adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic {n : ℕ+} [DecidableEq B] [IsDomain B]
    {ζ : B} (hζ : IsPrimitiveRoot ζ n) :
    adjoin A ((map (algebraMap A B) (cyclotomic n A)).roots.toFinset : Set B) = adjoin A {ζ} :=
  by
  refine' le_antisymm (adjoin_le fun x hx => _) (adjoin_mono fun x hx => _)
  · suffices hx : x ^ ↑n = 1
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos
    exact SetLike.mem_coe.2 (Subalgebra.pow_mem _ (subset_adjoin <| mem_singleton ζ) _)
    rw [isRoot_of_unity_iff n.pos]
    refine' ⟨n, Nat.mem_divisors_self n n.ne_zero, _⟩
    rwa [Finset.mem_coe, Multiset.mem_toFinset, map_cyclotomic,
      mem_roots <| cyclotomic_ne_zero n B] at hx
  · simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx
    simpa only [hx, Multiset.mem_toFinset, Finset.mem_coe, map_cyclotomic,
      mem_roots (cyclotomic_ne_zero n B)] using hζ.is_root_cyclotomic n.pos
#align is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic IsCyclotomicExtension.adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic

theorem adjoin_primitive_root_eq_top {n : ℕ+} [IsDomain B] [h : IsCyclotomicExtension {n} A B]
    {ζ : B} (hζ : IsPrimitiveRoot ζ n) : adjoin A ({ζ} : Set B) = ⊤ := by
  classical
    rw [← adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic hζ]
    rw [adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ]
    exact ((iff_adjoin_eq_top {n} A B).mp h).2
#align is_cyclotomic_extension.adjoin_primitive_root_eq_top IsCyclotomicExtension.adjoin_primitive_root_eq_top

variable (A)

theorem IsPrimitiveRoot.adjoin_isCyclotomicExtension {ζ : B} {n : ℕ+} (h : IsPrimitiveRoot ζ n) :
    IsCyclotomicExtension {n} A (adjoin A ({ζ} : Set B)) :=
  { exists_prim_root := fun i hi =>
      by
      rw [Set.mem_singleton_iff] at hi
      refine' ⟨⟨ζ, subset_adjoin <| Set.mem_singleton ζ⟩, _⟩
      rwa [← IsPrimitiveRoot.coe_submonoidClass_iff, Subtype.coe_mk, hi]
    adjoin_roots := fun x =>
      by
      refine'
        adjoin_induction' (fun b hb => _) (fun a => _) (fun b₁ b₂ hb₁ hb₂ => _)
          (fun b₁ b₂ hb₁ hb₂ => _) x
      · rw [Set.mem_singleton_iff] at hb
        refine' subset_adjoin _
        simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq, hb]
        rw [← Subalgebra.coe_eq_one, Subalgebra.coe_pow, [anonymous]]
        exact ((IsPrimitiveRoot.iff_def ζ n).1 h).1
      · exact Subalgebra.algebraMap_mem _ _
      · exact Subalgebra.add_mem _ hb₁ hb₂
      · exact Subalgebra.mul_mem _ hb₁ hb₂ }
#align is_primitive_root.adjoin_is_cyclotomic_extension IsPrimitiveRoot.adjoin_isCyclotomicExtension

end

section Field

variable {n S}

/-- A cyclotomic extension splits `X ^ n - 1` if `n ∈ S`.-/
theorem splits_x_pow_sub_one [H : IsCyclotomicExtension S K L] (hS : n ∈ S) :
    Splits (algebraMap K L) (X ^ (n : ℕ) - 1) :=
  by
  rw [← splits_id_iff_splits, Polynomial.map_sub, Polynomial.map_one, Polynomial.map_pow,
    Polynomial.map_X]
  obtain ⟨z, hz⟩ := ((isCyclotomicExtension_iff _ _ _).1 H).1 hS
  exact X_pow_sub_one_splits hz
#align is_cyclotomic_extension.splits_X_pow_sub_one IsCyclotomicExtension.splits_x_pow_sub_one

/-- A cyclotomic extension splits `cyclotomic n K` if `n ∈ S` and `ne_zero (n : K)`.-/
theorem splits_cyclotomic [IsCyclotomicExtension S K L] (hS : n ∈ S) :
    Splits (algebraMap K L) (cyclotomic n K) :=
  by
  refine' splits_of_splits_of_dvd _ (X_pow_sub_C_ne_zero n.pos _) (splits_X_pow_sub_one K L hS) _
  use ∏ i : ℕ in (n : ℕ).properDivisors, Polynomial.cyclotomic i K
  rw [(eq_cyclotomic_iff n.pos _).1 rfl, RingHom.map_one]
#align is_cyclotomic_extension.splits_cyclotomic IsCyclotomicExtension.splits_cyclotomic

variable (n S)

section Singleton

variable [IsCyclotomicExtension {n} K L]

/-- If `is_cyclotomic_extension {n} K L`, then `L` is the splitting field of `X ^ n - 1`. -/
theorem splitting_field_x_pow_sub_one : IsSplittingField K L (X ^ (n : ℕ) - 1) :=
  { Splits := splits_x_pow_sub_one K L (mem_singleton n)
    adjoin_roots := by
      rw [← ((iff_adjoin_eq_top {n} K L).1 inferInstance).2]
      congr
      refine' Set.ext fun x => _
      simp only [Polynomial.map_pow, mem_singleton_iff, Multiset.mem_toFinset, exists_eq_left,
        mem_set_of_eq, Polynomial.map_X, Polynomial.map_one, Finset.mem_coe, Polynomial.map_sub]
      rwa [← RingHom.map_one C, mem_roots (@X_pow_sub_C_ne_zero L _ _ _ n.pos _), is_root.def,
        eval_sub, eval_pow, eval_C, eval_X, sub_eq_zero] }
#align is_cyclotomic_extension.splitting_field_X_pow_sub_one IsCyclotomicExtension.splitting_field_x_pow_sub_one

/-- Any two `n`-th cyclotomic extensions are isomorphic. -/
def algEquiv (L' : Type _) [Field L'] [Algebra K L'] [IsCyclotomicExtension {n} K L'] :
    L ≃ₐ[K] L' :=
  let _ := splitting_field_x_pow_sub_one n K L
  let _ := splitting_field_x_pow_sub_one n K L'
  (is_splitting_field.alg_equiv L (X ^ (n : ℕ) - 1)).trans
    (is_splitting_field.alg_equiv L' (X ^ (n : ℕ) - 1)).symm
#align is_cyclotomic_extension.alg_equiv IsCyclotomicExtension.algEquiv

scoped[Cyclotomic] attribute [instance] IsCyclotomicExtension.splitting_field_x_pow_sub_one

include n

theorem isGalois : IsGalois K L :=
  letI := splitting_field_X_pow_sub_one n K L
  IsGalois.of_separable_splitting_field (X_pow_sub_one_separable_iff.2 (ne_zero' n K L).1)
#align is_cyclotomic_extension.is_galois IsCyclotomicExtension.isGalois

scoped[Cyclotomic] attribute [instance] IsCyclotomicExtension.isGalois

/-- If `is_cyclotomic_extension {n} K L`, then `L` is the splitting field of `cyclotomic n K`. -/
theorem splitting_field_cyclotomic : IsSplittingField K L (cyclotomic n K) :=
  { Splits := splits_cyclotomic K L (mem_singleton n)
    adjoin_roots := by
      rw [← ((iff_adjoin_eq_top {n} K L).1 inferInstance).2]
      letI := Classical.decEq L
      obtain ⟨ζ, hζ⟩ := @IsCyclotomicExtension.exists_prim_root {n} K L _ _ _ _ _ (mem_singleton n)
      exact adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ }
#align is_cyclotomic_extension.splitting_field_cyclotomic IsCyclotomicExtension.splitting_field_cyclotomic

scoped[Cyclotomic] attribute [instance] IsCyclotomicExtension.splitting_field_cyclotomic

end Singleton

end Field

end IsCyclotomicExtension

section CyclotomicField

/- ./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] K -/
/-- Given `n : ℕ+` and a field `K`, we define `cyclotomic_field n K` as the
splitting field of `cyclotomic n K`. If `n` is nonzero in `K`, it has
the instance `is_cyclotomic_extension {n} K (cyclotomic_field n K)`. -/
def CyclotomicField : Type w :=
  (cyclotomic n K).SplittingField deriving Field,
  «./././Mathport/Syntax/Translate/Command.lean:42:9: unsupported derive handler algebra[algebra] K»,
  Inhabited
#align cyclotomic_field CyclotomicField

namespace CyclotomicField

instance [CharZero K] : CharZero (CyclotomicField n K) :=
  charZero_of_injective_algebraMap (algebraMap K _).Injective

instance isCyclotomicExtension [NeZero ((n : ℕ) : K)] :
    IsCyclotomicExtension {n} K (CyclotomicField n K) :=
  by
  haveI : NeZero ((n : ℕ) : CyclotomicField n K) :=
    NeZero.nat_of_injective (algebraMap K _).Injective
  letI := Classical.decEq (CyclotomicField n K)
  obtain ⟨ζ, hζ⟩ :=
    exists_root_of_splits (algebraMap K (CyclotomicField n K)) (splitting_field.splits _)
      (degree_cyclotomic_pos n K n.pos).ne'
  rw [← eval_map, ← is_root.def, map_cyclotomic, is_root_cyclotomic_iff] at hζ
  refine' ⟨forall_eq.2 ⟨ζ, hζ⟩, _⟩
  rw [← Algebra.eq_top_iff, ← splitting_field.adjoin_roots, eq_comm]
  exact IsCyclotomicExtension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ
#align cyclotomic_field.is_cyclotomic_extension CyclotomicField.isCyclotomicExtension

end CyclotomicField

end CyclotomicField

section IsDomain

variable [IsDomain A] [Algebra A K] [IsFractionRing A K]

section CyclotomicRing

/-- If `K` is the fraction field of `A`, the `A`-algebra structure on `cyclotomic_field n K`.
This is not an instance since it causes diamonds when `A = ℤ`. -/
@[nolint unused_arguments]
def CyclotomicField.algebraBase : Algebra A (CyclotomicField n K) :=
  ((algebraMap K (CyclotomicField n K)).comp (algebraMap A K)).toAlgebra
#align cyclotomic_field.algebra_base CyclotomicField.algebraBase

attribute [local instance] CyclotomicField.algebraBase

instance CyclotomicField.noZeroSMulDivisors : NoZeroSMulDivisors A (CyclotomicField n K) :=
  NoZeroSMulDivisors.of_algebraMap_injective <|
    Function.Injective.comp (NoZeroSMulDivisors.algebraMap_injective _ _) <|
      IsFractionRing.injective A K
#align cyclotomic_field.no_zero_smul_divisors CyclotomicField.noZeroSMulDivisors

/-- If `A` is a domain with fraction field `K` and `n : ℕ+`, we define `cyclotomic_ring n A K` as
the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of `X ^ n - 1`. If `n`
is nonzero in `A`, it has the instance `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`. -/
def CyclotomicRing : Type w :=
  adjoin A { b : CyclotomicField n K | b ^ (n : ℕ) = 1 }deriving CommRing, IsDomain, Inhabited
#align cyclotomic_ring CyclotomicRing

namespace CyclotomicRing

/-- The `A`-algebra structure on `cyclotomic_ring n A K`.
This is not an instance since it causes diamonds when `A = ℤ`. -/
def algebraBase : Algebra A (CyclotomicRing n A K) :=
  (adjoin A _).Algebra
#align cyclotomic_ring.algebra_base CyclotomicRing.algebraBase

attribute [local instance] CyclotomicRing.algebraBase

instance : NoZeroSMulDivisors A (CyclotomicRing n A K) :=
  (adjoin A _).noZeroSMulDivisors_bot

theorem algebraBase_injective : Function.Injective <| algebraMap A (CyclotomicRing n A K) :=
  NoZeroSMulDivisors.algebraMap_injective _ _
#align cyclotomic_ring.algebra_base_injective CyclotomicRing.algebraBase_injective

instance : Algebra (CyclotomicRing n A K) (CyclotomicField n K) :=
  (adjoin A _).toAlgebra

theorem adjoin_algebra_injective :
    Function.Injective <| algebraMap (CyclotomicRing n A K) (CyclotomicField n K) :=
  Subtype.val_injective
#align cyclotomic_ring.adjoin_algebra_injective CyclotomicRing.adjoin_algebra_injective

instance : NoZeroSMulDivisors (CyclotomicRing n A K) (CyclotomicField n K) :=
  NoZeroSMulDivisors.of_algebraMap_injective (adjoin_algebra_injective n A K)

instance : IsScalarTower A (CyclotomicRing n A K) (CyclotomicField n K) :=
  IsScalarTower.subalgebra' _ _ _ _

instance isCyclotomicExtension [NeZero ((n : ℕ) : A)] :
    IsCyclotomicExtension {n} A (CyclotomicRing n A K)
    where
  exists_prim_root a han := by
    rw [mem_singleton_iff] at han
    subst a
    haveI := NeZero.of_noZeroSMulDivisors A K n
    haveI := NeZero.of_noZeroSMulDivisors A (CyclotomicField n K) n
    obtain ⟨μ, hμ⟩ := (CyclotomicField.isCyclotomicExtension n K).exists_prim_root (mem_singleton n)
    refine' ⟨⟨μ, subset_adjoin _⟩, _⟩
    · apply (isRoot_of_unity_iff n.pos (CyclotomicField n K)).mpr
      refine' ⟨n, Nat.mem_divisors_self _ n.ne_zero, _⟩
      rwa [← is_root_cyclotomic_iff] at hμ
    · rwa [← IsPrimitiveRoot.coe_submonoidClass_iff, Subtype.coe_mk]
  adjoin_roots x :=
    by
    refine'
      adjoin_induction' (fun y hy => _) (fun a => _) (fun y z hy hz => _) (fun y z hy hz => _) x
    · refine' subset_adjoin _
      simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq]
      rwa [← Subalgebra.coe_eq_one, Subalgebra.coe_pow, Subtype.coe_mk]
    · exact Subalgebra.algebraMap_mem _ a
    · exact Subalgebra.add_mem _ hy hz
    · exact Subalgebra.mul_mem _ hy hz
#align cyclotomic_ring.is_cyclotomic_extension CyclotomicRing.isCyclotomicExtension

instance [NeZero ((n : ℕ) : A)] : IsFractionRing (CyclotomicRing n A K) (CyclotomicField n K)
    where
  map_units := fun ⟨x, hx⟩ => by
    rw [isUnit_iff_ne_zero]
    apply map_ne_zero_of_mem_nonZeroDivisors
    apply adjoin_algebra_injective
    exact hx
  surj x :=
    by
    letI : NeZero ((n : ℕ) : K) := NeZero.nat_of_injective (IsFractionRing.injective A K)
    refine'
      Algebra.adjoin_induction
        (((IsCyclotomicExtension.iff_singleton n K _).1
              (CyclotomicField.isCyclotomicExtension n K)).2
          x)
        (fun y hy => _) (fun k => _) _ _
    · exact ⟨⟨⟨y, subset_adjoin hy⟩, 1⟩, by simpa⟩
    · have : IsLocalization (nonZeroDivisors A) K := inferInstance
      replace := this.surj
      obtain ⟨⟨z, w⟩, hw⟩ := this k
      refine'
        ⟨⟨algebraMap A _ z, algebraMap A _ w,
            map_mem_nonZeroDivisors _ (algebra_base_injective n A K) w.2⟩,
          _⟩
      letI : IsScalarTower A K (CyclotomicField n K) :=
        IsScalarTower.of_algebraMap_eq (congr_fun rfl)
      rw [[anonymous], ← IsScalarTower.algebraMap_apply, ← IsScalarTower.algebraMap_apply,
        @IsScalarTower.algebraMap_apply A K _ _ _ _ _ (_root_.cyclotomic_field.algebra n K) _ _ w, ←
        RingHom.map_mul, hw, ← IsScalarTower.algebraMap_apply]
    · rintro y z ⟨a, ha⟩ ⟨b, hb⟩
      refine' ⟨⟨a.1 * b.2 + b.1 * a.2, a.2 * b.2, mul_mem_nonZeroDivisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩
      rw [[anonymous], RingHom.map_mul, add_mul, ← mul_assoc, ha, mul_comm ((algebraMap _ _) ↑a.2),
        ← mul_assoc, hb]
      simp only [map_add, map_mul]
    · rintro y z ⟨a, ha⟩ ⟨b, hb⟩
      refine' ⟨⟨a.1 * b.1, a.2 * b.2, mul_mem_nonZeroDivisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩
      rw [[anonymous], RingHom.map_mul, mul_comm ((algebraMap _ _) ↑a.2), mul_assoc, ← mul_assoc z,
        hb, ← mul_comm ((algebraMap _ _) ↑a.2), ← mul_assoc, ha]
      simp only [map_mul]
  eq_iff_exists x y :=
    ⟨fun h => ⟨1, by rw [adjoin_algebra_injective n A K h]⟩, fun ⟨c, hc⟩ => by
      rw [mul_left_cancel₀ (nonZeroDivisors.ne_zero c.prop) hc]⟩

theorem eq_adjoin_primitive_root {μ : CyclotomicField n K} (h : IsPrimitiveRoot μ n) :
    CyclotomicRing n A K = adjoin A ({μ} : Set (CyclotomicField n K)) :=
  by
  letI := Classical.propDecidable
  rw [← IsCyclotomicExtension.adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic h,
    IsCyclotomicExtension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots h]
  simp [CyclotomicRing]
#align cyclotomic_ring.eq_adjoin_primitive_root CyclotomicRing.eq_adjoin_primitive_root

end CyclotomicRing

end CyclotomicRing

end IsDomain

section IsAlgClosed

variable [IsAlgClosed K]

/-- Algebraically closed fields are `S`-cyclotomic extensions over themselves if
`ne_zero ((a : ℕ) : K))` for all `a ∈ S`. -/
theorem IsAlgClosed.isCyclotomicExtension (h : ∀ a ∈ S, NeZero ((a : ℕ) : K)) :
    IsCyclotomicExtension S K K :=
  by
  refine' ⟨fun a ha => _, algebra.eq_top_iff.mp <| Subsingleton.elim _ _⟩
  obtain ⟨r, hr⟩ := IsAlgClosed.exists_aeval_eq_zero K _ (degree_cyclotomic_pos a K a.pos).ne'
  refine' ⟨r, _⟩
  haveI := h a ha
  rwa [coe_aeval_eq_eval, ← is_root.def, is_root_cyclotomic_iff] at hr
#align is_alg_closed.is_cyclotomic_extension IsAlgClosed.isCyclotomicExtension

instance IsAlgClosedOfCharZero.isCyclotomicExtension [CharZero K] :
    ∀ S, IsCyclotomicExtension S K K := fun S =>
  IsAlgClosed.isCyclotomicExtension S K fun a ha => inferInstance
#align is_alg_closed_of_char_zero.is_cyclotomic_extension IsAlgClosedOfCharZero.isCyclotomicExtension

end IsAlgClosed


def certificate : Type := sorry

def gen_prf_crt (P : Prop) (p : P) : certificate := sorry

def ver_prf_crt (P : Prop) (c : certificate) : bool := sorry

lemma correctness (P : Prop) (p : P) :
ver_prf_crt P (gen_prf_crt P p) = true := sorry

-- "lemma" integrity (P : Prop) :
-- it_is_hard_to_find (c : certificate)
-- such_that (ver_prf_crt P c = true) := sorry

-- "lemma" zero_knowledge (P : Prop) (c : certificate)
-- (h : ver_prf_crt P c = true) :
-- gives_no_knowledge_about_a_proof_of P


/-
Copyright © 2020 Nicolò Cavalleri. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Nicolò Cavalleri
-/

import topology.subset_properties
import topology.tactic
import topology.algebra.ordered

/-!
# Continuous bundled map

In this file we define the type `continuous_map` of continuous bundled maps.
-/

/-- Bundled continuous maps. -/
@[protect_proj]
structure continuous_map (α : Type*) (β : Type*)
[topological_space α] [topological_space β] :=
(to_fun             : α → β)
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')

notation `C(` α `, ` β `)` := continuous_map α β

namespace continuous_map

attribute [continuity] continuous_map.continuous_to_fun

variables {α : Type*} {β : Type*} {γ : Type*}
variables [topological_space α] [topological_space β] [topological_space γ]

instance : has_coe_to_fun (C(α, β)) := ⟨_, continuous_map.to_fun⟩

@[simp] lemma to_fun_eq_coe {f : C(α, β)} : f.to_fun = (f : α → β) := rfl

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

@[continuity] protected lemma continuous (f : C(α, β)) : continuous f := f.continuous_to_fun
@[continuity] lemma continuous_set_coe (s : set C(α, β)) (f : s) : continuous f :=
by { cases f, dsimp, continuity, }

protected lemma continuous_at (f : C(α, β)) (x : α) : continuous_at f x :=
f.continuous.continuous_at

protected lemma continuous_within_at (f : C(α, β)) (s : set α) (x : α) :
  continuous_within_at f s x :=
f.continuous.continuous_within_at

protected lemma congr_fun {f g : C(α, β)} (H : f = g) (x : α) : f x = g x := H ▸ rfl
protected lemma congr_arg (f : C(α, β)) {x y : α} (h : x = y) : f x = f y := h ▸ rfl

@[ext]

lemma ext_iff : f = g ↔ ∀ x, f x = g x :=
⟨continuous_map.congr_fun, ext⟩

instance [inhabited β] : inhabited C(α, β) :=
⟨{ to_fun := λ _, default _, }⟩

lemma coe_inj ⦃f g : C(α, β)⦄ (h : (f : α → β) = g) : f = g :=
by cases f; cases g; cases h; refl

@[simp] lemma coe_mk (f : α → β) (h : continuous f) :
  ⇑(⟨f, h⟩ : continuous_map α β) = f := rfl

section
variables (α β)

/--
The continuous functions from `α` to `β` are the same as the plain functions when `α` is discrete.
-/
@[simps]
def equiv_fn_of_discrete [discrete_topology α] : C(α, β) ≃ (α → β) :=
⟨(λ f, f), (λ f, ⟨f, continuous_of_discrete_topology⟩),
  λ f, by { ext, refl, }, λ f, by { ext, refl, }⟩

end

/-- The identity as a continuous map. -/
def id : C(α, α) := ⟨id⟩

@[simp] lemma id_coe : (id : α → α) = id := rfl
lemma id_apply (a : α) : id a = a := rfl

/-- The composition of continuous maps, as a continuous map. -/
def comp (f : C(β, γ)) (g : C(α, β)) : C(α, γ) := ⟨f ∘ g⟩

@[simp] lemma comp_coe (f : C(β, γ)) (g : C(α, β)) : (comp f g : α → γ) = f ∘ g := rfl
lemma comp_apply (f : C(β, γ)) (g : C(α, β)) (a : α) : comp f g a = f (g a) := rfl

/-- Constant map as a continuous map -/
def const (b : β) : C(α, β) := ⟨λ x, b⟩

@[simp] lemma const_coe (b : β) : (const b : α → β) = (λ x, b) := rfl
lemma const_apply (b : β) (a : α) : const b a = b := rfl

instance [nonempty α] [nontrivial β] : nontrivial C(α, β) :=
{ exists_pair_ne := begin
    obtain ⟨b₁, b₂, hb⟩ := exists_pair_ne β,
    refine ⟨const b₁, const b₂, _⟩,
    contrapose! hb,
    inhabit α,
    change const b₁ (default α) = const b₂ (default α),
    simp [hb]
  end }

section
variables [linear_ordered_add_comm_group β] [order_topology β]

/-- The pointwise absolute value of a continuous function as a continuous function. -/
def abs (f : C(α, β)) : C(α, β) :=
{ to_fun := λ x, abs (f x), }

@[simp] lemma abs_apply (f : C(α, β)) (x : α) : f.abs x = _root_.abs (f x) :=
rfl

end

/-!
We now set up the partial order and lattice structure (given by pointwise min and max)
on continuous functions.
-/
section lattice

instance partial_order [partial_order β] :
  partial_order C(α, β) :=
partial_order.lift (λ f, f.to_fun) (by tidy)

lemma le_def [partial_order β] {f g : C(α, β)} : f ≤ g ↔ ∀ a, f a ≤ g a :=
pi.le_def

lemma lt_def [partial_order β] {f g : C(α, β)} :
  f < g ↔ (∀ a, f a ≤ g a) ∧ (∃ a, f a < g a) :=
pi.lt_def

instance has_sup [linear_order β] [order_closed_topology β] : has_sup C(α, β) :=
{ sup := λ f g, { to_fun := λ a, max (f a) (g a), } }

@[simp, norm_cast] lemma sup_coe [linear_order β] [order_closed_topology β] (f g : C(α, β)) :
  ((f ⊔ g : C(α, β)) : α → β) = (f ⊔ g : α → β) :=
rfl

@[simp] lemma sup_apply [linear_order β] [order_closed_topology β] (f g : C(α, β)) (a : α) :
  (f ⊔ g) a = max (f a) (g a) :=
rfl

instance [linear_order β] [order_closed_topology β] : semilattice_sup C(α, β) :=
{ le_sup_left := λ f g, le_def.mpr (by simp [le_refl]),
  le_sup_right := λ f g, le_def.mpr (by simp [le_refl]),
  sup_le := λ f₁ f₂ g w₁ w₂, le_def.mpr (λ a, by simp [le_def.mp w₁ a, le_def.mp w₂ a]),
  ..continuous_map.partial_order,
  ..continuous_map.has_sup, }

instance has_inf [linear_order β] [order_closed_topology β] : has_inf C(α, β) :=
{ inf := λ f g, { to_fun := λ a, min (f a) (g a), } }

@[simp, norm_cast] lemma inf_coe [linear_order β] [order_closed_topology β] (f g : C(α, β)) :
  ((f ⊓ g : C(α, β)) : α → β) = (f ⊓ g : α → β) :=
rfl

@[simp] lemma inf_apply [linear_order β] [order_closed_topology β] (f g : C(α, β)) (a : α) :
  (f ⊓ g) a = min (f a) (g a) :=
rfl

instance [linear_order β] [order_closed_topology β] : semilattice_inf C(α, β) :=
{ inf_le_left := λ f g, le_def.mpr (by simp [le_refl]),
  inf_le_right := λ f g, le_def.mpr (by simp [le_refl]),
  le_inf := λ f₁ f₂ g w₁ w₂, le_def.mpr (λ a, by simp [le_def.mp w₁ a, le_def.mp w₂ a]),
  ..continuous_map.partial_order,
  ..continuous_map.has_inf, }

instance [linear_order β] [order_closed_topology β] : lattice C(α, β) :=
{ ..continuous_map.semilattice_inf,
  ..continuous_map.semilattice_sup }

-- TODO transfer this lattice structure to `bounded_continuous_function`

section sup'
variables [linear_order γ] [order_closed_topology γ]

lemma sup'_apply {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) (b : β) :
  s.sup' H f b = s.sup' H (λ a, f a b) :=
finset.comp_sup'_eq_sup'_comp H (λ f : C(β, γ), f b) (λ i j, rfl)

@[simp, norm_cast]
lemma sup'_coe {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) :
  ((s.sup' H f : C(β, γ)) : ι → β) = s.sup' H (λ a, (f a : β → γ)) :=
by { ext, simp [sup'_apply], }

end sup'

section inf'
variables [linear_order γ] [order_closed_topology γ]

lemma inf'_apply {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) (b : β) :
  s.inf' H f b = s.inf' H (λ a, f a b) :=
@sup'_apply _ (order_dual γ) _ _ _ _ _ _ H f b

@[simp, norm_cast]
lemma inf'_coe {ι : Type*} {s : finset ι} (H : s.nonempty) (f : ι → C(β, γ)) :
  ((s.inf' H f : C(β, γ)) : ι → β) = s.inf' H (λ a, (f a : β → γ)) :=
@sup'_coe _ (order_dual γ) _ _ _ _ _ _ H f

end inf'

end lattice

end continuous_map

/--
The forward direction of a homeomorphism, as a bundled continuous map.
-/
@[simps]
def homeomorph.to_continuous_map {α β : Type*} [topological_space α] [topological_space β]
  (e : α ≃ₜ β) : C(α, β) := ⟨e⟩


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Sébastien Gouëzel, Patrick Massot
-/
import topology.uniform_space.cauchy
import topology.uniform_space.separation
import topology.dense_embedding

/-!
# Uniform embeddings of uniform spaces.

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

Extension of uniform continuous functions.
-/

open filter topological_space set function classical
open_locale classical uniformity topology filter

section
variables {α : Type*} {β : Type*} {γ : Type*}
          [uniform_space α] [uniform_space β] [uniform_space γ]
universes u v

/-!
### Uniform inducing maps
-/

/-- A map `f : α → β` between uniform spaces is called *uniform inducing* if the uniformity filter
on `α` is the pullback of the uniformity filter on `β` under `prod.map f f`. If `α` is a separated
space, then this implies that `f` is injective, hence it is a `uniform_embedding`. -/
@[mk_iff]
structure uniform_inducing (f : α → β) : Prop :=
(comap_uniformity : comap (λx:α×α, (f x.1, f x.2)) (𝓤 β) = 𝓤 α)

protected lemma uniform_inducing.comap_uniform_space {f : α → β} (hf : uniform_inducing f) :
  ‹uniform_space β›.comap f = ‹uniform_space α› :=
uniform_space_eq hf.1

lemma uniform_inducing_iff' {f : α → β} :
  uniform_inducing f ↔ uniform_continuous f ∧ comap (prod.map f f) (𝓤 β) ≤ 𝓤 α :=
by rw [uniform_inducing_iff, uniform_continuous, tendsto_iff_comap, le_antisymm_iff, and_comm]; refl

protected lemma filter.has_basis.uniform_inducing_iff {ι ι'} {p : ι → Prop} {p' : ι' → Prop} {s s'}
  (h : (𝓤 α).has_basis p s) (h' : (𝓤 β).has_basis p' s') {f : α → β} :
  uniform_inducing f ↔
    (∀ i, p' i → ∃ j, p j ∧ ∀ x y, (x, y) ∈ s j → (f x, f y) ∈ s' i) ∧
      (∀ j, p j → ∃ i, p' i ∧ ∀ x y, (f x, f y) ∈ s' i → (x, y) ∈ s j) :=
by simp [uniform_inducing_iff', h.uniform_continuous_iff h', (h'.comap _).le_basis_iff h,
  subset_def]

lemma uniform_inducing.mk' {f : α → β} (h : ∀ s, s ∈ 𝓤 α ↔
    ∃ t ∈ 𝓤 β, ∀ x y : α, (f x, f y) ∈ t → (x, y) ∈ s) : uniform_inducing f :=
⟨by simp [eq_comm, filter.ext_iff, subset_def, h]⟩

lemma uniform_inducing_id : uniform_inducing (@id α) :=
⟨by rw [← prod.map_def, prod.map_id, comap_id]⟩

lemma uniform_inducing.comp {g : β → γ} (hg : uniform_inducing g)
  {f : α → β} (hf : uniform_inducing f) : uniform_inducing (g ∘ f) :=
⟨by rw [← hf.1, ← hg.1, comap_comap]⟩

lemma uniform_inducing.basis_uniformity {f : α → β} (hf : uniform_inducing f)
  {ι : Sort*} {p : ι → Prop} {s : ι → set (β × β)} (H : (𝓤 β).has_basis p s) :
  (𝓤 α).has_basis p (λ i, prod.map f f ⁻¹' s i) :=
hf.1 ▸ H.comap _

lemma uniform_inducing.cauchy_map_iff {f : α → β} (hf : uniform_inducing f) {F : filter α} :
  cauchy (map f F) ↔ cauchy F :=
by simp only [cauchy, map_ne_bot_iff, prod_map_map_eq, map_le_iff_le_comap, ← hf.comap_uniformity]

lemma uniform_inducing_of_compose {f : α → β} {g : β → γ} (hf : uniform_continuous f)
  (hg : uniform_continuous g) (hgf : uniform_inducing (g ∘ f)) : uniform_inducing f :=
begin
  refine ⟨le_antisymm _ hf.le_comap⟩,
  rw [← hgf.1, ← prod.map_def, ← prod.map_def, ← prod.map_comp_map f f g g,
      ← @comap_comap _ _ _ _ (prod.map f f)],
  exact comap_mono hg.le_comap
end

lemma uniform_inducing.uniform_continuous {f : α → β}
  (hf : uniform_inducing f) : uniform_continuous f :=
(uniform_inducing_iff'.1 hf).1

lemma uniform_inducing.uniform_continuous_iff {f : α → β} {g : β → γ} (hg : uniform_inducing g) :
  uniform_continuous f ↔ uniform_continuous (g ∘ f) :=
by { dsimp only [uniform_continuous, tendsto],
  rw [← hg.comap_uniformity, ← map_le_iff_le_comap, filter.map_map] }

protected lemma uniform_inducing.inducing {f : α → β} (h : uniform_inducing f) : inducing f :=
begin
  unfreezingI { obtain rfl := h.comap_uniform_space },
  letI := uniform_space.comap f _,
  exact ⟨rfl⟩
end

lemma uniform_inducing.prod {α' : Type*} {β' : Type*} [uniform_space α'] [uniform_space β']
  {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_inducing e₁) (h₂ : uniform_inducing e₂) :
  uniform_inducing (λp:α×β, (e₁ p.1, e₂ p.2)) :=
⟨by simp [(∘), uniformity_prod, h₁.comap_uniformity.symm, h₂.comap_uniformity.symm,
           comap_inf, comap_comap]⟩

lemma uniform_inducing.dense_inducing {f : α → β} (h : uniform_inducing f) (hd : dense_range f) :
  dense_inducing f :=
{ dense   := hd,
  induced := h.inducing.induced }

protected lemma uniform_inducing.injective [t0_space α] {f : α → β} (h : uniform_inducing f) :
  injective f :=
h.inducing.injective

/-- A map `f : α → β` between uniform spaces is a *uniform embedding* if it is uniform inducing and
injective. If `α` is a separated space, then the latter assumption follows from the former. -/
@[mk_iff]
structure uniform_embedding (f : α → β) extends uniform_inducing f : Prop :=
(inj : function.injective f)

theorem uniform_embedding_iff' {f : α → β} :
  uniform_embedding f ↔ injective f ∧ uniform_continuous f ∧ comap (prod.map f f) (𝓤 β) ≤ 𝓤 α :=
by rw [uniform_embedding_iff, and_comm, uniform_inducing_iff']

theorem filter.has_basis.uniform_embedding_iff' {ι ι'} {p : ι → Prop} {p' : ι' → Prop} {s s'}
  (h : (𝓤 α).has_basis p s) (h' : (𝓤 β).has_basis p' s') {f : α → β} :
  uniform_embedding f ↔ injective f ∧
    (∀ i, p' i → ∃ j, p j ∧ ∀ x y, (x, y) ∈ s j → (f x, f y) ∈ s' i) ∧
      (∀ j, p j → ∃ i, p' i ∧ ∀ x y, (f x, f y) ∈ s' i → (x, y) ∈ s j) :=
by rw [uniform_embedding_iff, and_comm, h.uniform_inducing_iff h']

theorem filter.has_basis.uniform_embedding_iff {ι ι'} {p : ι → Prop} {p' : ι' → Prop} {s s'}
  (h : (𝓤 α).has_basis p s) (h' : (𝓤 β).has_basis p' s') {f : α → β} :
  uniform_embedding f ↔ injective f ∧ uniform_continuous f ∧
      (∀ j, p j → ∃ i, p' i ∧ ∀ x y, (f x, f y) ∈ s' i → (x, y) ∈ s j) :=
by simp only [h.uniform_embedding_iff' h', h.uniform_continuous_iff h', exists_prop]

lemma uniform_embedding_subtype_val {p : α → Prop} :
  uniform_embedding (subtype.val : subtype p → α) :=
{ comap_uniformity := rfl,
  inj := subtype.val_injective }

lemma uniform_embedding_subtype_coe {p : α → Prop} :
  uniform_embedding (coe : subtype p → α) :=
uniform_embedding_subtype_val

lemma uniform_embedding_set_inclusion {s t : set α} (hst : s ⊆ t) :
  uniform_embedding (inclusion hst) :=
{ comap_uniformity :=
    by { erw [uniformity_subtype, uniformity_subtype, comap_comap], congr },
  inj := inclusion_injective hst }

lemma uniform_embedding.comp {g : β → γ} (hg : uniform_embedding g)
  {f : α → β} (hf : uniform_embedding f) : uniform_embedding (g ∘ f) :=
{ inj := hg.inj.comp hf.inj,
  ..hg.to_uniform_inducing.comp hf.to_uniform_inducing }

lemma equiv.uniform_embedding {α β : Type*} [uniform_space α] [uniform_space β] (f : α ≃ β)
  (h₁ : uniform_continuous f) (h₂ : uniform_continuous f.symm) : uniform_embedding f :=
uniform_embedding_iff'.2 ⟨f.injective, h₁, by rwa [← equiv.prod_congr_apply, ← map_equiv_symm]⟩

theorem uniform_embedding_inl : uniform_embedding (sum.inl : α → α ⊕ β) :=
begin
  refine ⟨⟨_⟩, sum.inl_injective⟩,
  rw [sum.uniformity, comap_sup, comap_map, comap_eq_bot_iff_compl_range.2 _, sup_bot_eq],
  { refine mem_map.2 (univ_mem' _),
    simp },
  { exact sum.inl_injective.prod_map sum.inl_injective }
end

theorem uniform_embedding_inr : uniform_embedding (sum.inr : β → α ⊕ β) :=
begin
  refine ⟨⟨_⟩, sum.inr_injective⟩,
  rw [sum.uniformity, comap_sup, comap_eq_bot_iff_compl_range.2 _, comap_map, bot_sup_eq],
  { exact sum.inr_injective.prod_map sum.inr_injective },
  { refine mem_map.2 (univ_mem' _),
    simp },
end

/-- If the domain of a `uniform_inducing` map `f` is a `separated_space`, then `f` is injective,
hence it is a `uniform_embedding`. -/
protected theorem uniform_inducing.uniform_embedding [t0_space α] {f : α → β}
  (hf : uniform_inducing f) :
  uniform_embedding f :=
⟨hf, hf.injective⟩

theorem uniform_embedding_iff_uniform_inducing [t0_space α] {f : α → β} :
  uniform_embedding f ↔ uniform_inducing f :=
⟨uniform_embedding.to_uniform_inducing, uniform_inducing.uniform_embedding⟩

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is uniform inducing with respect to the discrete uniformity on `α`:
the preimage of `𝓤 β` under `prod.map f f` is the principal filter generated by the diagonal in
`α × α`. -/
lemma comap_uniformity_of_spaced_out {α} {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  comap (prod.map f f) (𝓤 β) = 𝓟 id_rel :=
begin
  refine le_antisymm _ (@refl_le_uniformity α (uniform_space.comap f ‹_›)),
  calc comap (prod.map f f) (𝓤 β) ≤ comap (prod.map f f) (𝓟 s) : comap_mono (le_principal_iff.2 hs)
  ... = 𝓟 (prod.map f f ⁻¹' s) : comap_principal
  ... ≤ 𝓟 id_rel : principal_mono.2 _,
  rintro ⟨x, y⟩, simpa [not_imp_not] using @hf x y
end

/-- If a map `f : α → β` sends any two distinct points to point that are **not** related by a fixed
`s ∈ 𝓤 β`, then `f` is a uniform embedding with respect to the discrete uniformity on `α`. -/
lemma uniform_embedding_of_spaced_out {α} {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  @uniform_embedding α β ⊥ ‹_› f :=
begin
  letI : uniform_space α := ⊥, haveI := discrete_topology_bot α,
  haveI : separated_space α := separated_iff_t2.2 infer_instance,
  exact uniform_inducing.uniform_embedding ⟨comap_uniformity_of_spaced_out hs hf⟩
end

protected lemma uniform_embedding.embedding {f : α → β} (h : uniform_embedding f) : embedding f :=
{ induced := h.to_uniform_inducing.inducing.induced,
  inj := h.inj }

lemma uniform_embedding.dense_embedding {f : α → β} (h : uniform_embedding f) (hd : dense_range f) :
  dense_embedding f :=
{ dense   := hd,
  inj     := h.inj,
  induced := h.embedding.induced }

lemma closed_embedding_of_spaced_out {α} [topological_space α] [discrete_topology α]
  [separated_space β] {f : α → β} {s : set (β × β)} (hs : s ∈ 𝓤 β)
  (hf : pairwise (λ x y, (f x, f y) ∉ s)) :
  closed_embedding f :=
begin
  unfreezingI { rcases (discrete_topology.eq_bot α) with rfl }, letI : uniform_space α := ⊥,
  exact { closed_range := is_closed_range_of_spaced_out hs hf,
          .. (uniform_embedding_of_spaced_out hs hf).embedding }
end

lemma closure_image_mem_nhds_of_uniform_inducing
  {s : set (α×α)} {e : α → β} (b : β)
  (he₁ : uniform_inducing e) (he₂ : dense_inducing e) (hs : s ∈ 𝓤 α) :
  ∃ a, closure (e '' {a' | (a, a') ∈ s}) ∈ 𝓝 b :=
have s ∈ comap (λp:α×α, (e p.1, e p.2)) (𝓤 β),
  from he₁.comap_uniformity.symm ▸ hs,
let ⟨t₁, ht₁u, ht₁⟩ := this in
have ht₁ : ∀p:α×α, (e p.1, e p.2) ∈ t₁ → p ∈ s, from ht₁,
let ⟨t₂, ht₂u, ht₂s, ht₂c⟩ := comp_symm_of_uniformity ht₁u in
let ⟨t, htu, hts, htc⟩ := comp_symm_of_uniformity ht₂u in
have preimage e {b' | (b, b') ∈ t₂} ∈ comap e (𝓝 b),
  from preimage_mem_comap $ mem_nhds_left b ht₂u,
let ⟨a, (ha : (b, e a) ∈ t₂)⟩ := (he₂.comap_nhds_ne_bot _).nonempty_of_mem this in
have ∀b' (s' : set (β × β)), (b, b') ∈ t → s' ∈ 𝓤 β →
  ({y : β | (b', y) ∈ s'} ∩ e '' {a' : α | (a, a') ∈ s}).nonempty,
  from assume b' s' hb' hs',
  have preimage e {b'' | (b', b'') ∈ s' ∩ t} ∈ comap e (𝓝 b'),
    from preimage_mem_comap $ mem_nhds_left b' $ inter_mem hs' htu,
  let ⟨a₂, ha₂s', ha₂t⟩ := (he₂.comap_nhds_ne_bot _).nonempty_of_mem this in
  have (e a, e a₂) ∈ t₁,
    from ht₂c $ prod_mk_mem_comp_rel (ht₂s ha) $ htc $ prod_mk_mem_comp_rel hb' ha₂t,
  have e a₂ ∈ {b'':β | (b', b'') ∈ s'} ∩ e '' {a' | (a, a') ∈ s},
    from ⟨ha₂s', mem_image_of_mem _ $ ht₁ (a, a₂) this⟩,
  ⟨_, this⟩,
have ∀b', (b, b') ∈ t → ne_bot (𝓝 b' ⊓ 𝓟 (e '' {a' | (a, a') ∈ s})),
begin
  intros b' hb',
  rw [nhds_eq_uniformity, lift'_inf_principal_eq, lift'_ne_bot_iff],
  exact assume s, this b' s hb',
  exact monotone_preimage.inter monotone_const
end,
have ∀b', (b, b') ∈ t → b' ∈ closure (e '' {a' | (a, a') ∈ s}),
  from assume b' hb', by rw [closure_eq_cluster_pts]; exact this b' hb',
⟨a, (𝓝 b).sets_of_superset (mem_nhds_left b htu) this⟩

lemma uniform_embedding_subtype_emb (p : α → Prop) {e : α → β} (ue : uniform_embedding e)
  (de : dense_embedding e) : uniform_embedding (dense_embedding.subtype_emb p e) :=
{ comap_uniformity := by simp [comap_comap, (∘), dense_embedding.subtype_emb,
           uniformity_subtype, ue.comap_uniformity.symm],
  inj := (de.subtype p).inj }

lemma uniform_embedding.prod {α' : Type*} {β' : Type*} [uniform_space α'] [uniform_space β']
  {e₁ : α → α'} {e₂ : β → β'} (h₁ : uniform_embedding e₁) (h₂ : uniform_embedding e₂) :
  uniform_embedding (λp:α×β, (e₁ p.1, e₂ p.2)) :=
{ inj := h₁.inj.prod_map h₂.inj,
  ..h₁.to_uniform_inducing.prod h₂.to_uniform_inducing }

lemma is_complete_of_complete_image {m : α → β} {s : set α} (hm : uniform_inducing m)
  (hs : is_complete (m '' s)) : is_complete s :=
begin
  intros f hf hfs,
  rw le_principal_iff at hfs,
  obtain ⟨_, ⟨x, hx, rfl⟩, hyf⟩ : ∃ y ∈ m '' s, map m f ≤ 𝓝 y,
    from hs (f.map m) (hf.map hm.uniform_continuous)
      (le_principal_iff.2 (image_mem_map hfs)),
  rw [map_le_iff_le_comap, ← nhds_induced, ← hm.inducing.induced] at hyf,
  exact ⟨x, hx, hyf⟩
end

lemma is_complete.complete_space_coe {s : set α} (hs : is_complete s) :
  complete_space s :=
complete_space_iff_is_complete_univ.2 $
  is_complete_of_complete_image uniform_embedding_subtype_coe.to_uniform_inducing $ by simp [hs]

/-- A set is complete iff its image under a uniform inducing map is complete. -/
lemma is_complete_image_iff {m : α → β} {s : set α} (hm : uniform_inducing m) :
  is_complete (m '' s) ↔ is_complete s :=
begin
  refine ⟨is_complete_of_complete_image hm, λ c, _⟩,
  haveI : complete_space s := c.complete_space_coe,
  set m' : s → β := m ∘ coe,
  suffices : is_complete (range m'), by rwa [range_comp, subtype.range_coe] at this,
  have hm' : uniform_inducing m' := hm.comp uniform_embedding_subtype_coe.to_uniform_inducing,
  intros f hf hfm,
  rw filter.le_principal_iff at hfm,
  have cf' : cauchy (comap m' f) :=
    hf.comap' hm'.comap_uniformity.le (ne_bot.comap_of_range_mem hf.1 hfm),
  rcases complete_space.complete cf' with ⟨x, hx⟩,
  rw [hm'.inducing.nhds_eq_comap, comap_le_comap_iff hfm] at hx,
  use [m' x, mem_range_self _, hx]
end

lemma complete_space_iff_is_complete_range {f : α → β} (hf : uniform_inducing f) :
  complete_space α ↔ is_complete (range f) :=
by rw [complete_space_iff_is_complete_univ, ← is_complete_image_iff hf, image_univ]

lemma uniform_inducing.is_complete_range [complete_space α] {f : α → β}
  (hf : uniform_inducing f) :
  is_complete (range f) :=
(complete_space_iff_is_complete_range hf).1 ‹_›

lemma complete_space_congr {e : α ≃ β} (he : uniform_embedding e) :
  complete_space α ↔ complete_space β :=
by rw [complete_space_iff_is_complete_range he.to_uniform_inducing, e.range_eq_univ,
  complete_space_iff_is_complete_univ]

lemma complete_space_coe_iff_is_complete {s : set α} :
  complete_space s ↔ is_complete s :=
(complete_space_iff_is_complete_range uniform_embedding_subtype_coe.to_uniform_inducing).trans $
  by rw [subtype.range_coe]

lemma is_closed.complete_space_coe [complete_space α] {s : set α} (hs : is_closed s) :
  complete_space s :=
hs.is_complete.complete_space_coe

/-- The lift of a complete space to another universe is still complete. -/
instance ulift.complete_space [h : complete_space α] : complete_space (ulift α) :=
begin
  have : uniform_embedding (@equiv.ulift α), from ⟨⟨rfl⟩, ulift.down_injective⟩,
  exact (complete_space_congr this).2 h,
end

lemma complete_space_extension {m : β → α} (hm : uniform_inducing m) (dense : dense_range m)
  (h : ∀f:filter β, cauchy f → ∃x:α, map m f ≤ 𝓝 x) : complete_space α :=
⟨assume (f : filter α), assume hf : cauchy f,
let
  p : set (α × α) → set α → set α := λs t, {y : α| ∃x:α, x ∈ t ∧ (x, y) ∈ s},
  g := (𝓤 α).lift (λs, f.lift' (p s))
in
have mp₀ : monotone p,
  from assume a b h t s ⟨x, xs, xa⟩, ⟨x, xs, h xa⟩,
have mp₁ : ∀{s}, monotone (p s),
  from assume s a b h x ⟨y, ya, yxs⟩, ⟨y, h ya, yxs⟩,

have f ≤ g, from
  le_infi $ assume s, le_infi $ assume hs, le_infi $ assume t, le_infi $ assume ht,
  le_principal_iff.mpr $
  mem_of_superset ht $ assume x hx, ⟨x, hx, refl_mem_uniformity hs⟩,

have ne_bot g, from hf.left.mono this,

have ne_bot (comap m g), from comap_ne_bot $ assume t ht,
  let ⟨t', ht', ht_mem⟩ := (mem_lift_sets $ monotone_lift' monotone_const mp₀).mp ht in
  let ⟨t'', ht'', ht'_sub⟩ := (mem_lift'_sets mp₁).mp ht_mem in
  let ⟨x, (hx : x ∈ t'')⟩ := hf.left.nonempty_of_mem ht'' in
  have h₀ : ne_bot (𝓝[range m] x),
    from dense.nhds_within_ne_bot x,
  have h₁ : {y | (x, y) ∈ t'} ∈ 𝓝[range m] x,
    from @mem_inf_of_left α (𝓝 x) (𝓟 (range m)) _ $ mem_nhds_left x ht',
  have h₂ : range m ∈ 𝓝[range m] x,
    from @mem_inf_of_right α (𝓝 x) (𝓟 (range m)) _ $ subset.refl _,
  have {y | (x, y) ∈ t'} ∩ range m ∈ 𝓝[range m] x,
    from @inter_mem α (𝓝[range m] x) _ _ h₁ h₂,
  let ⟨y, xyt', b, b_eq⟩ := h₀.nonempty_of_mem this in
  ⟨b, b_eq.symm ▸ ht'_sub ⟨x, hx, xyt'⟩⟩,

have cauchy g, from
  ⟨‹ne_bot g›, assume s hs,
  let
    ⟨s₁, hs₁, (comp_s₁ : comp_rel s₁ s₁ ⊆ s)⟩ := comp_mem_uniformity_sets hs,
    ⟨s₂, hs₂, (comp_s₂ : comp_rel s₂ s₂ ⊆ s₁)⟩ := comp_mem_uniformity_sets hs₁,
    ⟨t, ht, (prod_t : t ×ˢ t ⊆ s₂)⟩ := mem_prod_same_iff.mp (hf.right hs₂)
  in
  have hg₁ : p (preimage prod.swap s₁) t ∈ g,
    from mem_lift (symm_le_uniformity hs₁) $ @mem_lift' α α f _ t ht,
  have hg₂ : p s₂ t ∈ g,
    from mem_lift hs₂ $ @mem_lift' α α f _ t ht,
  have hg : p (prod.swap ⁻¹' s₁) t ×ˢ p s₂ t ∈ g ×ᶠ g,
    from @prod_mem_prod α α _ _ g g hg₁ hg₂,
  (g ×ᶠ g).sets_of_superset hg
    (assume ⟨a, b⟩ ⟨⟨c₁, c₁t, hc₁⟩, ⟨c₂, c₂t, hc₂⟩⟩,
      have (c₁, c₂) ∈ t ×ˢ t, from ⟨c₁t, c₂t⟩,
      comp_s₁ $ prod_mk_mem_comp_rel hc₁ $
      comp_s₂ $ prod_mk_mem_comp_rel (prod_t this) hc₂)⟩,

have cauchy (filter.comap m g),
  from ‹cauchy g›.comap' (le_of_eq hm.comap_uniformity) ‹_›,

let ⟨x, (hx : map m (filter.comap m g) ≤ 𝓝 x)⟩ := h _ this in
have cluster_pt x (map m (filter.comap m g)),
  from (le_nhds_iff_adhp_of_cauchy (this.map hm.uniform_continuous)).mp hx,
have cluster_pt x g,
  from  this.mono map_comap_le,

⟨x, calc f ≤ g : by assumption
  ... ≤ 𝓝 x : le_nhds_of_cauchy_adhp ‹cauchy g› this⟩⟩

lemma totally_bounded_preimage {f : α → β} {s : set β} (hf : uniform_embedding f)
  (hs : totally_bounded s) : totally_bounded (f ⁻¹' s) :=
λ t ht, begin
  rw ← hf.comap_uniformity at ht,
  rcases mem_comap.2 ht with ⟨t', ht', ts⟩,
  rcases totally_bounded_iff_subset.1
    (totally_bounded_subset (image_preimage_subset f s) hs) _ ht' with ⟨c, cs, hfc, hct⟩,
  refine ⟨f ⁻¹' c, hfc.preimage (hf.inj.inj_on _), λ x h, _⟩,
  have := hct (mem_image_of_mem f h), simp at this ⊢,
  rcases this with ⟨z, zc, zt⟩,
  rcases cs zc with ⟨y, yc, rfl⟩,
  exact ⟨y, zc, ts (by exact zt)⟩
end

instance complete_space.sum [complete_space α] [complete_space β] :
  complete_space (α ⊕ β) :=
begin
  rw [complete_space_iff_is_complete_univ, ← range_inl_union_range_inr],
  exact uniform_embedding_inl.to_uniform_inducing.is_complete_range.union
    uniform_embedding_inr.to_uniform_inducing.is_complete_range
end

end

lemma uniform_embedding_comap {α : Type*} {β : Type*} {f : α → β} [u : uniform_space β]
  (hf : function.injective f) : @uniform_embedding α β (uniform_space.comap f u) u f :=
@uniform_embedding.mk _ _ (uniform_space.comap f u) _ _
  (@uniform_inducing.mk _ _ (uniform_space.comap f u) _ _ rfl) hf

/-- Pull back a uniform space structure by an embedding, adjusting the new uniform structure to
make sure that its topology is defeq to the original one. -/
def embedding.comap_uniform_space {α β} [topological_space α] [u : uniform_space β] (f : α → β)
  (h : embedding f) : uniform_space α :=
(u.comap f).replace_topology h.induced

lemma embedding.to_uniform_embedding {α β} [topological_space α] [u : uniform_space β] (f : α → β)
  (h : embedding f) :
  @uniform_embedding α β (h.comap_uniform_space f) u f :=
{ comap_uniformity := rfl,
  inj := h.inj }

section uniform_extension

variables {α : Type*} {β : Type*} {γ : Type*}
          [uniform_space α] [uniform_space β] [uniform_space γ]
          {e : β → α}
          (h_e : uniform_inducing e)
          (h_dense : dense_range e)
          {f : β → γ}
          (h_f : uniform_continuous f)

local notation `ψ` := (h_e.dense_inducing h_dense).extend f

lemma uniformly_extend_exists [complete_space γ] (a : α) :
  ∃c, tendsto f (comap e (𝓝 a)) (𝓝 c) :=
let de := (h_e.dense_inducing h_dense) in
have cauchy (𝓝 a), from cauchy_nhds,
have cauchy (comap e (𝓝 a)), from
  this.comap' (le_of_eq h_e.comap_uniformity) (de.comap_nhds_ne_bot _),
have cauchy (map f (comap e (𝓝 a))), from this.map h_f,
complete_space.complete this

lemma uniform_extend_subtype [complete_space γ]
  {p : α → Prop} {e : α → β} {f : α → γ} {b : β} {s : set α}
  (hf : uniform_continuous (λx:subtype p, f x.val))
  (he : uniform_embedding e) (hd : ∀x:β, x ∈ closure (range e))
  (hb : closure (e '' s) ∈ 𝓝 b) (hs : is_closed s) (hp : ∀x∈s, p x) :
  ∃c, tendsto f (comap e (𝓝 b)) (𝓝 c) :=
have de : dense_embedding e,
  from he.dense_embedding hd,
have de' : dense_embedding (dense_embedding.subtype_emb p e),
  by exact de.subtype p,
have ue' : uniform_embedding (dense_embedding.subtype_emb p e),
  from uniform_embedding_subtype_emb _ he de,
have b ∈ closure (e '' {x | p x}),
  from (closure_mono $ monotone_image $ hp) (mem_of_mem_nhds hb),
let ⟨c, (hc : tendsto (f ∘ subtype.val)
     (comap (dense_embedding.subtype_emb p e) (𝓝 ⟨b, this⟩)) (𝓝 c))⟩ :=
  uniformly_extend_exists ue'.to_uniform_inducing de'.dense hf _ in
begin
  rw [nhds_subtype_eq_comap] at hc,
  simp [comap_comap] at hc,
  change (tendsto (f ∘ @subtype.val α p) (comap (e ∘ @subtype.val α p) (𝓝 b)) (𝓝 c)) at hc,
  rw [←comap_comap, tendsto_comap'_iff] at hc,
  exact ⟨c, hc⟩,
  exact ⟨_, hb, assume x,
    begin
      change e x ∈ (closure (e '' s)) → x ∈ range subtype.val,
      rw [← closure_induced, mem_closure_iff_cluster_pt, cluster_pt, ne_bot_iff,
          nhds_induced, ← de.to_dense_inducing.nhds_eq_comap,
          ← mem_closure_iff_nhds_ne_bot, hs.closure_eq],
      exact assume hxs, ⟨⟨x, hp x hxs⟩, rfl⟩,
    end⟩
end

include h_f

lemma uniformly_extend_spec [complete_space γ] (a : α) :
  tendsto f (comap e (𝓝 a)) (𝓝 (ψ a)) :=
by simpa only [dense_inducing.extend] using tendsto_nhds_lim (uniformly_extend_exists h_e ‹_› h_f _)

lemma uniform_continuous_uniformly_extend [cγ : complete_space γ] : uniform_continuous ψ :=
assume d hd,
let ⟨s, hs, hs_comp⟩ := (mem_lift'_sets $
  monotone_id.comp_rel $ monotone_id.comp_rel monotone_id).mp
    (comp_le_uniformity3 hd) in
have h_pnt : ∀{a m}, m ∈ 𝓝 a → ∃c, c ∈ f '' preimage e m ∧ (c, ψ a) ∈ s ∧ (ψ a, c) ∈ s,
  from assume a m hm,
  have nb : ne_bot (map f (comap e (𝓝 a))),
    from ((h_e.dense_inducing h_dense).comap_nhds_ne_bot _).map _,
  have (f '' preimage e m) ∩ ({c | (c, ψ a) ∈ s } ∩ {c | (ψ a, c) ∈ s }) ∈ map f (comap e (𝓝 a)),
    from inter_mem (image_mem_map $ preimage_mem_comap $ hm)
      (uniformly_extend_spec h_e h_dense h_f _
        (inter_mem (mem_nhds_right _ hs) (mem_nhds_left _ hs))),
  nb.nonempty_of_mem this,
have preimage (λp:β×β, (f p.1, f p.2)) s ∈ 𝓤 β,
  from h_f hs,
have preimage (λp:β×β, (f p.1, f p.2)) s ∈ comap (λx:β×β, (e x.1, e x.2)) (𝓤 α),
  by rwa [h_e.comap_uniformity.symm] at this,
let ⟨t, ht, ts⟩ := this in
show preimage (λp:(α×α), (ψ p.1, ψ p.2)) d ∈ 𝓤 α,
  from (𝓤 α).sets_of_superset (interior_mem_uniformity ht) $
  assume ⟨x₁, x₂⟩ hx_t,
  have 𝓝 (x₁, x₂) ≤ 𝓟 (interior t),
    from is_open_iff_nhds.mp is_open_interior (x₁, x₂) hx_t,
  have interior t ∈ 𝓝 x₁ ×ᶠ 𝓝 x₂,
    by rwa [nhds_prod_eq, le_principal_iff] at this,
  let ⟨m₁, hm₁, m₂, hm₂, (hm : m₁ ×ˢ m₂ ⊆ interior t)⟩ := mem_prod_iff.mp this in
  let ⟨a, ha₁, _, ha₂⟩ := h_pnt hm₁ in
  let ⟨b, hb₁, hb₂, _⟩ := h_pnt hm₂ in
  have (e ⁻¹' m₁) ×ˢ (e ⁻¹' m₂) ⊆ (λ p : β × β, (f p.1, f p.2)) ⁻¹' s,
    from calc _ ⊆ preimage (λp:(β×β), (e p.1, e p.2)) (interior t) : preimage_mono hm
    ... ⊆ preimage (λp:(β×β), (e p.1, e p.2)) t : preimage_mono interior_subset
    ... ⊆ preimage (λp:(β×β), (f p.1, f p.2)) s : ts,
  have (f '' (e ⁻¹' m₁)) ×ˢ (f '' (e ⁻¹' m₂)) ⊆ s,
    from calc (f '' (e ⁻¹' m₁)) ×ˢ (f '' (e ⁻¹' m₂)) =
      (λp:(β×β), (f p.1, f p.2)) '' ((e ⁻¹' m₁) ×ˢ (e ⁻¹' m₂)) : prod_image_image_eq
    ... ⊆ (λp:(β×β), (f p.1, f p.2)) '' ((λp:(β×β), (f p.1, f p.2)) ⁻¹' s) : monotone_image this
    ... ⊆ s : image_preimage_subset _ _,
  have (a, b) ∈ s, from @this (a, b) ⟨ha₁, hb₁⟩,
  hs_comp $ show (ψ x₁, ψ x₂) ∈ comp_rel s (comp_rel s s),
    from ⟨a, ha₂, ⟨b, this, hb₂⟩⟩

omit h_f

variables [separated_space γ]

lemma uniformly_extend_of_ind (b : β) : ψ (e b) = f b :=
dense_inducing.extend_eq_at _ h_f.continuous.continuous_at

lemma uniformly_extend_unique {g : α → γ} (hg : ∀ b, g (e b) = f b)
  (hc : continuous g) :
  ψ = g :=
dense_inducing.extend_unique _ hg hc

end uniform_extension


/-
Copyright (c) 2021 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers

! This file was ported from Lean 3 source module linear_algebra.multilinear.basis
! leanprover-community/mathlib commit ce11c3c2a285bbe6937e26d9792fda4e51f3fe1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Basis
import Mathbin.LinearAlgebra.Multilinear.Basic

/-!
# Multilinear maps in relation to bases.

This file proves lemmas about the action of multilinear maps on basis vectors.

## TODO

 * Refactor the proofs in terms of bases of tensor products, once there is an equivalent of
   `basis.tensor_product` for `pi_tensor_product`.

-/

open MultilinearMap

variable {R : Type _} {ι : Type _} {n : ℕ} {M : Fin n → Type _} {M₂ : Type _} {M₃ : Type _}

variable [CommSemiring R] [AddCommMonoid M₂] [AddCommMonoid M₃] [∀ i, AddCommMonoid (M i)]

variable [∀ i, Module R (M i)] [Module R M₂] [Module R M₃]

/-- Two multilinear maps indexed by `fin n` are equal if they are equal when all arguments are
basis vectors. -/
theorem Basis.ext_multilinear_fin {f g : MultilinearMap R M M₂} {ι₁ : Fin n → Type _}
    (e : ∀ i, Basis (ι₁ i) R (M i))
    (h : ∀ v : ∀ i, ι₁ i, (f fun i => e i (v i)) = g fun i => e i (v i)) : f = g :=
  by
  induction' n with m hm
  · ext x
    convert h finZeroElim
  · apply Function.LeftInverse.injective uncurry_curry_left
    refine' Basis.ext (e 0) _
    intro i
    apply hm (Fin.tail e)
    intro j
    convert h (Fin.cons i j)
    iterate 2
      rw [curry_left_apply]
      congr 1 with x
      refine' Fin.cases rfl (fun x => _) x
      dsimp [Fin.tail]
      rw [Fin.cons_succ, Fin.cons_succ]
#align basis.ext_multilinear_fin Basis.ext_multilinear_fin

/-- Two multilinear maps indexed by a `fintype` are equal if they are equal when all arguments
are basis vectors. Unlike `basis.ext_multilinear_fin`, this only uses a single basis; a
dependently-typed version would still be true, but the proof would need a dependently-typed
version of `dom_dom_congr`. -/
theorem Basis.ext_multilinear [Finite ι] {f g : MultilinearMap R (fun i : ι => M₂) M₃} {ι₁ : Type _}
    (e : Basis ι₁ R M₂) (h : ∀ v : ι → ι₁, (f fun i => e (v i)) = g fun i => e (v i)) : f = g :=
  by
  cases nonempty_fintype ι
  exact
    (dom_dom_congr_eq_iff (Fintype.equivFin ι) f g).mp
      (Basis.ext_multilinear_fin (fun i => e) fun i => h (i ∘ _))
#align basis.ext_multilinear Basis.ext_multilinear