/-
Copyright (c) 2018 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/
import analysis.normed_space.basic
import data.polynomial.algebra_map
import data.polynomial.inductions

/-!
# Polynomials and limits

In this file we prove the following lemmas.

* `polynomial.continuous_eval₂: `polynomial.eval₂` defines a continuous function.
* `polynomial.continuous_aeval: `polynomial.aeval` defines a continuous function;
  we also prove convenience lemmas `polynomial.continuous_at_aeval`,
  `polynomial.continuous_within_at_aeval`, `polynomial.continuous_on_aeval`.
* `polynomial.continuous`:  `polynomial.eval` defines a continuous functions;
  we also prove convenience lemmas `polynomial.continuous_at`, `polynomial.continuous_within_at`,
  `polynomial.continuous_on`.
* `polynomial.tendsto_norm_at_top`: `λ x, ∥polynomial.eval (z x) p∥` tends to infinity provided that
  `λ x, ∥z x∥` tends to infinity and `0 < degree p`;
* `polynomial.tendsto_abv_eval₂_at_top`, `polynomial.tendsto_abv_at_top`,
  `polynomial.tendsto_abv_aeval_at_top`: a few versions of the previous statement for
  `is_absolute_value abv` instead of norm.

## Tags

polynomial, continuity
-/

open is_absolute_value filter

namespace polynomial
open_locale polynomial

section topological_semiring

variables {R S : Type*} [semiring R] [topological_space R] [topological_semiring R]
  (p : R[X])

@[continuity]
protected lemma continuous_eval₂ [semiring S] (p : S[X]) (f : S →+* R) :
  continuous (λ x, p.eval₂ f x) :=
begin
  dsimp only [eval₂_eq_sum, finsupp.sum],
  exact continuous_finset_sum _ (λ c hc, continuous_const.mul (continuous_pow _))
end

@[continuity]
protected lemma continuous : continuous (λ x, p.eval x) :=
p.continuous_eval₂ _

protected lemma continuous_at {a : R} : continuous_at (λ x, p.eval x) a :=
p.continuous.continuous_at

protected lemma continuous_within_at {s a} : continuous_within_at (λ x, p.eval x) s a :=
p.continuous.continuous_within_at

protected lemma continuous_on {s} : continuous_on (λ x, p.eval x) s :=
p.continuous.continuous_on

end topological_semiring

section topological_algebra

variables {R A : Type*} [comm_semiring R] [semiring A] [algebra R A]
  [topological_space A] [topological_semiring A]
  (p : R[X])

@[continuity]
protected lemma continuous_aeval : continuous (λ x : A, aeval x p) :=
p.continuous_eval₂ _

protected lemma continuous_at_aeval {a : A} : continuous_at (λ x : A, aeval x p) a :=
p.continuous_aeval.continuous_at

protected lemma continuous_within_at_aeval {s a} : continuous_within_at (λ x : A, aeval x p) s a :=
p.continuous_aeval.continuous_within_at

protected lemma continuous_on_aeval {s} : continuous_on (λ x : A, aeval x p) s :=
p.continuous_aeval.continuous_on

end topological_algebra

lemma tendsto_abv_eval₂_at_top {R S k α : Type*} [semiring R] [ring S] [linear_ordered_field k]
  (f : R →+* S) (abv : S → k) [is_absolute_value abv] (p : R[X]) (hd : 0 < degree p)
  (hf : f p.leading_coeff ≠ 0) {l : filter α} {z : α → S} (hz : tendsto (abv ∘ z) l at_top) :
  tendsto (λ x, abv (p.eval₂ f (z x))) l at_top :=
begin
  revert hf, refine degree_pos_induction_on p hd _ _ _; clear hd p,
  { rintros c - hc,
    rw [leading_coeff_mul_X, leading_coeff_C] at hc,
    simpa [abv_mul abv] using hz.const_mul_at_top ((abv_pos abv).2 hc) },
  { intros p hpd ihp hf,
    rw [leading_coeff_mul_X] at hf,
    simpa [abv_mul abv] using  (ihp hf).at_top_mul_at_top hz },
  { intros p a hd ihp hf,
    rw [add_comm, leading_coeff_add_of_degree_lt (degree_C_le.trans_lt hd)] at hf,
    refine tendsto_at_top_of_add_const_right (abv (-f a)) _,
    refine tendsto_at_top_mono (λ _, abv_add abv _ _) _,
    simpa using ihp hf }
end

lemma tendsto_abv_at_top {R k α : Type*} [ring R] [linear_ordered_field k]
  (abv : R → k) [is_absolute_value abv] (p : R[X]) (h : 0 < degree p)
  {l : filter α} {z : α → R} (hz : tendsto (abv ∘ z) l at_top) :
  tendsto (λ x, abv (p.eval (z x))) l at_top :=
tendsto_abv_eval₂_at_top _ _ _ h (mt leading_coeff_eq_zero.1 $ ne_zero_of_degree_gt h) hz

lemma tendsto_abv_aeval_at_top {R A k α : Type*} [comm_semiring R] [ring A] [algebra R A]
  [linear_ordered_field k] (abv : A → k) [is_absolute_value abv] (p : R[X])
  (hd : 0 < degree p) (h₀ : algebra_map R A p.leading_coeff ≠ 0)
  {l : filter α} {z : α → A} (hz : tendsto (abv ∘ z) l at_top) :
  tendsto (λ x, abv (aeval (z x) p)) l at_top :=
tendsto_abv_eval₂_at_top _ abv p hd h₀ hz

variables {α R : Type*} [normed_ring R] [is_absolute_value (norm : R → ℝ)]

lemma tendsto_norm_at_top (p : R[X]) (h : 0 < degree p) {l : filter α} {z : α → R}
  (hz : tendsto (λ x, ∥z x∥) l at_top) :
  tendsto (λ x, ∥p.eval (z x)∥) l at_top :=
p.tendsto_abv_at_top norm h hz

lemma exists_forall_norm_le [proper_space R] (p : R[X]) :
  ∃ x, ∀ y, ∥p.eval x∥ ≤ ∥p.eval y∥ :=
if hp0 : 0 < degree p
then p.continuous.norm.exists_forall_le $ p.tendsto_norm_at_top hp0 tendsto_norm_cocompact_at_top
else ⟨p.coeff 0, by rw [eq_C_of_degree_le_zero (le_of_not_gt hp0)]; simp⟩

end polynomial


/-
Copyright (c) 2023 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module ring_theory.complex
! leanprover-community/mathlib commit 9015c511549dc77a0f8d6eba021d8ac4bba20c82
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Complex.Module
import Mathbin.RingTheory.Norm
import Mathbin.RingTheory.Trace

/-! # Lemmas about `algebra.trace` and `algebra.norm` on `ℂ` -/

open Complex

