/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author : María Inés de Frutos-Fernández
-/

import topology.basic

noncomputable theory

/-!
# Espacios topológicos en Lean

Para cualquier tipo `α : Type`,una topología en `α` está definida en la clase `topological_space`.
El conjunto `univ` contiene todos los elementos de un tipo.

```
@[protect_proj] class topological_space (α : Type u) :=
(is_open        : set α → Prop) -- Qué conjuntos son abiertos en esta topología.
(is_open_univ   : is_open univ) -- univ es abierto.
(is_open_inter  : ∀s t, is_open s → is_open t → is_open (s ∩ t))
-- la intersección de dos abiertos es un conjunto abierto.
(is_open_sUnion : ∀s, (∀t∈s, is_open t) → is_open (⋃₀ s))
-- la unión arbitraria de abiertos es un abierto.
```
-/

universe u

namespace topological_space

open set

open_locale classical

variables (X : Type u)

-- Recordad el truco `{!}` para acceder al menú de sugerencias.

/-- La topología discreta es aquella en la que todo subconjunto de `X` (es decir, todo término de
  tipo `set X`) es abierto. -/
def discreta : topological_space X :=
sorry

/-- La topología indiscreta o trivial es aquella en la que los únicos abiertos son `X` y `∅`. -/
def indiscreta : topological_space X :=
sorry

/-- La función `id : (X, discreta) ----->  (X, indiscreta)` es continuais continuous . -/
example : @continuous X X (discreta X) (indiscreta X) id :=
sorry

/-- Sin embargo, `id : (X, indiscreta) ------> (X, discreta)` no lo es. -/
example (x y : X) (h : x ≠ y) : ¬ @continuous X X (indiscreta X) (discreta X) id :=
begin
  sorry
end

end topological_space


import data.finsupp .to_finsupp
open classical
local attribute [instance] prop_decidable
noncomputable theory
local infix ^ := monoid.pow
universe u
variable α : Type u
namespace multiset
--simp correct?
theorem multiset.not_mem_empty (a : α) : a ∉ (∅ : finset α) := id --why does this work?

lemma map_id_eq {f : multiset α} : f.map id = f :=
begin
  apply multiset.induction_on f,
  {
    simp
  },
  {
    simp
  }
end

lemma prod_mul_prod_eq_add_prod [comm_monoid α] {a b : multiset α} : a.prod * b.prod = (a + b).prod :=
begin
  simp,
end

open finsupp

def to_finsupp {α : Type u} (m : multiset α) : α →₀ ℕ :=
(m.map $ λa, single a 1).sum

lemma to_finsupp_add {α : Type u} (m n : multiset α) :
   (m + n).to_finsupp = m.to_finsupp + n.to_finsupp :=
calc (m + n).to_finsupp = ((m.map $ λa, single a 1) + (n.map $ λa, single a 1)).sum :
    by rw [← multiset.map_add]; refl
  ... = m.to_finsupp + n.to_finsupp :
    by rw [multiset.sum_add]; refl

lemma to_finsupp_prod {α : Type*} [comm_monoid α] (m : multiset α) :
m.prod = (finsupp.prod (m.to_finsupp) (λ k n, k ^ n) ) :=
begin
  apply multiset.induction_on m,
  {
    simp [to_finsupp, prod_zero_index],
  },
  {
    intros a s h1,
    simp [*, to_finsupp] at *,
    rw [prod_add_index, prod_single_index],
    repeat {simp [pow_add]}
  }
end

lemma to_finsupp_support {α : Type u} (m : multiset α) : m.to_finsupp.support = m.to_finset :=
begin
  apply multiset.induction_on m,
  {
    simp [*, to_finsupp, to_finset] at *,
    exact rfl,
  },
  {
    intros a s h1,
    simp [*, to_finsupp, to_finset] at *,
    apply finset.subset.antisymm,
    {
       intros y h2,
       have h3 : support (single a 1 + sum (map (λ (a : α), single a 1) s)) ⊆ support (single a 1) ∪ support (sum (map (λ (a : α), single a 1) s)),
       from support_add,
       have h4 : y ∈ support (single a 1) ∪ support (sum (map (λ (a : α), single a 1) s)),
       from mem_of_subset h3 h2,
       rw [h1, finset.mem_union] at h4,
       cases h4,
       {
         rw [support_single_ne_zero] at h4,
         simp * at *,
         exact ne.symm zero_ne_one,
       },
       {
         simp,
         by_cases h5 : (y = a),
         {
           simp *,
         },
         {
           have h5 : y ∈ s,
           {
             rw ←mem_erase_dup,
             exact h4,
           },
           simp *,
         }
       }
    },
    {
      intros y h2,
      have h3 : support (single a 1 + sum (map (λ (a : α), single a 1) s)) ⊆ support (single a 1) ∪ support (sum (map (λ (a : α), single a 1) s)),
      from support_add,

      have h4 : y ∈ support (single a 1) ∪ support (sum (map (λ (a : α), single a 1) s)),
      {
        rw [finset.mem_union],
        by_cases h4 : (y = a),
        {
          subst h4,
          rw [support_single_ne_zero],
          simp,
          exact ne.symm zero_ne_one,
        },
        {
          rw h1,
          have h5 :  y ∈  erase_dup s,
          {
            rw mem_erase_dup,
            have : y ∈ erase_dup (a :: s),
            exact h2,
            rw mem_erase_dup at this,
            simp * at *,

          },
          simp * at *,
        }
      },
      rw [h1, finset.mem_union] at h4,
      have h5 :   support (single a 1 + sum (map (λ (a : α), single a 1) s)) =
      support (single a 1) ∪ support (sum (map (λ (a : α), single a 1) s)),
      {
        apply finset.subset.antisymm,
        {
          exact h3,
        },
        {
          intros x h5,
          simp at h5,
          cases h5,
          {
            simp,
            by_contradiction h6,
            have : (single a 1).val x = 0,
            from nat.eq_zero_of_add_eq_zero_right h6,
            exact h5 this,
          },
          {
            simp,
            by_contradiction h6,
            have : (sum (map (λ (a : α), single a 1) s)).val x = 0,
            from nat.eq_zero_of_add_eq_zero_left h6,
            exact h5 this,
          },
        }
      },
      rw h5,
      simp * at *,
    }
  },

end

lemma to_finsupp_support_subset {α : Type u} (m : multiset α) : m.to_finsupp.support.val ⊆ m :=
begin
  intros x h1,
  rw to_finsupp_support at h1,
  rw ← mem_to_finset,
  exact h1,
end
lemma to_finsupp_predicate {α : Type u} (m : multiset α) (p : α → Prop) :
(∀x ∈ m, p x) ↔ (∀x ∈ (m.to_finsupp).support, p x) :=
iff.intro
  begin
    intros h1 x h2,
    rw [to_finsupp_support, mem_to_finset] at h2,
    exact h1 _ h2,
  end
  begin
    intros h1 x h2,
    rw [to_finsupp_support] at h1,
    have h3 : x ∈ to_finset m → p x,
    from h1 x,
    rw [mem_to_finset] at h3,
    exact h3 h2,
  end

lemma sum_map_eq_zero_iff_forall_eq_zero (f : α → multiset α) (s : multiset α) : sum (map f s) = 0 ↔ ∀ x ∈ s, f x = 0 :=
begin
  split,
  {
    apply multiset.induction_on s,
    {
      simp * at *,
    },
    {
      intros a s h1 h2 y h3,
      simp * at *,
      cases h3,
      {
        simp * at *,
      },
      {
        exact h1 y h3,
      }
    }
  },
  {
    intros h1,
    revert h1,
    apply multiset.induction_on s,
    {
      simp * at *,
    },
    {
      intros a s h1 h2,
      simp * at *,
      apply h1,
      intros x h3,
      apply h2,
      simp * at *,
    }
  }
end

lemma sum_map_singleton {α : Type u} {s : multiset α} : sum (map (λ x, {x}) s) = s :=
begin
  apply multiset.induction_on s,
  {
    simp * at *,
  },
  {
    intros a s h1,
    simp * at *,
    rw add_comm,
    exact singleton_add _ _,
  }
end

lemma finset_prod_eq_map_prod {α β : Type u} [comm_monoid β] {s : finset α} (f : α → β) : finset.prod s f = (map f s.val).prod :=
begin
  exact rfl, --nice
end

lemma prod_ne_zero_of_forall_mem_ne_zero {α : Type u} [integral_domain α] (s : multiset α) (h : ∀x : α, x ∈ s → x ≠ 0) : s.prod ≠ 0 :=
begin
  revert h,
  apply multiset.induction_on s,
  {
    simp,
  },
  {
    intros a s h1 h2,
    simp * at *,
    apply mul_ne_zero,
    {
      apply h2 a,
      simp,
    },
    {
      apply h1,
      intros x h3,
      apply h2 x,
      simp *,
    }
  }
end

lemma sub_erase_dup_add_erase_dup_eq {α : Type u} (s : multiset α) : s - s.erase_dup + s.erase_dup = s :=
multiset.sub_add_cancel (erase_dup_le _)

lemma sum_map_mul {α β: Type u} [semiring β] (a : β) (f : α → β) (s : multiset α):
  multiset.sum (multiset.map (λ (b : α), a * f b) s) =
  a * multiset.sum (multiset.map (λ (b : α), f b) s):=
begin
  apply multiset.induction_on s,
  {
    simp * at *,
  },
  {
    intros a s h,
    simp [*, mul_add],
  }
end

--Naming correct or dvd_sum_of_forall_mem_dvd
lemma dvd_sum [comm_semiring α] (s : multiset α) (p : α) : (∀x ∈ s, p ∣ x) → p ∣ s.sum :=
begin
  apply multiset.induction_on s,
  {
    simp * at *,
  },
  {
    intros a s h1 h2,
    simp * at *,
    apply dvd_add,
    {
      apply h2,
      simp,
    },
    {
      apply h1,
      intros x h3,
      apply h2,
      simp [h3],
    }
  }
end

lemma forall_pow_count_dvd_prod {α : Type u} [comm_semiring α] (s : multiset α) : ∀x : α , x ^ count x s ∣ prod s :=
begin
  intros x,
  by_cases hx : x ∈ s,
  {
    apply multiset.induction_on s,
    {
      simp,
    },
    {
      intros a s h,
      simp,
      by_cases h1 : x = a,
      {
        subst h1,
        rw [count_cons_self, pow_succ],
        apply mul_dvd_mul_left,
        assumption,
      },
      {
        rw count_cons_of_ne h1,
        apply dvd_mul_of_dvd_right,
        exact h,
      }
    }
  },
  {
    rw ←count_eq_zero at hx,
    simp *,
  }
end

lemma pow_count_sub_one_dvd_pow_count {α : Type u} [comm_semiring α] (s : multiset α) (x : α) : x ^ (count x s - 1) ∣ x ^ count x s :=
begin
  by_cases h1 : (count x s) ≥ 1,
  {
    rw [←nat.sub_add_cancel h1] {occs := occurrences.pos [2]},
    rw [pow_add],
    apply dvd_mul_of_dvd_left,
    simp,
  },
  {
    have : count x s < 1,
      from lt_of_not_ge h1,
    have : nat.succ (count x s) ≤ 1,
      from this,
    have : count x s ≤ 0,
      from nat.le_of_succ_le_succ this,
    have : count x s = 0,
      from nat.eq_zero_of_le_zero this,
    simp *,
  }
end

lemma prod_dvd_prod_of_le [comm_semiring α] {p q : multiset (α)} (h : p ≤ q) : p.prod ∣ q.prod :=
begin
  have h1 : p + (q - p) = q,
  from multiset.add_sub_of_le h,
  rw ← h1,
  simp,
end

lemma prod_sub_dvd_prod [comm_semiring α] {s t : multiset α} : (s - t).prod ∣ s.prod :=
begin
  apply prod_dvd_prod_of_le,
  apply sub_le_self,
end

lemma dvd_prod_of_mem {α : Type u} [comm_semiring α] (s : multiset α) {x : α} (h : x ∈ s) : x ∣ s.prod :=
begin
  rcases (exists_cons_of_mem h) with ⟨t, ht⟩,
  subst ht,
  simp * at *,
end

lemma erase_dup_eq_zero_iff_eq_zero {α : Type u} (s : multiset α) : s.erase_dup = 0 ↔ s = 0 :=
begin
  split,
  {
    intro h,
    have : s ⊆ erase_dup s,
      from subset_erase_dup s,
    simp * at *,
    exact eq_zero_of_subset_zero this,
  },
  {
    intro h,
    subst h,
    simp,
  }
