/-
Chapter 6: Soundness and Completeness
Author: Billy Price
-/
import definitions chapter5

namespace nat_deduction

def soundness {X : set Form} {A : Form} : X ⊢I A → X ⊨ A :=
begin
  rintro ⟨XdA⟩,
  induction' XdA,
  case assumption {tauto},
  case and_intro {apply boolean.and_iff.mpr, tidy },
  case and_left {rw boolean.and_iff at *, tidy },
  case and_right {rw boolean.and_iff at *, tidy },
  case imp_intro {apply boolean.imp_iff.mpr, tidy},
  case imp_elim {rw boolean.imp_iff at *, rw ←set.union_self X, apply boolean.valid_cut A, tidy },
  case or_left { intros M hM, simp, exact or.inl (ih _ hM) },
  case or_right { intros M hM, simp, exact or.inr (ih _ hM) },
  case or_elim : X A B C _ _ _ ihAB ihA ihB
    { intros M hM,
      specialize ihAB M hM, simp * at *,
      cases ihAB,
        apply ihA, simp, tidy,
        apply ihB, simp, tidy, },
  case falsum { intros M hM, specialize ih M hM, contradiction }
end

theorem not_provable_atomic : ∀ p : ℕ, ¬ (∅ ⊢I p) :=
begin
  rintros p hp,
  apply absurd (soundness hp),
  intro mp,
  specialize mp ∅, simp * at *,
end

namespace intuitionistic