/- ./././Mathport/Syntax/Translate/Expr.lean:207:4: warning: unsupported notation `«expr!![ » -/
/- ./././Mathport/Syntax/Translate/Expr.lean:387:14: unsupported user notation matrix.notation -/
theorem Algebra.leftMulMatrix_complex (z : ℂ) :
    Algebra.leftMulMatrix Complex.basisOneI z =
      «expr!![ »
        "./././Mathport/Syntax/Translate/Expr.lean:387:14: unsupported user notation matrix.notation" :=
  by
  ext (i j)
  rw [Algebra.leftMulMatrix_eq_repr_mul, Complex.coe_basisOneI_repr, Complex.coe_basisOneI, mul_re,
    mul_im, Matrix.of_apply]
  fin_cases j
  · simp_rw [Matrix.cons_val_zero, one_re, one_im, MulZeroClass.mul_zero, mul_one, sub_zero,
      zero_add]
    fin_cases i <;> rfl
  · simp_rw [Matrix.cons_val_one, Matrix.head_cons, I_re, I_im, MulZeroClass.mul_zero, mul_one,
      zero_sub, add_zero]
    fin_cases i <;> rfl
#align algebra.left_mul_matrix_complex Algebra.leftMulMatrix_complex

theorem Algebra.trace_complex_apply (z : ℂ) : Algebra.trace ℝ ℂ z = 2 * z.re :=
  by
  rw [Algebra.trace_eq_matrix_trace Complex.basisOneI, Algebra.leftMulMatrix_complex,
    Matrix.trace_fin_two]
  exact (two_mul _).symm
#align algebra.trace_complex_apply Algebra.trace_complex_apply

theorem Algebra.norm_complex_apply (z : ℂ) : Algebra.norm ℝ z = z.normSq :=
  by
  rw [Algebra.norm_eq_matrix_det Complex.basisOneI, Algebra.leftMulMatrix_complex,
    Matrix.det_fin_two, norm_sq_apply]
  simp
#align algebra.norm_complex_apply Algebra.norm_complex_apply

theorem Algebra.norm_complex_eq : Algebra.norm ℝ = normSq.toMonoidHom :=
  MonoidHom.ext Algebra.norm_complex_apply
#align algebra.norm_complex_eq Algebra.norm_complex_eq


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

! This file was ported from Lean 3 source module category_theory.limits.shapes.disjoint_coproduct
! leanprover-community/mathlib commit f47581155c818e6361af4e4fda60d27d020c226b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Shapes.BinaryProducts
import Mathbin.CategoryTheory.Limits.Shapes.Pullbacks

/-!
# Disjoint coproducts

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

Defines disjoint coproducts: coproducts where the intersection is initial and the coprojections
are monic.
Shows that a category with disjoint coproducts is `initial_mono_class`.

## TODO

* Adapt this to the infinitary (small) version: This is one of the conditions in Giraud's theorem
  characterising sheaf topoi.
* Construct examples (and counterexamples?), eg Type, Vec.
* Define extensive categories, and show every extensive category has disjoint coproducts.
* Define coherent categories and use this to define positive coherent categories.
-/

universe v u u₂

namespace CategoryTheory

namespace Limits

open Category

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

#print CategoryTheory.Limits.CoproductDisjoint /-
/-- Given any pullback diagram of the form

Z  ⟶  X₁
↓      ↓
X₂ ⟶  X

where `X₁ ⟶ X ← X₂` is a coproduct diagram, then `Z` is initial, and both `X₁ ⟶ X` and `X₂ ⟶ X`
are mono.
-/
class CoproductDisjoint (X₁ X₂ : C) where
  isInitialOfIsPullbackOfIsCoproduct :
    ∀ {X Z} {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} {f : Z ⟶ X₁} {g : Z ⟶ X₂}
      (cX : IsColimit (BinaryCofan.mk pX₁ pX₂)) {comm : f ≫ pX₁ = g ≫ pX₂},
      IsLimit (PullbackCone.mk _ _ comm) → IsInitial Z
  mono_inl : ∀ (X) (X₁ : X₁ ⟶ X) (X₂ : X₂ ⟶ X) (cX : IsColimit (BinaryCofan.mk X₁ X₂)), Mono X₁
  mono_inr : ∀ (X) (X₁ : X₁ ⟶ X) (X₂ : X₂ ⟶ X) (cX : IsColimit (BinaryCofan.mk X₁ X₂)), Mono X₂
#align category_theory.limits.coproduct_disjoint CategoryTheory.Limits.CoproductDisjoint
-/

#print CategoryTheory.Limits.isInitialOfIsPullbackOfIsCoproduct /-
/-- If the coproduct of `X₁` and `X₂` is disjoint, then given any pullback square

Z  ⟶  X₁
↓      ↓
X₂ ⟶  X

where `X₁ ⟶ X ← X₂` is a coproduct, then `Z` is initial.
-/
def isInitialOfIsPullbackOfIsCoproduct {Z X₁ X₂ X : C} [CoproductDisjoint X₁ X₂] {pX₁ : X₁ ⟶ X}
    {pX₂ : X₂ ⟶ X} (cX : IsColimit (BinaryCofan.mk pX₁ pX₂)) {f : Z ⟶ X₁} {g : Z ⟶ X₂}
    {comm : f ≫ pX₁ = g ≫ pX₂} (cZ : IsLimit (PullbackCone.mk _ _ comm)) : IsInitial Z :=
  CoproductDisjoint.isInitialOfIsPullbackOfIsCoproduct cX cZ
#align category_theory.limits.is_initial_of_is_pullback_of_is_coproduct CategoryTheory.Limits.isInitialOfIsPullbackOfIsCoproduct
-/

#print CategoryTheory.Limits.isInitialOfIsPullbackOfCoproduct /-
/-- If the coproduct of `X₁` and `X₂` is disjoint, then given any pullback square

Z  ⟶  X₁
↓       ↓
X₂ ⟶  X₁ ⨿ X₂

`Z` is initial.
-/
noncomputable def isInitialOfIsPullbackOfCoproduct {Z X₁ X₂ : C} [HasBinaryCoproduct X₁ X₂]
    [CoproductDisjoint X₁ X₂] {f : Z ⟶ X₁} {g : Z ⟶ X₂}
    {comm : f ≫ (coprod.inl : X₁ ⟶ _ ⨿ X₂) = g ≫ coprod.inr}
    (cZ : IsLimit (PullbackCone.mk _ _ comm)) : IsInitial Z :=
  CoproductDisjoint.isInitialOfIsPullbackOfIsCoproduct (coprodIsCoprod _ _) cZ
#align category_theory.limits.is_initial_of_is_pullback_of_coproduct CategoryTheory.Limits.isInitialOfIsPullbackOfCoproduct
-/

#print CategoryTheory.Limits.isInitialOfPullbackOfIsCoproduct /-
/-- If the coproduct of `X₁` and `X₂` is disjoint, then provided `X₁ ⟶ X ← X₂` is a coproduct the
pullback is an initial object:

        X₁
        ↓
X₂ ⟶  X
-/
noncomputable def isInitialOfPullbackOfIsCoproduct {X X₁ X₂ : C} [CoproductDisjoint X₁ X₂]
    {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} [HasPullback pX₁ pX₂] (cX : IsColimit (BinaryCofan.mk pX₁ pX₂)) :
    IsInitial (pullback pX₁ pX₂) :=
  CoproductDisjoint.isInitialOfIsPullbackOfIsCoproduct cX (pullbackIsPullback _ _)
#align category_theory.limits.is_initial_of_pullback_of_is_coproduct CategoryTheory.Limits.isInitialOfPullbackOfIsCoproduct
-/

#print CategoryTheory.Limits.isInitialOfPullbackOfCoproduct /-
/-- If the coproduct of `X₁` and `X₂` is disjoint, the pullback of `X₁ ⟶ X₁ ⨿ X₂` and `X₂ ⟶ X₁ ⨿ X₂`
is initial.
-/
noncomputable def isInitialOfPullbackOfCoproduct {X₁ X₂ : C} [HasBinaryCoproduct X₁ X₂]
    [CoproductDisjoint X₁ X₂] [HasPullback (coprod.inl : X₁ ⟶ _ ⨿ X₂) coprod.inr] :
    IsInitial (pullback (coprod.inl : X₁ ⟶ _ ⨿ X₂) coprod.inr) :=
  isInitialOfIsPullbackOfCoproduct (pullbackIsPullback _ _)
#align category_theory.limits.is_initial_of_pullback_of_coproduct CategoryTheory.Limits.isInitialOfPullbackOfCoproduct
-/

instance {X₁ X₂ : C} [HasBinaryCoproduct X₁ X₂] [CoproductDisjoint X₁ X₂] :
    Mono (coprod.inl : X₁ ⟶ X₁ ⨿ X₂) :=
  CoproductDisjoint.mono_inl _ _ _ (coprodIsCoprod _ _)

instance {X₁ X₂ : C} [HasBinaryCoproduct X₁ X₂] [CoproductDisjoint X₁ X₂] :
    Mono (coprod.inr : X₂ ⟶ X₁ ⨿ X₂) :=
  CoproductDisjoint.mono_inr _ _ _ (coprodIsCoprod _ _)

#print CategoryTheory.Limits.CoproductsDisjoint /-
/-- `C` has disjoint coproducts if every coproduct is disjoint. -/
class CoproductsDisjoint (C : Type u) [Category.{v} C] where
  CoproductDisjoint : ∀ X Y : C, CoproductDisjoint X Y
#align category_theory.limits.coproducts_disjoint CategoryTheory.Limits.CoproductsDisjoint
-/

attribute [instance] coproducts_disjoint.coproduct_disjoint

#print CategoryTheory.Limits.initialMonoClass_of_disjoint_coproducts /-
/-- If `C` has disjoint coproducts, any morphism out of initial is mono. Note it isn't true in
general that `C` has strict initial objects, for instance consider the category of types and
partial functions. -/
theorem initialMonoClass_of_disjoint_coproducts [CoproductsDisjoint C] : InitialMonoClass C :=
  {
    isInitial_mono_from := fun I X hI =>
      CoproductDisjoint.mono_inl _ _ (𝟙 X)
        { desc := fun s : BinaryCofan _ _ => s.inr
          fac := fun s j =>
            Discrete.casesOn j fun j => WalkingPair.casesOn j (hI.hom_ext _ _) (id_comp _)
          uniq := fun (s : BinaryCofan _ _) m w =>
            (id_comp _).symm.trans (w ⟨WalkingPair.right⟩) } }
#align category_theory.limits.initial_mono_class_of_disjoint_coproducts CategoryTheory.Limits.initialMonoClass_of_disjoint_coproducts
-/

end Limits

end CategoryTheory


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.homology.image_to_kernel_map
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Exact sequences

In a category with zero morphisms, images, and equalizers we say that `f : A ⟶ B` and `g : B ⟶ C`
are exact if `f ≫ g = 0` and the natural map `image f ⟶ kernel g` is an epimorphism.

This definition is equivalent to the homology at `B` vanishing (at least for preadditive
categories). At this level of generality, this is not necessarily equivalent to other reasonable
definitions of exactness, for example that the inclusion map `image.ι f` is a kernel of `g` or that
the map `image f ⟶ kernel g` is an isomorphism. By adding more assumptions on our category, we get
these equivalences and more. Currently, there is one particular set of assumptions mathlib knows
about: abelian categories. Consequently, many interesting results about exact sequences are found in
`category_theory/abelian/exact.lean`.

# Main results
* Suppose that cokernels exist and that `f` and `g` are exact. If `s` is any kernel fork over `g`
  and `t` is any cokernel cofork over `f`, then `fork.ι s ≫ cofork.π t = 0`.
* Precomposing the first morphism with an epimorphism retains exactness. Postcomposing the second
  morphism with a monomorphism retains exactness.
* If `f` and `g` are exact and `i` is an isomorphism, then `f ≫ i.hom` and `i.inv ≫ g` are also
  exact.

# Future work
* Short exact sequences, split exact sequences, the splitting lemma (maybe only for abelian
  categories?)
* Two adjacent maps in a chain complex are exact iff the homology vanishes

-/

namespace category_theory

/-- Two morphisms `f : A ⟶ B`, `g : B ⟶ C` are called exact if `f ≫ g = 0` and the natural map
    `image f ⟶ kernel g` is an epimorphism. -/
class exact {V : Type u} [category V] [limits.has_zero_morphisms V] [limits.has_equalizers V]
    [limits.has_images V] {A : V} {B : V} {C : V} (f : A ⟶ B) (g : B ⟶ C)
    where
  w : f ≫ g = 0
  epi : epi (image_to_kernel_map f g w)

@[simp] theorem exact.w_assoc {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] {A : V} {B : V} {C : V} {f : A ⟶ B} {g : B ⟶ C}
    [c : exact f g] {X' : V} (f' : C ⟶ X') : f ≫ g ≫ f' = 0 ≫ f' :=
  sorry

theorem exact_comp_hom_inv_comp {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] {A : V} {B : V} {C : V} {D : V} {f : A ⟶ B}
    {g : B ⟶ C} [exact f g] (i : B ≅ D) : exact (f ≫ iso.hom i) (iso.inv i ≫ g) :=
  sorry

theorem exact_comp_hom_inv_comp_iff {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] {A : V} {B : V} {C : V} {D : V} {f : A ⟶ B}
    {g : B ⟶ C} (i : B ≅ D) : exact (f ≫ iso.hom i) (iso.inv i ≫ g) ↔ exact f g :=
  sorry

theorem exact_epi_comp {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] {A : V} {B : V} {C : V} {D : V} {f : A ⟶ B}
    {g : B ⟶ C} {h : C ⟶ D} [exact g h] [epi f] : exact (f ≫ g) h :=
  sorry

theorem exact_comp_mono {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] {A : V} {B : V} {C : V} {D : V} {f : A ⟶ B}
    {g : B ⟶ C} {h : C ⟶ D} [exact f g] [mono h] : exact f (g ≫ h) :=
  sorry

theorem exact_kernel {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] {A : V} {B : V} {f : A ⟶ B} :
    exact (limits.kernel.ι f) f :=
  sorry

theorem kernel_ι_eq_zero_of_exact_zero_left {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] (A : V) {B : V} {C : V} {g : B ⟶ C}
    [exact 0 g] : limits.kernel.ι g = 0 :=
  sorry

theorem exact_zero_left_of_mono {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] (A : V) {B : V} {C : V} {g : B ⟶ C}
    [limits.has_zero_object V] [mono g] : exact 0 g :=
  sorry

@[simp] theorem kernel_comp_cokernel_assoc {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] [limits.has_cokernels V] {A : V} {B : V} {C : V}
    (f : A ⟶ B) (g : B ⟶ C) [exact f g] {X' : V} (f' : limits.cokernel f ⟶ X') :
    limits.kernel.ι g ≫ limits.cokernel.π f ≫ f' = 0 ≫ f' :=
  sorry

theorem comp_eq_zero_of_exact {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] [limits.has_cokernels V] {A : V} {B : V} {C : V}
    (f : A ⟶ B) (g : B ⟶ C) [exact f g] {X : V} {Y : V} {ι : X ⟶ B} (hι : ι ≫ g = 0) {π : B ⟶ Y}
    (hπ : f ≫ π = 0) : ι ≫ π = 0 :=
  sorry

@[simp] theorem fork_ι_comp_cofork_π {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] [limits.has_cokernels V] {A : V} {B : V} {C : V}
    (f : A ⟶ B) (g : B ⟶ C) [exact f g] (s : limits.kernel_fork g) (t : limits.cokernel_cofork f) :
    limits.fork.ι s ≫ limits.cofork.π t = 0 :=
  comp_eq_zero_of_exact f g (limits.kernel_fork.condition s) (limits.cokernel_cofork.condition t)

theorem exact_of_zero {V : Type u} [category V] [limits.has_zero_morphisms V]
    [limits.has_equalizers V] [limits.has_images V] [limits.has_zero_object V] {A : V} {C : V}
    (f : A ⟶ 0) (g : 0 ⟶ C) : exact f g :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Koundinya Vajjha. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Koundinya Vajjha

A formalization of Basic probability theory + Bayes theorem.
-/
import measure_theory.measure_space tactic.tidy

open set measurable_space measure_theory ennreal lattice

universe u

/- The sample space -/
variable {s : Type u}

section probability_measure

structure probability_measure  (α : Type*) [measurable_space α] extends measure_theory.measure α :=
(is_one : measure_of univ = 1)

class probability_space (α : Type*) extends measurable_space α :=
(μ {} : probability_measure α)

instance prob.has_coe_to_fun {α} [probability_space α] : has_coe_to_fun (probability_measure α) :=
⟨λ _, set α → ennreal, λ m, m.to_measure⟩

/- The coercion of a ennreal probability measure to a nnreal probability measure -/
def prob [probability_space s] (p : probability_measure s) (a : set s)
:= (p a).to_nnreal

variables [probability_space s] (p : probability_measure s) (a : set s)

lemma prob_eq_coerc: prob p a = ennreal.to_nnreal(p a) := rfl

lemma coe_def (a : set s): p a = p.to_measure a := rfl

lemma prob_univ : p(univ) = 1 := p.is_one

lemma prob_univ_nnreal : prob p univ = 1 :=
begin
  rw [prob,prob_univ],refl,
end

lemma prob_le_1 :
Π (a : set(s)), p(a) ≤ (1:ennreal) :=
begin
  intros,
  rewrite ← prob_univ p,
  apply outer_measure.mono,
  apply subset_univ,
end

lemma prob_ne_top :
Π (a : set(s)), p(a) ≠ ⊤ :=
begin
  intros a,
  rw ← lattice.lt_top_iff_ne_top,
  have h : (1 : ennreal) < ⊤,
    { rw lattice.lt_top_iff_ne_top,
    apply ennreal.one_ne_top, },
  apply lt_of_le_of_lt (prob_le_1 p a) h,
end

@[simp] lemma coe_prob (a : set s) : (prob p a : ennreal) = p a := coe_to_nnreal  (prob_ne_top _ _)

lemma prob_le_1_nnreal :
Π (a : set(s)), prob p a ≤ (1:nnreal) :=
begin
  intros, rw ← ennreal.coe_le_coe,
  rw coe_prob,
  exact prob_le_1 p a,
end

lemma prob_empty : p(∅) = 0 := measure_empty

lemma prob_empty_nnreal : prob p ∅ = 0 :=
begin
rw prob, rw prob_empty, refl,
end

lemma prob_mono (a b : set s) (h1 : is_measurable a)
  (h2 : is_measurable b) : (a ⊆ b) → (p(a) ≤ p(b)) :=
  measure_theory.measure_mono

lemma prob_mono_nnreal (a b : set s) (h1 : is_measurable a)
  (h2 : is_measurable b) : (a ⊆ b) → (prob p a ≤ prob p b) :=
begin
  intros h,
  rw ← ennreal.coe_le_coe,
  rw [coe_prob,coe_prob],
  apply prob_mono p a b h1 h2 h,
end

lemma prob_comp
(a : set s)
(h: is_measurable a): p(-a) + p(a) = 1 :=
begin
  intros, rewrite ← prob_univ p,
  have h : ∀ x : set s, p x = p.to_measure x, {intros x, refl},
  repeat {rw h},
  rw [← compl_union_self a, measure_union _ _ _],
  apply disjoint_iff.2 (@compl_inter_self _ a),
  apply is_measurable.compl, repeat{assumption},
end

lemma prob_comp_nnreal
(a : set s)
(h: is_measurable a): prob p (-a) + prob p (a) = 1 :=
begin
  rw ← ennreal.coe_eq_coe,
  simp, rw add_comm,
  apply prob_comp p a h,
end

lemma prob_union {s : Type u} [probability_space s] (s₁ s₂ : set s) (hd : disjoint s₁ s₂) (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) (p : probability_measure s) :
  p (s₁ ∪ s₂) = p s₁ + p s₂ := measure_theory.measure_union hd h₁ h₂

lemma prob_union_nnreal {s : Type u} [probability_space s] (s₁ s₂ : set s)
(hd : disjoint s₁ s₂) (h₁ : is_measurable s₁) (h₂ : is_measurable s₂) (p : probability_measure s) :
  prob p (s₁ ∪ s₂) = prob p s₁ + prob p s₂ :=
begin
  rw ← ennreal.coe_eq_coe, simp, apply prob_union s₁ s₂ hd h₁ h₂,
end

lemma prob_diff_inter {s : Type u} [probability_space s](p : probability_measure s)
(a b : set s) (h₁ : is_measurable a) (h₂ : is_measurable b) :
p(b ∩ -a) + p(b ∩ a) = p(b) :=
begin
  have h :p(b) = p(b ∩ univ),
  by rewrite inter_univ b,
  rewrite [h,← compl_union_self a,set.inter_distrib_left,prob_union],
  have g : (b ∩ -a) ∩ (b ∩ a) = ∅, by rw [inter_left_comm,set.inter_assoc, compl_inter_self,inter_empty,inter_empty],
  apply disjoint_iff.2 g,
  {
    rewrite ← diff_eq,
    apply is_measurable.diff h₂ h₁,
  },
  apply is_measurable.inter h₂ h₁,
end

lemma prob_diff_inter_nnreal {s : Type u} [probability_space s](p : probability_measure s)
(a b : set s) (h₁ : is_measurable a) (h₂ : is_measurable b) :
prob p (b ∩ -a) + prob p (b ∩ a) = prob p (b) :=
begin
  rw ← ennreal.coe_eq_coe,
  simp, rw add_comm,
  apply prob_diff_inter p a b h₁ h₂,
end

lemma prob_union_inter
(a b : set s) (g₁ : is_measurable a) (g₂ : is_measurable b) :
p(a ∪ b) + p(a ∩ b) = p(a) + p(b) :=
begin
  have h₁ : a ∪ b = a ∪ (b ∩ -a),by
    rewrite [set.union_distrib_left, union_compl_self a,inter_univ],
  have h₂ : is_measurable(b ∩ -a),
  {
    rewrite ← diff_eq,
    apply is_measurable.diff g₂ g₁,
  },
  rewrite [h₁,prob_union a _ _ g₁ h₂],
  have h₃: a ∩ b = b ∩ a, by exact set.inter_comm a b,
  rewrite [h₃,← prob_diff_inter p a b g₁ g₂],
  simp,
  have h₄ : a ∩ (b ∩ -a) = ∅, by tidy,
  apply disjoint_iff.2 h₄,
end

lemma prob_union_inter_nnreal
(a b : set s) (g₁ : is_measurable a) (g₂ : is_measurable b) :
prob p (a ∪ b) + prob p (a ∩ b) = prob p (a) + prob p (b) :=
begin
  rw ← ennreal.coe_eq_coe,
  simp only [coe_prob, ennreal.coe_add],
  apply prob_union_inter p a b g₁ g₂,
end

/-- The Bonnferroni inequality. --/
lemma prob_add_le_inter_add_one
(a b : set s) (h_1 : is_measurable a) (h_2 : is_measurable b) :
p(a) + p(b) ≤ p(a ∩ b) + 1 :=
begin
  rewrite [← prob_union_inter p a b h_1 h_2, ← add_comm],
  apply add_le_add_left' _,
  apply prob_le_1,
end

/-- The Bonnferroni inequality for a nnreal probability measure. --/
lemma prob_add_le_inter_add_one_nnreal
(a b : set s) (h_1 : is_measurable a) (h_2 : is_measurable b) :
prob p a + prob p b ≤ prob p (a ∩ b) + 1:=
begin
  rw ← ennreal.coe_le_coe, simp only [coe_prob, ennreal.coe_add, ennreal.coe_one],
  apply prob_add_le_inter_add_one p a b h_1 h_2,
end

def are_disj_ctble' (f : ℕ → set s) := pairwise (disjoint on λ (i : ℕ), f i)

def is_partition' (f : ℕ  → set s) := (are_disj_ctble' f) ∧ ((⋃i, f i) = univ)

lemma prob_partn
{f : ℕ → set s}
{a : set s}
(h₁: is_partition' f)
(h₂ : is_measurable a)
(h₃ : ∀ i : ℕ, is_measurable (f i))
:
p(a) = ∑i, p(a ∩ f i) :=
begin
  have g₁ : p(a) = p(a ∩ univ), by rw inter_univ,
  have g₂ : p(a) = p(⋃ i , (a ∩ f i)),by rw [g₁,← h₁.right, inter_Union_left],
  rw g₂,
  apply p.m_Union,
  {
    intros j,
    apply is_measurable.inter,
    exact h₂, exact h₃ j,
  },
  intros m n h,
  refine disjoint_mono _ _ (h₁.left m n h),
  repeat{apply inter_subset_right},
end

lemma prob_partn_ne_top {f : ℕ → set s}
(h₁: is_partition' f)
(h₂ : is_measurable a)
(h₃ : ∀ i : ℕ, is_measurable (f i)):
((∑i, p (a ∩ f i)) ≠ ⊤) :=
begin
  rw ← lt_top_iff_ne_top,
  have h : ∀ i , p(a ∩ f i) ≤ p (f i), {
    intro j,
    apply prob_mono,
    by apply is_measurable.inter h₂ (h₃ j),
    by exact h₃ j, by finish,
  },
  have k₁ : has_sum (λ (i : ℕ), p (f i)), by apply ennreal.has_sum,
  have k₂ : has_sum (λ (i : ℕ), p (a ∩ f i)),
    by apply ennreal.has_sum,
  have k₃ : (∑i, p (a ∩ f i)) ≤ (∑i, p (f i)),
  {
    apply tsum_le_tsum h k₂ k₁,
  },
  have l₀ : tsum (λ (i : ℕ), p (f i)) = 1,
  {
    rw [ ← prob_univ p,← h₁.right],
    symmetry,
    apply p.m_Union h₃,
    exact h₁.left,
  },
  rw l₀ at k₃,

  apply lt_of_le_of_lt k₃, rw lt_top_iff_ne_top,
  apply one_ne_top,
end

lemma has_sum_coe' {α} {f : α → nnreal}
(h : (∑a, (f a : ennreal)) ≠ ⊤) : has_sum f :=
begin
  use (∑a, (f a : ennreal)).to_nnreal,
  apply (ennreal.is_sum_coe).mp, rw coe_to_nnreal h,
  apply is_sum_tsum,
  apply ennreal.has_sum,
end

lemma tsum_coe' {α} {f : α → nnreal} (h : (∑a, (f a : ennreal)) ≠ ⊤) : (∑a, (f a : ennreal)) = ↑(tsum f) :=
begin
  apply ennreal.tsum_coe,
  apply has_sum_coe',
  assumption,
end

lemma prob_partn_nnreal
{f : ℕ → set s}
(h₁: is_partition' f)
{a : set s}
(h₂ : is_measurable a)
(h₃ : ∀ i : ℕ, is_measurable (f i))
:
prob p a = ∑i, prob p (a ∩ f i) :=
begin
  rw [←ennreal.coe_eq_coe, ←tsum_coe'], simp,
  apply prob_partn p h₁ h₂ h₃,
  simp, rw ← prob_partn p h₁ h₂ h₃,
  apply prob_ne_top,
end

end probability_measure

section cond_prob

noncomputable def cond_prob {s : Type u} [probability_space s] (p : probability_measure s)
(a b : set s) := p(a ∩ b)/p(b)

noncomputable def cond_prob_nnreal {s : Type u} [probability_space s] (p : probability_measure s)
(a b : set s) := prob p (a ∩ b) /(prob p b)

variables [probability_space s] (p : probability_measure s)

notation `ℙ^`:95 p `[[`:95 a ` | `:95 b `]]`:0 := cond_prob p a b
notation `ℙ^^`:95 p `[[`:95 a ` | `:95 b `]]`:0 := cond_prob_nnreal p a b

lemma cond_prob_rw
(a b : set s) (h₁ : p(b) ≠ 0):
p(a ∩ b) = ℙ^p [[ a | b ]] * p(b) :=
begin
  unfold cond_prob,
  rw [div_def,mul_assoc],
  have g₁ : (1 : ennreal) < ⊤,
  {
    rw lattice.lt_top_iff_ne_top,
    apply ennreal.one_ne_top,
  },
  have g₂ : ∀ a, (p(a) ≠ 0) → (p(a))⁻¹ * p(a) = 1,
  {
    intros a k,
    rw mul_comm,
    apply ennreal.mul_inv_cancel, exact k, rw ← lattice.lt_top_iff_ne_top,
    apply lt_of_le_of_lt (prob_le_1 p a) g₁
  },
  rw g₂ b h₁, simp,
end

lemma cond_prob_rw_nnreal
(a b : set s) (h₁ : p(b) ≠ 0):
prob p (a ∩ b) = ℙ^^p [[ a | b ]] * prob p b :=
begin
  unfold cond_prob_nnreal,
  rw ← ennreal.coe_eq_coe, simp,
  rw coe_div, simp, apply cond_prob_rw _ a b h₁,
  {
    rw [ne.def, ← ennreal.coe_eq_coe, coe_prob],
    assumption,
  }
end

/- Bayes theorem for two sets -/
@[simp] theorem cond_prob_swap
{a b : set s} (h₁ : p a ≠ 0) (h₂ : p b ≠ 0) :
ℙ^p [[ b | a ]] * p(a) =  ℙ^p [[ a | b ]] * p(b) :=
begin
  unfold cond_prob,
  rw [div_def,mul_assoc],
  have g₁ : (1 : ennreal) < ⊤,
  {
    rw lattice.lt_top_iff_ne_top,
    apply ennreal.one_ne_top,
  },
  have g₂ : ∀ a, (p(a) ≠ 0) → (p(a))⁻¹ * p(a) = 1,
  {
    intros a k,
    rw mul_comm,
    apply ennreal.mul_inv_cancel, exact k, rw ← lattice.lt_top_iff_ne_top,
    apply lt_of_le_of_lt (prob_le_1 p a) g₁
  },
  rw [g₂ a,div_def,mul_assoc,g₂ b, mul_one],
  symmetry, rw [mul_one,set.inter_comm],
  assumption, assumption,
end

theorem cond_prob_swap_nnreal
{a b : set s} (h₁ : p a ≠ 0) (h₂ : p b ≠ 0) :
ℙ^^p [[ b | a ]] * prob p a =  ℙ^^p [[ a | b ]] * prob p b :=
begin
  unfold cond_prob_nnreal,
  rw ← ennreal.coe_eq_coe, simp,
  repeat{rw coe_div}, simp,
  apply cond_prob_swap p h₁ h₂,
  repeat{
    rw [ne.def, ← ennreal.coe_eq_coe, coe_prob],
    assumption,
  },
end

/-- Law of Total Probability for an ennreal probability measure--/
@[simp] lemma total_prob
{f : ℕ → set s}
(h₁: is_partition' f)
{a : set s}
(h₂ : is_measurable a)
(h₃ : ∀ i : ℕ, is_measurable (f i))
(h₄ : ∀ i : ℕ, p (f i) ≠ 0) :
p(a) = ∑j, ℙ^p[[a | f j]] * p(f j)
:=
begin
  rw prob_partn p h₁ h₂ h₃,
  have g : (λ (i : ℕ), p (a ∩ f i)) = (λ (i : ℕ),  ℙ^p [[ a | f i ]] * p(f i)),
  {
    apply funext, intros x, apply cond_prob_rw, apply h₄ x,
  },
  rw g,
end

/-- Law of Total Probability for a nnreal probability measure--/
lemma total_prob_nnreal
{f : ℕ → set s}
(h₁: is_partition' f)
{a : set s}
(h₂ : is_measurable a)
(h₃ : ∀ i : ℕ, is_measurable (f i))
(h₄ : ∀ i : ℕ, p (f i) ≠ 0) :
prob p a = ∑j, ℙ^^p[[a | f j]] * prob p (f j)
:=
begin
  rw prob_partn_nnreal p h₁ h₂ h₃,
   have g : (λ (i : ℕ),prob p (a ∩ f i)) = (λ (i : ℕ),  ℙ^^p [[ a | f i ]] * prob p(f i)),
  {
    apply funext, intros x, apply cond_prob_rw_nnreal, apply h₄ x,
  },
  rw g,
end

/-- Bayes theorem for an arbitrary partition of the sample space --/
theorem cond_prob_partn_swap
(f : ℕ → set s) (b : set s)
(h₁: is_partition' f)
(h₂ : p b ≠ 0)
(h₃ : ∀ j : ℕ, is_measurable (f j))
(h₄ : ∀ j : ℕ, p (f j) ≠ 0)
(h₅ : is_measurable b)
:  ∀ i : ℕ ,
ℙ^p[[(f i) | b]] = (ℙ^p[[b | f i]])*(p(f i))/(∑j, ℙ^p[[b | f j]] * p(f j)):=
begin
  intros i,
  rw ← total_prob p h₁ h₅ h₃ h₄,
  rw cond_prob_swap p (h₄ i) h₂,
  rw [div_def,mul_assoc],
  rw ennreal.mul_inv_cancel h₂ (prob_ne_top p b),
  simp,
end

/-- Bayes theorem for an arbitrary partition of the sample space for an nnreal probability measure --/
theorem cond_prob_partn_swap_nnreal
(f : ℕ → set s) (b : set s)
(h₁: is_partition' f)
(h₂ : p b ≠ 0)
(h₃ : ∀ j : ℕ, is_measurable (f j))
(h₄ : ∀ j : ℕ, p (f j) ≠ 0)
(h₅ : is_measurable b)
:  ∀ i : ℕ ,
ℙ^^p[[(f i) | b]] = (ℙ^^p[[b | f i]])*(prob p(f i))/(∑j, ℙ^^p[[b | f j]] * prob p (f j)):=
begin
  intros i,
  rw ← total_prob_nnreal p h₁ h₅ h₃ h₄,
  rw cond_prob_swap_nnreal p (h₄ i) h₂,
  rw [nnreal.div_def,mul_assoc],
  rw nnreal.mul_inv_cancel,
  simp, rw [ne.def, ← ennreal.coe_eq_coe, coe_prob],
  assumption,
end

end cond_prob


/-
Copyright (c) 2021 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Yury Kudryashov
-/
import topology.algebra.order.intermediate_value

/-!
# Compactness of a closed interval

In this file we prove that a closed interval in a conditionally complete linear ordered type with
order topology (or a product of such types) is compact.

We prove the extreme value theorem (`is_compact.exists_forall_le`, `is_compact.exists_forall_ge`):
a continuous function on a compact set takes its minimum and maximum values. We provide many
variations of this theorem.

We also prove that the image of a closed interval under a continuous map is a closed interval, see
`continuous_on.image_Icc`.

## Tags

compact, extreme value theorem
-/

open filter order_dual topological_space function set
open_locale filter topological_space

/-!
### Compactness of a closed interval

In this section we define a typeclass `compact_Icc_space α` saying that all closed intervals in `α`
are compact. Then we provide an instance for a `conditionally_complete_linear_order` and prove that
the product (both `α × β` and an indexed product) of spaces with this property inherits the
property.

We also prove some simple lemmas about spaces with this property.
-/

/-- This typeclass says that all closed intervals in `α` are compact. This is true for all
conditionally complete linear orders with order topology and products (finite or infinite)
of such spaces. -/
class compact_Icc_space (α : Type*) [topological_space α] [preorder α] : Prop :=
(is_compact_Icc : ∀ {a b : α}, is_compact (Icc a b))

export compact_Icc_space (is_compact_Icc)

/-- A closed interval in a conditionally complete linear order is compact. -/
@[priority 100]
instance conditionally_complete_linear_order.to_compact_Icc_space
  (α : Type*) [conditionally_complete_linear_order α] [topological_space α] [order_topology α] :
  compact_Icc_space α :=
begin
  refine ⟨λ a b, _⟩,
  cases le_or_lt a b with hab hab, swap, { simp [hab] },
  refine is_compact_iff_ultrafilter_le_nhds.2 (λ f hf, _),
  contrapose! hf,
  rw [le_principal_iff],
  have hpt : ∀ x ∈ Icc a b, {x} ∉ f,
    from λ x hx hxf, hf x hx ((le_pure_iff.2 hxf).trans (pure_le_nhds x)),
  set s := {x ∈ Icc a b | Icc a x ∉ f},
  have hsb : b ∈ upper_bounds s, from λ x hx, hx.1.2,
  have sbd : bdd_above s, from ⟨b, hsb⟩,
  have ha : a ∈ s, by simp [hpt, hab],
  rcases hab.eq_or_lt with rfl|hlt, { exact ha.2 },
  set c := Sup s,
  have hsc : is_lub s c, from is_lub_cSup ⟨a, ha⟩ sbd,
  have hc : c ∈ Icc a b, from ⟨hsc.1 ha, hsc.2 hsb⟩,
  specialize hf c hc,
  have hcs : c ∈ s,
  { cases hc.1.eq_or_lt with heq hlt, { rwa ← heq },
    refine ⟨hc, λ hcf, hf (λ U hU, _)⟩,
    rcases (mem_nhds_within_Iic_iff_exists_Ioc_subset' hlt).1 (mem_nhds_within_of_mem_nhds hU)
      with ⟨x, hxc, hxU⟩,
    rcases ((hsc.frequently_mem ⟨a, ha⟩).and_eventually
      (Ioc_mem_nhds_within_Iic ⟨hxc, le_rfl⟩)).exists
      with ⟨y, ⟨hyab, hyf⟩, hy⟩,
    refine mem_of_superset(f.diff_mem_iff.2 ⟨hcf, hyf⟩) (subset.trans _ hxU),
    rw diff_subset_iff,
    exact subset.trans Icc_subset_Icc_union_Ioc
      (union_subset_union subset.rfl $ Ioc_subset_Ioc_left hy.1.le) },
  cases hc.2.eq_or_lt with heq hlt, { rw ← heq, exact hcs.2 },
  contrapose! hf,
  intros U hU,
  rcases (mem_nhds_within_Ici_iff_exists_mem_Ioc_Ico_subset hlt).1 (mem_nhds_within_of_mem_nhds hU)
    with ⟨y, hxy, hyU⟩,
  refine mem_of_superset _ hyU, clear_dependent U,
  have hy : y ∈ Icc a b, from ⟨hc.1.trans hxy.1.le, hxy.2⟩,
  by_cases hay : Icc a y ∈ f,
  { refine mem_of_superset (f.diff_mem_iff.2 ⟨f.diff_mem_iff.2 ⟨hay, hcs.2⟩, hpt y hy⟩) _,
    rw [diff_subset_iff, union_comm, Ico_union_right hxy.1.le, diff_subset_iff],
    exact Icc_subset_Icc_union_Icc },
  { exact ((hsc.1 ⟨hy, hay⟩).not_lt hxy.1).elim },
end

instance {ι : Type*} {α : ι → Type*} [Π i, preorder (α i)] [Π i, topological_space (α i)]
  [Π i, compact_Icc_space (α i)] : compact_Icc_space (Π i, α i) :=
⟨λ a b, pi_univ_Icc a b ▸ is_compact_univ_pi $ λ i, is_compact_Icc⟩

instance pi.compact_Icc_space' {α β : Type*} [preorder β] [topological_space β]
  [compact_Icc_space β] : compact_Icc_space (α → β) :=
pi.compact_Icc_space

instance {α β : Type*} [preorder α] [topological_space α] [compact_Icc_space α]
  [preorder β] [topological_space β] [compact_Icc_space β] :
  compact_Icc_space (α × β) :=
⟨λ a b, (Icc_prod_eq a b).symm ▸ is_compact_Icc.prod is_compact_Icc⟩

/-- An unordered closed interval is compact. -/
lemma is_compact_interval {α : Type*} [linear_order α] [topological_space α] [compact_Icc_space α]
  {a b : α} : is_compact (interval a b) :=
is_compact_Icc

/-- A complete linear order is a compact space.

We do not register an instance for a `[compact_Icc_space α]` because this would only add instances
for products (indexed or not) of complete linear orders, and we have instances with higher priority
that cover these cases. -/
@[priority 100] -- See note [lower instance priority]
instance compact_space_of_complete_linear_order {α : Type*} [complete_linear_order α]
  [topological_space α] [order_topology α] :
  compact_space α :=
⟨by simp only [← Icc_bot_top, is_compact_Icc]⟩

section

variables {α : Type*} [preorder α] [topological_space α] [compact_Icc_space α]

instance compact_space_Icc (a b : α) : compact_space (Icc a b) :=
is_compact_iff_compact_space.mp is_compact_Icc

end

/-!
### Min and max elements of a compact set
-/

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

lemma is_compact.Inf_mem {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  Inf s ∈ s :=
hs.is_closed.cInf_mem ne_s hs.bdd_below

lemma is_compact.Sup_mem {s : set α} (hs : is_compact s) (ne_s : s.nonempty) : Sup s ∈ s :=
@is_compact.Inf_mem αᵒᵈ _ _ _ _ hs ne_s

lemma is_compact.is_glb_Inf {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  is_glb s (Inf s) :=
is_glb_cInf ne_s hs.bdd_below

lemma is_compact.is_lub_Sup {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  is_lub s (Sup s) :=
@is_compact.is_glb_Inf αᵒᵈ _ _ _ _ hs ne_s

lemma is_compact.is_least_Inf {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  is_least s (Inf s) :=
⟨hs.Inf_mem ne_s, (hs.is_glb_Inf ne_s).1⟩

lemma is_compact.is_greatest_Sup {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  is_greatest s (Sup s) :=
@is_compact.is_least_Inf αᵒᵈ _ _ _ _ hs ne_s

lemma is_compact.exists_is_least {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  ∃ x, is_least s x :=
⟨_, hs.is_least_Inf ne_s⟩

lemma is_compact.exists_is_greatest {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  ∃ x, is_greatest s x :=
⟨_, hs.is_greatest_Sup ne_s⟩

lemma is_compact.exists_is_glb {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  ∃ x ∈ s, is_glb s x :=
⟨_, hs.Inf_mem ne_s, hs.is_glb_Inf ne_s⟩

lemma is_compact.exists_is_lub {s : set α} (hs : is_compact s) (ne_s : s.nonempty) :
  ∃ x ∈ s, is_lub s x :=
⟨_, hs.Sup_mem ne_s, hs.is_lub_Sup ne_s⟩

lemma is_compact.exists_Inf_image_eq_and_le {s : set β} (hs : is_compact s) (ne_s : s.nonempty)
  {f : β → α} (hf : continuous_on f s) :
  ∃ x ∈ s, Inf (f '' s) = f x ∧ ∀ y ∈ s, f x ≤ f y :=
let ⟨x, hxs, hx⟩ := (hs.image_of_continuous_on hf).Inf_mem (ne_s.image f)
in ⟨x, hxs, hx.symm, λ y hy,
  hx.trans_le $ cInf_le (hs.image_of_continuous_on hf).bdd_below $ mem_image_of_mem f hy⟩

lemma is_compact.exists_Sup_image_eq_and_ge {s : set β} (hs : is_compact s) (ne_s : s.nonempty)
  {f : β → α} (hf : continuous_on f s) :
  ∃ x ∈ s, Sup (f '' s) = f x ∧ ∀ y ∈ s, f y ≤ f x :=
@is_compact.exists_Inf_image_eq_and_le αᵒᵈ _ _ _ _ _ _ hs ne_s _ hf

lemma is_compact.exists_Inf_image_eq {s : set β} (hs : is_compact s) (ne_s : s.nonempty)
  {f : β → α} (hf : continuous_on f s) :
  ∃ x ∈ s,  Inf (f '' s) = f x :=
let ⟨x, hxs, hx, _⟩ := hs.exists_Inf_image_eq_and_le ne_s hf in ⟨x, hxs, hx⟩

lemma is_compact.exists_Sup_image_eq :
  ∀ {s : set β}, is_compact s → s.nonempty → ∀ {f : β → α}, continuous_on f s →
  ∃ x ∈ s, Sup (f '' s) = f x :=
@is_compact.exists_Inf_image_eq αᵒᵈ _ _ _ _ _

lemma eq_Icc_of_connected_compact {s : set α} (h₁ : is_connected s) (h₂ : is_compact s) :
  s = Icc (Inf s) (Sup s) :=
eq_Icc_cInf_cSup_of_connected_bdd_closed h₁ h₂.bdd_below h₂.bdd_above h₂.is_closed

/-!
### Extreme value theorem
-/

/-- The **extreme value theorem**: a continuous function realizes its minimum on a compact set. -/
lemma is_compact.exists_forall_le {s : set β} (hs : is_compact s) (ne_s : s.nonempty)
  {f : β → α} (hf : continuous_on f s) :
  ∃x∈s, ∀y∈s, f x ≤ f y :=
begin
  rcases (hs.image_of_continuous_on hf).exists_is_least (ne_s.image f)
    with ⟨_, ⟨x, hxs, rfl⟩, hx⟩,
  exact ⟨x, hxs, ball_image_iff.1 hx⟩
end

/-- The **extreme value theorem**: a continuous function realizes its maximum on a compact set. -/
lemma is_compact.exists_forall_ge :
  ∀ {s : set β}, is_compact s → s.nonempty → ∀ {f : β → α}, continuous_on f s →
  ∃x∈s, ∀y∈s, f y ≤ f x :=
@is_compact.exists_forall_le αᵒᵈ _ _ _ _ _

/-- The **extreme value theorem**: if a function `f` is continuous on a closed set `s` and it is
larger than a value in its image away from compact sets, then it has a minimum on this set. -/
lemma continuous_on.exists_forall_le' {s : set β} {f : β → α} (hf : continuous_on f s)
  (hsc : is_closed s) {x₀ : β} (h₀ : x₀ ∈ s) (hc : ∀ᶠ x in cocompact β ⊓ 𝓟 s, f x₀ ≤ f x) :
  ∃ x ∈ s, ∀ y ∈ s, f x ≤ f y :=
begin
  rcases (has_basis_cocompact.inf_principal _).eventually_iff.1 hc with ⟨K, hK, hKf⟩,
  have hsub : insert x₀ (K ∩ s) ⊆ s, from insert_subset.2 ⟨h₀, inter_subset_right _ _⟩,
  obtain ⟨x, hx, hxf⟩ : ∃ x ∈ insert x₀ (K ∩ s), ∀ y ∈ insert x₀ (K ∩ s), f x ≤ f y :=
    ((hK.inter_right hsc).insert x₀).exists_forall_le (nonempty_insert _ _) (hf.mono hsub),
  refine ⟨x, hsub hx, λ y hy, _⟩,
  by_cases hyK : y ∈ K,
  exacts [hxf _ (or.inr ⟨hyK, hy⟩), (hxf _ (or.inl rfl)).trans (hKf ⟨hyK, hy⟩)]
end

/-- The **extreme value theorem**: if a function `f` is continuous on a closed set `s` and it is
smaller than a value in its image away from compact sets, then it has a maximum on this set. -/
lemma continuous_on.exists_forall_ge' {s : set β} {f : β → α} (hf : continuous_on f s)
  (hsc : is_closed s) {x₀ : β} (h₀ : x₀ ∈ s) (hc : ∀ᶠ x in cocompact β ⊓ 𝓟 s, f x ≤ f x₀) :
  ∃ x ∈ s, ∀ y ∈ s, f y ≤ f x :=
@continuous_on.exists_forall_le' αᵒᵈ _ _ _ _ _ _ _ hf hsc _ h₀ hc

/-- The **extreme value theorem**: if a continuous function `f` is larger than a value in its range
away from compact sets, then it has a global minimum. -/
lemma _root_.continuous.exists_forall_le' {f : β → α} (hf : continuous f) (x₀ : β)
  (h : ∀ᶠ x in cocompact β, f x₀ ≤ f x) : ∃ (x : β), ∀ (y : β), f x ≤ f y :=
let ⟨x, _, hx⟩ := hf.continuous_on.exists_forall_le' is_closed_univ (mem_univ x₀)
  (by rwa [principal_univ, inf_top_eq])
in ⟨x, λ y, hx y (mem_univ y)⟩

/-- The **extreme value theorem**: if a continuous function `f` is smaller than a value in its range
away from compact sets, then it has a global maximum. -/
lemma _root_.continuous.exists_forall_ge' {f : β → α} (hf : continuous f) (x₀ : β)
  (h : ∀ᶠ x in cocompact β, f x ≤ f x₀) : ∃ (x : β), ∀ (y : β), f y ≤ f x :=
@continuous.exists_forall_le' αᵒᵈ _ _ _ _ _ _ hf x₀ h

/-- The **extreme value theorem**: if a continuous function `f` tends to infinity away from compact
sets, then it has a global minimum. -/
lemma _root_.continuous.exists_forall_le [nonempty β] {f : β → α}
  (hf : continuous f) (hlim : tendsto f (cocompact β) at_top) :
  ∃ x, ∀ y, f x ≤ f y :=
by { inhabit β, exact hf.exists_forall_le' default (hlim.eventually $ eventually_ge_at_top _) }

/-- The **extreme value theorem**: if a continuous function `f` tends to negative infinity away from
compact sets, then it has a global maximum. -/
lemma continuous.exists_forall_ge [nonempty β] {f : β → α}
  (hf : continuous f) (hlim : tendsto f (cocompact β) at_bot) :
  ∃ x, ∀ y, f y ≤ f x :=
@continuous.exists_forall_le αᵒᵈ _ _ _ _ _ _ _ hf hlim

lemma is_compact.Sup_lt_iff_of_continuous {f : β → α}
  {K : set β} (hK : is_compact K) (h0K : K.nonempty) (hf : continuous_on f K) (y : α) :
  Sup (f '' K) < y ↔ ∀ x ∈ K, f x < y :=
begin
  refine ⟨λ h x hx, (le_cSup (hK.bdd_above_image hf) $ mem_image_of_mem f hx).trans_lt h, λ h, _⟩,
  obtain ⟨x, hx, h2x⟩ := hK.exists_forall_ge h0K hf,
  refine (cSup_le (h0K.image f) _).trans_lt (h x hx),
  rintro _ ⟨x', hx', rfl⟩, exact h2x x' hx'
end

lemma is_compact.lt_Inf_iff_of_continuous {α β : Type*}
  [conditionally_complete_linear_order α] [topological_space α]
  [order_topology α] [topological_space β] {f : β → α}
  {K : set β} (hK : is_compact K) (h0K : K.nonempty) (hf : continuous_on f K) (y : α) :
  y < Inf (f '' K) ↔ ∀ x ∈ K, y < f x :=
@is_compact.Sup_lt_iff_of_continuous αᵒᵈ β _ _ _ _ _ _ hK h0K hf y

/-- A continuous function with compact support has a global minimum. -/
@[to_additive]
lemma _root_.continuous.exists_forall_le_of_has_compact_mul_support [nonempty β] [has_one α]
  {f : β → α} (hf : continuous f) (h : has_compact_mul_support f) :
  ∃ (x : β), ∀ (y : β), f x ≤ f y :=
begin
  obtain ⟨_, ⟨x, rfl⟩, hx⟩ := (h.is_compact_range hf).exists_is_least (range_nonempty _),
  rw [mem_lower_bounds, forall_range_iff] at hx,
  exact ⟨x, hx⟩,
end

/-- A continuous function with compact support has a global maximum. -/
@[to_additive]
lemma continuous.exists_forall_ge_of_has_compact_mul_support [nonempty β] [has_one α]
  {f : β → α} (hf : continuous f) (h : has_compact_mul_support f) :
  ∃ (x : β), ∀ (y : β), f y ≤ f x :=
@continuous.exists_forall_le_of_has_compact_mul_support αᵒᵈ _ _ _ _ _ _ _ _ hf h

lemma is_compact.continuous_Sup {f : γ → β → α}
  {K : set β} (hK : is_compact K) (hf : continuous ↿f) :
    continuous (λ x, Sup (f x '' K)) :=
begin
  rcases eq_empty_or_nonempty K with rfl|h0K,
  { simp_rw [image_empty], exact continuous_const },
  rw [continuous_iff_continuous_at],
  intro x,
  obtain ⟨y, hyK, h2y, hy⟩ :=
    hK.exists_Sup_image_eq_and_ge h0K
      (show continuous (λ y, f x y), from hf.comp $ continuous.prod.mk x).continuous_on,
  rw [continuous_at, h2y, tendsto_order],
  have := tendsto_order.mp ((show continuous (λ x, f x y), from
    hf.comp $ continuous_id.prod_mk continuous_const).tendsto x),
  refine ⟨λ z hz, _, λ z hz, _⟩,
  { refine (this.1 z hz).mono (λ x' hx', hx'.trans_le $ le_cSup _ $ mem_image_of_mem (f x') hyK),
    exact hK.bdd_above_image (hf.comp $ continuous.prod.mk x').continuous_on },
  { have h : ({x} : set γ) ×ˢ K ⊆ ↿f ⁻¹' (Iio z),
    { rintro ⟨x', y'⟩ ⟨hx', hy'⟩, cases hx', exact (hy y' hy').trans_lt hz },
    obtain ⟨u, v, hu, hv, hxu, hKv, huv⟩ :=
      generalized_tube_lemma is_compact_singleton hK (is_open_Iio.preimage hf) h,
    refine eventually_of_mem (hu.mem_nhds (singleton_subset_iff.mp hxu)) (λ x' hx', _),
    rw [hK.Sup_lt_iff_of_continuous h0K
      (show continuous (f x'), from (hf.comp $ continuous.prod.mk x')).continuous_on],
    exact λ y' hy', huv (mk_mem_prod hx' (hKv hy')) }
end

lemma is_compact.continuous_Inf {f : γ → β → α}
  {K : set β} (hK : is_compact K) (hf : continuous ↿f) :
    continuous (λ x, Inf (f x '' K)) :=
@is_compact.continuous_Sup αᵒᵈ β γ _ _ _ _ _ _ _ hK hf

namespace continuous_on
/-!
### Image of a closed interval
-/

variables [densely_ordered α] [conditionally_complete_linear_order β] [order_topology β]
  {f : α → β} {a b c : α}

open_locale interval

lemma image_Icc (hab : a ≤ b) (h : continuous_on f $ Icc a b) :
  f '' Icc a b = Icc (Inf $ f '' Icc a b) (Sup $ f '' Icc a b) :=
eq_Icc_of_connected_compact ⟨(nonempty_Icc.2 hab).image f, is_preconnected_Icc.image f h⟩
  (is_compact_Icc.image_of_continuous_on h)

lemma image_interval_eq_Icc (h : continuous_on f $ [a, b]) :
  f '' [a, b] = Icc (Inf (f '' [a, b])) (Sup (f '' [a, b])) :=
begin
  cases le_total a b with h2 h2,
  { simp_rw [interval_of_le h2] at h ⊢, exact h.image_Icc h2 },
  { simp_rw [interval_of_ge h2] at h ⊢, exact h.image_Icc h2 },
end

lemma image_interval (h : continuous_on f $ [a, b]) :
  f '' [a, b] = [Inf (f '' [a, b]), Sup (f '' [a, b])] :=
begin
  refine h.image_interval_eq_Icc.trans (interval_of_le _).symm,
  refine cInf_le_cSup _ _ (nonempty_interval.image _); rw h.image_interval_eq_Icc,
  exacts [bdd_below_Icc, bdd_above_Icc]
end

lemma Inf_image_Icc_le (h : continuous_on f $ Icc a b) (hc : c ∈ Icc a b) :
  Inf (f '' (Icc a b)) ≤ f c :=
begin
  rw h.image_Icc (nonempty_Icc.mp (set.nonempty_of_mem hc)),
  exact cInf_le bdd_below_Icc (mem_Icc.mpr ⟨cInf_le (is_compact_Icc.bdd_below_image h) ⟨c, hc, rfl⟩,
     le_cSup (is_compact_Icc.bdd_above_image h) ⟨c, hc, rfl⟩⟩),
end

lemma le_Sup_image_Icc (h : continuous_on f $ Icc a b) (hc : c ∈ Icc a b) :
  f c ≤ Sup (f '' (Icc a b)) :=
begin
  rw h.image_Icc (nonempty_Icc.mp (set.nonempty_of_mem hc)),
  exact le_cSup bdd_above_Icc (mem_Icc.mpr ⟨cInf_le (is_compact_Icc.bdd_below_image h) ⟨c, hc, rfl⟩,
     le_cSup (is_compact_Icc.bdd_above_image h) ⟨c, hc, rfl⟩⟩),
end

end continuous_on


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

! This file was ported from Lean 3 source module algebra.star.subalgebra
! leanprover-community/mathlib commit 160ef3e338a2a4f21a280e4c152d4016156e516d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Star.StarAlgHom
import Mathlib.Algebra.Algebra.Subalgebra.Basic
import Mathlib.Algebra.Star.Pointwise
import Mathlib.Algebra.Star.Module
import Mathlib.RingTheory.Adjoin.Basic

/-!
# Star subalgebras

A *-subalgebra is a subalgebra of a *-algebra which is closed under *.

The centralizer of a *-closed set is a *-subalgebra.
-/

universe u v

/-- A *-subalgebra is a subalgebra of a *-algebra which is closed under *. -/
structure StarSubalgebra (R : Type u) (A : Type v) [CommSemiring R] [StarRing R] [Semiring A]
  [StarRing A] [Algebra R A] [StarModule R A] extends Subalgebra R A : Type v where
  /-- The `carrier` is closed under the `star` operation. -/
  star_mem' {a} : a ∈ carrier → star a ∈ carrier
#align star_subalgebra StarSubalgebra

namespace StarSubalgebra

/-- Forgetting that a *-subalgebra is closed under *.
-/
add_decl_doc StarSubalgebra.toSubalgebra

variable {F R A B C : Type _} [CommSemiring R] [StarRing R]

variable [Semiring A] [StarRing A] [Algebra R A] [StarModule R A]

variable [Semiring B] [StarRing B] [Algebra R B] [StarModule R B]

variable [Semiring C] [StarRing C] [Algebra R C] [StarModule R C]

instance setLike : SetLike (StarSubalgebra R A) A where
  coe S := S.carrier
  coe_injective' p q h := by obtain ⟨⟨⟨⟨⟨_, _⟩, _⟩, _⟩, _⟩, _⟩ := p; cases q; congr

instance starMemClass : StarMemClass (StarSubalgebra R A) A where
  star_mem {s} := s.star_mem'

instance subsemiringClass : SubsemiringClass (StarSubalgebra R A) A where
  add_mem {s} := s.add_mem'
  mul_mem {s} := s.mul_mem'
  one_mem {s} := s.one_mem'
  zero_mem {s} := s.zero_mem'

-- porting note: work around lean4#2074
-- the following instance works with `set_option synthInstance.etaExperiment true`
attribute [-instance] Ring.toNonAssocRing Ring.toNonUnitalRing CommRing.toNonUnitalCommRing

instance subringClass {R A} [CommRing R] [StarRing R] [Ring A] [StarRing A] [Algebra R A]
    [StarModule R A] : SubringClass (StarSubalgebra R A) A where
  neg_mem {s a} ha := show -a ∈ s.toSubalgebra from neg_mem ha

-- this uses the `Star` instance `s` inherits from `StarMemClass (StarSubalgebra R A) A`
instance starRing (s : StarSubalgebra R A) : StarRing s :=
  { StarMemClass.star s with
    star_involutive := fun r => Subtype.ext (star_star (r : A))
    star_mul := fun r₁ r₂ => Subtype.ext (star_mul (r₁ : A) (r₂ : A))
    star_add := fun r₁ r₂ => Subtype.ext (star_add (r₁ : A) (r₂ : A)) }

instance algebra (s : StarSubalgebra R A) : Algebra R s :=
  s.toSubalgebra.algebra'

instance starModule (s : StarSubalgebra R A) : StarModule R s where
  star_smul r a := Subtype.ext (star_smul r (a : A))

@[simp, nolint simpNF] -- porting note: `simpNF` says `simp` can prove this, but it can't
theorem mem_carrier {s : StarSubalgebra R A} {x : A} : x ∈ s.carrier ↔ x ∈ s :=
  Iff.rfl
#align star_subalgebra.mem_carrier StarSubalgebra.mem_carrier

@[ext]
theorem ext {S T : StarSubalgebra R A} (h : ∀ x : A, x ∈ S ↔ x ∈ T) : S = T :=
  SetLike.ext h
#align star_subalgebra.ext StarSubalgebra.ext

@[simp]
theorem mem_toSubalgebra {S : StarSubalgebra R A} {x} : x ∈ S.toSubalgebra ↔ x ∈ S :=
  Iff.rfl
#align star_subalgebra.mem_to_subalgebra StarSubalgebra.mem_toSubalgebra

@[simp]
theorem coe_toSubalgebra (S : StarSubalgebra R A) : (S.toSubalgebra : Set A) = S :=
  rfl
#align star_subalgebra.coe_to_subalgebra StarSubalgebra.coe_toSubalgebra

theorem toSubalgebra_injective :
    Function.Injective (toSubalgebra : StarSubalgebra R A → Subalgebra R A) := fun S T h =>
  ext fun x => by rw [← mem_toSubalgebra, ← mem_toSubalgebra, h]
#align star_subalgebra.to_subalgebra_injective StarSubalgebra.toSubalgebra_injective

theorem toSubalgebra_inj {S U : StarSubalgebra R A} : S.toSubalgebra = U.toSubalgebra ↔ S = U :=
  toSubalgebra_injective.eq_iff
#align star_subalgebra.to_subalgebra_inj StarSubalgebra.toSubalgebra_inj

theorem toSubalgebra_le_iff {S₁ S₂ : StarSubalgebra R A} :
    S₁.toSubalgebra ≤ S₂.toSubalgebra ↔ S₁ ≤ S₂ :=
  Iff.rfl
#align star_subalgebra.to_subalgebra_le_iff StarSubalgebra.toSubalgebra_le_iff

/-- Copy of a star subalgebra with a new `carrier` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (S : StarSubalgebra R A) (s : Set A) (hs : s = ↑S) : StarSubalgebra R A where
  toSubalgebra := Subalgebra.copy S.toSubalgebra s hs
  star_mem' := @fun a ha => hs ▸ (S.star_mem' (by simpa [hs] using ha) : star a ∈ (S : Set A))
  -- porting note: the old proof kept crashing Lean
#align star_subalgebra.copy StarSubalgebra.copy

@[simp]
theorem coe_copy (S : StarSubalgebra R A) (s : Set A) (hs : s = ↑S) : (S.copy s hs : Set A) = s :=
  rfl
#align star_subalgebra.coe_copy StarSubalgebra.coe_copy

theorem copy_eq (S : StarSubalgebra R A) (s : Set A) (hs : s = ↑S) : S.copy s hs = S :=
  SetLike.coe_injective hs
#align star_subalgebra.copy_eq StarSubalgebra.copy_eq

variable (S : StarSubalgebra R A)

theorem algebraMap_mem (r : R) : algebraMap R A r ∈ S :=
  S.algebraMap_mem' r
#align star_subalgebra.algebra_map_mem StarSubalgebra.algebraMap_mem

theorem rangeS_le : (algebraMap R A).rangeS ≤ S.toSubalgebra.toSubsemiring := fun _x ⟨r, hr⟩ =>
  hr ▸ S.algebraMap_mem r
#align star_subalgebra.srange_le StarSubalgebra.rangeS_le

theorem range_subset : Set.range (algebraMap R A) ⊆ S := fun _x ⟨r, hr⟩ => hr ▸ S.algebraMap_mem r
#align star_subalgebra.range_subset StarSubalgebra.range_subset

theorem range_le : Set.range (algebraMap R A) ≤ S :=
  S.range_subset
#align star_subalgebra.range_le StarSubalgebra.range_le

protected theorem smul_mem {x : A} (hx : x ∈ S) (r : R) : r • x ∈ S :=
  (Algebra.smul_def r x).symm ▸ mul_mem (S.algebraMap_mem r) hx
#align star_subalgebra.smul_mem StarSubalgebra.smul_mem

/-- Embedding of a subalgebra into the algebra. -/
def subtype : S →⋆ₐ[R] A := by refine' { toFun := ((↑) : S → A), .. } <;> intros <;> rfl
#align star_subalgebra.subtype StarSubalgebra.subtype

@[simp]
theorem coe_subtype : (S.subtype : S → A) = Subtype.val :=
  rfl
#align star_subalgebra.coe_subtype StarSubalgebra.coe_subtype

theorem subtype_apply (x : S) : S.subtype x = (x : A) :=
  rfl
#align star_subalgebra.subtype_apply StarSubalgebra.subtype_apply

@[simp]
theorem toSubalgebra_subtype : S.toSubalgebra.val = S.subtype.toAlgHom :=
  rfl
#align star_subalgebra.to_subalgebra_subtype StarSubalgebra.toSubalgebra_subtype

/-- The inclusion map between `StarSubalgebra`s given by `Subtype.map id` as a `StarAlgHom`. -/
@[simps]
def inclusion {S₁ S₂ : StarSubalgebra R A} (h : S₁ ≤ S₂) : S₁ →⋆ₐ[R] S₂ where
  toFun := Subtype.map id h
  map_one' := rfl
  map_mul' _ _ := rfl
  map_zero' := rfl
  map_add' _ _ := rfl
  commutes' _ := rfl
  map_star' _ := rfl
#align star_subalgebra.inclusion StarSubalgebra.inclusion

theorem inclusion_injective {S₁ S₂ : StarSubalgebra R A} (h : S₁ ≤ S₂) :
    Function.Injective <| inclusion h :=
  Set.inclusion_injective h
#align star_subalgebra.inclusion_injective StarSubalgebra.inclusion_injective

@[simp]
theorem subtype_comp_inclusion {S₁ S₂ : StarSubalgebra R A} (h : S₁ ≤ S₂) :
    S₂.subtype.comp (inclusion h) = S₁.subtype :=
  rfl
#align star_subalgebra.subtype_comp_inclusion StarSubalgebra.subtype_comp_inclusion

section Map

/-- Transport a star subalgebra via a star algebra homomorphism. -/
def map (f : A →⋆ₐ[R] B) (S : StarSubalgebra R A) : StarSubalgebra R B :=
  { S.toSubalgebra.map f.toAlgHom with
    star_mem' := by
      rintro _ ⟨a, ha, rfl⟩
      exact map_star f a ▸ Set.mem_image_of_mem _ (S.star_mem' ha) }
#align star_subalgebra.map StarSubalgebra.map

theorem map_mono {S₁ S₂ : StarSubalgebra R A} {f : A →⋆ₐ[R] B} : S₁ ≤ S₂ → S₁.map f ≤ S₂.map f :=
  Set.image_subset f
#align star_subalgebra.map_mono StarSubalgebra.map_mono

theorem map_injective {f : A →⋆ₐ[R] B} (hf : Function.Injective f) : Function.Injective (map f) :=
  fun _S₁ _S₂ ih =>
  ext <| Set.ext_iff.1 <| Set.image_injective.2 hf <| Set.ext <| SetLike.ext_iff.mp ih
#align star_subalgebra.map_injective StarSubalgebra.map_injective

@[simp]
theorem map_id (S : StarSubalgebra R A) : S.map (StarAlgHom.id R A) = S :=
  SetLike.coe_injective <| Set.image_id _
#align star_subalgebra.map_id StarSubalgebra.map_id

theorem map_map (S : StarSubalgebra R A) (g : B →⋆ₐ[R] C) (f : A →⋆ₐ[R] B) :
    (S.map f).map g = S.map (g.comp f) :=
  SetLike.coe_injective <| Set.image_image _ _ _
#align star_subalgebra.map_map StarSubalgebra.map_map

theorem mem_map {S : StarSubalgebra R A} {f : A →⋆ₐ[R] B} {y : B} :
    y ∈ map f S ↔ ∃ x ∈ S, f x = y :=
  Subsemiring.mem_map
#align star_subalgebra.mem_map StarSubalgebra.mem_map

theorem map_toSubalgebra {S : StarSubalgebra R A} {f : A →⋆ₐ[R] B} :
    (S.map f).toSubalgebra = S.toSubalgebra.map f.toAlgHom :=
  SetLike.coe_injective rfl
#align star_subalgebra.map_to_subalgebra StarSubalgebra.map_toSubalgebra

@[simp]
theorem coe_map (S : StarSubalgebra R A) (f : A →⋆ₐ[R] B) : (S.map f : Set B) = f '' S :=
  rfl
#align star_subalgebra.coe_map StarSubalgebra.coe_map

/-- Preimage of a star subalgebra under an star algebra homomorphism. -/
def comap (f : A →⋆ₐ[R] B) (S : StarSubalgebra R B) : StarSubalgebra R A :=
  { S.toSubalgebra.comap f.toAlgHom with
    star_mem' := @fun a ha => show f (star a) ∈ S from (map_star f a).symm ▸ star_mem ha }
#align star_subalgebra.comap StarSubalgebra.comap

theorem map_le_iff_le_comap {S : StarSubalgebra R A} {f : A →⋆ₐ[R] B} {U : StarSubalgebra R B} :
    map f S ≤ U ↔ S ≤ comap f U :=
  Set.image_subset_iff
#align star_subalgebra.map_le_iff_le_comap StarSubalgebra.map_le_iff_le_comap

theorem gc_map_comap (f : A →⋆ₐ[R] B) : GaloisConnection (map f) (comap f) := fun _S _U =>
  map_le_iff_le_comap
#align star_subalgebra.gc_map_comap StarSubalgebra.gc_map_comap

theorem comap_mono {S₁ S₂ : StarSubalgebra R B} {f : A →⋆ₐ[R] B} :
    S₁ ≤ S₂ → S₁.comap f ≤ S₂.comap f :=
  Set.preimage_mono
#align star_subalgebra.comap_mono StarSubalgebra.comap_mono

theorem comap_injective {f : A →⋆ₐ[R] B} (hf : Function.Surjective f) :
    Function.Injective (comap f) := fun _S₁ _S₂ h =>
  ext fun b =>
    let ⟨x, hx⟩ := hf b
    let this := SetLike.ext_iff.1 h x
    hx ▸ this
#align star_subalgebra.comap_injective StarSubalgebra.comap_injective

@[simp]
theorem comap_id (S : StarSubalgebra R A) : S.comap (StarAlgHom.id R A) = S :=
  SetLike.coe_injective <| Set.preimage_id
#align star_subalgebra.comap_id StarSubalgebra.comap_id

theorem comap_comap (S : StarSubalgebra R C) (g : B →⋆ₐ[R] C) (f : A →⋆ₐ[R] B) :
    (S.comap g).comap f = S.comap (g.comp f) :=
  SetLike.coe_injective <| by exact Set.preimage_preimage
  -- porting note: the `by exact` trick still works sometimes
#align star_subalgebra.comap_comap StarSubalgebra.comap_comap

@[simp]
theorem mem_comap (S : StarSubalgebra R B) (f : A →⋆ₐ[R] B) (x : A) : x ∈ S.comap f ↔ f x ∈ S :=
  Iff.rfl
#align star_subalgebra.mem_comap StarSubalgebra.mem_comap

@[simp, norm_cast]
theorem coe_comap (S : StarSubalgebra R B) (f : A →⋆ₐ[R] B) :
    (S.comap f : Set A) = f ⁻¹' (S : Set B) :=
  rfl
#align star_subalgebra.coe_comap StarSubalgebra.coe_comap

end Map

section Centralizer

variable (R) -- porting note: redundant binder annotation update

theorem _root_.Set.star_mem_centralizer {a : A} {s : Set A} (h : ∀ a : A, a ∈ s → star a ∈ s)
    (ha : a ∈ Set.centralizer s) : star a ∈ Set.centralizer s := fun y hy => by
  simpa using congr_arg star (ha _ (h _ hy)).symm
#align set.star_mem_centralizer Set.star_mem_centralizer

/-- The centralizer, or commutant, of a *-closed set as star subalgebra. -/
def centralizer (s : Set A) (w : ∀ a : A, a ∈ s → star a ∈ s) : StarSubalgebra R A :=
  { Subalgebra.centralizer R s with
    star_mem' := Set.star_mem_centralizer w }
#align star_subalgebra.centralizer StarSubalgebra.centralizer

@[simp]
theorem coe_centralizer (s : Set A) (w : ∀ a : A, a ∈ s → star a ∈ s) :
    (centralizer R s w : Set A) = s.centralizer :=
  rfl
#align star_subalgebra.coe_centralizer StarSubalgebra.coe_centralizer

theorem mem_centralizer_iff {s : Set A} {w} {z : A} :
    z ∈ centralizer R s w ↔ ∀ g ∈ s, g * z = z * g :=
  Iff.rfl
#align star_subalgebra.mem_centralizer_iff StarSubalgebra.mem_centralizer_iff

theorem centralizer_le (s t : Set A) (ws : ∀ a : A, a ∈ s → star a ∈ s)
    (wt : ∀ a : A, a ∈ t → star a ∈ t) (h : s ⊆ t) : centralizer R t wt ≤ centralizer R s ws :=
  Set.centralizer_subset h
#align star_subalgebra.centralizer_le StarSubalgebra.centralizer_le

end Centralizer

end StarSubalgebra

/-! ### The star closure of a subalgebra -/

namespace Subalgebra

open Pointwise

variable {F R A B : Type _} [CommSemiring R] [StarRing R]

variable [Semiring A] [Algebra R A] [StarRing A] [StarModule R A]

variable [Semiring B] [Algebra R B] [StarRing B] [StarModule R B]

/-- The pointwise `star` of a subalgebra is a subalgebra. -/
instance involutiveStar : InvolutiveStar (Subalgebra R A) where
  star S :=
    { carrier := star S.carrier
      mul_mem' := fun {x y} hx hy => by
        simp only [Set.mem_star, Subalgebra.mem_carrier] at *
        exact (star_mul x y).symm ▸ mul_mem hy hx
      one_mem' := Set.mem_star.mp ((star_one A).symm ▸ one_mem S : star (1 : A) ∈ S)
      add_mem' := fun {x y} hx hy => by
        simp only [Set.mem_star, Subalgebra.mem_carrier] at *
        exact (star_add x y).symm ▸ add_mem hx hy
      zero_mem' := Set.mem_star.mp ((star_zero A).symm ▸ zero_mem S : star (0 : A) ∈ S)
      algebraMap_mem' := fun r => by
        simpa only [Set.mem_star, Subalgebra.mem_carrier, ← algebraMap_star_comm] using
          S.algebraMap_mem (star r) }
  star_involutive S :=
    Subalgebra.ext fun x =>
      ⟨fun hx => star_star x ▸ hx, fun hx => ((star_star x).symm ▸ hx : star (star x) ∈ S)⟩

@[simp]
theorem mem_star_iff (S : Subalgebra R A) (x : A) : x ∈ star S ↔ star x ∈ S :=
  Iff.rfl
#align subalgebra.mem_star_iff Subalgebra.mem_star_iff

-- porting note: removed `@[simp]` tag because `simp` can prove this
theorem star_mem_star_iff (S : Subalgebra R A) (x : A) : star x ∈ star S ↔ x ∈ S := by
  simp only [mem_star_iff, star_star]
#align subalgebra.star_mem_star_iff Subalgebra.star_mem_star_iff

@[simp]
theorem coe_star (S : Subalgebra R A) : ((star S : Subalgebra R A) : Set A) = star (S : Set A) :=
  rfl
#align subalgebra.coe_star Subalgebra.coe_star

theorem star_mono : Monotone (star : Subalgebra R A → Subalgebra R A) := fun _ _ h _ hx => h hx
#align subalgebra.star_mono Subalgebra.star_mono

variable (R)

/-- The star operation on `Subalgebra` commutes with `Algebra.adjoin`. -/
theorem star_adjoin_comm (s : Set A) : star (Algebra.adjoin R s) = Algebra.adjoin R (star s) :=
  have this : ∀ t : Set A, Algebra.adjoin R (star t) ≤ star (Algebra.adjoin R t) := fun t =>
    Algebra.adjoin_le fun x hx => Algebra.subset_adjoin hx
  le_antisymm (by simpa only [star_star] using Subalgebra.star_mono (this (star s))) (this s)
#align subalgebra.star_adjoin_comm Subalgebra.star_adjoin_comm

variable {R}

/-- The `StarSubalgebra` obtained from `S : Subalgebra R A` by taking the smallest subalgebra
containing both `S` and `star S`. -/
@[simps!]
def starClosure (S : Subalgebra R A) : StarSubalgebra R A :=
  { S ⊔ star S with
    star_mem' := fun {a} ha =>
      by
      simp only [Subalgebra.mem_carrier, ← (@Algebra.gi R A _ _ _).l_sup_u _ _] at *
      rw [← mem_star_iff _ a, star_adjoin_comm, sup_comm]
      simpa using ha }
#align subalgebra.star_closure Subalgebra.starClosure

theorem starClosure_le {S₁ : Subalgebra R A} {S₂ : StarSubalgebra R A} (h : S₁ ≤ S₂.toSubalgebra) :
    S₁.starClosure ≤ S₂ :=
  StarSubalgebra.toSubalgebra_le_iff.1 <|
    sup_le h fun x hx =>
      (star_star x ▸ star_mem (show star x ∈ S₂ from h <| (S₁.mem_star_iff _).1 hx) : x ∈ S₂)
#align subalgebra.star_closure_le Subalgebra.starClosure_le

theorem starClosure_le_iff {S₁ : Subalgebra R A} {S₂ : StarSubalgebra R A} :
    S₁.starClosure ≤ S₂ ↔ S₁ ≤ S₂.toSubalgebra :=
  ⟨fun h => le_sup_left.trans h, starClosure_le⟩
#align subalgebra.star_closure_le_iff Subalgebra.starClosure_le_iff

end Subalgebra

/-! ### The star subalgebra generated by a set -/

namespace StarSubalgebra

variable {F R A B : Type _} [CommSemiring R] [StarRing R]

variable [Semiring A] [Algebra R A] [StarRing A] [StarModule R A]

variable [Semiring B] [Algebra R B] [StarRing B] [StarModule R B]

variable (R)

/-- The minimal star subalgebra that contains `s`. -/
@[simps!]
def adjoin (s : Set A) : StarSubalgebra R A :=
  { Algebra.adjoin R (s ∪ star s) with
    star_mem' := fun hx => by
      rwa [Subalgebra.mem_carrier, ← Subalgebra.mem_star_iff, Subalgebra.star_adjoin_comm,
        Set.union_star, star_star, Set.union_comm] }
#align star_subalgebra.adjoin StarSubalgebra.adjoin

theorem adjoin_eq_starClosure_adjoin (s : Set A) : adjoin R s = (Algebra.adjoin R s).starClosure :=
  toSubalgebra_injective <|
    show Algebra.adjoin R (s ∪ star s) = Algebra.adjoin R s ⊔ star (Algebra.adjoin R s) from
      (Subalgebra.star_adjoin_comm R s).symm ▸ Algebra.adjoin_union s (star s)
#align star_subalgebra.adjoin_eq_star_closure_adjoin StarSubalgebra.adjoin_eq_starClosure_adjoin

theorem adjoin_toSubalgebra (s : Set A) :
    (adjoin R s).toSubalgebra = Algebra.adjoin R (s ∪ star s) :=
  rfl
#align star_subalgebra.adjoin_to_subalgebra StarSubalgebra.adjoin_toSubalgebra

theorem subset_adjoin (s : Set A) : s ⊆ adjoin R s :=
  (Set.subset_union_left s (star s)).trans Algebra.subset_adjoin
#align star_subalgebra.subset_adjoin StarSubalgebra.subset_adjoin

theorem star_subset_adjoin (s : Set A) : star s ⊆ adjoin R s :=
  (Set.subset_union_right s (star s)).trans Algebra.subset_adjoin
#align star_subalgebra.star_subset_adjoin StarSubalgebra.star_subset_adjoin

theorem self_mem_adjoin_singleton (x : A) : x ∈ adjoin R ({x} : Set A) :=
  Algebra.subset_adjoin <| Set.mem_union_left _ (Set.mem_singleton x)
#align star_subalgebra.self_mem_adjoin_singleton StarSubalgebra.self_mem_adjoin_singleton

theorem star_self_mem_adjoin_singleton (x : A) : star x ∈ adjoin R ({x} : Set A) :=
  star_mem <| self_mem_adjoin_singleton R x
#align star_subalgebra.star_self_mem_adjoin_singleton StarSubalgebra.star_self_mem_adjoin_singleton

variable {R}

protected theorem gc : GaloisConnection (adjoin R : Set A → StarSubalgebra R A) (↑) := by
  intro s S
  rw [← toSubalgebra_le_iff, adjoin_toSubalgebra, Algebra.adjoin_le_iff, coe_toSubalgebra]
  exact
    ⟨fun h => (Set.subset_union_left s _).trans h, fun h =>
      Set.union_subset h fun x hx => star_star x ▸ star_mem (show star x ∈ S from h hx)⟩
#align star_subalgebra.gc StarSubalgebra.gc

/-- Galois insertion between `adjoin` and `coe`. -/
protected def gi : GaloisInsertion (adjoin R : Set A → StarSubalgebra R A) (↑) where
  choice s hs := (adjoin R s).copy s <| le_antisymm (StarSubalgebra.gc.le_u_l s) hs
  gc := StarSubalgebra.gc
  le_l_u S := (StarSubalgebra.gc (S : Set A) (adjoin R S)).1 <| le_rfl
  choice_eq _ _ := StarSubalgebra.copy_eq _ _ _
#align star_subalgebra.gi StarSubalgebra.gi

theorem adjoin_le {S : StarSubalgebra R A} {s : Set A} (hs : s ⊆ S) : adjoin R s ≤ S :=
  StarSubalgebra.gc.l_le hs
#align star_subalgebra.adjoin_le StarSubalgebra.adjoin_le

theorem adjoin_le_iff {S : StarSubalgebra R A} {s : Set A} : adjoin R s ≤ S ↔ s ⊆ S :=
  StarSubalgebra.gc _ _
#align star_subalgebra.adjoin_le_iff StarSubalgebra.adjoin_le_iff

theorem _root_.Subalgebra.starClosure_eq_adjoin (S : Subalgebra R A) :
    S.starClosure = adjoin R (S : Set A) :=
  le_antisymm (Subalgebra.starClosure_le_iff.2 <| subset_adjoin R (S : Set A))
    (adjoin_le (le_sup_left : S ≤ S ⊔ star S))
#align subalgebra.star_closure_eq_adjoin Subalgebra.starClosure_eq_adjoin

/-- If some predicate holds for all `x ∈ (s : Set A)` and this predicate is closed under the
`algebraMap`, addition, multiplication and star operations, then it holds for `a ∈ adjoin R s`. -/
theorem adjoin_induction {s : Set A} {p : A → Prop} {a : A} (h : a ∈ adjoin R s)
    (Hs : ∀ x : A, x ∈ s → p x) (Halg : ∀ r : R, p (algebraMap R A r))
    (Hadd : ∀ x y : A, p x → p y → p (x + y)) (Hmul : ∀ x y : A, p x → p y → p (x * y))
    (Hstar : ∀ x : A, p x → p (star x)) : p a :=
  Algebra.adjoin_induction h
    (fun x hx => hx.elim (fun hx => Hs x hx) fun hx => star_star x ▸ Hstar _ (Hs _ hx)) Halg Hadd
    Hmul
#align star_subalgebra.adjoin_induction StarSubalgebra.adjoin_induction

theorem adjoin_induction₂ {s : Set A} {p : A → A → Prop} {a b : A} (ha : a ∈ adjoin R s)
    (hb : b ∈ adjoin R s) (Hs : ∀ x : A, x ∈ s → ∀ y : A, y ∈ s → p x y)
    (Halg : ∀ r₁ r₂ : R, p (algebraMap R A r₁) (algebraMap R A r₂))
    (Halg_left : ∀ (r : R) (x : A), x ∈ s → p (algebraMap R A r) x)
    (Halg_right : ∀ (r : R) (x : A), x ∈ s → p x (algebraMap R A r))
    (Hadd_left : ∀ x₁ x₂ y : A, p x₁ y → p x₂ y → p (x₁ + x₂) y)
    (Hadd_right : ∀ x y₁ y₂ : A, p x y₁ → p x y₂ → p x (y₁ + y₂))
    (Hmul_left : ∀ x₁ x₂ y : A, p x₁ y → p x₂ y → p (x₁ * x₂) y)
    (Hmul_right : ∀ x y₁ y₂ : A, p x y₁ → p x y₂ → p x (y₁ * y₂))
    (Hstar : ∀ x y : A, p x y → p (star x) (star y)) (Hstar_left : ∀ x y : A, p x y → p (star x) y)
    (Hstar_right : ∀ x y : A, p x y → p x (star y)) : p a b := by
  refine'
    Algebra.adjoin_induction₂ ha hb (fun x hx y hy => _) Halg (fun r x hx => _) (fun r x hx => _)
      Hadd_left Hadd_right Hmul_left Hmul_right
  · cases' hx with hx hx <;> cases' hy with hy hy
    · exact Hs x hx y hy
    · exact star_star y ▸ Hstar_right _ _ (Hs _ hx _ hy)
    · exact star_star x ▸ Hstar_left _ _ (Hs _ hx _ hy)
    · exact star_star x ▸ star_star y ▸ Hstar _ _ (Hs _ hx _ hy)
  · cases' hx with hx hx
    · exact Halg_left _ _ hx
    · exact star_star x ▸ Hstar_right _ _ (Halg_left r _ hx)
  · cases' hx with hx hx
    · exact Halg_right _ _ hx
    · exact star_star x ▸ Hstar_left _ _ (Halg_right r _ hx)
#align star_subalgebra.adjoin_induction₂ StarSubalgebra.adjoin_induction₂

/-- The difference with `StarSubalgebra.adjoin_induction` is that this acts on the subtype. -/
theorem adjoin_induction' {s : Set A} {p : adjoin R s → Prop} (a : adjoin R s)
    (Hs : ∀ (x) (h : x ∈ s), p ⟨x, subset_adjoin R s h⟩) (Halg : ∀ r, p (algebraMap R _ r))
    (Hadd : ∀ x y, p x → p y → p (x + y)) (Hmul : ∀ x y, p x → p y → p (x * y))
    (Hstar : ∀ x, p x → p (star x)) : p a :=
  Subtype.recOn a fun b hb =>
    by
    refine' Exists.elim _ fun (hb : b ∈ adjoin R s) (hc : p ⟨b, hb⟩) => hc
    apply adjoin_induction hb
    exacts[fun x hx => ⟨subset_adjoin R s hx, Hs x hx⟩, fun r =>
      ⟨StarSubalgebra.algebraMap_mem _ r, Halg r⟩, fun x y hx hy =>
      Exists.elim hx fun hx' hx => Exists.elim hy fun hy' hy => ⟨add_mem hx' hy', Hadd _ _ hx hy⟩,
      fun x y hx hy =>
      Exists.elim hx fun hx' hx => Exists.elim hy fun hy' hy => ⟨mul_mem hx' hy', Hmul _ _ hx hy⟩,
      fun x hx => Exists.elim hx fun hx' hx => ⟨star_mem hx', Hstar _ hx⟩]
#align star_subalgebra.adjoin_induction' StarSubalgebra.adjoin_induction'

variable (R)

/-- If all elements of `s : Set A` commute pairwise and also commute pairwise with elements of
`star s`, then `StarSubalgebra.adjoin R s` is commutative. See note [reducible non-instances]. -/
@[reducible]
def adjoinCommSemiringOfComm {s : Set A} (hcomm : ∀ a : A, a ∈ s → ∀ b : A, b ∈ s → a * b = b * a)
    (hcomm_star : ∀ a : A, a ∈ s → ∀ b : A, b ∈ s → a * star b = star b * a) :
    CommSemiring (adjoin R s) :=
  { (adjoin R s).toSubalgebra.toSemiring with
    mul_comm := by
      rintro ⟨x, hx⟩ ⟨y, hy⟩
      ext
      simp only [MulMemClass.mk_mul_mk]
      rw [← mem_toSubalgebra, adjoin_toSubalgebra] at hx hy
      letI : CommSemiring (Algebra.adjoin R (s ∪ star s)) :=
        Algebra.adjoinCommSemiringOfComm R
          (by
            intro a ha b hb
            cases' ha with ha ha <;> cases' hb with hb hb
            · exact hcomm _ ha _ hb
            · exact star_star b ▸ hcomm_star _ ha _ hb
            · exact star_star a ▸ (hcomm_star _ hb _ ha).symm
            · simpa only [star_mul, star_star] using congr_arg star (hcomm _ hb _ ha))
      exact congr_arg Subtype.val (mul_comm (⟨x, hx⟩ : Algebra.adjoin R (s ∪ star s)) ⟨y, hy⟩) }
#align star_subalgebra.adjoin_comm_semiring_of_comm StarSubalgebra.adjoinCommSemiringOfComm

-- porting note: work around lean4#2074
-- the following instance works with `set_option synthInstance.etaExperiment true`
attribute [-instance] Ring.toNonAssocRing Ring.toNonUnitalRing CommRing.toNonUnitalCommRing

/-- If all elements of `s : Set A` commute pairwise and also commute pairwise with elements of
`star s`, then `StarSubalgebra.adjoin R s` is commutative. See note [reducible non-instances]. -/
@[reducible]
def adjoinCommRingOfComm (R : Type u) {A : Type v} [CommRing R] [StarRing R] [Ring A] [Algebra R A]
    [StarRing A] [StarModule R A] {s : Set A}
    (hcomm : ∀ a : A, a ∈ s → ∀ b : A, b ∈ s → a * b = b * a)
    (hcomm_star : ∀ a : A, a ∈ s → ∀ b : A, b ∈ s → a * star b = star b * a) :
    CommRing (adjoin R s) :=
  { StarSubalgebra.adjoinCommSemiringOfComm R hcomm hcomm_star,
    (adjoin R s).toSubalgebra.toRing with }
#align star_subalgebra.adjoin_comm_ring_of_comm StarSubalgebra.adjoinCommRingOfComm

/-- The star subalgebra `StarSubalgebra.adjoin R {x}` generated by a single `x : A` is commutative
if `x` is normal. -/
instance adjoinCommSemiringOfIsStarNormal (x : A) [IsStarNormal x] :
    CommSemiring (adjoin R ({x} : Set A)) :=
  adjoinCommSemiringOfComm R
    (fun a ha b hb => by
      rw [Set.mem_singleton_iff] at ha hb
      rw [ha, hb])
    fun a ha b hb => by
    rw [Set.mem_singleton_iff] at ha hb
    simpa only [ha, hb] using (star_comm_self' x).symm
#align star_subalgebra.adjoin_comm_semiring_of_is_star_normal StarSubalgebra.adjoinCommSemiringOfIsStarNormal

/-- The star subalgebra `StarSubalgebra.adjoin R {x}` generated by a single `x : A` is commutative
if `x` is normal. -/
instance adjoinCommRingOfIsStarNormal (R : Type u) {A : Type v} [CommRing R] [StarRing R] [Ring A]
    [Algebra R A] [StarRing A] [StarModule R A] (x : A) [IsStarNormal x] :
    CommRing (adjoin R ({x} : Set A)) :=
  { (adjoin R ({x} : Set A)).toSubalgebra.toRing with mul_comm := mul_comm }
#align star_subalgebra.adjoin_comm_ring_of_is_star_normal StarSubalgebra.adjoinCommRingOfIsStarNormal

/-! ### Complete lattice structure -/

variable {R} -- porting note: redundant binder annotation update

instance completeLattice : CompleteLattice (StarSubalgebra R A) :=
  GaloisInsertion.liftCompleteLattice StarSubalgebra.gi

instance inhabited : Inhabited (StarSubalgebra R A) :=
  ⟨⊤⟩

@[simp]
theorem coe_top : (↑(⊤ : StarSubalgebra R A) : Set A) = Set.univ :=
  rfl
#align star_subalgebra.coe_top StarSubalgebra.coe_top

@[simp]
theorem mem_top {x : A} : x ∈ (⊤ : StarSubalgebra R A) :=
  Set.mem_univ x
#align star_subalgebra.mem_top StarSubalgebra.mem_top

@[simp]
theorem top_toSubalgebra : (⊤ : StarSubalgebra R A).toSubalgebra = ⊤ := by ext; simp
-- porting note: Lean can no longer prove this by `rfl`, it times out
#align star_subalgebra.top_to_subalgebra StarSubalgebra.top_toSubalgebra

@[simp]
theorem toSubalgebra_eq_top {S : StarSubalgebra R A} : S.toSubalgebra = ⊤ ↔ S = ⊤ :=
  StarSubalgebra.toSubalgebra_injective.eq_iff' top_toSubalgebra
#align star_subalgebra.to_subalgebra_eq_top StarSubalgebra.toSubalgebra_eq_top

theorem mem_sup_left {S T : StarSubalgebra R A} : ∀ {x : A}, x ∈ S → x ∈ S ⊔ T :=
  have : S ≤ S ⊔ T := le_sup_left; (this ·) -- Porting note: need `have` instead of `show`
#align star_subalgebra.mem_sup_left StarSubalgebra.mem_sup_left

theorem mem_sup_right {S T : StarSubalgebra R A} : ∀ {x : A}, x ∈ T → x ∈ S ⊔ T :=
  have : T ≤ S ⊔ T := le_sup_right; (this ·) -- Porting note: need `have` instead of `show`
#align star_subalgebra.mem_sup_right StarSubalgebra.mem_sup_right

theorem mul_mem_sup {S T : StarSubalgebra R A} {x y : A} (hx : x ∈ S) (hy : y ∈ T) :
    x * y ∈ S ⊔ T :=
  mul_mem (mem_sup_left hx) (mem_sup_right hy)
#align star_subalgebra.mul_mem_sup StarSubalgebra.mul_mem_sup

theorem map_sup (f : A →⋆ₐ[R] B) (S T : StarSubalgebra R A) : map f (S ⊔ T) = map f S ⊔ map f T :=
  (StarSubalgebra.gc_map_comap f).l_sup
#align star_subalgebra.map_sup StarSubalgebra.map_sup

@[simp, norm_cast]
theorem coe_inf (S T : StarSubalgebra R A) : (↑(S ⊓ T) : Set A) = (S : Set A) ∩ T :=
  rfl
#align star_subalgebra.coe_inf StarSubalgebra.coe_inf

@[simp]

@[simp]
theorem inf_toSubalgebra (S T : StarSubalgebra R A) :
    (S ⊓ T).toSubalgebra = S.toSubalgebra ⊓ T.toSubalgebra := by
  ext; simp
-- porting note: Lean can no longer prove this by `rfl`, it times out
#align star_subalgebra.inf_to_subalgebra StarSubalgebra.inf_toSubalgebra

@[simp, norm_cast]
theorem coe_infₛ (S : Set (StarSubalgebra R A)) : (↑(infₛ S) : Set A) = ⋂ s ∈ S, ↑s :=
  infₛ_image
#align star_subalgebra.coe_Inf StarSubalgebra.coe_infₛ

theorem mem_infₛ {S : Set (StarSubalgebra R A)} {x : A} : x ∈ infₛ S ↔ ∀ p ∈ S, x ∈ p := by
  simp only [← SetLike.mem_coe, coe_infₛ, Set.mem_interᵢ₂]
#align star_subalgebra.mem_Inf StarSubalgebra.mem_infₛ

@[simp]
theorem infₛ_toSubalgebra (S : Set (StarSubalgebra R A)) :
    (infₛ S).toSubalgebra = infₛ (StarSubalgebra.toSubalgebra '' S) :=
  SetLike.coe_injective <| by simp
#align star_subalgebra.Inf_to_subalgebra StarSubalgebra.infₛ_toSubalgebra

@[simp, norm_cast]
theorem coe_infᵢ {ι : Sort _} {S : ι → StarSubalgebra R A} : (↑(⨅ i, S i) : Set A) = ⋂ i, S i := by
  simp [infᵢ]
#align star_subalgebra.coe_infi StarSubalgebra.coe_infᵢ

theorem mem_infᵢ {ι : Sort _} {S : ι → StarSubalgebra R A} {x : A} :
    (x ∈ ⨅ i, S i) ↔ ∀ i, x ∈ S i := by simp only [infᵢ, mem_infₛ, Set.forall_range_iff]
#align star_subalgebra.mem_infi StarSubalgebra.mem_infᵢ

@[simp]
theorem infᵢ_toSubalgebra {ι : Sort _} (S : ι → StarSubalgebra R A) :
    (⨅ i, S i).toSubalgebra = ⨅ i, (S i).toSubalgebra :=
  SetLike.coe_injective <| by simp
#align star_subalgebra.infi_to_subalgebra StarSubalgebra.infᵢ_toSubalgebra

theorem bot_toSubalgebra : (⊥ : StarSubalgebra R A).toSubalgebra = ⊥ := by
  change Algebra.adjoin R (∅ ∪ star ∅) = Algebra.adjoin R ∅
  simp
#align star_subalgebra.bot_to_subalgebra StarSubalgebra.bot_toSubalgebra

theorem mem_bot {x : A} : x ∈ (⊥ : StarSubalgebra R A) ↔ x ∈ Set.range (algebraMap R A) := by
  rw [← mem_toSubalgebra, bot_toSubalgebra, Algebra.mem_bot]
#align star_subalgebra.mem_bot StarSubalgebra.mem_bot

@[simp]
theorem coe_bot : ((⊥ : StarSubalgebra R A) : Set A) = Set.range (algebraMap R A) := by
  simp [Set.ext_iff, mem_bot]
#align star_subalgebra.coe_bot StarSubalgebra.coe_bot

theorem eq_top_iff {S : StarSubalgebra R A} : S = ⊤ ↔ ∀ x : A, x ∈ S :=
  ⟨fun h x => by rw [h]; exact mem_top,
  fun h => by ext x; exact ⟨fun _ => mem_top, fun _ => h x⟩⟩
#align star_subalgebra.eq_top_iff StarSubalgebra.eq_top_iff

end StarSubalgebra

namespace StarAlgHom

open StarSubalgebra

variable {F R A B : Type _} [CommSemiring R] [StarRing R]

variable [Semiring A] [Algebra R A] [StarRing A] [StarModule R A]

variable [Semiring B] [Algebra R B] [StarRing B]

variable [hF : StarAlgHomClass F R A B] (f g : F)

/-- The equalizer of two star `R`-algebra homomorphisms. -/
def equalizer : StarSubalgebra R A :=
  { toSubalgebra := AlgHom.equalizer (f : A →ₐ[R] B) g
    star_mem' := @fun a (ha : f a = g a) => by simpa only [←map_star] using congrArg star ha }
-- porting note: much like `StarSubalgebra.copy` the old proof was broken and hard to fix
#align star_alg_hom.equalizer StarAlgHom.equalizer

@[simp]
theorem mem_equalizer (x : A) : x ∈ StarAlgHom.equalizer f g ↔ f x = g x :=
  Iff.rfl
#align star_alg_hom.mem_equalizer StarAlgHom.mem_equalizer

theorem adjoin_le_equalizer {s : Set A} (h : s.EqOn f g) : adjoin R s ≤ StarAlgHom.equalizer f g :=
  adjoin_le h
#align star_alg_hom.adjoin_le_equalizer StarAlgHom.adjoin_le_equalizer

theorem ext_of_adjoin_eq_top {s : Set A} (h : adjoin R s = ⊤) ⦃f g : F⦄ (hs : s.EqOn f g) : f = g :=
  FunLike.ext f g fun _x => StarAlgHom.adjoin_le_equalizer f g hs <| h.symm ▸ trivial
#align star_alg_hom.ext_of_adjoin_eq_top StarAlgHom.ext_of_adjoin_eq_top

theorem map_adjoin [StarModule R B] (f : A →⋆ₐ[R] B) (s : Set A) :
    map f (adjoin R s) = adjoin R (f '' s) :=
  GaloisConnection.l_comm_of_u_comm Set.image_preimage (gc_map_comap f) StarSubalgebra.gc
    StarSubalgebra.gc fun _ => rfl
#align star_alg_hom.map_adjoin StarAlgHom.map_adjoin

theorem ext_adjoin {s : Set A} [StarAlgHomClass F R (adjoin R s) B] {f g : F}
    (h : ∀ x : adjoin R s, (x : A) ∈ s → f x = g x) : f = g := by
  refine' FunLike.ext f g fun a =>
    adjoin_induction' (p := fun y => f y = g y) a (fun x hx => _) (fun r => _)
    (fun x y hx hy => _) (fun x y hx hy => _) fun x hx => _
  · exact h ⟨x, subset_adjoin R s hx⟩ hx
  · simp only [AlgHomClass.commutes]
  · simp only [map_add, map_add, hx, hy]
  · simp only [map_mul, map_mul, hx, hy]
  · simp only [map_star, hx]
#align star_alg_hom.ext_adjoin StarAlgHom.ext_adjoin

theorem ext_adjoin_singleton {a : A} [StarAlgHomClass F R (adjoin R ({a} : Set A)) B] {f g : F}
    (h : f ⟨a, self_mem_adjoin_singleton R a⟩ = g ⟨a, self_mem_adjoin_singleton R a⟩) : f = g :=
  ext_adjoin fun x hx =>
    (show x = ⟨a, self_mem_adjoin_singleton R a⟩ from
          Subtype.ext <| Set.mem_singleton_iff.mp hx).symm ▸
      h
#align star_alg_hom.ext_adjoin_singleton StarAlgHom.ext_adjoin_singleton

end StarAlgHom