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

import ring_theory.polynomial.cyclotomic.basic
import number_theory.number_field
import algebra.char_p.algebra
import field_theory.galois

/-!
# Cyclotomic extensions

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

## Main definitions

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

## Main results

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

## Implementation details

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

-/

open polynomial algebra finite_dimensional module set

open_locale big_operators

universes u v w z

variables (n : ℕ+) (S T : set ℕ+) (A : Type u) (B : Type v) (K : Type w) (L : Type z)
variables [comm_ring A] [comm_ring B] [algebra A B]
variables [field K] [field L] [algebra K L]

noncomputable theory

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

namespace is_cyclotomic_extension

section basic

/-- A reformulation of `is_cyclotomic_extension` that uses `⊤`. -/
lemma iff_adjoin_eq_top : is_cyclotomic_extension S A B ↔
 (∀ (a : ℕ+), a ∈ S → ∃ r : B, is_primitive_root r a) ∧
 (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 } = ⊤) :=
⟨λ h, ⟨h.exists_prim_root, algebra.eq_top_iff.2 h.adjoin_roots⟩,
  λ h, ⟨h.1, algebra.eq_top_iff.1 h.2⟩⟩

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

/-- If `is_cyclotomic_extension ∅ A B`, then the image of `A` in `B` equals `B`. -/
lemma empty [h : is_cyclotomic_extension ∅ A B] : (⊥ : subalgebra A B) = ⊤ :=
by simpa [algebra.eq_top_iff, is_cyclotomic_extension_iff] using h

/-- If `is_cyclotomic_extension {1} A B`, then the image of `A` in `B` equals `B`. -/
lemma singleton_one [h : is_cyclotomic_extension {1} A B] : (⊥ : subalgebra A B) = ⊤ :=
algebra.eq_top_iff.2 (λ x, by simpa [adjoin_singleton_one]
  using ((is_cyclotomic_extension_iff _ _ _).1 h).2 x)

/-- Transitivity of cyclotomic extensions. -/
lemma trans (C : Type w) [comm_ring C] [nontrivial C] [algebra A C] [algebra B C]
  [is_scalar_tower A B C] [hS : is_cyclotomic_extension S A B]
  [hT : is_cyclotomic_extension T B C] [no_zero_smul_divisors B C] :
  is_cyclotomic_extension (S ∪ T) A C :=
begin
  refine ⟨λ n hn, _, λ x, _⟩,
  { cases hn,
    { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 hS).1 hn,
      refine ⟨algebra_map B C b, _⟩,
      exact hb.map_of_injective (no_zero_smul_divisors.algebra_map_injective B C) },
    { exact ((is_cyclotomic_extension_iff _ _ _).1 hT).1 hn } },
  { refine adjoin_induction (((is_cyclotomic_extension_iff _ _ _).1 hT).2 x) (λ c ⟨n, hn⟩,
      subset_adjoin ⟨n, or.inr hn.1, hn.2⟩) (λ b, _) (λ x y hx hy, subalgebra.add_mem _ hx hy)
      (λ x y hx hy, subalgebra.mul_mem _ hx hy),
    { let f := is_scalar_tower.to_alg_hom A B C,
      have hb : f b ∈ (adjoin A { b : B | ∃ (a : ℕ+), a ∈ S ∧ b ^ (a : ℕ) = 1 }).map f :=
        ⟨b, ((is_cyclotomic_extension_iff _ _ _).1 hS).2 b, rfl⟩,
      rw [is_scalar_tower.to_alg_hom_apply, ← adjoin_image] at hb,
      refine adjoin_mono (λ y hy, _) hb,
      obtain ⟨b₁, ⟨⟨n, hn⟩, h₁⟩⟩ := hy,
      exact ⟨n, ⟨mem_union_left T hn.1, by rw [← h₁, ← alg_hom.map_pow, hn.2, alg_hom.map_one]⟩⟩ } }
end

@[nontriviality] lemma subsingleton_iff [subsingleton B] :
  is_cyclotomic_extension S A B ↔ S = {} ∨ S = {1} :=
begin
  split,
  { rintro ⟨hprim, -⟩,
    rw ←subset_singleton_iff_eq,
    intros t ht,
    obtain ⟨ζ, hζ⟩ := hprim ht,
    rw [mem_singleton_iff, ←pnat.coe_eq_one_iff],
    exact_mod_cast hζ.unique (is_primitive_root.of_subsingleton ζ) },
  { rintro (rfl|rfl),
    { refine ⟨λ _ h, h.elim, λ x, by convert subalgebra.zero_mem _⟩ },
    { rw iff_singleton,
      refine ⟨⟨0, is_primitive_root.of_subsingleton 0⟩, λ x, by convert subalgebra.zero_mem _⟩ } }
end

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `S ∪ T`, then `B`
is a cyclotomic extension of `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 } ` given by
roots of unity of order in `T`. -/
lemma union_right [h : is_cyclotomic_extension (S ∪ T) A B] :
  is_cyclotomic_extension T (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) B :=
begin
  have : { b : B | ∃ (n : ℕ+), n ∈ S ∪ T ∧ b ^ (n : ℕ) = 1 } =
    { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 } ∪
    { b : B | ∃ (n : ℕ+), n ∈ T ∧ b ^ (n : ℕ) = 1 },
  { refine le_antisymm (λ x hx, _) (λ x hx, _),
    { rcases hx with ⟨n, hn₁ | hn₂, hnpow⟩,
      { left, exact ⟨n, hn₁, hnpow⟩ },
      { right, exact ⟨n, hn₂, hnpow⟩ } },
    { rcases hx with ⟨n, hn⟩ | ⟨n, hn⟩,
      { exact ⟨n, or.inl hn.1, hn.2⟩ },
      { exact ⟨n, or.inr hn.1, hn.2⟩ } } },

  refine ⟨λ n hn, ((is_cyclotomic_extension_iff _ _ _).1 h).1 (mem_union_right S hn), λ b, _⟩,
  replace h := ((is_cyclotomic_extension_iff _ _ _).1 h).2 b,
  rwa [this, adjoin_union_eq_adjoin_adjoin, subalgebra.mem_restrict_scalars] at h
end

/-- If `B` is a cyclotomic extension of `A` given by roots of unity of order in `T` and `S ⊆ T`,
then `adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }` is a cyclotomic extension of `B`
given by roots of unity of order in `S`. -/
lemma union_left [h : is_cyclotomic_extension T A B] (hS : S ⊆ T) :
  is_cyclotomic_extension S A (adjoin A { b : B | ∃ a : ℕ+, a ∈ S ∧ b ^ (a : ℕ) = 1 }) :=
begin
  refine ⟨λ n hn, _, λ b, _⟩,
  { obtain ⟨b, hb⟩ := ((is_cyclotomic_extension_iff _ _ _).1 h).1 (hS hn),
    refine ⟨⟨b, subset_adjoin ⟨n, hn, hb.pow_eq_one⟩⟩, _⟩,
    rwa [← is_primitive_root.coe_submonoid_class_iff, subtype.coe_mk] },
  { convert mem_top,
    rw [← adjoin_adjoin_coe_preimage, preimage_set_of_eq],
    norm_cast }
end

@[protected]
lemma ne_zero [h : is_cyclotomic_extension {n} A B] [is_domain B] : ne_zero ((n : ℕ) : B) :=
begin
  obtain ⟨⟨r, hr⟩, -⟩ := (iff_singleton n A B).1 h,
  exact hr.ne_zero'
end

@[protected]
lemma ne_zero' [is_cyclotomic_extension {n} A B] [is_domain B] : ne_zero ((n : ℕ) : A) :=
begin
  apply ne_zero.nat_of_ne_zero (algebra_map A B),
  exact ne_zero n A B,
end

end basic

section fintype

lemma finite_of_singleton [is_domain B] [h : is_cyclotomic_extension {n} A B] : finite A B :=
begin
  classical,
  rw [module.finite_def, ← top_to_submodule, ← ((iff_adjoin_eq_top _ _ _).1 h).2],
  refine fg_adjoin_of_finite _ (λ b hb, _),
  { simp only [mem_singleton_iff, exists_eq_left],
    have : {b : B | b ^ (n : ℕ) = 1} = (nth_roots n (1 : B)).to_finset :=
      set.ext (λ x, ⟨λ h, by simpa using h, λ h, by simpa using h⟩),
    rw [this],
    exact (nth_roots ↑n 1).to_finset.finite_to_set },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hb,
    refine ⟨X ^ (n : ℕ) - 1, ⟨monic_X_pow_sub_C _ n.pos.ne.symm, by simp [hb]⟩⟩ }
end

/-- If `S` is finite and `is_cyclotomic_extension S A B`, then `B` is a finite `A`-algebra. -/
lemma finite [is_domain B] [h₁ : fintype S] [h₂ : is_cyclotomic_extension S A B] : finite A B :=
begin
  unfreezingI {revert h₂ A B},
  refine set.finite.induction_on (set.finite.intro h₁) (λ A B, _) (λ n S hn hS H A B, _),
  { introsI _ _ _ _ _,
    refine module.finite_def.2 ⟨({1} : finset B), _⟩,
    simp [← top_to_submodule, ← empty, to_submodule_bot] },
  { introsI _ _ _ _ h,
    haveI : is_cyclotomic_extension S A (adjoin A { b : B | ∃ (n : ℕ+),
      n ∈ S ∧ b ^ (n : ℕ) = 1 }) := union_left _ (insert n S) _ _ (subset_insert n S),
    haveI := H A (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }),
    haveI : finite (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }) B,
    { rw [← union_singleton] at h,
      letI := @union_right S {n} A B _ _ _ h,
      exact finite_of_singleton n _ _ },
    exact finite.trans (adjoin A { b : B | ∃ (n : ℕ+), n ∈ S ∧ b ^ (n : ℕ) = 1 }) _ }
end

/-- A cyclotomic finite extension of a number field is a number field. -/
lemma number_field [h : number_field K] [fintype S] [is_cyclotomic_extension S K L] :
  number_field L :=
{ to_char_zero := char_zero_of_injective_algebra_map (algebra_map K L).injective,
  to_finite_dimensional := @finite.trans _ K L _ _ _ _
    (@algebra_rat L _ (char_zero_of_injective_algebra_map (algebra_map K L).injective)) _ _
    h.to_finite_dimensional (finite S K L) }

localized "attribute [instance] is_cyclotomic_extension.number_field" in cyclotomic

/-- A finite cyclotomic extension of an integral noetherian domain is integral -/
lemma integral [is_domain B] [is_noetherian_ring A] [fintype S] [is_cyclotomic_extension S A B] :
  algebra.is_integral A B :=
is_integral_of_noetherian $ is_noetherian_of_fg_of_noetherian' $ (finite S A B).out

/-- If `S` is finite and `is_cyclotomic_extension S K A`, then `finite_dimensional K A`. -/
lemma finite_dimensional (C : Type z) [fintype S] [comm_ring C] [algebra K C] [is_domain C]
  [is_cyclotomic_extension S K C] : finite_dimensional K C :=
finite S K C

localized "attribute [instance] is_cyclotomic_extension.finite_dimensional" in cyclotomic

end fintype

section

variables {A B}

lemma adjoin_roots_cyclotomic_eq_adjoin_nth_roots [decidable_eq B] [is_domain B] {ζ : B}
  {n : ℕ+} (hζ : is_primitive_root ζ n) :
  adjoin A ↑((map (algebra_map A B) (cyclotomic n A)).roots.to_finset) =
  adjoin A {b : B | ∃ (a : ℕ+), a ∈ ({n} : set ℕ+) ∧ b ^ (a : ℕ) = 1} :=
begin
  simp only [mem_singleton_iff, exists_eq_left, map_cyclotomic],
  refine le_antisymm (adjoin_mono (λ x hx, _)) (adjoin_le (λ x hx, _)),
  { simp only [multiset.mem_to_finset, finset.mem_coe,
               map_cyclotomic, mem_roots (cyclotomic_ne_zero n B)] at hx,
    simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq],
    rw is_root_of_unity_iff n.pos,
    exact ⟨n, nat.mem_divisors_self n n.ne_zero, hx⟩ },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx,
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos,
    refine set_like.mem_coe.2 (subalgebra.pow_mem _ (subset_adjoin _) _),
    rwa [finset.mem_coe, multiset.mem_to_finset, mem_roots $ cyclotomic_ne_zero n B],
    exact hζ.is_root_cyclotomic n.pos }
end

lemma adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic {n : ℕ+} [decidable_eq B] [is_domain B]
  {ζ : B} (hζ : is_primitive_root ζ n) :
  adjoin A (((map (algebra_map A B) (cyclotomic n A)).roots.to_finset) : set B) = adjoin A ({ζ}) :=
begin
  refine le_antisymm (adjoin_le (λ x hx, _)) (adjoin_mono (λ x hx, _)),
  { suffices hx : x ^ ↑n = 1,
    obtain ⟨i, hin, rfl⟩ := hζ.eq_pow_of_pow_eq_one hx n.pos,
    exact set_like.mem_coe.2 (subalgebra.pow_mem _ (subset_adjoin $ mem_singleton ζ) _),
    rw is_root_of_unity_iff n.pos,
    refine ⟨n, nat.mem_divisors_self n n.ne_zero, _⟩,
    rwa [finset.mem_coe, multiset.mem_to_finset,
         map_cyclotomic, mem_roots $ cyclotomic_ne_zero n B] at hx },
  { simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq] at hx,
    simpa only [hx, multiset.mem_to_finset, finset.mem_coe, map_cyclotomic,
                mem_roots (cyclotomic_ne_zero n B)] using hζ.is_root_cyclotomic n.pos }
end

lemma adjoin_primitive_root_eq_top {n : ℕ+} [is_domain B] [h : is_cyclotomic_extension {n} A B]
  {ζ : B} (hζ : is_primitive_root ζ n) : adjoin A ({ζ} : set B) = ⊤ :=
begin
  classical,
  rw ←adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic hζ,
  rw adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ,
  exact ((iff_adjoin_eq_top {n} A B).mp h).2,
end

variable (A)