def maximal_avoiding (A : Form) : Type := { X : set Form // ¬(X ⊢I A) ∧ ∀ B ∉ X, X ∪ {B} ⊢I A}

namespace maximal

variables {X Y : set Form}
variables {A B C : Form}

open classical
local attribute [instance] prop_decidable

lemma mem_of_provable (X : maximal_avoiding A) : X.1 ⊢I B → B ∈ X.1 :=
begin
  rcases X with ⟨X,nXdA,hX⟩,
  rintro XpB, simp at *,
  by_contradiction h,
  apply nXdA,
  rw ←set.union_self X,
  apply provable.cut B _ XpB,
  exact hX _ h
end

lemma bot_not_mem (X : maximal_avoiding A) : (⊥ : Form) ∉ X.1 :=
begin
  intro bmem,
  apply X.2.1,
  apply provable.explosion,
  constructor, assump,
end

lemma and_mem_iff (X : maximal_avoiding A) : B ⋀ C ∈ X.1 ↔ B ∈ X.1 ∧ C ∈ X.1 :=
begin
  rcases X with ⟨X,XnA,hX⟩,
  split,
    intro mBC, split; apply mem_of_provable; simp * at *,
    constructor, apply ⋀E₁ B C, assump,
    constructor, apply ⋀E₂ B C, assump,
  rintros ⟨mB, mC⟩,
  apply mem_of_provable, simp,
  constructor, apply ⋀I; assump
end

lemma or_mem_iff (X : maximal_avoiding A) : B ⋁ C ∈ X.1 ↔ B ∈ X.1 ∨ C ∈ X.1 :=
begin
  split,
    intro mBC,
    by_contradiction h,
    rw not_or_distrib at h,
    rcases X with ⟨X, nXpA, hX⟩,
    rcases hX B h.1 with hB,
    rcases hX C h.2 with hC,
    apply nXpA, constructor,
    apply ⋁E B C, assump, assumption, assumption,
  rintro (mB | mC); apply mem_of_provable; constructor,
  apply ⋁I₁, assump,
  apply ⋁I₂, assump
end

lemma or_of_imp_mem (X : maximal_avoiding A) : B ⟹ C ∈ X.1 → B ∉ X.1 ∨ C ∈ X.1 :=
begin
  intro mBC,
  by_cases B ∈ X.val,
  apply or.inr,
  apply mem_of_provable,
  constructor,
  apply ⟹E B; assump,
  exact or.inl h
end

lemma nmem_of_neg_mem (X : maximal_avoiding A) : (¬ B) ∈ X.1 → B ∉ X.1 :=
begin
  intro nbmem,
  cases or_of_imp_mem X nbmem, assumption,
  apply absurd h,
  exact bot_not_mem _
end

end maximal

end intuitionistic

/-TODO: Lemma 5. If X is a maximal A-avoiding set in a logic L that at least
contains all of the rules of classical logic, then X also satisfies the
following conditions:
  * ¬B ∈ X iff. B ∉ X
  * B ⟹ C ∈ X iff. B ∉ X or C ∈ X

(Will require classical logic provability)
-/

/-TODO: Lemma 6. If X is a maximal A-avoiding set in a logic L that
contains all of the rules of classical logic, then there is some valuation v_X
where for any formula B,
 * v_X(B) iff. B ∈ X
-/

/-TODO: Lemma 7. For any logic L, if X ⊬L A then there is some maximal A-excluding
set Y where Y ⊆ X -/

/-TODO: Completeness of Classical Logic-/

section heyting_algebra

universe u

class heyting_alegebra (α : Type u) extends bounded_lattice α :=
(imp : α → α → α)
(imp_prop : ∀ x y z : α, x ⊓ y ≤ z ↔ x ≤ imp y z)

-- Define valuation on a heyting algebra

end heyting_algebra

/-TODO: Chapter 6 Exercises-/

end nat_deduction


/-
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, Mario Carneiro
-/
import topology.bases
import topology.uniform_space.basic
/-!
# Theory of Cauchy filters in uniform spaces. Complete uniform spaces. Totally bounded subsets.
-/
universes u v

open filter topological_space set classical uniform_space
open_locale classical uniformity topological_space filter

variables {α : Type u} {β : Type v} [uniform_space α]

/-- A filter `f` is Cauchy if for every entourage `r`, there exists an
  `s ∈ f` such that `s × s ⊆ r`. This is a generalization of Cauchy
  sequences, because if `a : ℕ → α` then the filter of sets containing
  cofinitely many of the `a n` is Cauchy iff `a` is a Cauchy sequence. -/
def cauchy (f : filter α) := ne_bot f ∧ f ×ᶠ f ≤ (𝓤 α)

/-- A set `s` is called *complete*, if any Cauchy filter `f` such that `s ∈ f`
has a limit in `s` (formally, it satisfies `f ≤ 𝓝 x` for some `x ∈ s`). -/
def is_complete (s : set α) := ∀f, cauchy f → f ≤ 𝓟 s → ∃x∈s, f ≤ 𝓝 x

lemma filter.has_basis.cauchy_iff {ι} {p : ι → Prop} {s : ι → set (α × α)} (h : (𝓤 α).has_basis p s)
  {f : filter α} :
  cauchy f ↔ (ne_bot f ∧ (∀ i, p i → ∃ t ∈ f, ∀ x y ∈ t, (x, y) ∈ s i)) :=
and_congr iff.rfl $ (f.basis_sets.prod_self.le_basis_iff h).trans $
  by simp only [subset_def, prod.forall, mem_prod_eq, and_imp, id, ball_mem_comm]

lemma cauchy_iff' {f : filter α} :
  cauchy f ↔ (ne_bot f ∧ (∀ s ∈ 𝓤 α, ∃t∈f, ∀ x y ∈ t, (x, y) ∈ s)) :=
(𝓤 α).basis_sets.cauchy_iff

lemma cauchy_iff {f : filter α} :
  cauchy f ↔ (ne_bot f ∧ (∀ s ∈ 𝓤 α, ∃t∈f, t ×ˢ t ⊆ s)) :=
cauchy_iff'.trans $ by simp only [subset_def, prod.forall, mem_prod_eq, and_imp, id, ball_mem_comm]

lemma cauchy_map_iff {l : filter β} {f : β → α} :
  cauchy (l.map f) ↔ (ne_bot l ∧ tendsto (λp:β×β, (f p.1, f p.2)) (l ×ᶠ l) (𝓤 α)) :=
by rw [cauchy, map_ne_bot_iff, prod_map_map_eq, tendsto]

lemma cauchy_map_iff' {l : filter β} [hl : ne_bot l] {f : β → α} :
  cauchy (l.map f) ↔ tendsto (λp:β×β, (f p.1, f p.2)) (l ×ᶠ l) (𝓤 α) :=
cauchy_map_iff.trans $ and_iff_right hl

lemma cauchy.mono {f g : filter α} [hg : ne_bot g] (h_c : cauchy f) (h_le : g ≤ f) : cauchy g :=
⟨hg, le_trans (filter.prod_mono h_le h_le) h_c.right⟩

lemma cauchy.mono' {f g : filter α} (h_c : cauchy f) (hg : ne_bot g) (h_le : g ≤ f) : cauchy g :=
h_c.mono h_le

lemma cauchy_nhds {a : α} : cauchy (𝓝 a) :=
⟨nhds_ne_bot, nhds_prod_eq.symm.trans_le (nhds_le_uniformity a)⟩

lemma cauchy_pure {a : α} : cauchy (pure a) :=
cauchy_nhds.mono (pure_le_nhds a)

lemma filter.tendsto.cauchy_map {l : filter β} [ne_bot l] {f : β → α} {a : α}
  (h : tendsto f l (𝓝 a)) :
  cauchy (map f l) :=
cauchy_nhds.mono h

lemma cauchy.prod [uniform_space β] {f : filter α} {g : filter β} (hf : cauchy f) (hg : cauchy g) :
  cauchy (f ×ᶠ g) :=
begin
  refine ⟨hf.1.prod hg.1, _⟩,
  simp only [uniformity_prod, le_inf_iff, ← map_le_iff_le_comap, ← prod_map_map_eq],
  exact ⟨le_trans (prod_mono tendsto_fst tendsto_fst) hf.2,
    le_trans (prod_mono tendsto_snd tendsto_snd) hg.2⟩
end

/-- The common part of the proofs of `le_nhds_of_cauchy_adhp` and
`sequentially_complete.le_nhds_of_seq_tendsto_nhds`: if for any entourage `s`
one can choose a set `t ∈ f` of diameter `s` such that it contains a point `y`
with `(x, y) ∈ s`, then `f` converges to `x`. -/
lemma le_nhds_of_cauchy_adhp_aux {f : filter α} {x : α}
  (adhs : ∀ s ∈ 𝓤 α, ∃ t ∈ f, (t ×ˢ t ⊆ s) ∧ ∃ y, (x, y) ∈ s ∧ y ∈ t) :
  f ≤ 𝓝 x :=
begin
  -- Consider a neighborhood `s` of `x`
  assume s hs,
  -- Take an entourage twice smaller than `s`
  rcases comp_mem_uniformity_sets (mem_nhds_uniformity_iff_right.1 hs) with ⟨U, U_mem, hU⟩,
  -- Take a set `t ∈ f`, `t × t ⊆ U`, and a point `y ∈ t` such that `(x, y) ∈ U`
  rcases adhs U U_mem with ⟨t, t_mem, ht, y, hxy, hy⟩,
  apply mem_of_superset t_mem,
  -- Given a point `z ∈ t`, we have `(x, y) ∈ U` and `(y, z) ∈ t × t ⊆ U`, hence `z ∈ s`
  exact (λ z hz, hU (prod_mk_mem_comp_rel hxy (ht $ mk_mem_prod hy hz)) rfl)
end

/-- If `x` is an adherent (cluster) point for a Cauchy filter `f`, then it is a limit point
for `f`. -/
lemma le_nhds_of_cauchy_adhp {f : filter α} {x : α} (hf : cauchy f)
  (adhs : cluster_pt x f) : f ≤ 𝓝 x :=
le_nhds_of_cauchy_adhp_aux
begin
  assume s hs,
  obtain ⟨t, t_mem, ht⟩ : ∃ t ∈ f, t ×ˢ t ⊆ s,
    from (cauchy_iff.1 hf).2 s hs,
  use [t, t_mem, ht],
  exact (forall_mem_nonempty_iff_ne_bot.2 adhs _
    (inter_mem_inf (mem_nhds_left x hs) t_mem ))
end

lemma le_nhds_iff_adhp_of_cauchy {f : filter α} {x : α} (hf : cauchy f) :
  f ≤ 𝓝 x ↔ cluster_pt x f :=
⟨assume h, cluster_pt.of_le_nhds' h hf.1, le_nhds_of_cauchy_adhp hf⟩

lemma cauchy.map [uniform_space β] {f : filter α} {m : α → β}
  (hf : cauchy f) (hm : uniform_continuous m) : cauchy (map m f) :=
⟨hf.1.map _,
  calc map m f ×ᶠ map m f = map (λp:α×α, (m p.1, m p.2)) (f ×ᶠ f) : filter.prod_map_map_eq
    ... ≤ map (λp:α×α, (m p.1, m p.2)) (𝓤 α) : map_mono hf.right
    ... ≤ 𝓤 β : hm⟩

lemma cauchy.comap [uniform_space β] {f : filter β} {m : α → β}
  (hf : cauchy f) (hm : comap (λp:α×α, (m p.1, m p.2)) (𝓤 β) ≤ 𝓤 α)
  [ne_bot (comap m f)] : cauchy (comap m f) :=
⟨‹_›,
  calc comap m f ×ᶠ comap m f = comap (λp:α×α, (m p.1, m p.2)) (f ×ᶠ f) : filter.prod_comap_comap_eq
    ... ≤ comap (λp:α×α, (m p.1, m p.2)) (𝓤 β) : comap_mono hf.right
    ... ≤ 𝓤 α : hm⟩

lemma cauchy.comap' [uniform_space β] {f : filter β} {m : α → β}
  (hf : cauchy f) (hm : comap (λp:α×α, (m p.1, m p.2)) (𝓤 β) ≤ 𝓤 α)
  (hb : ne_bot (comap m f)) : cauchy (comap m f) :=
hf.comap hm

/-- Cauchy sequences. Usually defined on ℕ, but often it is also useful to say that a function
defined on ℝ is Cauchy at +∞ to deduce convergence. Therefore, we define it in a type class that
is general enough to cover both ℕ and ℝ, which are the main motivating examples. -/
def cauchy_seq [semilattice_sup β] (u : β → α) := cauchy (at_top.map u)

lemma cauchy_seq.tendsto_uniformity [semilattice_sup β] {u : β → α} (h : cauchy_seq u) :
  tendsto (prod.map u u) at_top (𝓤 α) :=
by simpa only [tendsto, prod_map_map_eq', prod_at_top_at_top_eq] using h.right

lemma cauchy_seq.nonempty [semilattice_sup β] {u : β → α} (hu : cauchy_seq u) : nonempty β :=
@nonempty_of_ne_bot _ _ $ (map_ne_bot_iff _).1 hu.1

lemma cauchy_seq.mem_entourage {β : Type*} [semilattice_sup β] {u : β → α}
  (h : cauchy_seq u) {V : set (α × α)} (hV : V ∈ 𝓤 α) :
  ∃ k₀, ∀ i j, k₀ ≤ i → k₀ ≤ j → (u i, u j) ∈ V :=
begin
  haveI := h.nonempty,
  have := h.tendsto_uniformity, rw ← prod_at_top_at_top_eq at this,
  simpa [maps_to] using at_top_basis.prod_self.tendsto_left_iff.1 this V hV
end

lemma filter.tendsto.cauchy_seq [semilattice_sup β] [nonempty β] {f : β → α} {x}
  (hx : tendsto f at_top (𝓝 x)) :
  cauchy_seq f :=
hx.cauchy_map

lemma cauchy_seq_const (x : α) : cauchy_seq (λ n : ℕ, x) :=
tendsto_const_nhds.cauchy_seq

lemma cauchy_seq_iff_tendsto [nonempty β] [semilattice_sup β] {u : β → α} :
  cauchy_seq u ↔ tendsto (prod.map u u) at_top (𝓤 α) :=
cauchy_map_iff'.trans $ by simp only [prod_at_top_at_top_eq, prod.map_def]

lemma cauchy_seq.comp_tendsto {γ} [semilattice_sup β] [semilattice_sup γ] [nonempty γ]
  {f : β → α} (hf : cauchy_seq f) {g : γ → β} (hg : tendsto g at_top at_top) :
  cauchy_seq (f ∘ g) :=
cauchy_seq_iff_tendsto.2 $ hf.tendsto_uniformity.comp (hg.prod_at_top hg)

lemma cauchy_seq.subseq_subseq_mem {V : ℕ → set (α × α)} (hV : ∀ n, V n ∈ 𝓤 α)
  {u : ℕ → α} (hu : cauchy_seq u)
  {f g : ℕ → ℕ} (hf : tendsto f at_top at_top) (hg : tendsto g at_top at_top) :
  ∃ φ : ℕ → ℕ, strict_mono φ ∧ ∀ n, ((u ∘ f ∘ φ) n, (u ∘ g ∘ φ) n) ∈ V n :=
begin
  rw cauchy_seq_iff_tendsto at hu,
  exact ((hu.comp $ hf.prod_at_top hg).comp tendsto_at_top_diagonal).subseq_mem hV,
end

lemma cauchy_seq_iff' {u : ℕ → α} :
  cauchy_seq u ↔ ∀ V ∈ 𝓤 α, ∀ᶠ k in at_top, k ∈ (prod.map u u) ⁻¹' V :=
by simpa only [cauchy_seq_iff_tendsto]

lemma cauchy_seq_iff {u : ℕ → α} :
  cauchy_seq u ↔ ∀ V ∈ 𝓤 α, ∃ N, ∀ k ≥ N, ∀ l ≥ N, (u k, u l) ∈ V :=
by simp [cauchy_seq_iff', filter.eventually_at_top_prod_self', prod_map]

lemma cauchy_seq.prod_map {γ δ} [uniform_space β] [semilattice_sup γ] [semilattice_sup δ]
  {u : γ → α} {v : δ → β}
  (hu : cauchy_seq u) (hv : cauchy_seq v) : cauchy_seq (prod.map u v) :=
by simpa only [cauchy_seq, prod_map_map_eq', prod_at_top_at_top_eq] using hu.prod hv

lemma cauchy_seq.prod {γ} [uniform_space β] [semilattice_sup γ] {u : γ → α} {v : γ → β}
  (hu : cauchy_seq u) (hv : cauchy_seq v) : cauchy_seq (λ x, (u x, v x)) :=
begin
  haveI := hu.nonempty,
  exact (hu.prod hv).mono (tendsto.prod_mk le_rfl le_rfl)
end

lemma cauchy_seq.eventually_eventually [semilattice_sup β] {u : β → α} (hu : cauchy_seq u)
  {V : set (α × α)} (hV : V ∈ 𝓤 α) :
  ∀ᶠ k in at_top, ∀ᶠ l in at_top, (u k, u l) ∈ V :=
eventually_at_top_curry $ hu.tendsto_uniformity hV

lemma uniform_continuous.comp_cauchy_seq {γ} [uniform_space β] [semilattice_sup γ]
  {f : α → β} (hf : uniform_continuous f) {u : γ → α} (hu : cauchy_seq u) :
  cauchy_seq (f ∘ u) :=
hu.map hf

lemma cauchy_seq.subseq_mem {V : ℕ → set (α × α)} (hV : ∀ n, V n ∈ 𝓤 α)
  {u : ℕ → α} (hu : cauchy_seq u) :
  ∃ φ : ℕ → ℕ, strict_mono φ ∧ ∀ n, (u $ φ (n + 1), u $ φ n) ∈ V n :=
begin
  have : ∀ n, ∃ N, ∀ k ≥ N, ∀ l ≥ k, (u l, u k) ∈ V n,
  { intro n,
    rw [cauchy_seq_iff] at hu,
    rcases hu _ (hV n) with ⟨N, H⟩,
    exact ⟨N, λ k hk l hl, H _ (le_trans hk hl) _ hk ⟩ },
  obtain ⟨φ : ℕ → ℕ, φ_extr : strict_mono φ, hφ : ∀ n, ∀ l ≥ φ n, (u l, u $ φ n) ∈ V n⟩ :=
    extraction_forall_of_eventually' this,
  exact ⟨φ, φ_extr, λ n, hφ _ _ (φ_extr $ lt_add_one n).le⟩,
end

lemma filter.tendsto.subseq_mem_entourage {V : ℕ → set (α × α)} (hV : ∀ n, V n ∈ 𝓤 α)
  {u : ℕ → α} {a : α} (hu : tendsto u at_top (𝓝 a)) :
  ∃ φ : ℕ → ℕ, strict_mono φ ∧ (u (φ 0), a) ∈ V 0 ∧ ∀ n, (u $ φ (n + 1), u $ φ n) ∈ V (n + 1) :=
begin
  rcases mem_at_top_sets.1 (hu (ball_mem_nhds a (symm_le_uniformity $ hV 0))) with ⟨n, hn⟩,
  rcases (hu.comp (tendsto_add_at_top_nat n)).cauchy_seq.subseq_mem (λ n, hV (n + 1))
    with ⟨φ, φ_mono, hφV⟩,
  exact ⟨λ k, φ k + n, φ_mono.add_const _, hn _ le_add_self, hφV⟩
end

/-- If a Cauchy sequence has a convergent subsequence, then it converges. -/
lemma tendsto_nhds_of_cauchy_seq_of_subseq
  [semilattice_sup β] {u : β → α} (hu : cauchy_seq u)
  {ι : Type*} {f : ι → β} {p : filter ι} [ne_bot p]
  (hf : tendsto f p at_top) {a : α} (ha : tendsto (u ∘ f) p (𝓝 a)) :
  tendsto u at_top (𝓝 a) :=
le_nhds_of_cauchy_adhp hu (map_cluster_pt_of_comp hf ha)

@[nolint ge_or_gt] -- see Note [nolint_ge]
lemma filter.has_basis.cauchy_seq_iff {γ} [nonempty β] [semilattice_sup β] {u : β → α}
  {p : γ → Prop} {s : γ → set (α × α)} (h : (𝓤 α).has_basis p s) :
  cauchy_seq u ↔ ∀ i, p i → ∃N, ∀m n≥N, (u m, u n) ∈ s i :=
begin
  rw [cauchy_seq_iff_tendsto, ← prod_at_top_at_top_eq],
  refine (at_top_basis.prod_self.tendsto_iff h).trans _,
  simp only [exists_prop, true_and, maps_to, preimage, subset_def, prod.forall,
    mem_prod_eq, mem_set_of_eq, mem_Ici, and_imp, prod.map, ge_iff_le, @forall_swap (_ ≤ _) β]
end

lemma filter.has_basis.cauchy_seq_iff' {γ} [nonempty β] [semilattice_sup β] {u : β → α}
  {p : γ → Prop} {s : γ → set (α × α)} (H : (𝓤 α).has_basis p s) :
  cauchy_seq u ↔ ∀ i, p i → ∃N, ∀n≥N, (u n, u N) ∈ s i :=
begin
  refine H.cauchy_seq_iff.trans ⟨λ h i hi, _, λ h i hi, _⟩,
  { exact (h i hi).imp (λ N hN n hn, hN n hn N le_rfl) },
  { rcases comp_symm_of_uniformity (H.mem_of_mem hi) with ⟨t, ht, ht', hts⟩,
    rcases H.mem_iff.1 ht with ⟨j, hj, hjt⟩,
    refine (h j hj).imp (λ N hN m hm n hn, hts ⟨u N, hjt _, ht' $ hjt _⟩),
    { exact hN m hm },
    { exact hN n hn } }
end

lemma cauchy_seq_of_controlled [semilattice_sup β] [nonempty β]
  (U : β → set (α × α)) (hU : ∀ s ∈ 𝓤 α, ∃ n, U n ⊆ s)
  {f : β → α} (hf : ∀ {N m n : β}, N ≤ m → N ≤ n → (f m, f n) ∈ U N) :
  cauchy_seq f :=
cauchy_seq_iff_tendsto.2
begin
  assume s hs,
  rw [mem_map, mem_at_top_sets],
  cases hU s hs with N hN,
  refine ⟨(N, N), λ mn hmn, _⟩,
  cases mn with m n,
  exact hN (hf hmn.1 hmn.2)
end

/-- A complete space is defined here using uniformities. A uniform space
  is complete if every Cauchy filter converges. -/
class complete_space (α : Type u) [uniform_space α] : Prop :=
(complete : ∀{f:filter α}, cauchy f → ∃x, f ≤ 𝓝 x)

lemma complete_univ {α : Type u} [uniform_space α] [complete_space α] :
  is_complete (univ : set α) :=
begin
  assume f hf _,
  rcases complete_space.complete hf with ⟨x, hx⟩,
  exact ⟨x, mem_univ x, hx⟩
end

instance complete_space.prod [uniform_space β] [complete_space α] [complete_space β] :
  complete_space (α × β) :=
{ complete := λ f hf,
    let ⟨x1, hx1⟩ := complete_space.complete $ hf.map uniform_continuous_fst in
    let ⟨x2, hx2⟩ := complete_space.complete $ hf.map uniform_continuous_snd in
    ⟨(x1, x2), by rw [nhds_prod_eq, filter.prod_def];
      from filter.le_lift (λ s hs, filter.le_lift' $ λ t ht,
        have H1 : prod.fst ⁻¹' s ∈ f.sets := hx1 hs,
        have H2 : prod.snd ⁻¹' t ∈ f.sets := hx2 ht,
        filter.inter_mem H1 H2)⟩ }

/--If `univ` is complete, the space is a complete space -/
lemma complete_space_of_is_complete_univ (h : is_complete (univ : set α)) : complete_space α :=
⟨λ f hf, let ⟨x, _, hx⟩ := h f hf ((@principal_univ α).symm ▸ le_top) in ⟨x, hx⟩⟩

lemma complete_space_iff_is_complete_univ :
  complete_space α ↔ is_complete (univ : set α) :=
⟨@complete_univ α _, complete_space_of_is_complete_univ⟩

lemma cauchy_iff_exists_le_nhds [complete_space α] {l : filter α} [ne_bot l] :
  cauchy l ↔ (∃x, l ≤ 𝓝 x) :=
⟨complete_space.complete, assume ⟨x, hx⟩, cauchy_nhds.mono hx⟩

lemma cauchy_map_iff_exists_tendsto [complete_space α] {l : filter β} {f : β → α} [ne_bot l] :
  cauchy (l.map f) ↔ (∃x, tendsto f l (𝓝 x)) :=
cauchy_iff_exists_le_nhds

/-- A Cauchy sequence in a complete space converges -/
theorem cauchy_seq_tendsto_of_complete [semilattice_sup β] [complete_space α]
  {u : β → α} (H : cauchy_seq u) : ∃x, tendsto u at_top (𝓝 x) :=
complete_space.complete H

/-- If `K` is a complete subset, then any cauchy sequence in `K` converges to a point in `K` -/
lemma cauchy_seq_tendsto_of_is_complete [semilattice_sup β] {K : set α} (h₁ : is_complete K)
  {u : β → α} (h₂ : ∀ n, u n ∈ K) (h₃ : cauchy_seq u) : ∃ v ∈ K, tendsto u at_top (𝓝 v) :=
h₁ _ h₃ $ le_principal_iff.2 $ mem_map_iff_exists_image.2 ⟨univ, univ_mem,
  by { simp only [image_univ], rintros _ ⟨n, rfl⟩, exact h₂ n }⟩

theorem cauchy.le_nhds_Lim [complete_space α] [nonempty α] {f : filter α} (hf : cauchy f) :
  f ≤ 𝓝 (Lim f) :=
le_nhds_Lim (complete_space.complete hf)

theorem cauchy_seq.tendsto_lim [semilattice_sup β] [complete_space α] [nonempty α] {u : β → α}
  (h : cauchy_seq u) :
  tendsto u at_top (𝓝 $ lim at_top u) :=
h.le_nhds_Lim

lemma is_closed.is_complete [complete_space α] {s : set α}
  (h : is_closed s) : is_complete s :=
λ f cf fs, let ⟨x, hx⟩ := complete_space.complete cf in
⟨x, is_closed_iff_cluster_pt.mp h x (cf.left.mono (le_inf hx fs)), hx⟩

/-- A set `s` is totally bounded if for every entourage `d` there is a finite
  set of points `t` such that every element of `s` is `d`-near to some element of `t`. -/
def totally_bounded (s : set α) : Prop :=
∀d ∈ 𝓤 α, ∃t : set α, finite t ∧ s ⊆ (⋃y∈t, {x | (x,y) ∈ d})

theorem totally_bounded_iff_subset {s : set α} : totally_bounded s ↔
  ∀d ∈ 𝓤 α, ∃t ⊆ s, finite t ∧ s ⊆ (⋃y∈t, {x | (x,y) ∈ d}) :=
⟨λ H d hd, begin
  rcases comp_symm_of_uniformity hd with ⟨r, hr, rs, rd⟩,
  rcases H r hr with ⟨k, fk, ks⟩,
  let u := k ∩ {y | ∃ x ∈ s, (x, y) ∈ r},
  choose hk f hfs hfr using λ x : u, x.coe_prop,
  refine ⟨range f, _, _, _⟩,
  { exact range_subset_iff.2 hfs },
  { haveI : fintype u := (fk.inter_of_left _).fintype,
    exact finite_range f },
  { intros x xs,
    obtain ⟨y, hy, xy⟩ : ∃ y ∈ k, (x, y) ∈ r, from mem_Union₂.1 (ks xs),
    rw [bUnion_range, mem_Union],
    set z : ↥u := ⟨y, hy, ⟨x, xs, xy⟩⟩,
    exact ⟨z, rd $ mem_comp_rel.2 ⟨y, xy, rs (hfr z)⟩⟩ }
end,
λ H d hd, let ⟨t, _, ht⟩ := H d hd in ⟨t, ht⟩⟩

lemma totally_bounded_of_forall_symm {s : set α}
  (h : ∀ V ∈ 𝓤 α, symmetric_rel V → ∃ t : set α, finite t ∧ s ⊆ ⋃ y ∈ t, ball y V) :
totally_bounded s :=
begin
  intros V V_in,
  rcases h _ (symmetrize_mem_uniformity V_in) (symmetric_symmetrize_rel V) with ⟨t, tfin, h⟩,
  refine ⟨t, tfin, subset.trans h _⟩,
  mono,
  intros x x_in z z_in,
  exact z_in.right
end

lemma totally_bounded_subset {s₁ s₂ : set α} (hs : s₁ ⊆ s₂)
  (h : totally_bounded s₂) : totally_bounded s₁ :=
assume d hd, let ⟨t, ht₁, ht₂⟩ := h d hd in ⟨t, ht₁, subset.trans hs ht₂⟩

lemma totally_bounded_empty : totally_bounded (∅ : set α) :=
λ d hd, ⟨∅, finite_empty, empty_subset _⟩

/-- The closure of a totally bounded set is totally bounded. -/
lemma totally_bounded.closure {s : set α} (h : totally_bounded s) :
  totally_bounded (closure s) :=
assume t ht,
let ⟨t', ht', hct', htt'⟩ := mem_uniformity_is_closed ht, ⟨c, hcf, hc⟩ := h t' ht' in
⟨c, hcf,
  calc closure s ⊆ closure (⋃ (y : α) (H : y ∈ c), {x : α | (x, y) ∈ t'}) : closure_mono hc
    ... = _ : is_closed.closure_eq $ is_closed_bUnion hcf $ assume i hi,
      continuous_iff_is_closed.mp (continuous_id.prod_mk continuous_const) _ hct'
    ... ⊆ _ : Union₂_subset $ assume i hi, subset.trans (assume x, @htt' (x, i))
      (subset_bUnion_of_mem hi)⟩

/-- The image of a totally bounded set under a unifromly continuous map is totally bounded. -/
lemma totally_bounded.image [uniform_space β] {f : α → β} {s : set α}
  (hs : totally_bounded s) (hf : uniform_continuous f) : totally_bounded (f '' s) :=
assume t ht,
have {p:α×α | (f p.1, f p.2) ∈ t} ∈ 𝓤 α,
  from hf ht,
let ⟨c, hfc, hct⟩ := hs _ this in
⟨f '' c, hfc.image f,
  begin
    simp [image_subset_iff],
    simp [subset_def] at hct,
    intros x hx, simp,
    exact hct x hx
  end⟩

lemma ultrafilter.cauchy_of_totally_bounded {s : set α} (f : ultrafilter α)
  (hs : totally_bounded s) (h : ↑f ≤ 𝓟 s) : cauchy (f : filter α) :=
⟨f.ne_bot', assume t ht,
  let ⟨t', ht'₁, ht'_symm, ht'_t⟩ := comp_symm_of_uniformity ht in
  let ⟨i, hi, hs_union⟩ := hs t' ht'₁ in
  have (⋃y∈i, {x | (x,y) ∈ t'}) ∈ f,
    from mem_of_superset (le_principal_iff.mp h) hs_union,
  have ∃y∈i, {x | (x,y) ∈ t'} ∈ f,
    from (ultrafilter.finite_bUnion_mem_iff hi).1 this,
  let ⟨y, hy, hif⟩ := this in
  have {x | (x,y) ∈ t'} ×ˢ {x | (x,y) ∈ t'} ⊆ comp_rel t' t',
    from assume ⟨x₁, x₂⟩ ⟨(h₁ : (x₁, y) ∈ t'), (h₂ : (x₂, y) ∈ t')⟩,
      ⟨y, h₁, ht'_symm h₂⟩,
  mem_of_superset (prod_mem_prod hif hif) (subset.trans this ht'_t)⟩

lemma totally_bounded_iff_filter {s : set α} :
  totally_bounded s ↔ (∀f, ne_bot f → f ≤ 𝓟 s → ∃c ≤ f, cauchy c) :=
begin
  split,
  { introsI H f hf hfs,
    exact ⟨ultrafilter.of f, ultrafilter.of_le f,
      (ultrafilter.of f).cauchy_of_totally_bounded H ((ultrafilter.of_le f).trans hfs)⟩ },
  { intros H d hd,
    contrapose! H with hd_cover,
    set f := ⨅ t : finset α, 𝓟 (s \ ⋃ y ∈ t, {x | (x, y) ∈ d}),
    have : ne_bot f,
    { refine infi_ne_bot_of_directed' (directed_of_sup _) _,
      { intros t₁ t₂ h,
        exact principal_mono.2 (diff_subset_diff_right $ bUnion_subset_bUnion_left h) },
      { intro t,
        simpa [nonempty_diff] using hd_cover t t.finite_to_set } },
    have : f ≤ 𝓟 s, from infi_le_of_le ∅ (by simp),
    refine ⟨f, ‹_›, ‹_›, λ c hcf hc, _⟩,
    rcases mem_prod_same_iff.1 (hc.2 hd) with ⟨m, hm, hmd⟩,
    have : m ∩ s ∈ c, from inter_mem hm (le_principal_iff.mp (hcf.trans ‹_›)),
    rcases hc.1.nonempty_of_mem this with ⟨y, hym, hys⟩,
    set ys := ⋃ y' ∈ ({y} : finset α), {x | (x, y') ∈ d},
    have : m ⊆ ys, by simpa [ys] using λ x hx, hmd (mk_mem_prod hx hym),
    have : c ≤ 𝓟 (s \ ys) := hcf.trans (infi_le_of_le {y} le_rfl),
    refine hc.1.ne (empty_mem_iff_bot.mp _),
    filter_upwards [le_principal_iff.1 this, hm],
    refine λ x hx hxm, hx.2 _,
    simpa [ys] using hmd (mk_mem_prod hxm hym) }
end

lemma totally_bounded_iff_ultrafilter {s : set α} :
  totally_bounded s ↔ (∀f : ultrafilter α, ↑f ≤ 𝓟 s → cauchy (f : filter α)) :=
begin
  refine ⟨λ hs f, f.cauchy_of_totally_bounded hs, λ H, totally_bounded_iff_filter.2 _⟩,
  introsI f hf hfs,
  exact ⟨ultrafilter.of f, ultrafilter.of_le f, H _ ((ultrafilter.of_le f).trans hfs)⟩
end

lemma compact_iff_totally_bounded_complete {s : set α} :
  is_compact s ↔ totally_bounded s ∧ is_complete s :=
⟨λ hs, ⟨totally_bounded_iff_ultrafilter.2 (λ f hf,
    let ⟨x, xs, fx⟩ := is_compact_iff_ultrafilter_le_nhds.1 hs f hf in cauchy_nhds.mono fx),
  λ f fc fs,
    let ⟨a, as, fa⟩ := @hs f fc.1 fs in
    ⟨a, as, le_nhds_of_cauchy_adhp fc fa⟩⟩,
 λ ⟨ht, hc⟩, is_compact_iff_ultrafilter_le_nhds.2
   (λf hf, hc _ (totally_bounded_iff_ultrafilter.1 ht f hf) hf)⟩

lemma is_compact.totally_bounded {s : set α} (h : is_compact s) : totally_bounded s :=
(compact_iff_totally_bounded_complete.1 h).1

lemma is_compact.is_complete {s : set α} (h : is_compact s) : is_complete s :=
(compact_iff_totally_bounded_complete.1 h).2

@[priority 100] -- see Note [lower instance priority]
instance complete_of_compact {α : Type u} [uniform_space α] [compact_space α] : complete_space α :=
⟨λf hf, by simpa using (compact_iff_totally_bounded_complete.1 compact_univ).2 f hf⟩

lemma compact_of_totally_bounded_is_closed [complete_space α] {s : set α}
  (ht : totally_bounded s) (hc : is_closed s) : is_compact s :=
(@compact_iff_totally_bounded_complete α _ s).2 ⟨ht, hc.is_complete⟩

/-!
### Sequentially complete space

In this section we prove that a uniform space is complete provided that it is sequentially complete
(i.e., any Cauchy sequence converges) and its uniformity filter admits a countable generating set.
In particular, this applies to (e)metric spaces, see the files `topology/metric_space/emetric_space`
and `topology/metric_space/basic`.

More precisely, we assume that there is a sequence of entourages `U_n` such that any other
entourage includes one of `U_n`. Then any Cauchy filter `f` generates a decreasing sequence of
sets `s_n ∈ f` such that `s_n × s_n ⊆ U_n`. Choose a sequence `x_n∈s_n`. It is easy to show
that this is a Cauchy sequence. If this sequence converges to some `a`, then `f ≤ 𝓝 a`. -/

namespace sequentially_complete

variables {f : filter α} (hf : cauchy f) {U : ℕ → set (α × α)}
  (U_mem : ∀ n, U n ∈ 𝓤 α) (U_le : ∀ s ∈ 𝓤 α, ∃ n, U n ⊆ s)

open set finset

noncomputable theory

/-- An auxiliary sequence of sets approximating a Cauchy filter. -/
def set_seq_aux (n : ℕ) : {s : set α // ∃ (_ : s ∈ f), s ×ˢ s ⊆ U n } :=
indefinite_description _ $ (cauchy_iff.1 hf).2 (U n) (U_mem n)

/-- Given a Cauchy filter `f` and a sequence `U` of entourages, `set_seq` provides
an antitone sequence of sets `s n ∈ f` such that `s n ×ˢ s n ⊆ U`. -/
def set_seq (n : ℕ) : set α :=  ⋂ m ∈ Iic n, (set_seq_aux hf U_mem m).val

lemma set_seq_mem (n : ℕ) : set_seq hf U_mem n ∈ f :=
(bInter_mem (finite_le_nat n)).2 (λ m _, (set_seq_aux hf U_mem m).2.fst)

lemma set_seq_mono ⦃m n : ℕ⦄ (h : m ≤ n) : set_seq hf U_mem n ⊆ set_seq hf U_mem m :=
bInter_subset_bInter_left (λ k hk, le_trans hk h)

lemma set_seq_sub_aux (n : ℕ) : set_seq hf U_mem n ⊆ set_seq_aux hf U_mem n :=
bInter_subset_of_mem right_mem_Iic

lemma set_seq_prod_subset {N m n} (hm : N ≤ m) (hn : N ≤ n) :
  set_seq hf U_mem m ×ˢ set_seq hf U_mem n ⊆ U N :=
begin
  assume p hp,
  refine (set_seq_aux hf U_mem N).2.snd ⟨_, _⟩;
    apply set_seq_sub_aux,
  exact set_seq_mono hf U_mem hm hp.1,
  exact set_seq_mono hf U_mem hn hp.2
end

/-- A sequence of points such that `seq n ∈ set_seq n`. Here `set_seq` is an antitone
sequence of sets `set_seq n ∈ f` with diameters controlled by a given sequence
of entourages. -/
def seq (n : ℕ) : α := some $ hf.1.nonempty_of_mem (set_seq_mem hf U_mem n)

lemma seq_mem (n : ℕ) : seq hf U_mem n ∈ set_seq hf U_mem n :=
some_spec $ hf.1.nonempty_of_mem (set_seq_mem hf U_mem n)

lemma seq_pair_mem ⦃N m n : ℕ⦄ (hm : N ≤ m) (hn : N ≤ n) :
  (seq hf U_mem m, seq hf U_mem n) ∈ U N :=
set_seq_prod_subset hf U_mem hm hn ⟨seq_mem hf U_mem m, seq_mem hf U_mem n⟩

include U_le

theorem seq_is_cauchy_seq : cauchy_seq $ seq hf U_mem :=
cauchy_seq_of_controlled U U_le $ seq_pair_mem hf U_mem

/-- If the sequence `sequentially_complete.seq` converges to `a`, then `f ≤ 𝓝 a`. -/
theorem le_nhds_of_seq_tendsto_nhds ⦃a : α⦄ (ha : tendsto (seq hf U_mem) at_top (𝓝 a)) :
  f ≤ 𝓝 a :=
le_nhds_of_cauchy_adhp_aux
begin
  assume s hs,
  rcases U_le s hs with ⟨m, hm⟩,
  rcases tendsto_at_top'.1 ha _ (mem_nhds_left a (U_mem m)) with ⟨n, hn⟩,
  refine ⟨set_seq hf U_mem (max m n), set_seq_mem hf U_mem _, _,
          seq hf U_mem (max m n), _, seq_mem hf U_mem _⟩,
  { have := le_max_left m n,
    exact set.subset.trans (set_seq_prod_subset hf U_mem this this) hm },
  { exact hm (hn _ $ le_max_right m n) }
end

end sequentially_complete

namespace uniform_space

open sequentially_complete

variables [is_countably_generated (𝓤 α)]

/-- A uniform space is complete provided that (a) its uniformity filter has a countable basis;
(b) any sequence satisfying a "controlled" version of the Cauchy condition converges. -/
theorem complete_of_convergent_controlled_sequences (U : ℕ → set (α × α)) (U_mem : ∀ n, U n ∈ 𝓤 α)
  (HU : ∀ u : ℕ → α, (∀ N m n, N ≤ m → N ≤ n → (u m, u n) ∈ U N) → ∃ a, tendsto u at_top (𝓝 a)) :
  complete_space α :=
begin
  obtain ⟨U', U'_mono, hU'⟩ := (𝓤 α).exists_antitone_seq,
  have Hmem : ∀ n, U n ∩ U' n ∈ 𝓤 α,
    from λ n, inter_mem (U_mem n) (hU'.2 ⟨n, subset.refl _⟩),
  refine ⟨λ f hf, (HU (seq hf Hmem) (λ N m n hm hn, _)).imp $
    le_nhds_of_seq_tendsto_nhds _ _ (λ s hs, _)⟩,
  { rcases (hU'.1 hs) with ⟨N, hN⟩,
    exact ⟨N, subset.trans (inter_subset_right _ _) hN⟩ },
  { exact inter_subset_left _ _ (seq_pair_mem hf Hmem hm hn) }
end

/-- A sequentially complete uniform space with a countable basis of the uniformity filter is
complete. -/
theorem complete_of_cauchy_seq_tendsto
  (H' : ∀ u : ℕ → α, cauchy_seq u → ∃a, tendsto u at_top (𝓝 a)) :
  complete_space α :=
let ⟨U', U'_mono, hU'⟩ := (𝓤 α).exists_antitone_seq in
complete_of_convergent_controlled_sequences U' (λ n, hU'.2 ⟨n, subset.refl _⟩)
  (λ u hu, H' u $ cauchy_seq_of_controlled U' (λ s hs, hU'.1 hs) hu)

variable (α)

@[priority 100]
instance first_countable_topology : first_countable_topology α :=
⟨λ a, by { rw nhds_eq_comap_uniformity, apply_instance }⟩

/-- A separable uniform space with countably generated uniformity filter is second countable:
one obtains a countable basis by taking the balls centered at points in a dense subset,
and with rational "radii" from a countable open symmetric antitone basis of `𝓤 α`. We do not
register this as an instance, as there is already an instance going in the other direction
from second countable spaces to separable spaces, and we want to avoid loops. -/
lemma second_countable_of_separable [separable_space α] : second_countable_topology α :=
begin
  rcases exists_countable_dense α with ⟨s, hsc, hsd⟩,
  obtain ⟨t : ℕ → set (α × α),
    hto : ∀ (i : ℕ), t i ∈ (𝓤 α).sets ∧ is_open (t i) ∧ symmetric_rel (t i),
      h_basis : (𝓤 α).has_antitone_basis t⟩ :=
    (@uniformity_has_basis_open_symmetric α _).exists_antitone_subbasis,
  choose ht_mem hto hts using hto,
  refine ⟨⟨⋃ (x ∈ s), range (λ k, ball x (t k)), hsc.bUnion (λ x hx, countable_range _), _⟩⟩,
  refine (is_topological_basis_of_open_of_nhds _ _).eq_generate_from,
  { simp only [mem_Union₂, mem_range],
    rintros _ ⟨x, hxs, k, rfl⟩,
    exact is_open_ball x (hto k) },
  { intros x V hxV hVo,
    simp only [mem_Union₂, mem_range, exists_prop],
    rcases uniform_space.mem_nhds_iff.1 (is_open.mem_nhds hVo hxV) with ⟨U, hU, hUV⟩,
    rcases comp_symm_of_uniformity hU with ⟨U', hU', hsymm, hUU'⟩,
    rcases h_basis.to_has_basis.mem_iff.1 hU' with ⟨k, -, hk⟩,
    rcases hsd.inter_open_nonempty (ball x $ t k) (is_open_ball x (hto k))
      ⟨x, uniform_space.mem_ball_self _ (ht_mem k)⟩ with ⟨y, hxy, hys⟩,
    refine ⟨_, ⟨y, hys, k, rfl⟩, (hts k).subset hxy, λ z hz, _⟩,
    exact hUV (ball_subset_of_comp_subset (hk hxy) hUU' (hk hz)) }
end

end uniform_space


import Smt

theorem resolution (p q r : Prop) : p ∨ q → ¬p ∨ r → q ∨ r := by
  smt


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Reid Barton, Bhavik Mehta

! This file was ported from Lean 3 source module category_theory.limits.constructions.over.products
! leanprover-community/mathlib commit ac3ae212f394f508df43e37aa093722fa9b65d31
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Over
import Mathbin.CategoryTheory.Limits.Shapes.Pullbacks
import Mathbin.CategoryTheory.Limits.Shapes.WidePullbacks
import Mathbin.CategoryTheory.Limits.Shapes.FiniteProducts

/-!
# Products in the over category

Shows that products in the over category can be derived from wide pullbacks in the base category.
The main result is `over_product_of_wide_pullback`, which says that if `C` has `J`-indexed wide
pullbacks, then `over B` has `J`-indexed products.
-/

universe w v u

-- morphism levels before object levels. See note [category_theory universes].
open CategoryTheory CategoryTheory.Limits

variable {J : Type w}

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

variable {X : C}

namespace CategoryTheory.Over

namespace ConstructProducts

/-- (Implementation)
Given a product diagram in `C/B`, construct the corresponding wide pullback diagram
in `C`.
-/
@[reducible]
def widePullbackDiagramOfDiagramOver (B : C) {J : Type w} (F : Discrete J ⥤ Over B) :
    WidePullbackShape J ⥤ C :=
  WidePullbackShape.wideCospan B (fun j => (F.obj ⟨j⟩).left) fun j => (F.obj ⟨j⟩).Hom
#align category_theory.over.construct_products.wide_pullback_diagram_of_diagram_over CategoryTheory.Over.ConstructProducts.widePullbackDiagramOfDiagramOver

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def conesEquivInverseObj (B : C) {J : Type w} (F : Discrete J ⥤ Over B) (c : Cone F) :
    Cone (widePullbackDiagramOfDiagramOver B F)
    where
  pt := c.pt.left
  π :=
    { app := fun X => Option.casesOn X c.pt.Hom fun j : J => (c.π.app ⟨j⟩).left
      -- `tidy` can do this using `case_bash`, but let's try to be a good `-T50000` citizen:
      naturality' := fun X Y f => by
        dsimp; cases X <;> cases Y <;> cases f
        · rw [category.id_comp, category.comp_id]
        · rw [over.w, category.id_comp]
        · rw [category.id_comp, category.comp_id] }
#align category_theory.over.construct_products.cones_equiv_inverse_obj CategoryTheory.Over.ConstructProducts.conesEquivInverseObj

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def conesEquivInverse (B : C) {J : Type w} (F : Discrete J ⥤ Over B) :
    Cone F ⥤ Cone (widePullbackDiagramOfDiagramOver B F)
    where
  obj := conesEquivInverseObj B F
  map c₁ c₂ f :=
    { Hom := f.Hom.left
      w' := fun j => by
        cases j
        · simp
        · dsimp
          rw [← f.w ⟨j⟩]
          rfl }
#align category_theory.over.construct_products.cones_equiv_inverse CategoryTheory.Over.ConstructProducts.conesEquivInverse

attribute [local tidy] tactic.discrete_cases

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simps]
def conesEquivFunctor (B : C) {J : Type w} (F : Discrete J ⥤ Over B) :
    Cone (widePullbackDiagramOfDiagramOver B F) ⥤ Cone F
    where
  obj c :=
    { pt := Over.mk (c.π.app none)
      π :=
        {
          app := fun ⟨j⟩ =>
            Over.homMk (c.π.app (some j)) (by apply c.w (wide_pullback_shape.hom.term j)) } }
  map c₁ c₂ f := { Hom := Over.homMk f.Hom }
#align category_theory.over.construct_products.cones_equiv_functor CategoryTheory.Over.ConstructProducts.conesEquivFunctor

attribute [local tidy] tactic.case_bash

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simp]
def conesEquivUnitIso (B : C) (F : Discrete J ⥤ Over B) :
    𝟭 (Cone (widePullbackDiagramOfDiagramOver B F)) ≅
      conesEquivFunctor B F ⋙ conesEquivInverse B F :=
  NatIso.ofComponents
    (fun _ =>
      Cones.ext
        { Hom := 𝟙 _
          inv := 𝟙 _ } (by tidy))
    (by tidy)
#align category_theory.over.construct_products.cones_equiv_unit_iso CategoryTheory.Over.ConstructProducts.conesEquivUnitIso

/-- (Impl) A preliminary definition to avoid timeouts. -/
@[simp]
def conesEquivCounitIso (B : C) (F : Discrete J ⥤ Over B) :
    conesEquivInverse B F ⋙ conesEquivFunctor B F ≅ 𝟭 (Cone F) :=
  NatIso.ofComponents
    (fun _ =>
      Cones.ext
        { Hom := Over.homMk (𝟙 _)
          inv := Over.homMk (𝟙 _) } (by tidy))
    (by tidy)
#align category_theory.over.construct_products.cones_equiv_counit_iso CategoryTheory.Over.ConstructProducts.conesEquivCounitIso

-- TODO: Can we add `. obviously` to the second arguments of `nat_iso.of_components` and
--       `cones.ext`?
/-- (Impl) Establish an equivalence between the category of cones for `F` and for the "grown" `F`.
-/
@[simps]
def conesEquiv (B : C) (F : Discrete J ⥤ Over B) :
    Cone (widePullbackDiagramOfDiagramOver B F) ≌ Cone F
    where
  Functor := conesEquivFunctor B F
  inverse := conesEquivInverse B F
  unitIso := conesEquivUnitIso B F
  counitIso := conesEquivCounitIso B F
#align category_theory.over.construct_products.cones_equiv CategoryTheory.Over.ConstructProducts.conesEquiv

/-- Use the above equivalence to prove we have a limit. -/
theorem has_over_limit_discrete_of_wide_pullback_limit {B : C} (F : Discrete J ⥤ Over B)
    [HasLimit (widePullbackDiagramOfDiagramOver B F)] : HasLimit F :=
  HasLimit.mk
    { Cone := _
      IsLimit :=
        IsLimit.ofRightAdjoint (conesEquiv B F).Functor
          (limit.isLimit (widePullbackDiagramOfDiagramOver B F)) }
#align category_theory.over.construct_products.has_over_limit_discrete_of_wide_pullback_limit CategoryTheory.Over.ConstructProducts.has_over_limit_discrete_of_wide_pullback_limit

/-- Given a wide pullback in `C`, construct a product in `C/B`. -/
theorem over_product_of_wide_pullback [HasLimitsOfShape (WidePullbackShape J) C] {B : C} :
    HasLimitsOfShape (Discrete J) (Over B) :=
  { HasLimit := fun F => has_over_limit_discrete_of_wide_pullback_limit F }
#align category_theory.over.construct_products.over_product_of_wide_pullback CategoryTheory.Over.ConstructProducts.over_product_of_wide_pullback

/-- Given a pullback in `C`, construct a binary product in `C/B`. -/
theorem over_binary_product_of_pullback [HasPullbacks C] {B : C} : HasBinaryProducts (Over B) :=
  over_product_of_wide_pullback
#align category_theory.over.construct_products.over_binary_product_of_pullback CategoryTheory.Over.ConstructProducts.over_binary_product_of_pullback

/-- Given all wide pullbacks in `C`, construct products in `C/B`. -/
theorem over_products_of_wide_pullbacks [HasWidePullbacks.{w} C] {B : C} :
    HasProducts.{w} (Over B) := fun J => over_product_of_wide_pullback
#align category_theory.over.construct_products.over_products_of_wide_pullbacks CategoryTheory.Over.ConstructProducts.over_products_of_wide_pullbacks

/-- Given all finite wide pullbacks in `C`, construct finite products in `C/B`. -/
theorem over_finite_products_of_finite_wide_pullbacks [HasFiniteWidePullbacks C] {B : C} :
    HasFiniteProducts (Over B) :=
  ⟨fun n => over_product_of_wide_pullback⟩
#align category_theory.over.construct_products.over_finite_products_of_finite_wide_pullbacks CategoryTheory.Over.ConstructProducts.over_finite_products_of_finite_wide_pullbacks

end ConstructProducts

attribute [local tidy] tactic.discrete_cases

/-- Construct terminal object in the over category. This isn't an instance as it's not typically the
way we want to define terminal objects.
(For instance, this gives a terminal object which is different from the generic one given by
`over_product_of_wide_pullback` above.)
-/
theorem over_hasTerminal (B : C) : HasTerminal (Over B) :=
  {
    HasLimit := fun F =>
      HasLimit.mk
        { Cone :=
            { pt := Over.mk (𝟙 _)
              π := { app := fun p => p.as.elim } }
          IsLimit :=
            { lift := fun s => Over.homMk _
              fac := fun _ j => j.as.elim
              uniq := fun s m _ => by
                ext
                rw [over.hom_mk_left]
                have := m.w
                dsimp at this
                rwa [category.comp_id, category.comp_id] at this } } }
#align category_theory.over.over_has_terminal CategoryTheory.Over.over_hasTerminal

end CategoryTheory.Over


import number_theory.pythagorean_triples
import tactic.ring

lemma sq_ne_two_fin_zmod_three (z : zmod 3) : z * z ≠ 2 :=
begin
  change fin 3 at z,
  fin_cases z; norm_num [fin.ext_iff, fin.coe_bit0, fin.coe_bit1],
end

lemma int.sq_ne_two_mod_three (z : ℤ) : (z * z) % 3 ≠ 2 :=
suffices ¬ (z * z) % (3 : ℕ) = 2 % (3 : ℕ), by norm_num at this,
begin
  rw ← zmod.int_coe_eq_int_coe_iff',
  simpa using sq_ne_two_fin_zmod_three _,
end

variables {x y z : ℤ}

lemma mod_three_eq_zero_or_one_or_two (n : ℤ) : n % 3 = 0 ∨ n % 3 = 1 ∨ n % 3 = 2 :=
have h : n % 3 < 3 := abs_of_nonneg (show 0 ≤ (3 : ℤ), from dec_trivial) ▸ int.mod_lt _ dec_trivial,
have h₁ : 0 ≤ n % 3 := int.mod_nonneg _ dec_trivial,
match (n % 3), h, h₁ with
| (0:ℕ) := λ _ _, or.inl rfl
| (1 : ℕ) := λ _ _, or.inr (or.inl rfl)
| (2 : ℕ) := λ _ _, or.inr (or.inr rfl)
| (k + 3 : ℕ) := λ h _, absurd h dec_trivial
| -[1+ a] := λ _ h₁, absurd h₁ dec_trivial
end

variables (h : pythagorean_triple x y z)

include h

lemma exact_one_div_three (hc : int.gcd x y = 1) :
  (x % 3 = 0 ∧ y % 3 = 1) ∨ (x % 3 = 0 ∧ y % 3 = 2) ∨ (x % 3 = 1 ∧ y % 3 = 0) ∨ (x % 3 = 2 ∧ y % 3 = 0) :=
begin
  rcases mod_three_eq_zero_or_one_or_two x with hx | hx | hx ;
    rcases mod_three_eq_zero_or_one_or_two y with hy | hy | hy,
  {-- x % 3 = 0, y % 3 = 0
  exfalso,
  apply nat.not_coprime_of_dvd_of_dvd (dec_trivial : 1 < 3) _ _ hc,
  {apply int.dvd_nat_abs_of_of_nat_dvd, apply int.dvd_of_mod_eq_zero hx },
  {apply int.dvd_nat_abs_of_of_nat_dvd, apply int.dvd_of_mod_eq_zero hy}},
  {left, exact ⟨ hx, hy ⟩}, --x % 3 = 0, y % 3 = 1
  {right,left, exact ⟨ hx, hy ⟩}, --x % 3 = 0, y % 3 = 2
  {right, right, left, exact ⟨ hx, hy ⟩}, --x % 3 = 1, y % 3 = 1
  {-- x % 3 = 1, y % 3 = 1
    exfalso,
    obtain ⟨x0, y0, rfl, rfl⟩ : ∃ x0 y0, x = x0* 3 + 1 ∧ y = y0 * 3 + 1,
    { cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hx) with x0 hx2,
      cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hy) with y0 hy2,
      rw sub_eq_iff_eq_add at hx2 hy2, exact ⟨x0, y0, hx2, hy2⟩ },
    apply int.sq_ne_two_mod_three z,
    rw show z * z = 3 * (3 * x0 * x0 + 2 * x0 + 2 * y0 + 3 * y0 * y0 ) + 2, by { rw ← h.eq, ring },
    rw [int.add_mod, int.mul_mod_right, zero_add, int.mod_mod], norm_num,},
  {--x % 3 = 1, y % 3 = 2
    exfalso,
    obtain ⟨x0, y0, rfl, rfl⟩ : ∃ x0 y0, x = x0* 3 + 1 ∧ y = y0 * 3 + 2,
    { cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hx) with x0 hx2,
      cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hy) with y0 hy2,
      rw sub_eq_iff_eq_add at hx2 hy2, exact ⟨x0, y0, hx2, hy2⟩ },
    apply int.sq_ne_two_mod_three z,
     rw show z * z = 3 * (3 * x0 * x0 + 2 * x0 + 4 * y0 + 3 * y0 * y0 ) + 5, by { rw ← h.eq, ring },
    rw [int.add_mod, int.mul_mod_right, zero_add, int.mod_mod], norm_num,},
  {right ,right ,right ,exact ⟨hx, hy⟩ },
  {--x % 3 = 2, y % 3 = 1
    exfalso,
    obtain ⟨x0, y0, rfl, rfl⟩ : ∃ x0 y0, x = x0* 3 + 2 ∧ y = y0 * 3 + 1,
    { cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hx) with x0 hx2,
      cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hy) with y0 hy2,
      rw sub_eq_iff_eq_add at hx2 hy2, exact ⟨x0, y0, hx2, hy2⟩ },
    apply int.sq_ne_two_mod_three z,
     rw show z * z = 3 * (3 * x0 * x0 + 4 * x0 + 2 * y0 + 3 * y0 * y0 ) + 5, by { rw ← h.eq, ring },
    rw [int.add_mod, int.mul_mod_right, zero_add, int.mod_mod],
    norm_num,},
  {--x % 3 = 2, y % 3 = 1
    exfalso,
    obtain ⟨x0, y0, rfl, rfl⟩ : ∃ x0 y0, x = x0* 3 + 2 ∧ y = y0 * 3 + 2,
    { cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hx) with x0 hx2,
      cases exists_eq_mul_left_of_dvd (int.dvd_sub_of_mod_eq hy) with y0 hy2,
      rw sub_eq_iff_eq_add at hx2 hy2, exact ⟨x0, y0, hx2, hy2⟩ },
    apply int.sq_ne_two_mod_three z,
     rw show z * z = 3 * (3 * x0 * x0 + 4 * x0 + 4 * y0 + 3 * y0 * y0 ) + 8, by { rw ← h.eq, ring },
    rw [int.add_mod, int.mul_mod_right, zero_add, int.mod_mod],
    norm_num,},
end


import M4R.Algebra.Ring.RMorphism

namespace M4R
  open NCSemiring Semiring

  namespace UnorderedList.map_sum

    theorem mul_sum [NCSemiring β] (b : β) (f : α → β) (s : UnorderedList α) :
      b * (∑ f in s) = ∑ (b * f ·) in s := by
        let h := NCSemiring.MulHomLeft b
        have : b * (∑ f in s) = h (∑ f in s) := rfl
        rw [this, h.map_sum']; rfl

    theorem sum_mul [NCSemiring β] (b : β) (f : α → β) (s : UnorderedList α) :
      (∑ f in s) * b = ∑ (f · * b) in s := by
        let h := NCSemiring.MulHomRight b
        have : (∑ f in s) * b = h (∑ f in s) := rfl
        rw [this, h.map_sum']; rfl

    theorem div_sum [Semiring β] (b : β) (f : α → β) (s : UnorderedList α) (h : ∀ a ∈ s, b ÷ f a) :
      b ÷ (∑ f in s) :=
        prop_sum (b ÷ ·) f s (divides_zero b) h (fun _ _ => divides_add)

    theorem mul_distrib [NCSemiring γ] (s₁ : UnorderedList α) (s₂ : UnorderedList β) (f₁ : α → γ) (f₂ : β → γ) :
      (∑ f₁ in s₁) * (∑ f₂ in s₂) = ∑ x in s₁.product s₂, f₁ x.fst * f₂ x.snd :=
        UnorderedList.induction_on (fun s₁ : UnorderedList α => (∑ f₁ in s₁) * (∑ f₂ in s₂) = ∑ x in s₁.product s₂, f₁ x.fst * f₂ x.snd) s₁
          (by simp only [product.empty_left, empty, zero_mul])
          (fun a s ih => by
            simp only [cons, mul_distrib_right, ih, product.cons_left, append]
            exact congrArg (_ + ·) (UnorderedList.induction_on (fun s₂ => f₁ a * (∑ f₂ in s₂) = ∑ x in s₂.map (Prod.mk a), f₁ x.fst * f₂ x.snd) s₂
              (by simp only [map_nil, empty, mul_zero])
              (fun _ _ ih => by simp only [map.cons, cons, mul_distrib_left, ih])))

  end UnorderedList.map_sum

  namespace Finset.map_sum

    theorem mul_sum [NCSemiring β] (b : β) (f : α → β) (s : Finset α) :
      b * (∑ f in s) = ∑ (b * f ·) in s := UnorderedList.map_sum.mul_sum b f s

    theorem sum_mul [NCSemiring β] (b : β) (f : α → β) (s : Finset α) :
      (∑ f in s) * b = ∑ (f · * b) in s := UnorderedList.map_sum.sum_mul b f s

    theorem div_sum [Semiring β] (b : β) (f : α → β) (s : Finset α) (h : ∀ a ∈ s, b ÷ f a) :
      b ÷ (∑ f in s) := UnorderedList.map_sum.div_sum b f s h

    theorem mul_distrib [NCSemiring γ] (s₁ : Finset α) (s₂ : Finset β) (f₁ : α → γ) (f₂ : β → γ) :
      (∑ f₁ in s₁) * (∑ f₂ in s₂) = ∑ x in s₁.elems.product s₂.elems, f₁ x.fst * f₂ x.snd :=
        UnorderedList.map_sum.mul_distrib s₁.elems s₂.elems f₁ f₂

  end Finset.map_sum

  theorem Semiring.binomial [Semiring α] (a b : α) (n : Nat) : (a + b)^n =
    ∑ (fun x => n.choose x.fst * a ^ x.fst * b ^ x.snd) in (Finset.antidiagonal n) := by
      induction n with
      | zero => simp only [Nat.zero_eq, pow_nat_0, Finset.antidiagonal.zero,
        Finset.map_sum.singleton, mul_one]; rfl
      | succ n ih =>
        rw [pow_nat_succ, ih, Finset.map_sum.sum_mul]
        have : (fun (x : Nat × Nat) => n.choose x.fst * a ^ x.fst * b ^ x.snd * (a + b)) =
          (fun (x : Nat × Nat) => n.choose x.fst * a ^ x.fst.succ * b ^ x.snd +
            n.choose x.fst * a ^ x.fst * b ^ x.snd.succ) := funext fun x => by
              rw [mul_distrib_left, mul_right_comm, mul_assoc _ _ a,
                mul_assoc _ _ b, pow_nat_succ, pow_nat_succ]
        rw [this]; simp only [Finset.map_sum.antidiagonal_eq_range]
        rw [Finset.map_sum.distrib, CommMonoid.add_comm, Finset.map_sum.range_start,
          Finset.map_sum.range_succ, ←Monoid.add_assoc, Monoid.add_assoc (_ * _)]
        have : (∑ k in Finset.range' 1 n, n.choose k * a ^ k * b ^ (n - k).succ) +
          (∑ k in Finset.range n, n.choose k * a ^ k.succ * b ^ (n - k)) =
            ∑ k in Finset.range' 1 n, n.succ.choose k * a ^ k * b ^ (n.succ - k) := by
              rw [Finset.map_sum.range_shift, ←Finset.map_sum.distrib]
              exact Finset.map_sum.congr rfl (fun x hx => by
                simp only [Function.comp]
                have ⟨h₁, h₂⟩ := Finset.range'.mem_range'.mp hx
                have h₂ : x ≤ n := Nat.le_of_lt_succ (Nat.one_add n ▸ h₂)
                rw [Nat.succ_pred_eq_of_pos h₁, Nat.succ_sub h₂, Nat.sub_pred h₁ h₂,
                  ←mul_distrib_right, ←mul_distrib_right, ←ofNat.preserve_add, Nat.choose_pred h₁])
        rw [this, Finset.map_sum.range_succ, Finset.map_sum.range_start, Nat.choose_zero_right_succ,
          Nat.sub_zero, Nat.sub_zero, Nat.choose_self_succ, Nat.sub_self, Nat.sub_self]

  def UnorderedList.fold_mul [Semiring α] (init : α) (s : UnorderedList α) :=
    s.fold (· * ·) (fun x y z => mul_right_comm x z y) init

  namespace UnorderedList.fold_mul

    @[simp] theorem empty [Semiring α] (init : α) : UnorderedList.fold_mul init ∅ = init := rfl

    theorem cons [Semiring α] (init a : α) (s : UnorderedList α) : (s.cons a).fold_mul init = s.fold_mul init * a :=
      UnorderedList.fold.cons' _ _ init a s

    theorem init_change [Semiring α] (init a : α) (s : UnorderedList α) : s.fold_mul (init * a) = s.fold_mul init * a := by
      have : (s.cons a).fold_mul init = s.fold_mul (init * a) :=
        UnorderedList.fold.cons _ _ init a s
      rw [←this, cons]

    theorem init_swap [Semiring α] (a b : α) (s : UnorderedList α) : s.fold_mul a * b = s.fold_mul b * a := by
      rw [←init_change, ←init_change, mul_comm]

    theorem append [Semiring α] (init : α) (s t : UnorderedList α) : (s + t).fold_mul init * init = s.fold_mul init * t.fold_mul init := by
      have : (s + t).fold_mul init = t.fold_mul (s.fold_mul init) := by
        simp only [fold_mul, fold.append]
      rw [this, init_swap, mul_comm]

  end UnorderedList.fold_mul

  def UnorderedList.map_fold_mul [Semiring α] (init : α) (f : β → α) (s : UnorderedList β) : α :=
    s.map_fold (· * ·) mul_comm mul_assoc init f

  namespace UnorderedList.map_fold_mul

    @[simp] theorem empty [Semiring α] (init : α) (f : β → α) : map_fold_mul init f ∅ = init := rfl

    theorem cons [Semiring α] (init : α) (f : β → α) (b : β) (s : UnorderedList β) :
      (s.cons b).map_fold_mul init f = s.map_fold_mul init f * f b :=
        map_fold.cons (· * ·) mul_comm mul_assoc init f s b

    theorem distrib [Semiring α] (init : α) (f g : β → α) (s : UnorderedList β) :
      init * s.map_fold_mul init (fun b => f b * g b) =
        (s.map_fold_mul init f) * (s.map_fold_mul init g) := by
          simp only [map_fold_mul, map_fold.distrib]

    theorem congr_map [Semiring α] (init : α) {s : UnorderedList β} {f g : β → α} (h : ∀ x ∈ s, f x = g x) :
      s.map_fold_mul init f = s.map_fold_mul init g :=
        map_fold.congr_map (· * ·) mul_comm mul_assoc init h

  end UnorderedList.map_fold_mul

  def UnorderedList.prod [Semiring α] (s : UnorderedList α) : α :=
    s.fold_mul 1
  def UnorderedList.map_prod [Semiring β] (s : UnorderedList α) (f : α → β) : β :=
    s.map_fold_mul 1 f

  namespace UnorderedList.prod

    @[simp] theorem empty [Semiring α] : (∏ (0 : UnorderedList α)) = 1 := rfl

    theorem cons [Semiring α] (a : α) (s : UnorderedList α) : (∏ s.cons a) = (∏ s) * a :=
      fold_mul.cons 1 a s

    @[simp] theorem cons_one [Semiring α] (s : UnorderedList α) : (∏ s.cons 1) = ∏ s :=
      mul_one (∏ s) ▸ cons 1 s

    @[simp] theorem singleton [Semiring α] (a : α) : (∏ UnorderedList.singleton a) = a := by
      conv => rhs rw [←one_mul a]

    @[simp] theorem double  [Semiring α] (a b : α) : (∏ ([a, b] : UnorderedList α)) = a * b := by
      have : ([a, b] : UnorderedList α) = (UnorderedList.singleton b).cons a := rfl
      rw [this, cons, singleton]; exact mul_comm b a

    theorem eq_one [Semiring α] {s : UnorderedList α} (h : ∀ x ∈ s, x = 1) : (∏ s) = 1 :=
      @Quotient.inductionOn (List α) (Perm.PermSetoid α) (fun (l : UnorderedList α) =>
        (∀ a ∈ l, a = 1) → (∏ l) = 1) s (fun l hl => by
          induction l with
          | nil => rfl
          | cons x l ih =>
            rw [UnorderedList.cons', cons, hl x (by rw [UnorderedList.cons']; exact UnorderedList.mem_cons_self _ _), mul_one]
            exact ih (fun a ha => hl a (UnorderedList.mem_cons_of_mem ha)))
        h

    theorem append [Semiring α] (s t : UnorderedList α) : (∏ s + t) = (∏ s) * (∏ t) := by
      have := fold_mul.append 1 s t
      rw [mul_one] at this
      exact this

    theorem prop_prod [Semiring α] (p : α → Prop) (s : UnorderedList α) (h₀ : p 1)
      (h₁ : ∀ a ∈ s, p a) (h₂ : ∀ a₁ a₂, p a₁ → p a₂ → p (a₁ * a₂)) :
        p (∏ s) :=
          UnorderedList.induction_on (fun l => l ⊆ s → p (∏ l)) s (fun _ => h₀)
            (fun a l hl hla => by
              rw [cons]; exact h₂ _ _ (hl fun x hx => hla (mem_cons.mpr (Or.inr hx)))
                (h₁ _ (hla (mem_cons.mpr (Or.inl rfl))))) (Subset.refl _)

  end UnorderedList.prod
  namespace UnorderedList.map_prod

    @[simp] theorem map_def [Semiring β] (f : α → β) (s : UnorderedList α) : (∏ s.map f) = ∏ f in s := rfl

    @[simp] theorem empty [Semiring β] (f : α → β) : (∏ f in (0 : UnorderedList α)) = 1 := rfl

    @[simp] theorem map_id [Semiring α] (s : UnorderedList α) : (∏ id in s) = ∏ s := by
      simp only [map_prod, map_fold_mul, map_fold, UnorderedList.map.map_id s] rfl

    theorem cons [Semiring β] (f : α → β) (a : α) (s : UnorderedList α) : (∏ f in s.cons a) = (∏ f in s) * (f a) :=
      map_fold_mul.cons 1 f a s

    theorem congr [Semiring β] {f g : α → β} {s₁ s₂ : UnorderedList α} (h : s₁ = s₂) :
      (∀ x ∈ s₂, f x = g x) → (∏ f in s₁) = ∏ g in s₂ := by
        rw [h]; exact UnorderedList.map_fold_mul.congr_map 1

    @[simp] theorem singleton [Semiring β] (f : α → β) (a : α) : (∏ f in UnorderedList.singleton a) = f a := by
      simp only [map_prod, map_fold_mul, map_fold, map.singleton f a, fold.singleton, one_mul]

    @[simp] theorem double  [Semiring β] (f : α → β) (a b : α) : (∏ f in ([a, b] : UnorderedList α)) = f a * f b :=
      (prod.double (f a) (f b)).symm ▸ rfl

    theorem eq_one [Semiring β] {f : α → β} {s : UnorderedList α} (h : ∀ x ∈ s, f x = 1) :
      (∏ f in s) = 1 :=
        UnorderedList.prod.eq_one fun x hx =>
          let ⟨a, ha, he⟩ := UnorderedList.map.mem_map.mp hx
          he.symm.trans (h a ha)

    theorem distrib [Semiring β] (f g : α → β) (s : UnorderedList α) :
      (∏ x in s, f x * g x) = (∏ f in s) * ∏ g in s := by
        have := map_fold_mul.distrib 1 f g s
        rw [one_mul] at this
        simp only [map_prod, this]

    theorem comm [Semiring γ] {s : UnorderedList α} {t : UnorderedList β} {f : α → β → γ} :
      (∏ x in s, ∏ y in t, f x y) = (∏ y in t, ∏ x in s, f x y) :=
        UnorderedList.induction_on (fun l => (∏ x in l, ∏ y in t, f x y) = (∏ y in t, ∏ x in l, f x y)) s
          (by simp only [empty]; exact (eq_one (fun _ _ => rfl)).symm)
          (fun a l ih => by
            simp at ih ⊢
            have : (fun y => map_prod (UnorderedList.cons a l) (f · y)) =
              (fun y => (map_prod l (f · y)) * f a y) := by simp only [cons]
            rw [cons, this, distrib, ih])

    theorem map [Semiring γ] (s : UnorderedList α) (e : α → β) (f : β → γ) :
      (∏ f in s.map e) = ∏ f ∘ e in s := by
        simp only [map_prod, map_fold_mul, map_fold, UnorderedList.map.map_comp]

    theorem prop_prod [Semiring β] (p : β → Prop) (f : α → β) (s : UnorderedList α) (h₀ : p 1)
      (h₁ : ∀ a ∈ s, p (f a)) (h₂ : ∀ b₁ b₂, p b₁ → p b₂ → p (b₁ * b₂)) :
        p (∏ f in s) :=
          UnorderedList.prod.prop_prod _ _ h₀ (fun b hb =>
            let ⟨a, has, hab⟩ := map.mem_map.mp hb
            hab ▸ h₁ a has) h₂

  end UnorderedList.map_prod

  def Finset.prod [Semiring α] (s : Finset α) : α := s.elems.prod
  def Finset.map_prod [Semiring β] (s : Finset α) (f : α → β) : β := s.elems.map_prod f

  namespace Finset.prod

    @[simp] theorem empty [Semiring α] : (∏ (∅ : Finset α)) = 1 := rfl

    theorem cons [Semiring α] {a : α} {s : Finset α} (ha : a ∉ s) : (∏ s.cons a ha) = (∏ s) * a :=
      UnorderedList.prod.cons a s.elems

    theorem eq_one [Semiring α] {s : Finset α} (h : ∀ x ∈ s, x = 1) : (∏ s) = 1 :=
      UnorderedList.prod.eq_one h

    @[simp] theorem singleton [Semiring α] (a : α) : (∏ Finset.singleton a) = a :=
      UnorderedList.prod.singleton a

    @[simp] theorem prod_insert [Semiring α] {a : α} {s : Finset α} : a ∉ s → (∏ insert a s) = a * ∏ s := by
      rw [mul_comm]; exact fold.fold_insert (· * ·) (fun x y z => mul_right_comm x z y) 1

    theorem prop_prod [Semiring α] (p : α → Prop) (s : Finset α) (h₀ : p 1)
      (h₁ : ∀ a ∈ s, p a) (h₂ : ∀ a₁ a₂, p a₁ → p a₂ → p (a₁ * a₂)) :
        p (∏ s) := UnorderedList.prod.prop_prod p s h₀ h₁ h₂

  end Finset.prod

  namespace Finset.map_prod

    @[simp] theorem map_def [Semiring β] (f : α → β) (s : Finset α) : (∏ s.map f) = ∏ f in s := rfl

    @[simp] theorem empty [Semiring β] (f : α → β) : (∏ f in (∅ : Finset α)) = 1 := rfl

    @[simp] theorem map_id [Semiring α] (s : Finset α) : (∏ id in s) = ∏ s :=
      UnorderedList.map_prod.map_id s.elems

    theorem cons [Semiring β] (f : α → β) {a : α} {s : Finset α} (ha : a ∉ s) : (∏ f in s.cons a ha) = (∏ f in s) * (f a) :=
      UnorderedList.map_prod.cons f a s.elems

    theorem eq_one [Semiring β] {f : α → β} {s : Finset α} (h : ∀ x ∈ s, f x = 1) :
      (∏ f in s) = 1 :=
        UnorderedList.map_prod.eq_one h

    @[simp] theorem singleton [Semiring β] (f : α → β) (a : α) : (∏ f in Finset.singleton a) = f a :=
      UnorderedList.map_prod.singleton f a

    theorem distrib [Semiring β] (f g : α → β) (s : Finset α) :
      (∏ x in s, f x * g x) = (∏ f in s) * ∏ g in s := by
        exact UnorderedList.map_prod.distrib f g s

    theorem congr [Semiring β] {f g : α → β} {s₁ s₂ : Finset α} (h : s₁ = s₂) :
      (∀ x ∈ s₂, f x = g x) → (∏ f in s₁) = ∏ g in s₂ :=
        UnorderedList.map_prod.congr (val_inj.mpr h)

    theorem union_inter [Semiring β] {f : α → β} {s₁ s₂ : Finset α} :
      (∏ f in (s₁ ∪ s₂)) * (∏ f in (s₁ ∩ s₂)) = (∏ f in s₁) * (∏ f in s₂) :=
        Finset.map_fold.union_inter (· * ·) mul_comm mul_assoc f

    theorem union [Semiring β] {f : α → β} {s₁ s₂ : Finset α} (h : disjoint s₁ s₂) :
      (∏ f in (s₁ ∪ s₂)) = (∏ f in s₁) * (∏ f in s₂) := by
        rw [←union_inter, h, empty, mul_one]

    theorem sdiff [Semiring β] {s₁ s₂ : Finset α} (h : s₁ ⊆ s₂) {f : α → β} :
      (∏ f in (s₂ ∖ s₁)) * (∏ f in s₁) = (∏ f in s₂) := by
        rw [←union (((s₂ ∖ s₁).inter_comm s₁).trans (s₁.inter_sdiff_self s₂)), sdiff_union_of_subset h]

    theorem subset_zero_on_sdiff [Semiring β] {s₁ s₂ : Finset α} (h : s₁ ⊆ s₂) {f g : α → β}
      (hg : ∀ x ∈ (s₂ ∖ s₁), g x = 1) (hfg : ∀ x ∈ s₁, f x = g x) : (∏ f in s₁) = ∏ g in s₂ := by
        rw [←sdiff h, eq_one hg, one_mul]
        exact congr rfl hfg

    theorem subset [Semiring β] {s₁ s₂ : Finset α} (h : s₁ ⊆ s₂) {f : α → β} (hf : ∀ x ∈ s₂, x ∉ s₁ → f x = 1) :
      (∏ f in s₁) = ∏ f in s₂ :=
        subset_zero_on_sdiff h (by simp only [mem_sdiff, and_imp]; exact hf) (fun _ _ => rfl)

    @[simp] theorem prod_insert [Semiring β] (f : α → β) {a : α} {s : Finset α} :
      a ∉ s → (∏ f in insert a s) = f a * ∏ f in s :=
        map_fold.fold_insert (· * ·) mul_comm mul_assoc 1 f

    theorem comm [Semiring γ] {s : Finset α} {t : Finset β} {f : α → β → γ} :
      (∏ x in s, ∏ y in t, f x y) = (∏ y in t, ∏ x in s, f x y) :=
        UnorderedList.map_prod.comm

    theorem map [Semiring γ] (s : Finset α) {e : α → β} (he : Function.injective e) (f : β → γ) :
      (∏ f in s.map_inj he) = ∏ f ∘ e in s :=
        UnorderedList.map_prod.map s.elems e f

    theorem antidiagonal_eq_range [Semiring α] (f : Nat × Nat → α) (n : Nat) :
      (∏ f in Finset.antidiagonal n) = ∏ k in Finset.range n.succ, f (k, n-k) := by
        have : Finset.antidiagonal n = (Finset.range n.succ).map_inj (fun _ _ h => by
          rw [Prod.mk.injEq] at h; exact h.left) := rfl
        rw [this, map_prod.map]

    theorem range'_start [Semiring α] (f : Nat → α) (s n : Nat) :
      (∏ f in Finset.range' s n.succ) = f s * ∏ f in Finset.range' s.succ n := by
        rw [Finset.range'.start, cons, mul_comm]

    theorem range'_succ [Semiring α] (f : Nat → α) (s n : Nat) :
      (∏ f in Finset.range' s n.succ) = (∏ f in Finset.range' s n) * f (s+n) := by
        rw [Finset.range'.succ, cons]

    theorem range_start [Semiring α] (f : Nat → α) (n : Nat) :
      (∏ f in Finset.range n.succ) = f 0 * ∏ f in Finset.range' 1 n := by
        rw [Finset.range.start, cons, mul_comm]

    theorem range_succ [Semiring α] (f : Nat → α) (n : Nat) :
      (∏ f in Finset.range n.succ) = (∏ f in Finset.range n) * f n := by
        rw [Finset.range.succ, cons]

    theorem range'_shift [Semiring α] (f : Nat → α) (s n : Nat) :
      (∏ f in Finset.range' s n) = ∏ f ∘ Nat.pred in Finset.range' s.succ n := by
        induction n with
        | zero => rw [Finset.range'.zero, Finset.range'.zero, empty, empty]
        | succ n ih =>
          rw [range'_succ, ih, range'_succ, Nat.succ_add]
          simp only [Function.comp, Nat.pred_succ]

    theorem range_shift [Semiring α] (f : Nat → α) (n : Nat) :
      (∏ f in Finset.range n) = ∏ f ∘ Nat.pred in Finset.range' 1 n := by
        rw [range_eq_range']; exact range'_shift f 0 n

    theorem range'_split [Semiring α] {f : Nat → α} {s n : Nat} (m : Nat) (h : m ≤ n) :
      (∏ f in Finset.range' s n) = (∏ f in Finset.range' s m) * (∏ f in Finset.range' (s + m) (n - m)) := by
        have := Finset.range'.append s m (n - m)
        rw [Nat.add_comm m, Nat.sub_add_cancel h] at this
        rw [←this, union ((Finset.range'.disjoint _ _ _ _).mpr (Or.inl (Nat.le_refl _)))]

    theorem prop_prod [Semiring β] (p : β → Prop) (f : α → β) (s : Finset α) (h₀ : p 1)
      (h₁ : ∀ a ∈ s, p (f a)) (h₂ : ∀ b₁ b₂, p b₁ → p b₂ → p (b₁ * b₂)) :
        p (∏ f in s) := UnorderedList.map_prod.prop_prod p f s h₀ h₁ h₂

    theorem prod_term [Semiring β] (f : α → β) (s : Finset α) {a : α} (ha : a ∈ s) : (∏ f in s) = (∏ f in s.erase a) * f a := by
      conv => lhs rw [s.erase_cons ha, cons]

  end Finset.map_prod

end M4R


/-
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

! This file was ported from Lean 3 source module data.sigma.basic
! leanprover-community/mathlib commit a148d797a1094ab554ad4183a4ad6f130358ef64
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Init.Function
import Std.Tactic.Ext
import Mathlib.Logic.Function.Basic

/-!
# Sigma types

This file proves basic results about sigma types.

A sigma type is a dependent pair type. Like `α × β` but where the type of the second component
depends on the first component. More precisely, given `β : ι → Type _`, `Sigma β` is made of stuff
which is of type `β i` for some `i : ι`, so the sigma type is a disjoint union of types.
For example, the sum type `X ⊕ Y` can be emulated using a sigma type, by taking `ι` with
exactly two elements (see `Equiv.sumEquivSigmaBool`).

`Σ x, A x` is notation for `Sigma A` (note that this is `\Sigma`, not the sum operator `∑`).
`Σ x y z ..., A x y z ...` is notation for `Σ x, Σ y, Σ z, ..., A x y z ...`. Here we have
`α : Type _`, `β : α → Type _`, `γ : Π a : α, β a → Type _`, ...,
`A : Π (a : α) (b : β a) (c : γ a b) ..., Type _`  with `x : α` `y : β x`, `z : γ x y`, ...

## Notes

The definition of `Sigma` takes values in `Type _`. This effectively forbids `Prop`- valued sigma
types. To that effect, we have `PSigma`, which takes value in `Sort _` and carries a more
complicated universe signature as a consequence.
-/

section Sigma

variable {α α₁ α₂ : Type _} {β : α → Type _} {β₁ : α₁ → Type _} {β₂ : α₂ → Type _}

namespace Sigma

instance [Inhabited α] [Inhabited (β default)] : Inhabited (Sigma β) :=
  ⟨⟨default, default⟩⟩

instance [h₁ : DecidableEq α] [h₂ : ∀ a, DecidableEq (β a)] : DecidableEq (Sigma β)
  | ⟨a₁, b₁⟩, ⟨a₂, b₂⟩ =>
    match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
    | _, b₁, _, b₂, isTrue (Eq.refl _) =>
      match b₁, b₂, h₂ _ b₁ b₂ with
      | _, _, isTrue (Eq.refl _) => isTrue rfl
      | _, _, isFalse n => isFalse fun h ↦ Sigma.noConfusion h fun _ e₂ ↦ n <| eq_of_heq e₂
    | _, _, _, _, isFalse n => isFalse fun h ↦ Sigma.noConfusion h fun e₁ _ ↦ n e₁

-- sometimes the built-in injectivity support does not work
@[simp] -- @[nolint simpNF]
theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
    Sigma.mk a₁ b₁ = ⟨a₂, b₂⟩ ↔ a₁ = a₂ ∧ HEq b₁ b₂ :=
  ⟨λ h => by cases h; exact ⟨rfl, heq_of_eq rfl⟩, -- in Lean 3 `simp` solved this
   λ ⟨h₁, h₂⟩ => by subst h₁; rw [eq_of_heq h₂]⟩
#align sigma.mk.inj_iff Sigma.mk.inj_iff

@[simp]
theorem eta : ∀ x : Σa, β a, Sigma.mk x.1 x.2 = x
  | ⟨_, _⟩ => rfl
#align sigma.eta Sigma.eta

@[ext]
theorem ext {x₀ x₁ : Sigma β} (h₀ : x₀.1 = x₁.1) (h₁ : HEq x₀.2 x₁.2) : x₀ = x₁ := by
  cases x₀; cases x₁; cases h₀; cases h₁; rfl
#align sigma.ext Sigma.ext

theorem ext_iff {x₀ x₁ : Sigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ HEq x₀.2 x₁.2 := by
  cases x₀; cases x₁; exact Sigma.mk.inj_iff
#align sigma.ext_iff Sigma.ext_iff

/-- A specialized ext lemma for equality of sigma types over an indexed subtype. -/
@[ext]
theorem subtype_ext {β : Type _} {p : α → β → Prop} :
    ∀ {x₀ x₁ : Σa, Subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
  | ⟨_, _, _⟩, ⟨_, _, _⟩, rfl, rfl => rfl
#align sigma.subtype_ext Sigma.subtype_ext

theorem subtype_ext_iff {β : Type _} {p : α → β → Prop} {x₀ x₁ : Σa, Subtype (p a)} :
    x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
  ⟨fun h ↦ h ▸ ⟨rfl, rfl⟩, fun ⟨h₁, h₂⟩ ↦ subtype_ext h₁ h₂⟩
#align sigma.subtype_ext_iff Sigma.subtype_ext_iff

@[simp]
theorem «forall» {p : (Σa, β a) → Prop} : (∀ x, p x) ↔ ∀ a b, p ⟨a, b⟩ :=
  ⟨fun h a b ↦ h ⟨a, b⟩, fun h ⟨a, b⟩ ↦ h a b⟩
#align sigma.forall Sigma.forall

@[simp]
theorem «exists» {p : (Σa, β a) → Prop} : (∃ x, p x) ↔ ∃ a b, p ⟨a, b⟩ :=
  ⟨fun ⟨⟨a, b⟩, h⟩ ↦ ⟨a, b, h⟩, fun ⟨a, b, h⟩ ↦ ⟨⟨a, b⟩, h⟩⟩
#align sigma.exists Sigma.exists

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : ∀ a, β₁ a → β₂ (f₁ a)) (x : Sigma β₁) : Sigma β₂ :=
  ⟨f₁ x.1, f₂ x.1 x.2⟩
#align sigma.map Sigma.map

lemma map_mk (f₁ : α₁ → α₂) (f₂ : ∀ a, β₁ a → β₂ (f₁ a)) (x : α₁) (y : β₁ x) :
    map f₁ f₂ ⟨x, y⟩ = ⟨f₁ x, f₂ x y⟩ := rfl
end Sigma

theorem sigma_mk_injective {i : α} : Function.Injective (@Sigma.mk α β i)
  | _, _, rfl => rfl
#align sigma_mk_injective sigma_mk_injective

theorem Function.Injective.sigma_map {f₁ : α₁ → α₂} {f₂ : ∀ a, β₁ a → β₂ (f₁ a)}
  (h₁ : Function.Injective f₁) (h₂ : ∀ a, Function.Injective (f₂ a)) :
    Function.Injective (Sigma.map f₁ f₂)
  | ⟨i, x⟩, ⟨j, y⟩, h => by
    obtain rfl : i = j := h₁ (Sigma.mk.inj_iff.mp h).1
    obtain rfl : x = y := h₂ i (sigma_mk_injective h)
    rfl
#align function.injective.sigma_map Function.Injective.sigma_map

theorem Function.Injective.of_sigma_map {f₁ : α₁ → α₂} {f₂ : ∀ a, β₁ a → β₂ (f₁ a)}
    (h : Function.Injective (Sigma.map f₁ f₂)) (a : α₁) : Function.Injective (f₂ a) :=
  fun x y hxy ↦
  sigma_mk_injective <| @h ⟨a, x⟩ ⟨a, y⟩ (Sigma.ext rfl (heq_of_eq hxy))
#align function.injective.of_sigma_map Function.Injective.of_sigma_map

theorem Function.Injective.sigma_map_iff {f₁ : α₁ → α₂} {f₂ : ∀ a, β₁ a → β₂ (f₁ a)}
  (h₁ : Function.Injective f₁) :
    Function.Injective (Sigma.map f₁ f₂) ↔ ∀ a, Function.Injective (f₂ a) :=
  ⟨fun h ↦ h.of_sigma_map, h₁.sigma_map⟩
#align function.injective.sigma_map_iff Function.Injective.sigma_map_iff

theorem Function.Surjective.sigma_map {f₁ : α₁ → α₂} {f₂ : ∀ a, β₁ a → β₂ (f₁ a)}
  (h₁ : Function.Surjective f₁) (h₂ : ∀ a, Function.Surjective (f₂ a)) :
    Function.Surjective (Sigma.map f₁ f₂) := by
  simp only [Function.Surjective, Sigma.forall, h₁.forall]
  exact fun i ↦ (h₂ _).forall.2 fun x ↦ ⟨⟨i, x⟩, rfl⟩
#align function.surjective.sigma_map Function.Surjective.sigma_map

/-- Interpret a function on `Σ x : α, β x` as a dependent function with two arguments.

This also exists as an `Equiv` as `Equiv.piCurry γ`. -/
def Sigma.curry {γ : ∀ a, β a → Type _} (f : ∀ x : Sigma β, γ x.1 x.2) (x : α) (y : β x) : γ x y :=
  f ⟨x, y⟩
#align sigma.curry Sigma.curry

/-- Interpret a dependent function with two arguments as a function on `Σ x : α, β x`.

This also exists as an `Equiv` as `(Equiv.piCurry γ).symm`. -/
def Sigma.uncurry {γ : ∀ a, β a → Type _} (f : ∀ (x) (y : β x), γ x y) (x : Sigma β) : γ x.1 x.2 :=
  f x.1 x.2
#align sigma.uncurry Sigma.uncurry

@[simp]
theorem Sigma.uncurry_curry {γ : ∀ a, β a → Type _} (f : ∀ x : Sigma β, γ x.1 x.2) :
    Sigma.uncurry (Sigma.curry f) = f :=
  funext fun ⟨_, _⟩ ↦ rfl
#align sigma.uncurry_curry Sigma.uncurry_curry

@[simp]
theorem Sigma.curry_uncurry {γ : ∀ a, β a → Type _} (f : ∀ (x) (y : β x), γ x y) :
    Sigma.curry (Sigma.uncurry f) = f :=
  rfl
#align sigma.curry_uncurry Sigma.curry_uncurry

/-- Convert a product type to a Σ-type. -/
def Prod.toSigma {α β} (p : α × β) : Σ_ : α, β :=
  ⟨p.1, p.2⟩
#align prod.to_sigma Prod.toSigma

@[simp]
theorem Prod.fst_comp_toSigma {α β} : Sigma.fst ∘ @Prod.toSigma α β = Prod.fst :=
  rfl
#align prod.fst_comp_to_sigma Prod.fst_comp_toSigma

@[simp]
theorem Prod.fst_toSigma {α β} (x : α × β) : (Prod.toSigma x).fst = x.fst :=
  rfl
#align prod.fst_to_sigma Prod.fst_toSigma

@[simp]
theorem Prod.snd_toSigma {α β} (x : α × β) : (Prod.toSigma x).snd = x.snd :=
  rfl
#align prod.snd_to_sigma Prod.snd_toSigma

@[simp]
theorem Prod.toSigma_mk {α β} (x : α) (y : β) : (x, y).toSigma = ⟨x, y⟩ :=
  rfl
#align prod.to_sigma_mk Prod.toSigma_mk

-- Porting note: the meta instance `has_reflect (Σa, β a)` was removed here.

end Sigma

namespace PSigma

variable {α : Sort _} {β : α → Sort _}

/-- Nondependent eliminator for `PSigma`. -/
def elim {γ} (f : ∀ a, β a → γ) (a : PSigma β) : γ :=
  PSigma.casesOn a f
#align psigma.elim PSigma.elim

@[simp]
theorem elim_val {γ} (f : ∀ a, β a → γ) (a b) : PSigma.elim f ⟨a, b⟩ = f a b :=
  rfl
#align psigma.elim_val PSigma.elim_val

instance [Inhabited α] [Inhabited (β default)] : Inhabited (PSigma β) :=
  ⟨⟨default, default⟩⟩

instance decidableEq [h₁ : DecidableEq α] [h₂ : ∀ a, DecidableEq (β a)] : DecidableEq (PSigma β)
  | ⟨a₁, b₁⟩, ⟨a₂, b₂⟩ =>
    match a₁, b₁, a₂, b₂, h₁ a₁ a₂ with
    | _, b₁, _, b₂, isTrue (Eq.refl _) =>
      match b₁, b₂, h₂ _ b₁ b₂ with
      | _, _, isTrue (Eq.refl _) => isTrue rfl
      | _, _, isFalse n => isFalse fun h ↦ PSigma.noConfusion h fun _ e₂ ↦ n <| eq_of_heq e₂
    | _, _, _, _, isFalse n => isFalse fun h ↦ PSigma.noConfusion h fun e₁ _ ↦ n e₁

-- See https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/porting.20data.2Esigma.2Ebasic/near/304855864
-- for an explanation of why this is currently needed. It generates `PSigma.mk.inj`.
-- This could be done elsewhere.
gen_injective_theorems% PSigma

theorem mk.inj_iff {a₁ a₂ : α} {b₁ : β a₁} {b₂ : β a₂} :
    @PSigma.mk α β a₁ b₁ = @PSigma.mk α β a₂ b₂ ↔ a₁ = a₂ ∧ HEq b₁ b₂ :=
  (Iff.intro PSigma.mk.inj) fun ⟨h₁, h₂⟩ ↦
    match a₁, a₂, b₁, b₂, h₁, h₂ with
    | _, _, _, _, Eq.refl _, HEq.refl _ => rfl
#align psigma.mk.inj_iff PSigma.mk.inj_iff

@[ext]
theorem ext {x₀ x₁ : PSigma β} (h₀ : x₀.1 = x₁.1) (h₁ : HEq x₀.2 x₁.2) : x₀ = x₁ := by
  cases x₀; cases x₁; cases h₀; cases h₁; rfl
#align psigma.ext PSigma.ext

theorem ext_iff {x₀ x₁ : PSigma β} : x₀ = x₁ ↔ x₀.1 = x₁.1 ∧ HEq x₀.2 x₁.2 := by
  cases x₀; cases x₁; exact PSigma.mk.inj_iff
#align psigma.ext_iff PSigma.ext_iff

@[simp]
theorem «forall» {p : (Σ'a, β a) → Prop} : (∀ x, p x) ↔ ∀ a b, p ⟨a, b⟩ :=
  ⟨fun h a b ↦ h ⟨a, b⟩, fun h ⟨a, b⟩ ↦ h a b⟩
#align psigma.forall PSigma.forall

@[simp]
theorem «exists» {p : (Σ'a, β a) → Prop} : (∃ x, p x) ↔ ∃ a b, p ⟨a, b⟩ :=
  ⟨fun ⟨⟨a, b⟩, h⟩ ↦ ⟨a, b, h⟩, fun ⟨a, b, h⟩ ↦ ⟨⟨a, b⟩, h⟩⟩
#align psigma.exists PSigma.exists

/-- A specialized ext lemma for equality of `PSigma` types over an indexed subtype. -/
@[ext]
theorem subtype_ext {β : Sort _} {p : α → β → Prop} :
    ∀ {x₀ x₁ : Σ'a, Subtype (p a)}, x₀.fst = x₁.fst → (x₀.snd : β) = x₁.snd → x₀ = x₁
  | ⟨_, _, _⟩, ⟨_, _, _⟩, rfl, rfl => rfl
#align psigma.subtype_ext PSigma.subtype_ext

theorem subtype_ext_iff {β : Sort _} {p : α → β → Prop} {x₀ x₁ : Σ'a, Subtype (p a)} :
    x₀ = x₁ ↔ x₀.fst = x₁.fst ∧ (x₀.snd : β) = x₁.snd :=
  ⟨fun h ↦ h ▸ ⟨rfl, rfl⟩, fun ⟨h₁, h₂⟩ ↦ subtype_ext h₁ h₂⟩
#align psigma.subtype_ext_iff PSigma.subtype_ext_iff

variable {α₁ : Sort _} {α₂ : Sort _} {β₁ : α₁ → Sort _} {β₂ : α₂ → Sort _}

/-- Map the left and right components of a sigma -/
def map (f₁ : α₁ → α₂) (f₂ : ∀ a, β₁ a → β₂ (f₁ a)) : PSigma β₁ → PSigma β₂
  | ⟨a, b⟩ => ⟨f₁ a, f₂ a b⟩
#align psigma.map PSigma.map

end PSigma


/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import algebra.group_with_zero.power
import algebra.ring.equiv
import tactic.linarith

/-!
# Integer power operation on fields and division rings

This file collects basic facts about the operation of raising an element of a `division_ring` to an
integer power. More specialised results are provided in the case of a linearly ordered field.
-/

open function int

variables {α β : Type*}

section division_ring
variables [division_ring α] [division_ring β]

@[simp] lemma ring_hom.map_zpow (f : α →+* β) : ∀ (a : α) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_monoid_with_zero_hom.map_zpow

@[simp] lemma ring_equiv.map_zpow (f : α ≃+* β) : ∀ (a : α) (n : ℤ), f (a ^ n) = f a ^ n :=
f.to_ring_hom.map_zpow

@[simp] lemma zpow_bit1_neg (x : α) (n : ℤ) : (-x) ^ bit1 n = - x ^ bit1 n :=
by rw [zpow_bit1', zpow_bit1', neg_mul_neg, neg_mul_eq_mul_neg]

@[simp, norm_cast] lemma rat.cast_zpow [char_zero α] (q : ℚ) (n : ℤ) : ((q ^ n : ℚ) : α) = q ^ n :=
(rat.cast_hom α).map_zpow q n

end division_ring

section linear_ordered_semifield
variables [linear_ordered_semifield α] {a b x : α} {m n : ℤ}

lemma zpow_nonneg (ha : 0 ≤ a) : ∀ (z : ℤ), 0 ≤ a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_nonneg ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_nonneg.2 (pow_nonneg ha _) }

lemma zpow_pos_of_pos (ha : 0 < a) : ∀ (z : ℤ), 0 < a ^ z
| (n : ℕ) := by { rw zpow_coe_nat, exact pow_pos ha _ }
| -[1+n]  := by { rw zpow_neg_succ_of_nat, exact inv_pos.2 (pow_pos ha _) }

lemma zpow_le_of_le (ha : 1 ≤ a) (h : m ≤ n) : a ^ m ≤ a ^ n :=
begin
  induction m with m m; induction n with n n,
  { simp only [of_nat_eq_coe, zpow_coe_nat],
    exact pow_le_pow ha (le_of_coe_nat_le_coe_nat h) },
  { cases h.not_lt ((neg_succ_lt_zero _).trans_le $ of_nat_nonneg _) },
  { simp only [zpow_neg_succ_of_nat, one_div, of_nat_eq_coe, zpow_coe_nat],
    apply le_trans (inv_le_one _); apply one_le_pow_of_one_le ha },
  { simp only [zpow_neg_succ_of_nat],
    apply (inv_le_inv _ _).2,
    { apply pow_le_pow ha,
      have : -(↑(m+1) : ℤ) ≤ -(↑(n+1) : ℤ), from h,
      have h' := le_of_neg_le_neg this,
      apply le_of_coe_nat_le_coe_nat h' },
    repeat { apply pow_pos (zero_lt_one.trans_le ha) } }
end

lemma pow_le_max_of_min_le (hx : 1 ≤ x) {a b c : ℤ} (h : min a b ≤ c) :
  x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b)) :=
begin
  wlog hle : a ≤ b,
  have hnle : -b ≤ -a, from neg_le_neg hle,
  have hfle : x ^ (-b) ≤ x ^ (-a), from zpow_le_of_le hx hnle,
  have : x ^ (-c) ≤ x ^ (-a),
  { apply zpow_le_of_le hx,
    simpa only [min_eq_left hle, neg_le_neg_iff] using h },
  simpa only [max_eq_left hfle]
end

lemma zpow_le_one_of_nonpos (ha : 1 ≤ a) (hn : n ≤ 0) : a ^ n ≤ 1 :=
(zpow_le_of_le ha hn).trans_eq $ zpow_zero _

lemma one_le_zpow_of_nonneg (ha : 1 ≤ a) (hn : 0 ≤ n) : 1 ≤ a ^ n :=
(zpow_zero _).symm.trans_le $ zpow_le_of_le ha hn

protected lemma nat.zpow_pos_of_pos {a : ℕ} (h : 0 < a) (n : ℤ) : 0 < (a : α)^n :=
by { apply zpow_pos_of_pos, exact_mod_cast h }

lemma nat.zpow_ne_zero_of_pos {a : ℕ} (h : 0 < a) (n : ℤ) : (a : α)^n ≠ 0 :=
(nat.zpow_pos_of_pos h n).ne'

lemma one_lt_zpow (ha : 1 < a) : ∀ n : ℤ, 0 < n → 1 < a ^ n
| (n : ℕ) h := (zpow_coe_nat _ _).symm.subst (one_lt_pow ha $ int.coe_nat_ne_zero.mp h.ne')
| -[1+ n] h := ((int.neg_succ_not_pos _).mp h).elim

lemma zpow_strict_mono (hx : 1 < x) : strict_mono ((^) x : ℤ → α) :=
strict_mono_int_of_lt_succ $ λ n,
have xpos : 0 < x, from zero_lt_one.trans hx,
calc x ^ n < x ^ n * x : lt_mul_of_one_lt_right (zpow_pos_of_pos xpos _) hx
... = x ^ (n + 1) : (zpow_add_one₀ xpos.ne' _).symm

lemma zpow_strict_anti (h₀ : 0 < x) (h₁ : x < 1) : strict_anti ((^) x : ℤ → α) :=
strict_anti_int_of_succ_lt $ λ n,
calc x ^ (n + 1) = x ^ n * x : zpow_add_one₀ h₀.ne' _
... < x ^ n * 1 : (mul_lt_mul_left $ zpow_pos_of_pos h₀ _).2 h₁
... = x ^ n : mul_one _

@[simp] lemma zpow_lt_iff_lt (hx : 1 < x) : x ^ m < x ^ n ↔ m < n := (zpow_strict_mono hx).lt_iff_lt
@[simp] lemma zpow_le_iff_le (hx : 1 < x) : x ^ m ≤ x ^ n ↔ m ≤ n := (zpow_strict_mono hx).le_iff_le

lemma min_le_of_zpow_le_max (hx : 1 < x) {a b c : ℤ}
  (h_max : x ^ (-c) ≤ max (x ^ (-a)) (x ^ (-b))) : min a b ≤ c :=
begin
  rw min_le_iff,
  refine or.imp (λ h, _) (λ h, _) (le_max_iff.mp h_max);
  rwa [zpow_le_iff_le hx, neg_le_neg_iff] at h
end

@[simp] lemma pos_div_pow_pos (ha : 0 < a) (hb : 0 < b) (k : ℕ) : 0 < a/b^k :=
div_pos ha (pow_pos hb k)

@[simp] lemma div_pow_le (ha : 0 < a) (hb : 1 ≤ b) (k : ℕ) : a/b^k ≤ a :=
(div_le_iff $ pow_pos (lt_of_lt_of_le zero_lt_one hb) k).mpr
(calc a = a * 1 : (mul_one a).symm
   ...  ≤ a*b^k : (mul_le_mul_left ha).mpr $ one_le_pow_of_one_le hb _)

lemma zpow_injective (h₀ : 0 < x) (h₁ : x ≠ 1) : injective ((^) x : ℤ → α) :=
begin
  intros m n h,
  rcases h₁.lt_or_lt with H|H,
  { apply (zpow_strict_mono (one_lt_inv h₀ H)).injective,
    show x⁻¹ ^ m = x⁻¹ ^ n,
    rw [← zpow_neg_one, ← zpow_mul, ← zpow_mul, mul_comm _ m, mul_comm _ n, zpow_mul, zpow_mul,
      h], },
  { exact (zpow_strict_mono H).injective h, },
end

@[simp] lemma zpow_inj (h₀ : 0 < x) (h₁ : x ≠ 1) : x ^ m = x ^ n ↔ m = n :=
(zpow_injective h₀ h₁).eq_iff

end linear_ordered_semifield

section linear_ordered_field
variables [linear_ordered_field α] {a x : α} {m n : ℤ}

lemma zpow_bit0_nonneg (a : α) (n : ℤ) : 0 ≤ a ^ bit0 n :=
(mul_self_nonneg _).trans_eq $ (zpow_bit0 _ _).symm

lemma zpow_two_nonneg (a : α) : 0 ≤ a ^ (2 : ℤ) := zpow_bit0_nonneg _ _

lemma zpow_bit0_pos (h : a ≠ 0) (n : ℤ) : 0 < a ^ bit0 n :=
(zpow_bit0_nonneg a n).lt_of_ne (zpow_ne_zero _ h).symm

lemma zpow_two_pos_of_ne_zero (h : a ≠ 0) : 0 < a ^ (2 : ℤ) := zpow_bit0_pos h _

@[simp] theorem zpow_bit1_neg_iff : a ^ bit1 n < 0 ↔ a < 0 :=
⟨λ h, not_le.1 $ λ h', not_le.2 h $ zpow_nonneg h' _,
 λ h, by rw [bit1, zpow_add_one₀ h.ne]; exact mul_neg_of_pos_of_neg (zpow_bit0_pos h.ne _) h⟩

@[simp] theorem zpow_bit1_nonneg_iff : 0 ≤ a ^ bit1 n ↔ 0 ≤ a :=
le_iff_le_iff_lt_iff_lt.2 zpow_bit1_neg_iff

@[simp] theorem zpow_bit1_nonpos_iff : a ^ bit1 n ≤ 0 ↔ a ≤ 0 :=
begin
  rw [le_iff_lt_or_eq, zpow_bit1_neg_iff],
  split,
  { rintro (h | h),
    { exact h.le },
    { exact (zpow_eq_zero h).le } },
  { intro h,
    rcases eq_or_lt_of_le h with rfl|h,
    { exact or.inr (zero_zpow _ (bit1_ne_zero n)) },
    { exact or.inl h } }
end

@[simp] theorem zpow_bit1_pos_iff : 0 < a ^ bit1 n ↔ 0 < a :=
lt_iff_lt_of_le_iff_le zpow_bit1_nonpos_iff

end linear_ordered_field


inductive gcd : ℕ → ℕ → ℕ → Prop
| gcd_0 : ∀ n, gcd n 0 n
| gcd_step : ∀ n m p, gcd m n p → gcd (n + m) n p
| gcd_swap : ∀ n m p, gcd m n p → gcd n m p

example : forall n, gcd n (n + 1) 1 := begin
    intros n,
    apply gcd.gcd_swap,
    apply gcd.gcd_step,
    induction n,
    apply gcd.gcd_0,
    apply gcd.gcd_swap,
    rw nat.succ_eq_add_one,
    rw nat.add_comm n_n 1,
    apply gcd.gcd_step,
    apply gcd.gcd_swap,
    assumption
end


/-
Copyright (c) 2020 Thomas Browning, Patrick Lutz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning, Patrick Lutz
-/

import field_theory.adjoin
import field_theory.is_alg_closed.basic
import field_theory.separable
import ring_theory.integral_domain

/-!
# Primitive Element Theorem

In this file we prove the primitive element theorem.

## Main results

- `exists_primitive_element`: a finite separable extension `E / F` has a primitive element, i.e.
  there is an `α : E` such that `F⟮α⟯ = (⊤ : subalgebra F E)`.

## Implementation notes

In declaration names, `primitive_element` abbreviates `adjoin_simple_eq_top`:
it stands for the statement `F⟮α⟯ = (⊤ : subalgebra F E)`. We did not add an extra
declaration `is_primitive_element F α := F⟮α⟯ = (⊤ : subalgebra F E)` because this
requires more unfolding without much obvious benefit.

## Tags

primitive element, separable field extension, separable extension, intermediate field, adjoin,
exists_adjoin_simple_eq_top

-/

noncomputable theory
open_locale classical

open finite_dimensional polynomial intermediate_field

namespace field

section primitive_element_finite
variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

/-! ### Primitive element theorem for finite fields -/

/-- **Primitive element theorem** assuming E is finite. -/
lemma exists_primitive_element_of_fintype_top [fintype E] : ∃ α : E, F⟮α⟯ = ⊤ :=
begin
  obtain ⟨α, hα⟩ := is_cyclic.exists_generator (units E),
  use α,
  apply eq_top_iff.mpr,
  rintros x -,
  by_cases hx : x = 0,
  { rw hx,
    exact F⟮α.val⟯.zero_mem },
  { obtain ⟨n, hn⟩ := set.mem_range.mp (hα (units.mk0 x hx)),
    rw (show x = α^n, by { norm_cast, rw [hn, units.coe_mk0] }),
    exact pow_mem F⟮↑α⟯ (mem_adjoin_simple_self F ↑α) n, },
end

/-- Primitive element theorem for finite dimensional extension of a finite field. -/
theorem exists_primitive_element_of_fintype_bot [fintype F] [finite_dimensional F E] :
  ∃ α : E, F⟮α⟯ = ⊤ :=
begin
  haveI : fintype E := fintype_of_fintype F E,
  exact exists_primitive_element_of_fintype_top F E,
end

end primitive_element_finite

/-! ### Primitive element theorem for infinite fields -/

section primitive_element_inf

variables {F : Type*} [field F] [infinite F] {E : Type*} [field E] (ϕ : F →+* E) (α β : E)

lemma primitive_element_inf_aux_exists_c (f g : polynomial F) :
  ∃ c : F, ∀ (α' ∈ (f.map ϕ).roots) (β' ∈ (g.map ϕ).roots), -(α' - α)/(β' - β) ≠ ϕ c :=
begin
  let sf := (f.map ϕ).roots,
  let sg := (g.map ϕ).roots,
  let s := (sf.bind (λ α', sg.map (λ β', -(α' - α) / (β' - β)))).to_finset,
  let s' := s.preimage ϕ (λ x hx y hy h, ϕ.injective h),
  obtain ⟨c, hc⟩ := infinite.exists_not_mem_finset s',
  simp_rw [finset.mem_preimage, multiset.mem_to_finset, multiset.mem_bind, multiset.mem_map] at hc,
  push_neg at hc,
  exact ⟨c, hc⟩,
end

variables (F) [algebra F E]

-- This is the heart of the proof of the primitive element theorem. It shows that if `F` is
-- infinite and `α` and `β` are separable over `F` then `F⟮α, β⟯` is generated by a single element.
lemma primitive_element_inf_aux [is_separable F E] :
  ∃ γ : E, F⟮α, β⟯ = F⟮γ⟯ :=
begin
  have hα := is_separable.is_integral F α,
  have hβ := is_separable.is_integral F β,
  let f := minpoly F α,
  let g := minpoly F β,
  let ιFE := algebra_map F E,
  let ιEE' := algebra_map E (splitting_field (g.map ιFE)),
  obtain ⟨c, hc⟩ := primitive_element_inf_aux_exists_c (ιEE'.comp ιFE) (ιEE' α) (ιEE' β) f g,
  let γ := α + c • β,
  suffices β_in_Fγ : β ∈ F⟮γ⟯,
  { use γ,
    apply le_antisymm,
    { rw adjoin_le_iff,
      have α_in_Fγ : α ∈ F⟮γ⟯,
      { rw ← add_sub_cancel α (c • β),
        exact F⟮γ⟯.sub_mem (mem_adjoin_simple_self F γ) (F⟮γ⟯.to_subalgebra.smul_mem β_in_Fγ c) },
      exact λ x hx, by cases hx; cases hx; cases hx; assumption },
    { rw adjoin_le_iff,
      change {γ} ⊆ _,
      rw set.singleton_subset_iff,
      have α_in_Fαβ : α ∈ F⟮α, β⟯ := subset_adjoin F {α, β} (set.mem_insert α {β}),
      have β_in_Fαβ : β ∈ F⟮α, β⟯ := subset_adjoin F {α, β} (set.mem_insert_of_mem α rfl),
      exact F⟮α,β⟯.add_mem α_in_Fαβ (F⟮α, β⟯.smul_mem β_in_Fαβ) } },
  let p := euclidean_domain.gcd ((f.map (algebra_map F F⟮γ⟯)).comp
    (C (adjoin_simple.gen F γ) - (C ↑c * X))) (g.map (algebra_map F F⟮γ⟯)),
  let h := euclidean_domain.gcd ((f.map ιFE).comp (C γ - (C (ιFE c) * X))) (g.map ιFE),
  have map_g_ne_zero : g.map ιFE ≠ 0 := map_ne_zero (minpoly.ne_zero hβ),
  have h_ne_zero : h ≠ 0 :=  mt euclidean_domain.gcd_eq_zero_iff.mp
    (not_and.mpr (λ _, map_g_ne_zero)),
  suffices p_linear : p.map (algebra_map F⟮γ⟯ E) = (C h.leading_coeff) * (X - C β),
  { have finale : β = algebra_map F⟮γ⟯ E (-p.coeff 0 / p.coeff 1),
    { rw [ring_hom.map_div, ring_hom.map_neg, ←coeff_map, ←coeff_map, p_linear],
      simp [mul_sub, coeff_C, mul_div_cancel_left β (mt leading_coeff_eq_zero.mp h_ne_zero)] },
    rw finale,
    exact subtype.mem (-p.coeff 0 / p.coeff 1) },
  have h_sep : h.separable := separable_gcd_right _ (is_separable.separable F β).map,
  have h_root : h.eval β = 0,
  { apply eval_gcd_eq_zero,
    { rw [eval_comp, eval_sub, eval_mul, eval_C, eval_C, eval_X, eval_map, ←aeval_def,
          ←algebra.smul_def, add_sub_cancel, minpoly.aeval] },
    { rw [eval_map, ←aeval_def, minpoly.aeval] } },
  have h_splits : splits ιEE' h := splits_of_splits_gcd_right ιEE' map_g_ne_zero
    (splitting_field.splits _),
  have h_roots : ∀ x ∈ (h.map ιEE').roots, x = ιEE' β,
  { intros x hx,
    rw mem_roots_map h_ne_zero at hx,
    specialize hc ((ιEE' γ) - (ιEE' (ιFE c)) * x) (begin
      have f_root := root_left_of_root_gcd hx,
      rw [eval₂_comp, eval₂_sub, eval₂_mul,eval₂_C, eval₂_C, eval₂_X, eval₂_map] at f_root,
      exact (mem_roots_map (minpoly.ne_zero hα)).mpr f_root,
    end),
    specialize hc x (begin
      rw [mem_roots_map (minpoly.ne_zero hβ), ←eval₂_map],
      exact root_right_of_root_gcd hx,
    end),
    by_contradiction a,
    apply hc,
    apply (div_eq_iff (sub_ne_zero.mpr a)).mpr,
    simp only [algebra.smul_def, ring_hom.map_add, ring_hom.map_mul, ring_hom.comp_apply],
    ring },
  rw ← eq_X_sub_C_of_separable_of_root_eq h_sep h_root h_splits h_roots,
  transitivity euclidean_domain.gcd (_ : polynomial E) (_ : polynomial E),
  { dsimp only [p],
    convert (gcd_map (algebra_map F⟮γ⟯ E)).symm },
  { simpa [map_comp, map_map, ←is_scalar_tower.algebra_map_eq, h] },
end

end primitive_element_inf

variables (F E : Type*) [field F] [field E]
variables [algebra F E] [finite_dimensional F E] [is_separable F E]

/-- Primitive element theorem: a finite separable field extension `E` of `F` has a
  primitive element, i.e. there is an `α ∈ E` such that `F⟮α⟯ = (⊤ : subalgebra F E)`.-/
theorem exists_primitive_element : ∃ α : E, F⟮α⟯ = ⊤ :=
begin
  rcases is_empty_or_nonempty (fintype F) with F_inf|⟨⟨F_finite⟩⟩,
  { let P : intermediate_field F E → Prop := λ K, ∃ α : E, F⟮α⟯ = K,
    have base : P ⊥ := ⟨0, adjoin_zero⟩,
    have ih : ∀ (K : intermediate_field F E) (x : E), P K → P ↑K⟮x⟯,
    { intros K β hK,
      cases hK with α hK,
      rw [←hK, adjoin_simple_adjoin_simple],
      haveI : infinite F := is_empty_fintype.mp F_inf,
      cases primitive_element_inf_aux F α β with γ hγ,
      exact ⟨γ, hγ.symm⟩ },
    exact induction_on_adjoin P base ih ⊤ },
  { exactI exists_primitive_element_of_fintype_bot F E }
end

/-- Alternative phrasing of primitive element theorem:
a finite separable field extension has a basis `1, α, α^2, ..., α^n`.

See also `exists_primitive_element`. -/
noncomputable def power_basis_of_finite_of_separable : power_basis F E :=
let α := (exists_primitive_element F E).some,
    pb := (adjoin.power_basis (is_separable.is_integral F α)) in
have e : F⟮α⟯ = ⊤ := (exists_primitive_element F E).some_spec,
pb.map ((intermediate_field.equiv_of_eq e).trans intermediate_field.top_equiv)

/-- If `E / F` is a finite separable extension, then there are finitely many
embeddings from `E` into `K` that fix `F`, corresponding to the number of
conjugate roots of the primitive element generating `F`. -/
instance {K : Type*} [field K] [algebra F K] : fintype (E →ₐ[F] K) :=
power_basis.alg_hom.fintype (power_basis_of_finite_of_separable F E)

end field

@[simp] lemma alg_hom.card (F E K : Type*) [field F] [field E] [field K] [is_alg_closed K]
  [algebra F E] [finite_dimensional F E] [is_separable F E] [algebra F K] :
  fintype.card (E →ₐ[F] K) = finrank F E :=
(alg_hom.card_of_power_basis (field.power_basis_of_finite_of_separable F E)
    (is_separable.separable _ _) (is_alg_closed.splits_codomain _)).trans
  (power_basis.finrank _).symm