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

/-!
# Lexicographic ordering of lists.

The lexicographic order on `list α` is defined by `L < M` iff
* `[] < (a :: L)` for any `a` and `L`,
* `(a :: L) < (b :: M)` where `a < b`, or
* `(a :: L) < (a :: M)` where `L < M`.

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.psigma.order`: Lexicographic order on `Σ' i, α i`.
* `data.sigma.order`: Lexicographic order on `Σ i, α i`.
* `order.lexicographic`: Lexicographic order on `α × β`.
-/

namespace list

open nat

universes u

variables {α : Type u}

/-! ### lexicographic ordering -/

/-- Given a strict order `<` on `α`, the lexicographic strict order on `list α`, for which
`[a0, ..., an] < [b0, ..., b_k]` if `a0 < b0` or `a0 = b0` and `[a1, ..., an] < [b1, ..., bk]`.
The definition is given for any relation `r`, not only strict orders. -/
inductive lex (r : α → α → Prop) : list α → list α → Prop
| nil {a l} : lex [] (a :: l)
| cons {a l₁ l₂} (h : lex l₁ l₂) : lex (a :: l₁) (a :: l₂)
| rel {a₁ l₁ a₂ l₂} (h : r a₁ a₂) : lex (a₁ :: l₁) (a₂ :: l₂)

namespace lex
theorem cons_iff {r : α → α → Prop} [is_irrefl α r] {a l₁ l₂} :
  lex r (a :: l₁) (a :: l₂) ↔ lex r l₁ l₂ :=
⟨λ h, by cases h with _ _ _ _ _ h _ _ _ _ h;
  [exact h, exact (irrefl_of r a h).elim], lex.cons⟩

@[simp] theorem not_nil_right (r : α → α → Prop) (l : list α) : ¬ lex r l [].

instance is_order_connected (r : α → α → Prop)
  [is_order_connected α r] [is_trichotomous α r] :
  is_order_connected (list α) (lex r) :=
⟨λ l₁, match l₁ with
| _,     [],    c::l₃, nil    := or.inr nil
| _,     [],    c::l₃, rel _ := or.inr nil
| _,     [],    c::l₃, cons _ := or.inr nil
| _,     b::l₂, c::l₃, nil := or.inl nil
| a::l₁, b::l₂, c::l₃, rel h :=
  (is_order_connected.conn _ b _ h).imp rel rel
| a::l₁, b::l₂, _::l₃, cons h := begin
    rcases trichotomous_of r a b with ab | rfl | ab,
    { exact or.inl (rel ab) },
    { exact (_match _ l₂ _ h).imp cons cons },
    { exact or.inr (rel ab) }
  end
end⟩

instance is_trichotomous (r : α → α → Prop) [is_trichotomous α r] :
  is_trichotomous (list α) (lex r) :=
⟨λ l₁, match l₁ with
| [], [] := or.inr (or.inl rfl)
| [], b::l₂ := or.inl nil
| a::l₁, [] := or.inr (or.inr nil)
| a::l₁, b::l₂ := begin
    rcases trichotomous_of r a b with ab | rfl | ab,
    { exact or.inl (rel ab) },
    { exact (_match l₁ l₂).imp cons
      (or.imp (congr_arg _) cons) },
    { exact or.inr (or.inr (rel ab)) }
  end
end⟩

instance is_asymm (r : α → α → Prop)
  [is_asymm α r] : is_asymm (list α) (lex r) :=
⟨λ l₁, match l₁ with
| a::l₁, b::l₂, lex.rel h₁, lex.rel h₂ := asymm h₁ h₂
| a::l₁, b::l₂, lex.rel h₁, lex.cons h₂ := asymm h₁ h₁
| a::l₁, b::l₂, lex.cons h₁, lex.rel h₂ := asymm h₂ h₂
| a::l₁, b::l₂, lex.cons h₁, lex.cons h₂ :=
  by exact _match _ _ h₁ h₂
end⟩