lemma _root_.is_primitive_root.adjoin_is_cyclotomic_extension {ζ : B} {n : ℕ+}
  (h : is_primitive_root ζ n) : is_cyclotomic_extension {n} A (adjoin A ({ζ} : set B)) :=
{ exists_prim_root := λ i hi,
  begin
    rw [set.mem_singleton_iff] at hi,
    refine ⟨⟨ζ, subset_adjoin $ set.mem_singleton ζ⟩, _⟩,
    rwa [← is_primitive_root.coe_submonoid_class_iff, subtype.coe_mk, hi],
  end,
  adjoin_roots := λ x,
  begin
    refine adjoin_induction' (λ b hb, _) (λ a, _) (λ b₁ b₂ hb₁ hb₂, _) (λ b₁ b₂ hb₁ hb₂, _) x,
    { rw [set.mem_singleton_iff] at hb,
      refine subset_adjoin _,
      simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq, hb],
      rw [← subalgebra.coe_eq_one, subalgebra.coe_pow, set_like.coe_mk],
      exact ((is_primitive_root.iff_def ζ n).1 h).1 },
    { exact subalgebra.algebra_map_mem _ _ },
    { exact subalgebra.add_mem _ hb₁ hb₂ },
    { exact subalgebra.mul_mem _ hb₁ hb₂ }
  end }

end

section field

variables {n S}

/-- A cyclotomic extension splits `X ^ n - 1` if `n ∈ S`.-/
lemma splits_X_pow_sub_one [H : is_cyclotomic_extension S K L] (hS : n ∈ S) :
  splits (algebra_map K L) (X ^ (n : ℕ) - 1) :=
begin
  rw [← splits_id_iff_splits, polynomial.map_sub, polynomial.map_one,
      polynomial.map_pow, polynomial.map_X],
  obtain ⟨z, hz⟩ := ((is_cyclotomic_extension_iff _ _ _).1 H).1 hS,
  exact X_pow_sub_one_splits hz,
end

/-- A cyclotomic extension splits `cyclotomic n K` if `n ∈ S` and `ne_zero (n : K)`.-/
lemma splits_cyclotomic [is_cyclotomic_extension S K L] (hS : n ∈ S) :
  splits (algebra_map K L) (cyclotomic n K) :=
begin
  refine splits_of_splits_of_dvd _ (X_pow_sub_C_ne_zero n.pos _)
    (splits_X_pow_sub_one K L hS) _,
  use (∏ (i : ℕ) in (n : ℕ).proper_divisors, polynomial.cyclotomic i K),
  rw [(eq_cyclotomic_iff n.pos _).1 rfl, ring_hom.map_one],
end

variables (n S)

section singleton

variables [is_cyclotomic_extension {n} K L]

/-- If `is_cyclotomic_extension {n} K L`, then `L` is the splitting field of `X ^ n - 1`. -/
lemma splitting_field_X_pow_sub_one : is_splitting_field K L (X ^ (n : ℕ) - 1) :=
{ splits := splits_X_pow_sub_one K L (mem_singleton n),
  adjoin_roots :=
  begin
    rw [← ((iff_adjoin_eq_top {n} K L).1 infer_instance).2],
    congr,
    refine set.ext (λ x, _),
    simp only [polynomial.map_pow, mem_singleton_iff, multiset.mem_to_finset, exists_eq_left,
      mem_set_of_eq, polynomial.map_X, polynomial.map_one, finset.mem_coe, polynomial.map_sub],
    rwa [← ring_hom.map_one C, mem_roots (@X_pow_sub_C_ne_zero L _ _ _ n.pos _), is_root.def,
      eval_sub, eval_pow, eval_C, eval_X, sub_eq_zero]
  end }

localized "attribute [instance] is_cyclotomic_extension.splitting_field_X_pow_sub_one" in cyclotomic

include n