end

inductive rel_multiset {α β : Type u} (r : α → β → Prop) : multiset α → multiset β → Prop
| nil : rel_multiset ∅ ∅
| cons : ∀a b xs ys, r a b → rel_multiset xs ys → rel_multiset (a::xs) (b::ys)

lemma rel_multiset_def {α β : Type u} {r : α → β → Prop} {x : multiset α} {y : multiset β} :
  rel_multiset r x y ↔
    ((x = ∅ ∧ y = ∅) ∨ (∃a b x' y', r a b ∧ rel_multiset r x' y' ∧ x = a :: x' ∧ y = b :: y')) :=
iff.intro
  (assume h,
    match x, y, h with
    | _, _, (rel_multiset.nil r) := or.inl ⟨rfl, rfl⟩
    | _, _, (rel_multiset.cons a b x y r r') := or.inr ⟨a, b, x, y, r, r', rfl, rfl⟩
    end)
  (assume h,
    match x, y, h with
    | _, _, or.inl ⟨rfl, rfl⟩ := rel_multiset.nil r
    | _, _, or.inr ⟨a, b, x, y, r, r', rfl, rfl⟩ := rel_multiset.cons a b x y r r'
    end)

open multiset

lemma multiset.cons_ne_empty {α : Type u} (a : α) (as : multiset α) : a :: as ≠ ∅ :=
assume h,
have a ∈ a :: as, by simp,
have a ∈ (∅ : multiset α), from h ▸ this,
not_mem_zero a this

--Can we do an induction on rel_multiset?
lemma rel_multiset.cons_right {α β: Type u} {r : α → β → Prop} {as : multiset α} {bs : multiset β} {b : β} :
  rel_multiset r as (b :: bs) → ∃a' as', as = (a' :: as') ∧ r a' b ∧ rel_multiset r as' bs :=
begin
  generalize hbs' : (b :: bs) = bs',
  intro h,
  induction h generalizing bs,
  case rel_multiset.nil { exact (multiset.cons_ne_empty _ _ hbs').elim },
  case rel_multiset.cons : a b' as bs' hr₁ hr' ih {
    by_cases b_b' : b = b',
    { subst b_b',
      have h : bs = bs', from (cons_inj_right b).1 hbs',
      subst h,
      exact ⟨_, _, rfl, hr₁, hr'⟩ },
    exact (
      have b ∈ b' :: bs', by rw [← hbs']; simp,
      have b ∈ bs', by simpa [b_b'],
      have b :: bs'.erase b = bs', from cons_erase this,
      let ⟨a'', as'', eq, hr₂, hr''⟩ := ih this in
      have ih' : rel_multiset r (a :: as'') (b' :: bs'.erase b),
        from rel_multiset.cons _ _ _ _ hr₁ hr'',
      have b' :: bs'.erase b = bs,
        by rw [← erase_cons_tail, ← hbs', erase_cons_head]; exact ne.symm b_b',
      ⟨a'', a :: as'', by simp [eq, cons_swap], hr₂, this ▸ ih'⟩
    )
  }
end

end multiset


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

/-!
# Weak dual topology

This file defines the weak topology given two vector spaces `E` and `F` over a commutative semiring
`𝕜` and a bilinear form `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`. The weak topology on `E` is the coarsest topology
such that for all `y : F` every map `λ x, B x y` is continuous.

In the case that `F = E →L[𝕜] 𝕜` and `B` being the canonical pairing, we obtain the weak-* topology,
`weak_dual 𝕜 E := (E →L[𝕜] 𝕜)`. Interchanging the arguments in the bilinear form yields the
weak topology `weak_space 𝕜 E := E`.

## Main definitions

The main definitions are the types `weak_bilin B` for the general case and the two special cases
`weak_dual 𝕜 E` and `weak_space 𝕜 E` with the respective topology instances on it.

* Given `B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜`, the type `weak_bilin B` is a type synonym for `E`.
* The instance `weak_bilin.topological_space` is the weak topology induced by the bilinear form `B`.
* `weak_dual 𝕜 E` is a type synonym for `dual 𝕜 E` (when the latter is defined): both are equal to
  the type `E →L[𝕜] 𝕜` of continuous linear maps from a module `E` over `𝕜` to the ring `𝕜`.
* The instance `weak_dual.topological_space` is the weak-* topology on `weak_dual 𝕜 E`, i.e., the
  coarsest topology making the evaluation maps at all `z : E` continuous.
* `weak_space 𝕜 E` is a type synonym for `E` (when the latter is defined).
* The instance `weak_dual.topological_space` is the weak topology on `E`, i.e., the
  coarsest topology such that all `v : dual 𝕜 E` remain continuous.

## Main results

We establish that `weak_bilin B` has the following structure:
* `weak_bilin.has_continuous_add`: The addition in `weak_bilin B` is continuous.
* `weak_bilin.has_continuous_smul`: The scalar multiplication in `weak_bilin B` is continuous.

We prove the following results characterizing the weak topology:
* `eval_continuous`: For any `y : F`, the evaluation mapping `λ x, B x y` is continuous.
* `continuous_of_continuous_eval`: For a mapping to `weak_bilin B` to be continuous,
  it suffices that its compositions with pairing with `B` at all points `y : F` is continuous.
* `tendsto_iff_forall_eval_tendsto`: Convergence in `weak_bilin B` can be characterized
  in terms of convergence of the evaluations at all points `y : F`.

## Notations

No new notation is introduced.

## References

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

## Tags

weak-star, weak dual, duality

-/

noncomputable theory
open filter
open_locale topological_space

variables {α 𝕜 𝕝 R E F M : Type*}

section weak_topology

/-- The space `E` equipped with the weak topology induced by the bilinear form `B`. -/
@[derive [add_comm_monoid, module 𝕜],
nolint has_inhabited_instance unused_arguments]
def weak_bilin [comm_semiring 𝕜] [add_comm_monoid E] [module 𝕜 E] [add_comm_monoid F]
  [module 𝕜 F] (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) := E

namespace weak_bilin

instance [comm_semiring 𝕜] [a : add_comm_group E] [module 𝕜 E] [add_comm_monoid F]
  [module 𝕜 F] (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) : add_comm_group (weak_bilin B) := a

@[priority 100]
instance module' [comm_semiring 𝕜] [comm_semiring 𝕝] [add_comm_group E] [module 𝕜 E]
  [add_comm_group F] [module 𝕜 F] [m : module 𝕝 E] (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) :
  module 𝕝 (weak_bilin B) := m

instance [comm_semiring 𝕜] [comm_semiring 𝕝] [add_comm_group E] [module 𝕜 E]
  [add_comm_group F] [module 𝕜 F] [has_scalar 𝕝 𝕜] [module 𝕝 E] [s : is_scalar_tower 𝕝 𝕜 E]
  (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜) : is_scalar_tower 𝕝 𝕜 (weak_bilin B) := s

section semiring

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

instance : topological_space (weak_bilin B) :=
topological_space.induced (λ x y, B x y) Pi.topological_space

lemma coe_fn_continuous : continuous (λ (x : weak_bilin B) y, B x y) :=
continuous_induced_dom

lemma eval_continuous (y : F) : continuous (λ x : weak_bilin B, B x y) :=
( continuous_pi_iff.mp (coe_fn_continuous B)) y

lemma continuous_of_continuous_eval [topological_space α] {g : α → weak_bilin B}
  (h : ∀ y, continuous (λ a, B (g a) y)) : continuous g :=
continuous_induced_rng (continuous_pi_iff.mpr h)

/-- The coercion `(λ x y, B x y) : E → (F → 𝕜)` is an embedding. -/
lemma embedding {B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜} (hB : function.injective B) :
  embedding (λ (x : weak_bilin B)  y, B x y) :=
function.injective.embedding_induced $ linear_map.coe_injective.comp hB

theorem tendsto_iff_forall_eval_tendsto {l : filter α} {f : α → (weak_bilin B)} {x : weak_bilin B}
  (hB : function.injective B) : tendsto f l (𝓝 x) ↔ ∀ y, tendsto (λ i, B (f i) y) l (𝓝 (B x y)) :=
by rw [← tendsto_pi_nhds, embedding.tendsto_nhds_iff (embedding hB)]

/-- Addition in `weak_space B` is continuous. -/
instance [has_continuous_add 𝕜] : has_continuous_add (weak_bilin B) :=
begin
  refine ⟨continuous_induced_rng _⟩,
  refine cast (congr_arg _ _) (((coe_fn_continuous B).comp continuous_fst).add
    ((coe_fn_continuous B).comp continuous_snd)),
  ext,
  simp only [function.comp_app, pi.add_apply, map_add, linear_map.add_apply],
end

/-- Scalar multiplication by `𝕜` on `weak_bilin B` is continuous. -/
instance [has_continuous_smul 𝕜 𝕜] : has_continuous_smul 𝕜 (weak_bilin B) :=
begin
  refine ⟨continuous_induced_rng _⟩,
  refine cast (congr_arg _ _) (continuous_fst.smul ((coe_fn_continuous B).comp continuous_snd)),
  ext,
  simp only [function.comp_app, pi.smul_apply, linear_map.map_smulₛₗ, ring_hom.id_apply,
    linear_map.smul_apply],
end

end semiring

section ring

variables [topological_space 𝕜] [comm_ring 𝕜]
variables [add_comm_group E] [module 𝕜 E]
variables [add_comm_group F] [module 𝕜 F]
variables (B : E →ₗ[𝕜] F →ₗ[𝕜] 𝕜)

/-- `weak_space B` is a `topological_add_group`, meaning that addition and negation are
continuous. -/
instance [has_continuous_add 𝕜] : topological_add_group (weak_bilin B) :=
{ to_has_continuous_add := by apply_instance,
  continuous_neg := begin
    refine continuous_induced_rng (continuous_pi_iff.mpr (λ y, _)),
    refine cast (congr_arg _ _) (eval_continuous B (-y)),
    ext,
    simp only [map_neg, function.comp_app, linear_map.neg_apply],
  end }

end ring

end weak_bilin

end weak_topology

section weak_star_topology

/-- The canonical pairing of a vector space and its topological dual. -/
def top_dual_pairing (𝕜 E) [comm_semiring 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [add_comm_monoid E] [module 𝕜 E] [topological_space E]
  [has_continuous_const_smul 𝕜 𝕜] :
  (E →L[𝕜] 𝕜) →ₗ[𝕜] E →ₗ[𝕜] 𝕜 := continuous_linear_map.coe_lm 𝕜

variables [comm_semiring 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
variables [has_continuous_const_smul 𝕜 𝕜]
variables [add_comm_monoid E] [module 𝕜 E] [topological_space E]

lemma dual_pairing_apply (v : (E →L[𝕜] 𝕜)) (x : E) : top_dual_pairing 𝕜 E v x = v x := rfl

/-- The weak star topology is the topology coarsest topology on `E →L[𝕜] 𝕜` such that all
functionals `λ v, top_dual_pairing 𝕜 E v x` are continuous. -/
@[derive [add_comm_monoid, module 𝕜, topological_space, has_continuous_add]]
def weak_dual (𝕜 E) [comm_semiring 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [add_comm_monoid E] [module 𝕜 E] [topological_space E] :=
weak_bilin (top_dual_pairing 𝕜 E)

namespace weak_dual

instance : inhabited (weak_dual 𝕜 E) := continuous_linear_map.inhabited

instance weak_dual.add_monoid_hom_class : add_monoid_hom_class (weak_dual 𝕜 E) E 𝕜 :=
continuous_linear_map.add_monoid_hom_class

/-- Helper instance for when there's too many metavariables to apply `fun_like.has_coe_to_fun`
directly. -/
instance : has_coe_to_fun (weak_dual 𝕜 E) (λ _, E → 𝕜) := fun_like.has_coe_to_fun

/-- If a monoid `M` distributively continuously acts on `𝕜` and this action commutes with
multiplication on `𝕜`, then it acts on `weak_dual 𝕜 E`. -/
instance (M) [monoid M] [distrib_mul_action M 𝕜] [smul_comm_class 𝕜 M 𝕜]
  [has_continuous_const_smul M 𝕜] :
  mul_action M (weak_dual 𝕜 E) :=
continuous_linear_map.mul_action

/-- If a monoid `M` distributively continuously acts on `𝕜` and this action commutes with
multiplication on `𝕜`, then it acts distributively on `weak_dual 𝕜 E`. -/
instance (M) [monoid M] [distrib_mul_action M 𝕜] [smul_comm_class 𝕜 M 𝕜]
  [has_continuous_const_smul M 𝕜] :
  distrib_mul_action M (weak_dual 𝕜 E) :=
continuous_linear_map.distrib_mul_action

/-- If `𝕜` is a topological module over a semiring `R` and scalar multiplication commutes with the
multiplication on `𝕜`, then `weak_dual 𝕜 E` is a module over `R`. -/
instance module' (R) [semiring R] [module R 𝕜] [smul_comm_class 𝕜 R 𝕜]
  [has_continuous_const_smul R 𝕜] :
  module R (weak_dual 𝕜 E) :=
continuous_linear_map.module

instance (M) [monoid M] [distrib_mul_action M 𝕜] [smul_comm_class 𝕜 M 𝕜]
  [has_continuous_const_smul M 𝕜] : has_continuous_const_smul M (weak_dual 𝕜 E) :=
⟨λ m, continuous_induced_rng $ (weak_bilin.coe_fn_continuous (top_dual_pairing 𝕜 E)).const_smul m⟩

/-- If a monoid `M` distributively continuously acts on `𝕜` and this action commutes with
multiplication on `𝕜`, then it continuously acts on `weak_dual 𝕜 E`. -/
instance (M) [monoid M] [distrib_mul_action M 𝕜] [smul_comm_class 𝕜 M 𝕜]
  [topological_space M] [has_continuous_smul M 𝕜] :
  has_continuous_smul M (weak_dual 𝕜 E) :=
⟨continuous_induced_rng $ continuous_fst.smul ((weak_bilin.coe_fn_continuous
                          (top_dual_pairing 𝕜 E)).comp continuous_snd)⟩

lemma coe_fn_continuous : continuous (λ (x : weak_dual 𝕜 E) y, x y) :=
continuous_induced_dom

lemma eval_continuous (y : E) : continuous (λ x : weak_dual 𝕜 E, x y) :=
continuous_pi_iff.mp coe_fn_continuous y

lemma continuous_of_continuous_eval [topological_space α] {g : α → weak_dual 𝕜 E}
  (h : ∀ y, continuous (λ a, (g a) y)) : continuous g :=
continuous_induced_rng (continuous_pi_iff.mpr h)

end weak_dual

/-- The weak topology is the topology coarsest topology on `E` such that all
functionals `λ x, top_dual_pairing 𝕜 E v x` are continuous. -/
@[derive [add_comm_monoid, module 𝕜, topological_space, has_continuous_add],
nolint has_inhabited_instance]
def weak_space (𝕜 E) [comm_semiring 𝕜] [topological_space 𝕜] [has_continuous_add 𝕜]
  [has_continuous_const_smul 𝕜 𝕜] [add_comm_monoid E] [module 𝕜 E] [topological_space E] :=
weak_bilin (top_dual_pairing 𝕜 E).flip

theorem tendsto_iff_forall_eval_tendsto_top_dual_pairing
  {l : filter α} {f : α → weak_dual 𝕜 E} {x : weak_dual 𝕜 E} :
  tendsto f l (𝓝 x) ↔
    ∀ y, tendsto (λ i, top_dual_pairing 𝕜 E (f i) y) l (𝓝 (top_dual_pairing 𝕜 E x y)) :=
weak_bilin.tendsto_iff_forall_eval_tendsto _ continuous_linear_map.coe_injective

end weak_star_topology


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

! This file was ported from Lean 3 source module data.nat.upto
! leanprover-community/mathlib commit ee0c179cd3c8a45aa5bffbf1b41d8dbede452865
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Nat.Order.Basic

/-!
# `Nat.Upto`

`Nat.Upto p`, with `p` a predicate on `ℕ`, is a subtype of elements `n : ℕ` such that no value
(strictly) below `n` satisfies `p`.

This type has the property that `>` is well-founded when `∃ i, p i`, which allows us to implement
searches on `ℕ`, starting at `0` and with an unknown upper-bound.

It is similar to the well founded relation constructed to define `Nat.find` with
the difference that, in `Nat.Upto p`, `p` does not need to be decidable. In fact,
`Nat.find` could be slightly altered to factor decidability out of its
well founded relation and would then fulfill the same purpose as this file.
-/

namespace Nat

/-- The subtype of natural numbers `i` which have the property that
no `j` less than `i` satisfies `p`. This is an initial segment of the
natural numbers, up to and including the first value satisfying `p`.

We will be particularly interested in the case where there exists a value
satisfying `p`, because in this case the `>` relation is well-founded.  -/
@[reducible]
def Upto (p : ℕ → Prop) : Type :=
  { i : ℕ // ∀ j < i, ¬p j }
#align nat.upto Nat.Upto

namespace Upto

variable {p : ℕ → Prop}

/-- Lift the "greater than" relation on natural numbers to `Nat.Upto`. -/
protected def GT (p) (x y : Upto p) : Prop :=
  x.1 > y.1
#align nat.upto.gt Nat.Upto.GT

instance : LT (Upto p) :=
  ⟨fun x y => x.1 < y.1⟩

/-- The "greater than" relation on `Upto p` is well founded if (and only if) there exists a value
satisfying `p`. -/
protected theorem wf : (∃ x, p x) → WellFounded (Upto.GT p)
  | ⟨x, h⟩ => by
    suffices Upto.GT p = Measure fun y : Nat.Upto p => x - y.val by
      rw [this]
      exact (measure _).wf
    ext (⟨a, ha⟩⟨b, _⟩)
    dsimp [Measure, InvImage, Upto.GT]
    rw [tsub_lt_tsub_iff_left_of_le (le_of_not_lt fun h' => ha _ h' h)]
#align nat.upto.wf Nat.Upto.wf

/-- Zero is always a member of `Nat.Upto p` because it has no predecessors. -/
def zero : Nat.Upto p :=
  ⟨0, fun _ h => False.elim (Nat.not_lt_zero _ h)⟩
#align nat.upto.zero Nat.Upto.zero

/-- The successor of `n` is in `Nat.Upto p` provided that `n` doesn't satisfy `p`. -/
def succ (x : Nat.Upto p) (h : ¬p x.val) : Nat.Upto p :=
  ⟨x.val.succ, fun j h' => by
    rcases Nat.lt_succ_iff_lt_or_eq.1 h' with (h' | rfl) <;> [exact x.2 _ h', exact h]⟩
#align nat.upto.succ Nat.Upto.succ

end Upto

end Nat


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/
import linear_algebra.matrix.to_lin

/-!
# Diagonal matrices

This file contains some results on the linear map corresponding to a
diagonal matrix (`range`, `ker` and `rank`).

## Tags

matrix, diagonal, linear_map
-/

noncomputable theory

open linear_map matrix set submodule
open_locale big_operators
open_locale matrix

universes u v w

namespace matrix

section comm_ring

variables {n : Type*} [fintype n] [decidable_eq n] {R : Type v} [comm_ring R]

lemma proj_diagonal (i : n) (w : n → R) :
  (proj i).comp (to_lin' (diagonal w)) = (w i) • proj i :=
by ext j; simp [mul_vec_diagonal]

lemma diagonal_comp_std_basis (w : n → R) (i : n) :
  (diagonal w).to_lin'.comp (linear_map.std_basis R (λ_:n, R) i) =
  (w i) • linear_map.std_basis R (λ_:n, R) i :=
begin
  ext j,
  simp_rw [linear_map.comp_apply, to_lin'_apply, mul_vec_diagonal, linear_map.smul_apply,
           pi.smul_apply, algebra.id.smul_eq_mul],
  by_cases i = j,
  { subst h },
  { rw [std_basis_ne R (λ_:n, R) _ _ (ne.symm h), _root_.mul_zero, _root_.mul_zero] }
end

lemma diagonal_to_lin' (w : n → R) :
  (diagonal w).to_lin' = linear_map.pi (λi, w i • linear_map.proj i) :=
by ext v j; simp [mul_vec_diagonal]

end comm_ring

section field

variables {m n : Type*} [fintype m] [fintype n]
variables {K : Type u} [field K] -- maybe try to relax the universe constraint

lemma ker_diagonal_to_lin' [decidable_eq m] (w : m → K) :
  ker (diagonal w).to_lin' = (⨆i∈{i | w i = 0 }, range (linear_map.std_basis K (λi, K) i)) :=
begin
  rw [← comap_bot, ← infi_ker_proj, comap_infi],
  have := λ i : m, ker_comp (to_lin' (diagonal w)) (proj i),
  simp only [comap_infi, ← this, proj_diagonal, ker_smul'],
  have : univ ⊆ {i : m | w i = 0} ∪ {i : m | w i = 0}ᶜ, { rw set.union_compl_self },
  exact (supr_range_std_basis_eq_infi_ker_proj K (λi:m, K)
    disjoint_compl_right this (finite.of_fintype _)).symm
end

lemma range_diagonal [decidable_eq m] (w : m → K) :
  (diagonal w).to_lin'.range = (⨆ i ∈ {i | w i ≠ 0}, (linear_map.std_basis K (λi, K) i).range) :=
begin
  dsimp only [mem_set_of_eq],
  rw [← map_top, ← supr_range_std_basis, map_supr],
  congr, funext i,
  rw [← linear_map.range_comp, diagonal_comp_std_basis, ← range_smul']
end

lemma rank_diagonal [decidable_eq m] [decidable_eq K] (w : m → K) :
  rank (diagonal w).to_lin' = fintype.card { i // w i ≠ 0 } :=
begin
  have hu : univ ⊆ {i : m | w i = 0}ᶜ ∪ {i : m | w i = 0}, { rw set.compl_union_self },
  have hd : disjoint {i : m | w i ≠ 0} {i : m | w i = 0} := disjoint_compl_left,
  have B₁ := supr_range_std_basis_eq_infi_ker_proj K (λi:m, K) hd hu (finite.of_fintype _),
  have B₂ := @infi_ker_proj_equiv K _ _ (λi:m, K) _ _ _ _ (by simp; apply_instance) hd hu,
  rw [rank, range_diagonal, B₁, ←@dim_fun' K],
  apply linear_equiv.dim_eq,
  apply B₂,
end

end field

end matrix


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import topology.urysohns_bounded
import topology.algebra.ordered.monotone_continuity
import data.set.intervals.disjoint
import data.set.intervals.monotone

/-!
# Tietze extension theorem

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

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

## Implementation notes

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

## Tags

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

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

open metric set filter
open_locale bounded_continuous_function topological_space
noncomputable theory

namespace bounded_continuous_function

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

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

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

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

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

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

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

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

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

end bounded_continuous_function

namespace continuous_map

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

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

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

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

end continuous_map


/-
Copyright (c) 2014 Robert Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Lewis, Leonardo de Moura, Johannes Hölzl, Mario Carneiro

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

import Mathlib.Algebra.Ring.Defs
import Mathlib.Tactic.Convert
import Std.Data.Rat
import Mathlib.Data.Rat.Init

/-!
# Division (semi)rings and (semi)fields

This file introduces fields and division rings (also known as skewfields) and proves some basic
statements about them. For a more extensive theory of fields, see the `FieldTheory` folder.

## Main definitions

* `DivisionSemiring`: Nontrivial semiring with multiplicative inverses for nonzero elements.
* `DivisionRing`: : Nontrivial ring with multiplicative inverses for nonzero elements.
* `Semifield`: Commutative division semiring.
* `Field`: Commutative division ring.
* `IsField`: Predicate on a (semi)ring that it is a (semi)field, i.e. that the multiplication is
  commutative, that it has more than one element and that all non-zero elements have a
  multiplicative inverse. In contrast to `Field`, which contains the data of a function associating
  to an element of the field its multiplicative inverse, this predicate only assumes the existence
  and can therefore more easily be used to e.g. transfer along ring isomorphisms.

## Implementation details

By convention `0⁻¹ = 0` in a field or division ring. This is due to the fact that working with total
functions has the advantage of not constantly having to check that `x ≠ 0` when writing `x⁻¹`. With
this convention in place, some statements like `(a + b) * c⁻¹ = a * c⁻¹ + b * c⁻¹` still remain
true, while others like the defining property `a * a⁻¹ = 1` need the assumption `a ≠ 0`. If you are
a beginner in using Lean and are confused by that, you can read more about why this convention is
taken in Kevin Buzzard's
[blogpost](https://xenaproject.wordpress.com/2020/07/05/division-by-zero-in-type-theory-a-faq/)

A division ring or field is an example of a `GroupWithZero`. If you cannot find
a division ring / field lemma that does not involve `+`, you can try looking for
a `GroupWithZero` lemma instead.

## Tags

field, division ring, skew field, skew-field, skewfield
-/

open Function Set

universe u

variable {α β K : Type _}

/-- The default definition of the coercion `(↑(a : ℚ) : K)` for a division ring `K`
is defined as `(a / b : K) = (a : K) * (b : K)⁻¹`.
Use `coe` instead of `Rat.castRec` for better definitional behaviour.
-/
def Rat.castRec [NatCast K] [IntCast K] [Mul K] [Inv K] : ℚ → K
  | ⟨a, b, _, _⟩ => ↑a * (↑b)⁻¹
#align rat.cast_rec Rat.castRec

/-- The default definition of the scalar multiplication `(a : ℚ) • (x : K)` for a division ring `K`
is given by `a • x = (↑ a) * x`.
Use `(a : ℚ) • (x : K)` instead of `qsmulRec` for better definitional behaviour.
-/
def qsmulRec (coe : ℚ → K) [Mul K] (a : ℚ) (x : K) : K :=
  coe a * x
#align qsmul_rec qsmulRec

/-- A `DivisionSemiring` is a `Semiring` with multiplicative inverses for nonzero elements. -/
class DivisionSemiring (α : Type _) extends Semiring α, GroupWithZero α
#align division_semiring DivisionSemiring

/-- A `DivisionRing` is a `Ring` with multiplicative inverses for nonzero elements.

An instance of `DivisionRing K` includes maps `ratCast : ℚ → K` and `qsmul : ℚ → K → K`.
If the division ring has positive characteristic p, we define `ratCast (1 / p) = 1 / 0 = 0`
for consistency with our division by zero convention.
The fields `ratCast` and `qsmul` are needed to implement the
`algebraRat [DivisionRing K] : Algebra ℚ K` instance, since we need to control the specific
definitions for some special cases of `K` (in particular `K = ℚ` itself).
See also Note [forgetful inheritance].
-/
class DivisionRing (K : Type u) extends Ring K, DivInvMonoid K, Nontrivial K, RatCast K where
  /-- For a nonzero `a`, `a⁻¹` is a right multiplicative inverse. -/
  protected mul_inv_cancel : ∀ (a : K), a ≠ 0 → a * a⁻¹ = 1
  /-- We define the inverse of `0` to be `0`. -/
  protected inv_zero : (0 : K)⁻¹ = 0
  protected ratCast := Rat.castRec
  /-- However `ratCast` is defined, propositionally it must be equal to `a * b⁻¹`. -/
  protected ratCast_mk : ∀ (a : ℤ) (b : ℕ) (h1 h2), Rat.cast ⟨a, b, h1, h2⟩ = a * (b : K)⁻¹ := by
    intros
    rfl
  /-- Multiplication by a rational number. -/
  protected qsmul : ℚ → K → K := qsmulRec Rat.cast
  /-- However `qsmul` is defined,
  propositionally it must be equal to multiplication by `ratCast`. -/
  protected qsmul_eq_mul' : ∀ (a : ℚ) (x : K), qsmul a x = Rat.cast a * x := by
    intros
    rfl
#align division_ring DivisionRing
#align division_ring.rat_cast_mk DivisionRing.ratCast_mk

-- see Note [lower instance priority]
instance (priority := 100) DivisionRing.toDivisionSemiring [DivisionRing α] : DivisionSemiring α :=
  { ‹DivisionRing α›, (inferInstance : Semiring α) with }
#align division_ring.to_division_semiring DivisionRing.toDivisionSemiring

/-- A `Semifield` is a `CommSemiring` with multiplicative inverses for nonzero elements. -/
class Semifield (α : Type _) extends CommSemiring α, DivisionSemiring α, CommGroupWithZero α
#align semifield Semifield

/-- A `Field` is a `CommRing` with multiplicative inverses for nonzero elements.

An instance of `Field K` includes maps `ratCast : ℚ → K` and `qsmul : ℚ → K → K`.
If the field has positive characteristic p, we define `ratCast (1 / p) = 1 / 0 = 0`
for consistency with our division by zero convention.
The fields `ratCast` and `qsmul` are needed to implement the
`algebraRat [DivisionRing K] : Algebra ℚ K` instance, since we need to control the specific
definitions for some special cases of `K` (in particular `K = ℚ` itself).
See also Note [forgetful inheritance].
-/
class Field (K : Type u) extends CommRing K, DivisionRing K
#align field Field

section DivisionRing

variable [DivisionRing K] {a b : K}

namespace Rat

theorem cast_mk' (a b h1 h2) : ((⟨a, b, h1, h2⟩ : ℚ) : K) = a * (b : K)⁻¹ :=
  DivisionRing.ratCast_mk _ _ _ _
#align rat.cast_mk' Rat.cast_mk'

theorem cast_def : ∀ r : ℚ, (r : K) = r.num / r.den
  | ⟨_, _, _, _⟩ => (cast_mk' _ _ _ _).trans (div_eq_mul_inv _ _).symm
#align rat.cast_def Rat.cast_def

instance (priority := 100) smulDivisionRing : SMul ℚ K :=
  ⟨DivisionRing.qsmul⟩
#align rat.smul_division_ring Rat.smulDivisionRing

theorem smul_def (a : ℚ) (x : K) : a • x = ↑a * x :=
  DivisionRing.qsmul_eq_mul' a x
#align rat.smul_def Rat.smul_def

end Rat

end DivisionRing

section Field

variable [Field K]

-- see Note [lower instance priority]
instance (priority := 100) Field.toSemifield : Semifield K :=
  { ‹Field K›, (inferInstance : Semiring K) with }
#align field.to_semifield Field.toSemifield

end Field

section IsField

/-- A predicate to express that a (semi)ring is a (semi)field.

This is mainly useful because such a predicate does not contain data,
and can therefore be easily transported along ring isomorphisms.
Additionaly, this is useful when trying to prove that
a particular ring structure extends to a (semi)field. -/
structure IsField (R : Type u) [Semiring R] : Prop where
  /-- For a semiring to be a field, it must have two distinct elements. -/
  exists_pair_ne : ∃ x y : R, x ≠ y
  /-- Fields are commutative. -/
  mul_comm : ∀ x y : R, x * y = y * x
  /-- Nonzero elements have multiplicative inverses. -/
  mul_inv_cancel : ∀ {a : R}, a ≠ 0 → ∃ b, a * b = 1
#align is_field IsField

/-- Transferring from `Semifield` to `IsField`. -/
theorem Semifield.toIsField (R : Type u) [Semifield R] : IsField R :=
  { ‹Semifield R› with
    mul_inv_cancel := @fun a ha => ⟨a⁻¹, mul_inv_cancel a ha⟩ }
#align semifield.to_is_field Semifield.toIsField

/-- Transferring from `Field` to `IsField`. -/
theorem Field.toIsField (R : Type u) [Field R] : IsField R :=
  Semifield.toIsField _
#align field.to_is_field Field.toIsField

@[simp]
theorem IsField.nontrivial {R : Type u} [Semiring R] (h : IsField R) : Nontrivial R :=
  ⟨h.exists_pair_ne⟩
#align is_field.nontrivial IsField.nontrivial

@[simp]
theorem not_isField_of_subsingleton (R : Type u) [Semiring R] [Subsingleton R] : ¬IsField R :=
  fun h =>
  let ⟨_, _, h⟩ := h.exists_pair_ne
  h (Subsingleton.elim _ _)
#align not_is_field_of_subsingleton not_isField_of_subsingleton

open Classical

/-- Transferring from `IsField` to `Semifield`. -/
noncomputable def IsField.toSemifield {R : Type u} [Semiring R] (h : IsField R) : Semifield R :=
  { ‹Semiring R›, h with
    inv := fun a => if ha : a = 0 then 0 else Classical.choose (IsField.mul_inv_cancel h ha),
    inv_zero := dif_pos rfl,
    mul_inv_cancel := fun a ha => by
      convert Classical.choose_spec (IsField.mul_inv_cancel h ha)
      exact dif_neg ha }
#align is_field.to_semifield IsField.toSemifield

/-- Transferring from `IsField` to `Field`. -/
noncomputable def IsField.toField {R : Type u} [Ring R] (h : IsField R) : Field R :=
  { ‹Ring R›, IsField.toSemifield h with }
#align is_field.to_field IsField.toField

/-- For each field, and for each nonzero element of said field, there is a unique inverse.
Since `IsField` doesn't remember the data of an `inv` function and as such,
a lemma that there is a unique inverse could be useful.
-/
theorem uniq_inv_of_isField (R : Type u) [Ring R] (hf : IsField R) :
    ∀ x : R, x ≠ 0 → ∃! y : R, x * y = 1 := by
  intro x hx
  apply exists_unique_of_exists_of_unique
  · exact hf.mul_inv_cancel hx

  · intro y z hxy hxz
    calc
      y = y * (x * z) := by rw [hxz, mul_one]
      _ = x * y * z := by rw [← mul_assoc, hf.mul_comm y x]
      _ = z := by rw [hxy, one_mul]

#align uniq_inv_of_is_field uniq_inv_of_isField

end IsField


-- La imagen de la unión es la unión de las imágenes
-- =================================================

import data.set
open set function

variables {X Y : Type}
variable  (f : X → Y)
variables (A₁ A₂ : set X)

-- #reduce image f A₁
-- #reduce f '' A₁

-- 1ª demostración
example :
  f '' (A₁ ∪ A₂) = f '' A₁ ∪ f '' A₂ :=
begin
  ext y,
  split,
  { intro h,
    cases h with x hx,
    cases hx with xA₁A₂ fxy,
    cases xA₁A₂ with xA₁ xA₂,
    { left,
      -- simp,
      use x,
      exact ⟨xA₁, fxy⟩, },
    { right,
      use x,
      exact ⟨xA₂, fxy⟩, }},
  { intro h,
    cases h with yifA₁ yifA₂,
    { cases yifA₁ with  x h1,
      cases h1 with xA₁ fxy,
      use x,
      split,
      { left,
        exact xA₁, },
      { exact fxy, }},
    { cases yifA₂ with x h1,
      cases h1 with xA₂ fxy,
      use x,
      split,
      { right,
        exact xA₂, },
      { exact fxy, }}},
end

-- 2ª demostración
example :
  f '' (A₁ ∪ A₂) = f '' A₁ ∪ f '' A₂ :=
begin
  ext y,
  split,
  { rintro ⟨x, (xA₁ | xA₂), fxy⟩,
    { exact or.inl ⟨x, xA₁, fxy⟩, },
    { exact or.inr ⟨x, xA₂, fxy⟩, }},
  { rintro (⟨x, xA₁, fxy⟩ | ⟨x, xA₂, fxy⟩),
    { exact ⟨x, or.inl xA₁, fxy⟩, },
    { exact ⟨x, or.inr xA₂, fxy⟩, }},
end

-- 3ª demostración
example :
  f '' (A₁ ∪ A₂) = f '' A₁ ∪ f '' A₂ :=
ext (assume y, iff.intro
  ( assume h : y ∈ f '' (A₁ ∪ A₂),
    exists.elim h
      ( assume x h1,
        have xA₁A₂ : x ∈ A₁ ∪ A₂, from h1.left,
        have fxy : f x = y, from h1.right,
        or.elim xA₁A₂
          ( assume xA₁, or.inl ⟨x, xA₁, fxy⟩)
          ( assume xA₂, or.inr ⟨x, xA₂, fxy⟩)))
  ( assume h : y ∈ f '' A₁ ∪ f '' A₂,
    or.elim h
      ( assume yifA₁ : y ∈ f '' A₁,
        exists.elim yifA₁
          ( assume x h1,
            have xA₁ : x ∈ A₁, from h1.left,
            have fxy : f x = y, from h1.right,
            ⟨x, or.inl xA₁, fxy⟩))
      ( assume yifA₂ : y ∈ f '' A₂,
        exists.elim yifA₂
          ( assume x h1,
            have xA₂ : x ∈ A₂, from h1.left,
            have fxy : f x = y, from h1.right,
            ⟨x, (or.inr xA₂), fxy⟩))))

-- 4ª demostración
example :
  f '' (A₁ ∪ A₂) = f '' A₁ ∪ f '' A₂ :=
-- by library_search
image_union f A₁ A₂

-- 5ª demostración
example :
  f '' (A₁ ∪ A₂) = f '' A₁ ∪ f '' A₂ :=
by finish [ext_iff, iff_def]


/-
Copyright (c) 2020 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Devon Tuma
-/
import ring_theory.ideal.quotient
import ring_theory.polynomial.basic

/-!
# Jacobson radical

The Jacobson radical of a ring `R` is defined to be the intersection of all maximal ideals of `R`.
This is similar to how the nilradical is equal to the intersection of all prime ideals of `R`.

We can extend the idea of the nilradical to ideals of `R`,
by letting the radical of an ideal `I` be the intersection of prime ideals containing `I`.
Under this extension, the original nilradical is the radical of the zero ideal `⊥`.
Here we define the Jacobson radical of an ideal `I` in a similar way,
as the intersection of maximal ideals containing `I`.

## Main definitions

Let `R` be a commutative ring, and `I` be an ideal of `R`

* `jacobson I` is the jacobson radical, i.e. the infimum of all maximal ideals containing I.

* `is_local I` is the proposition that the jacobson radical of `I` is itself a maximal ideal

## Main statements

* `mem_jacobson_iff` gives a characterization of members of the jacobson of I

* `is_local_of_is_maximal_radical`: if the radical of I is maximal then so is the jacobson radical

## Tags

Jacobson, Jacobson radical, Local Ideal

-/

universes u v

namespace ideal
variables {R : Type u} [comm_ring R] {I : ideal R}
variables {S : Type v} [comm_ring S]

section jacobson

/-- The Jacobson radical of `I` is the infimum of all maximal ideals containing `I`. -/
def jacobson (I : ideal R) : ideal R :=
Inf {J : ideal R | I ≤ J ∧ is_maximal J}

lemma le_jacobson : I ≤ jacobson I :=
λ x hx, mem_Inf.mpr (λ J hJ, hJ.left hx)

@[simp] lemma jacobson_idem : jacobson (jacobson I) = jacobson I :=
le_antisymm (Inf_le_Inf (λ J hJ, ⟨Inf_le hJ, hJ.2⟩)) le_jacobson

lemma radical_le_jacobson : radical I ≤ jacobson I :=
le_Inf (λ J hJ, (radical_eq_Inf I).symm ▸ Inf_le ⟨hJ.left, is_maximal.is_prime hJ.right⟩)

lemma eq_radical_of_eq_jacobson : jacobson I = I → radical I = I :=
λ h, le_antisymm (le_trans radical_le_jacobson (le_of_eq h)) le_radical

@[simp] lemma jacobson_top : jacobson (⊤ : ideal R) = ⊤ :=
eq_top_iff.2 le_jacobson

@[simp] theorem jacobson_eq_top_iff : jacobson I = ⊤ ↔ I = ⊤ :=
⟨λ H, classical.by_contradiction $ λ hi, let ⟨M, hm, him⟩ := exists_le_maximal I hi in
  lt_top_iff_ne_top.1
    (lt_of_le_of_lt (show jacobson I ≤ M, from Inf_le ⟨him, hm⟩) $
      lt_top_iff_ne_top.2 hm.ne_top) H,
λ H, eq_top_iff.2 $ le_Inf $ λ J ⟨hij, hj⟩, H ▸ hij⟩

lemma jacobson_eq_bot : jacobson I = ⊥ → I = ⊥ :=
λ h, eq_bot_iff.mpr (h ▸ le_jacobson)

lemma jacobson_eq_self_of_is_maximal [H : is_maximal I] : I.jacobson = I :=
le_antisymm (Inf_le ⟨le_of_eq rfl, H⟩) le_jacobson

@[priority 100]
instance jacobson.is_maximal [H : is_maximal I] : is_maximal (jacobson I) :=
⟨⟨λ htop, H.1.1 (jacobson_eq_top_iff.1 htop),
  λ J hJ, H.1.2 _ (lt_of_le_of_lt le_jacobson hJ)⟩⟩

theorem mem_jacobson_iff {x : R} : x ∈ jacobson I ↔ ∀ y, ∃ z, x * y * z + z - 1 ∈ I :=
⟨λ hx y, classical.by_cases
  (assume hxy : I ⊔ span {x * y + 1} = ⊤,
    let ⟨p, hpi, q, hq, hpq⟩ := submodule.mem_sup.1 ((eq_top_iff_one _).1 hxy) in
    let ⟨r, hr⟩ := mem_span_singleton.1 hq in
    ⟨r, by rw [← one_mul r, ← mul_assoc, ← add_mul, mul_one, ← hr, ← hpq, ← neg_sub,
               add_sub_cancel]; exact I.neg_mem hpi⟩)
  (assume hxy : I ⊔ span {x * y + 1} ≠ ⊤,
    let ⟨M, hm1, hm2⟩ := exists_le_maximal _ hxy in
    suffices x ∉ M, from (this $ mem_Inf.1 hx ⟨le_trans le_sup_left hm2, hm1⟩).elim,
    λ hxm, hm1.1.1 $ (eq_top_iff_one _).2 $ add_sub_cancel' (x * y) 1 ▸ M.sub_mem
      (le_sup_right.trans hm2 $ mem_span_singleton.2 dvd_rfl)
      (M.mul_mem_right _ hxm)),
λ hx, mem_Inf.2 $ λ M ⟨him, hm⟩, classical.by_contradiction $ λ hxm,
  let ⟨y, hy⟩ := hm.exists_inv hxm, ⟨z, hz⟩ := hx (-y) in
  hm.1.1 $ (eq_top_iff_one _).2 $ sub_sub_cancel (x * -y * z + z) 1 ▸ M.sub_mem
    (by { rw [← one_mul z, ← mul_assoc, ← add_mul, mul_one, mul_neg_eq_neg_mul_symm, neg_add_eq_sub,
        ← neg_sub, neg_mul_eq_neg_mul_symm, neg_mul_eq_mul_neg, mul_comm x y, mul_comm _ (- z)],
      rcases hy with ⟨i, hi, df⟩,
      rw [← (sub_eq_iff_eq_add.mpr df.symm), sub_sub, add_comm, ← sub_sub, sub_self, zero_sub],
      refine M.mul_mem_left (-z) ((neg_mem_iff _).mpr hi) }) (him hz)⟩

lemma exists_mul_sub_mem_of_sub_one_mem_jacobson {I : ideal R} (r : R)
  (h : r - 1 ∈ jacobson I) : ∃ s, r * s - 1 ∈ I :=
begin
  cases mem_jacobson_iff.1 h 1 with s hs,
  use s,
  simpa [sub_mul] using hs
end

lemma is_unit_of_sub_one_mem_jacobson_bot (r : R)
  (h : r - 1 ∈ jacobson (⊥ : ideal R)) : is_unit r :=
begin
  cases exists_mul_sub_mem_of_sub_one_mem_jacobson r h with s hs,
  rw [mem_bot, sub_eq_zero] at hs,
  exact is_unit_of_mul_eq_one _ _ hs
end

/-- An ideal equals its Jacobson radical iff it is the intersection of a set of maximal ideals.
Allowing the set to include ⊤ is equivalent, and is included only to simplify some proofs. -/
theorem eq_jacobson_iff_Inf_maximal :
  I.jacobson = I ↔ ∃ M : set (ideal R), (∀ J ∈ M, is_maximal J ∨ J = ⊤) ∧ I = Inf M :=
begin
  use λ hI, ⟨{J : ideal R | I ≤ J ∧ J.is_maximal}, ⟨λ _ hJ, or.inl hJ.right, hI.symm⟩⟩,
  rintros ⟨M, hM, hInf⟩,
  refine le_antisymm (λ x hx, _) le_jacobson,
  rw [hInf, mem_Inf],
  intros I hI,
  cases hM I hI with is_max is_top,
  { exact (mem_Inf.1 hx) ⟨le_Inf_iff.1 (le_of_eq hInf) I hI, is_max⟩ },
  { exact is_top.symm ▸ submodule.mem_top }
end

theorem eq_jacobson_iff_Inf_maximal' :
  I.jacobson = I ↔ ∃ M : set (ideal R), (∀ (J ∈ M) (K : ideal R), J < K → K = ⊤) ∧ I = Inf M :=
eq_jacobson_iff_Inf_maximal.trans
  ⟨λ h, let ⟨M, hM⟩ := h in ⟨M, ⟨λ J hJ K hK, or.rec_on (hM.1 J hJ) (λ h, h.1.2 K hK)
    (λ h, eq_top_iff.2 (le_of_lt (h ▸ hK))), hM.2⟩⟩,
  λ h, let ⟨M, hM⟩ := h in ⟨M, ⟨λ J hJ, or.rec_on (classical.em (J = ⊤)) (λ h, or.inr h)
    (λ h, or.inl ⟨⟨h, hM.1 J hJ⟩⟩), hM.2⟩⟩⟩

/-- An ideal `I` equals its Jacobson radical if and only if every element outside `I`
also lies outside of a maximal ideal containing `I`. -/
lemma eq_jacobson_iff_not_mem :
  I.jacobson = I ↔ ∀ x ∉ I, ∃ M : ideal R, (I ≤ M ∧ M.is_maximal) ∧ x ∉ M :=
begin
  split,
  { intros h x hx,
    erw [← h, mem_Inf] at hx,
    push_neg at hx,
    exact hx },
  { refine λ h, le_antisymm (λ x hx, _) le_jacobson,
    contrapose hx,
    erw mem_Inf,
    push_neg,
    exact h x hx }
end

theorem map_jacobson_of_surjective {f : R →+* S} (hf : function.surjective f) :
  ring_hom.ker f ≤ I → map f (I.jacobson) = (map f I).jacobson :=
begin
  intro h,
  unfold ideal.jacobson,
  have : ∀ J ∈ {J : ideal R | I ≤ J ∧ J.is_maximal}, f.ker ≤ J := λ J hJ, le_trans h hJ.left,
  refine trans (map_Inf hf this) (le_antisymm _ _),
  { refine Inf_le_Inf (λ J hJ, ⟨comap f J, ⟨⟨le_comap_of_map_le hJ.1, _⟩,
    map_comap_of_surjective f hf J⟩⟩),
    haveI : J.is_maximal := hJ.right,
    exact comap_is_maximal_of_surjective f hf },
  { refine Inf_le_Inf_of_subset_insert_top (λ j hj, hj.rec_on (λ J hJ, _)),
    rw ← hJ.2,
    cases map_eq_top_or_is_maximal_of_surjective f hf hJ.left.right with htop hmax,
    { exact htop.symm ▸ set.mem_insert ⊤ _ },
    { exact set.mem_insert_of_mem ⊤ ⟨map_mono hJ.1.1, hmax⟩ } },
end

lemma map_jacobson_of_bijective {f : R →+* S} (hf : function.bijective f) :
  map f (I.jacobson) = (map f I).jacobson :=
map_jacobson_of_surjective hf.right
  (le_trans (le_of_eq (f.injective_iff_ker_eq_bot.1 hf.left)) bot_le)

lemma comap_jacobson {f : R →+* S} {K : ideal S} :
  comap f (K.jacobson) = Inf (comap f '' {J : ideal S | K ≤ J ∧ J.is_maximal}) :=
trans (comap_Inf' f _) (Inf_eq_infi).symm

theorem comap_jacobson_of_surjective {f : R →+* S} (hf : function.surjective f) {K : ideal S} :
  comap f (K.jacobson) = (comap f K).jacobson :=
begin
  unfold ideal.jacobson,
  refine le_antisymm _ _,
  { refine le_trans (comap_mono (le_of_eq (trans top_inf_eq.symm Inf_insert.symm))) _,
    rw [comap_Inf', Inf_eq_infi],
    refine infi_le_infi_of_subset (λ J hJ, _),
    have : comap f (map f J) = J := trans (comap_map_of_surjective f hf J)
      (le_antisymm (sup_le_iff.2 ⟨le_of_eq rfl, le_trans (comap_mono bot_le) hJ.left⟩) le_sup_left),
    cases map_eq_top_or_is_maximal_of_surjective _ hf hJ.right with htop hmax,
    { refine ⟨⊤, ⟨set.mem_insert ⊤ _, htop ▸ this⟩⟩ },
    { refine ⟨map f J, ⟨set.mem_insert_of_mem _
        ⟨le_map_of_comap_le_of_surjective f hf hJ.1, hmax⟩, this⟩⟩ } },
  { rw comap_Inf,
    refine le_infi_iff.2 (λ J, (le_infi_iff.2 (λ hJ, _))),
    haveI : J.is_maximal := hJ.right,
    refine Inf_le ⟨comap_mono hJ.left, comap_is_maximal_of_surjective _ hf⟩ }
end

lemma mem_jacobson_bot {x : R} : x ∈ jacobson (⊥ : ideal R) ↔ ∀ y, is_unit (x * y + 1) :=
⟨λ hx y, let ⟨z, hz⟩ := (mem_jacobson_iff.1 hx) y in
  is_unit_iff_exists_inv.2 ⟨z, by rwa [add_mul, one_mul, ← sub_eq_zero]⟩,
λ h, mem_jacobson_iff.mpr (λ y, (let ⟨b, hb⟩ := is_unit_iff_exists_inv.1 (h y) in
  ⟨b, (submodule.mem_bot R).2 (hb ▸ (by ring))⟩))⟩

/-- An ideal `I` of `R` is equal to its Jacobson radical if and only if
the Jacobson radical of the quotient ring `R/I` is the zero ideal -/
theorem jacobson_eq_iff_jacobson_quotient_eq_bot :
  I.jacobson = I ↔ jacobson (⊥ : ideal (R ⧸ I)) = ⊥ :=
begin
  have hf : function.surjective (quotient.mk I) := submodule.quotient.mk_surjective I,
  split,
  { intro h,
    replace h := congr_arg (map (quotient.mk I)) h,
    rw map_jacobson_of_surjective hf (le_of_eq mk_ker) at h,
    simpa using h },
  { intro h,
    replace h := congr_arg (comap (quotient.mk I)) h,
    rw [comap_jacobson_of_surjective hf, ← (quotient.mk I).ker_eq_comap_bot] at h,
    simpa using h }
end

/-- The standard radical and Jacobson radical of an ideal `I` of `R` are equal if and only if
the nilradical and Jacobson radical of the quotient ring `R/I` coincide -/
theorem radical_eq_jacobson_iff_radical_quotient_eq_jacobson_bot :
  I.radical = I.jacobson ↔ radical (⊥ : ideal (R ⧸ I)) = jacobson ⊥ :=
begin
  have hf : function.surjective (quotient.mk I) := submodule.quotient.mk_surjective I,
  split,
  { intro h,
    have := congr_arg (map (quotient.mk I)) h,
    rw [map_radical_of_surjective hf (le_of_eq mk_ker),
      map_jacobson_of_surjective hf (le_of_eq mk_ker)] at this,
    simpa using this },
  { intro h,
    have := congr_arg (comap (quotient.mk I)) h,
    rw [comap_radical, comap_jacobson_of_surjective hf, ← (quotient.mk I).ker_eq_comap_bot] at this,
    simpa using this }
end

@[mono] lemma jacobson_mono {I J : ideal R} : I ≤ J → I.jacobson ≤ J.jacobson :=
begin
  intros h x hx,
  erw mem_Inf at ⊢ hx,
  exact λ K ⟨hK, hK_max⟩, hx ⟨trans h hK, hK_max⟩
end

lemma jacobson_radical_eq_jacobson :
  I.radical.jacobson = I.jacobson :=
le_antisymm (le_trans (le_of_eq (congr_arg jacobson (radical_eq_Inf I)))
  (Inf_le_Inf (λ J hJ, ⟨Inf_le ⟨hJ.1, hJ.2.is_prime⟩, hJ.2⟩))) (jacobson_mono le_radical)

end jacobson

section polynomial
open polynomial

lemma jacobson_bot_polynomial_le_Inf_map_maximal :
  jacobson (⊥ : ideal (polynomial R)) ≤ Inf (map C '' {J : ideal R | J.is_maximal}) :=
begin
  refine le_Inf (λ J, exists_imp_distrib.2 (λ j hj, _)),
  haveI : j.is_maximal := hj.1,
  refine trans (jacobson_mono bot_le) (le_of_eq _ : J.jacobson ≤ J),
  suffices : (⊥ : ideal (polynomial (R ⧸ j))).jacobson = ⊥,
  { rw [← hj.2, jacobson_eq_iff_jacobson_quotient_eq_bot],
    replace this :=
    congr_arg (map (polynomial_quotient_equiv_quotient_polynomial j).to_ring_hom) this,
    rwa [map_jacobson_of_bijective _, map_bot] at this,
    exact (ring_equiv.bijective (polynomial_quotient_equiv_quotient_polynomial j)) },
  refine eq_bot_iff.2 (λ f hf, _),
  simpa [(λ hX, by simpa using congr_arg (λ f, coeff f 1) hX : (X : polynomial (R ⧸ j)) ≠ 0)]
    using eq_C_of_degree_eq_zero (degree_eq_zero_of_is_unit ((mem_jacobson_bot.1 hf) X)),
end

lemma jacobson_bot_polynomial_of_jacobson_bot (h : jacobson (⊥ : ideal R) = ⊥) :
  jacobson (⊥ : ideal (polynomial R)) = ⊥ :=
begin
  refine eq_bot_iff.2 (le_trans jacobson_bot_polynomial_le_Inf_map_maximal _),
  refine (λ f hf, ((submodule.mem_bot _).2 (polynomial.ext (λ n, trans _ (coeff_zero n).symm)))),
  suffices : f.coeff n ∈ ideal.jacobson ⊥, by rwa [h, submodule.mem_bot] at this,
  exact mem_Inf.2 (λ j hj, (mem_map_C_iff.1 ((mem_Inf.1 hf) ⟨j, ⟨hj.2, rfl⟩⟩)) n),
end

end polynomial

section is_local

/-- An ideal `I` is local iff its Jacobson radical is maximal. -/
class is_local (I : ideal R) : Prop := (out : is_maximal (jacobson I))

theorem is_local_iff {I : ideal R} : is_local I ↔ is_maximal (jacobson I) :=
⟨λ h, h.1, λ h, ⟨h⟩⟩

theorem is_local_of_is_maximal_radical {I : ideal R} (hi : is_maximal (radical I)) : is_local I :=
⟨have radical I = jacobson I,
from le_antisymm (le_Inf $ λ M ⟨him, hm⟩, hm.is_prime.radical_le_iff.2 him)
  (Inf_le ⟨le_radical, hi⟩),
show is_maximal (jacobson I), from this ▸ hi⟩

theorem is_local.le_jacobson {I J : ideal R} (hi : is_local I) (hij : I ≤ J) (hj : J ≠ ⊤) :
  J ≤ jacobson I :=
let ⟨M, hm, hjm⟩ := exists_le_maximal J hj in
le_trans hjm $ le_of_eq $ eq.symm $ hi.1.eq_of_le hm.1.1 $ Inf_le ⟨le_trans hij hjm, hm⟩

theorem is_local.mem_jacobson_or_exists_inv {I : ideal R} (hi : is_local I) (x : R) :
  x ∈ jacobson I ∨ ∃ y, y * x - 1 ∈ I :=
classical.by_cases
  (assume h : I ⊔ span {x} = ⊤,
    let ⟨p, hpi, q, hq, hpq⟩ := submodule.mem_sup.1 ((eq_top_iff_one _).1 h) in
    let ⟨r, hr⟩ := mem_span_singleton.1 hq in
    or.inr ⟨r, by rw [← hpq, mul_comm, ← hr, ← neg_sub, add_sub_cancel]; exact I.neg_mem hpi⟩)
  (assume h : I ⊔ span {x} ≠ ⊤,
    or.inl $ le_trans le_sup_right (hi.le_jacobson le_sup_left h) $ mem_span_singleton.2 $
      dvd_refl x)

end is_local

theorem is_primary_of_is_maximal_radical {I : ideal R} (hi : is_maximal (radical I)) :
  is_primary I :=
have radical I = jacobson I,
from le_antisymm (le_Inf $ λ M ⟨him, hm⟩, hm.is_prime.radical_le_iff.2 him)
  (Inf_le ⟨le_radical, hi⟩),
⟨ne_top_of_lt $ lt_of_le_of_lt le_radical (lt_top_iff_ne_top.2 hi.1.1),
λ x y hxy, ((is_local_of_is_maximal_radical hi).mem_jacobson_or_exists_inv y).symm.imp
  (λ ⟨z, hz⟩, by rw [← mul_one x, ← sub_sub_cancel (z * y) 1, mul_sub, mul_left_comm]; exact
    I.sub_mem (I.mul_mem_left _ hxy) (I.mul_mem_left _ hz))
  (this ▸ id)⟩

end ideal


/-
Copyright (c) 2019 Amelia Livingston. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Amelia Livingston, Bryan Gin-ge Chen, Patrick Massot
-/

import data.fintype.basic
import data.set.finite
import data.setoid.basic
import order.partition.finpartition

/-!
# Equivalence relations: partitions

This file comprises properties of equivalence relations viewed as partitions.
There are two implementations of partitions here:
* A collection `c : set (set α)` of sets is a partition of `α` if `∅ ∉ c` and each element `a : α`
  belongs to a unique set `b ∈ c`. This is expressed as `is_partition c`
* An indexed partition is a map `s : ι → α` whose image is a partition. This is
  expressed as `indexed_partition s`.

Of course both implementations are related to `quotient` and `setoid`.

`setoid.is_partition.partition` and `finpartition.is_partition_parts` furnish
a link between `setoid.is_partition` and `finpartition`.

## TODO

Could the design of `finpartition` inform the one of `setoid.is_partition`? Maybe bundling it and
changing it from `set (set α)` to `set α` where `[lattice α] [order_bot α]` would make it more
usable.

## Tags

setoid, equivalence, iseqv, relation, equivalence relation, partition, equivalence class
-/

namespace setoid

variables {α : Type*}

/-- If x ∈ α is in 2 elements of a set of sets partitioning α, those 2 sets are equal. -/
lemma eq_of_mem_eqv_class {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b)
  {x b b'} (hc : b ∈ c) (hb : x ∈ b) (hc' : b' ∈ c) (hb' : x ∈ b') :
  b = b' :=
(H x).unique2 hc hb hc' hb'

/-- Makes an equivalence relation from a set of sets partitioning α. -/
def mk_classes (c : set (set α)) (H : ∀ a, ∃! b ∈ c, a ∈ b) :
  setoid α :=
⟨λ x y, ∀ s ∈ c, x ∈ s → y ∈ s, ⟨λ _ _ _ hx, hx,
 λ x y h s hs hy, (H x).elim2 $ λ t ht hx _,
   have s = t, from eq_of_mem_eqv_class H hs hy ht (h t ht hx),
   this.symm ▸ hx,
 λ x y z h1 h2 s hs hx, (H y).elim2 $ λ t ht hy _, (H z).elim2 $ λ t' ht' hz _,
   have hst : s = t, from eq_of_mem_eqv_class H hs (h1 _ hs hx) ht hy,
   have htt' : t = t', from eq_of_mem_eqv_class H ht (h2 _ ht hy) ht' hz,
   (hst.trans htt').symm ▸ hz⟩⟩

/-- Makes the equivalence classes of an equivalence relation. -/
def classes (r : setoid α) : set (set α) :=
{s | ∃ y, s = {x | r.rel x y}}

lemma mem_classes (r : setoid α) (y) : {x | r.rel x y} ∈ r.classes := ⟨y, rfl⟩

lemma classes_ker_subset_fiber_set {β : Type*} (f : α → β) :
  (setoid.ker f).classes ⊆ set.range (λ y, {x | f x = y}) :=
by { rintro s ⟨x, rfl⟩, rw set.mem_range, exact ⟨f x, rfl⟩ }

lemma nonempty_fintype_classes_ker {α β : Type*} [fintype β] (f : α → β) :
  nonempty (fintype (setoid.ker f).classes) :=
by { classical, exact ⟨set.fintype_subset _ (classes_ker_subset_fiber_set f)⟩ }

lemma card_classes_ker_le {α β : Type*} [fintype β]
  (f : α → β) [fintype (setoid.ker f).classes] :
  fintype.card (setoid.ker f).classes ≤ fintype.card β :=
begin
  classical,
  exact le_trans (set.card_le_of_subset (classes_ker_subset_fiber_set f)) (fintype.card_range_le _)
end

/-- Two equivalence relations are equal iff all their equivalence classes are equal. -/
lemma eq_iff_classes_eq {r₁ r₂ : setoid α} :
  r₁ = r₂ ↔ ∀ x, {y | r₁.rel x y} = {y | r₂.rel x y} :=
⟨λ h x, h ▸ rfl, λ h, ext' $ λ x, set.ext_iff.1 $ h x⟩

lemma rel_iff_exists_classes (r : setoid α) {x y} :
  r.rel x y ↔ ∃ c ∈ r.classes, x ∈ c ∧ y ∈ c :=
⟨λ h, ⟨_, r.mem_classes y, h, r.refl' y⟩,
  λ ⟨c, ⟨z, hz⟩, hx, hy⟩, by { subst c, exact r.trans' hx (r.symm' hy) }⟩

/-- Two equivalence relations are equal iff their equivalence classes are equal. -/
lemma classes_inj {r₁ r₂ : setoid α} :
  r₁ = r₂ ↔ r₁.classes = r₂.classes :=
⟨λ h, h ▸ rfl, λ h, ext' $ λ a b, by simp only [rel_iff_exists_classes, exists_prop, h] ⟩

/-- The empty set is not an equivalence class. -/
lemma empty_not_mem_classes {r : setoid α} : ∅ ∉ r.classes :=
λ ⟨y, hy⟩, set.not_mem_empty y $ hy.symm ▸ r.refl' y

/-- Equivalence classes partition the type. -/
lemma classes_eqv_classes {r : setoid α} (a) : ∃! b ∈ r.classes, a ∈ b :=
exists_unique.intro2 {x | r.rel x a} (r.mem_classes a) (r.refl' _) $
begin
  rintros _ ⟨y, rfl⟩ ha,
  ext x,
  exact ⟨λ hx, r.trans' hx (r.symm' ha), λ hx, r.trans' hx ha⟩
end

/-- If x ∈ α is in 2 equivalence classes, the equivalence classes are equal. -/
lemma eq_of_mem_classes {r : setoid α} {x b} (hc : b ∈ r.classes)
  (hb : x ∈ b) {b'} (hc' : b' ∈ r.classes) (hb' : x ∈ b') : b = b' :=
eq_of_mem_eqv_class classes_eqv_classes hc hb hc' hb'

/-- The elements of a set of sets partitioning α are the equivalence classes of the
    equivalence relation defined by the set of sets. -/
lemma eq_eqv_class_of_mem {c : set (set α)}
  (H : ∀ a, ∃! b ∈ c, a ∈ b) {s y} (hs : s ∈ c) (hy : y ∈ s) :
  s = {x | (mk_classes c H).rel x y} :=
set.ext $ λ x,
  ⟨λ hs', symm' (mk_classes c H) $ λ b' hb' h', eq_of_mem_eqv_class H hs hy hb' h' ▸ hs',
   λ hx, (H x).elim2 $ λ b' hc' hb' h',
     (eq_of_mem_eqv_class H hs hy hc' $ hx b' hc' hb').symm ▸ hb'⟩

/-- The equivalence classes of the equivalence relation defined by a set of sets
    partitioning α are elements of the set of sets. -/
lemma eqv_class_mem {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b) {y} :
  {x | (mk_classes c H).rel x y} ∈ c :=
(H y).elim2 $ λ b hc hy hb, eq_eqv_class_of_mem H hc hy ▸ hc

lemma eqv_class_mem' {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b) {x} :
  {y : α | (mk_classes c H).rel x y} ∈ c :=
by { convert setoid.eqv_class_mem H, ext, rw setoid.comm' }

/-- Distinct elements of a set of sets partitioning α are disjoint. -/
lemma eqv_classes_disjoint {c : set (set α)} (H : ∀ a, ∃! b ∈ c, a ∈ b) :
  c.pairwise_disjoint id :=
λ b₁ h₁ b₂ h₂ h, set.disjoint_left.2 $
  λ x hx1 hx2, (H x).elim2 $ λ b hc hx hb, h $ eq_of_mem_eqv_class H h₁ hx1 h₂ hx2

/-- A set of disjoint sets covering α partition α (classical). -/
lemma eqv_classes_of_disjoint_union {c : set (set α)}
  (hu : set.sUnion c = @set.univ α) (H : c.pairwise_disjoint id) (a) :
  ∃! b ∈ c, a ∈ b :=
let ⟨b, hc, ha⟩ := set.mem_sUnion.1 $ show a ∈ _, by rw hu; exact set.mem_univ a in
  exists_unique.intro2 b hc ha $ λ b' hc' ha', H.elim_set hc' hc a ha' ha

/-- Makes an equivalence relation from a set of disjoints sets covering α. -/
def setoid_of_disjoint_union {c : set (set α)} (hu : set.sUnion c = @set.univ α)
  (H : c.pairwise_disjoint id) : setoid α :=
setoid.mk_classes c $ eqv_classes_of_disjoint_union hu H

/-- The equivalence relation made from the equivalence classes of an equivalence
    relation r equals r. -/
theorem mk_classes_classes (r : setoid α) :
  mk_classes r.classes classes_eqv_classes = r :=
ext' $ λ x y, ⟨λ h, r.symm' (h {z | r.rel z x} (r.mem_classes x) $ r.refl' x),
  λ h b hb hx, eq_of_mem_classes (r.mem_classes x) (r.refl' x) hb hx ▸ r.symm' h⟩

@[simp] theorem sUnion_classes (r : setoid α) : ⋃₀ r.classes = set.univ :=
set.eq_univ_of_forall $ λ x, set.mem_sUnion.2 ⟨{ y | r.rel y x }, ⟨x, rfl⟩, setoid.refl _⟩

section partition

/-- A collection `c : set (set α)` of sets is a partition of `α` into pairwise
disjoint sets if `∅ ∉ c` and each element `a : α` belongs to a unique set `b ∈ c`. -/
def is_partition (c : set (set α)) :=
∅ ∉ c ∧ ∀ a, ∃! b ∈ c, a ∈ b

/-- A partition of `α` does not contain the empty set. -/
lemma nonempty_of_mem_partition {c : set (set α)} (hc : is_partition c) {s} (h : s ∈ c) :
  s.nonempty :=
set.ne_empty_iff_nonempty.1 $ λ hs0, hc.1 $ hs0 ▸ h

lemma is_partition_classes (r : setoid α) : is_partition r.classes :=
⟨empty_not_mem_classes, classes_eqv_classes⟩

lemma is_partition.pairwise_disjoint {c : set (set α)} (hc : is_partition c) :
  c.pairwise_disjoint id :=
eqv_classes_disjoint hc.2

lemma is_partition.sUnion_eq_univ {c : set (set α)} (hc : is_partition c) :
  ⋃₀ c = set.univ :=
set.eq_univ_of_forall $ λ x, set.mem_sUnion.2 $
  let ⟨t, ht⟩ := hc.2 x in ⟨t, by { simp only [exists_unique_iff_exists] at ht, tauto }⟩

/-- All elements of a partition of α are the equivalence class of some y ∈ α. -/
lemma exists_of_mem_partition {c : set (set α)} (hc : is_partition c) {s} (hs : s ∈ c) :
  ∃ y, s = {x | (mk_classes c hc.2).rel x y} :=
let ⟨y, hy⟩ := nonempty_of_mem_partition hc hs in
  ⟨y, eq_eqv_class_of_mem hc.2 hs hy⟩

/-- The equivalence classes of the equivalence relation defined by a partition of α equal
    the original partition. -/
theorem classes_mk_classes (c : set (set α)) (hc : is_partition c) :
  (mk_classes c hc.2).classes = c :=
set.ext $ λ s,
  ⟨λ ⟨y, hs⟩, (hc.2 y).elim2 $ λ b hm hb hy,
    by rwa (show s = b, from hs.symm ▸ set.ext
      (λ x, ⟨λ hx, symm' (mk_classes c hc.2) hx b hm hb,
             λ hx b' hc' hx', eq_of_mem_eqv_class hc.2 hm hx hc' hx' ▸ hb⟩)),
   exists_of_mem_partition hc⟩

/-- Defining `≤` on partitions as the `≤` defined on their induced equivalence relations. -/
instance partition.le : has_le (subtype (@is_partition α)) :=
⟨λ x y, mk_classes x.1 x.2.2 ≤ mk_classes y.1 y.2.2⟩

/-- Defining a partial order on partitions as the partial order on their induced
    equivalence relations. -/
instance partition.partial_order : partial_order (subtype (@is_partition α)) :=
{ le := (≤),
  lt := λ x y, x ≤ y ∧ ¬y ≤ x,
  le_refl := λ _, @le_refl (setoid α) _ _,
  le_trans := λ _ _ _, @le_trans (setoid α) _ _ _ _,
  lt_iff_le_not_le := λ _ _, iff.rfl,
  le_antisymm := λ x y hx hy, let h := @le_antisymm (setoid α) _ _ _ hx hy in by
    rw [subtype.ext_iff_val, ←classes_mk_classes x.1 x.2, ←classes_mk_classes y.1 y.2, h] }

variables (α)

/-- The order-preserving bijection between equivalence relations on a type `α`, and
  partitions of `α` into subsets. -/
protected def partition.order_iso :
  setoid α ≃o {C : set (set α) // is_partition C} :=
{ to_fun := λ r, ⟨r.classes, empty_not_mem_classes, classes_eqv_classes⟩,
  inv_fun := λ C, mk_classes C.1 C.2.2,
  left_inv := mk_classes_classes,
  right_inv := λ C, by rw [subtype.ext_iff_val, ←classes_mk_classes C.1 C.2],
  map_rel_iff' := λ r s,
    by { conv_rhs { rw [←mk_classes_classes r, ←mk_classes_classes s] }, refl } }

variables {α}

/-- A complete lattice instance for partitions; there is more infrastructure for the
    equivalent complete lattice on equivalence relations. -/
instance partition.complete_lattice : complete_lattice (subtype (@is_partition α)) :=
galois_insertion.lift_complete_lattice $ @order_iso.to_galois_insertion
_ (subtype (@is_partition α)) _ (partial_order.to_preorder _) $ partition.order_iso α

end partition

/-- A finite setoid partition furnishes a finpartition -/
@[simps]
def is_partition.finpartition {c : finset (set α)}
  (hc : setoid.is_partition (c : set (set α))) : finpartition (set.univ : set α) :=
{ parts := c,
  sup_indep := finset.sup_indep_iff_pairwise_disjoint.mpr $ eqv_classes_disjoint hc.2,
  sup_parts := c.sup_id_set_eq_sUnion.trans hc.sUnion_eq_univ,
  not_bot_mem := hc.left }

end setoid

/-- A finpartition gives rise to a setoid partition -/
theorem finpartition.is_partition_parts {α} (f : finpartition (set.univ : set α)) :
  setoid.is_partition (f.parts : set (set α)) :=
⟨f.not_bot_mem, setoid.eqv_classes_of_disjoint_union
  (f.parts.sup_id_set_eq_sUnion.symm.trans f.sup_parts) f.sup_indep.pairwise_disjoint⟩

/-- Constructive information associated with a partition of a type `α` indexed by another type `ι`,
`s : ι → set α`.

`indexed_partition.index` sends an element to its index, while `indexed_partition.some` sends
an index to an element of the corresponding set.

This type is primarily useful for definitional control of `s` - if this is not needed, then
`setoid.ker index` by itself may be sufficient. -/
structure indexed_partition {ι α : Type*} (s : ι → set α) :=
(eq_of_mem : ∀ {x i j}, x ∈ s i → x ∈ s j → i = j)
(some : ι → α)
(some_mem : ∀ i, some i ∈ s i)
(index : α → ι)
(mem_index : ∀ x, x ∈ s (index x))

/-- The non-constructive constructor for `indexed_partition`. -/
noncomputable
def indexed_partition.mk' {ι α : Type*} (s : ι → set α) (dis : ∀ i j, i ≠ j → disjoint (s i) (s j))
  (nonempty : ∀ i, (s i).nonempty) (ex : ∀ x, ∃ i, x ∈ s i) : indexed_partition s :=
{ eq_of_mem := λ x i j hxi hxj, classical.by_contradiction $ λ h, dis _ _ h ⟨hxi, hxj⟩,
  some := λ i, (nonempty i).some,
  some_mem := λ i, (nonempty i).some_spec,
  index := λ x, (ex x).some,
  mem_index := λ x, (ex x).some_spec }

namespace indexed_partition

open set

variables {ι α : Type*} {s : ι → set α} (hs : indexed_partition s)

/-- On a unique index set there is the obvious trivial partition -/
instance [unique ι] [inhabited α] :
  inhabited (indexed_partition (λ i : ι, (set.univ : set α))) :=
⟨{ eq_of_mem := λ x i j hi hj, subsingleton.elim _ _,
   some := λ i, default,
   some_mem := set.mem_univ,
   index := λ a, default,
   mem_index := set.mem_univ }⟩

attribute [simp] some_mem mem_index

include hs

lemma exists_mem (x : α) : ∃ i, x ∈ s i := ⟨hs.index x, hs.mem_index x⟩

lemma Union : (⋃ i, s i) = univ :=
by { ext x, simp [hs.exists_mem x] }

lemma disjoint : ∀ {i j}, i ≠ j → disjoint (s i) (s j) :=
λ i j h x ⟨hxi, hxj⟩, h (hs.eq_of_mem hxi hxj)

lemma mem_iff_index_eq {x i} : x ∈ s i ↔ hs.index x = i :=
⟨λ hxi, (hs.eq_of_mem hxi (hs.mem_index x)).symm, λ h, h ▸ hs.mem_index _⟩

lemma eq (i) : s i = {x | hs.index x = i} :=
set.ext $ λ _, hs.mem_iff_index_eq

/-- The equivalence relation associated to an indexed partition. Two
elements are equivalent if they belong to the same set of the partition. -/
protected abbreviation setoid (hs : indexed_partition s) : setoid α :=
setoid.ker hs.index

@[simp]

lemma some_index (x : α) : hs.setoid.rel (hs.some (hs.index x)) x :=
hs.index_some (hs.index x)

/-- The quotient associated to an indexed partition. -/
protected def quotient := quotient hs.setoid

/-- The projection onto the quotient associated to an indexed partition. -/
def proj : α → hs.quotient := quotient.mk'

instance [inhabited α] : inhabited (hs.quotient) := ⟨hs.proj default⟩

lemma proj_eq_iff {x y : α} : hs.proj x = hs.proj y ↔ hs.index x = hs.index y :=
quotient.eq_rel

@[simp] lemma proj_some_index (x : α) : hs.proj (hs.some (hs.index x)) = hs.proj x :=
quotient.eq'.2 (hs.some_index x)

/-- The obvious equivalence between the quotient associated to an indexed partition and
the indexing type. -/
def equiv_quotient : ι ≃ hs.quotient :=
(setoid.quotient_ker_equiv_of_right_inverse hs.index hs.some $ hs.index_some).symm

@[simp] lemma equiv_quotient_index_apply (x : α) : hs.equiv_quotient (hs.index x) = hs.proj x :=
hs.proj_eq_iff.mpr (some_index hs x)

@[simp] lemma equiv_quotient_symm_proj_apply (x : α) :
  hs.equiv_quotient.symm (hs.proj x) = hs.index x :=
rfl

lemma equiv_quotient_index : hs.equiv_quotient ∘ hs.index = hs.proj :=
funext hs.equiv_quotient_index_apply

/-- A map choosing a representative for each element of the quotient associated to an indexed
partition. This is a computable version of `quotient.out'` using `indexed_partition.some`. -/
def out : hs.quotient ↪ α :=
hs.equiv_quotient.symm.to_embedding.trans ⟨hs.some, function.left_inverse.injective hs.index_some⟩

/-- This lemma is analogous to `quotient.mk_out'`. -/
@[simp]
lemma out_proj (x : α) : hs.out (hs.proj x) = hs.some (hs.index x) :=
rfl

/-- The indices of `quotient.out'` and `indexed_partition.out` are equal. -/
lemma index_out' (x : hs.quotient) : hs.index (x.out') = hs.index (hs.out x) :=
quotient.induction_on' x $ λ x, (setoid.ker_apply_mk_out' x).trans (hs.index_some _).symm

/-- This lemma is analogous to `quotient.out_eq'`. -/
@[simp] lemma proj_out (x : hs.quotient) : hs.proj (hs.out x) = x :=
quotient.induction_on' x $ λ x, quotient.sound' $ hs.some_index x

lemma class_of {x : α} : set_of (hs.setoid.rel x) = s (hs.index x) :=
set.ext $ λ y, eq_comm.trans hs.mem_iff_index_eq.symm

lemma proj_fiber (x : hs.quotient) : hs.proj ⁻¹' {x} = s (hs.equiv_quotient.symm x) :=
quotient.induction_on' x $ λ x, begin
  ext y,
  simp only [set.mem_preimage, set.mem_singleton_iff, hs.mem_iff_index_eq],
  exact quotient.eq',
end

end indexed_partition


import tactic.ring_exp
import tactic.zify
import algebra.group_with_zero.power
import tactic.field_simp

universes u

section addition
/-!
  ### `addition` section

  Test associativity and commutativity of `(+)`.
-/
example (a b : ℚ) : a = a := by ring_exp
example (a b : ℚ) : a + b = a + b := by ring_exp
example (a b : ℚ) : b + a = a + b := by ring_exp
example (a b : ℤ) : a + b + b = b + (a + b) := by ring_exp
example (a b c : ℕ) : a + b + b + (c + c) = c + (b + c) + (a + b) := by ring_exp
end addition

section numerals
/-!
  ### `numerals` section

  Test that numerals behave like rational numbers.
-/
example (a : ℕ) : a + 5 + 5 = 0 + a + 10 := by ring_exp
example (a : ℤ) : a + 5 + 5 = 0 + a + 10 := by ring_exp
example (a : ℚ) : (1/2) * a + (1/2) * a = a := by ring_exp
end numerals

section multiplication
/-!
  ### `multiplication section`

  Test that multiplication is associative and commutative.
  Also test distributivity of `(+)` and `(*)`.
-/
example (a : ℕ) : 0 = a * 0 := by ring_exp_eq
example (a : ℕ) : a = a * 1 := by ring_exp
example (a : ℕ) : a + a = a * 2 := by ring_exp
example (a b : ℤ) : a * b = b * a := by ring_exp
example (a b : ℕ) : a * 4 * b + a = a * (4 * b + 1) := by ring_exp
end multiplication

section exponentiation
/-!
  ### `exponentiation` section

  Test that exponentiation has the correct distributivity properties.
-/
example : 0 ^ 1 = 0 := by ring_exp
example : 0 ^ 2 = 0 := by ring_exp
example (a : ℕ) : a ^ 0 = 1 := by ring_exp
example (a : ℕ) : a ^ 1 = a := by ring_exp
example (a : ℕ) : a ^ 2 = a * a := by ring_exp
example (a b : ℕ) : a ^ b = a ^ b := by ring_exp
example (a b : ℕ) : a ^ (b + 1) = a * a ^ b := by ring_exp
example (n : ℕ) (a m : ℕ) : a * a^n * m = a^(n+1) * m := by ring_exp
example (n : ℕ) (a m : ℕ) : m * a^n * a = a^(n+1) * m := by ring_exp
example (n : ℕ) (a m : ℤ) : a * a^n * m = a^(n+1) * m := by ring_exp
example (n : ℕ) (m : ℤ) : 2 * 2^n * m = 2^(n+1) * m := by ring_exp
example (n : ℕ) (m : ℤ) : 2^(n+1) * m = 2 * 2^n * m := by ring_exp
example (n m : ℕ) (a : ℤ) : (a ^ n)^m = a^(n * m) := by ring_exp
example (n m : ℕ) (a : ℤ) : a^(n^0) = a^1 := by ring_exp
example (n : ℕ) : 0^(n + 1) = 0 := by ring_exp
example {α} [comm_ring α] (x : α) (k : ℕ) : x ^ (k + 2) = x * x * x^k := by ring_exp
example {α} [comm_ring α] (k : ℕ) (x y z : α) :
  x * (z * (x - y)) + (x * (y * y ^ k) - y * (y * y ^ k)) = (z * x + y * y ^ k) * (x - y)
:= by ring_exp

-- We can represent a large exponent `n` more efficiently than just `n` multiplications:
example (a b : ℚ) : (a * b) ^ 1000000 = (b * a) ^ 1000000 := by ring_exp

example (n : ℕ) : 2 ^ (n + 1 + 1)  = 2 * 2 ^ (n + 1) :=
by ring_exp_eq

end exponentiation

section power_of_sum
/-!
  ### `power_of_sum` section

  Test that raising a sum to a power behaves like repeated multiplication,
  if needed.
-/
example (a b : ℤ) : (a + b)^2 = a^2 + b^2 + a * b + b * a := by ring_exp
example (a b : ℤ) (n : ℕ) : (a + b)^(n + 2) = (a^2 + b^2 + a * b + b * a) * (a + b)^n := by ring_exp
end power_of_sum

section negation
/-!
  ### `negation` section

  Test that negation and subtraction satisfy the expected properties,
  also in semirings such as `ℕ`.
-/
example {α} [comm_ring α] (a : α) : a - a = 0 := by ring_exp_eq
example (a : ℤ) : a - a = 0 := by ring_exp
example (a : ℤ) : a + - a = 0 := by ring_exp
example (a : ℤ) : - a = (-1) * a := by ring_exp
-- Here, (a - b) is treated as an atom.
example (a b : ℕ) : a - b + a + a = a - b + 2 * a := by ring_exp
example (n : ℕ) : n + 1 - 1 = n := by ring_exp! -- But we can force a bit of evaluation anyway.
end negation

constant f {α} : α → α
section complicated
/-!
  ### `complicated` section

  Test that complicated, real-life expressions also get normalized.
-/
example {α : Type} [linear_ordered_field α] (x : α) :
  2 * x + 1 * 1 - (2 * f (x + 1 / 2) + 2 * 1) + (1 * 1 - (2 * x - 2 * f (x + 1 / 2))) = 0
:= by ring_exp_eq
example {α : Type u} [linear_ordered_field α] (x : α) :
  f (x + 1 / 2) ^ 1 * -2 + (f (x + 1 / 2) ^ 1 * 2 + 0) = 0
:= by ring_exp_eq

example (x y : ℕ) : x + id y = y + id x := by ring_exp!

-- Here, we check that `n - s` is not treated as `n + additive_inverse s`,
-- if `s` doesn't have an additive inverse.
example (B s n : ℕ) : B * (f s * ((n - s) * f (n - s - 1))) = B * (n - s) * (f s * f (n - s - 1)) :=
by ring_exp

-- This is a somewhat subtle case: `-c/b` is parsed as `(-c)/b`,
-- so we can't simply treat both sides of the division as atoms.
-- Instead, we follow the `ring` tactic in interpreting `-c / b` as `-c * b⁻¹`,
-- with only `b⁻¹` an atom.
example {α} [linear_ordered_field α] (a b c : α) : a*(-c/b)*(-c/b) = a*((c/b)*(c/b)) := by ring_exp

-- test that `field_simp` works fine with powers and `ring_exp`.
example (x y : ℚ) (n : ℕ) (hx : x ≠ 0) (hy : y ≠ 0) :
  1/ (2/(x / y))^(2 * n) + y / y^(n+1) - (x/y)^n * (x/(2 * y))^n / 2 ^n = 1/y^n :=
begin
  field_simp,
  ring_exp
end
end complicated

-- Test that `nat.succ d` gets handled as `d + 1`.
example (d : ℕ) : 2 * (2 ^ d - 1) + 1 = 2 ^ d.succ - 1 :=
begin
  zify [nat.one_le_pow'],
  ring_exp,
end

section conv
/-!
  ### `conv` section

  Test that `ring_exp` works inside of `conv`, both with and without `!`.
-/

example (n : ℕ) : (2^n * 2 + 1)^10 = (2^(n+1) + 1)^10 :=
begin
conv_rhs
{ congr,
  ring_exp, },
conv_lhs
{ congr,
  ring_exp, },
end

example (x y : ℤ) : x + id y - y + id x = x * 2 := begin
  conv_lhs { ring_exp!, },
end
end conv

section benchmark
/-!
  ### `benchmark` section

  The `ring_exp` tactic shouldn't be too slow.
-/
-- This last example was copied from `data/polynomial.lean`, because it timed out.
-- After some optimization, it doesn't.
variables {α : Type} [comm_ring α]
def pow_sub_pow_factor (x y : α) : Π {i : ℕ},{z // x^i - y^i = z*(x - y)}
| 0 := ⟨0, by simp⟩
| 1 := ⟨1, by simp⟩
| (k+2) :=
begin
  cases @pow_sub_pow_factor (k+1) with z hz,
  existsi z*x + y^(k+1),
  rw [pow_succ x, pow_succ y, ←sub_add_sub_cancel (x*x^(k+1)) (x*y^(k+1)),
  ←mul_sub x, hz],
  ring_exp_eq
end

-- Another benchmark: bound the growth of the complexity somewhat.
example {α} [comm_semiring α] (x : α) : (x + 1) ^ 4 = (1 + x) ^ 4   := by try_for  5000 {ring_exp}
example {α} [comm_semiring α] (x : α) : (x + 1) ^ 6 = (1 + x) ^ 6   := by try_for 10000 {ring_exp}
example {α} [comm_semiring α] (x : α) : (x + 1) ^ 8 = (1 + x) ^ 8   := by try_for 15000 {ring_exp}
end benchmark