instance is_strict_total_order (r : α → α → Prop)
  [is_strict_total_order' α r] : is_strict_total_order' (list α) (lex r) :=
{..is_strict_weak_order_of_is_order_connected}

instance decidable_rel [decidable_eq α] (r : α → α → Prop)
  [decidable_rel r] : decidable_rel (lex r)
| l₁ [] := is_false $ λ h, by cases h
| [] (b::l₂) := is_true lex.nil
| (a::l₁) (b::l₂) := begin
  haveI := decidable_rel l₁ l₂,
  refine decidable_of_iff (r a b ∨ a = b ∧ lex r l₁ l₂) ⟨λ h, _, λ h, _⟩,
  { rcases h with h | ⟨rfl, h⟩,
    { exact lex.rel h },
    { exact lex.cons h } },
  { rcases h with _|⟨_,_,_,h⟩|⟨_,_,_,_,h⟩,
    { exact or.inr ⟨rfl, h⟩ },
    { exact or.inl h } }
end

theorem append_left (R : α → α → Prop) {t₁ t₂} (h : lex R t₁ t₂) :
  ∀ s, lex R (s ++ t₁) (s ++ t₂)
| []      := h
| (a::l) := cons (append_left l)

theorem imp {r s : α → α → Prop} (H : ∀ a b, r a b → s a b) :
  ∀ l₁ l₂, lex r l₁ l₂ → lex s l₁ l₂
| _ _ nil      := nil
| _ _ (cons h) := cons (imp _ _ h)
| _ _ (rel r)  := rel (H _ _ r)

theorem to_ne : ∀ {l₁ l₂ : list α}, lex (≠) l₁ l₂ → l₁ ≠ l₂
| _ _ (cons h) e := to_ne h (list.cons.inj e).2
| _ _ (rel r)  e := r (list.cons.inj e).1

theorem _root_.decidable.list.lex.ne_iff [decidable_eq α]
  {l₁ l₂ : list α} (H : length l₁ ≤ length l₂) : lex (≠) l₁ l₂ ↔ l₁ ≠ l₂ :=
⟨to_ne, λ h, begin
  induction l₁ with a l₁ IH generalizing l₂; cases l₂ with b l₂,
  { contradiction },
  { apply nil },
  { exact (not_lt_of_ge H).elim (succ_pos _) },
  { by_cases ab : a = b,
    { subst b, apply cons,
      exact IH (le_of_succ_le_succ H) (mt (congr_arg _) h) },
    { exact rel ab } }
end⟩

theorem ne_iff {l₁ l₂ : list α} (H : length l₁ ≤ length l₂) : lex (≠) l₁ l₂ ↔ l₁ ≠ l₂ :=
by classical; exact decidable.list.lex.ne_iff H

end lex

--Note: this overrides an instance in core lean
instance has_lt' [has_lt α] : has_lt (list α) := ⟨lex (<)⟩

theorem nil_lt_cons [has_lt α] (a : α) (l : list α) : [] < a :: l :=
lex.nil

instance [linear_order α] : linear_order (list α) :=
linear_order_of_STO' (lex (<))

--Note: this overrides an instance in core lean
instance has_le' [linear_order α] : has_le (list α) :=
preorder.to_has_le _

end list


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import topology.uniform_space.uniform_convergence
import topology.uniform_space.uniform_embedding
import topology.uniform_space.complete_separated
import topology.algebra.group
import tactic.abel

/-!
# Uniform structure on topological groups

* `topological_add_group.to_uniform_space` and `topological_add_group_is_uniform` can be used to
  construct a canonical uniformity for a topological add group.

* extension of ℤ-bilinear maps to complete groups (useful for ring completions)
-/

noncomputable theory
open_locale classical uniformity topological_space filter

section uniform_group
open filter set

variables {α : Type*} {β : Type*}

/-- A uniform group is a group in which multiplication and inversion are uniformly continuous. -/
class uniform_group (α : Type*) [uniform_space α] [group α] : Prop :=
(uniform_continuous_div : uniform_continuous (λp:α×α, p.1 / p.2))

/-- A uniform additive group is an additive group in which addition
  and negation are uniformly continuous.-/
class uniform_add_group (α : Type*) [uniform_space α] [add_group α] : Prop :=
(uniform_continuous_sub : uniform_continuous (λp:α×α, p.1 - p.2))

attribute [to_additive] uniform_group

@[to_additive] theorem uniform_group.mk' {α} [uniform_space α] [group α]
  (h₁ : uniform_continuous (λp:α×α, p.1 * p.2))
  (h₂ : uniform_continuous (λp:α, p⁻¹)) : uniform_group α :=
⟨by simpa only [div_eq_mul_inv] using
  h₁.comp (uniform_continuous_fst.prod_mk (h₂.comp uniform_continuous_snd))⟩

variables [uniform_space α] [group α] [uniform_group α]

@[to_additive] lemma uniform_continuous_div : uniform_continuous (λp:α×α, p.1 / p.2) :=
uniform_group.uniform_continuous_div

@[to_additive] lemma uniform_continuous.div [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x / g x) :=
uniform_continuous_div.comp (hf.prod_mk hg)

@[to_additive] lemma uniform_continuous.inv [uniform_space β] {f : β → α}
  (hf : uniform_continuous f) : uniform_continuous (λx, (f x)⁻¹) :=
have uniform_continuous (λx, 1 / f x),
  from uniform_continuous_const.div hf,
by simp * at *

@[to_additive] lemma uniform_continuous_inv : uniform_continuous (λx:α, x⁻¹) :=
uniform_continuous_id.inv

@[to_additive] lemma uniform_continuous.mul [uniform_space β] {f : β → α} {g : β → α}
  (hf : uniform_continuous f) (hg : uniform_continuous g) : uniform_continuous (λx, f x * g x) :=
have uniform_continuous (λx, f x / (g x)⁻¹), from hf.div hg.inv,
by simp * at *

@[to_additive] lemma uniform_continuous_mul : uniform_continuous (λp:α×α, p.1 * p.2) :=
uniform_continuous_fst.mul uniform_continuous_snd

@[priority 10, to_additive]
instance uniform_group.to_topological_group : topological_group α :=
{ continuous_mul := uniform_continuous_mul.continuous,
  continuous_inv := uniform_continuous_inv.continuous }

@[to_additive] instance [uniform_space β] [group β] [uniform_group β] : uniform_group (α × β) :=
⟨((uniform_continuous_fst.comp uniform_continuous_fst).div
  (uniform_continuous_fst.comp uniform_continuous_snd)).prod_mk
 ((uniform_continuous_snd.comp uniform_continuous_fst).div
  (uniform_continuous_snd.comp uniform_continuous_snd))⟩

@[to_additive] lemma uniformity_translate_mul (a : α) :
  (𝓤 α).map (λx:α×α, (x.1 * a, x.2 * a)) = 𝓤 α :=
le_antisymm
  (uniform_continuous_id.mul uniform_continuous_const)
  (calc 𝓤 α =
    ((𝓤 α).map (λx:α×α, (x.1 * a⁻¹, x.2 * a⁻¹))).map (λx:α×α, (x.1 * a, x.2 * a)) :
      by simp [filter.map_map, (∘)]; exact filter.map_id.symm
    ... ≤ (𝓤 α).map (λx:α×α, (x.1 * a, x.2 * a)) :
      filter.map_mono (uniform_continuous_id.mul uniform_continuous_const))

@[to_additive] lemma uniform_embedding_translate_mul (a : α) : uniform_embedding (λx:α, x * a) :=
{ comap_uniformity := begin
    rw [← uniformity_translate_mul a, comap_map] {occs := occurrences.pos [1]},
    rintros ⟨p₁, p₂⟩ ⟨q₁, q₂⟩,
    simp [prod.eq_iff_fst_eq_snd_eq] {contextual := tt}
  end,
  inj := mul_left_injective a }

section
variables (α)
@[to_additive] lemma uniformity_eq_comap_nhds_one : 𝓤 α = comap (λx:α×α, x.2 / x.1) (𝓝 (1:α)) :=
begin
  rw [nhds_eq_comap_uniformity, filter.comap_comap],
  refine le_antisymm (filter.map_le_iff_le_comap.1 _) _,
  { assume s hs,
    rcases mem_uniformity_of_uniform_continuous_invariant uniform_continuous_div hs
      with ⟨t, ht, hts⟩,
    refine mem_map.2 (mem_of_superset ht _),
    rintros ⟨a, b⟩,
    simpa [subset_def] using hts a b a },
  { assume s hs,
    rcases mem_uniformity_of_uniform_continuous_invariant uniform_continuous_mul hs
      with ⟨t, ht, hts⟩,
    refine ⟨_, ht, _⟩,
    rintros ⟨a, b⟩, simpa [subset_def] using hts 1 (b / a) a }
end
end

@[to_additive] lemma group_separation_rel (x y : α) :
  (x, y) ∈ separation_rel α ↔ x / y ∈ closure ({1} : set α) :=
have embedding (λa, a * (y / x)), from (uniform_embedding_translate_mul (y / x)).embedding,
show (x, y) ∈ ⋂₀ (𝓤 α).sets ↔ x / y ∈ closure ({1} : set α),
begin
  rw [this.closure_eq_preimage_closure_image, uniformity_eq_comap_nhds_one α, sInter_comap_sets],
  simp [mem_closure_iff_nhds, inter_singleton_nonempty, sub_eq_add_neg, add_assoc]
end

@[to_additive] lemma uniform_continuous_of_tendsto_one
  [uniform_space β] [group β] [uniform_group β] {f : α →* β} (h : tendsto f (𝓝 1) (𝓝 1)) :
  uniform_continuous f :=
begin
  have : ((λx:β×β, x.2 / x.1) ∘ (λx:α×α, (f x.1, f x.2))) = (λx:α×α, f (x.2 / x.1)),
  { simp only [f.map_div] },
  rw [uniform_continuous, uniformity_eq_comap_nhds_one α, uniformity_eq_comap_nhds_one β,
    tendsto_comap_iff, this],
  exact tendsto.comp h tendsto_comap
end

@[to_additive] lemma monoid_hom.uniform_continuous_of_continuous_at_one
  [uniform_space β] [group β] [uniform_group β]
  (f : α →* β) (hf : continuous_at f 1) :
  uniform_continuous f :=
uniform_continuous_of_tendsto_one (by simpa using hf.tendsto)

@[to_additive] lemma uniform_continuous_monoid_hom_of_continuous [uniform_space β]
  [group β] [uniform_group β] {f : α →* β} (h : continuous f) : uniform_continuous f :=
uniform_continuous_of_tendsto_one $
  suffices tendsto f (𝓝 1) (𝓝 (f 1)), by rwa f.map_one at this,
  h.tendsto 1

@[to_additive] lemma cauchy_seq.mul {ι : Type*} [semilattice_sup ι] {u v : ι → α}
  (hu : cauchy_seq u) (hv : cauchy_seq v) : cauchy_seq (u * v) :=
uniform_continuous_mul.comp_cauchy_seq (hu.prod hv)

end uniform_group

section topological_comm_group
open filter
variables (G : Type*) [comm_group G] [topological_space G] [topological_group G]

/-- The right uniformity on a topological group. -/
@[to_additive "The right uniformity on a topological group"]
def topological_group.to_uniform_space : uniform_space G :=
{ uniformity          := comap (λp:G×G, p.2 / p.1) (𝓝 1),
  refl                :=
    by refine map_le_iff_le_comap.1 (le_trans _ (pure_le_nhds 1));
      simp [set.subset_def] {contextual := tt},
  symm                :=
  begin
    suffices : tendsto (λp:G×G, (p.2 / p.1)⁻¹) (comap (λp:G×G, p.2 / p.1) (𝓝 1)) (𝓝 1⁻¹),
    { simpa [tendsto_comap_iff], },
    exact tendsto.comp (tendsto.inv tendsto_id) tendsto_comap
  end,
  comp                :=
  begin
    intros D H,
    rw mem_lift'_sets,
    { rcases H with ⟨U, U_nhds, U_sub⟩,
      rcases exists_nhds_one_split U_nhds with ⟨V, ⟨V_nhds, V_sum⟩⟩,
      existsi ((λp:G×G, p.2 / p.1) ⁻¹' V),
      have H : (λp:G×G, p.2 / p.1) ⁻¹' V ∈ comap (λp:G×G, p.2 / p.1) (𝓝 (1 : G)),
        by existsi [V, V_nhds] ; refl,
      existsi H,
      have comp_rel_sub :
        comp_rel ((λp:G×G, p.2 / p.1) ⁻¹' V) ((λp, p.2 / p.1) ⁻¹' V) ⊆ (λp:G×G, p.2 / p.1) ⁻¹' U,
      begin
        intros p p_comp_rel,
        rcases p_comp_rel with ⟨z, ⟨Hz1, Hz2⟩⟩,
        simpa [sub_eq_add_neg, add_comm, add_left_comm] using V_sum _ Hz1 _ Hz2
      end,
      exact set.subset.trans comp_rel_sub U_sub },
    { exact monotone_comp_rel monotone_id monotone_id }
  end,
  is_open_uniformity  :=
  begin
    intro S,
    let S' := λ x, {p : G × G | p.1 = x → p.2 ∈ S},
    show is_open S ↔ ∀ (x : G), x ∈ S → S' x ∈ comap (λp:G×G, p.2 / p.1) (𝓝 (1 : G)),
    rw [is_open_iff_mem_nhds],
    refine forall₂_congr (λ a ha, _),
    rw [← nhds_translation_div, mem_comap, mem_comap],
    refine exists₂_congr (λ t ht, _),
    show (λ (y : G), y / a) ⁻¹' t ⊆ S ↔ (λ (p : G × G), p.snd / p.fst) ⁻¹' t ⊆ S' a,
    split,
    { rintros h ⟨x, y⟩ hx rfl, exact h hx },
    { rintros h x hx, exact @h (a, x) hx rfl }
  end }

variables {G}

@[to_additive] lemma topological_group.tendsto_uniformly_iff
  {ι α : Type*} (F : ι → α → G) (f : α → G) (p : filter ι) :
  @tendsto_uniformly α G ι (topological_group.to_uniform_space G) F f p
    ↔ ∀ u ∈ 𝓝 (1 : G), ∀ᶠ i in p, ∀ a, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩,
  mem_of_superset (h u hu) (λ i hi a, hv (by exact hi a))⟩

@[to_additive] lemma topological_group.tendsto_uniformly_on_iff
  {ι α : Type*} (F : ι → α → G) (f : α → G) (p : filter ι) (s : set α) :
  @tendsto_uniformly_on α G ι (topological_group.to_uniform_space G) F f p s
    ↔ ∀ u ∈ 𝓝 (1 : G), ∀ᶠ i in p, ∀ a ∈ s, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩,
  mem_of_superset (h u hu) (λ i hi a ha, hv (by exact hi a ha))⟩

@[to_additive] lemma topological_group.tendsto_locally_uniformly_iff
  {ι α : Type*} [topological_space α] (F : ι → α → G) (f : α → G) (p : filter ι) :
  @tendsto_locally_uniformly α G ι (topological_group.to_uniform_space G) _ F f p
    ↔ ∀ (u ∈ 𝓝 (1 : G)) (x : α), ∃ (t ∈ 𝓝 x), ∀ᶠ i in p, ∀ a ∈ t, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩ x, exists_imp_exists (by exact λ a,
  exists_imp_exists (λ ha hp, mem_of_superset hp (λ i hi a ha, hv (by exact hi a ha)))) (h u hu x)⟩

@[to_additive] lemma topological_group.tendsto_locally_uniformly_on_iff
  {ι α : Type*} [topological_space α] (F : ι → α → G) (f : α → G) (p : filter ι) (s : set α) :
  @tendsto_locally_uniformly_on α G ι (topological_group.to_uniform_space G) _ F f p s
    ↔ ∀ (u ∈ 𝓝 (1 : G)) (x ∈ s), ∃ (t ∈ 𝓝[s] x), ∀ᶠ i in p, ∀ a ∈ t, F i a / f a ∈ u :=
⟨λ h u hu, h _ ⟨u, hu, λ _, id⟩, λ h v ⟨u, hu, hv⟩ x, exists_imp_exists (by exact λ a,
  exists_imp_exists (λ ha hp, mem_of_superset hp (λ i hi a ha, hv (by exact hi a ha)))) ∘ h u hu x⟩

end topological_comm_group

section topological_comm_group
universes u v w x
open filter

variables (G : Type*) [comm_group G] [topological_space G] [topological_group G]

section
local attribute [instance] topological_group.to_uniform_space

@[to_additive] lemma uniformity_eq_comap_nhds_one' :
  𝓤 G = comap (λp:G×G, p.2 / p.1) (𝓝 (1 : G)) := rfl

variable {G}
@[to_additive] lemma topological_group_is_uniform : uniform_group G :=
have tendsto
    ((λp:(G×G), p.1 / p.2) ∘ (λp:(G×G)×(G×G), (p.1.2 / p.1.1, p.2.2 / p.2.1)))
    (comap (λp:(G×G)×(G×G), (p.1.2 / p.1.1, p.2.2 / p.2.1)) ((𝓝 1).prod (𝓝 1)))
    (𝓝 (1 / 1)) :=
  (tendsto_fst.div' tendsto_snd).comp tendsto_comap,
begin
  constructor,
  rw [uniform_continuous, uniformity_prod_eq_prod, tendsto_map'_iff,
    uniformity_eq_comap_nhds_one' G, tendsto_comap_iff, prod_comap_comap_eq],
  simpa [(∘), div_eq_mul_inv, mul_comm, mul_left_comm] using this
end

local attribute [instance] topological_group_is_uniform

open set

@[to_additive] lemma topological_group.separated_iff_one_closed :
  separated_space G ↔ is_closed ({1} : set G) :=
begin
  rw [separated_space_iff, ← closure_eq_iff_is_closed],
  split; intro h,
  { apply subset.antisymm,
    { intros x x_in,
      have := group_separation_rel x 1,
      rw div_one' at this,
      rw [← this, h] at x_in,
      change x = 1 at x_in,
      simp [x_in] },
    { exact subset_closure } },
  { ext p,
    cases p with x y,
    rw [group_separation_rel x, h, mem_singleton_iff, div_eq_one],
    refl }
end

@[to_additive] lemma topological_group.separated_of_one_sep
  (H : ∀ x : G, x ≠ 1 → ∃ U ∈ nhds (1 : G), x ∉ U) : separated_space G:=
begin
  rw [topological_group.separated_iff_one_closed, ← is_open_compl_iff, is_open_iff_mem_nhds],
  intros x x_not,
  have : x ≠ 1, from mem_compl_singleton_iff.mp x_not,
  rcases H x this with ⟨U, U_in, xU⟩,
  rw ← nhds_one_symm G at U_in,
  rcases U_in with ⟨W, W_in, UW⟩,
  rw ← nhds_translation_mul_inv,
  use [W, W_in],
  rw subset_compl_comm,
  suffices : x⁻¹ ∉ W, by simpa,
  exact λ h, xU (UW h)
end

end

@[to_additive] lemma uniform_group.to_uniform_space_eq {G : Type*} [u : uniform_space G]
  [comm_group G] [uniform_group G] : topological_group.to_uniform_space G = u :=
begin
  ext : 1,
  show @uniformity G (topological_group.to_uniform_space G) = 𝓤 G,
  rw [uniformity_eq_comap_nhds_one' G, uniformity_eq_comap_nhds_one G]
end

end topological_comm_group

open comm_group filter set function

section
variables {α : Type*} {β : Type*}
variables [topological_space α] [comm_group α] [topological_group α]

-- β is a dense subgroup of α, inclusion is denoted by e
variables [topological_space β] [comm_group β]
variables {e : β →* α} (de : dense_inducing e)
include de

@[to_additive] lemma tendsto_div_comap_self (x₀ : α) :
  tendsto (λt:β×β, t.2 / t.1) (comap (λp:β×β, (e p.1, e p.2)) $ 𝓝 (x₀, x₀)) (𝓝 1) :=
begin
  have comm : (λx:α×α, x.2/x.1) ∘ (λt:β×β, (e t.1, e t.2)) = e ∘ (λt:β×β, t.2 / t.1),
  { ext t,
    change e t.2 / e t.1 = e (t.2 / t.1),
    rwa ← e.map_div t.2 t.1 },
  have lim : tendsto (λ x : α × α, x.2/x.1) (𝓝 (x₀, x₀)) (𝓝 (e 1)),
  { simpa using (continuous_div'.comp (@continuous_swap α α _ _)).tendsto (x₀, x₀) },
  simpa using de.tendsto_comap_nhds_nhds lim comm
end
end

namespace dense_inducing
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables {G : Type*}

-- β is a dense subgroup of α, inclusion is denoted by e
-- δ is a dense subgroup of γ, inclusion is denoted by f
variables [topological_space α] [add_comm_group α] [topological_add_group α]
variables [topological_space β] [add_comm_group β] [topological_add_group β]
variables [topological_space γ] [add_comm_group γ] [topological_add_group γ]
variables [topological_space δ] [add_comm_group δ] [topological_add_group δ]
variables [uniform_space G] [add_comm_group G] [uniform_add_group G] [separated_space G]
  [complete_space G]
variables {e : β →+ α} (de : dense_inducing e)
variables {f : δ →+ γ} (df : dense_inducing f)

variables {φ : β →+ δ →+ G}
local notation `Φ` := λ p : β × δ, φ p.1 p.2

variables  (hφ : continuous Φ)

include de df hφ

variables {W' : set G} (W'_nhd : W' ∈ 𝓝 (0 : G))
include W'_nhd

private lemma extend_Z_bilin_aux (x₀ : α) (y₁ : δ) :
  ∃ U₂ ∈ comap e (𝓝 x₀), ∀ x x' ∈ U₂, Φ (x' - x, y₁) ∈ W' :=
begin
  let Nx := 𝓝 x₀,
  let ee := λ u : β × β, (e u.1, e u.2),

  have lim1 : tendsto (λ a : β × β, (a.2 - a.1, y₁)) (comap e Nx ×ᶠ comap e Nx) (𝓝 (0, y₁)),
  { have := tendsto.prod_mk (tendsto_sub_comap_self de x₀)
      (tendsto_const_nhds : tendsto (λ (p : β × β), y₁) (comap ee $ 𝓝 (x₀, x₀)) (𝓝 y₁)),
    rw [nhds_prod_eq, prod_comap_comap_eq, ←nhds_prod_eq],
    exact (this : _) },
  have lim2 : tendsto Φ (𝓝 (0, y₁)) (𝓝 0), by simpa using hφ.tendsto (0, y₁),
  have lim := lim2.comp lim1,
  rw tendsto_prod_self_iff at lim,
  simp_rw ball_mem_comm,
  exact lim W' W'_nhd
end

private lemma extend_Z_bilin_key (x₀ : α) (y₀ : γ) :
  ∃ U ∈ comap e (𝓝 x₀), ∃ V ∈ comap f (𝓝 y₀),
    ∀ x x' ∈ U, ∀ y y' ∈ V, Φ (x', y') - Φ (x, y) ∈ W' :=
begin
  let Nx := 𝓝 x₀,
  let Ny := 𝓝 y₀,
  let dp := dense_inducing.prod de df,
  let ee := λ u : β × β, (e u.1, e u.2),
  let ff := λ u : δ × δ, (f u.1, f u.2),

  have lim_φ : filter.tendsto Φ (𝓝 (0, 0)) (𝓝 0),
  { simpa using hφ.tendsto (0, 0) },

  have lim_φ_sub_sub : tendsto (λ (p : (β × β) × (δ × δ)), Φ (p.1.2 - p.1.1, p.2.2 - p.2.1))
    ((comap ee $ 𝓝 (x₀, x₀)) ×ᶠ (comap ff $ 𝓝 (y₀, y₀))) (𝓝 0),
  { have lim_sub_sub :  tendsto (λ (p : (β × β) × δ × δ), (p.1.2 - p.1.1, p.2.2 - p.2.1))
      ((comap ee (𝓝 (x₀, x₀))) ×ᶠ (comap ff (𝓝 (y₀, y₀)))) (𝓝 0 ×ᶠ 𝓝 0),
    { have := filter.prod_mono (tendsto_sub_comap_self de x₀) (tendsto_sub_comap_self df y₀),
      rwa prod_map_map_eq at this },
    rw ← nhds_prod_eq at lim_sub_sub,
    exact tendsto.comp lim_φ lim_sub_sub },

  rcases exists_nhds_zero_quarter W'_nhd with ⟨W, W_nhd, W4⟩,

  have : ∃ U₁ ∈ comap e (𝓝 x₀), ∃ V₁ ∈ comap f (𝓝 y₀),
    ∀ x x' ∈ U₁, ∀ y y' ∈ V₁,  Φ (x'-x, y'-y) ∈ W,
  { have := tendsto_prod_iff.1 lim_φ_sub_sub W W_nhd,
    repeat { rw [nhds_prod_eq, ←prod_comap_comap_eq] at this },
    rcases this with ⟨U, U_in, V, V_in, H⟩,
    rw [mem_prod_same_iff] at U_in V_in,
    rcases U_in with ⟨U₁, U₁_in, HU₁⟩,
    rcases V_in with ⟨V₁, V₁_in, HV₁⟩,
    existsi [U₁, U₁_in, V₁, V₁_in],
    intros x x_in x' x'_in y y_in y' y'_in,
    exact H _ _ (HU₁ (mk_mem_prod x_in x'_in)) (HV₁ (mk_mem_prod y_in y'_in)) },
  rcases this with ⟨U₁, U₁_nhd, V₁, V₁_nhd, H⟩,

  obtain ⟨x₁, x₁_in⟩ : U₁.nonempty :=
    ((de.comap_nhds_ne_bot _).nonempty_of_mem U₁_nhd),
  obtain ⟨y₁, y₁_in⟩ : V₁.nonempty :=
    ((df.comap_nhds_ne_bot _).nonempty_of_mem V₁_nhd),

  have cont_flip : continuous (λ p : δ × β, φ.flip p.1 p.2),
  { show continuous (Φ ∘ prod.swap), from hφ.comp continuous_swap },
  rcases (extend_Z_bilin_aux de df hφ W_nhd x₀ y₁) with ⟨U₂, U₂_nhd, HU⟩,
  rcases (extend_Z_bilin_aux df de cont_flip W_nhd y₀ x₁) with ⟨V₂, V₂_nhd, HV⟩,

  existsi [U₁ ∩ U₂, inter_mem U₁_nhd U₂_nhd,
            V₁ ∩ V₂, inter_mem V₁_nhd V₂_nhd],

  rintros x ⟨xU₁, xU₂⟩ x' ⟨x'U₁, x'U₂⟩ y ⟨yV₁, yV₂⟩ y' ⟨y'V₁, y'V₂⟩,
  have key_formula : φ x' y' - φ x y =
    φ(x' - x) y₁ + φ (x' - x) (y' - y₁) + φ x₁ (y' - y) + φ (x - x₁) (y' - y),
  { simp, abel },
  rw key_formula,
  have h₁ := HU x xU₂ x' x'U₂,
  have h₂ := H x xU₁ x' x'U₁ y₁ y₁_in y' y'V₁,
  have h₃ := HV y yV₂ y' y'V₂,
  have h₄ := H x₁ x₁_in x xU₁ y yV₁ y' y'V₁,
  exact W4 h₁ h₂ h₃ h₄
end

omit W'_nhd

open dense_inducing

/-- Bourbaki GT III.6.5 Theorem I:
ℤ-bilinear continuous maps from dense images into a complete Hausdorff group extend by continuity.
Note: Bourbaki assumes that α and β are also complete Hausdorff, but this is not necessary. -/
theorem extend_Z_bilin  : continuous (extend (de.prod df) Φ) :=
begin
  refine continuous_extend_of_cauchy _ _,
  rintro ⟨x₀, y₀⟩,
  split,
  { apply ne_bot.map,
    apply comap_ne_bot,

    intros U h,
    rcases mem_closure_iff_nhds.1 ((de.prod df).dense (x₀, y₀)) U h with ⟨x, x_in, ⟨z, z_x⟩⟩,
    existsi z,
    cc },
  { suffices : map (λ (p : (β × δ) × (β × δ)), Φ p.2 - Φ p.1)
      (comap (λ (p : (β × δ) × β × δ), ((e p.1.1, f p.1.2), (e p.2.1, f p.2.2)))
         (𝓝 (x₀, y₀) ×ᶠ 𝓝 (x₀, y₀))) ≤ 𝓝 0,
    by rwa [uniformity_eq_comap_nhds_zero G, prod_map_map_eq, ←map_le_iff_le_comap, filter.map_map,
        prod_comap_comap_eq],

    intros W' W'_nhd,

    have key := extend_Z_bilin_key de df hφ W'_nhd x₀ y₀,
    rcases key with ⟨U, U_nhd, V, V_nhd, h⟩,
    rw mem_comap at U_nhd,
    rcases U_nhd with ⟨U', U'_nhd, U'_sub⟩,
    rw mem_comap at V_nhd,
    rcases V_nhd with ⟨V', V'_nhd, V'_sub⟩,

    rw [mem_map, mem_comap, nhds_prod_eq],
    existsi (U' ×ˢ V') ×ˢ (U' ×ˢ V'),
    rw mem_prod_same_iff,

    simp only [exists_prop],
    split,
    { change U' ∈ 𝓝 x₀ at U'_nhd,
      change V' ∈ 𝓝 y₀ at V'_nhd,
      have := prod_mem_prod U'_nhd V'_nhd,
      tauto },
    { intros p h',
      simp only [set.mem_preimage, set.prod_mk_mem_set_prod_eq] at h',
      rcases p with ⟨⟨x, y⟩, ⟨x', y'⟩⟩,
      apply h ; tauto } }
end
end dense_inducing


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import measure_theory.group.measurable_equiv
import measure_theory.measure.regular
import dynamics.ergodic.measure_preserving
import dynamics.minimal

/-!
# Measures invariant under group actions

A measure `μ : measure α` is said to be *invariant* under an action of a group `G` if scalar
multiplication by `c : G` is a measure preserving map for all `c`. In this file we define a
typeclass for measures invariant under action of an (additive or multiplicative) group and prove
some basic properties of such measures.
-/

open_locale ennreal nnreal pointwise topology
open measure_theory measure_theory.measure set function

namespace measure_theory

variables {G M α : Type*} {s : set α}

/-- A measure `μ : measure α` is invariant under an additive action of `M` on `α` if for any
measurable set `s : set α` and `c : M`, the measure of its preimage under `λ x, c +ᵥ x` is equal to
the measure of `s`. -/
class vadd_invariant_measure (M α : Type*) [has_vadd M α] {_ : measurable_space α}
  (μ : measure α) : Prop :=
(measure_preimage_vadd [] : ∀ (c : M) ⦃s : set α⦄, measurable_set s → μ ((λ x, c +ᵥ x) ⁻¹' s) = μ s)

/-- A measure `μ : measure α` is invariant under a multiplicative action of `M` on `α` if for any
measurable set `s : set α` and `c : M`, the measure of its preimage under `λ x, c • x` is equal to
the measure of `s`. -/
@[to_additive] class smul_invariant_measure (M α : Type*) [has_smul M α] {_ : measurable_space α}
  (μ : measure α) : Prop :=
(measure_preimage_smul [] : ∀ (c : M) ⦃s : set α⦄, measurable_set s → μ ((λ x, c • x) ⁻¹' s) = μ s)

namespace smul_invariant_measure

@[to_additive] instance zero [measurable_space α] [has_smul M α] : smul_invariant_measure M α 0 :=
⟨λ _ _ _, rfl⟩

variables [has_smul M α] {m : measurable_space α} {μ ν : measure α}

@[to_additive] instance add [smul_invariant_measure M α μ] [smul_invariant_measure M α ν] :
  smul_invariant_measure M α (μ + ν) :=
⟨λ c s hs, show _ + _ = _ + _,
  from congr_arg2 (+) (measure_preimage_smul μ c hs) (measure_preimage_smul ν c hs)⟩

@[to_additive] instance smul [smul_invariant_measure M α μ] (c : ℝ≥0∞) :
  smul_invariant_measure M α (c • μ) :=
⟨λ a s hs, show c • _ = c • _, from congr_arg ((•) c) (measure_preimage_smul μ a hs)⟩

@[to_additive] instance smul_nnreal [smul_invariant_measure M α μ] (c : ℝ≥0) :
  smul_invariant_measure M α (c • μ) :=
smul_invariant_measure.smul c

end smul_invariant_measure

section has_measurable_smul

variables {m : measurable_space α} [measurable_space M] [has_smul M α] [has_measurable_smul M α]
  (c : M) (μ : measure α) [smul_invariant_measure M α μ]

@[simp, to_additive] lemma measure_preserving_smul : measure_preserving ((•) c) μ μ :=
{ measurable := measurable_const_smul c,
  map_eq :=
  begin
    ext1 s hs,
    rw map_apply (measurable_const_smul c) hs,
    exact smul_invariant_measure.measure_preimage_smul μ c hs,
  end }

@[simp, to_additive] lemma map_smul : map ((•) c) μ = μ :=
(measure_preserving_smul c μ).map_eq

end has_measurable_smul

variables (G) {m : measurable_space α} [group G] [mul_action G α] [measurable_space G]
  [has_measurable_smul G α] (c : G) (μ : measure α)

/-- Equivalent definitions of a measure invariant under a multiplicative action of a group.

- 0: `smul_invariant_measure G α μ`;

- 1: for every `c : G` and a measurable set `s`, the measure of the preimage of `s` under scalar
     multiplication by `c` is equal to the measure of `s`;

- 2: for every `c : G` and a measurable set `s`, the measure of the image `c • s` of `s` under
     scalar multiplication by `c` is equal to the measure of `s`;

- 3, 4: properties 2, 3 for any set, including non-measurable ones;

- 5: for any `c : G`, scalar multiplication by `c` maps `μ` to `μ`;

- 6: for any `c : G`, scalar multiplication by `c` is a measure preserving map. -/
@[to_additive] lemma smul_invariant_measure_tfae :
  tfae [smul_invariant_measure G α μ,
    ∀ (c : G) s, measurable_set s → μ (((•) c) ⁻¹' s) = μ s,
    ∀ (c : G) s, measurable_set s → μ (c • s) = μ s,
    ∀ (c : G) s, μ (((•) c) ⁻¹' s) = μ s,
    ∀ (c : G) s, μ (c • s) = μ s,
    ∀ c : G, measure.map ((•) c) μ = μ,
    ∀ c : G, measure_preserving ((•) c) μ μ] :=
begin
  tfae_have : 1 ↔ 2, from ⟨λ h, h.1, λ h, ⟨h⟩⟩,
  tfae_have : 1 → 6, { introsI h c, exact (measure_preserving_smul c μ).map_eq, },
  tfae_have : 6 → 7, from λ H c, ⟨measurable_const_smul c, H c⟩,
  tfae_have : 7 → 4, from λ H c, (H c).measure_preimage_emb (measurable_embedding_const_smul c),
  tfae_have : 4 → 5, from λ H c s, by { rw [← preimage_smul_inv], apply H },
  tfae_have : 5 → 3, from λ H c s hs, H c s,
  tfae_have : 3 → 2, { intros H c s hs, rw preimage_smul, exact H c⁻¹ s hs },
  tfae_finish
end

/-- Equivalent definitions of a measure invariant under an additive action of a group.

- 0: `vadd_invariant_measure G α μ`;

- 1: for every `c : G` and a measurable set `s`, the measure of the preimage of `s` under
     vector addition `(+ᵥ) c` is equal to the measure of `s`;

- 2: for every `c : G` and a measurable set `s`, the measure of the image `c +ᵥ s` of `s` under
     vector addition `(+ᵥ) c` is equal to the measure of `s`;

- 3, 4: properties 2, 3 for any set, including non-measurable ones;

- 5: for any `c : G`, vector addition of `c` maps `μ` to `μ`;

- 6: for any `c : G`, vector addition of `c` is a measure preserving map. -/
add_decl_doc vadd_invariant_measure_tfae

variables {G} [smul_invariant_measure G α μ]

@[simp, to_additive] lemma measure_preimage_smul (s : set α) : μ ((•) c ⁻¹' s) = μ s :=
((smul_invariant_measure_tfae G μ).out 0 3).mp ‹_› c s

@[simp, to_additive] lemma measure_smul (s : set α) : μ (c • s) = μ s :=
((smul_invariant_measure_tfae G μ).out 0 4).mp ‹_› c s

variable {μ}

@[to_additive] lemma null_measurable_set.smul {s} (hs : null_measurable_set s μ) (c : G) :
  null_measurable_set (c • s) μ :=
by simpa only [← preimage_smul_inv]
  using hs.preimage (measure_preserving_smul _ _).quasi_measure_preserving

lemma measure_smul_null {s} (h : μ s = 0) (c : G) : μ (c • s) = 0 := by rwa measure_smul

section is_minimal

variables (G) [topological_space α] [has_continuous_const_smul G α] [mul_action.is_minimal G α]
  {K U : set α}

/-- If measure `μ` is invariant under a group action and is nonzero on a compact set `K`, then it is
positive on any nonempty open set. In case of a regular measure, one can assume `μ ≠ 0` instead of
`μ K ≠ 0`, see `measure_theory.measure_is_open_pos_of_smul_invariant_of_ne_zero`. -/
@[to_additive] lemma measure_is_open_pos_of_smul_invariant_of_compact_ne_zero (hK : is_compact K)
  (hμK : μ K ≠ 0) (hU : is_open U) (hne : U.nonempty) : 0 < μ U :=
let ⟨t, ht⟩ := hK.exists_finite_cover_smul G hU hne
in pos_iff_ne_zero.2 $ λ hμU, hμK $ measure_mono_null ht $
  (measure_bUnion_null_iff t.countable_to_set).2 $ λ _ _, by rwa measure_smul

/-- If measure `μ` is invariant under an additive group action and is nonzero on a compact set `K`,
then it is positive on any nonempty open set. In case of a regular measure, one can assume `μ ≠ 0`
instead of `μ K ≠ 0`, see `measure_theory.measure_is_open_pos_of_vadd_invariant_of_ne_zero`. -/
add_decl_doc measure_is_open_pos_of_vadd_invariant_of_compact_ne_zero

@[to_additive] lemma is_locally_finite_measure_of_smul_invariant (hU : is_open U) (hne : U.nonempty)
  (hμU : μ U ≠ ∞) : is_locally_finite_measure μ :=
⟨λ x, let ⟨g, hg⟩ := hU.exists_smul_mem G x hne in
  ⟨(•) g ⁻¹' U, (hU.preimage (continuous_id.const_smul _)).mem_nhds hg, ne.lt_top $
    by rwa [measure_preimage_smul]⟩⟩

variables [measure.regular μ]

@[to_additive] lemma measure_is_open_pos_of_smul_invariant_of_ne_zero (hμ : μ ≠ 0) (hU : is_open U)
  (hne : U.nonempty) : 0 < μ U :=
let ⟨K, hK, hμK⟩ := regular.exists_compact_not_null.mpr hμ
in measure_is_open_pos_of_smul_invariant_of_compact_ne_zero G hK hμK hU hne

@[to_additive] lemma measure_pos_iff_nonempty_of_smul_invariant (hμ : μ ≠ 0) (hU : is_open U) :
  0 < μ U ↔ U.nonempty :=
⟨λ h, nonempty_of_measure_ne_zero h.ne', measure_is_open_pos_of_smul_invariant_of_ne_zero G hμ hU⟩

include G

@[to_additive] lemma measure_eq_zero_iff_eq_empty_of_smul_invariant (hμ : μ ≠ 0) (hU : is_open U) :
  μ U = 0 ↔ U = ∅ :=
by rw [← not_iff_not, ← ne.def, ← pos_iff_ne_zero,
  measure_pos_iff_nonempty_of_smul_invariant G hμ hU, nonempty_iff_ne_empty]

end is_minimal

lemma smul_ae_eq_self_of_mem_zpowers
  {x y : G} (hs : (x • s : set α) =ᵐ[μ] s) (hy : y ∈ subgroup.zpowers x) :
  (y • s : set α) =ᵐ[μ] s :=
begin
  obtain ⟨k, rfl⟩ := subgroup.mem_zpowers_iff.mp hy,
  let e : α ≃ α := mul_action.to_perm_hom G α x,
  have he : quasi_measure_preserving e μ μ :=
    (measure_preserving_smul x μ).quasi_measure_preserving,
  have he' : quasi_measure_preserving e.symm μ μ :=
    (measure_preserving_smul x⁻¹ μ).quasi_measure_preserving,
  simpa only [mul_action.to_perm_hom_apply, mul_action.to_perm_apply, image_smul,
    ← monoid_hom.map_zpow] using he.image_zpow_ae_eq he' k hs,
end

lemma vadd_ae_eq_self_of_mem_zmultiples {G : Type*} [measurable_space G]
  [add_group G] [add_action G α] [vadd_invariant_measure G α μ] [has_measurable_vadd G α]
  {x y : G} (hs : (x +ᵥ s : set α) =ᵐ[μ] s) (hy : y ∈ add_subgroup.zmultiples x) :
  (y +ᵥ s : set α) =ᵐ[μ] s :=
begin
  letI : measurable_space (multiplicative G) := (by apply_instance : measurable_space G),
  letI : smul_invariant_measure (multiplicative G) α μ :=
    ⟨λ g, vadd_invariant_measure.measure_preimage_vadd μ (multiplicative.to_add g)⟩,
  letI : has_measurable_smul (multiplicative G) α :=
  { measurable_const_smul := λ g, measurable_const_vadd (multiplicative.to_add g),
    measurable_smul_const := λ a, @measurable_vadd_const (multiplicative G) α
      (by apply_instance : has_vadd G α) _ _ (by apply_instance : has_measurable_vadd G α) a },
  exact @smul_ae_eq_self_of_mem_zpowers (multiplicative G) α _ _ _ _ _ _ _ _ _ _ hs hy,
end

attribute [to_additive vadd_ae_eq_self_of_mem_zmultiples] smul_ae_eq_self_of_mem_zpowers

end measure_theory


-- just an old factorial function

def fac : ℕ → ℕ
| 0 := 1
| (nat.succ n') :=
    (nat.succ n') * (fac n')

/-
Let's look at proofs of (fac k = 0) in two
different styles. In one style we'll use
metavariables and axioms. In the other, it's
ordinary variables and constructive proofs.
-/

-- with metavariables and axioms

variable k : ℕ
#check k
#reduce k    -- can't reduce a metavariable
axiom k0 : k = 0  -- omg, it's a real function
#check k0     -- wait, that's kind of weird
#check k0 k   -- we can create proofs of k = 0
variable l : ℕ -- for any k, let's try it on l
#check k0 l   -- here we have a proof of l = 0
#reduce k0 k  -- but again can't reduce metavar

-- that said, we can use the axiom in proofs
example : fac k = 1 :=
begin
    have keq0 := k0 k,
    rw keq0,
    trivial,
end

-- QED

/-
Now with ordinary variables: it's just rfl.
In a way, rfl causes (fac k) to compute, to
reduce, after which it's just reflexive eq.
-/

/-
Here's a zero-valued (non-meta) variable. It
thus has a definite value, which, in this case
is zero. There's a constructive proof, namely
0, of the type of k', i.e., ℕ.
-/

def k' := 0

/-
Now the proof is literally trivial. In this
case, the trivial tactic tries applying rfl
and that is all it takes.
-/

example : fac k' = 1 :=
begin
    trivial,
end


/-
Copyright (c) 2021 Apurva Nakade. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Apurva Nakade
-/
import algebra.algebra.basic
import ring_theory.localization
import set_theory.surreal.basic

/-!
# Dyadic numbers
Dyadic numbers are obtained by localizing ℤ away from 2. They are the initial object in the category
of rings with no 2-torsion.

## Dyadic surreal numbers
We construct dyadic surreal numbers using the canonical map from ℤ[2 ^ {-1}] to surreals.
As we currently do not have a ring structure on `surreal` we construct this map explicitly. Once we
have the ring structure, this map can be constructed directly by sending `2 ^ {-1}` to `half`.

## Embeddings
The above construction gives us an abelian group embedding of ℤ into `surreal`. The goal is to
extend this to an embedding of dyadic rationals into `surreal` and use Cauchy sequences of dyadic
rational numbers to construct an ordered field embedding of ℝ into `surreal`.
-/

universes u

local infix ` ≈ ` := pgame.equiv

namespace pgame

/-- For a natural number `n`, the pre-game `pow_half (n + 1)` is recursively defined as
`{ 0 | pow_half n }`. These are the explicit expressions of powers of `half`. By definition, we have
 `pow_half 0 = 0` and `pow_half 1 = half` and we prove later on that
`pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n`.-/
def pow_half : ℕ → pgame
| 0       := mk punit pempty 0 pempty.elim
| (n + 1) := mk punit punit 0 (λ _, pow_half n)

@[simp] lemma pow_half_left_moves {n} : (pow_half n).left_moves = punit :=
by cases n; refl

@[simp] lemma pow_half_right_moves {n} : (pow_half (n + 1)).right_moves = punit :=
by cases n; refl

@[simp] lemma pow_half_move_left {n i} : (pow_half n).move_left i = 0 :=
by cases n; cases i; refl

@[simp] lemma pow_half_move_right {n i} : (pow_half (n + 1)).move_right i = pow_half n :=
by cases n; cases i; refl

lemma pow_half_move_left' (n) :
  (pow_half n).move_left (equiv.cast (pow_half_left_moves.symm) punit.star) = 0 :=
by simp only [eq_self_iff_true, pow_half_move_left]

lemma pow_half_move_right' (n) :
  (pow_half (n + 1)).move_right (equiv.cast (pow_half_right_moves.symm) punit.star) = pow_half n :=
by simp only [pow_half_move_right, eq_self_iff_true]

/-- For all natural numbers `n`, the pre-games `pow_half n` are numeric. -/
theorem numeric_pow_half {n} : (pow_half n).numeric :=
begin
  induction n with n hn,
  { exact numeric_one },
  { split,
    { rintro ⟨ ⟩ ⟨ ⟩,
      dsimp only [pi.zero_apply],
      rw ← pow_half_move_left' n,
      apply hn.move_left_lt },
    { exact ⟨λ _, numeric_zero, λ _, hn⟩ } }
end

theorem pow_half_succ_lt_pow_half {n : ℕ} : pow_half (n + 1) < pow_half n :=
(@numeric_pow_half (n + 1)).lt_move_right punit.star

theorem pow_half_succ_le_pow_half {n : ℕ} : pow_half (n + 1) ≤ pow_half n :=
le_of_lt numeric_pow_half numeric_pow_half pow_half_succ_lt_pow_half

theorem zero_lt_pow_half {n : ℕ} : 0 < pow_half n :=
by cases n; rw lt_def_le; use ⟨punit.star, pgame.le_refl 0⟩

theorem zero_le_pow_half {n : ℕ} : 0 ≤ pow_half n :=
le_of_lt numeric_zero numeric_pow_half zero_lt_pow_half

theorem add_pow_half_succ_self_eq_pow_half {n} : pow_half (n + 1) + pow_half (n + 1) ≈ pow_half n :=
begin
  induction n with n hn,
  { exact half_add_half_equiv_one },
  { split; rw le_def_lt; split,
    { rintro (⟨⟨ ⟩⟩ | ⟨⟨ ⟩⟩),
      { calc 0 + pow_half (n.succ + 1) ≈ pow_half (n.succ + 1) : zero_add_equiv _
                                   ... < pow_half n.succ       : pow_half_succ_lt_pow_half },
      { calc pow_half (n.succ + 1) + 0 ≈ pow_half (n.succ + 1) : add_zero_equiv _
                                   ... < pow_half n.succ       : pow_half_succ_lt_pow_half } },
    { rintro ⟨ ⟩,
      rw lt_def_le,
      right,
      use sum.inl punit.star,
      calc pow_half (n.succ) + pow_half (n.succ + 1)
          ≤ pow_half (n.succ) + pow_half (n.succ) : add_le_add_left pow_half_succ_le_pow_half
      ... ≈ pow_half n                            : hn },
    { rintro ⟨ ⟩,
      calc 0 ≈ 0 + 0                                        : (add_zero_equiv _).symm
        ... ≤ pow_half (n.succ + 1) + 0                     : add_le_add_right zero_le_pow_half
        ... < pow_half (n.succ + 1) + pow_half (n.succ + 1) : add_lt_add_left zero_lt_pow_half },
    { rintro (⟨⟨ ⟩⟩ | ⟨⟨ ⟩⟩),
      { calc pow_half n.succ
            ≈ pow_half n.succ + 0                           : (add_zero_equiv _).symm
        ... < pow_half (n.succ) + pow_half (n.succ + 1)     : add_lt_add_left zero_lt_pow_half },
      { calc pow_half n.succ
            ≈ 0 + pow_half n.succ                           : (zero_add_equiv _).symm
        ... < pow_half (n.succ + 1) + pow_half (n.succ)     : add_lt_add_right zero_lt_pow_half }}}
end

end pgame

namespace surreal
open pgame

/-- The surreal number `half`. -/
def half : surreal := ⟦⟨pgame.half, pgame.numeric_half⟩⟧

/-- Powers of the surreal number `half`. -/
def pow_half (n : ℕ) : surreal := ⟦⟨pgame.pow_half n, pgame.numeric_pow_half⟩⟧

@[simp] lemma pow_half_zero : pow_half 0 = 1 := rfl

@[simp] lemma pow_half_one : pow_half 1 = half := rfl

@[simp] theorem add_half_self_eq_one : half + half = 1 :=
quotient.sound pgame.half_add_half_equiv_one

lemma double_pow_half_succ_eq_pow_half (n : ℕ) : 2 • pow_half n.succ = pow_half n :=
begin
  rw two_nsmul,
  apply quotient.sound,
  exact pgame.add_pow_half_succ_self_eq_pow_half,
end

lemma nsmul_pow_two_pow_half (n : ℕ) : 2 ^ n • pow_half n = 1 :=
begin
  induction n with n hn,
  { simp only [nsmul_one, pow_half_zero, nat.cast_one, pow_zero] },
  { rw [← hn, ← double_pow_half_succ_eq_pow_half n, smul_smul (2^n) 2 (pow_half n.succ),
        mul_comm, pow_succ] }
end

lemma nsmul_pow_two_pow_half' (n k : ℕ) : 2 ^ n • pow_half (n + k) = pow_half k :=
begin
  induction k with k hk,
  { simp only [add_zero, surreal.nsmul_pow_two_pow_half, nat.nat_zero_eq_zero, eq_self_iff_true,
               surreal.pow_half_zero] },
  { rw [← double_pow_half_succ_eq_pow_half (n + k), ← double_pow_half_succ_eq_pow_half k,
        smul_algebra_smul_comm] at hk,
    rwa ← (zsmul_eq_zsmul_iff' two_ne_zero) }
end

lemma zsmul_pow_two_pow_half (m : ℤ) (n k : ℕ) :
  (m * 2 ^ n) • pow_half (n + k) = m • pow_half k :=
begin
  rw mul_zsmul,
  congr,
  norm_cast,
  exact nsmul_pow_two_pow_half' n k,
end

lemma dyadic_aux {m₁ m₂ : ℤ} {y₁ y₂ : ℕ} (h₂ : m₁ * (2 ^ y₁) = m₂ * (2 ^ y₂)) :
  m₁ • pow_half y₂ = m₂ • pow_half y₁ :=
begin
  revert m₁ m₂,
  wlog h : y₁ ≤ y₂,
  intros m₁ m₂ h₂,
  obtain ⟨c, rfl⟩ := le_iff_exists_add.mp h,
  rw [add_comm, pow_add, ← mul_assoc, mul_eq_mul_right_iff] at h₂,
  cases h₂,
  { rw [h₂, add_comm, zsmul_pow_two_pow_half m₂ c y₁] },
  { have := nat.one_le_pow y₁ 2 nat.succ_pos',
    linarith },
end

/-- The additive monoid morphism `dyadic_map` sends ⟦⟨m, 2^n⟩⟧ to m • half ^ n. -/
def dyadic_map : localization.away (2 : ℤ) →+ surreal :=
{ to_fun :=
  λ x, localization.lift_on x (λ x y, x • pow_half (submonoid.log y)) $
  begin
    intros m₁ m₂ n₁ n₂ h₁,
    obtain ⟨⟨n₃, y₃, hn₃⟩, h₂⟩ := localization.r_iff_exists.mp h₁,
    simp only [subtype.coe_mk, mul_eq_mul_right_iff] at h₂,
    cases h₂,
    { simp only,
      obtain ⟨a₁, ha₁⟩ := n₁.prop,
      obtain ⟨a₂, ha₂⟩ := n₂.prop,
      have hn₁ : n₁ = submonoid.pow 2 a₁ := subtype.ext ha₁.symm,
      have hn₂ : n₂ = submonoid.pow 2 a₂ := subtype.ext ha₂.symm,
      have h₂ : 1 < (2 : ℤ).nat_abs, from one_lt_two,
      rw [hn₁, hn₂, submonoid.log_pow_int_eq_self h₂, submonoid.log_pow_int_eq_self h₂],
      apply dyadic_aux,
      rwa [ha₁, ha₂] },
    { have := nat.one_le_pow y₃ 2 nat.succ_pos',
      linarith }
    end,
  map_zero' := localization.lift_on_zero _ _,
  map_add' := λ x y, localization.induction_on₂ x y $
  begin
    rintro ⟨a, ⟨b, ⟨b', rfl⟩⟩⟩ ⟨c, ⟨d, ⟨d', rfl⟩⟩⟩,
    have h₂ : 1 < (2 : ℤ).nat_abs, from one_lt_two,
    have hpow₂ := submonoid.log_pow_int_eq_self h₂,
    simp_rw submonoid.pow_apply at hpow₂,
    simp_rw [localization.add_mk, localization.lift_on_mk, subtype.coe_mk,
      submonoid.log_mul (int.pow_right_injective h₂), hpow₂],
    calc (2 ^ b' * c + 2 ^ d' * a) • pow_half (b' + d')
        = (c * 2 ^ b') • pow_half (b' + d') + (a * 2 ^ d') • pow_half (d' + b')
        : by simp only [add_smul, mul_comm,add_comm]
    ... = c • pow_half d' + a • pow_half b' : by simp only [zsmul_pow_two_pow_half]
    ... = a • pow_half b' + c • pow_half d' : add_comm _ _,
  end }

@[simp] lemma dyadic_map_apply (m : ℤ) (p : submonoid.powers (2 : ℤ)) :
  dyadic_map (is_localization.mk' (localization (submonoid.powers 2)) m p) =
  m • pow_half (submonoid.log p) :=
begin
  rw ← localization.mk_eq_mk',
  refl,
end

@[simp] lemma dyadic_map_apply_pow (m : ℤ) (n : ℕ) :
  dyadic_map (is_localization.mk' (localization (submonoid.powers 2)) m (submonoid.pow 2 n)) =
  m • pow_half n :=
by rw [dyadic_map_apply, @submonoid.log_pow_int_eq_self 2 one_lt_two]

/-- We define dyadic surreals as the range of the map `dyadic_map`. -/
def dyadic : set surreal := set.range dyadic_map

-- We conclude with some ideas for further work on surreals; these would make fun projects.

-- TODO show that the map from dyadic rationals to surreals is injective

-- TODO map the reals into the surreals, using dyadic Dedekind cuts
-- TODO show this is a group homomorphism, and injective

-- TODO show the maps from the dyadic rationals and from the reals
-- into the surreals are multiplicative

end surreal


/-
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.normal
import field_theory.primitive_element
import field_theory.fixed
import ring_theory.power_basis

/-!
# Galois Extensions

In this file we define Galois extensions as extensions which are both separable and normal.

## Main definitions

- `is_galois F E` where `E` is an extension of `F`
- `fixed_field H` where `H : subgroup (E ≃ₐ[F] E)`
- `fixing_subgroup K` where `K : intermediate_field F E`
- `galois_correspondence` where `E/F` is finite dimensional and Galois

## Main results

- `fixing_subgroup_of_fixed_field` : If `E/F` is finite dimensional (but not necessarily Galois)
  then `fixing_subgroup (fixed_field H) = H`
- `fixed_field_of_fixing_subgroup`: If `E/F` is finite dimensional and Galois
  then `fixed_field (fixing_subgroup K) = K`
Together, these two result prove the Galois correspondence

- `is_galois.tfae` : Equivalent characterizations of a Galois extension of finite degree
-/

noncomputable theory
open_locale classical

open finite_dimensional alg_equiv

section

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

/-- A field extension E/F is galois if it is both separable and normal. Note that in mathlib
a separable extension of fields is by definition algebraic. -/
class is_galois : Prop :=
[to_is_separable : is_separable F E]
[to_normal : normal F E]

variables {F E}

theorem is_galois_iff : is_galois F E ↔ is_separable F E ∧ normal F E :=
⟨λ h, ⟨h.1, h.2⟩, λ h, { to_is_separable := h.1, to_normal := h.2 }⟩

attribute [instance, priority 100] -- see Note [lower instance priority]
is_galois.to_is_separable is_galois.to_normal

variables (F E)

namespace is_galois

instance self : is_galois F F :=
⟨⟩

variables (F) {E}

lemma integral [is_galois F E] (x : E) : is_integral F x := normal.is_integral' x

lemma separable [is_galois F E] (x : E) : (minpoly F x).separable := is_separable.separable F x

lemma splits [is_galois F E] (x : E) : (minpoly F x).splits (algebra_map F E) := normal.splits' x

variables (F E)

instance of_fixed_field (G : Type*) [group G] [fintype G] [mul_semiring_action G E] :
  is_galois (fixed_points.subfield G E) E :=
⟨⟩

lemma intermediate_field.adjoin_simple.card_aut_eq_finrank
  [finite_dimensional F E] {α : E} (hα : is_integral F α)
  (h_sep : (minpoly F α).separable)
  (h_splits : (minpoly F α).splits (algebra_map F F⟮α⟯)) :
  fintype.card (F⟮α⟯ ≃ₐ[F] F⟮α⟯) = finrank F F⟮α⟯ :=
begin
  letI : fintype (F⟮α⟯ →ₐ[F] F⟮α⟯) := intermediate_field.fintype_of_alg_hom_adjoin_integral F hα,
  rw intermediate_field.adjoin.finrank hα,
  rw ← intermediate_field.card_alg_hom_adjoin_integral F hα h_sep h_splits,
  exact fintype.card_congr (alg_equiv_equiv_alg_hom F F⟮α⟯)
end

lemma card_aut_eq_finrank [finite_dimensional F E] [is_galois F E] :
  fintype.card (E ≃ₐ[F] E) = finrank F E :=
begin
  cases field.exists_primitive_element F E with α hα,
  let iso : F⟮α⟯ ≃ₐ[F] E :=
  { to_fun := λ e, e.val,
    inv_fun := λ e, ⟨e, by { rw hα, exact intermediate_field.mem_top }⟩,
    left_inv := λ _, by { ext, refl },
    right_inv := λ _, rfl,
    map_mul' := λ _ _, rfl,
    map_add' := λ _ _, rfl,
    commutes' := λ _, rfl },
  have H : is_integral F α := is_galois.integral F α,
  have h_sep : (minpoly F α).separable := is_galois.separable F α,
  have h_splits : (minpoly F α).splits (algebra_map F E) := is_galois.splits F α,
  replace h_splits : polynomial.splits (algebra_map F F⟮α⟯) (minpoly F α),
  { have p : iso.symm.to_alg_hom.to_ring_hom.comp (algebra_map F E) = (algebra_map F ↥F⟮α⟯),
    { ext, simp, },
    simpa [p] using polynomial.splits_comp_of_splits
      (algebra_map F E) iso.symm.to_alg_hom.to_ring_hom h_splits, },
  rw ← linear_equiv.finrank_eq iso.to_linear_equiv,
  rw ← intermediate_field.adjoin_simple.card_aut_eq_finrank F E H h_sep h_splits,
  apply fintype.card_congr,
  apply equiv.mk (λ ϕ, iso.trans (trans ϕ iso.symm)) (λ ϕ, iso.symm.trans (trans ϕ iso)),
  { intro ϕ, ext1, simp only [trans_apply, apply_symm_apply] },
  { intro ϕ, ext1, simp only [trans_apply, symm_apply_apply] },
end

end is_galois

end

section is_galois_tower

variables (F K E : Type*) [field F] [field K] [field E] {E' : Type*} [field E'] [algebra F E']
variables [algebra F K] [algebra F E] [algebra K E] [is_scalar_tower F K E]

lemma is_galois.tower_top_of_is_galois [is_galois F E] : is_galois K E :=
{ to_is_separable := is_separable_tower_top_of_is_separable F K E,
  to_normal := normal.tower_top_of_normal F K E }

variables {F E}

@[priority 100] -- see Note [lower instance priority]
instance is_galois.tower_top_intermediate_field (K : intermediate_field F E) [h : is_galois F E] :
  is_galois K E := is_galois.tower_top_of_is_galois F K E

lemma is_galois_iff_is_galois_bot : is_galois (⊥ : intermediate_field F E) E ↔ is_galois F E :=
begin
  split,
  { introI h,
    exact is_galois.tower_top_of_is_galois (⊥ : intermediate_field F E) F E },
  { introI h, apply_instance },
end

lemma is_galois.of_alg_equiv [h : is_galois F E] (f : E ≃ₐ[F] E') : is_galois F E' :=
{ to_is_separable := is_separable.of_alg_hom F E f.symm, to_normal := normal.of_alg_equiv f }

lemma alg_equiv.transfer_galois (f : E ≃ₐ[F] E') : is_galois F E ↔ is_galois F E' :=
⟨λ h, by exactI is_galois.of_alg_equiv f, λ h, by exactI is_galois.of_alg_equiv f.symm⟩

lemma is_galois_iff_is_galois_top : is_galois F (⊤ : intermediate_field F E) ↔ is_galois F E :=
(intermediate_field.top_equiv).transfer_galois

instance is_galois_bot : is_galois F (⊥ : intermediate_field F E) :=
(intermediate_field.bot_equiv F E).transfer_galois.mpr (is_galois.self F)

end is_galois_tower

section galois_correspondence

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E]
variables (H : subgroup (E ≃ₐ[F] E)) (K : intermediate_field F E)

namespace intermediate_field

/-- The intermediate_field fixed by a subgroup -/
def fixed_field : intermediate_field F E :=
{ carrier := mul_action.fixed_points H E,
  zero_mem' := λ g, smul_zero g,
  add_mem' := λ a b hx hy g, by rw [smul_add g a b, hx, hy],
  neg_mem' := λ a hx g, by rw [smul_neg g a, hx],
  one_mem' := λ g, smul_one g,
  mul_mem' := λ a b hx hy g, by rw [smul_mul' g a b, hx, hy],
  inv_mem' := λ a hx g, by rw [smul_inv'' g a, hx],
  algebra_map_mem' := λ a g, commutes g a }

lemma finrank_fixed_field_eq_card [finite_dimensional F E] :
  finrank (fixed_field H) E = fintype.card H :=
fixed_points.finrank_eq_card H E

/-- The subgroup fixing an intermediate_field -/
def fixing_subgroup : subgroup (E ≃ₐ[F] E) :=
{ carrier := λ ϕ, ∀ x : K, ϕ x = x,
  one_mem' := λ _, rfl,
  mul_mem' := λ _ _ hx hy _, (congr_arg _ (hy _)).trans (hx _),
  inv_mem' := λ _ hx _, (equiv.symm_apply_eq (to_equiv _)).mpr (hx _).symm }

lemma le_iff_le : K ≤ fixed_field H ↔ H ≤ fixing_subgroup K :=
⟨λ h g hg x, h (subtype.mem x) ⟨g, hg⟩, λ h x hx g, h (subtype.mem g) ⟨x, hx⟩⟩

/-- The fixing_subgroup of `K : intermediate_field F E` is isomorphic to `E ≃ₐ[K] E` -/
def fixing_subgroup_equiv : fixing_subgroup K ≃* (E ≃ₐ[K] E) :=
{ to_fun := λ ϕ, of_bijective (alg_hom.mk ϕ (map_one ϕ) (map_mul ϕ)
    (map_zero ϕ) (map_add ϕ) (ϕ.mem)) (bijective ϕ),
  inv_fun := λ ϕ, ⟨of_bijective (alg_hom.mk ϕ (ϕ.map_one) (ϕ.map_mul)
    (ϕ.map_zero) (ϕ.map_add) (λ r, ϕ.commutes (algebra_map F K r)))
      (ϕ.bijective), ϕ.commutes⟩,
  left_inv := λ _, by { ext, refl },
  right_inv := λ _, by { ext, refl },
  map_mul' := λ _ _, by { ext, refl } }

theorem fixing_subgroup_fixed_field [finite_dimensional F E] :
  fixing_subgroup (fixed_field H) = H :=
begin
  have H_le : H ≤ (fixing_subgroup (fixed_field H)) := (le_iff_le _ _).mp (le_refl _),
  suffices : fintype.card H = fintype.card (fixing_subgroup (fixed_field H)),
  { exact set_like.coe_injective
      (set.eq_of_inclusion_surjective ((fintype.bijective_iff_injective_and_card
        (set.inclusion H_le)).mpr ⟨set.inclusion_injective H_le, this⟩).2).symm },
  apply fintype.card_congr,
  refine (fixed_points.to_alg_hom_equiv H E).trans _,
  refine (alg_equiv_equiv_alg_hom (fixed_field H) E).symm.trans _,
  exact (fixing_subgroup_equiv (fixed_field H)).to_equiv.symm
end

instance fixed_field.algebra : algebra K (fixed_field (fixing_subgroup K)) :=
{ smul := λ x y, ⟨x*y, λ ϕ, by rw [smul_mul', (show ϕ • ↑x = ↑x, by exact subtype.mem ϕ x),
    (show ϕ • ↑y = ↑y, by exact subtype.mem y ϕ)]⟩,
  to_fun := λ x, ⟨x, λ ϕ, subtype.mem ϕ x⟩,
  map_zero' := rfl,
  map_add' := λ _ _, rfl,
  map_one' := rfl,
  map_mul' := λ _ _, rfl,
  commutes' := λ _ _, mul_comm _ _,
  smul_def' := λ _ _, rfl }

instance fixed_field.is_scalar_tower : is_scalar_tower K (fixed_field (fixing_subgroup K)) E :=
⟨λ _ _ _, mul_assoc _ _ _⟩

end intermediate_field

namespace is_galois
theorem fixed_field_fixing_subgroup [finite_dimensional F E] [h : is_galois F E] :
  intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) = K :=
begin
  have K_le : K ≤ intermediate_field.fixed_field (intermediate_field.fixing_subgroup K) :=
    (intermediate_field.le_iff_le _ _).mpr (le_refl _),
  suffices : finrank K E =
    finrank (intermediate_field.fixed_field (intermediate_field.fixing_subgroup K)) E,
  { exact (intermediate_field.eq_of_le_of_finrank_eq' K_le this).symm },
  rw [intermediate_field.finrank_fixed_field_eq_card,
    fintype.card_congr (intermediate_field.fixing_subgroup_equiv K).to_equiv],
  exact (card_aut_eq_finrank K E).symm,
end

lemma card_fixing_subgroup_eq_finrank [finite_dimensional F E] [is_galois F E] :
  fintype.card (intermediate_field.fixing_subgroup K) = finrank K E :=
by conv { to_rhs, rw [←fixed_field_fixing_subgroup K,
  intermediate_field.finrank_fixed_field_eq_card] }

/-- The Galois correspondence from intermediate fields to subgroups -/
def intermediate_field_equiv_subgroup [finite_dimensional F E] [is_galois F E] :
  intermediate_field F E ≃o order_dual (subgroup (E ≃ₐ[F] E)) :=
{ to_fun := intermediate_field.fixing_subgroup,
  inv_fun := intermediate_field.fixed_field,
  left_inv := λ K, fixed_field_fixing_subgroup K,
  right_inv := λ H, intermediate_field.fixing_subgroup_fixed_field H,
  map_rel_iff' := λ K L, by { rw [←fixed_field_fixing_subgroup L, intermediate_field.le_iff_le,
                                  fixed_field_fixing_subgroup L, ←order_dual.dual_le], refl } }

/-- The Galois correspondence as a galois_insertion -/
def galois_insertion_intermediate_field_subgroup [finite_dimensional F E] :
  galois_insertion (order_dual.to_dual ∘
      (intermediate_field.fixing_subgroup : intermediate_field F E → subgroup (E ≃ₐ[F] E)))
    ((intermediate_field.fixed_field : subgroup (E ≃ₐ[F] E) → intermediate_field F E) ∘
      order_dual.to_dual) :=
{ choice := λ K _, intermediate_field.fixing_subgroup K,
  gc := λ K H, (intermediate_field.le_iff_le H K).symm,
  le_l_u := λ H, le_of_eq (intermediate_field.fixing_subgroup_fixed_field H).symm,
  choice_eq := λ K _, rfl }

/-- The Galois correspondence as a galois_coinsertion -/
def galois_coinsertion_intermediate_field_subgroup [finite_dimensional F E] [is_galois F E] :
  galois_coinsertion (order_dual.to_dual ∘
      (intermediate_field.fixing_subgroup : intermediate_field F E → subgroup (E ≃ₐ[F] E)))
    ((intermediate_field.fixed_field : subgroup (E ≃ₐ[F] E) → intermediate_field F E) ∘
      order_dual.to_dual) :=
{ choice := λ H _, intermediate_field.fixed_field H,
  gc := λ K H, (intermediate_field.le_iff_le H K).symm,
  u_l_le := λ K, le_of_eq (fixed_field_fixing_subgroup K),
  choice_eq := λ H _, rfl }

end is_galois

end galois_correspondence

section galois_equivalent_definitions

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

namespace is_galois

lemma is_separable_splitting_field [finite_dimensional F E] [is_galois F E] :
  ∃ p : polynomial F, p.separable ∧ p.is_splitting_field F E :=
begin
  cases field.exists_primitive_element F E with α h1,
  use [minpoly F α, separable F α, is_galois.splits F α],
  rw [eq_top_iff, ←intermediate_field.top_to_subalgebra, ←h1],
  rw intermediate_field.adjoin_simple_to_subalgebra_of_integral F α (integral F α),
  apply algebra.adjoin_mono,
  rw [set.singleton_subset_iff, finset.mem_coe, multiset.mem_to_finset, polynomial.mem_roots],
  { dsimp only [polynomial.is_root],
    rw [polynomial.eval_map, ←polynomial.aeval_def],
    exact minpoly.aeval _ _ },
  { exact polynomial.map_ne_zero (minpoly.ne_zero (integral F α)) }
end

lemma of_fixed_field_eq_bot [finite_dimensional F E]
  (h : intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E)) = ⊥) : is_galois F E :=
begin
  rw [←is_galois_iff_is_galois_bot, ←h],
  exact is_galois.of_fixed_field E (⊤ : subgroup (E ≃ₐ[F] E)),
end

lemma of_card_aut_eq_finrank [finite_dimensional F E]
  (h : fintype.card (E ≃ₐ[F] E) = finrank F E) : is_galois F E :=
begin
  apply of_fixed_field_eq_bot,
  have p : 0 < finrank (intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E))) E := finrank_pos,
  rw [←intermediate_field.finrank_eq_one_iff, ←mul_left_inj' (ne_of_lt p).symm, finrank_mul_finrank,
      ←h, one_mul, intermediate_field.finrank_fixed_field_eq_card],
  apply fintype.card_congr,
  exact { to_fun := λ g, ⟨g, subgroup.mem_top g⟩, inv_fun := coe,
          left_inv := λ g, rfl, right_inv := λ _, by { ext, refl } },
end

variables {F} {E} {p : polynomial F}

lemma of_separable_splitting_field_aux [hFE : finite_dimensional F E]
  [sp : p.is_splitting_field F E] (hp : p.separable) (K : intermediate_field F E) {x : E}
  (hx : x ∈ (p.map (algebra_map F E)).roots) :
  fintype.card ((↑K⟮x⟯ : intermediate_field F E) →ₐ[F] E) =
    fintype.card (K →ₐ[F] E) * finrank K K⟮x⟯ :=
begin
  have h : is_integral K x := is_integral_of_is_scalar_tower x
    (is_integral_of_noetherian (is_noetherian.iff_fg.2 hFE) x),
  have h1 : p ≠ 0 := λ hp, by rwa [hp, polynomial.map_zero, polynomial.roots_zero] at hx,
  have h2 : (minpoly K x) ∣ p.map (algebra_map F K),
  { apply minpoly.dvd,
    rw [polynomial.aeval_def, polynomial.eval₂_map, ←polynomial.eval_map],
    exact (polynomial.mem_roots (polynomial.map_ne_zero h1)).mp hx },
  let key_equiv : ((↑K⟮x⟯ : intermediate_field F E) →ₐ[F] E) ≃ Σ (f : K →ₐ[F] E),
    @alg_hom K K⟮x⟯ E _ _ _ _ (ring_hom.to_algebra f) :=
  equiv.trans (alg_equiv.arrow_congr (intermediate_field.lift2_alg_equiv K⟮x⟯) (alg_equiv.refl))
    alg_hom_equiv_sigma,
  haveI : Π (f : K →ₐ[F] E), fintype (@alg_hom K K⟮x⟯ E _ _ _ _ (ring_hom.to_algebra f)) := λ f, by
  { apply fintype.of_injective (sigma.mk f) (λ _ _ H, eq_of_heq ((sigma.mk.inj H).2)),
    exact fintype.of_equiv _ key_equiv },
  rw [fintype.card_congr key_equiv, fintype.card_sigma, intermediate_field.adjoin.finrank h],
  apply finset.sum_const_nat,
  intros f hf,
  rw ← @intermediate_field.card_alg_hom_adjoin_integral K _ E _ _ x E _ (ring_hom.to_algebra f) h,
  { apply fintype.card_congr, refl },
  { exact polynomial.separable.of_dvd ((polynomial.separable_map (algebra_map F K)).mpr hp) h2 },
  { refine polynomial.splits_of_splits_of_dvd _ (polynomial.map_ne_zero h1) _ h2,
    rw [polynomial.splits_map_iff, ←is_scalar_tower.algebra_map_eq],
    exact sp.splits },
end

lemma of_separable_splitting_field [sp : p.is_splitting_field F E] (hp : p.separable) :
  is_galois F E :=
begin
  haveI hFE : finite_dimensional F E := polynomial.is_splitting_field.finite_dimensional E p,
  let s := (p.map (algebra_map F E)).roots.to_finset,
  have adjoin_root : intermediate_field.adjoin F ↑s = ⊤,
  { apply intermediate_field.to_subalgebra_injective,
    rw [intermediate_field.top_to_subalgebra, ←top_le_iff, ←sp.adjoin_roots],
    apply intermediate_field.algebra_adjoin_le_adjoin, },
  let P : intermediate_field F E → Prop := λ K, fintype.card (K →ₐ[F] E) = finrank F K,
  suffices : P (intermediate_field.adjoin F ↑s),
  { rw adjoin_root at this,
    apply of_card_aut_eq_finrank,
    rw ← eq.trans this (linear_equiv.finrank_eq intermediate_field.top_equiv.to_linear_equiv),
    exact fintype.card_congr (equiv.trans (alg_equiv_equiv_alg_hom F E)
      (alg_equiv.arrow_congr intermediate_field.top_equiv.symm alg_equiv.refl)) },
  apply intermediate_field.induction_on_adjoin_finset s P,
  { have key := intermediate_field.card_alg_hom_adjoin_integral F
      (show is_integral F (0 : E), by exact is_integral_zero),
    rw [minpoly.zero, polynomial.nat_degree_X] at key,
    specialize key polynomial.separable_X (polynomial.splits_X (algebra_map F E)),
    rw [←@subalgebra.finrank_bot F E _ _ _, ←intermediate_field.bot_to_subalgebra] at key,
    refine eq.trans _ key,
    apply fintype.card_congr,
    rw intermediate_field.adjoin_zero },
  intros K x hx hK,
  simp only [P] at *,
  rw [of_separable_splitting_field_aux hp K (multiset.mem_to_finset.mp hx),
    hK, finrank_mul_finrank],
  exact (linear_equiv.finrank_eq (intermediate_field.lift2_alg_equiv K⟮x⟯).to_linear_equiv).symm,
end

/--Equivalent characterizations of a Galois extension of finite degree-/
theorem tfae [finite_dimensional F E] :
  tfae [is_galois F E,
    intermediate_field.fixed_field (⊤ : subgroup (E ≃ₐ[F] E)) = ⊥,
    fintype.card (E ≃ₐ[F] E) = finrank F E,
    ∃ p : polynomial F, p.separable ∧ p.is_splitting_field F E] :=
begin
  tfae_have : 1 → 2,
  { exact λ h, order_iso.map_bot (@intermediate_field_equiv_subgroup F _ E _ _ _ h).symm },
  tfae_have : 1 → 3,
  { introI _, exact card_aut_eq_finrank F E },
  tfae_have : 1 → 4,
  { introI _, exact is_separable_splitting_field F E },
  tfae_have : 2 → 1,
  { exact of_fixed_field_eq_bot F E },
  tfae_have : 3 → 1,
  { exact of_card_aut_eq_finrank F E },
  tfae_have : 4 → 1,
  { rintros ⟨h, hp1, _⟩, exactI of_separable_splitting_field hp1 },
  tfae_finish,
end

end is_galois

end galois_equivalent_definitions


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro, Scott Morrison, Ainsley Pahljina
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ring_exp
import Mathlib.tactic.interval_cases
import Mathlib.data.nat.parity
import Mathlib.data.zmod.basic
import Mathlib.group_theory.order_of_element
import Mathlib.ring_theory.fintype
import Mathlib.PostPort

namespace Mathlib

/-!
# The Lucas-Lehmer test for Mersenne primes.

We define `lucas_lehmer_residue : Π p : ℕ, zmod (2^p - 1)`, and
prove `lucas_lehmer_residue p = 0 → prime (mersenne p)`.

We construct a tactic `lucas_lehmer.run_test`, which iteratively certifies the arithmetic
required to calculate the residue, and enables us to prove

```
example : prime (mersenne 127) :=
lucas_lehmer_sufficiency _ (by norm_num) (by lucas_lehmer.run_test)
```

## TODO

- Show reverse implication.
- Speed up the calculations using `n ≡ (n % 2^p) + (n / 2^p) [MOD 2^p - 1]`.
- Find some bigger primes!

## History

This development began as a student project by Ainsley Pahljina,
and was then cleaned up for mathlib by Scott Morrison.
The tactic for certified computation of Lucas-Lehmer residues was provided by Mario Carneiro.
-/

/-- The Mersenne numbers, 2^p - 1. -/
def mersenne (p : ℕ) : ℕ :=
  bit0 1 ^ p - 1

theorem mersenne_pos {p : ℕ} (h : 0 < p) : 0 < mersenne p := sorry

@[simp] theorem succ_mersenne (k : ℕ) : mersenne k + 1 = bit0 1 ^ k := sorry

namespace lucas_lehmer

/-!
We now define three(!) different versions of the recurrence
`s (i+1) = (s i)^2 - 2`.

These versions take values either in `ℤ`, in `zmod (2^p - 1)`, or
in `ℤ` but applying `% (2^p - 1)` at each step.

They are each useful at different points in the proof,
so we take a moment setting up the lemmas relating them.
-/

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `ℤ`. -/
def s : ℕ → ℤ :=
  sorry

/-- The recurrence `s (i+1) = (s i)^2 - 2` in `zmod (2^p - 1)`. -/
def s_zmod (p : ℕ) : ℕ → zmod (bit0 1 ^ p - 1) :=
  sorry

/-- The recurrence `s (i+1) = ((s i)^2 - 2) % (2^p - 1)` in `ℤ`. -/
def s_mod (p : ℕ) : ℕ → ℤ :=
  sorry

theorem mersenne_int_ne_zero (p : ℕ) (w : 0 < p) : bit0 1 ^ p - 1 ≠ 0 := sorry

theorem s_mod_nonneg (p : ℕ) (w : 0 < p) (i : ℕ) : 0 ≤ s_mod p i :=
  nat.cases_on i (id (iff.mp sup_eq_left rfl))
    fun (i : ℕ) => id (int.mod_nonneg (s_mod p i ^ bit0 1 - bit0 1) (mersenne_int_ne_zero p w))

theorem s_mod_mod (p : ℕ) (i : ℕ) : s_mod p i % (bit0 1 ^ p - 1) = s_mod p i := sorry

theorem s_mod_lt (p : ℕ) (w : 0 < p) (i : ℕ) : s_mod p i < bit0 1 ^ p - 1 := sorry

theorem s_zmod_eq_s (p' : ℕ) (i : ℕ) : s_zmod (p' + bit0 1) i = ↑(s i) := sorry

-- These next two don't make good `norm_cast` lemmas.

theorem int.coe_nat_pow_pred (b : ℕ) (p : ℕ) (w : 0 < b) : ↑(b ^ p - 1) = ↑b ^ p - 1 := sorry

theorem int.coe_nat_two_pow_pred (p : ℕ) : ↑(bit0 1 ^ p - 1) = bit0 1 ^ p - 1 :=
  int.coe_nat_pow_pred (bit0 1) p (of_as_true trivial)

theorem s_zmod_eq_s_mod (p : ℕ) (i : ℕ) : s_zmod p i = ↑(s_mod p i) := sorry

/-- The Lucas-Lehmer residue is `s p (p-2)` in `zmod (2^p - 1)`. -/
def lucas_lehmer_residue (p : ℕ) : zmod (bit0 1 ^ p - 1) :=
  s_zmod p (p - bit0 1)

theorem residue_eq_zero_iff_s_mod_eq_zero (p : ℕ) (w : 1 < p) : lucas_lehmer_residue p = 0 ↔ s_mod p (p - bit0 1) = 0 := sorry

/--
A Mersenne number `2^p-1` is prime if and only if
the Lucas-Lehmer residue `s p (p-2) % (2^p - 1)` is zero.
-/
def lucas_lehmer_test (p : ℕ) :=
  lucas_lehmer_residue p = 0

/-- `q` is defined as the minimum factor of `mersenne p`, bundled as an `ℕ+`. -/
def q (p : ℕ) : ℕ+ :=
  { val := nat.min_fac (mersenne p), property := sorry }

protected instance fact_pnat_pos (q : ℕ+) : fact (0 < ↑q) :=
  subtype.property q

/-- We construct the ring `X q` as ℤ/qℤ + √3 ℤ/qℤ. -/
-- It would be nice to define this as (ℤ/qℤ)[x] / (x^2 - 3),

-- obtaining the ring structure for free,

-- but that seems to be more trouble than it's worth;

-- if it were easy to make the definition,

-- cardinality calculations would be somewhat more involved, too.

def X (q : ℕ+) :=
  zmod ↑q × zmod ↑q

namespace X

theorem ext {q : ℕ+} {x : X q} {y : X q} (h₁ : prod.fst x = prod.fst y) (h₂ : prod.snd x = prod.snd y) : x = y := sorry

@[simp] theorem add_fst {q : ℕ+} (x : X q) (y : X q) : prod.fst (x + y) = prod.fst x + prod.fst y :=
  rfl

@[simp] theorem add_snd {q : ℕ+} (x : X q) (y : X q) : prod.snd (x + y) = prod.snd x + prod.snd y :=
  rfl

@[simp] theorem neg_fst {q : ℕ+} (x : X q) : prod.fst (-x) = -prod.fst x :=
  rfl

@[simp] theorem neg_snd {q : ℕ+} (x : X q) : prod.snd (-x) = -prod.snd x :=
  rfl

protected instance has_mul {q : ℕ+} : Mul (X q) :=
  { mul :=
      fun (x y : X q) =>
        (prod.fst x * prod.fst y + bit1 1 * prod.snd x * prod.snd y, prod.fst x * prod.snd y + prod.snd x * prod.fst y) }

@[simp] theorem mul_fst {q : ℕ+} (x : X q) (y : X q) : prod.fst (x * y) = prod.fst x * prod.fst y + bit1 1 * prod.snd x * prod.snd y :=
  rfl

@[simp] theorem mul_snd {q : ℕ+} (x : X q) (y : X q) : prod.snd (x * y) = prod.fst x * prod.snd y + prod.snd x * prod.fst y :=
  rfl

protected instance has_one {q : ℕ+} : HasOne (X q) :=
  { one := (1, 0) }

@[simp] theorem one_fst {q : ℕ+} : prod.fst 1 = 1 :=
  rfl

@[simp] theorem one_snd {q : ℕ+} : prod.snd 1 = 0 :=
  rfl

@[simp] theorem bit0_fst {q : ℕ+} (x : X q) : prod.fst (bit0 x) = bit0 (prod.fst x) :=
  rfl

@[simp] theorem bit0_snd {q : ℕ+} (x : X q) : prod.snd (bit0 x) = bit0 (prod.snd x) :=
  rfl

@[simp] theorem bit1_fst {q : ℕ+} (x : X q) : prod.fst (bit1 x) = bit1 (prod.fst x) :=
  rfl

@[simp] theorem bit1_snd {q : ℕ+} (x : X q) : prod.snd (bit1 x) = bit0 (prod.snd x) := sorry

protected instance monoid {q : ℕ+} : monoid (X q) :=
  monoid.mk Mul.mul sorry (1, 0) sorry sorry

theorem left_distrib {q : ℕ+} (x : X q) (y : X q) (z : X q) : x * (y + z) = x * y + x * z := sorry

theorem right_distrib {q : ℕ+} (x : X q) (y : X q) (z : X q) : (x + y) * z = x * z + y * z := sorry

protected instance ring {q : ℕ+} : ring (X q) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg add_comm_group.sub sorry sorry
    monoid.mul sorry monoid.one sorry sorry left_distrib right_distrib

protected instance comm_ring {q : ℕ+} : comm_ring (X q) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry ring.one sorry sorry
    sorry sorry sorry

protected instance nontrivial {q : ℕ+} [fact (1 < ↑q)] : nontrivial (X q) :=
  nontrivial.mk
    (Exists.intro 0
      (Exists.intro 1 fun (h : 0 = 1) => prod.mk.inj_arrow h fun (h1 : 0 = 1) (ᾰ : 0 = 0) => zero_ne_one h1))

@[simp] theorem nat_coe_fst {q : ℕ+} (n : ℕ) : prod.fst ↑n = ↑n :=
  Nat.rec (Eq.refl (prod.fst ↑0))
    (fun (n_n : ℕ) (n_ih : prod.fst ↑n_n = ↑n_n) => id (eq.mpr (id (propext (add_left_inj 1))) n_ih)) n

@[simp] theorem nat_coe_snd {q : ℕ+} (n : ℕ) : prod.snd ↑n = 0 := sorry

@[simp] theorem int_coe_fst {q : ℕ+} (n : ℤ) : prod.fst ↑n = ↑n := sorry

@[simp] theorem int_coe_snd {q : ℕ+} (n : ℤ) : prod.snd ↑n = 0 := sorry

theorem coe_mul {q : ℕ+} (n : ℤ) (m : ℤ) : ↑(n * m) = ↑n * ↑m := sorry

theorem coe_nat {q : ℕ+} (n : ℕ) : ↑↑n = ↑n := sorry

/-- The cardinality of `X` is `q^2`. -/
theorem X_card {q : ℕ+} : fintype.card (X q) = ↑q ^ bit0 1 := sorry

/-- There are strictly fewer than `q^2` units, since `0` is not a unit. -/
theorem units_card {q : ℕ+} (w : 1 < q) : fintype.card (units (X q)) < ↑q ^ bit0 1 := sorry

/-- We define `ω = 2 + √3`. -/
/-- We define `ωb = 2 - √3`, which is the inverse of `ω`. -/
def ω {q : ℕ+} : X q :=
  (bit0 1, 1)

def ωb {q : ℕ+} : X q :=
  (bit0 1, -1)

theorem ω_mul_ωb (q : ℕ+) : ω * ωb = 1 := sorry

theorem ωb_mul_ω (q : ℕ+) : ωb * ω = 1 := sorry

/-- A closed form for the recurrence relation. -/
theorem closed_form {q : ℕ+} (i : ℕ) : ↑(s i) = ω ^ bit0 1 ^ i + ωb ^ bit0 1 ^ i := sorry

end X

/-!
Here and below, we introduce `p' = p - 2`, in order to avoid using subtraction in `ℕ`.
-/

/-- If `1 < p`, then `q p`, the smallest prime factor of `mersenne p`, is more than 2. -/
theorem two_lt_q (p' : ℕ) : bit0 1 < q (p' + bit0 1) := sorry

theorem ω_pow_formula (p' : ℕ) (h : lucas_lehmer_residue (p' + bit0 1) = 0) : ∃ (k : ℤ), X.ω ^ bit0 1 ^ (p' + 1) = ↑k * ↑(mersenne (p' + bit0 1)) * X.ω ^ bit0 1 ^ p' - 1 := sorry

/-- `q` is the minimum factor of `mersenne p`, so `M p = 0` in `X q`. -/
theorem mersenne_coe_X (p : ℕ) : ↑(mersenne p) = 0 := sorry

theorem ω_pow_eq_neg_one (p' : ℕ) (h : lucas_lehmer_residue (p' + bit0 1) = 0) : X.ω ^ bit0 1 ^ (p' + 1) = -1 := sorry

theorem ω_pow_eq_one (p' : ℕ) (h : lucas_lehmer_residue (p' + bit0 1) = 0) : X.ω ^ bit0 1 ^ (p' + bit0 1) = 1 := sorry

/-- `ω` as an element of the group of units. -/
def ω_unit (p : ℕ) : units (X (q p)) :=
  units.mk X.ω X.ωb sorry sorry

@[simp] theorem ω_unit_coe (p : ℕ) : ↑(ω_unit p) = X.ω :=
  rfl

/-- The order of `ω` in the unit group is exactly `2^p`. -/
theorem order_ω (p' : ℕ) (h : lucas_lehmer_residue (p' + bit0 1) = 0) : order_of (ω_unit (p' + bit0 1)) = bit0 1 ^ (p' + bit0 1) := sorry

theorem order_ineq (p' : ℕ) (h : lucas_lehmer_residue (p' + bit0 1) = 0) : bit0 1 ^ (p' + bit0 1) < ↑(q (p' + bit0 1)) ^ bit0 1 :=
  lt_of_le_of_lt (trans_rel_right LessEq (Eq.symm (order_ω p' h)) order_of_le_card_univ)
    (X.units_card (nat.lt_of_succ_lt (two_lt_q p')))

end lucas_lehmer

theorem lucas_lehmer_sufficiency (p : ℕ) (w : 1 < p) : lucas_lehmer_test p → nat.prime (mersenne p) := sorry

-- Here we calculate the residue, very inefficiently, using `dec_trivial`. We can do much better.

-- Next we use `norm_num` to calculate each `s p i`.

namespace lucas_lehmer

theorem s_mod_succ {p : ℕ} {a : ℤ} {i : ℕ} {b : ℤ} {c : ℤ} (h1 : bit0 1 ^ p - 1 = a) (h2 : s_mod p i = b) (h3 : (b * b - bit0 1) % a = c) : s_mod p (i + 1) = c := sorry

/--
Given a goal of the form `lucas_lehmer_test p`,
attempt to do the calculation using `norm_num` to certify each step.
-/
end lucas_lehmer

/-- We verify that the tactic works to prove `127.prime`. -/
/-!
This implementation works successfully to prove `(2^127 - 1).prime`,
and all the Mersenne primes up to this point appear in [archive/examples/mersenne_primes.lean].

`(2^127 - 1).prime` takes about 5 minutes to run (depending on your CPU!),
and unfortunately the next Mersenne prime `(2^521 - 1)`,
which was the first "computer era" prime,
is out of reach with the current implementation.

There's still low hanging fruit available to do faster computations
based on the formula
  n ≡ (n % 2^p) + (n / 2^p) [MOD 2^p - 1]
and the fact that `% 2^p` and `/ 2^p` can be very efficient on the binary representation.
Someone should do this, too!
-/

-- See https://leanprover.zulipchat.com/#narrow/stream/113489-new-members/topic/help.20finding.20a.20lemma/near/177698446

theorem modeq_mersenne (n : ℕ) (k : ℕ) : nat.modeq (bit0 1 ^ n - 1) k (k / bit0 1 ^ n + k % bit0 1 ^ n) := sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.tensor_product
import Mathlib.algebra.algebra.basic
import Mathlib.PostPort

universes u v₁ v₂ v₃ v₄

namespace Mathlib

/-!
# The tensor product of R-algebras

We construct the R-algebra structure on `A ⊗[R] B`, when `A` and `B` are both `R`-algebras,
and provide the structure isomorphisms

* `R ⊗[R] A ≃ₐ[R] A`
* `A ⊗[R] R ≃ₐ[R] A`
* `A ⊗[R] B ≃ₐ[R] B ⊗[R] A`

The code for
* `((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C))`
is written and compiles, but takes longer than the `-T100000` time limit,
so is currently commented out.
-/

namespace algebra

namespace tensor_product

/--
(Implementation detail)
The multiplication map on `A ⊗[R] B`,
for a fixed pure tensor in the first argument,
as an `R`-linear map.
-/
def mul_aux {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂}
    [semiring B] [algebra R B] (a₁ : A) (b₁ : B) :
    linear_map R (tensor_product R A B) (tensor_product R A B) :=
  tensor_product.lift
    (linear_map.mk
      (fun (a₂ : A) =>
        linear_map.mk (fun (b₂ : B) => tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) sorry sorry)
      sorry sorry)

@[simp] theorem mul_aux_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] (a₁ : A) (a₂ : A) (b₁ : B) (b₂ : B) :
    coe_fn (mul_aux a₁ b₁) (tensor_product.tmul R a₂ b₂) =
        tensor_product.tmul R (a₁ * a₂) (b₁ * b₂) :=
  rfl

/--
(Implementation detail)
The multiplication map on `A ⊗[R] B`,
as an `R`-bilinear map.
-/
def mul {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂}
    [semiring B] [algebra R B] :
    linear_map R (tensor_product R A B)
        (linear_map R (tensor_product R A B) (tensor_product R A B)) :=
  tensor_product.lift
    (linear_map.mk (fun (a₁ : A) => linear_map.mk (fun (b₁ : B) => mul_aux a₁ b₁) sorry sorry) sorry
      sorry)

@[simp] theorem mul_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] (a₁ : A) (a₂ : A) (b₁ : B) (b₂ : B) :
    coe_fn (coe_fn mul (tensor_product.tmul R a₁ b₁)) (tensor_product.tmul R a₂ b₂) =
        tensor_product.tmul R (a₁ * a₂) (b₁ * b₂) :=
  rfl

theorem mul_assoc' {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B]
    (mul :
      linear_map R (tensor_product R A B)
        (linear_map R (tensor_product R A B) (tensor_product R A B)))
    (h :
      ∀ (a₁ a₂ a₃ : A) (b₁ b₂ b₃ : B),
        coe_fn
            (coe_fn mul
              (coe_fn (coe_fn mul (tensor_product.tmul R a₁ b₁)) (tensor_product.tmul R a₂ b₂)))
            (tensor_product.tmul R a₃ b₃) =
          coe_fn (coe_fn mul (tensor_product.tmul R a₁ b₁))
            (coe_fn (coe_fn mul (tensor_product.tmul R a₂ b₂)) (tensor_product.tmul R a₃ b₃)))
    (x : tensor_product R A B) (y : tensor_product R A B) (z : tensor_product R A B) :
    coe_fn (coe_fn mul (coe_fn (coe_fn mul x) y)) z =
        coe_fn (coe_fn mul x) (coe_fn (coe_fn mul y) z) :=
  sorry

theorem mul_assoc {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] (x : tensor_product R A B) (y : tensor_product R A B)
    (z : tensor_product R A B) :
    coe_fn (coe_fn mul (coe_fn (coe_fn mul x) y)) z =
        coe_fn (coe_fn mul x) (coe_fn (coe_fn mul y) z) :=
  sorry

theorem one_mul {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] (x : tensor_product R A B) :
    coe_fn (coe_fn mul (tensor_product.tmul R 1 1)) x = x :=
  sorry

theorem mul_one {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] (x : tensor_product R A B) :
    coe_fn (coe_fn mul x) (tensor_product.tmul R 1 1) = x :=
  sorry

protected instance tensor_product.semiring {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] : semiring (tensor_product R A B) :=
  semiring.mk Add.add sorry 0 sorry sorry sorry
    (fun (a b : tensor_product R A B) => coe_fn (coe_fn mul a) b) mul_assoc
    (tensor_product.tmul R 1 1) one_mul mul_one sorry sorry sorry sorry

theorem one_def {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] : 1 = tensor_product.tmul R 1 1 :=
  rfl

@[simp] theorem tmul_mul_tmul {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] (a₁ : A) (a₂ : A) (b₁ : B) (b₂ : B) :
    tensor_product.tmul R a₁ b₁ * tensor_product.tmul R a₂ b₂ =
        tensor_product.tmul R (a₁ * a₂) (b₁ * b₂) :=
  rfl

@[simp] theorem tmul_pow {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] (a : A) (b : B) (k : ℕ) :
    tensor_product.tmul R a b ^ k = tensor_product.tmul R (a ^ k) (b ^ k) :=
  sorry

/--
The algebra map `R →+* (A ⊗[R] B)` giving `A ⊗[R] B` the structure of an `R`-algebra.
-/
def tensor_algebra_map {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] : R →+* tensor_product R A B :=
  ring_hom.mk (fun (r : R) => tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) sorry sorry
    sorry sorry

protected instance tensor_product.algebra {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] : algebra R (tensor_product R A B) :=
  mk (ring_hom.mk (ring_hom.to_fun tensor_algebra_map) sorry sorry sorry sorry) sorry sorry

@[simp] theorem algebra_map_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] (r : R) :
    coe_fn (algebra_map R (tensor_product R A B)) r =
        tensor_product.tmul R (coe_fn (algebra_map R A) r) 1 :=
  rfl

theorem ext {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂}
    [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C]
    {g : alg_hom R (tensor_product R A B) C} {h : alg_hom R (tensor_product R A B) C}
    (H :
      ∀ (a : A) (b : B),
        coe_fn g (tensor_product.tmul R a b) = coe_fn h (tensor_product.tmul R a b)) :
    g = h :=
  sorry

/-- The algebra morphism `A →ₐ[R] A ⊗[R] B` sending `a` to `a ⊗ₜ 1`. -/
def include_left {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] : alg_hom R A (tensor_product R A B) :=
  alg_hom.mk (fun (a : A) => tensor_product.tmul R a 1) sorry sorry sorry sorry sorry

@[simp] theorem include_left_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] (a : A) :
    coe_fn include_left a = tensor_product.tmul R a 1 :=
  rfl

/-- The algebra morphism `B →ₐ[R] A ⊗[R] B` sending `b` to `1 ⊗ₜ b`. -/
def include_right {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] : alg_hom R B (tensor_product R A B) :=
  alg_hom.mk (fun (b : B) => tensor_product.tmul R 1 b) sorry sorry sorry sorry sorry

@[simp] theorem include_right_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] (b : B) :
    coe_fn include_right b = tensor_product.tmul R 1 b :=
  rfl

protected instance tensor_product.ring {R : Type u} [comm_ring R] {A : Type v₁} [ring A]
    [algebra R A] {B : Type v₂} [ring B] [algebra R B] : ring (tensor_product R A B) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg
    add_comm_group.sub sorry sorry semiring.mul sorry semiring.one sorry sorry sorry sorry

protected instance tensor_product.comm_ring {R : Type u} [comm_ring R] {A : Type v₁} [comm_ring A]
    [algebra R A] {B : Type v₂} [comm_ring B] [algebra R B] : comm_ring (tensor_product R A B) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

/--
Verify that typeclass search finds the ring structure on `A ⊗[ℤ] B`
when `A` and `B` are merely rings, by treating both as `ℤ`-algebras.
-/
/--
Verify that typeclass search finds the comm_ring structure on `A ⊗[ℤ] B`
when `A` and `B` are merely comm_rings, by treating both as `ℤ`-algebras.
-/
/-!
We now build the structure maps for the symmetric monoidal category of `R`-algebras.
-/

/--
Build an algebra morphism from a linear map out of a tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_hom_of_linear_map_tensor_product {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C]
    (f : linear_map R (tensor_product R A B) C)
    (w₁ :
      ∀ (a₁ a₂ : A) (b₁ b₂ : B),
        coe_fn f (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) =
          coe_fn f (tensor_product.tmul R a₁ b₁) * coe_fn f (tensor_product.tmul R a₂ b₂))
    (w₂ :
      ∀ (r : R),
        coe_fn f (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) =
          coe_fn (algebra_map R C) r) :
    alg_hom R (tensor_product R A B) C :=
  alg_hom.mk (linear_map.to_fun f) sorry sorry sorry sorry sorry

@[simp] theorem alg_hom_of_linear_map_tensor_product_apply {R : Type u} [comm_semiring R]
    {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃}
    [semiring C] [algebra R C] (f : linear_map R (tensor_product R A B) C)
    (w₁ :
      ∀ (a₁ a₂ : A) (b₁ b₂ : B),
        coe_fn f (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) =
          coe_fn f (tensor_product.tmul R a₁ b₁) * coe_fn f (tensor_product.tmul R a₂ b₂))
    (w₂ :
      ∀ (r : R),
        coe_fn f (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) =
          coe_fn (algebra_map R C) r)
    (x : tensor_product R A B) :
    coe_fn (alg_hom_of_linear_map_tensor_product f w₁ w₂) x = coe_fn f x :=
  rfl

/--
Build an algebra equivalence from a linear equivalence out of a tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_equiv_of_linear_equiv_tensor_product {R : Type u} [comm_semiring R] {A : Type v₁}
    [semiring A] [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C]
    [algebra R C] (f : linear_equiv R (tensor_product R A B) C)
    (w₁ :
      ∀ (a₁ a₂ : A) (b₁ b₂ : B),
        coe_fn f (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) =
          coe_fn f (tensor_product.tmul R a₁ b₁) * coe_fn f (tensor_product.tmul R a₂ b₂))
    (w₂ :
      ∀ (r : R),
        coe_fn f (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) =
          coe_fn (algebra_map R C) r) :
    alg_equiv R (tensor_product R A B) C :=
  alg_equiv.mk (alg_hom.to_fun (alg_hom_of_linear_map_tensor_product (↑f) w₁ w₂))
    (linear_equiv.inv_fun f) sorry sorry sorry sorry sorry

@[simp] theorem alg_equiv_of_linear_equiv_tensor_product_apply {R : Type u} [comm_semiring R]
    {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃}
    [semiring C] [algebra R C] (f : linear_equiv R (tensor_product R A B) C)
    (w₁ :
      ∀ (a₁ a₂ : A) (b₁ b₂ : B),
        coe_fn f (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) =
          coe_fn f (tensor_product.tmul R a₁ b₁) * coe_fn f (tensor_product.tmul R a₂ b₂))
    (w₂ :
      ∀ (r : R),
        coe_fn f (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) =
          coe_fn (algebra_map R C) r)
    (x : tensor_product R A B) :
    coe_fn (alg_equiv_of_linear_equiv_tensor_product f w₁ w₂) x = coe_fn f x :=
  rfl

/--
Build an algebra equivalence from a linear equivalence out of a triple tensor product,
and evidence of multiplicativity on pure tensors.
-/
def alg_equiv_of_linear_equiv_triple_tensor_product {R : Type u} [comm_semiring R] {A : Type v₁}
    [semiring A] [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C]
    [algebra R C] {D : Type v₄} [semiring D] [algebra R D]
    (f : linear_equiv R (tensor_product R (tensor_product R A B) C) D)
    (w₁ :
      ∀ (a₁ a₂ : A) (b₁ b₂ : B) (c₁ c₂ : C),
        coe_fn f (tensor_product.tmul R (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) (c₁ * c₂)) =
          coe_fn f (tensor_product.tmul R (tensor_product.tmul R a₁ b₁) c₁) *
            coe_fn f (tensor_product.tmul R (tensor_product.tmul R a₂ b₂) c₂))
    (w₂ :
      ∀ (r : R),
        coe_fn f (tensor_product.tmul R (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) 1) =
          coe_fn (algebra_map R D) r) :
    alg_equiv R (tensor_product R (tensor_product R A B) C) D :=
  alg_equiv.mk (⇑f) (linear_equiv.inv_fun f) sorry sorry sorry sorry sorry

@[simp] theorem alg_equiv_of_linear_equiv_triple_tensor_product_apply {R : Type u} [comm_semiring R]
    {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃}
    [semiring C] [algebra R C] {D : Type v₄} [semiring D] [algebra R D]
    (f : linear_equiv R (tensor_product R (tensor_product R A B) C) D)
    (w₁ :
      ∀ (a₁ a₂ : A) (b₁ b₂ : B) (c₁ c₂ : C),
        coe_fn f (tensor_product.tmul R (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) (c₁ * c₂)) =
          coe_fn f (tensor_product.tmul R (tensor_product.tmul R a₁ b₁) c₁) *
            coe_fn f (tensor_product.tmul R (tensor_product.tmul R a₂ b₂) c₂))
    (w₂ :
      ∀ (r : R),
        coe_fn f (tensor_product.tmul R (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) 1) =
          coe_fn (algebra_map R D) r)
    (x : tensor_product R (tensor_product R A B) C) :
    coe_fn (alg_equiv_of_linear_equiv_triple_tensor_product f w₁ w₂) x = coe_fn f x :=
  rfl

/--
The base ring is a left identity for the tensor product of algebra, up to algebra isomorphism.
-/
protected def lid (R : Type u) [comm_semiring R] (A : Type v₁) [semiring A] [algebra R A] :
    alg_equiv R (tensor_product R R A) A :=
  alg_equiv_of_linear_equiv_tensor_product (tensor_product.lid R A) sorry sorry

@[simp] theorem lid_tmul (R : Type u) [comm_semiring R] (A : Type v₁) [semiring A] [algebra R A]
    (r : R) (a : A) : coe_fn (tensor_product.lid R A) (tensor_product.tmul R r a) = r • a :=
  sorry

/--
The base ring is a right identity for the tensor product of algebra, up to algebra isomorphism.
-/
protected def rid (R : Type u) [comm_semiring R] (A : Type v₁) [semiring A] [algebra R A] :
    alg_equiv R (tensor_product R A R) A :=
  alg_equiv_of_linear_equiv_tensor_product (tensor_product.rid R A) sorry sorry

@[simp] theorem rid_tmul (R : Type u) [comm_semiring R] (A : Type v₁) [semiring A] [algebra R A]
    (r : R) (a : A) : coe_fn (tensor_product.rid R A) (tensor_product.tmul R a r) = r • a :=
  sorry

/--
The tensor product of R-algebras is commutative, up to algebra isomorphism.
-/
protected def comm (R : Type u) [comm_semiring R] (A : Type v₁) [semiring A] [algebra R A]
    (B : Type v₂) [semiring B] [algebra R B] :
    alg_equiv R (tensor_product R A B) (tensor_product R B A) :=
  alg_equiv_of_linear_equiv_tensor_product (tensor_product.comm R A B) sorry sorry

@[simp] theorem comm_tmul (R : Type u) [comm_semiring R] (A : Type v₁) [semiring A] [algebra R A]
    (B : Type v₂) [semiring B] [algebra R B] (a : A) (b : B) :
    coe_fn (tensor_product.comm R A B) (tensor_product.tmul R a b) = tensor_product.tmul R b a :=
  sorry

theorem assoc_aux_1 {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C] (a₁ : A)
    (a₂ : A) (b₁ : B) (b₂ : B) (c₁ : C) (c₂ : C) :
    coe_fn (tensor_product.assoc R A B C)
          (tensor_product.tmul R (tensor_product.tmul R (a₁ * a₂) (b₁ * b₂)) (c₁ * c₂)) =
        coe_fn (tensor_product.assoc R A B C)
            (tensor_product.tmul R (tensor_product.tmul R a₁ b₁) c₁) *
          coe_fn (tensor_product.assoc R A B C)
            (tensor_product.tmul R (tensor_product.tmul R a₂ b₂) c₂) :=
  rfl

theorem assoc_aux_2 {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C] (r : R) :
    coe_fn (tensor_product.assoc R A B C)
          (tensor_product.tmul R (tensor_product.tmul R (coe_fn (algebra_map R A) r) 1) 1) =
        coe_fn (algebra_map R (tensor_product R A (tensor_product R B C))) r :=
  rfl

-- variables (R A B C)

-- -- local attribute [elab_simple] alg_equiv_of_linear_equiv_triple_tensor_product

-- /-- The associator for tensor product of R-algebras, as an algebra isomorphism. -/

-- -- FIXME This is _really_ slow to compile. :-(

-- protected def assoc : ((A ⊗[R] B) ⊗[R] C) ≃ₐ[R] (A ⊗[R] (B ⊗[R] C)) :=

-- alg_equiv_of_linear_equiv_triple_tensor_product

--   (tensor_product.assoc R A B C)

--   assoc_aux_1 assoc_aux_2

-- variables {R A B C}

-- @[simp] theorem assoc_tmul (a : A) (b : B) (c : C) :

--   ((tensor_product.assoc R A B C) : (A ⊗[R] B) ⊗[R] C → A ⊗[R] (B ⊗[R] C)) ((a ⊗ₜ b) ⊗ₜ c) = a ⊗ₜ (b ⊗ₜ c) :=

-- rfl

/-- The tensor product of a pair of algebra morphisms. -/
def map {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂}
    [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C] {D : Type v₄} [semiring D]
    [algebra R D] (f : alg_hom R A B) (g : alg_hom R C D) :
    alg_hom R (tensor_product R A C) (tensor_product R B D) :=
  alg_hom_of_linear_map_tensor_product
    (tensor_product.map (alg_hom.to_linear_map f) (alg_hom.to_linear_map g)) sorry sorry

@[simp] theorem map_tmul {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C] {D : Type v₄}
    [semiring D] [algebra R D] (f : alg_hom R A B) (g : alg_hom R C D) (a : A) (c : C) :
    coe_fn (map f g) (tensor_product.tmul R a c) =
        tensor_product.tmul R (coe_fn f a) (coe_fn g c) :=
  rfl

/--
Construct an isomorphism between tensor products of R-algebras
from isomorphisms between the tensor factors.
-/
def congr {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A] {B : Type v₂}
    [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C] {D : Type v₄} [semiring D]
    [algebra R D] (f : alg_equiv R A B) (g : alg_equiv R C D) :
    alg_equiv R (tensor_product R A C) (tensor_product R B D) :=
  alg_equiv.of_alg_hom (map ↑f ↑g) (map ↑(alg_equiv.symm f) ↑(alg_equiv.symm g)) sorry sorry

@[simp] theorem congr_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A] [algebra R A]
    {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C] {D : Type v₄}
    [semiring D] [algebra R D] (f : alg_equiv R A B) (g : alg_equiv R C D)
    (x : tensor_product R A C) : coe_fn (congr f g) x = coe_fn (map ↑f ↑g) x :=
  rfl

@[simp] theorem congr_symm_apply {R : Type u} [comm_semiring R] {A : Type v₁} [semiring A]
    [algebra R A] {B : Type v₂} [semiring B] [algebra R B] {C : Type v₃} [semiring C] [algebra R C]
    {D : Type v₄} [semiring D] [algebra R D] (f : alg_equiv R A B) (g : alg_equiv R C D)
    (x : tensor_product R B D) :
    coe_fn (alg_equiv.symm (congr f g)) x =
        coe_fn (map ↑(alg_equiv.symm f) ↑(alg_equiv.symm g)) x :=
  rfl

end Mathlib