lemma is_galois : is_galois K L :=
begin
  letI := splitting_field_X_pow_sub_one n K L,
  exact is_galois.of_separable_splitting_field (X_pow_sub_one_separable_iff.2 ((ne_zero' n K L).1))
end

localized "attribute [instance] is_cyclotomic_extension.is_galois" in cyclotomic

/-- If `is_cyclotomic_extension {n} K L`, then `L` is the splitting field of `cyclotomic n K`. -/
lemma splitting_field_cyclotomic : is_splitting_field K L (cyclotomic n K) :=
{ splits := splits_cyclotomic K L (mem_singleton n),
  adjoin_roots :=
  begin
    rw [← ((iff_adjoin_eq_top {n} K L).1 infer_instance).2],
    letI := classical.dec_eq L,
    obtain ⟨ζ, hζ⟩ := @is_cyclotomic_extension.exists_prim_root {n} K L _ _ _ _ _ (mem_singleton n),
    exact adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ
  end }

localized "attribute [instance] is_cyclotomic_extension.splitting_field_cyclotomic" in cyclotomic

end singleton

end field

end is_cyclotomic_extension

section cyclotomic_field

/-- Given `n : ℕ+` and a field `K`, we define `cyclotomic_field n K` as the
splitting field of `cyclotomic n K`. If `n` is nonzero in `K`, it has
the instance `is_cyclotomic_extension {n} K (cyclotomic_field n K)`. -/
@[derive [field, algebra K, inhabited]]
def cyclotomic_field : Type w := (cyclotomic n K).splitting_field

namespace cyclotomic_field

instance [char_zero K] : char_zero (cyclotomic_field n K) :=
char_zero_of_injective_algebra_map ((algebra_map K _).injective)

instance is_cyclotomic_extension [ne_zero ((n : ℕ) : K)] :
  is_cyclotomic_extension {n} K (cyclotomic_field n K) :=
{ exists_prim_root := λ a han,
  begin
    rw mem_singleton_iff at han,
    subst a,
    obtain ⟨r, hr⟩ := exists_root_of_splits (algebra_map K (cyclotomic_field n K))
      (splitting_field.splits _) (degree_cyclotomic_pos n K (n.pos)).ne',
    refine ⟨r, _⟩,
    haveI := ne_zero.of_no_zero_smul_divisors K (cyclotomic_field n K) n,
    rwa [← eval_map, ← is_root.def, map_cyclotomic, is_root_cyclotomic_iff] at hr
  end,
  adjoin_roots :=
  begin
    rw [←algebra.eq_top_iff, ←splitting_field.adjoin_roots, eq_comm],
    letI := classical.dec_eq (cyclotomic_field n K),
    obtain ⟨ζ, hζ⟩ := exists_root_of_splits _ (splitting_field.splits (cyclotomic n K))
      (degree_cyclotomic_pos n _ n.pos).ne',
    haveI : ne_zero ((n : ℕ) : (cyclotomic_field n K)) :=
      ne_zero.nat_of_injective (algebra_map K _).injective,
    rw [eval₂_eq_eval_map, map_cyclotomic, ← is_root.def, is_root_cyclotomic_iff] at hζ,
    exact is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots hζ,
  end }

end cyclotomic_field

end cyclotomic_field

section is_domain

variables [is_domain A] [algebra A K] [is_fraction_ring A K]

section cyclotomic_ring

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

local attribute [instance] cyclotomic_field.algebra_base

instance cyclotomic_field.no_zero_smul_divisors : no_zero_smul_divisors A (cyclotomic_field n K) :=
no_zero_smul_divisors.of_algebra_map_injective $ function.injective.comp
(no_zero_smul_divisors.algebra_map_injective _ _) $ is_fraction_ring.injective A K

/-- If `A` is a domain with fraction field `K` and `n : ℕ+`, we define `cyclotomic_ring n A K` as
the `A`-subalgebra of `cyclotomic_field n K` generated by the roots of `X ^ n - 1`. If `n`
is nonzero in `A`, it has the instance `is_cyclotomic_extension {n} A (cyclotomic_ring n A K)`. -/
@[derive [comm_ring, is_domain, inhabited]]
def cyclotomic_ring : Type w := adjoin A { b : (cyclotomic_field n K) | b ^ (n : ℕ) = 1 }

namespace cyclotomic_ring

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

local attribute [instance] cyclotomic_ring.algebra_base

instance : no_zero_smul_divisors A (cyclotomic_ring n A K) := (adjoin A _).no_zero_smul_divisors_bot

lemma algebra_base_injective : function.injective $ algebra_map A (cyclotomic_ring n A K) :=
no_zero_smul_divisors.algebra_map_injective _ _

instance : algebra (cyclotomic_ring n A K) (cyclotomic_field n K) :=
(adjoin A _).to_algebra

lemma adjoin_algebra_injective :
  function.injective $ algebra_map (cyclotomic_ring n A K) (cyclotomic_field n K) :=
subtype.val_injective

instance : no_zero_smul_divisors (cyclotomic_ring n A K) (cyclotomic_field n K) :=
no_zero_smul_divisors.of_algebra_map_injective (adjoin_algebra_injective n A K)

instance : is_scalar_tower A (cyclotomic_ring n A K) (cyclotomic_field n K) :=
is_scalar_tower.subalgebra' _ _ _ _

instance is_cyclotomic_extension [ne_zero ((n : ℕ) : A)] :
  is_cyclotomic_extension {n} A (cyclotomic_ring n A K) :=
{ exists_prim_root := λ a han,
  begin
    rw mem_singleton_iff at han,
    subst a,
    haveI := ne_zero.of_no_zero_smul_divisors A K n,
    haveI := ne_zero.of_no_zero_smul_divisors A (cyclotomic_field n K) n,
    obtain ⟨μ, hμ⟩ := let h := (cyclotomic_field.is_cyclotomic_extension n K).exists_prim_root
                      in h $ mem_singleton n,
    refine ⟨⟨μ, subset_adjoin _⟩, _⟩,
    { apply (is_root_of_unity_iff n.pos (cyclotomic_field n K)).mpr,
      refine ⟨n, nat.mem_divisors_self _ n.ne_zero, _⟩,
      rwa [← is_root_cyclotomic_iff] at hμ },
    { rwa [← is_primitive_root.coe_submonoid_class_iff, subtype.coe_mk] }
  end,
  adjoin_roots := λ x,
  begin
    refine adjoin_induction' (λ y hy, _) (λ a, _) (λ y z hy hz, _) (λ y z hy hz, _) x,
    { refine subset_adjoin _,
      simp only [mem_singleton_iff, exists_eq_left, mem_set_of_eq],
      rwa [← subalgebra.coe_eq_one, subalgebra.coe_pow, subtype.coe_mk] },
    { exact subalgebra.algebra_map_mem _ a },
    { exact subalgebra.add_mem _ hy hz },
    { exact subalgebra.mul_mem _ hy hz },
  end }

instance [ne_zero ((n : ℕ) : A)] :
  is_fraction_ring (cyclotomic_ring n A K) (cyclotomic_field n K) :=
{ map_units := λ ⟨x, hx⟩, begin
    rw is_unit_iff_ne_zero,
    apply map_ne_zero_of_mem_non_zero_divisors,
    apply adjoin_algebra_injective,
    exact hx
  end,
  surj := λ x,
  begin
    letI : ne_zero ((n : ℕ) : K) := ne_zero.nat_of_injective (is_fraction_ring.injective A K),
    refine algebra.adjoin_induction (((is_cyclotomic_extension.iff_singleton n K _).1
      (cyclotomic_field.is_cyclotomic_extension n K)).2 x) (λ y hy, _) (λ k, _) _ _,
    { exact ⟨⟨⟨y, subset_adjoin hy⟩, 1⟩, by simpa⟩ },
    { have : is_localization (non_zero_divisors A) K := infer_instance,
      replace := this.surj,
      obtain ⟨⟨z, w⟩, hw⟩ := this k,
      refine ⟨⟨algebra_map A _ z, algebra_map A _ w, map_mem_non_zero_divisors _
        (algebra_base_injective n A K) w.2⟩, _⟩,
      letI : is_scalar_tower A K (cyclotomic_field n K) :=
        is_scalar_tower.of_algebra_map_eq (congr_fun rfl),
      rw [set_like.coe_mk, ← is_scalar_tower.algebra_map_apply,
        ← is_scalar_tower.algebra_map_apply, @is_scalar_tower.algebra_map_apply A K _ _ _ _ _
        (_root_.cyclotomic_field.algebra n K) _ _ w, ← ring_hom.map_mul, hw,
        ← is_scalar_tower.algebra_map_apply] },
    { rintro y z ⟨a, ha⟩ ⟨b, hb⟩,
      refine ⟨⟨a.1 * b.2 + b.1 * a.2, a.2 * b.2, mul_mem_non_zero_divisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩,
      rw [set_like.coe_mk, ring_hom.map_mul, add_mul, ← mul_assoc, ha,
        mul_comm ((algebra_map _ _) ↑a.2), ← mul_assoc, hb],
      simp },
    { rintro y z ⟨a, ha⟩ ⟨b, hb⟩,
      refine ⟨⟨a.1 * b.1, a.2 * b.2, mul_mem_non_zero_divisors.2 ⟨a.2.2, b.2.2⟩⟩, _⟩,
      rw [set_like.coe_mk, ring_hom.map_mul, mul_comm ((algebra_map _ _) ↑a.2), mul_assoc,
        ← mul_assoc z, hb, ← mul_comm ((algebra_map _ _) ↑a.2), ← mul_assoc, ha],
      simp }
  end,
  eq_iff_exists := λ x y, ⟨λ h, ⟨1, by rw adjoin_algebra_injective n A K h⟩,
    λ ⟨c, hc⟩, by rw mul_right_cancel₀ (non_zero_divisors.ne_zero c.prop) hc⟩ }

lemma eq_adjoin_primitive_root {μ : (cyclotomic_field n K)} (h : is_primitive_root μ n) :
  cyclotomic_ring n A K = adjoin A ({μ} : set ((cyclotomic_field n K))) :=
begin
  letI := classical.prop_decidable,
  rw [←is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_root_cyclotomic h,
      is_cyclotomic_extension.adjoin_roots_cyclotomic_eq_adjoin_nth_roots h],
  simp [cyclotomic_ring]
end

end cyclotomic_ring

end cyclotomic_ring

end is_domain

section is_alg_closed

variables [is_alg_closed K]

/-- Algebraically closed fields are `S`-cyclotomic extensions over themselves if
`ne_zero ((a : ℕ) : K))` for all `a ∈ S`. -/
lemma is_alg_closed.is_cyclotomic_extension (h : ∀ a ∈ S, ne_zero ((a : ℕ) : K)) :
  is_cyclotomic_extension S K K :=
begin
  refine ⟨λ a ha, _,  algebra.eq_top_iff.mp $ subsingleton.elim _ _ ⟩,
  obtain ⟨r, hr⟩ := is_alg_closed.exists_aeval_eq_zero K _ (degree_cyclotomic_pos a K a.pos).ne',
  refine ⟨r, _⟩,
  haveI := h a ha,
  rwa [coe_aeval_eq_eval, ← is_root.def, is_root_cyclotomic_iff] at hr,
end

instance is_alg_closed_of_char_zero.is_cyclotomic_extension [char_zero K] :
  ∀ S, is_cyclotomic_extension S K K :=
λ S, is_alg_closed.is_cyclotomic_extension S K (λ a ha, infer_instance)

end is_alg_closed


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro, Yury Kudryashov
-/
import topology.algebra.order.basic
import topology.extend_from

/-!
# Lemmas about `extend_from` in an order topology.
-/

open filter set topological_space
open_locale topological_space classical

universes u v
variables {α : Type u} {β : Type v}

lemma continuous_on_Icc_extend_from_Ioo [topological_space α] [linear_order α] [densely_ordered α]
  [order_topology α] [topological_space β] [regular_space β] {f : α → β} {a b : α}
  {la lb : β} (hab : a ≠ b) (hf : continuous_on f (Ioo a b))
  (ha : tendsto f (𝓝[>] a) (𝓝 la)) (hb : tendsto f (𝓝[<] b) (𝓝 lb)) :
  continuous_on (extend_from (Ioo a b) f) (Icc a b) :=
begin
  apply continuous_on_extend_from,
  { rw closure_Ioo hab },
  { intros x x_in,
    rcases eq_endpoints_or_mem_Ioo_of_mem_Icc x_in with rfl | rfl | h,
    { exact ⟨la, ha.mono_left $ nhds_within_mono _ Ioo_subset_Ioi_self⟩ },
    { exact ⟨lb, hb.mono_left $ nhds_within_mono _ Ioo_subset_Iio_self⟩ },
    { use [f x, hf x h] } }
end

lemma eq_lim_at_left_extend_from_Ioo [topological_space α] [linear_order α] [densely_ordered α]
  [order_topology α] [topological_space β] [t2_space β] {f : α → β} {a b : α}
  {la : β} (hab : a < b) (ha : tendsto f (𝓝[>] a) (𝓝 la)) :
  extend_from (Ioo a b) f a = la :=
begin
  apply extend_from_eq,
  { rw closure_Ioo hab.ne,
    simp only [le_of_lt hab, left_mem_Icc, right_mem_Icc] },
  { simpa [hab] }
end

lemma eq_lim_at_right_extend_from_Ioo [topological_space α] [linear_order α] [densely_ordered α]
  [order_topology α] [topological_space β] [t2_space β] {f : α → β} {a b : α}
  {lb : β} (hab : a < b) (hb : tendsto f (𝓝[<] b) (𝓝 lb)) :
  extend_from (Ioo a b) f b = lb :=
begin
  apply extend_from_eq,
  { rw closure_Ioo hab.ne,
    simp only [le_of_lt hab, left_mem_Icc, right_mem_Icc] },
  { simpa [hab] }
end

lemma continuous_on_Ico_extend_from_Ioo [topological_space α]
  [linear_order α] [densely_ordered α] [order_topology α] [topological_space β]
  [regular_space β] {f : α → β} {a b : α} {la : β} (hab : a < b) (hf : continuous_on f (Ioo a b))
  (ha : tendsto f (𝓝[>] a) (𝓝 la)) :
  continuous_on (extend_from (Ioo a b) f) (Ico a b) :=
begin
  apply continuous_on_extend_from,
  { rw [closure_Ioo hab.ne], exact Ico_subset_Icc_self, },
  { intros x x_in,
    rcases eq_left_or_mem_Ioo_of_mem_Ico x_in with rfl | h,
    { use la,
      simpa [hab] },
    { use [f x, hf x h] } }
end

lemma continuous_on_Ioc_extend_from_Ioo [topological_space α]
  [linear_order α] [densely_ordered α] [order_topology α] [topological_space β]
  [regular_space β] {f : α → β} {a b : α} {lb : β} (hab : a < b) (hf : continuous_on f (Ioo a b))
  (hb : tendsto f (𝓝[<] b) (𝓝 lb)) :
  continuous_on (extend_from (Ioo a b) f) (Ioc a b) :=
begin
  have := @continuous_on_Ico_extend_from_Ioo (order_dual α) _ _ _ _ _ _ _ f _ _ _ hab,
  erw [dual_Ico, dual_Ioi, dual_Ioo] at this,
  exact this hf hb
end


/-
Copyright (c) 2021 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.category.Module.epi_mono
import algebra.category.Module.kernels
import category_theory.subobject.well_powered
import category_theory.subobject.limits
import category_theory.limits.concrete_category

/-!
# Subobjects in the category of `R`-modules

We construct an explicit order isomorphism between the categorical subobjects of an `R`-module `M`
and its submodules. This immediately implies that the category of `R`-modules is well-powered.

-/

open category_theory
open category_theory.subobject
open category_theory.limits

open_locale Module

universes v u

namespace Module
variables {R : Type u} [ring R] (M : Module.{v} R)

/-- The categorical subobjects of a module `M` are in one-to-one correspondence with its
    submodules.-/
noncomputable def subobject_Module : subobject M ≃o submodule R M := order_iso.symm
({ inv_fun := λ S, S.arrow.range,
  to_fun := λ N, subobject.mk ↾N.subtype,
  right_inv := λ S, eq.symm
  begin
    fapply eq_mk_of_comm,
    { apply linear_equiv.to_Module_iso'_left,
      apply linear_equiv.of_bijective (linear_map.cod_restrict S.arrow.range S.arrow _),
      { simpa only [← linear_map.ker_eq_bot, linear_map.ker_cod_restrict]
          using ker_eq_bot_of_mono _ },
      { rw [← linear_map.range_eq_top, linear_map.range_cod_restrict,
          submodule.comap_subtype_self] },
      { exact linear_map.mem_range_self _ } },
    { apply linear_map.ext,
      intros x,
      refl }
  end,
  left_inv := λ N,
  begin
    convert congr_arg linear_map.range (underlying_iso_arrow ↾N.subtype) using 1,
    { have : (underlying_iso ↾N.subtype).inv = (underlying_iso ↾N.subtype).symm.to_linear_equiv,
      { apply linear_map.ext,
        intros x,
        refl },
      rw [this, comp_def, linear_equiv.range_comp] },
    { exact (submodule.range_subtype _).symm }
  end,
  map_rel_iff' := λ S T,
  begin
    refine ⟨λ h, _, λ h, mk_le_mk_of_comm ↟(submodule.of_le h) (by { ext, refl })⟩,
    convert linear_map.range_comp_le_range (of_mk_le_mk _ _ h) ↾T.subtype,
    { simpa only [←comp_def, of_mk_le_mk_comp] using (submodule.range_subtype _).symm },
    { exact (submodule.range_subtype _).symm }
  end })

instance well_powered_Module : well_powered (Module.{v} R) :=
⟨λ M, ⟨⟨_, ⟨(subobject_Module M).to_equiv⟩⟩⟩⟩

local attribute [instance] has_kernels_Module

/-- Bundle an element `m : M` such that `f m = 0` as a term of `kernel_subobject f`. -/
noncomputable def to_kernel_subobject {M N : Module R} {f : M ⟶ N} :
  linear_map.ker f →ₗ[R] kernel_subobject f :=
(kernel_subobject_iso f ≪≫ Module.kernel_iso_ker f).inv

@[simp] lemma to_kernel_subobject_arrow {M N : Module R} {f : M ⟶ N} (x : linear_map.ker f) :
  (kernel_subobject f).arrow (to_kernel_subobject x) = x.1 :=
by simp [to_kernel_subobject]

/--
An extensionality lemma showing that two elements of a cokernel by an image
are equal if they differ by an element of the image.

The application is for homology:
two elements in homology are equal if they differ by a boundary.
-/
@[ext]
lemma cokernel_π_image_subobject_ext {L M N : Module.{v} R}
  (f : L ⟶ M) [has_image f] (g : (image_subobject f : Module.{v} R) ⟶ N) [has_cokernel g]
  {x y : N} (l : L) (w : x = y + g (factor_thru_image_subobject f l)) :
  cokernel.π g x = cokernel.π g y :=
by { subst w, simp, }

end Module


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

! This file was ported from Lean 3 source module algebra.group_with_zero.basic
! leanprover-community/mathlib commit 2196ab363eb097c008d4497125e0dde23fb36db2
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/

import Mathlib.Algebra.Group.Basic
import Mathlib.Algebra.GroupWithZero.Defs
import Mathlib.Algebra.Group.OrderSynonym
import Mathlib.Tactic.SimpRw

/-!
# Groups with an adjoined zero element

This file describes structures that are not usually studied on their own right in mathematics,
namely a special sort of monoid: apart from a distinguished “zero element” they form a group,
or in other words, they are groups with an adjoined zero element.

Examples are:

* division rings;
* the value monoid of a multiplicative valuation;
* in particular, the non-negative real numbers.

## Main definitions

Various lemmas about `GroupWithZero` and `CommGroupWithZero`.
To reduce import dependencies, the type-classes themselves are in
`Algebra.GroupWithZero.Defs`.

## Implementation details

As is usual in mathlib, we extend the inverse function to the zero element,
and require `0⁻¹ = 0`.

-/

open Classical

open Function

variable {α M₀ G₀ M₀' G₀' F F' : Type _}

section

section MulZeroClass

variable [MulZeroClass M₀] {a b : M₀}

theorem left_ne_zero_of_mul : a * b ≠ 0 → a ≠ 0 :=
  mt fun h => mul_eq_zero_of_left h b
#align left_ne_zero_of_mul left_ne_zero_of_mul

theorem right_ne_zero_of_mul : a * b ≠ 0 → b ≠ 0 :=
  mt (mul_eq_zero_of_right a)
#align right_ne_zero_of_mul right_ne_zero_of_mul

theorem ne_zero_and_ne_zero_of_mul (h : a * b ≠ 0) : a ≠ 0 ∧ b ≠ 0 :=
  ⟨left_ne_zero_of_mul h, right_ne_zero_of_mul h⟩
#align ne_zero_and_ne_zero_of_mul ne_zero_and_ne_zero_of_mul

theorem mul_eq_zero_of_ne_zero_imp_eq_zero {a b : M₀} (h : a ≠ 0 → b = 0) : a * b = 0 :=
  if ha : a = 0 then by rw [ha, zero_mul] else by rw [h ha, mul_zero]
#align mul_eq_zero_of_ne_zero_imp_eq_zero mul_eq_zero_of_ne_zero_imp_eq_zero

/-- To match `one_mul_eq_id`. -/
theorem zero_mul_eq_const : (· * ·) (0 : M₀) = Function.const _ 0 :=
  funext zero_mul
#align zero_mul_eq_const zero_mul_eq_const

/-- To match `mul_one_eq_id`. -/
theorem mul_zero_eq_const : (· * (0 : M₀)) = Function.const _ 0 :=
  funext mul_zero
#align mul_zero_eq_const mul_zero_eq_const

end MulZeroClass

section Mul

variable [Mul M₀] [Zero M₀] [NoZeroDivisors M₀] {a b : M₀}

theorem eq_zero_of_mul_self_eq_zero (h : a * a = 0) : a = 0 :=
  (eq_zero_or_eq_zero_of_mul_eq_zero h).elim id id
#align eq_zero_of_mul_self_eq_zero eq_zero_of_mul_self_eq_zero

@[field_simps]
theorem mul_ne_zero (ha : a ≠ 0) (hb : b ≠ 0) : a * b ≠ 0 :=
  mt eq_zero_or_eq_zero_of_mul_eq_zero <| not_or.mpr ⟨ha, hb⟩
#align mul_ne_zero mul_ne_zero

end Mul

namespace NeZero

instance mul [Zero M₀] [Mul M₀] [NoZeroDivisors M₀] {x y : M₀} [NeZero x] [NeZero y] :
    NeZero (x * y) :=
  ⟨mul_ne_zero out out⟩

end NeZero

end

section

variable [MulZeroOneClass M₀]

/-- In a monoid with zero, if zero equals one, then zero is the only element. -/
theorem eq_zero_of_zero_eq_one (h : (0 : M₀) = 1) (a : M₀) : a = 0 := by
  rw [← mul_one a, ← h, mul_zero]
#align eq_zero_of_zero_eq_one eq_zero_of_zero_eq_one

/-- In a monoid with zero, if zero equals one, then zero is the unique element.

Somewhat arbitrarily, we define the default element to be `0`.
All other elements will be provably equal to it, but not necessarily definitionally equal. -/
def uniqueOfZeroEqOne (h : (0 : M₀) = 1) : Unique M₀ where
  default := 0
  uniq := eq_zero_of_zero_eq_one h
#align unique_of_zero_eq_one uniqueOfZeroEqOne

/-- In a monoid with zero, zero equals one if and only if all elements of that semiring
are equal. -/
theorem subsingleton_iff_zero_eq_one : (0 : M₀) = 1 ↔ Subsingleton M₀ :=
  ⟨fun h => haveI := uniqueOfZeroEqOne h; inferInstance, fun h => @Subsingleton.elim _ h _ _⟩
#align subsingleton_iff_zero_eq_one subsingleton_iff_zero_eq_one

alias subsingleton_iff_zero_eq_one ↔ subsingleton_of_zero_eq_one _
#align subsingleton_of_zero_eq_one subsingleton_of_zero_eq_one

theorem eq_of_zero_eq_one (h : (0 : M₀) = 1) (a b : M₀) : a = b :=
  @Subsingleton.elim _ (subsingleton_of_zero_eq_one h) a b
#align eq_of_zero_eq_one eq_of_zero_eq_one

/-- In a monoid with zero, either zero and one are nonequal, or zero is the only element. -/
theorem zero_ne_one_or_forall_eq_0 : (0 : M₀) ≠ 1 ∨ ∀ a : M₀, a = 0 :=
  not_or_of_imp eq_zero_of_zero_eq_one
#align zero_ne_one_or_forall_eq_0 zero_ne_one_or_forall_eq_0

end

section

variable [MulZeroOneClass M₀] [Nontrivial M₀] {a b : M₀}

theorem left_ne_zero_of_mul_eq_one (h : a * b = 1) : a ≠ 0 :=
  left_ne_zero_of_mul <| ne_zero_of_eq_one h
#align left_ne_zero_of_mul_eq_one left_ne_zero_of_mul_eq_one

theorem right_ne_zero_of_mul_eq_one (h : a * b = 1) : b ≠ 0 :=
  right_ne_zero_of_mul <| ne_zero_of_eq_one h
#align right_ne_zero_of_mul_eq_one right_ne_zero_of_mul_eq_one

end

section CancelMonoidWithZero

variable [CancelMonoidWithZero M₀] {a b c : M₀}

-- see Note [lower instance priority]
instance (priority := 10) CancelMonoidWithZero.to_noZeroDivisors : NoZeroDivisors M₀ :=
  ⟨fun ab0 => or_iff_not_imp_left.mpr <| fun ha => mul_left_cancel₀ ha <|
    ab0.trans (mul_zero _).symm⟩
#align cancel_monoid_with_zero.to_no_zero_divisors CancelMonoidWithZero.to_noZeroDivisors

theorem mul_left_inj' (hc : c ≠ 0) : a * c = b * c ↔ a = b :=
  (mul_left_injective₀ hc).eq_iff
#align mul_left_inj' mul_left_inj'

theorem mul_right_inj' (ha : a ≠ 0) : a * b = a * c ↔ b = c :=
  (mul_right_injective₀ ha).eq_iff
#align mul_right_inj' mul_right_inj'

@[simp]
theorem mul_eq_mul_right_iff : a * c = b * c ↔ a = b ∨ c = 0 := by
  by_cases hc : c = 0 <;> [simp [hc], simp [mul_left_inj', hc]]
#align mul_eq_mul_right_iff mul_eq_mul_right_iff

@[simp]
theorem mul_eq_mul_left_iff : a * b = a * c ↔ b = c ∨ a = 0 := by
  by_cases ha : a = 0 <;> [simp [ha], simp [mul_right_inj', ha]]
#align mul_eq_mul_left_iff mul_eq_mul_left_iff

theorem mul_right_eq_self₀ : a * b = a ↔ b = 1 ∨ a = 0 :=
  calc
    a * b = a ↔ a * b = a * 1 := by rw [mul_one]
    _ ↔ b = 1 ∨ a = 0 := mul_eq_mul_left_iff
#align mul_right_eq_self₀ mul_right_eq_self₀

theorem mul_left_eq_self₀ : a * b = b ↔ a = 1 ∨ b = 0 :=
  calc
    a * b = b ↔ a * b = 1 * b := by rw [one_mul]
    _ ↔ a = 1 ∨ b = 0 := mul_eq_mul_right_iff
#align mul_left_eq_self₀ mul_left_eq_self₀

/-- An element of a `CancelMonoidWithZero` fixed by right multiplication by an element other
than one must be zero. -/
theorem eq_zero_of_mul_eq_self_right (h₁ : b ≠ 1) (h₂ : a * b = a) : a = 0 :=
  Classical.byContradiction fun ha => h₁ <| mul_left_cancel₀ ha <| h₂.symm ▸ (mul_one a).symm
#align eq_zero_of_mul_eq_self_right eq_zero_of_mul_eq_self_right

/-- An element of a `CancelMonoidWithZero` fixed by left multiplication by an element other
than one must be zero. -/
theorem eq_zero_of_mul_eq_self_left (h₁ : b ≠ 1) (h₂ : b * a = a) : a = 0 :=
  Classical.byContradiction fun ha => h₁ <| mul_right_cancel₀ ha <| h₂.symm ▸ (one_mul a).symm
#align eq_zero_of_mul_eq_self_left eq_zero_of_mul_eq_self_left

end CancelMonoidWithZero

section GroupWithZero

variable [GroupWithZero G₀] {a b c g h x : G₀}

@[simp]
theorem mul_inv_cancel_right₀ (h : b ≠ 0) (a : G₀) : a * b * b⁻¹ = a :=
  calc
    a * b * b⁻¹ = a * (b * b⁻¹) := mul_assoc _ _ _
    _ = a := by simp [h]
#align mul_inv_cancel_right₀ mul_inv_cancel_right₀

@[simp]
theorem mul_inv_cancel_left₀ (h : a ≠ 0) (b : G₀) : a * (a⁻¹ * b) = b :=
  calc
    a * (a⁻¹ * b) = a * a⁻¹ * b := (mul_assoc _ _ _).symm
    _ = b := by simp [h]
#align mul_inv_cancel_left₀ mul_inv_cancel_left₀

-- Porting note: used `simpa` to prove `False` in lean3
theorem inv_ne_zero (h : a ≠ 0) : a⁻¹ ≠ 0 := fun a_eq_0 => by
  have := mul_inv_cancel h
  simp [a_eq_0] at this
#align inv_ne_zero inv_ne_zero

@[simp]
theorem inv_mul_cancel (h : a ≠ 0) : a⁻¹ * a = 1 :=
  calc
    a⁻¹ * a = a⁻¹ * a * a⁻¹ * a⁻¹⁻¹ := by simp [inv_ne_zero h]
    _ = a⁻¹ * a⁻¹⁻¹ := by simp [h]
    _ = 1 := by simp [inv_ne_zero h]
#align inv_mul_cancel inv_mul_cancel

theorem GroupWithZero.mul_left_injective (h : x ≠ 0) :
    Function.Injective fun y => x * y := fun y y' w => by
  simpa only [← mul_assoc, inv_mul_cancel h, one_mul] using congr_arg (fun y => x⁻¹ * y) w
#align group_with_zero.mul_left_injective GroupWithZero.mul_left_injective

theorem GroupWithZero.mul_right_injective (h : x ≠ 0) :
    Function.Injective fun y => y * x := fun y y' w => by
  simpa only [mul_assoc, mul_inv_cancel _ h, mul_one] using congr_arg (fun y => y * x⁻¹) w
#align group_with_zero.mul_right_injective GroupWithZero.mul_right_injective

@[simp]
theorem inv_mul_cancel_right₀ (h : b ≠ 0) (a : G₀) : a * b⁻¹ * b = a :=
  calc
    a * b⁻¹ * b = a * (b⁻¹ * b) := mul_assoc _ _ _
    _ = a := by simp [h]
#align inv_mul_cancel_right₀ inv_mul_cancel_right₀

@[simp]
theorem inv_mul_cancel_left₀ (h : a ≠ 0) (b : G₀) : a⁻¹ * (a * b) = b :=
  calc
    a⁻¹ * (a * b) = a⁻¹ * a * b := (mul_assoc _ _ _).symm
    _ = b := by simp [h]
#align inv_mul_cancel_left₀ inv_mul_cancel_left₀

private theorem inv_eq_of_mul (h : a * b = 1) : a⁻¹ = b := by
  rw [← inv_mul_cancel_left₀ (left_ne_zero_of_mul_eq_one h) b, h, mul_one]

-- See note [lower instance priority]
instance (priority := 100) GroupWithZero.toDivisionMonoid : DivisionMonoid G₀ :=
  { ‹GroupWithZero G₀› with
    inv := Inv.inv,
    inv_inv := fun a => by
      by_cases h : a = 0
      · simp [h]

      · exact left_inv_eq_right_inv (inv_mul_cancel <| inv_ne_zero h) (inv_mul_cancel h)
        ,
    mul_inv_rev := fun a b => by
      by_cases ha : a = 0
      · simp [ha]

      by_cases hb : b = 0
      · simp [hb]

      refine' inv_eq_of_mul _
      simp [mul_assoc, ha, hb],
    inv_eq_of_mul := fun a b => inv_eq_of_mul }
#align group_with_zero.to_division_monoid GroupWithZero.toDivisionMonoid

end GroupWithZero

section GroupWithZero

variable [GroupWithZero G₀] {a b c : G₀}

@[simp]
theorem zero_div (a : G₀) : 0 / a = 0 := by rw [div_eq_mul_inv, zero_mul]
#align zero_div zero_div

@[simp]
theorem div_zero (a : G₀) : a / 0 = 0 := by rw [div_eq_mul_inv, inv_zero, mul_zero]
#align div_zero div_zero

/-- Multiplying `a` by itself and then by its inverse results in `a`
(whether or not `a` is zero). -/
@[simp]
theorem mul_self_mul_inv (a : G₀) : a * a * a⁻¹ = a := by
  by_cases h : a = 0
  · rw [h, inv_zero, mul_zero]
  · rw [mul_assoc, mul_inv_cancel h, mul_one]
#align mul_self_mul_inv mul_self_mul_inv

/-- Multiplying `a` by its inverse and then by itself results in `a`
(whether or not `a` is zero). -/
@[simp]
theorem mul_inv_mul_self (a : G₀) : a * a⁻¹ * a = a := by
  by_cases h : a = 0
  · rw [h, inv_zero, mul_zero]
  · rw [mul_inv_cancel h, one_mul]
#align mul_inv_mul_self mul_inv_mul_self

/-- Multiplying `a⁻¹` by `a` twice results in `a` (whether or not `a`
is zero). -/
@[simp]
theorem inv_mul_mul_self (a : G₀) : a⁻¹ * a * a = a := by
  by_cases h : a = 0
  · rw [h, inv_zero, mul_zero]
  · rw [inv_mul_cancel h, one_mul]
#align inv_mul_mul_self inv_mul_mul_self

/-- Multiplying `a` by itself and then dividing by itself results in `a`, whether or not `a` is
zero. -/
@[simp]
theorem mul_self_div_self (a : G₀) : a * a / a = a := by rw [div_eq_mul_inv, mul_self_mul_inv a]
#align mul_self_div_self mul_self_div_self

/-- Dividing `a` by itself and then multiplying by itself results in `a`, whether or not `a` is
zero. -/
@[simp]
theorem div_self_mul_self (a : G₀) : a / a * a = a := by rw [div_eq_mul_inv, mul_inv_mul_self a]
#align div_self_mul_self div_self_mul_self

attribute [local simp] div_eq_mul_inv mul_comm mul_assoc mul_left_comm

@[simp]
theorem div_self_mul_self' (a : G₀) : a / (a * a) = a⁻¹ :=
  calc
    a / (a * a) = a⁻¹⁻¹ * a⁻¹ * a⁻¹ := by simp [mul_inv_rev]
    _ = a⁻¹ := inv_mul_mul_self _
#align div_self_mul_self' div_self_mul_self'

theorem one_div_ne_zero {a : G₀} (h : a ≠ 0) : 1 / a ≠ 0 := by
  simpa only [one_div] using inv_ne_zero h
#align one_div_ne_zero one_div_ne_zero

@[simp]
theorem inv_eq_zero {a : G₀} : a⁻¹ = 0 ↔ a = 0 := by rw [inv_eq_iff_eq_inv, inv_zero]
#align inv_eq_zero inv_eq_zero

@[simp]
theorem zero_eq_inv {a : G₀} : 0 = a⁻¹ ↔ 0 = a :=
  eq_comm.trans <| inv_eq_zero.trans eq_comm
#align zero_eq_inv zero_eq_inv

/-- Dividing `a` by the result of dividing `a` by itself results in
`a` (whether or not `a` is zero). -/
@[simp]
theorem div_div_self (a : G₀) : a / (a / a) = a := by
  rw [div_div_eq_mul_div]
  exact mul_self_div_self a
#align div_div_self div_div_self

theorem ne_zero_of_one_div_ne_zero {a : G₀} (h : 1 / a ≠ 0) : a ≠ 0 := fun ha : a = 0 => by
  rw [ha, div_zero] at h
  contradiction
#align ne_zero_of_one_div_ne_zero ne_zero_of_one_div_ne_zero

theorem eq_zero_of_one_div_eq_zero {a : G₀} (h : 1 / a = 0) : a = 0 :=
  Classical.byCases (fun ha => ha) fun ha => ((one_div_ne_zero ha) h).elim
#align eq_zero_of_one_div_eq_zero eq_zero_of_one_div_eq_zero

theorem mul_left_surjective₀ {a : G₀} (h : a ≠ 0) : Surjective fun g => a * g := fun g =>
  ⟨a⁻¹ * g, by simp [← mul_assoc, mul_inv_cancel h]⟩
#align mul_left_surjective₀ mul_left_surjective₀

theorem mul_right_surjective₀ {a : G₀} (h : a ≠ 0) : Surjective fun g => g * a := fun g =>
  ⟨g * a⁻¹, by simp [mul_assoc, inv_mul_cancel h]⟩
#align mul_right_surjective₀ mul_right_surjective₀

end GroupWithZero

section CommGroupWithZero

variable [CommGroupWithZero G₀] {a b c d : G₀}

theorem div_mul_eq_mul_div₀ (a b c : G₀) : a / c * b = a * b / c := by
  simp_rw [div_eq_mul_inv, mul_assoc, mul_comm c⁻¹]
#align div_mul_eq_mul_div₀ div_mul_eq_mul_div₀

end CommGroupWithZero

/-! ### Order dual -/

open OrderDual

instance [h : MulZeroClass α] : MulZeroClass αᵒᵈ := h

instance [h : MulZeroOneClass α] : MulZeroOneClass αᵒᵈ := h

instance [Mul α] [Zero α] [h : NoZeroDivisors α] : NoZeroDivisors αᵒᵈ := h

instance [h : SemigroupWithZero α] : SemigroupWithZero αᵒᵈ := h

instance [h : MonoidWithZero α] : MonoidWithZero αᵒᵈ := h

instance [h : CancelMonoidWithZero α] : CancelMonoidWithZero αᵒᵈ := h

instance [h : CommMonoidWithZero α] : CommMonoidWithZero αᵒᵈ := h

instance [h : CancelCommMonoidWithZero α] : CancelCommMonoidWithZero αᵒᵈ := h

instance [h : GroupWithZero α] : GroupWithZero αᵒᵈ := h

instance [h : CommGroupWithZero α] : CommGroupWithZero αᵒᵈ := h

/-! ### Lexicographic order -/

instance [h : MulZeroClass α] : MulZeroClass (Lex α) := h

instance [h : MulZeroOneClass α] : MulZeroOneClass (Lex α) := h

instance [Mul α] [Zero α] [h : NoZeroDivisors α] : NoZeroDivisors (Lex α) := h

instance [h : SemigroupWithZero α] : SemigroupWithZero (Lex α) := h

instance [h : MonoidWithZero α] : MonoidWithZero (Lex α) := h

instance [h : CancelMonoidWithZero α] : CancelMonoidWithZero (Lex α) := h

instance [h : CommMonoidWithZero α] : CommMonoidWithZero (Lex α) := h

instance [h : CancelCommMonoidWithZero α] : CancelCommMonoidWithZero (Lex α) := h

instance [h : GroupWithZero α] : GroupWithZero (Lex α) := h

instance [h : CommGroupWithZero α] : CommGroupWithZero (Lex α) := h


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

/-!
# Locally integrable functions

A function is called *locally integrable* (`measure_theory.locally_integrable`) if it is integrable
on every compact subset of its domain.

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

## Main statements

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

-/

open measure_theory measure_theory.measure set function topological_space
open_locale topological_space interval

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

namespace measure_theory

/-- A function `f : X → E` is locally integrable if it is integrable on all compact sets.
  See `measure_theory.locally_integrable_iff` for the justification of this name. -/
def locally_integrable (f : X → E) (μ : measure X . volume_tac) : Prop :=
∀ ⦃K⦄, is_compact K → integrable_on f K μ

lemma integrable.locally_integrable (hf : integrable f μ) : locally_integrable f μ :=
λ K hK, hf.integrable_on

lemma locally_integrable.ae_strongly_measurable [sigma_compact_space X]
  (hf : locally_integrable f μ) :
  ae_strongly_measurable f μ :=
begin
  rw [← @restrict_univ _ _ μ, ← Union_compact_covering, ae_strongly_measurable_Union_iff],
  exact λ i, (hf $ is_compact_compact_covering X i).ae_strongly_measurable
end

lemma locally_integrable_iff [locally_compact_space X] :
  locally_integrable f μ ↔ ∀ x : X, ∃ U ∈ 𝓝 x, integrable_on f U μ :=
begin
  refine ⟨λ hf x, _, λ hf K hK, _⟩,
  { obtain ⟨K, hK, h2K⟩ := exists_compact_mem_nhds x, exact ⟨K, h2K, hf hK⟩ },
  { refine is_compact.induction_on hK integrable_on_empty (λ s t hst h, h.mono_set hst)
      (λ s t hs ht, integrable_on_union.mpr ⟨hs, ht⟩) (λ x hx, _),
    obtain ⟨K, hK, h2K⟩ := hf x,
    exact ⟨K, nhds_within_le_nhds hK, h2K⟩ }
end

section real
variables [opens_measurable_space X] {A K : set X} {g g' : X → ℝ}

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

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

lemma integrable_on.continuous_on_mul_of_subset
  (hg : continuous_on g K) (hg' : integrable_on g' A μ)
  (hK : is_compact K) (hA : measurable_set A) (hAK : A ⊆ K) :
  integrable_on (λ x, g x * g' x) A μ :=
by simpa [mul_comm] using hg'.mul_continuous_on_of_subset hg hA hK hAK

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

end real

end measure_theory
open measure_theory

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

section borel

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

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

/-- A continuous function `f` is locally integrable with respect to any locally finite measure. -/
lemma continuous.locally_integrable (hf : continuous f) : locally_integrable f μ :=
λ s hs, hf.continuous_on.integrable_on_compact hs

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

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

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

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

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

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

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

end borel

section monotone

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

lemma monotone_on.integrable_on_compact (hs : is_compact s) (hmono : monotone_on f s) :
  integrable_on f s μ :=
begin
  borelize E,
  obtain rfl | h := s.eq_empty_or_nonempty,
  { exact integrable_on_empty },
  have hbelow : bdd_below (f '' s) :=
    ⟨f (Inf s), λ x ⟨y, hy, hyx⟩, hyx ▸ hmono (hs.Inf_mem h) hy (cInf_le hs.bdd_below hy)⟩,
  have habove : bdd_above (f '' s) :=
    ⟨f (Sup s), λ x ⟨y, hy, hyx⟩, hyx ▸ hmono hy (hs.Sup_mem h) (le_cSup hs.bdd_above hy)⟩,
  have : metric.bounded (f '' s) := metric.bounded_of_bdd_above_of_bdd_below habove hbelow,
  rcases bounded_iff_forall_norm_le.mp this with ⟨C, hC⟩,
  refine integrable.mono' (continuous_const.locally_integrable hs)
    (ae_measurable_restrict_of_monotone_on hs.measurable_set hmono).ae_strongly_measurable
    ((ae_restrict_iff' hs.measurable_set).mpr $ ae_of_all _ $
      λ y hy, hC (f y) (mem_image_of_mem f hy)),
end

lemma antitone_on.integrable_on_compact (hs : is_compact s) (hanti : antitone_on f s) :
  integrable_on f s μ :=
hanti.dual_right.integrable_on_compact hs

lemma monotone.locally_integrable (hmono : monotone f) : locally_integrable f μ :=
λ s hs, (hmono.monotone_on _).integrable_on_compact hs

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

end monotone


/-
Just some random additions to `Core.lean` that look like they would actually belong there.
-/

theorem Iff.isEquivalence              : Equivalence Iff     := ⟨Iff.refl, Iff.symm, Iff.trans⟩
theorem Eq.isEquivalence  {α : Sort u} : Equivalence (@Eq α) := ⟨Eq.refl,  Eq.symm,  Eq.trans⟩

theorem Setoid.of_Eq {α : Sort u} [Setoid α] {a b : α} (h : a = b) : a ≈ b :=
h ▸ Setoid.refl a

class Mem (α : outParam $ Type u) (γ : Type v) where
  mem : α → γ → Prop

infix:50 " ∈ " => Mem.mem

class Subset (α : Type u) where
  subset : α → α → Prop

infix:50 " ⊆ " => Subset.subset

namespace List

protected def mem : α → List α → Prop
| a, [] => False
| a, b :: l => a = b ∨ List.mem a l

instance : Mem α (List α) := ⟨List.mem⟩

theorem mem_cons_self (a : α) (l : List α) : a ∈ a :: l :=
Or.inl rfl

@[simp] theorem mem_cons_iff (a y : α) (l : List α) : a ∈ y :: l ↔ (a = y ∨ a ∈ l) := Iff.rfl

protected def subset (l₁ l₂ : List α) := ∀ {a : α}, a ∈ l₁ → a ∈ l₂

instance : Subset (List α) := ⟨List.subset⟩

theorem eq_nil_of_length_eq_zero {l : List α} (hl : length l = 0) : l = [] :=
match l with
| [] => rfl
| x :: m => False.elim $ Nat.succNeZero (m.length) (List.length_cons x m ▸ hl)

end List

def symmetric (r : α → α → Prop) := ∀ {x y}, r x y → r y x


import MLIR.Util.Arith
import MLIR.AST
import Mathlib.Data.Int.Basic
import Mathlib.Data.Int.Order.Basic
import Mathlib.Data.Int.Bitwise
import Mathlib.Data.Int.ModEq
import Mathlib.Tactic.Ring
import Mathlib.Tactic.LibrarySearch
import Mathlib.Init.Data.Fin.Basic

open MLIR.AST (Signedness)

-- This file contains many sorrys for trivial arithmetic results that aren't
-- automated in Lean 4 yet (mainly because omega isn't ported). The following
-- tactic is used to dispatch them. We only use `sorry` for incomplete proofs.
macro "sorry_arith": tactic => `(tactic| sorry)

-- Stored as most significant bit first
inductive FinInt: Nat → Type :=
  | nil: FinInt 0
  | next: Bool → FinInt n → FinInt (n+1)
deriving DecidableEq

@[match_pattern]
abbrev FinInt.O: FinInt sz → FinInt (sz+1) := .next false
@[match_pattern]
abbrev FinInt.I: FinInt sz → FinInt (sz+1) := .next true

namespace FinInt

/-
### Computations modulo powers of 2
-/

-- Standard modulo: mod2 a n = a % 2^n

def mod2 (a: Int) (n: Nat): Int :=
  ((a % 2^n) + 2^n) % 2^n

theorem mod2_ge: mod2 a n ≥ 0 := by
  simp [mod2]
  apply Int.mod_ge
  have h := Int.ge_add_ge_right (2^n) (@Int.mod_ge_neg a (2^n))
  rw [Int.add_left_neg] at h
  -- assumption
  sorry

theorem mod2_lt: mod2 a n < 2^n := by
  simp [mod2]
  apply Int.mod_lt Int.two_pow_pos

theorem mod2_bounds: mod2 a n ≥ 0 ∧ mod2 a n < 2^n :=
  ⟨mod2_ge, mod2_lt⟩

theorem mod2_idem {a: Int}: a ≥ 0 ∧ a < 2^n → mod2 a n = a := by
  intros h
  simp [mod2]
  -- rw [Int.add_mod_right Int.two_pow_pos (Int.mod_ge h.1), Int.mod_mod]
  simp [Int.mod_bounds _ h.1 h.2]

theorem mod2_idem_iff_bounds {a: Int}:
    mod2 a n = a ↔ (a ≥ 0 ∧ a < 2^n) :=
  ⟨(. ▸ mod2_bounds), mod2_idem⟩

@[simp]
theorem mod2_mod2: mod2 (mod2 a n) n = mod2 a n :=
  mod2_idem mod2_bounds

theorem mod2_fequal: x = y → mod2 x n = mod2 y n := by
  intros h; simp [h]

theorem mod2_zero: mod2 0 n = 0 := by
  simp [mod2]
  simp [Int.emod_self]

theorem mod2_exp_n: mod2 (2^n) n = 0 := by
  simp [mod2]
  simp [Int.mod_mod]
  simp [Int.emod_self]

theorem mod2_add_left: mod2 (2^n + x) n = mod2 x n := by
  sorry

theorem mod2_add_right: mod2 (x + 2^n) n = mod2 x n := by
  sorry

-- Symmetric modulo : smod2 a n = a % 2^(n+1) spread over -(2^n) ... 2^n-1

def smod2 (a: Int) (n: Nat): Int :=
  if mod2 a (n+1) ≥ 2^n then mod2 a (n+1) - 2^(n+1) else mod2 a (n+1)

theorem smod2_ge: smod2 a n ≥ -(2^n) := by
  simp [smod2]; split
  . sorry_arith
  . apply Int.ge_trans 0 mod2_ge (Int.zero_ge_neg Int.two_pow_ge)

theorem smod2_lt: smod2 a n < 2^n := by
  simp [smod2]; split
  . sorry_arith -- it's < 0 anyway
  . sorry_arith

theorem smod2_bounds: smod2 a n ≥ -(2^n) ∧ smod2 a n < 2^n :=
  ⟨smod2_ge, smod2_lt⟩

theorem smod2_idem {a: Int}: a ≥ -(2^n) ∧ a < 2^n → smod2 a n = a := by
  sorry

theorem smod2_idem_iff_bounds {a: Int}:
    smod2 a n = a ↔ (a ≥ -(2^n) ∧ a < 2^n) :=
  ⟨(. ▸ smod2_bounds), smod2_idem⟩

theorem smod2_smod2: smod2 (smod2 a n) n = smod2 a n :=
  smod2_idem smod2_bounds

-- Relation between modulo and symmetric modulo

theorem smod2_as_mod2: smod2 a n = mod2 (a + 2^n) (n+1) - 2^n := by
  sorry

-- Congruence

def cong2 (n: Nat): Int → Int → Prop :=
  fun a b => mod2 a n = mod2 b n

def scong2 (n: Nat): Int → Int → Prop :=
  fun a b => smod2 a n = smod2 b n

notation a " ≡ " b  " [2^" n "]" =>  cong2 n a b
notation a " ≡ " b " [±2^" n "]" => scong2 n a b

instance {n}: Equivalence (cong2 n) where
  refl _ := rfl
  symm := Eq.symm
  trans := Eq.trans

instance {n}: Equivalence (scong2 n) where
  refl _ := rfl
  symm := Eq.symm
  trans := Eq.trans

theorem cong2_to_eq (n: Nat):
    a ≡ b [2^n] →
    a ≥ 0 ∧ a < 2^n →
    b ≥ 0 ∧ b < 2^n →
    a = b := by
  intros h ha hb
  rw [←mod2_idem ha, ←mod2_idem hb]; assumption

theorem scong2_to_eq (n: Nat):
    a ≡ b [±2^n] →
    a ≥ -(2^n) ∧ a < 2^n →
    b ≥ -(2^n) ∧ b < 2^n →
    a = b := by
  intros h ha hb
  rw [←smod2_idem ha, ←smod2_idem hb]; assumption

@[simp]
theorem mod2_add_l: mod2 (mod2 a n + b) n = mod2 (a + b) n := by
  sorry

@[simp]
theorem mod2_add_r: mod2 (a + mod2 b n) n = mod2 (a + b) n := by
  sorry

@[simp]
theorem mod2_neg: mod2 (-mod2 a n) n = mod2 (-a) n := by
  sorry

@[simp]
theorem mod2_sub_r: mod2 (a - mod2 b n) n = mod2 (a - b) n := by
  sorry

@[simp]
theorem mod2_sub_l: mod2 (mod2 a n - b) n = mod2 (a - b) n := by
  sorry

theorem cong2_mod2_right: a ≡ b [2^n] → a ≡ mod2 b n [2^n] := by
  simp [cong2, mod2_idem mod2_bounds];

theorem cong2_mod2_left: a ≡ b [2^n] → mod2 a n ≡ b [2^n] := by
  simp [cong2, mod2_idem mod2_bounds];

/-
### Building FinInt from constants
-/

def zero: FinInt sz :=
  match sz with
  | 0 => .nil
  | sz+1 => .O zero

def one: FinInt sz :=
  match sz with
  | 0 => .nil
  | 1 => .I nil
  | sz+1 => .O one

def minusOne: FinInt sz :=
  match sz with
  | 0 => .nil
  | sz+1 => .I minusOne

instance: Inhabited (FinInt sz) where
  default := zero

def isInBounds (sgn: Signedness) (sz: Nat) (i: Int): Bool :=
  match sgn with
  | .Signless => i ≥ 0 ∧ i < 2^sz
  | .Unsigned => i ≥ 0 ∧ i < 2^sz
  | .Signed   => i ≥ -(2^(sz-1)) ∧ i < 2^(sz-1)

private def ofIntAux (sz: Nat) (n: Int): FinInt sz × Int :=
  match sz with
  | 0 => (.nil, n)
  | sz+1 =>
      match ofIntAux sz n with
      | (r, m) => (.next (m%2 == 1) r, m / 2)

def ofInt (sz: Nat) (i: Int): FinInt sz :=
  ofIntAux sz (mod2 i sz) |>.fst

instance {sz: Nat} {a: Nat}: OfNat (FinInt sz) a where
  ofNat := ofInt sz a

def ofIntAux_0 {sz: Nat}:
    ofIntAux sz 0 = (zero, 0) := by
  induction sz with
  | zero => decide
  | succ n h => simp [ofIntAux, h, zero]

def ofInt_0 {sz: Nat}:
    ofInt sz 0 = zero := by
  simp [ofInt, ofIntAux_0, mod2_zero]

def ofIntAux_1 {sz: Nat}:
    ofIntAux (sz+1) 1 = (one, 0) := by
  induction sz with
  | zero => decide
  | succ n h => rw [Nat.succ_add]; unfold ofIntAux; simp [h, one]

def ofInt_1 {sz: Nat}:
    ofInt sz 1 = one := by
  match sz with
  | 0 => decide
  | sz'+1 =>
    simp [ofInt, @mod2_idem (sz'+1) 1 ⟨by decide, by sorry_arith⟩]
    simp [ofIntAux_1]

/-
### Converting FinInt back to Int
-/

@[simp]
def toUint (n: FinInt sz): Int :=
  match sz, n with
  | 0,    .nil => 0
  | sz+1, .O i => i.toUint
  | sz+1, .I i => 2^sz + i.toUint

def toSint (n: FinInt sz): Int :=
  match sz, n with
  | 0, .nil => 0
  | sz+1, .O m => m.toUint
  | sz+1, .I m => m.toUint - 2^sz

-- | A variant of toSint that is defined at the singularity of
-- zero bit-width based on https://reviews.llvm.org/D116413
def toSint' (n: FinInt sz): Int :=
  match sz, n with
  | 0, .nil =>  0 -- is this sane?
  | sz+1, .O m => m.toUint
  | sz+1, .I m => m.toUint - 2^sz

theorem toUint_ge {n: FinInt sz}: n.toUint ≥ 0 := by
  revert n; induction sz <;> intros n <;> cases n <;> simp
  case next sz bn n' ih =>
    cases bn <;> simp [@ih n']
    apply Int.add_ge_zero; apply Int.pow_ge_zero; decide; apply ih

theorem toUint_lt {n: FinInt sz}: n.toUint < (2:Int)^sz := by
  revert n; induction sz <;> intros n <;> cases n <;> simp
  sorry
  /-
  case succ.next sz bn n' ih =>
    cases bn <;> simp
    . apply Int.lt_trans ((2:Int)^sz)
      . specialize @ih n'; simp at ih; trivial
      . simp [Int.pow_succ, Int.mul_two]; apply Int.lt_add_right
        apply Int.pow_gt_zero; decide
    . specialize @ih n'; simp at ih; simp [Int.pow_succ, Int.mul_two]
      apply Int.lt_add_lt_left; trivial
    -/

theorem toUint_bounds {n: FinInt sz}:
    n.toUint ≥ 0 ∧ n.toUint < 2^sz :=
  ⟨toUint_ge, toUint_lt⟩

theorem toUint_mod2 {n: FinInt sz}: mod2 n.toUint sz = n.toUint :=
  mod2_idem toUint_bounds

theorem toSint_ge {n: FinInt (sz+1)}: n.toSint ≥ -(2^sz) := by
  sorry
  /-
  cases n; case next bn n' =>
  cases bn <;> simp [toSint]
  . apply Int.le_trans _ <;> sorry_arith
  . sorry_arith
  -/

theorem toSint_lt {n: FinInt (sz+1)}: n.toSint < 2^sz := by
  cases n; case next bn n' =>
  cases bn <;> simp [toSint]
  . apply toUint_lt
  . sorry_arith

theorem toSint_bounds {n: FinInt (sz+1)}:
    n.toSint ≥ -(2^sz) ∧ n.toSint < 2^sz :=
  ⟨toSint_ge, toSint_lt⟩

theorem toSint_smod2 {n: FinInt (sz+1)}: smod2 n.toSint sz = n.toSint :=
  smod2_idem toSint_bounds

theorem toUint_zero {sz}:
    toUint (@zero sz) = 0 := by
  induction sz with
  | zero => decide
  | succ n ih => simp [toUint, ih]

theorem toUint_one {sz}:
    sz > 0 → toUint (@one sz) = 1 := by
  intros h
  induction sz with
  | zero => cases (by decide: ¬ 0 > 0) h
  | succ n ih => cases n; decide; simp [toUint]; apply ih; simp_arith

theorem toUint_minusOne {sz}:
    toUint (@minusOne sz) = 2^sz - 1 := by
  induction sz with
  | zero => decide
  | succ n ih => simp [toUint, ih]; sorry_arith

/-
### Numerical bounds derived from bit structure
-/

theorem msb_bound (b: Bool) (n: FinInt sz):
    (FinInt.next b n).toUint < 2^sz ↔ b = false := by
  sorry
  /-
  cases b <;> simp [toUint]
  . apply toUint_lt
  . intro h; sorry_arith
  -/

theorem O_lt (n: FinInt sz): (FinInt.next false n).toUint < 2^sz :=
  (msb_bound false n).2 rfl

theorem I_not_lt (n: FinInt sz): ¬(FinInt.next true n).toUint < 2^sz :=
  fun h => Bool.noConfusion <| (msb_bound true n).1 h

/-
### String representation
-/

def str_u (n: FinInt sz): String :=
  match sz, n with
  | 0,    .nil => ""
  | sz+1, .O m => "0 " ++ str_u m
  | sz+1, .I m => "1 " ++ str_u m

def str_s (n: FinInt (sz+1)): String :=
  match n with
  | .O m => "s=0 " ++ str_u m
  | .I m => "s=1 " ++ str_u m

-- The default is still to display them as unsigned integers
instance: ToString (FinInt sz) where
  toString n := s!"{n.toUint}[{sz}-bit]"

/-
### Conversions of sign/valuation and derived equalities
-/

theorem toSint_of_toUint (n: FinInt (sz+1)):
  n.toSint =
    match n with
    | .O _ => n.toUint
    | .I _ => n.toUint - 2^(sz+1) := by
  match n with
  | .O m => simp [toSint, toUint]
  | .I m => simp [toSint, toUint]; sorry_arith

theorem toUint_of_toSint (n: FinInt (sz+1)):
  n.toUint =
    match n with
    | .O _ => n.toSint
    | .I _ => n.toSint + 2^(sz+1) := by
  match n with
  | .O m => simp [toSint, toUint]
  | .I m => simp [toSint, toUint]; sorry_arith

theorem toUint_ofInt (sz: Nat) (n: Int):
    (ofInt sz n).toUint = mod2 n sz := by
  induction sz
  case zero =>
    simp [mod2]; sorry_arith
  case succ sz ih =>
    sorry

theorem toUint_ofNat (sz: Nat) (n: Nat):
    (OfNat.ofNat n: FinInt sz).toUint = mod2 n sz := by
  simp [OfNat.ofNat, toUint_ofInt]

theorem toSint_ofSint (sz: Nat)(n: Int):
    (ofInt (sz+1) n).toSint = smod2 n sz := by
  sorry

theorem ofIntAux_spec (sz: Nat) (n: Int):
    (FinInt.ofIntAux sz n).fst.toUint = mod2 n sz ∧
    (FinInt.ofIntAux sz n).snd = n / 2^sz := by
  induction sz
  case zero =>
    simp [FinInt.ofIntAux]; sorry_arith
  case succ sz ih =>
    simp [FinInt.ofIntAux, ih]; constructor
    . have h: (n / 2^sz % 2 = 0) ∨ (n / 2^sz %2 = 1) := by sorry
      match h with
      | .inl h => simp [h, ih]; sorry_arith
      | .inr h => simp [h, ih]; sorry_arith
    . sorry_arith

theorem eq_of_toUint_eq (a b: FinInt sz):
    a.toUint = b.toUint → a = b := by
  intros h <;> induction sz
  case zero =>
    cases a; cases b; rfl
  case succ sz ih =>
    cases a; case next sz da a' =>
    cases b; case next db b' =>
    cases da <;> cases db <;> simp [toUint] at h <;> simp
    . apply ih _ _ h
    . have h₁ := @toUint_lt _ a'; have h₂ := @toUint_ge _ b'; sorry_arith
    . have h₁ := @toUint_ge _ a'; have h₂ := @toUint_lt _ b'; sorry_arith
    . apply ih; sorry_arith

theorem eq_of_toUint_cong2 (a b: FinInt n):
    a.toUint ≡ b.toUint [2^n] → a = b := by
  intros h
  apply eq_of_toUint_eq
  apply cong2_to_eq n h toUint_bounds toUint_bounds

/-
### Logical operations
-/

def logic1 (f: Bool → Bool) (n: FinInt sz): FinInt sz :=
  match n with
  | .nil => .nil
  | .next bn n' => .next (f bn) (logic1 f n')

def comp: FinInt sz → FinInt sz :=
  logic1 (! ·)

def logic2 (f: Bool → Bool → Bool) (n m: FinInt sz): FinInt sz :=
  match n, m with
  | .nil, .nil => .nil
  | .next bn n', .next bm m' => .next (f bn bm) (logic2 f n' m')

def and: FinInt sz → FinInt sz → FinInt sz :=
  logic2 (· && ·)
def or: FinInt sz → FinInt sz → FinInt sz :=
  logic2 (· || ·)
def xor: FinInt sz → FinInt sz → FinInt sz :=
  logic2 (· != ·)

instance: HAnd (FinInt sz) (FinInt sz) (FinInt sz) where
  hAnd := FinInt.and

instance: HOr (FinInt sz) (FinInt sz) (FinInt sz) where
  hOr := FinInt.or

instance: HXor (FinInt sz) (FinInt sz) (FinInt sz) where
  hXor := FinInt.xor

theorem comp_toUint (n: FinInt sz):
    (comp n).toUint = 2^sz - 1 - n.toUint := by
  induction sz
  case zero =>
    cases n; simp
  case succ sz ih =>
    simp [comp] at ih
    cases n; case next sz bn n' =>
    cases bn <;> simp [ih]
    . sorry_arith
    . sorry_arith

/-
### Addition to n+1 bits
-/

def addfull (n m: FinInt sz): FinInt (sz+1) :=
  match sz, n, m with
  | 0, .nil, .nil => .O .nil
  | sz+1, .next bn n', .next bm m' =>
      match addfull n' m' with
      | .O r => .next (bn && bm) $ .next (bn != bm) r
      | .I r => .next (bn || bm) $ .next (bn == bm) r

protected theorem addfull_toUint (n m: FinInt sz):
    (addfull n m).toUint = n.toUint + m.toUint := by
  revert n m; induction sz <;> intros n m
  case zero =>
    cases n; cases m; simp [addfull]
  case succ sz ih =>
    cases n; case next sz dn n' =>
    cases m; case next dm m' =>
    simp [addfull]
    split
    case h_1 r h =>
      have h': r.toUint = n'.toUint + m'.toUint := by
        rw [←ih n' m']; simp [h]
      simp at h'
      cases dn <;> cases dm <;> simp [FinInt.toUint, h']
      <;> sorry_arith
    case h_2 r h =>
      have h': r.toUint = n'.toUint + m'.toUint - 2^sz := by
        rw [←ih n' m']
        simp [h, Int.add_comm, toSint]
      simp at h'
      cases dn <;> cases dm <;> simp [FinInt.toUint, h', toSint]
      <;> sorry_arith

theorem addfull_toSint (n m: FinInt (sz+1)):
  (addfull n m).toSint =
    match n, m with
    | .O n', .O m' =>
        n.toSint + m.toSint -- carry is always 0
    | .O n', .I m' =>
        match addfull n m with
        | .O _ => n.toSint + m.toSint + 2^(sz+1)
        | .I _ => n.toSint + m.toSint - 2^(sz+1)
    | .I n', .O m' =>
        match addfull n m with
        | .O _ => n.toSint + m.toSint + 2^(sz+1)
        | .I _ => n.toSint + m.toSint - 2^(sz+1)
    | .I n', .I m' =>
        n.toSint + m.toSint := by -- carry is always 1
  cases n; case next bn n' =>
  cases m; case next bm m' =>
  cases bn <;> cases bm <;> simp [addfull]
  case false.false =>
    match h: addfull n' m' with
    | .next br r =>
      cases br <;> simp [toSint, ←FinInt.addfull_toUint, h]
  case false.true =>
    match h: addfull n' m' with
    | .next br r =>
      have h' := FinInt.addfull_toUint n' m'
      rw [h] at h'
      cases br <;> simp at h' <;> simp [toSint]
      . simp [h']; sorry_arith
      . sorry_arith
  case true.false =>
    match h: addfull n' m' with
    | .next br r =>
      have h' := FinInt.addfull_toUint n' m'
      rw [h] at h'
      cases br <;> simp at h' <;> simp [toSint]
      . simp [h']; sorry_arith
      . sorry_arith
  case true.true =>
    match h: addfull n' m' with
    | .next br r =>
      have h' := FinInt.addfull_toUint n' m'
      rw [h] at h'
      cases br <;> simp at h' <;> simp [toSint, h'] <;> sorry_arith

theorem addfull_comm (n m: FinInt sz):
    addfull n m = addfull m n := by
  induction sz <;> cases n <;> cases m <;> simp [addfull]
  case succ.next.next sz bn n' ih bm m' =>
    simp [ih n' m']
    split <;> cases bn <;> cases bm <;> rfl

/-
### Addition to n bits
-/

def addc (n m: FinInt sz): FinInt sz × Bool :=
  match addfull n m with
  | .next carry n => (n, carry)

theorem addc_comm (n m: FinInt sz): addc n m = addc m n := by
  simp [addc, addfull_comm]

def add (n m: FinInt sz): FinInt sz :=
  match addfull n m with
  | .next carry n => n

theorem add_comm' (n m: FinInt sz): add n m = add m n := by
  simp [add, addfull_comm]

instance {sz}: HAdd (FinInt sz) (FinInt sz) (FinInt sz) where
  hAdd := add

theorem add_comm (n m: FinInt sz): n + m = m + n := by
  simp [HAdd.hAdd, add_comm']

protected theorem add_toUint_msb (n m: FinInt sz):
  (n + m).toUint =
    match addfull n m with
    | .O _ => n.toUint + m.toUint
    | .I _ => n.toUint + m.toUint - 2^sz := by
  simp [add]
  match h: addfull n m with
  | .next br r =>
    have h₁ := FinInt.addfull_toUint n m
    rw [h] at h₁
    have h₂: n+m = r := by simp [HAdd.hAdd, add, h]
    cases br <;> simp [h₂] at *
    . exact h₁
    . sorry_arith

theorem add_toUint_by_lt (n m: FinInt sz):
    n.toUint + m.toUint < 2^sz →
    (n + m).toUint = n.toUint + m.toUint := by
  intros h_bound
  simp [HAdd.hAdd, FinInt.add, FinInt.addfull_toUint]
  cases h₁: addfull n m
  case next carry r =>
    have h₂: (addfull n m).toUint = (next carry r).toUint := by simp [h₁]
    cases carry <;> simp at h₂
    . simp [←h₂, FinInt.addfull_toUint, HAdd.hAdd]
    . simp [FinInt.addfull_toUint] at h₂
      rw [h₂] at h_bound
      sorry_arith -- contradiction at h_bound

theorem add_toUint_rem (n m: FinInt sz):
    (n + m).toUint =
      if n.toUint + m.toUint < 2^sz then
        n.toUint + m.toUint
      else
        n.toUint + m.toUint - 2^sz := by
  simp [FinInt.add_toUint_msb]
  cases h_full: addfull n m
  case next br r' =>
  cases br <;> simp
  . have h := O_lt r'; rw [←h_full] at h
    simp [FinInt.addfull_toUint] at h; simp [h]
  . have h := I_not_lt r'; rw [←h_full] at h; sorry

theorem add_toUint (n m: FinInt sz):
    (n + m).toUint = mod2 (n.toUint + m.toUint) sz := by
  rw [add_toUint_rem]; split
  . simp [mod2_idem ⟨Int.add_ge_zero _ _ toUint_ge toUint_ge, by assumption⟩]
  . sorry_arith

theorem add_toUint_cong2 (n m: FinInt sz):
    (n + m).toUint ≡ n.toUint + m.toUint [2^sz] := by
  simp [cong2, toUint_mod2]; apply add_toUint

theorem add_toSint_msb (n m: FinInt (sz+1)):
  (n + m).toSint =
    match n, m with
    | .O n', .O m' =>
        match n + m with
        | .O _ => n.toSint + m.toSint
        | .I _ => n.toSint + m.toSint - 2^(sz+1)
    | .O n', .I m' =>
        n.toSint + m.toSint
    | .I n', .O m' =>
        n.toSint + m.toSint
    | .I n', .I m' =>
        match n + m with
        | .O _ => n.toSint + m.toSint + 2^(sz+1)
        | .I _ => n.toSint + m.toSint := by
  simp [add]
  have h := addfull_toSint n m
  cases n; case next bn n' =>
  cases m; case next bm m' =>
  cases bn <;> cases bm <;> simp [addfull] at *
  case false.false =>
    match h': addfull n' m' with
    | .next br r =>
      rw [h'] at h
      cases br <;> simp [bne, toSint] at * <;> sorry_arith
  case false.true =>
    match h': addfull n' m' with
    | .next br r =>
      rw [h'] at h
      cases br <;> simp [bne, BEq.beq, toSint] at * <;> sorry_arith
  case true.false =>
    match h': addfull n' m' with
    | .next br r =>
      rw [h'] at h
      cases br <;> simp [bne, BEq.beq, toSint] at * <;> sorry_arith
  case true.true =>
    match h': addfull n' m' with
    | .next br r =>
      rw [h'] at h
      cases br <;> simp [bne, toSint] at * <;> sorry_arith

def addv (n m: FinInt (sz+1)): FinInt (sz+1) × Bool :=
  match n, m with
  | .O n', .O m' =>
    match n + m with
    | .next msb r' => (.next msb r', msb)
  | .I n', .I m' =>
    match n + m with
    | .next msb r' => (.next msb r', !msb)
  | _, _ =>
      (n + m, false)

theorem addv_comm (n m: FinInt (sz+1)): addv n m = addv m n := by
  simp [addv]; cases n; cases m; case next.next bn n' bm m' =>
  simp [add_comm]; cases bn <;> cases bm <;> rfl

theorem addv_toSint (n m: FinInt (sz+1)):
    (addv n m).snd = false →
    (addv n m).fst.toSint = n.toSint + m.toSint := by
  intros h_nov
  simp [addv] at *
  have h := add_toSint_msb n m
  cases n; case next dn n' =>
  cases m; case next dm m' =>
  cases dn <;> cases dm <;> simp [h] at *
  case false.false =>
    match h: next false n' + next false m' with
    | .next br r =>
      rw [h] at h_nov
      cases br <;> simp at *
      rw [←h]; simp [add_toSint_msb]; simp [h]
  case true.true =>
    match h: next true n' + next true m' with
    | .next br r =>
      rw [h] at h_nov
      cases br <;> simp at *
      rw [←h]; simp [add_toSint_msb]; simp [h]

/-
### Negation operator
-/

def neg (n: FinInt sz): FinInt sz :=
  comp n + 1

instance: Neg (FinInt sz) where
  neg := neg

theorem neg_toUint (n: FinInt sz):
    (-n).toUint = mod2 (-n.toUint) sz := by
  sorry

theorem neg_toUint_cong2 (n: FinInt sz):
    (-n).toUint ≡ -n.toUint [2^sz] := by
  simp [cong2, toUint_mod2]; apply neg_toUint

theorem neg_minusOne {sz: Nat}:
    (-1: FinInt sz) = minusOne := by
  match H: sz with
  | 0 => decide
  | sz'+1 =>
      have h: sz' + 1 > 0 := by sorry_arith
      apply eq_of_toUint_cong2
      simp [toUint_minusOne]
      simp [neg_toUint]
      apply cong2_mod2_left
      simp [ofInt_1, toUint_one h]
      sorry_arith

theorem comp_eq_xor_minusOne (n: FinInt sz):
    comp n = n ^^^ -1 := by
  simp [neg_minusOne, HXor.hXor]
  induction sz <;> simp [comp, xor, logic1, logic2, minusOne] at *
  case zero =>
    cases n; simp
  case succ sz ih =>
    match n with
    | .I m => simp [logic1, logic2, ih]
    | .O m => simp [logic1, logic2, ih]

/-
### Subtraction
-/

def sub (n m: FinInt sz): FinInt sz :=
  n + -m

instance: Sub (FinInt sz) where
  sub := sub

theorem sub_toUint (n m: FinInt sz):
    (n - m).toUint = mod2 (n.toUint - m.toUint) sz := by
  sorry

theorem sub_toUint_cong2 (n: FinInt sz):
    (n - m).toUint ≡ n.toUint - m.toUint [2^sz] := by
  simp [cong2, toUint_mod2]; apply sub_toUint

/-
### Sign extensions
-/

-- TODO: The MSB first encoding makes it really hard to do zext structurally
-- without type casts
def zext {sz₁: Nat} (sz₂: Nat) (n: FinInt sz₁): FinInt sz₂ :=
  .ofInt sz₂ n.toUint

theorem zext_toUint: (@zext sz₁ sz₂ n).toUint = mod2 n.toUint sz₂ := by
  simp [zext, toUint_ofInt]

theorem zext_toUint': sz₁ < sz₂ → (@zext sz₁ sz₂ n).toUint = n.toUint := by
  sorry
  /-
  simp [zext, toUint_ofInt]
  intros h
  apply mod2_idem ⟨toUint_ge, _⟩
  apply Int.lt_trans (2^sz₁) toUint_lt
  exact (sorry: 2^sz₁ < 2^sz₂)
  -/

/-
### Select operation
-/

def select {α: Type} (b: FinInt 1) (a₁ a₂: α): α :=
  if b.toUint = 1 then a₁ else a₂

theorem bool_cases (b: FinInt 1):
    b = .ofInt _ 0 ∨ b = .ofInt _ 1 :=
  match b with
  | .O .nil => .inl rfl
  | .I .nil => .inr rfl

end FinInt


/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import data.fintype.option
import data.fintype.pi
import data.fintype.sum
import algebra.big_operators.basic

/-!
# The Hales-Jewett theorem

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

We prove the Hales-Jewett theorem and deduce Van der Waerden's theorem as a corollary.

The Hales-Jewett theorem is a result in Ramsey theory dealing with *combinatorial lines*. Given
an 'alphabet' `α : Type*` and `a b : α`, an example of a combinatorial line in `α^5` is
`{ (a, x, x, b, x) | x : α }`. See `combinatorics.line` for a precise general definition. The
Hales-Jewett theorem states that for any fixed finite types `α` and `κ`, there exists a (potentially
huge) finite type `ι` such that whenever `ι → α` is `κ`-colored (i.e. for any coloring
`C : (ι → α) → κ`), there exists a monochromatic line. We prove the Hales-Jewett theorem using
the idea of *color focusing* and a *product argument*. See the proof of
`combinatorics.line.exists_mono_in_high_dimension'` for details.

The version of Van der Waerden's theorem in this file states that whenever a commutative monoid `M`
is finitely colored and `S` is a finite subset, there exists a monochromatic homothetic copy of `S`.
This follows from the Hales-Jewett theorem by considering the map `(ι → S) → M` sending `v`
to `∑ i : ι, v i`, which sends a combinatorial line to a homothetic copy of `S`.

## Main results

- `combinatorics.line.exists_mono_in_high_dimension`: the Hales-Jewett theorem.
- `combinatorics.exists_mono_homothetic_copy`: a generalization of Van der Waerden's theorem.

## Implementation details

For convenience, we work directly with finite types instead of natural numbers. That is, we write
`α, ι, κ` for (finite) types where one might traditionally use natural numbers `n, H, c`. This
allows us to work directly with `α`, `option α`, `(ι → α) → κ`, and `ι ⊕ ι'` instead of `fin n`,
`fin (n+1)`, `fin (c^(n^H))`, and `fin (H + H')`.

## Todo

- Prove a finitary version of Van der Waerden's theorem (either by compactness or by modifying the
current proof).

- One could reformulate the proof of Hales-Jewett to give explicit upper bounds on the number of
coordinates needed.

## Tags

combinatorial line, Ramsey theory, arithmetic progession

### References

* https://en.wikipedia.org/wiki/Hales%E2%80%93Jewett_theorem

-/

open_locale classical
open_locale big_operators

universes u v

namespace combinatorics

/-- The type of combinatorial lines. A line `l : line α ι` in the hypercube `ι → α` defines a
function `α → ι → α` from `α` to the hypercube, such that for each coordinate `i : ι`, the function
`λ x, l x i` is either `id` or constant. We require lines to be nontrivial in the sense that
`λ x, l x i` is `id` for at least one `i`.

Formally, a line is represented by the function `l.idx_fun : ι → option α` which says whether
`λ x, l x i` is `id` (corresponding to `l.idx_fun i = none`) or constantly `y` (corresponding to
`l.idx_fun i = some y`).

When `α` has size `1` there can be many elements of `line α ι` defining the same function. -/
structure line (α ι : Type*) :=
(idx_fun : ι → option α)
(proper : ∃ i, idx_fun i = none)

namespace line

/- This lets us treat a line `l : line α ι` as a function `α → ι → α`. -/
instance (α ι) : has_coe_to_fun (line α ι) (λ _, α → ι → α) :=
⟨λ l x i, (l.idx_fun i).get_or_else x⟩

/-- A line is monochromatic if all its points are the same color. -/
def is_mono {α ι κ} (C : (ι → α) → κ) (l : line α ι) : Prop :=
∃ c, ∀ x, C (l x) = c

/-- The diagonal line. It is the identity at every coordinate. -/
def diagonal (α ι) [nonempty ι] : line α ι :=
{ idx_fun := λ _, none,
  proper  := ⟨classical.arbitrary ι, rfl⟩ }

instance (α ι) [nonempty ι] : inhabited (line α ι) := ⟨diagonal α ι⟩

/-- The type of lines that are only one color except possibly at their endpoints. -/
structure almost_mono {α ι κ : Type*} (C : (ι → option α) → κ) :=
(line : line (option α) ι)
(color : κ)
(has_color : ∀ x : α, C (line (some x)) = color)

instance {α ι κ : Type*} [nonempty ι] [inhabited κ] :
  inhabited (almost_mono (λ v : ι → option α, (default : κ))) :=
⟨{ line      := default,
   color     := default,
   has_color := λ _, rfl }⟩

/-- The type of collections of lines such that
- each line is only one color except possibly at its endpoint
- the lines all have the same endpoint
- the colors of the lines are distinct.
Used in the proof `exists_mono_in_high_dimension`. -/
structure color_focused {α ι κ : Type*} (C : (ι → option α) → κ) :=
(lines : multiset (almost_mono C))
(focus : ι → option α)
(is_focused : ∀ p ∈ lines, almost_mono.line p none = focus)
(distinct_colors : (lines.map almost_mono.color).nodup)

instance {α ι κ} (C : (ι → option α) → κ) : inhabited (color_focused C) :=
⟨⟨0, λ _, none, λ _, false.elim, multiset.nodup_zero⟩⟩

/-- A function `f : α → α'` determines a function `line α ι → line α' ι`. For a coordinate `i`,
`l.map f` is the identity at `i` if `l` is, and constantly `f y` if `l` is constantly `y` at `i`. -/
def map {α α' ι} (f : α → α') (l : line α ι) : line α' ι :=
{ idx_fun := λ i, (l.idx_fun i).map f,
  proper  := ⟨l.proper.some, by rw [l.proper.some_spec, option.map_none'] ⟩ }

/-- A point in `ι → α` and a line in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def vertical {α ι ι'} (v : ι → α) (l : line α ι') : line α (ι ⊕ ι') :=
{ idx_fun := sum.elim (some ∘ v) l.idx_fun,
  proper  := ⟨sum.inr l.proper.some, l.proper.some_spec⟩ }

/-- A line in `ι → α` and a point in `ι' → α` determine a line in `ι ⊕ ι' → α`. -/
def horizontal {α ι ι'} (l : line α ι) (v : ι' → α) : line α (ι ⊕ ι') :=
{ idx_fun := sum.elim l.idx_fun (some ∘ v),
  proper  := ⟨sum.inl l.proper.some, l.proper.some_spec⟩ }

/-- One line in `ι → α` and one in `ι' → α` together determine a line in `ι ⊕ ι' → α`. -/
def prod {α ι ι'} (l : line α ι) (l' : line α ι') : line α (ι ⊕ ι') :=
{ idx_fun := sum.elim l.idx_fun l'.idx_fun,
  proper  := ⟨sum.inl l.proper.some, l.proper.some_spec⟩ }

lemma apply {α ι} (l : line α ι) (x : α) : l x = λ i, (l.idx_fun i).get_or_else x := rfl

lemma apply_none {α ι} (l : line α ι) (x : α) (i : ι) (h : l.idx_fun i = none) : l x i = x :=
by simp only [option.get_or_else_none, h, l.apply]

lemma apply_of_ne_none {α ι} (l : line α ι) (x : α) (i : ι) (h : l.idx_fun i ≠ none) :
  some (l x i) = l.idx_fun i :=
by rw [l.apply, option.get_or_else_of_ne_none h]

@[simp] lemma map_apply {α α' ι} (f : α → α') (l : line α ι) (x : α) :
  l.map f (f x) = f ∘ l x :=
by simp only [line.apply, line.map, option.get_or_else_map]

@[simp] lemma vertical_apply {α ι ι'} (v : ι → α) (l : line α ι') (x : α) :
  l.vertical v x = sum.elim v (l x) :=
by { funext i, cases i; refl }

@[simp] lemma horizontal_apply {α ι ι'} (l : line α ι) (v : ι' → α) (x : α) :
  l.horizontal v x = sum.elim (l x) v :=
by { funext i, cases i; refl }

@[simp]

@[simp] lemma diagonal_apply {α ι} [nonempty ι] (x : α) :
  line.diagonal α ι x = λ i, x :=
by simp_rw [line.apply, line.diagonal, option.get_or_else_none]

/-- The Hales-Jewett theorem. This version has a restriction on universe levels which is necessary
for the proof. See `exists_mono_in_high_dimension` for a fully universe-polymorphic version. -/
private theorem exists_mono_in_high_dimension' :
  ∀ (α : Type u) [finite α] (κ : Type (max v u)) [finite κ],
  ∃ (ι : Type) (_ : fintype ι), ∀ C : (ι → α) → κ, ∃ l : line α ι, l.is_mono C :=
-- The proof proceeds by induction on `α`.
finite.induction_empty_option
-- We have to show that the theorem is invariant under `α ≃ α'` for the induction to work.
(λ α α' e, forall_imp $ λ κ, forall_imp $ λ _, Exists.imp $ λ ι, Exists.imp $ λ _ h C,
  let ⟨l, c, lc⟩ := h (λ v, C (e ∘ v)) in
  ⟨l.map e, c, e.forall_congr_left.mp $ λ x, by rw [←lc x, line.map_apply]⟩)
begin -- This deals with the degenerate case where `α` is empty.
  introsI κ _,
  by_cases h : nonempty κ,
  { resetI, exact ⟨unit, infer_instance, λ C, ⟨default, classical.arbitrary _, pempty.rec _⟩⟩, },
  { exact ⟨empty, infer_instance, λ C, (h ⟨C (empty.rec _)⟩).elim⟩, }
end
begin -- Now we have to show that the theorem holds for `option α` if it holds for `α`.
  introsI α _ ihα κ _,
  casesI nonempty_fintype κ,
-- Later we'll need `α` to be nonempty. So we first deal with the trivial case where `α` is empty.
-- Then `option α` has only one element, so any line is monochromatic.
  by_cases h : nonempty α,
  work_on_goal 2 { refine ⟨unit, infer_instance, λ C, ⟨diagonal _ _, C (λ _, none), _⟩⟩,
    rintros (_ | ⟨a⟩), refl, exact (h ⟨a⟩).elim, },
-- The key idea is to show that for every `r`, in high dimension we can either find
-- `r` color focused lines or a monochromatic line.
  suffices key : ∀ r : ℕ, ∃ (ι : Type) (_ : fintype ι), ∀ C : (ι → (option α)) → κ,
    (∃ s : color_focused C, s.lines.card = r) ∨ (∃ l, is_mono C l),
-- Given the key claim, we simply take `r = |κ| + 1`. We cannot have this many distinct colors so
-- we must be in the second case, where there is a monochromatic line.
  { obtain ⟨ι, _inst, hι⟩ := key (fintype.card κ + 1),
    refine ⟨ι, _inst, λ C, (hι C).resolve_left _⟩,
    rintro ⟨s, sr⟩,
    apply nat.not_succ_le_self (fintype.card κ),
    rw [←nat.add_one, ←sr, ←multiset.card_map, ←finset.card_mk],
    exact finset.card_le_univ ⟨_, s.distinct_colors⟩ },
-- We now prove the key claim, by induction on `r`.
  intro r,
  induction r with r ihr,
-- The base case `r = 0` is trivial as the empty collection is color-focused.
  { exact ⟨empty, infer_instance, λ C, or.inl ⟨default, multiset.card_zero⟩⟩, },
-- Supposing the key claim holds for `r`, we need to show it for `r+1`. First pick a high enough
-- dimension `ι` for `r`.
  obtain ⟨ι, _inst, hι⟩ := ihr,
  resetI,
-- Then since the theorem holds for `α` with any number of colors, pick a dimension `ι'` such that
-- `ι' → α` always has a monochromatic line whenever it is `(ι → option α) → κ`-colored.
  specialize ihα ((ι → option α) → κ),
  obtain ⟨ι', _inst, hι'⟩ := ihα,
  resetI,
-- We claim that `ι ⊕ ι'` works for `option α` and `κ`-coloring.
  refine ⟨ι ⊕ ι', infer_instance, _⟩,
  intro C,
-- A `κ`-coloring of `ι ⊕ ι' → option α` induces an `(ι → option α) → κ`-coloring of `ι' → α`.
  specialize hι' (λ v' v, C (sum.elim v (some ∘ v'))),
-- By choice of `ι'` this coloring has a monochromatic line `l'` with color class `C'`, where
-- `C'` is a `κ`-coloring of `ι → α`.
  obtain ⟨l', C', hl'⟩ := hι',
-- If `C'` has a monochromatic line, then so does `C`. We use this in two places below.
  have mono_of_mono : (∃ l, is_mono C' l) → (∃ l, is_mono C l),
  { rintro ⟨l, c, hl⟩,
    refine ⟨l.horizontal (some ∘ l' (classical.arbitrary α)), c, λ x, _⟩,
    rw [line.horizontal_apply, ←hl, ←hl'], },
-- By choice of `ι`, `C'` either has `r` color-focused lines or a monochromatic line.
  specialize hι C',
  rcases hι with ⟨s, sr⟩ | _,
-- By above, we are done if `C'` has a monochromatic line.
  work_on_goal 2 { exact or.inr (mono_of_mono hι) },
-- Here we assume `C'` has `r` color focused lines. We split into cases depending on whether one of
-- these `r` lines has the same color as the focus point.
  by_cases h : ∃ p ∈ s.lines, (p : almost_mono _).color = C' s.focus,
-- If so then this is a `C'`-monochromatic line and we are done.
  { obtain ⟨p, p_mem, hp⟩ := h,
    refine or.inr (mono_of_mono ⟨p.line, p.color, _⟩),
    rintro (_ | _), rw [hp, s.is_focused p p_mem], apply p.has_color, },
-- If not, we get `r+1` color focused lines by taking the product of the `r` lines with `l'` and
-- adding to this the vertical line obtained by the focus point and `l`.
  refine or.inl ⟨⟨(s.lines.map _).cons ⟨(l'.map some).vertical s.focus, C' s.focus, λ x, _⟩,
    sum.elim s.focus (l'.map some none), _, _⟩, _⟩,
-- The vertical line is almost monochromatic.
  { rw [vertical_apply, ←congr_fun (hl' x), line.map_apply], },
  { refine λ p, ⟨p.line.prod (l'.map some), p.color, λ x, _⟩,
-- The product lines are almost monochromatic.
    rw [line.prod_apply, line.map_apply, ←p.has_color, ←congr_fun (hl' x)], },
-- Our `r+1` lines have the same endpoint.
  { simp_rw [multiset.mem_cons, multiset.mem_map],
    rintros _ (rfl | ⟨q, hq, rfl⟩),
    { rw line.vertical_apply, },
    { rw [line.prod_apply, s.is_focused q hq], }, },
-- Our `r+1` lines have distinct colors (this is why we needed to split into cases above).
  { rw [multiset.map_cons, multiset.map_map, multiset.nodup_cons, multiset.mem_map],
    exact ⟨λ ⟨q, hq, he⟩, h ⟨q, hq, he⟩, s.distinct_colors⟩, },
-- Finally, we really do have `r+1` lines!
  { rw [multiset.card_cons, multiset.card_map, sr], },
end

/-- The Hales-Jewett theorem: for any finite types `α` and `κ`, there exists a finite type `ι` such
that whenever the hypercube `ι → α` is `κ`-colored, there is a monochromatic combinatorial line. -/
theorem exists_mono_in_high_dimension (α : Type u) [finite α] (κ : Type v) [finite κ] :
  ∃ (ι : Type) [fintype ι], ∀ C : (ι → α) → κ, ∃ l : line α ι, l.is_mono C :=
let ⟨ι, ιfin, hι⟩ := exists_mono_in_high_dimension' α (ulift κ)
in ⟨ι, ιfin, λ C, let ⟨l, c, hc⟩ := hι (ulift.up ∘ C) in ⟨l, c.down, λ x, by rw ←hc⟩ ⟩

end line

/-- A generalization of Van der Waerden's theorem: if `M` is a finitely colored commutative
monoid, and `S` is a finite subset, then there exists a monochromatic homothetic copy of `S`. -/
theorem exists_mono_homothetic_copy {M κ : Type*} [add_comm_monoid M] (S : finset M) [finite κ]
  (C : M → κ) :
  ∃ (a > 0) (b : M) (c : κ), ∀ s ∈ S, C (a • s + b) = c :=
begin
  obtain ⟨ι, _inst, hι⟩ := line.exists_mono_in_high_dimension S κ,
  resetI,
  specialize hι (λ v, C $ ∑ i, v i),
  obtain ⟨l, c, hl⟩ := hι,
  set s : finset ι := { i ∈ finset.univ | l.idx_fun i = none } with hs,
  refine ⟨s.card, finset.card_pos.mpr ⟨l.proper.some, _⟩,
    ∑ i in sᶜ, ((l.idx_fun i).map coe).get_or_else 0, c, _⟩,
  { rw [hs, finset.sep_def, finset.mem_filter], exact ⟨finset.mem_univ _, l.proper.some_spec⟩, },
  intros x xs,
  rw ←hl ⟨x, xs⟩,
  clear hl, congr,
  rw ←finset.sum_add_sum_compl s,
  congr' 1,
  { rw ←finset.sum_const,
    apply finset.sum_congr rfl,
    intros i hi,
    rw [hs, finset.sep_def, finset.mem_filter] at hi,
    rw [l.apply_none _ _ hi.right, subtype.coe_mk], },
  { apply finset.sum_congr rfl,
    intros i hi,
    rw [hs, finset.sep_def, finset.compl_filter, finset.mem_filter] at hi,
    obtain ⟨y, hy⟩ := option.ne_none_iff_exists.mp hi.right,
    simp_rw [line.apply, ←hy, option.map_some', option.get_or_else_some], },
end

end combinatorics


/-
Copyright (c) 2022 Moritz Doll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Moritz Doll, Kalle Kytölä
-/

import analysis.normed.field.basic
import analysis.convex.basic
import linear_algebra.sesquilinear_form
import topology.algebra.module.weak_dual

/-!
# Polar set

In this file we define the polar set. There are different notions of the polar, we will define the
*absolute polar*. The advantage over the real polar is that we can define the absolute polar for
any bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`, where `𝕜` is a normed commutative ring and
`E` and `F` are modules over `𝕜`.

## Main definitions

* `linear_map.polar`: The polar of a bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`.

## Main statements

* `linear_map.polar_eq_Inter`: The polar as an intersection.
* `linear_map.subset_bipolar`: The polar is a subset of the bipolar.
* `linear_map.polar_weak_closed`: The polar is closed in the weak topology induced by `B.flip`.

## References

* [H. H. Schaefer, *Topological Vector Spaces*][schaefer1966]

## Tags

polar
-/

variables {𝕜 E F : Type*}

namespace linear_map

section normed_ring

variables [normed_comm_ring 𝕜] [add_comm_monoid E] [add_comm_monoid F]
variables [module 𝕜 E] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

/-- The (absolute) polar of `s : set E` is given by the set of all `y : F` such that `∥B x y∥ ≤ 1`
for all `x ∈ s`.-/
def polar (s : set E) : set F :=
  {y : F | ∀ x ∈ s, ∥B x y∥ ≤ 1 }

lemma polar_mem_iff (s : set E) (y : F) :
  y ∈ B.polar s ↔ ∀ x ∈ s, ∥B x y∥ ≤ 1 := iff.rfl

lemma polar_mem (s : set E) (y : F) (hy : y ∈ B.polar s) :
  ∀ x ∈ s, ∥B x y∥ ≤ 1 := hy

@[simp] lemma zero_mem_polar (s : set E) :
  (0 : F) ∈ B.polar s :=
λ _ _, by simp only [map_zero, norm_zero, zero_le_one]

lemma polar_eq_Inter {s : set E} :
  B.polar s = ⋂ x ∈ s, {y : F | ∥B x y∥ ≤ 1} :=
by { ext, simp only [polar_mem_iff, set.mem_Inter, set.mem_set_of_eq] }

/-- The map `B.polar : set E → set F` forms an order-reversing Galois connection with
`B.flip.polar : set F → set E`. We use `order_dual.to_dual` and `order_dual.of_dual` to express
that `polar` is order-reversing. -/
lemma polar_gc : galois_connection (order_dual.to_dual ∘ B.polar)
  (B.flip.polar ∘ order_dual.of_dual) :=
λ s t, ⟨λ h _ hx _ hy, h hy _ hx, λ h _ hx _ hy, h hy _ hx⟩

@[simp] lemma polar_Union {ι} {s : ι → set E} : B.polar (⋃ i, s i) = ⋂ i, B.polar (s i) :=
B.polar_gc.l_supr

@[simp] lemma polar_union {s t : set E} : B.polar (s ∪ t) = B.polar s ∩ B.polar t :=
B.polar_gc.l_sup

lemma polar_antitone : antitone (B.polar : set E → set F) := B.polar_gc.monotone_l

@[simp] lemma polar_empty : B.polar ∅ = set.univ := B.polar_gc.l_bot

@[simp]

lemma subset_bipolar (s : set E) : s ⊆ B.flip.polar (B.polar s) :=
λ x hx y hy, by { rw B.flip_apply, exact hy x hx }

@[simp] lemma tripolar_eq_polar (s : set E) : B.polar (B.flip.polar (B.polar s)) = B.polar s :=
begin
  refine (B.polar_antitone (B.subset_bipolar s)).antisymm _,
  convert subset_bipolar B.flip (B.polar s),
  exact B.flip_flip.symm,
end

/-- The polar set is closed in the weak topology induced by `B.flip`. -/
lemma polar_weak_closed (s : set E) :
  @is_closed _ (weak_bilin.topological_space B.flip) (B.polar s) :=
begin
  rw polar_eq_Inter,
  refine is_closed_Inter (λ x, is_closed_Inter (λ _, _)),
  exact is_closed_le (weak_bilin.eval_continuous B.flip x).norm continuous_const,
end

end normed_ring

section nondiscrete_normed_field

variables [nondiscrete_normed_field 𝕜] [add_comm_monoid E] [add_comm_monoid F]
variables [module 𝕜 E] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

lemma polar_univ (h : separating_right B) :
  B.polar set.univ = {(0 : F)} :=
begin
  rw set.eq_singleton_iff_unique_mem,
  refine ⟨by simp only [zero_mem_polar], λ y hy, h _ (λ x, _)⟩,
  refine norm_le_zero_iff.mp (le_of_forall_le_of_dense $ λ ε hε, _),
  rcases normed_field.exists_norm_lt 𝕜 hε with ⟨c, hc, hcε⟩,
  calc ∥B x y∥ = ∥c∥ * ∥B (c⁻¹ • x) y∥ :
    by rw [B.map_smul, linear_map.smul_apply, algebra.id.smul_eq_mul, norm_mul, norm_inv,
      mul_inv_cancel_left₀ hc.ne']
  ... ≤ ε * 1 : mul_le_mul hcε.le (hy _ trivial) (norm_nonneg _) hε.le
  ... = ε : mul_one _
end

end nondiscrete_normed_field

end linear_map