/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Kevin Buzzard, Jujian Zhang
-/
import algebra.direct_sum.algebra
import algebra.direct_sum.decomposition
import algebra.direct_sum.internal
import algebra.direct_sum.ring
import group_theory.subgroup.basic

/-!
# Internally-graded rings and algebras

This file defines the typeclass `graded_algebra 𝒜`, for working with an algebra `A` that is
internally graded by a collection of submodules `𝒜 : ι → submodule R A`.
See the docstring of that typeclass for more information.

## Main definitions

* `graded_ring 𝒜`: the typeclass, which is a combination of `set_like.graded_monoid`, and
  `direct_sum.decomposition 𝒜`.
* `graded_algebra 𝒜`: A convenience alias for `graded_ring` when `𝒜` is a family of submodules.
* `direct_sum.decompose_ring_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `direct_sum.decompose_alg_equiv 𝒜 : A ≃ₐ[R] ⨁ i, 𝒜 i`, a more bundled version of
  `direct_sum.decompose 𝒜`.
* `graded_algebra.proj 𝒜 i` is the linear map from `A` to its degree `i : ι` component, such that
  `proj 𝒜 i x = decompose 𝒜 x i`.

## Implementation notes

For now, we do not have internally-graded semirings and internally-graded rings; these can be
represented with `𝒜 : ι → submodule ℕ A` and `𝒜 : ι → submodule ℤ A` respectively, since all
`semiring`s are ℕ-algebras via `algebra_nat`, and all `ring`s are `ℤ`-algebras via `algebra_int`.

## Tags

graded algebra, graded ring, graded semiring, decomposition
-/

open_locale direct_sum big_operators

variables {ι R A σ : Type*}
section graded_ring
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ)

include A

open direct_sum

/-- An internally-graded `R`-algebra `A` is one that can be decomposed into a collection
of `submodule R A`s indexed by `ι` such that the canonical map `A → ⨁ i, 𝒜 i` is bijective and
respects multiplication, i.e. the product of an element of degree `i` and an element of degree `j`
is an element of degree `i + j`.

Note that the fact that `A` is internally-graded, `graded_algebra 𝒜`, implies an externally-graded
algebra structure `direct_sum.galgebra R (λ i, ↥(𝒜 i))`, which in turn makes available an
`algebra R (⨁ i, 𝒜 i)` instance.
-/
class graded_ring (𝒜 : ι → σ) extends set_like.graded_monoid 𝒜, direct_sum.decomposition 𝒜.

variables [graded_ring 𝒜]
namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
a ring to a direct sum of components. -/
def decompose_ring_equiv : A ≃+* ⨁ i, 𝒜 i := ring_equiv.symm
{ map_mul' := (coe_ring_hom 𝒜).map_mul,
  map_add' := (coe_ring_hom 𝒜).map_add,
  ..(decompose_add_equiv 𝒜).symm }

@[simp] lemma decompose_one : decompose 𝒜 (1 : A) = 1 := map_one (decompose_ring_equiv 𝒜)
@[simp] lemma decompose_symm_one : (decompose 𝒜).symm 1 = (1 : A) :=
map_one (decompose_ring_equiv 𝒜).symm

@[simp] lemma decompose_mul (x y : A) : decompose 𝒜 (x * y) = decompose 𝒜 x * decompose 𝒜 y :=
map_mul (decompose_ring_equiv 𝒜) x y
@[simp] lemma decompose_symm_mul (x y : ⨁ i, 𝒜 i) :
  (decompose 𝒜).symm (x * y) = (decompose 𝒜).symm x * (decompose 𝒜).symm y :=
map_mul (decompose_ring_equiv 𝒜).symm x y

end direct_sum

/-- The projection maps of a graded ring -/
def graded_ring.proj (i : ι) : A →+ A :=
(add_submonoid_class.subtype (𝒜 i)).comp $
  (dfinsupp.eval_add_monoid_hom i).comp $
  ring_hom.to_add_monoid_hom $ ring_equiv.to_ring_hom $ direct_sum.decompose_ring_equiv 𝒜

@[simp] lemma graded_ring.proj_apply (i : ι) (r : A) :
  graded_ring.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_ring.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_ring.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (direct_sum.of _ i (a i)) :=
by rw [graded_ring.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_ring.mem_support_iff [Π i (x : 𝒜 i), decidable (x ≠ 0)] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_ring.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans add_submonoid_class.coe_eq_zero.not.symm

end graded_ring

section graded_algebra
variables [decidable_eq ι] [add_monoid ι] [comm_semiring R] [semiring A] [algebra R A]
variables (𝒜 : ι → submodule R A)

/-- A special case of `graded_ring` with `σ = submodule R A`. This is useful both because it
can avoid typeclass search, and because it provides a more concise name. -/
@[reducible]
def graded_algebra := graded_ring 𝒜

/-- A helper to construct a `graded_algebra` when the `set_like.graded_monoid` structure is already
available. This makes the `left_inv` condition easier to prove, and phrases the `right_inv`
condition in a way that allows custom `@[ext]` lemmas to apply.

See note [reducible non-instances]. -/
@[reducible]
def graded_algebra.of_alg_hom [set_like.graded_monoid 𝒜] (decompose : A →ₐ[R] ⨁ i, 𝒜 i)
  (right_inv : (direct_sum.coe_alg_hom 𝒜).comp decompose = alg_hom.id R A)
  (left_inv : ∀ i (x : 𝒜 i), decompose (x : A) = direct_sum.of (λ i, ↥(𝒜 i)) i x) :
  graded_algebra 𝒜 :=
{ decompose' := decompose,
  left_inv := alg_hom.congr_fun right_inv,
  right_inv := begin
    suffices : decompose.comp (direct_sum.coe_alg_hom 𝒜) = alg_hom.id _ _,
    from alg_hom.congr_fun this,
    ext i x : 2,
    exact (decompose.congr_arg $ direct_sum.coe_alg_hom_of _ _ _).trans (left_inv i x),
  end}

variable [graded_algebra 𝒜]

namespace direct_sum

/-- If `A` is graded by `ι` with degree `i` component `𝒜 i`, then it is isomorphic as
an algebra to a direct sum of components. -/
@[simps]
def decompose_alg_equiv : A ≃ₐ[R] ⨁ i, 𝒜 i := alg_equiv.symm
{ map_mul' := (coe_alg_hom 𝒜).map_mul,
  map_add' := (coe_alg_hom 𝒜).map_add,
  commutes' := (coe_alg_hom 𝒜).commutes,
  ..(decompose_add_equiv 𝒜).symm }

end direct_sum

open direct_sum

/-- The projection maps of graded algebra-/
def graded_algebra.proj (𝒜 : ι → submodule R A) [graded_algebra 𝒜] (i : ι) : A →ₗ[R] A :=
(𝒜 i).subtype.comp $
  (dfinsupp.lapply i).comp $
  (decompose_alg_equiv 𝒜).to_alg_hom.to_linear_map

@[simp] lemma graded_algebra.proj_apply (i : ι) (r : A) :
  graded_algebra.proj 𝒜 i r = (decompose 𝒜 r : ⨁ i, 𝒜 i) i := rfl

lemma graded_algebra.proj_recompose (a : ⨁ i, 𝒜 i) (i : ι) :
  graded_algebra.proj 𝒜 i ((decompose 𝒜).symm a) =
  (decompose 𝒜).symm (of _ i (a i)) :=
by rw [graded_algebra.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_algebra.mem_support_iff [decidable_eq A] (r : A) (i : ι) :
  i ∈ (decompose 𝒜 r).support ↔ graded_algebra.proj 𝒜 i r ≠ 0 :=
dfinsupp.mem_support_iff.trans submodule.coe_eq_zero.not.symm

end graded_algebra

section canonical_order

open graded_ring set_like.graded_monoid direct_sum

variables [semiring A] [decidable_eq ι]
variables [canonically_ordered_add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]

/--
If `A` is graded by a canonically ordered add monoid, then the projection map `x ↦ x₀` is a ring
homomorphism.
-/
@[simps]
def graded_ring.proj_zero_ring_hom : A →+* A :=
{ to_fun := λ a, decompose 𝒜 a 0,
  map_one' := decompose_of_mem_same 𝒜 one_mem,
  map_zero' := by simp,
  map_add' := λ _ _, by simp,
  map_mul' := λ x y, begin
    -- Convert the abstract add_submonoid into a concrete one. This is necessary as there is no
    -- lattice structure on the abstract ones.
    let 𝒜' : ι → add_submonoid A :=
      λ i, (⟨𝒜 i, λ _ _, add_mem_class.add_mem, zero_mem_class.zero_mem _⟩ : add_submonoid A),
    letI : graded_ring 𝒜' :=
      { decompose' := (direct_sum.decompose 𝒜 : A → ⨁ i, 𝒜 i),
        left_inv := direct_sum.decomposition.left_inv,
        right_inv := direct_sum.decomposition.right_inv,
        ..(by apply_instance : set_like.graded_monoid 𝒜), },
    have m : ∀ x, x ∈ supr 𝒜',
    { intro x,
      rw direct_sum.is_internal.add_submonoid_supr_eq_top 𝒜'
        (direct_sum.decomposition.is_internal 𝒜'),
      exact add_submonoid.mem_top x },
    refine add_submonoid.supr_induction 𝒜' (m x) (λ i c hc, _) _ _,
    { refine add_submonoid.supr_induction 𝒜' (m y) (λ j c' hc', _) _ _,
      { by_cases h : i + j = 0,
        { rw [decompose_of_mem_same 𝒜 (show c * c' ∈ 𝒜 0, from h ▸ mul_mem hc hc'),
            decompose_of_mem_same 𝒜 (show c ∈ 𝒜 0, from (add_eq_zero_iff.mp h).1 ▸ hc),
            decompose_of_mem_same 𝒜 (show c' ∈ 𝒜 0, from (add_eq_zero_iff.mp h).2 ▸ hc')] },
        { rw [decompose_of_mem_ne 𝒜 (mul_mem hc hc') h],
          cases (show i ≠ 0 ∨ j ≠ 0, by rwa [add_eq_zero_iff, not_and_distrib] at h) with h' h',
          { simp only [decompose_of_mem_ne 𝒜 hc h', zero_mul] },
          { simp only [decompose_of_mem_ne 𝒜 hc' h', mul_zero] } } },
      { simp only [decompose_zero, zero_apply, add_submonoid_class.coe_zero, mul_zero], },
      { intros _ _ hd he,
        simp only [mul_add, decompose_add, add_apply, add_mem_class.coe_add, hd, he] } },
    { simp only [decompose_zero, zero_apply, add_submonoid_class.coe_zero, zero_mul] },
    { rintros _ _ ha hb,
      simp only [add_mul, decompose_add, add_apply, add_mem_class.coe_add, ha, hb] },
  end }

end canonical_order


/-
This is a d∃∀duction file providing easy and progressive exercises for basic set theory.
It may be used as a tutorial for d∃∀duction.
French version.
-/

import data.set
import tactic

-- dEAduction tactics
import structures2      -- hypo_analysis, targets_analysis
import utils            -- no_meta_vars
import user_notations   -- notations that can be used in deaduction UI for a new object

-- dEAduction definitions
import set_definitions

-------------------------
-- dEAduction METADATA --
-------------------------

/- dEAduction
Title
    Tutoriel
Author
    Camille Lichère
Institution
    Université de France
Description
    Ce fichier contient quelques exercices faciles et progressifs de théorie élémentaire
    des ensembles. Il peut être utilisé comme tutoriel pour d∃∀duction ; en particulier,
    les boutons logiques sont introduits progressivement.
AvailableProof
    ALL -new_object
AvailableMagic
    assumption
-/

local attribute [instance] classical.prop_decidable

---------------------------------------------
-- global parameters = implicit variables --
---------------------------------------------
section course
parameters {X Y Z: Type}

open set

------------------------
-- COURSE DEFINITIONS --
------------------------
namespace definitions
/- dEAduction
PrettyName
    Définitions
-/

namespace inclusions_egalites
/- dEAduction
PrettyName
    Inclusions, égalités
-/

lemma definition.inclusion {A B : set X} : A ⊆ B ↔ ∀ {x:X}, x ∈ A → x ∈ B :=
/- dEAduction
ImplicitUse
    True
-/
begin
    exact iff.rfl
end

lemma definition.egalite_deux_ensembles {A A' : set X} :
(A = A') ↔ ( ∀ x, x ∈ A ↔ x ∈ A' ) :=
/- dEAduction
PrettyName
    Egalité de deux ensembles
ImplicitUse
    True
-/
begin
     exact set.ext_iff
end

lemma definition.double_inclusion (A A' : set X) :
A = A' ↔ (A ⊆ A' ∧ A' ⊆ A):=
/- dEAduction
PrettyName
    Double inclusion
ImplicitUse
    True
-/
begin
    exact subset.antisymm_iff,
end
end inclusions_egalites

namespace unions_intersections
/- dEAduction
PrettyName
    Unions, intersections
-/
lemma definition.intersection_deux_ensembles {A B : set X} {x : X} :
x ∈ A ∩ B ↔ ( x ∈ A ∧ x ∈ B) :=
/- dEAduction
PrettyName
    Intersection de deux ensembles
ImplicitUse
    True
-/
begin
    exact iff.rfl
end

lemma definition.union_deux_ensembles  {A : set X} {B : set X} {x : X} :
x ∈ A ∪ B ↔ ( x ∈ A ∨ x ∈ B) :=
/- dEAduction
PrettyName
    Union de deux ensembles
ImplicitUse
    True
-/
begin
    exact iff.rfl
end

end unions_intersections

end definitions
---------------
-- SECTION 1 --
---------------
-- variables exercices --
-- variables {A B C : set X}

---------------
-- EXERCICES --
---------------
namespace exercices

lemma exercise.intersection_inclus_ensemble
(A B : set X) :
A ∩ B ⊆ A
:=
/- dEAduction
PrettyName
    Un ensemble contient son intersection avec un autre
Description
    Voici un premier exercice !
-/
begin
    todo
end

lemma exercise.inclus_dans_les_deux_implique_dans_lintersection
(A B C : set X) :
(C ⊆ A) ∧ (C ⊆ B) → C ⊆ A ∩ B
:=
/- dEAduction
PrettyName
    Inclus dans les deux implique inclus dans l'intersection
Description
    Voici un deuxième exercice !
-/
begin
    todo
end

lemma exercise.inclusion_transitive
(A B C : set X) :
(A ⊆ B ∧ B ⊆ C) → A ⊆ C
:=
/- dEAduction
PrettyName
    Transitivité de l'inclusion
Description
    Voici un troisième exercice !
-/
begin
    todo
end

lemma exercise.ensemble_inclus_union
(A B : set X) :
B ⊆ A ∪ B
:=
/- dEAduction
PrettyName
    Ensemble inclus dans l'union
Description
    Le bouton ∨ ("ou"), permet notamment de montrer un but de la forme "P ou Q" en choisissant si on veut montrer "P" ou "Q".
-/
begin
    todo
end

lemma exercise.ensemble_inclus_intersection
(A B : set X) :
A ⊆ A ∩ B  → (A ∪ B) = B
:=
/- dEAduction
PrettyName
    Ensemble inclus dans l'intersection
Description
    Le bouton ∨ ("ou") permet également, appliqué à une hypothèse du type "P ou Q" de faire une disjonction de cas selon si on a "P" ou "Q".
-/
begin
    todo
end

lemma exercise.inter_distributive_union
(A B C : set X):
A ∪ (B ∩ C) = (A ∪ B) ∩ (A ∪ C)
:=
/- dEAduction
PrettyName
    Union avec une intersection
Description
    Le bouton ↔ (équivalence), permet notamment de scinder "P ↔ Q" en deux implications "P → Q" et "Q → P".
-/
begin
    todo
end

lemma exercise.exercice_bilan
(A B : set X) :
A ⊆ B ↔ A ∩ B = A
:=
/- dEAduction
PrettyName
    Exercice bilan
-/
begin
    todo
end
end exercices

namespace composition
/- dEAduction
PrettyName
    Exercices sur la composition
-/

open set
variables (f: X → Y) (g : Y → Z) (A: set X) (B: set Y)

namespace definitions
/- dEAduction
PrettyName
    Définitions
-/

lemma definition.composition {x:X}:
composition g f x = g (f x)
:=
begin
    todo,
end

lemma definition.image_directe (y : Y) : y ∈ f '' A ↔ ∃ x : X, x ∈ A ∧  f x = y :=
/- dEAduction
ImplicitUse
    True
-/
begin
    todo
end

lemma definition.image_reciproque (x:X) : x ∈ f  ⁻¹' B ↔ f(x) ∈ B :=
begin
    todo
end

lemma definition.injectivite :
injective f ↔ ∀ x y : X, (f x = f y → x = y)
:=
/- dEAduction
PrettyName
    Application injective
ImplicitUse
    True
-/
begin
    refl,
end

lemma definition.surjectivite :
surjective f ↔ ∀ y : Y, ∃ x : X, y = f x
:=
/- dEAduction
PrettyName
    Application surjective
ImplicitUse
    True
-/
begin
    refl,
end

end definitions

namespace exercices

lemma exercise.composition_injections
(H1 : injective f) (H2 : injective g)
:
injective (composition g f)
:=
/- dEAduction
PrettyName
    Composition d'injections
-/
begin
    todo
end

lemma exercise.composition_surjections
(H1 : surjective f) (H2 : surjective g) :
surjective (composition g f)
:=
/- dEAduction
PrettyName
    Composition de surjections
-/
begin
    todo
end

lemma exercise.composition_image_directe
(A: set X) :
(composition g f) '' A = g '' (f '' A)
:=
/- dEAduction
PrettyName
    Image directe par une composition
-/
begin
    todo
end

lemma exercise.composition_image_reciproque
(C: set Z) :
(composition g f) ⁻¹' C = f ⁻¹' (g ⁻¹' C)
:=
/- dEAduction
PrettyName
    Image réciproque par une composition
-/
begin
    todo
end

end exercices
end composition
end course


/-
Copyright (c) 2022 Sam van Gool and Jake Levinson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sam van Gool, Jake Levinson

! This file was ported from Lean 3 source module topology.sheaves.locally_surjective
! leanprover-community/mathlib commit fb7698eb37544cbb66292b68b40e54d001f8d1a9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.Sheaves.Presheaf
import Mathbin.Topology.Sheaves.Stalks
import Mathbin.CategoryTheory.Sites.Surjective

/-!

# Locally surjective maps of presheaves.

Let `X` be a topological space, `ℱ` and `𝒢` presheaves on `X`, `T : ℱ ⟶ 𝒢` a map.

In this file we formulate two notions for what it means for
`T` to be locally surjective:

  1. For each open set `U`, each section `t : 𝒢(U)` is in the image of `T`
     after passing to some open cover of `U`.

  2. For each `x : X`, the map of *stalks* `Tₓ : ℱₓ ⟶ 𝒢ₓ` is surjective.

We prove that these are equivalent.

-/

universe v u

noncomputable section

open CategoryTheory

open TopologicalSpace

open Opposite

namespace TopCat.Presheaf

section LocallySurjective

attribute [local instance] concrete_category.has_coe_to_fun

attribute [local instance] concrete_category.has_coe_to_sort

open AlgebraicGeometry

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

variable {ℱ 𝒢 : X.Presheaf C}

/-- A map of presheaves `T : ℱ ⟶ 𝒢` is **locally surjective** if for any open set `U`,
section `t` over `U`, and `x ∈ U`, there exists an open set `x ∈ V ⊆ U` and a section `s` over `V`
such that `$T_*(s_V) = t|_V$`.

See `is_locally_surjective_iff` below.
-/
def IsLocallySurjective (T : ℱ ⟶ 𝒢) :=
  CategoryTheory.IsLocallySurjective (Opens.grothendieckTopology X) T
#align Top.presheaf.is_locally_surjective TopCat.Presheaf.IsLocallySurjective

theorem isLocallySurjective_iff (T : ℱ ⟶ 𝒢) :
    IsLocallySurjective T ↔
      ∀ (U t), ∀ x ∈ U, ∃ (V : _)(ι : V ⟶ U), (∃ s, T.app _ s = t |_ₕ ι) ∧ x ∈ V :=
  Iff.rfl
#align Top.presheaf.is_locally_surjective_iff TopCat.Presheaf.isLocallySurjective_iff

section SurjectiveOnStalks

variable [Limits.HasColimits C] [Limits.PreservesFilteredColimits (forget C)]

/-- An equivalent condition for a map of presheaves to be locally surjective
is for all the induced maps on stalks to be surjective. -/
theorem locally_surjective_iff_surjective_on_stalks (T : ℱ ⟶ 𝒢) :
    IsLocallySurjective T ↔ ∀ x : X, Function.Surjective ((stalkFunctor C x).map T) :=
  by
  constructor <;> intro hT
  · /- human proof:
        Let g ∈ Γₛₜ 𝒢 x be a germ. Represent it on an open set U ⊆ X
        as ⟨t, U⟩. By local surjectivity, pass to a smaller open set V
        on which there exists s ∈ Γ_ ℱ V mapping to t |_ V.
        Then the germ of s maps to g -/
    -- Let g ∈ Γₛₜ 𝒢 x be a germ.
    intro x g
    -- Represent it on an open set U ⊆ X as ⟨t, U⟩.
    obtain ⟨U, hxU, t, rfl⟩ := 𝒢.germ_exist x g
    -- By local surjectivity, pass to a smaller open set V
    -- on which there exists s ∈ Γ_ ℱ V mapping to t |_ V.
    rcases hT U t x hxU with ⟨V, ι, ⟨s, h_eq⟩, hxV⟩
    -- Then the germ of s maps to g.
    use ℱ.germ ⟨x, hxV⟩ s
    convert stalk_functor_map_germ_apply V ⟨x, hxV⟩ T s
    simpa [h_eq] using germ_res_apply 𝒢 ι ⟨x, hxV⟩ t
  · /- human proof:
        Let U be an open set, t ∈ Γ ℱ U a section, x ∈ U a point.
        By surjectivity on stalks, the germ of t is the image of
        some germ f ∈ Γₛₜ ℱ x. Represent f on some open set V ⊆ X as ⟨s, V⟩.
        Then there is some possibly smaller open set x ∈ W ⊆ V ∩ U on which
        we have T(s) |_ W = t |_ W. -/
    intro U t x hxU
    set t_x := 𝒢.germ ⟨x, hxU⟩ t with ht_x
    obtain ⟨s_x, hs_x : ((stalk_functor C x).map T) s_x = t_x⟩ := hT x t_x
    obtain ⟨V, hxV, s, rfl⟩ := ℱ.germ_exist x s_x
    -- rfl : ℱ.germ x s = s_x
    have key_W :=
      𝒢.germ_eq x hxV hxU (T.app _ s) t
        (by
          convert hs_x
          symm
          convert stalk_functor_map_germ_apply _ _ _ s)
    obtain ⟨W, hxW, hWV, hWU, h_eq⟩ := key_W
    refine' ⟨W, hWU, ⟨ℱ.map hWV.op s, _⟩, hxW⟩
    convert h_eq
    simp only [← comp_apply, T.naturality]
#align Top.presheaf.locally_surjective_iff_surjective_on_stalks TopCat.Presheaf.locally_surjective_iff_surjective_on_stalks

end SurjectiveOnStalks

end LocallySurjective

end TopCat.Presheaf


import algebra.module.linear_map
import linear_algebra.basic
import data.real.basic
import algebra.module.submodule

theorem cpge_applin_16
(R : Type*) (E : Type*) (F : Type*)
[field R]
[add_comm_group E] [module R E]
(f g : linear_map R E E)
:
f.comp (g.comp f) = f ∧  g.comp (f.comp g)  = g ->  g.ker + ((⊤ : submodule R E).map f) = ⊤ := sorry


/-
Copyright (c) 2019 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.set_theory.pgame
import Mathlib.PostPort

universes u_1 u_2 u l u_3

namespace Mathlib

/-!
# Surreal numbers

The basic theory of surreal numbers, built on top of the theory of combinatorial (pre-)games.

A pregame is `numeric` if all the Left options are strictly smaller than all the Right options, and
all those options are themselves numeric. In terms of combinatorial games, the numeric games have
"frozen"; you can only make your position worse by playing, and Left is some definite "number" of
moves ahead (or behind) Right.

A surreal number is an equivalence class of numeric pregames.

In fact, the surreals form a complete ordered field, containing a copy of the reals (and much else
besides!) but we do not yet have a complete development.

## Order properties
Surreal numbers inherit the relations `≤` and `<` from games, and these relations satisfy the axioms
of a partial order (recall that `x < y ↔ x ≤ y ∧ ¬ y ≤ x` did not hold for games).

## Algebraic operations
At this point, we have defined addition and negation (from pregames), and shown that surreals form
an additive semigroup. It would be very little work to finish showing that the surreals form an
ordered commutative group.

We define the operations of multiplication and inverse on surreals, but do not yet establish any of
the necessary properties to show the surreals form an ordered field.

## Embeddings
It would be nice projects to define the group homomorphism `surreal → game`, and also `ℤ → surreal`,
and then the homomorphic inclusion of the dyadic rationals into surreals, and finally
via dyadic Dedekind cuts the homomorphic inclusion of the reals into the surreals.

One can also map all the ordinals into the surreals!

## References
* [Conway, *On numbers and games*][conway2001]
-/

namespace pgame

/-! Multiplicative operations can be defined at the level of pre-games, but as
they are only useful on surreal numbers, we define them here. -/

/-- The product of `x = {xL | xR}` and `y = {yL | yR}` is
`{xL*y + x*yL - xL*yL, xR*y + x*yR - xR*yR | xL*y + x*yR - xL*yR, x*yL + xR*y - xR*yL }`. -/
def mul (x : pgame) (y : pgame) : pgame := sorry

protected instance has_mul : Mul pgame :=
  { mul := mul }

/-- Because the two halves of the definition of `inv` produce more elements
of each side, we have to define the two families inductively.
This is the indexing set for the function, and `inv_val` is the function part. -/
inductive inv_ty (l : Type u) (r : Type u) : Bool → Type u
where
| zero : inv_ty l r false
| left₁ : r → inv_ty l r false → inv_ty l r false
| left₂ : l → inv_ty l r tt → inv_ty l r false
| right₁ : l → inv_ty l r false → inv_ty l r tt
| right₂ : r → inv_ty l r tt → inv_ty l r tt

/-- Because the two halves of the definition of `inv` produce more elements
of each side, we have to define the two families inductively.
This is the function part, defined by recursion on `inv_ty`. -/
def inv_val {l : Type u_1} {r : Type u_1} (L : l → pgame) (R : r → pgame) (IHl : l → pgame) (IHr : r → pgame) {b : Bool} : inv_ty l r b → pgame :=
  sorry

/-- The inverse of a positive surreal number `x = {L | R}` is
given by `x⁻¹ = {0,
  (1 + (R - x) * x⁻¹L) * R, (1 + (L - x) * x⁻¹R) * L |
  (1 + (L - x) * x⁻¹L) * L, (1 + (R - x) * x⁻¹R) * R}`.
Because the two halves `x⁻¹L, x⁻¹R` of `x⁻¹` are used in their own
definition, the sets and elements are inductively generated. -/
def inv' : pgame → pgame :=
  sorry

/-- The inverse of a surreal number in terms of the inverse on positive surreals. -/
def inv (x : pgame) : pgame :=
  ite (x = 0) 0 (ite (0 < x) (inv' x) (inv' (-x)))

protected instance has_inv : has_inv pgame :=
  has_inv.mk inv

protected instance has_div : Div pgame :=
  { div := fun (x y : pgame) => x * (y⁻¹) }

/-- A pre-game is numeric if everything in the L set is less than everything in the R set,
and all the elements of L and R are also numeric. -/
def numeric : pgame → Prop :=
  sorry

theorem numeric.move_left {x : pgame} (o : numeric x) (i : left_moves x) : numeric (move_left x i) := sorry

theorem numeric.move_right {x : pgame} (o : numeric x) (j : right_moves x) : numeric (move_right x j) := sorry

theorem numeric_rec {C : pgame → Prop} (H : ∀ (l r : Type u_1) (L : l → pgame) (R : r → pgame),
  (∀ (i : l) (j : r), L i < R j) →
    (∀ (i : l), numeric (L i)) →
      (∀ (i : r), numeric (R i)) → (∀ (i : l), C (L i)) → (∀ (i : r), C (R i)) → C (mk l r L R)) (x : pgame) : numeric x → C x := sorry

theorem lt_asymm {x : pgame} {y : pgame} (ox : numeric x) (oy : numeric y) : x < y → ¬y < x := sorry

theorem le_of_lt {x : pgame} {y : pgame} (ox : numeric x) (oy : numeric y) (h : x < y) : x ≤ y :=
  iff.mp not_lt (lt_asymm ox oy h)

/-- On numeric pre-games, `<` and `≤` satisfy the axioms of a partial order (even though they
don't on all pre-games). -/
theorem lt_iff_le_not_le {x : pgame} {y : pgame} (ox : numeric x) (oy : numeric y) : x < y ↔ x ≤ y ∧ ¬y ≤ x :=
  { mp := fun (h : x < y) => { left := le_of_lt ox oy h, right := iff.mpr not_le h },
    mpr := fun (h : x ≤ y ∧ ¬y ≤ x) => iff.mp not_le (and.right h) }

theorem numeric_zero : numeric 0 := sorry

theorem numeric_one : numeric 1 := sorry

theorem numeric_neg {x : pgame} (o : numeric x) : numeric (-x) := sorry

theorem numeric.move_left_lt {x : pgame} (o : numeric x) (i : left_moves x) : move_left x i < x :=
  eq.mpr (id (Eq._oldrec (Eq.refl (move_left x i < x)) (propext lt_def_le)))
    (Or.inl (Exists.intro i (id (le_refl (move_left x i)))))

theorem numeric.move_left_le {x : pgame} (o : numeric x) (i : left_moves x) : move_left x i ≤ x :=
  le_of_lt (numeric.move_left o i) o (numeric.move_left_lt o i)

theorem numeric.lt_move_right {x : pgame} (o : numeric x) (j : right_moves x) : x < move_right x j :=
  eq.mpr (id (Eq._oldrec (Eq.refl (x < move_right x j)) (propext lt_def_le)))
    (Or.inr (Exists.intro j (id (le_refl (move_right x j)))))

theorem numeric.le_move_right {x : pgame} (o : numeric x) (j : right_moves x) : x ≤ move_right x j :=
  le_of_lt o (numeric.move_right o j) (numeric.lt_move_right o j)

theorem add_lt_add {w : pgame} {x : pgame} {y : pgame} {z : pgame} (ow : numeric w) (ox : numeric x) (oy : numeric y) (oz : numeric z) (hwx : w < x) (hyz : y < z) : w + y < x + z := sorry

theorem numeric_add {x : pgame} {y : pgame} (ox : numeric x) (oy : numeric y) : numeric (x + y) := sorry

-- TODO prove

-- theorem numeric_nat (n : ℕ) : numeric n := sorry

-- theorem numeric_omega : numeric omega := sorry

end pgame

/-- The equivalence on numeric pre-games. -/
def surreal.equiv (x : Subtype fun (x : pgame) => pgame.numeric x) (y : Subtype fun (x : pgame) => pgame.numeric x) :=
  pgame.equiv (subtype.val x) (subtype.val y)

protected instance surreal.setoid : setoid (Subtype fun (x : pgame) => pgame.numeric x) :=
  setoid.mk (fun (x y : Subtype fun (x : pgame) => pgame.numeric x) => pgame.equiv (subtype.val x) (subtype.val y)) sorry

/-- The type of surreal numbers. These are the numeric pre-games quotiented
by the equivalence relation `x ≈ y ↔ x ≤ y ∧ y ≤ x`. In the quotient,
the order becomes a total order. -/
def surreal :=
  quotient sorry

namespace surreal

/-- Construct a surreal number from a numeric pre-game. -/
def mk (x : pgame) (h : pgame.numeric x) : surreal :=
  quotient.mk { val := x, property := h }

protected instance has_zero : HasZero surreal :=
  { zero := quotient.mk { val := 0, property := pgame.numeric_zero } }

protected instance has_one : HasOne surreal :=
  { one := quotient.mk { val := 1, property := pgame.numeric_one } }

protected instance inhabited : Inhabited surreal :=
  { default := 0 }

/-- Lift an equivalence-respecting function on pre-games to surreals. -/
def lift {α : Sort u_1} (f : (x : pgame) → pgame.numeric x → α) (H : ∀ {x y : pgame} (hx : pgame.numeric x) (hy : pgame.numeric y), pgame.equiv x y → f x hx = f y hy) : surreal → α :=
  quotient.lift (fun (x : Subtype fun (x : pgame) => pgame.numeric x) => f (subtype.val x) sorry) sorry

/-- Lift a binary equivalence-respecting function on pre-games to surreals. -/
def lift₂ {α : Sort u_1} (f : (x : pgame) → (y : pgame) → pgame.numeric x → pgame.numeric y → α) (H : ∀ {x₁ : pgame} {y₁ : pgame} {x₂ : pgame} {y₂ : pgame} (ox₁ : pgame.numeric x₁) (oy₁ : pgame.numeric y₁)
  (ox₂ : pgame.numeric x₂) (oy₂ : pgame.numeric y₂),
  pgame.equiv x₁ x₂ → pgame.equiv y₁ y₂ → f x₁ y₁ ox₁ oy₁ = f x₂ y₂ ox₂ oy₂) : surreal → surreal → α :=
  lift (fun (x : pgame) (ox : pgame.numeric x) => lift (fun (y : pgame) (oy : pgame.numeric y) => f x y ox oy) sorry)
    sorry

/-- The relation `x ≤ y` on surreals. -/
def le : surreal → surreal → Prop :=
  lift₂ (fun (x y : pgame) (_x : pgame.numeric x) (_x : pgame.numeric y) => x ≤ y) sorry

/-- The relation `x < y` on surreals. -/
def lt : surreal → surreal → Prop :=
  lift₂ (fun (x y : pgame) (_x : pgame.numeric x) (_x : pgame.numeric y) => x < y) sorry

theorem not_le {x : surreal} {y : surreal} : ¬le x y ↔ lt y x := sorry

protected instance preorder : preorder surreal :=
  preorder.mk le lt sorry sorry

protected instance partial_order : partial_order surreal :=
  partial_order.mk preorder.le preorder.lt preorder.le_refl preorder.le_trans sorry

protected instance linear_order : linear_order surreal :=
  linear_order.mk partial_order.le partial_order.lt partial_order.le_refl partial_order.le_trans partial_order.le_antisymm
    sorry (classical.dec_rel LessEq) Mathlib.decidable_eq_of_decidable_le Mathlib.decidable_lt_of_decidable_le

/-- Addition on surreals is inherited from pre-game addition:
the sum of `x = {xL | xR}` and `y = {yL | yR}` is `{xL + y, x + yL | xR + y, x + yR}`. -/
def add : surreal → surreal → surreal :=
  lift₂
    (fun (x y : pgame) (ox : pgame.numeric x) (oy : pgame.numeric y) =>
      quotient.mk { val := x + y, property := pgame.numeric_add ox oy })
    sorry

protected instance has_add : Add surreal :=
  { add := add }

theorem add_assoc (x : surreal) (y : surreal) (z : surreal) : x + y + z = x + (y + z) := sorry

protected instance add_semigroup : add_semigroup surreal :=
  add_semigroup.mk Add.add add_assoc


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

/-!
# Schröder-Bernstein theorem, well-ordering of cardinals

This file proves the Schröder-Bernstein theorem (see `schroeder_bernstein`), the well-ordering of
cardinals (see `min_injective`) and the totality of their order (see `total`).

## Notes

Cardinals are naturally ordered by `α ≤ β ↔ ∃ f : a → β, injective f`:
* `schroeder_bernstein` states that, given injections `α → β` and `β → α`, one can get a
  bijection `α → β`. This corresponds to the antisymmetry of the order.
* The order is also well-founded: any nonempty set of cardinals has a minimal element.
  `min_injective` states that by saying that there exists an element of the set that injects into
  all others.

Cardinals are defined and further developed in the file `set_theory.cardinal`.
-/

open set function
open_locale classical

universes u v

namespace function
namespace embedding

section antisymm
variables {α : Type u} {β : Type v}

/-- **The Schröder-Bernstein Theorem**:
Given injections `α → β` and `β → α`, we can get a bijection `α → β`. -/
theorem schroeder_bernstein {f : α → β} {g : β → α}
  (hf : function.injective f) (hg : function.injective g) : ∃ h : α → β, bijective h :=
begin
  casesI is_empty_or_nonempty β with hβ hβ,
  { haveI : is_empty α, from function.is_empty f,
    exact ⟨_, ((equiv.equiv_empty α).trans (equiv.equiv_empty β).symm).bijective⟩ },
  set F : set α →ₘ set α :=
  { to_fun := λ s, (g '' (f '' s)ᶜ)ᶜ,
    monotone' := λ s t hst, compl_subset_compl.mpr $ image_subset _ $
     compl_subset_compl.mpr $ image_subset _ hst },
  set s : set α := F.lfp,
  have hs : (g '' (f '' s)ᶜ)ᶜ = s, from F.map_lfp,
  have hns : g '' (f '' s)ᶜ = sᶜ, from compl_injective (by simp [hs]),
  set g' := inv_fun g,
  have g'g : left_inverse g' g, from left_inverse_inv_fun hg,
  have hg'ns : g' '' sᶜ = (f '' s)ᶜ, by rw [← hns, g'g.image_image],
  set h : α → β := s.piecewise f g',
  have : surjective h, by rw [← range_iff_surjective, range_piecewise, hg'ns, union_compl_self],
  have : injective h,
  { refine (injective_piecewise_iff _).2 ⟨hf.inj_on _, _, _⟩,
    { intros x hx y hy hxy,
      obtain ⟨x', hx', rfl⟩ : x ∈ g '' (f '' s)ᶜ, by rwa hns,
      obtain ⟨y', hy', rfl⟩ : y ∈ g '' (f '' s)ᶜ, by rwa hns,
      rw [g'g _, g'g _] at hxy, rw hxy },
    { intros x hx y hy hxy,
      obtain ⟨y', hy', rfl⟩ : y ∈ g '' (f '' s)ᶜ, by rwa hns,
      rw [g'g _] at hxy,
      exact hy' ⟨x, hx, hxy⟩ } },
  exact ⟨h, ‹injective h›, ‹surjective h›⟩
end

/-- **The Schröder-Bernstein Theorem**: Given embeddings `α ↪ β` and `β ↪ α`, there exists an
equivalence `α ≃ β`. -/
theorem antisymm : (α ↪ β) → (β ↪ α) → nonempty (α ≃ β)
| ⟨e₁, h₁⟩ ⟨e₂, h₂⟩ :=
  let ⟨f, hf⟩ := schroeder_bernstein h₁ h₂ in
  ⟨equiv.of_bijective f hf⟩

end antisymm

section wo
parameters {ι : Type u} {β : ι → Type v}

@[reducible] private def sets := {s : set (∀ i, β i) |
  ∀ (x ∈ s) (y ∈ s) i, (x : ∀ i, β i) i = y i → x = y}

/-- The cardinals are well-ordered. We express it here by the fact that in any set of cardinals
there is an element that injects into the others. See `cardinal.linear_order` for (one of) the
lattice instance. -/
theorem min_injective (I : nonempty ι) : ∃ i, nonempty (∀ j, β i ↪ β j) :=
let ⟨s, hs, ms⟩ := show ∃ s ∈ sets, ∀ a ∈ sets, s ⊆ a → a = s, from
  zorn.zorn_subset sets (λ c hc hcc, ⟨⋃₀ c,
    λ x ⟨p, hpc, hxp⟩ y ⟨q, hqc, hyq⟩ i hi, (hcc.total hpc hqc).elim
      (λ h, hc hqc x (h hxp) y hyq i hi) (λ h, hc hpc x hxp y (h hyq) i hi),
  λ _, subset_sUnion_of_mem⟩) in
let ⟨i, e⟩ := show ∃ i, ∀ y, ∃ x ∈ s, (x : ∀ i, β i) i = y, from
  classical.by_contradiction $ λ h,
  have h : ∀ i, ∃ y, ∀ x ∈ s, (x : ∀ i, β i) i ≠ y,
    by simpa only [not_exists, not_forall] using h,
  let ⟨f, hf⟩ := classical.axiom_of_choice h in
  have f ∈ s, from
    have insert f s ∈ sets := λ x hx y hy, begin
      cases hx; cases hy, {simp [hx, hy]},
      { subst x, exact λ i e, (hf i y hy e.symm).elim },
      { subst y, exact λ i e, (hf i x hx e).elim },
      { exact hs x hx y hy }
    end, ms _ this (subset_insert f s) ▸ mem_insert _ _,
  let ⟨i⟩ := I in hf i f this rfl in
let ⟨f, hf⟩ := classical.axiom_of_choice e in
⟨i, ⟨λ j, ⟨λ a, f a j, λ a b e',
  let ⟨sa, ea⟩ := hf a, ⟨sb, eb⟩ := hf b in
  by rw [← ea, ← eb, hs _ sa _ sb _ e']⟩⟩⟩

end wo

/-- The cardinals are totally ordered. See `cardinal.linear_order` for (one of) the lattice
instance. -/
theorem total {α : Type u} {β : Type v} : nonempty (α ↪ β) ∨ nonempty (β ↪ α) :=
match @min_injective bool (λ b, cond b (ulift α) (ulift.{(max u v) v} β)) ⟨tt⟩ with
| ⟨tt, ⟨h⟩⟩ := let ⟨f, hf⟩ := h ff in or.inl ⟨embedding.congr equiv.ulift equiv.ulift ⟨f, hf⟩⟩
| ⟨ff, ⟨h⟩⟩ := let ⟨f, hf⟩ := h tt in or.inr ⟨embedding.congr equiv.ulift equiv.ulift ⟨f, hf⟩⟩
end

end embedding
end function


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import ring_theory.localization
import data.equiv.transfer_instance
import group_theory.submonoid.pointwise
import ring_theory.nilpotent

/-!
# Local properties of commutative rings

In this file, we provide the proofs of various local properties.

## Naming Conventions

* `localization_P` : `P` holds for `S⁻¹R` if `P` holds for `R`.
* `P_of_localization_maximal` : `P` holds for `R` if `P` holds for `Aₘ` for all maximal `m`.
* `P_of_localization_span` : `P` holds for `R` if given a spanning set `{fᵢ}`, `P` holds for all
  `A_{fᵢ}`.

## Main results

The following properties are covered:

* The triviality of an ideal or an element:
  `ideal_eq_zero_of_localization`, `eq_zero_of_localization`
* `is_reduced` : `localization_is_reduced`, `is_reduced_of_localization_maximal`.
* `finite`: `localization_finite`, `finite_of_localization_span`
* `finite_type`: `localization_finite_type`, `finite_type_of_localization_span`

-/

open_locale pointwise classical big_operators

universe u

variables {R S : Type u} [comm_ring R] [comm_ring S] (M : submonoid R)
variables (N : submonoid S) (R' S' : Type u) [comm_ring R'] [comm_ring S'] (f : R →+* S)
variables [algebra R R'] [algebra S S']

section properties

section comm_ring

variable (P : ∀ (R : Type u) [comm_ring R], Prop)

include P

/-- A property `P` of comm rings is said to be preserved by localization
  if `P` holds for `M⁻¹R` whenever `P` holds for `R`. -/
def localization_preserves : Prop :=
  ∀ {R : Type u} [hR : comm_ring R] (M : by exactI submonoid R) (S : Type u) [hS : comm_ring S]
    [by exactI algebra R S] [by exactI is_localization M S], @P R hR → @P S hS

/-- A property `P` of comm rings satisfies `of_localization_maximal` if
  if `P` holds for `R` whenever `P` holds for `Rₘ` for all maximal ideal `m`. -/
def of_localization_maximal : Prop :=
  ∀ (R : Type u) [comm_ring R],
    by exactI (∀ (J : ideal R) (hJ : J.is_maximal), by exactI P (localization.at_prime J)) → P R

end comm_ring

section ring_hom

variable (P : ∀ {R S : Type u} [comm_ring R] [comm_ring S] (f : by exactI R →+* S), Prop)

include P

/-- A property `P` of ring homs is said to be preserved by localization
 if `P` holds for `M⁻¹R →+* M⁻¹S` whenever `P` holds for `R →+* S`. -/
def ring_hom.localization_preserves :=
  ∀ {R S : Type u} [comm_ring R] [comm_ring S] (f : by exactI R →+* S) (M : by exactI submonoid R)
    (R' S' : Type u) [comm_ring R'] [comm_ring S'] [by exactI algebra R R']
    [by exactI algebra S S'] [by exactI is_localization M R']
    [by exactI is_localization (M.map (f : R →* S)) S'],
    by exactI (P f → P (is_localization.map S' f (submonoid.le_comap_map M) : R' →+* S'))

/-- A property `P` of ring homs satisfies `ring_hom.of_localization_finite_span`
if `P` holds for `R →+* S` whenever there exists a finite set `{ r }` that spans `R` such that
`P` holds for `Rᵣ →+* Sᵣ`.

Note that this is equivalent to `ring_hom.of_localization_span` via
`ring_hom.of_localization_span_iff_finite`, but this is easier to prove. -/
def ring_hom.of_localization_finite_span :=
  ∀ {R S : Type u} [comm_ring R] [comm_ring S] (f : by exactI R →+* S)
    (s : finset R) (hs : by exactI ideal.span (s : set R) = ⊤)
    (H : by exactI (∀ (r : s), P (localization.away_map f r))), by exactI P f

/-- A property `P` of ring homs satisfies `ring_hom.of_localization_finite_span`
if `P` holds for `R →+* S` whenever there exists a set `{ r }` that spans `R` such that
`P` holds for `Rᵣ →+* Sᵣ`.

Note that this is equivalent to `ring_hom.of_localization_finite_span` via
`ring_hom.of_localization_span_iff_finite`, but this has less restrictions when applying. -/
def ring_hom.of_localization_span :=
  ∀ {R S : Type u} [comm_ring R] [comm_ring S] (f : by exactI R →+* S)
    (s : set R) (hs : by exactI ideal.span s = ⊤)
    (H : by exactI (∀ (r : s), P (localization.away_map f r))), by exactI P f

lemma ring_hom.of_localization_span_iff_finite :
  ring_hom.of_localization_span @P ↔ ring_hom.of_localization_finite_span @P :=
begin
  delta ring_hom.of_localization_span ring_hom.of_localization_finite_span,
  apply forall₅_congr, -- TODO: Using `refine` here breaks `resetI`.
  introsI,
  split,
  { intros h s, exact h s },
  { intros h s hs hs',
    obtain ⟨s', h₁, h₂⟩ := (ideal.span_eq_top_iff_finite s).mp hs,
    exact h s' h₂ (λ x, hs' ⟨_, h₁ x.prop⟩) }
end

variables {P f R' S'}

-- Almost all arguments are implicit since this is not intended to use mid-proof.
lemma ring_hom.localization_away_of_localization_preserves
  (H : ring_hom.localization_preserves @P) {r : R} [is_localization.away r R']
  [is_localization.away (f r) S'] (hf : P f) :
    P (by exactI is_localization.away.map R' S' f r) :=
begin
  resetI,
  haveI : is_localization ((submonoid.powers r).map (f : R →* S)) S',
  { rw submonoid.map_powers, assumption },
  exact H f (submonoid.powers r) R' S' hf,
end

end ring_hom

end properties

section ideal

-- This proof should work for all modules, but we do not know how to localize a module yet.
/-- An ideal is trivial if its localization at every maximal ideal is trivial. -/
lemma ideal_eq_zero_of_localization (I : ideal R)
   (h : ∀ (J : ideal R) (hJ : J.is_maximal),
      by exactI is_localization.coe_submodule (localization.at_prime J) I = 0) : I = 0 :=
begin
  by_contradiction hI,
  obtain ⟨x, hx, hx'⟩ := set.exists_of_ssubset (bot_lt_iff_ne_bot.mpr hI),
  rw [submodule.bot_coe, set.mem_singleton_iff] at hx',
  have H : (ideal.span ({x} : set R)).annihilator ≠ ⊤,
  { rw [ne.def, submodule.annihilator_eq_top_iff],
    by_contra,
    apply hx',
    rw [← set.mem_singleton_iff, ← @submodule.bot_coe R, ← h],
    exact ideal.subset_span (set.mem_singleton x) },
  obtain ⟨p, hp₁, hp₂⟩ := ideal.exists_le_maximal _ H,
  resetI,
  specialize h p hp₁,
  have : algebra_map R (localization.at_prime p) x = 0,
  { rw ← set.mem_singleton_iff,
    change algebra_map R (localization.at_prime p) x ∈ (0 : submodule R (localization.at_prime p)),
    rw ← h,
    exact submodule.mem_map_of_mem hx },
  rw is_localization.map_eq_zero_iff p.prime_compl at this,
  obtain ⟨m, hm⟩ := this,
  apply m.prop,
  refine hp₂ _,
  erw submodule.mem_annihilator_span_singleton,
  rwa mul_comm at hm,
end

lemma eq_zero_of_localization (r : R)
   (h : ∀ (J : ideal R) (hJ : J.is_maximal),
      by exactI algebra_map R (localization.at_prime J) r = 0) : r = 0 :=
begin
  rw ← ideal.span_singleton_eq_bot,
  apply ideal_eq_zero_of_localization,
  intros J hJ,
  delta is_localization.coe_submodule,
  erw [submodule.map_span, submodule.span_eq_bot],
  rintro _ ⟨_, h', rfl⟩,
  cases set.mem_singleton_iff.mpr h',
  exact h J hJ,
end

end ideal

section reduced

lemma localization_is_reduced : localization_preserves (λ R hR, by exactI is_reduced R) :=
begin
  introv R _ _,
  resetI,
  constructor,
  rintro x ⟨(_|n), e⟩,
  { simpa using congr_arg (*x) e },
  obtain ⟨⟨y, m⟩, hx⟩ := is_localization.surj M x,
  dsimp only at hx,
  let hx' := congr_arg (^ n.succ) hx,
  simp only [mul_pow, e, zero_mul, ← ring_hom.map_pow] at hx',
  rw [← (algebra_map R S).map_zero] at hx',
  obtain ⟨m', hm'⟩ := (is_localization.eq_iff_exists M S).mp hx',
  apply_fun (*m'^n) at hm',
  simp only [mul_assoc, zero_mul] at hm',
  rw [mul_comm, ← pow_succ, ← mul_pow] at hm',
  replace hm' := is_nilpotent.eq_zero ⟨_, hm'.symm⟩,
  rw [← (is_localization.map_units S m).mul_left_inj, hx, zero_mul,
    is_localization.map_eq_zero_iff M],
  exact ⟨m', by rw [← hm', mul_comm]⟩
end

instance [is_reduced R] : is_reduced (localization M) := localization_is_reduced M _ infer_instance

lemma is_reduced_of_localization_maximal :
  of_localization_maximal (λ R hR, by exactI is_reduced R) :=
begin
  introv R h,
  constructor,
  intros x hx,
  apply eq_zero_of_localization,
  intros J hJ,
  specialize h J hJ,
  resetI,
  exact (hx.map $ algebra_map R $ localization.at_prime J).eq_zero,
end

end reduced

section finite

/-- If `S` is a finite `R`-algebra, then `S' = M⁻¹S` is a finite `R' = M⁻¹R`-algebra. -/
lemma localization_finite : ring_hom.localization_preserves @ring_hom.finite :=
begin
  introv R hf,
  -- Setting up the `algebra` and `is_scalar_tower` instances needed
  classical,
  letI := f.to_algebra,
  letI := ((algebra_map S S').comp f).to_algebra,
  let f' : R' →+* S' := is_localization.map S' f (submonoid.le_comap_map M),
  letI := f'.to_algebra,
  haveI : is_scalar_tower R R' S' :=
    is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,
  let fₐ : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S') (λ c x, ring_hom.map_mul _ _ _),

  -- We claim that if `S` is generated by `T` as an `R`-module,
  -- then `S'` is generated by `T` as an `R'`-module.
  unfreezingI { obtain ⟨T, hT⟩ := hf },
  use T.image (algebra_map S S'),
  rw eq_top_iff,
  rintro x -,

  -- By the hypotheses, for each `x : S'`, we have `x = y / (f r)` for some `y : S` and `r : M`.
  -- Since `S` is generated by `T`, the image of `y` should fall in the span of the image of `T`.
  obtain ⟨y, ⟨_, ⟨r, hr, rfl⟩⟩, rfl⟩ := is_localization.mk'_surjective (M.map (f : R →* S)) x,
  rw [is_localization.mk'_eq_mul_mk'_one, mul_comm, finset.coe_image],
  have hy : y ∈ submodule.span R ↑T, by { rw hT, trivial },
  replace hy : algebra_map S S' y ∈ submodule.map fₐ.to_linear_map (submodule.span R T) :=
    submodule.mem_map_of_mem hy,
  rw submodule.map_span fₐ.to_linear_map T at hy,
  have H : submodule.span R ((algebra_map S S') '' T) ≤
    (submodule.span R' ((algebra_map S S') '' T)).restrict_scalars R,
  { rw submodule.span_le, exact submodule.subset_span },

  -- Now, since `y ∈ span T`, and `(f r)⁻¹ ∈ R'`, `x / (f r)` is in `span T` as well.
  convert (submodule.span R' ((algebra_map S S') '' T)).smul_mem
    (is_localization.mk' R' (1 : R) ⟨r, hr⟩) (H hy) using 1,
  rw algebra.smul_def,
  erw is_localization.map_mk',
  rw map_one,
  refl,
end

lemma localization_away_map_finite (r : R) [is_localization.away r R']
  [is_localization.away (f r) S'] (hf : f.finite) :
    (is_localization.away.map R' S' f r).finite :=
ring_hom.localization_away_of_localization_preserves @localization_finite hf

/--
Let `S` be an `R`-algebra, `M` an submonoid of `R`, and `S' = M⁻¹S`.
If the image of some `x : S` falls in the span of some finite `s ⊆ S'` over `R`,
then there exists some `m : M` such that `m • x` falls in the
span of `finset_integer_multiple _ s` over `R`.
-/
lemma is_localization.smul_mem_finset_integer_multiple_span [algebra R S]
  [algebra R S'] [is_scalar_tower R S S']
  [is_localization (M.map (algebra_map R S : R →* S)) S'] (x : S)
  (s : finset S') (hx : algebra_map S S' x ∈ submodule.span R (s : set S')) :
    ∃ m : M, m • x ∈ submodule.span R
      (is_localization.finset_integer_multiple (M.map (algebra_map R S : R →* S)) s : set S) :=
begin
  let g : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S')
    (λ c x, by simp [algebra.algebra_map_eq_smul_one]),

  -- We first obtain the `y' ∈ M` such that `s' = y' • s` is falls in the image of `S` in `S'`.
  let y := is_localization.common_denom_of_finset (M.map (algebra_map R S : R →* S)) s,
  have hx₁ : (y : S) • ↑s = g '' _ := (is_localization.finset_integer_multiple_image _ s).symm,
  obtain ⟨y', hy', e : algebra_map R S y' = y⟩ := y.prop,
  have : algebra_map R S y' • (s : set S') = y' • s :=
    by simp_rw [algebra.algebra_map_eq_smul_one, smul_assoc, one_smul],
  rw [← e, this] at hx₁,
  replace hx₁ := congr_arg (submodule.span R) hx₁,
  rw submodule.span_smul_eq at hx₁,
  replace hx : _ ∈ y' • submodule.span R (s : set S') := set.smul_mem_smul_set hx,
  rw hx₁ at hx,
  erw [← g.map_smul, ← submodule.map_span (g : S →ₗ[R] S')] at hx,
  -- Since `x` falls in the span of `s` in `S'`, `y' • x : S` falls in the span of `s'` in `S'`.
  -- That is, there exists some `x' : S` in the span of `s'` in `S` and `x' = y' • x` in `S'`.
  -- Thus `a • (y' • x) = a • x' ∈ span s'` in `S` for some `a ∈ M`.
  obtain ⟨x', hx', hx'' : algebra_map _ _ _ = _⟩ := hx,
  obtain ⟨⟨_, a, ha₁, rfl⟩, ha₂⟩ := (is_localization.eq_iff_exists
    (M.map (algebra_map R S : R →* S)) S').mp hx'',
  use (⟨a, ha₁⟩ : M) * (⟨y', hy'⟩ : M),
  convert (submodule.span R (is_localization.finset_integer_multiple
    (submonoid.map (algebra_map R S : R →* S) M) s : set S)).smul_mem a hx' using 1,
  convert ha₂.symm,
  { rw [mul_comm (y' • x), subtype.coe_mk, submonoid.smul_def, submonoid.coe_mul, ← smul_smul],
    exact algebra.smul_def _ _ },
  { rw mul_comm, exact algebra.smul_def _ _ }
end

/-- If `S` is an `R' = M⁻¹R` algebra, and `x ∈ span R' s`,
then `t • x ∈ span R s` for some `t : M`.-/
lemma multiple_mem_span_of_mem_localization_span [algebra R' S] [algebra R S]
  [is_scalar_tower R R' S] [is_localization M R']
  (s : set S) (x : S) (hx : x ∈ submodule.span R' s) :
    ∃ t : M, t • x ∈ submodule.span R s :=
begin
  classical,
  obtain ⟨s', hss', hs'⟩ := submodule.mem_span_finite_of_mem_span hx,
  suffices : ∃ t : M, t • x ∈ submodule.span R (s' : set S),
  { obtain ⟨t, ht⟩ := this,
    exact ⟨t, submodule.span_mono hss' ht⟩ },
  clear hx hss' s,
  revert x,
  apply s'.induction_on,
  { intros x hx, use 1, simpa using hx },
  rintros a s ha hs x hx,
  simp only [finset.coe_insert, finset.image_insert, finset.coe_image, subtype.coe_mk,
    submodule.mem_span_insert] at hx ⊢,
  rcases hx with ⟨y, z, hz, rfl⟩,
  rcases is_localization.surj M y with ⟨⟨y', s'⟩, e⟩,
  replace e : _ * a = _ * a := (congr_arg (λ x, algebra_map R' S x * a) e : _),
  simp_rw [ring_hom.map_mul, ← is_scalar_tower.algebra_map_apply, mul_comm (algebra_map R' S y),
    mul_assoc, ← algebra.smul_def] at e,
  rcases hs _ hz with ⟨t, ht⟩,
  refine ⟨t*s', t*y', _, (submodule.span R (s : set S)).smul_mem s' ht, _⟩,
  rw [smul_add, ← smul_smul, mul_comm, ← smul_smul, ← smul_smul, ← e],
  refl,
end

/-- If `S` is an `R' = M⁻¹R` algebra, and `x ∈ adjoin R' s`,
then `t • x ∈ adjoin R s` for some `t : M`.-/
lemma multiple_mem_adjoin_of_mem_localization_adjoin [algebra R' S] [algebra R S]
  [is_scalar_tower R R' S] [is_localization M R']
  (s : set S) (x : S) (hx : x ∈ algebra.adjoin R' s) :
    ∃ t : M, t • x ∈ algebra.adjoin R s :=
begin
  change ∃ (t : M), t • x ∈ (algebra.adjoin R s).to_submodule,
  change x ∈ (algebra.adjoin R' s).to_submodule at hx,
  simp_rw [algebra.adjoin_eq_span] at hx ⊢,
  exact multiple_mem_span_of_mem_localization_span M R' _ _ hx
end

lemma finite_of_localization_span : ring_hom.of_localization_span @ring_hom.finite :=
begin
  rw ring_hom.of_localization_span_iff_finite,
  introv R hs H,
  -- We first setup the instances
  classical,
  letI := f.to_algebra,
  letI := λ (r : s), (localization.away_map f r).to_algebra,
  haveI : ∀ r : s, is_localization ((submonoid.powers (r : R)).map (algebra_map R S : R →* S))
    (localization.away (f r)),
  { intro r, rw submonoid.map_powers, exact localization.is_localization },
  haveI : ∀ r : s, is_scalar_tower R (localization.away (r : R)) (localization.away (f r)) :=
    λ r, is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,

  -- By the hypothesis, we may find a finite generating set for each `Sᵣ`. This set can then be
  -- lifted into `R` by multiplying a sufficiently large power of `r`. I claim that the union of
  -- these generates `S`.
  constructor,
  replace H := λ r, (H r).1,
  choose s₁ s₂ using H,
  let sf := λ (x : s), is_localization.finset_integer_multiple (submonoid.powers (f x)) (s₁ x),
  use s.attach.bUnion sf,
  rw [submodule.span_attach_bUnion, eq_top_iff],

  -- It suffices to show that `r ^ n • x ∈ span T` for each `r : s`, since `{ r ^ n }` spans `R`.
  -- This then follows from the fact that each `x : R` is a linear combination of the generating set
  -- of `Sᵣ`. By multiplying a sufficiently large power of `r`, we can cancel out the `r`s in the
  -- denominators of both the generating set and the coefficients.
  rintro x -,
  apply submodule.mem_of_span_eq_top_of_smul_pow_mem _ (s : set R) hs _ _,
  intro r,
  obtain ⟨⟨_, n₁, rfl⟩, hn₁⟩ := multiple_mem_span_of_mem_localization_span
    (submonoid.powers (r : R)) (localization.away (r : R)) (s₁ r : set (localization.away (f r)))
      (algebra_map S _ x) (by { rw s₂ r, trivial }),
  rw [submonoid.smul_def, algebra.smul_def, is_scalar_tower.algebra_map_apply R S,
    subtype.coe_mk, ← map_mul] at hn₁,
  obtain ⟨⟨_, n₂, rfl⟩, hn₂⟩ := is_localization.smul_mem_finset_integer_multiple_span
    (submonoid.powers (r : R)) (localization.away (f r)) _ (s₁ r) hn₁,
  rw [submonoid.smul_def, ← algebra.smul_def, smul_smul, subtype.coe_mk, ← pow_add] at hn₂,
  use n₂ + n₁,
  refine le_supr (λ (x : s), submodule.span R (sf x : set S)) r _,
  change _ ∈ submodule.span R
    ((is_localization.finset_integer_multiple _ (s₁ r) : finset S) : set S),
  convert hn₂,
  rw submonoid.map_powers, refl,
end

end finite

section finite_type

lemma localization_finite_type : ring_hom.localization_preserves @ring_hom.finite_type :=
begin
  introv R hf,
  -- mirrors the proof of `localization_map_finite`
  classical,
  letI := f.to_algebra,
  letI := ((algebra_map S S').comp f).to_algebra,
  let f' : R' →+* S' := is_localization.map S' f (submonoid.le_comap_map M),
  letI := f'.to_algebra,
  haveI : is_scalar_tower R R' S' :=
    is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,
  let fₐ : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S') (λ c x, ring_hom.map_mul _ _ _),

  obtain ⟨T, hT⟩ := id hf,
  use T.image (algebra_map S S'),
  rw eq_top_iff,
  rintro x -,
  obtain ⟨y, ⟨_, ⟨r, hr, rfl⟩⟩, rfl⟩ := is_localization.mk'_surjective (M.map (f : R →* S)) x,
  rw [is_localization.mk'_eq_mul_mk'_one, mul_comm, finset.coe_image],
  have hy : y ∈ algebra.adjoin R (T : set S), by { rw hT, trivial },
  replace hy : algebra_map S S' y ∈ (algebra.adjoin R (T : set S)).map fₐ :=
    subalgebra.mem_map.mpr ⟨_, hy, rfl⟩,
  rw fₐ.map_adjoin T at hy,
  have H : algebra.adjoin R ((algebra_map S S') '' T) ≤
    (algebra.adjoin R' ((algebra_map S S') '' T)).restrict_scalars R,
  { rw algebra.adjoin_le_iff, exact algebra.subset_adjoin },
  convert (algebra.adjoin R' ((algebra_map S S') '' T)).smul_mem (H hy)
    (is_localization.mk' R' (1 : R) ⟨r, hr⟩) using 1,
  rw algebra.smul_def,
  erw is_localization.map_mk',
  rw map_one,
  refl,
end

lemma localization_away_map_finite_type (r : R) [is_localization.away r R']
  [is_localization.away (f r) S'] (hf : f.finite_type) :
    (is_localization.away.map R' S' f r).finite_type :=
ring_hom.localization_away_of_localization_preserves @localization_finite_type hf

/--
Let `S` be an `R`-algebra, `M` an submonoid of `R`, and `S' = M⁻¹S`.
If the image of some `x : S` falls in the adjoin of some finite `s ⊆ S'` over `R`,
then there exists some `m : M` such that `m • x` falls in the
adjoin of `finset_integer_multiple _ s` over `R`.
-/
lemma is_localization.lift_mem_adjoin_finset_integer_multiple [algebra R S]
  [algebra R S'] [is_scalar_tower R S S']
  [is_localization (M.map (algebra_map R S : R →* S)) S'] (x : S)
  (s : finset S') (hx : algebra_map S S' x ∈ algebra.adjoin R (s : set S')) :
    ∃ m : M, m • x ∈ algebra.adjoin R
      (is_localization.finset_integer_multiple (M.map (algebra_map R S : R →* S)) s : set S) :=
begin
  -- mirrors the proof of `is_localization.smul_mem_finset_integer_multiple_span`
  let g : S →ₐ[R] S' := alg_hom.mk' (algebra_map S S')
    (λ c x, by simp [algebra.algebra_map_eq_smul_one]),

  let y := is_localization.common_denom_of_finset (M.map (algebra_map R S : R →* S)) s,
  have hx₁ : (y : S) • ↑s = g '' _ := (is_localization.finset_integer_multiple_image _ s).symm,
  obtain ⟨y', hy', e : algebra_map R S y' = y⟩ := y.prop,
  have : algebra_map R S y' • (s : set S') = y' • s :=
    by simp_rw [algebra.algebra_map_eq_smul_one, smul_assoc, one_smul],
  rw [← e, this] at hx₁,
  replace hx₁ := congr_arg (algebra.adjoin R) hx₁,
  obtain ⟨n, hn⟩ := algebra.pow_smul_mem_adjoin_smul _ y' (s : set S') hx,
  specialize hn n (le_of_eq rfl),
  erw [hx₁, ← g.map_smul, ← g.map_adjoin] at hn,
  obtain ⟨x', hx', hx''⟩ := hn,
  obtain ⟨⟨_, a, ha₁, rfl⟩, ha₂⟩ := (is_localization.eq_iff_exists
    (M.map (algebra_map R S : R →* S)) S').mp hx'',
  use (⟨a, ha₁⟩ : M) * (⟨y', hy'⟩ : M) ^ n,
  convert (algebra.adjoin R (is_localization.finset_integer_multiple
    (submonoid.map (algebra_map R S : R →* S) M) s : set S)).smul_mem hx' a using 1,
  convert ha₂.symm,
  { rw [mul_comm (y' ^ n • x), subtype.coe_mk, submonoid.smul_def, submonoid.coe_mul, ← smul_smul,
    algebra.smul_def, submonoid.coe_pow], refl },
  { rw mul_comm, exact algebra.smul_def _ _ }
end

lemma finite_type_of_localization_span : ring_hom.of_localization_span @ring_hom.finite_type :=
begin
  rw ring_hom.of_localization_span_iff_finite,
  introv R hs H,
  -- mirrors the proof of `finite_of_localization_span`
  classical,
  letI := f.to_algebra,
  letI := λ (r : s), (localization.away_map f r).to_algebra,
  haveI : ∀ r : s, is_localization ((submonoid.powers (r : R)).map (algebra_map R S : R →* S))
    (localization.away (f r)),
  { intro r, rw submonoid.map_powers, exact localization.is_localization },
  haveI : ∀ r : s, is_scalar_tower R (localization.away (r : R)) (localization.away (f r)) :=
    λ r, is_scalar_tower.of_algebra_map_eq' (is_localization.map_comp _).symm,

  constructor,
  replace H := λ r, (H r).1,
  choose s₁ s₂ using H,
  let sf := λ (x : s), is_localization.finset_integer_multiple (submonoid.powers (f x)) (s₁ x),
  use s.attach.bUnion sf,
  convert (algebra.adjoin_attach_bUnion sf).trans _,
  rw eq_top_iff,
  rintro x -,
  apply (⨆ (x : s), algebra.adjoin R (sf x : set S)).to_submodule
    .mem_of_span_eq_top_of_smul_pow_mem _ hs _ _,
  intro r,
  obtain ⟨⟨_, n₁, rfl⟩, hn₁⟩ := multiple_mem_adjoin_of_mem_localization_adjoin
    (submonoid.powers (r : R)) (localization.away (r : R)) (s₁ r : set (localization.away (f r)))
      (algebra_map S (localization.away (f r)) x) (by { rw s₂ r, trivial }),
  rw [submonoid.smul_def, algebra.smul_def, is_scalar_tower.algebra_map_apply R S,
    subtype.coe_mk, ← map_mul] at hn₁,
  obtain ⟨⟨_, n₂, rfl⟩, hn₂⟩ := is_localization.lift_mem_adjoin_finset_integer_multiple
    (submonoid.powers (r : R)) (localization.away (f r)) _ (s₁ r) hn₁,
  rw [submonoid.smul_def, ← algebra.smul_def, smul_smul, subtype.coe_mk, ← pow_add] at hn₂,
  use n₂ + n₁,
  refine le_supr (λ (x : s), algebra.adjoin R (sf x : set S)) r _,
  change _ ∈ algebra.adjoin R
    ((is_localization.finset_integer_multiple _ (s₁ r) : finset S) : set S),
  convert hn₂,
  rw submonoid.map_powers,
  refl,
end

end finite_type


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.products.basic

/-!
# Lemmas about functors out of product categories.
-/

open category_theory

namespace category_theory.bifunctor

universes v₁ v₂ v₃ u₁ u₂ u₃
variables {C : Type u₁} {D : Type u₂} {E : Type u₃}
variables [category.{v₁} C] [category.{v₂} D] [category.{v₃} E]

@[simp] lemma map_id (F : (C × D) ⥤ E) (X : C) (Y : D) :
  F.map ((𝟙 X, 𝟙 Y) : (X, Y) ⟶ (X, Y)) = 𝟙 (F.obj (X, Y)) :=
F.map_id (X, Y)

@[simp] lemma map_id_comp (F : (C × D) ⥤ E) (W : C) {X Y Z : D} (f : X ⟶ Y) (g : Y ⟶ Z) :
  F.map ((𝟙 W, f ≫ g) : (W, X) ⟶ (W, Z)) =
  F.map ((𝟙 W, f) : (W, X) ⟶ (W, Y)) ≫ F.map ((𝟙 W, g) : (W, Y) ⟶ (W, Z)) :=
by rw [←functor.map_comp,prod_comp,category.comp_id]

@[simp] lemma map_comp_id (F : (C × D) ⥤ E) (X Y Z : C) (W : D) (f : X ⟶ Y) (g : Y ⟶ Z) :
  F.map ((f ≫ g, 𝟙 W) : (X, W) ⟶ (Z, W)) =
  F.map ((f, 𝟙 W) : (X, W) ⟶ (Y, W)) ≫ F.map ((g, 𝟙 W) : (Y, W) ⟶ (Z, W)) :=
by rw [←functor.map_comp,prod_comp,category.comp_id]

@[simp] lemma diagonal (F : (C × D) ⥤ E) (X X' : C) (f : X ⟶ X') (Y Y' : D) (g : Y ⟶ Y') :
  F.map ((𝟙 X, g) : (X, Y) ⟶ (X, Y')) ≫ F.map ((f, 𝟙 Y') : (X, Y') ⟶ (X', Y')) =
  F.map ((f, g) : (X, Y) ⟶ (X', Y')) :=
by rw [←functor.map_comp, prod_comp, category.id_comp, category.comp_id]

@[simp] lemma diagonal' (F : (C × D) ⥤ E) (X X' : C) (f : X ⟶ X') (Y Y' : D) (g : Y ⟶ Y') :
  F.map ((f, 𝟙 Y) : (X, Y) ⟶ (X', Y)) ≫ F.map ((𝟙 X', g) : (X', Y) ⟶ (X', Y')) =
  F.map ((f, g) : (X, Y) ⟶ (X', Y')) :=
by rw [←functor.map_comp, prod_comp, category.id_comp, category.comp_id]

end category_theory.bifunctor


import .sum_over .nat_util
section add_group

lemma {u} add_group.ident_unique
  {G : Type u} [add_group G]
  (e : G) (h : ∀ x, x + e = x) : e = 0 :=
  eq.trans (eq.symm (zero_add e)) (h 0)

lemma {u} add_group.inv_unique
  {G : Type u} [add_group G]
  (x x' : G) (h : x' + x = 0) : x' = -x :=
  iff.mp (@sub_eq_zero_iff_eq _ _ x' (-x))
    $ eq.symm (sub_neg_eq_add x' x) ▸ h

lemma {u} add_group.eq_zero_of_add_eq_self
  {G : Type u} [add_group G]
  {x : G} (h : x + x = x) : x = 0 :=
  add_left_cancel $ eq.trans h (eq.symm $ add_zero x)

@[reducible]
def {u v} add_group.is_homomorphism
  {G : Type u} {H : Type v} [add_group G] [add_group H]
  (ψ : G → H)
  := ∀ g g', ψ (g + g') = ψ g + ψ g'

lemma {u v} add_group.homomorphism_preserves_zero
  {G : Type u} {H : Type v} [add_group G] [add_group H]
  (ψ : G → H) (h : add_group.is_homomorphism ψ)
  : ψ 0 = 0 :=
begin
  apply @add_left_cancel _ _ (ψ 0),
  rw ← h, rw add_zero, rw add_zero
end

lemma {u v} add_group.homomorphism_preserves_neg
  {G : Type u} {H : Type v} [add_group G] [add_group H]
  (ψ : G → H) (h : add_group.is_homomorphism ψ)
  : ∀ g, ψ (- g) = - (ψ g) :=
begin
  intro, apply @add_left_cancel _ _ (ψ g),
  transitivity add_group.zero H,
  rw ← h, rw add_right_neg,
  apply add_group.homomorphism_preserves_zero _ h,
  rw add_right_neg, refl
end

def {u v} kernel {G : Type u} {H : Type v} [add_group H]
  (ψ : G → H) := { g : G | ψ g = 0 }

lemma {u v} ker_trivial_imp_inj
  {G : Type u} {H : Type v} [add_group G] [add_group H]
  (ψ : G → H) (h : add_group.is_homomorphism ψ) :
  (∀ g, ψ g = 0 → g = 0) → function.injective ψ :=
begin
  intros ker_triv x y hxy,
  have : ψ (x - y) = 0 :=
    calc ψ (x - y) = ψ (x + -y) : by rw sub_eq_add_neg
                ... = ψ x + ψ (-y) : h x (-y)
                ... = ψ x + -(ψ y) : by rw add_group.homomorphism_preserves_neg ψ h
                ... = ψ x + -(ψ x) : by rw hxy
                ... = 0 : by rw [← sub_eq_add_neg, sub_self],
  have : x - y = 0 := ker_triv _ this,
  rw ← sub_eq_zero_iff_eq, assumption
end

lemma {u v} inj_iff_ker_trivial
  {G : Type u} {H : Type v} [add_group G] [add_group H]
  (ψ : G → H) (h : add_group.is_homomorphism ψ) :
  function.injective ψ ↔ kernel ψ = { g : G | g = 0 } :=
begin
  constructor,
  { dunfold function.injective, intros ψ_inj,
    have : ∀ y, ψ y = 0 → y = 0,
    { intros, apply ψ_inj, rw a, symmetry,
      apply add_group.homomorphism_preserves_zero _ h },
    dsimp [kernel],
    funext, apply propext, constructor; intro h',
    { exact this _ h' },
    { rw (_ : g = 0),
      apply add_group.homomorphism_preserves_zero _ h,
      assumption } },
  { intros ker_triv, apply ker_trivial_imp_inj _ h,
    intros g h, rw (_ : ψ g = 0 ↔ g ∈ kernel ψ) at h,
    rw ker_triv at h, exact h, refl }
end

end add_group

section monoid

@[reducible]
def {u} mul_n_times {M : Type u} [monoid M] : M → ℕ → M
| m 0     := 1
| m (n+1) := mul_n_times m n * m

section
universe u
instance monoid.pow {M : Type u} [monoid M] : has_pow M nat := ⟨mul_n_times⟩
end

lemma {u} monoid.exp_zero {M : Type u} [monoid M] (m : M)
  : m^0 = 1 := rfl

lemma {u} power_of_prod {M : Type u} [comm_monoid M]
  : ∀ (x y : M) (n : nat), (x * y)^n = x^n * y^n :=
begin
  intros, induction n; simp [(^), mul_n_times] at *,
  rw n_ih, ac_refl,
end

lemma {u} power_of_one {M : Type u} [monoid M]
  : ∀ (n : nat), 1^n = (1 : M) :=
by intros; induction n; simp [(^), mul_n_times] at *; rw n_ih

lemma {u} monoid.pow_of_sum_eq_mul {M : Type u} [monoid M]
  : ∀ (x : M) (n m : nat), x ^ (n+m) = x^n * x^m :=
begin
  intros, induction m with m ih;
  simp [(^), monoid.pow, mul_n_times] at *,
  rw nat.add_succ, dsimp [mul_n_times], rw ih,
  rw mul_assoc
end

lemma {u} monoid.pow_step_left {M : Type u} [monoid M]
  : ∀ (x : M) (n : nat), x ^ nat.succ n = x * x^n :=
begin
  intros, have : x = x^1, simp [(^), mul_n_times],
  transitivity x^1 * x^n,
  rw [this, ← monoid.pow_of_sum_eq_mul, nat.add_comm],
  congr, symmetry, assumption
end

lemma {u} exp_of_prod {M : Type u} [monoid M]
  : ∀ (b : M) (n m : nat), b ^ (n*m) = (b^n)^m :=
begin
  intros, induction m with m ih;
  simp [(^), mul_n_times], simp [(^)] at ih,
  rw ← ih, rw [nat.mul_succ],
  transitivity b^(n * m + n), refl,
  rw monoid.pow_of_sum_eq_mul, refl,
end

lemma {u} comm_with_pow_if_comm {M : Type u} [monoid M]
  : ∀ (x y : M) (n : ℕ), x * y = y * x → x^n * y = y * x^n :=
begin
  simp [(^)], intros x y n comm,
  induction n with n ih, simp [mul_n_times],
  transitivity mul_n_times x n * x * y, refl,
  rw [mul_assoc, comm, ← mul_assoc, ih, mul_assoc]
end

lemma {u} pows_comm_if_comm {M : Type u} [monoid M]
  : ∀ (x y : M) (n m : ℕ), x * y = y * x → x^n * y^m = y^m * x^n :=
begin
  simp [(^)], intros x y n m comm,
  induction m with m ih,
  simp [mul_n_times],
  transitivity (mul_n_times x  n *  mul_n_times y m) * y, rw mul_assoc,
  have := comm_with_pow_if_comm x y _ comm, dsimp [(^)] at this,
  rw [ih, mul_assoc, this, ← mul_assoc]
end

lemma {u} monoid.ident_unique
  {M : Type u} [monoid M]
  (e : M) (h : ∀ x, x * e = x) : e = 1 :=
  eq.trans (eq.symm (one_mul e)) (h 1)

@[reducible]
def {u v} monoid.is_homomorphism
  {M : Type u} {M' : Type v} [monoid M] [monoid M']
  (ψ : M → M')
  := (∀ x y, ψ (x * y) = ψ x * ψ y) ∧ ψ 1 = 1

end monoid

section semiring

def {u} semiring.embed_nat
  {R : Type u} [semiring R] : nat → R
| 0     := 0
| (n+1) := semiring.embed_nat n + 1

lemma {u} semiring.embed_zero
  {R : Type u} [semiring R]
  : (semiring.embed_nat 0 : R) = 0 := rfl

lemma {u} semiring.embed_one
  {R : Type u} [semiring R]
  : (semiring.embed_nat 1 : R) = 1 :=
by intros; dsimp [semiring.embed_nat]; rw zero_add

lemma {u} semiring.embed_nat_sum
  {R : Type u} [semiring R]
  : ∀ (n m : nat),
    (semiring.embed_nat (n + m) : R)
  = semiring.embed_nat n + semiring.embed_nat m :=
begin
  intros, induction m with m ih,
  simp, rw [semiring.embed_zero, add_zero],
  rw nat.add_succ, dsimp [semiring.embed_nat],
  rw [← add_assoc, ih],
end

lemma {u} semiring.embed_nat_comm
  {R : Type u} [semiring R]
  : ∀ (x : R) n, x * semiring.embed_nat n
               = semiring.embed_nat n * x :=
begin
  intros, induction n with n ih;
  simp [semiring.embed_nat],
  rw [left_distrib, right_distrib], apply congr,
  rw ih, simp
end

def {u} binomial_expansion {R : Type u} [semiring R] : R → R → nat → R :=
λ x y n, sum_over (λ k : fin (n+1), semiring.embed_nat (binomial_coefficient n k.val) * x^k.val * y^(n - k.val))

lemma {u} binomial_theorem.helper1 {R : Type u} [semiring R]
  : ∀ (x y : R) n, x * binomial_expansion x y n
                 = sum_over (λ k : fin n, semiring.embed_nat (binomial_coefficient n k.val) * x^(k.val+1) * y^(n - k.val)) + x^(n+1) :=
begin
  intros, dsimp [binomial_expansion],
  rw mul_sum_over_left, rw [sum_over.step],
  apply congr,
  { apply congr_arg, congr, funext, cases k with k hk,
    simp [fin.restrict], rw [← mul_assoc x, ← mul_assoc x],
    rw semiring.embed_nat_comm, rw mul_assoc _ x,
    rw ← comm_with_pow_if_comm x x k rfl, refl },
  { simp, rw binomial_coefficient_self,
    simp [semiring.embed_nat], rw nat.sub_self,
    rw (_ : y^0 = 1), rw mul_one,
    rw ← comm_with_pow_if_comm x x n rfl,
    refl, refl }
end

lemma {u} binomial_theorem.helper2 {R : Type u} [semiring R]
  : ∀ (x y : R) n, x * y = y *x
  → y * binomial_expansion x y n
  = y^(n+1) + sum_over (λ k : fin n, semiring.embed_nat (binomial_coefficient n (k.val + 1)) * x^(k.val+1) * y^(n - k.val)) :=
begin
  intros x y n comm, dsimp [binomial_expansion],
  rw mul_sum_over_left, rw [sum_over.step_front],
  apply congr,
  { apply congr_arg, simp, rw binomial_coefficient_zero,
    simp [semiring.embed_nat],
    rw (_ : x^0 = 1), rw one_mul,
    rw ← comm_with_pow_if_comm y y n rfl,
    refl, refl },
  { congr, funext k, cases k with k hk,
    simp [fin.restrict],
    rw [← mul_assoc y, ← mul_assoc y],
    rw semiring.embed_nat_comm, rw mul_assoc _ y,
    rw ← comm_with_pow_if_comm x y (k+1) comm,
    rw mul_assoc, rw mul_assoc,
    rw [(_ : y * y ^ (n - nat.succ k) = y^(n-k)), mul_assoc],
    rw ← comm_with_pow_if_comm y y (n - nat.succ k) rfl,
    transitivity y ^(n - (nat.succ k) + 1), refl,
    apply congr_arg, transitivity nat.succ n- nat.succ k,
    rw [add_comm, ← nat.add_sub_assoc hk],
    congr, rw nat.one_add,
    rw [← nat.add_one, ← nat.add_one, nat.add_sub_add_right] },
end

lemma {u} binomial_theorem.helper3 {R : Type u} [semiring R]
  : ∀ (x y : R) n,
  binomial_expansion x y (n + 1)
  = x^(n+1) + sum_over (λ k : fin n, semiring.embed_nat (binomial_coefficient (n+1) (k.val + 1)) * x^(k.val+1) * y^(n - k.val)) + y^(n+1) :=
begin
  intros,
  dsimp [binomial_expansion],
  rw sum_over.step, simp,
  apply congr,
  { apply congr_arg, rw binomial_coefficient_self,
    rw [semiring.embed_one, one_mul, nat.sub_self],
    rw [monoid.exp_zero, mul_one] },
  rw sum_over.step_front,
  congr,
  { simp [fin.restrict], rw binomial_coefficient_zero,
    rw [semiring.embed_one, monoid.exp_zero], simp },
  funext k, simp [fin.restrict]
end

theorem {u} binomial_theorem {R : Type u} [semiring R]
  : ∀ x y : R, x * y = y * x
  → ∀ n, (x + y)^n = binomial_expansion x y n :=
begin
  intros x y comm n, induction n with n ih,
  { simp [(^), mul_n_times, binomial_expansion],
    dsimp [sum_over, sum_over], rw zero_add,
    simp [binomial_coefficient, mul_n_times, semiring.embed_nat] },
  rw [monoid.pow_step_left, right_distrib, ih],
  rw [binomial_theorem.helper1 x y n, binomial_theorem.helper2 x y n comm],
  transitivity (x^(n+1) +
                ((sum_over (λ (k : fin n), semiring.embed_nat (binomial_coefficient n (k.val)) * x ^ (k.val + 1) * y ^ (n - k.val)) +
                  sum_over
                   (λ (k : fin n),
                     semiring.embed_nat (binomial_coefficient n (k.val + 1)) * x ^ (k.val + 1) * y ^ (n - k.val)))
                     + y ^ (n + 1))),
  { rw [add_comm _ (x^(n+1)), add_comm (y^(n+1)) _],
    rw [add_assoc, add_assoc] },
  rw ← sum_over_sum,
  rw (_ : (λ (k : fin n),
              semiring.embed_nat (binomial_coefficient n (k.val)) * x ^ (k.val + 1) * y ^ (n - k.val) +
                semiring.embed_nat (binomial_coefficient n (k.val + 1)) * x ^ (k.val + 1) * y ^ (n - k.val))
        = (λ (k : fin n),
              semiring.embed_nat (binomial_coefficient (n +  1) (k.val + 1)) * x ^ (k.val + 1) * y ^ (n - k.val))),
  { rw [binomial_theorem.helper3, add_assoc] },
  funext, dsimp [binomial_coefficient],
  rw semiring.embed_nat_sum,
  rw [right_distrib, right_distrib, add_comm]
end

end semiring

section ring

lemma {u} FOIL {R : Type u} [ring R] : ∀ a b c d : R, (a + b) * (c + d) = a*c + a*d + b*c + b*d :=
by { intros, rw [left_distrib, right_distrib, right_distrib], ac_refl }

@[reducible]
def {u v} ring.is_homomorphism
  {R : Type u} {S : Type v} [ring R] [ring S]
  (ψ : R → S) := add_group.is_homomorphism ψ
               ∧ monoid.is_homomorphism ψ

@[reducible]
def {u v} ring.is_ismorphism
  {R : Type u} {S : Type v} [ring R] [ring S]
  (ψ : R → S) := ring.is_homomorphism ψ
               ∧ (∃ ψ', ring.is_homomorphism ψ'
                      ∧ ψ ∘ ψ' = id
                      ∧ ψ' ∘ ψ = id)

lemma {u v} classical.ring.bijective_homomorphism_is_isomorphism
  {R : Type u} {S : Type v} [ring R] [ring S]
  (ψ : R → S) : function.bijective ψ
              → ring.is_homomorphism ψ
              → ring.is_ismorphism ψ :=
begin
  intros h h', cases h with ψ_i ψ_s,
  dsimp [ring.is_ismorphism], constructor,
  assumption,
  cases classical.axiom_of_choice ψ_s with ψ',
  simp at h,
  have : ∀ x, ψ' (ψ x) = x,
  { intro x, apply ψ_i, apply h },
  existsi ψ', constructor,
  { constructor,
    { intros x y, rw [← h x, ← h y],
      rw ← h'.left, repeat { rw this } },
    constructor,
    { intros x y, rw [← h x, ← h y],
      rw ← h'.right.left, repeat { rw this } },
    { transitivity ψ' (ψ 1), congr, symmetry,
      exact h'.right.right, rw this } },
  { constructor; apply funext; assumption }
end

definition {u v} ring.isomorphic
  (R : Type u) (S : Type v) [ring R] [ring S]
  := ∃ ψ : R → S, ring.is_ismorphism ψ

infix ` ≅ `:50 := ring.isomorphic

@[symm]
lemma {u v} ring.isomorphic_symm
  (R : Type u) (S : Type v) [ring R] [ring S]
  : R ≅ S → S ≅ R
| ⟨ψ, ⟨h, ⟨ψ', ⟨h', k⟩⟩⟩⟩ := ⟨ψ', ⟨h', ⟨ψ, ⟨h, and.symm k⟩⟩⟩⟩

def {u} neg_of_add {R : Type u} [ring R]
  (a b : R) : -(a + b) = -a + - b :=
begin
  rw [neg_eq_neg_one_mul, left_distrib],
  congr; rw ← neg_eq_neg_one_mul
end

def {u} elephant {R : Type u} [ring R]
  (a b : R) (n) :=
  sum_over (λ j : fin (n + 1), a^(n-j.val)*b^j.val)

lemma {u} elephant_teacup.helper1 {R : Type u} [ring R]
  (a b : R) (n) :
    elephant a b (n + 1)
    = a^(n+1) + (elephant a b n) * b :=
begin
  dsimp [elephant], rw sum_over.step_front,
  apply congr, { apply congr_arg, simp, apply mul_one },
  simp, rw mul_sum_over_right, congr, funext,
  rw mul_assoc, refl
end

lemma {u} elephant_teacup.helper2 {R : Type u} [ring R]
  (a b : R) (n) : elephant a b (n+1)
                = a * (elephant a b n) + b^(n+1) :=
begin
  dsimp [elephant], rw sum_over.step,
  apply congr,
  { congr, rw mul_sum_over_left, congr,
    dsimp [fin.restrict], funext,
    rw ← mul_assoc, congr, rw (_ : n + 1 - k.val = (n - k.val) + 1),
    { rw [nat.add_comm, monoid.pow_of_sum_eq_mul],
      congr, simp [(^), mul_n_times] },
    { cases k, simp, rw nat.add_comm n 1,
      rw nat.add_sub_assoc, apply nat.le_of_succ_le_succ k_is_lt } },
  simp, rw nat.sub_self n, simp [(^), mul_n_times]
end

lemma {u} elephant_teacup.helper3 {R : Type u} [ring R]
  (a b : R) (n) : a * b = b * a →
    b * elephant a b n
    = elephant a b n * b :=
begin
  intros h, induction n with n ih,
  { simp [elephant, sum_over,  (^), mul_n_times] },
  simp [elephant], rw [mul_sum_over_left, mul_sum_over_right],
  congr, funext,
  rw [← mul_assoc, ← comm_with_pow_if_comm a b _ h],
  rw mul_assoc, rw mul_assoc, apply congr_arg,
  rw comm_with_pow_if_comm, refl,
end

def {u} elephant_teacup {R : Type u} [ring R]
  (a b : R) (n) : a * b = b * a →
      a^(nat.succ (nat.succ n)) - b^(nat.succ (nat.succ n))
    = (a - b) * elephant a b (nat.succ n) :=
begin
  intros comm, rw mul_sub_right_distrib,
  transitivity a * (a^(n+1) + (elephant a b n) * b) - b * elephant a b (nat.succ n),
  rw elephant_teacup.helper2,
  { rw [left_distrib, left_distrib],
    rw [← elephant_teacup.helper3  _ _ _ comm, ← mul_assoc, ← mul_assoc],
    rw [← comm, sub_add_eq_sub_sub],
    rw [add_sub_assoc, sub_self, add_zero],
    congr, transitivity a ^ n.succ * a, refl,
    rw comm_with_pow_if_comm, refl,
    transitivity b ^ n.succ * b, refl,
    rw comm_with_pow_if_comm, refl },
  rw elephant_teacup.helper1
end

end ring


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

! This file was ported from Lean 3 source module group_theory.submonoid.centralizer
! leanprover-community/mathlib commit baba818b9acea366489e8ba32d2cc0fcaf50a1f7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.Subsemigroup.Centralizer
import Mathbin.GroupTheory.Submonoid.Center

/-!
# Centralizers of magmas and monoids

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

## Main definitions

* `submonoid.centralizer`: the centralizer of a subset of a monoid
* `add_submonoid.centralizer`: the centralizer of a subset of an additive monoid

We provide `subgroup.centralizer`, `add_subgroup.centralizer` in other files.
-/

variable {M : Type _} {S T : Set M}

namespace Submonoid

section

variable [Monoid M] (S)

#print Submonoid.centralizer /-
/-- The centralizer of a subset of a monoid `M`. -/
@[to_additive "The centralizer of a subset of an additive monoid."]
def centralizer : Submonoid M where
  carrier := S.centralizer
  one_mem' := S.one_mem_centralizer
  mul_mem' a b := Set.mul_mem_centralizer
#align submonoid.centralizer Submonoid.centralizer
#align add_submonoid.centralizer AddSubmonoid.centralizer
-/

/- warning: submonoid.coe_centralizer -> Submonoid.coe_centralizer is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} (S : Set.{u1} M) [_inst_1 : Monoid.{u1} M], Eq.{succ u1} (Set.{u1} M) ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Set.{u1} M) (HasLiftT.mk.{succ u1, succ u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Set.{u1} M) (CoeTCₓ.coe.{succ u1, succ u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Set.{u1} M) (SetLike.Set.hasCoeT.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.setLike.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))))) (Submonoid.centralizer.{u1} M S _inst_1)) (Set.centralizer.{u1} M S (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)))
but is expected to have type
  forall {M : Type.{u1}} (S : Set.{u1} M) [_inst_1 : Monoid.{u1} M], Eq.{succ u1} (Set.{u1} M) (SetLike.coe.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.instSetLikeSubmonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Submonoid.centralizer.{u1} M S _inst_1)) (Set.centralizer.{u1} M S (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)))
Case conversion may be inaccurate. Consider using '#align submonoid.coe_centralizer Submonoid.coe_centralizerₓ'. -/
@[simp, norm_cast, to_additive]
theorem coe_centralizer : ↑(centralizer S) = S.centralizer :=
  rfl
#align submonoid.coe_centralizer Submonoid.coe_centralizer
#align add_submonoid.coe_centralizer AddSubmonoid.coe_centralizer

/- warning: submonoid.centralizer_to_subsemigroup -> Submonoid.centralizer_toSubsemigroup is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} (S : Set.{u1} M) [_inst_1 : Monoid.{u1} M], Eq.{succ u1} (Subsemigroup.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) (Submonoid.toSubsemigroup.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1) (Submonoid.centralizer.{u1} M S _inst_1)) (Subsemigroup.centralizer.{u1} M S (Monoid.toSemigroup.{u1} M _inst_1))
but is expected to have type
  forall {M : Type.{u1}} (S : Set.{u1} M) [_inst_1 : Monoid.{u1} M], Eq.{succ u1} (Subsemigroup.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) (Submonoid.toSubsemigroup.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1) (Submonoid.centralizer.{u1} M S _inst_1)) (Subsemigroup.centralizer.{u1} M S (Monoid.toSemigroup.{u1} M _inst_1))
Case conversion may be inaccurate. Consider using '#align submonoid.centralizer_to_subsemigroup Submonoid.centralizer_toSubsemigroupₓ'. -/
theorem centralizer_toSubsemigroup : (centralizer S).toSubsemigroup = Subsemigroup.centralizer S :=
  rfl
#align submonoid.centralizer_to_subsemigroup Submonoid.centralizer_toSubsemigroup

/- warning: add_submonoid.centralizer_to_add_subsemigroup -> AddSubmonoid.centralizer_toAddSubsemigroup is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} [_inst_2 : AddMonoid.{u1} M] (S : Set.{u1} M), Eq.{succ u1} (AddSubsemigroup.{u1} M (AddZeroClass.toHasAdd.{u1} M (AddMonoid.toAddZeroClass.{u1} M _inst_2))) (AddSubmonoid.toAddSubsemigroup.{u1} M (AddMonoid.toAddZeroClass.{u1} M _inst_2) (AddSubmonoid.centralizer.{u1} M S _inst_2)) (AddSubsemigroup.centralizer.{u1} M S (AddMonoid.toAddSemigroup.{u1} M _inst_2))
but is expected to have type
  forall {M : Type.{u1}} [_inst_2 : AddMonoid.{u1} M] (S : Set.{u1} M), Eq.{succ u1} (AddSubsemigroup.{u1} M (AddZeroClass.toAdd.{u1} M (AddMonoid.toAddZeroClass.{u1} M _inst_2))) (AddSubmonoid.toAddSubsemigroup.{u1} M (AddMonoid.toAddZeroClass.{u1} M _inst_2) (AddSubmonoid.centralizer.{u1} M S _inst_2)) (AddSubsemigroup.centralizer.{u1} M S (AddMonoid.toAddSemigroup.{u1} M _inst_2))
Case conversion may be inaccurate. Consider using '#align add_submonoid.centralizer_to_add_subsemigroup AddSubmonoid.centralizer_toAddSubsemigroupₓ'. -/
theorem AddSubmonoid.centralizer_toAddSubsemigroup {M} [AddMonoid M] (S : Set M) :
    (AddSubmonoid.centralizer S).toAddSubsemigroup = AddSubsemigroup.centralizer S :=
  rfl
#align add_submonoid.centralizer_to_add_subsemigroup AddSubmonoid.centralizer_toAddSubsemigroup

attribute [to_additive AddSubmonoid.centralizer_toAddSubsemigroup]
  Submonoid.centralizer_toSubsemigroup

variable {S}

/- warning: submonoid.mem_centralizer_iff -> Submonoid.mem_centralizer_iff is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {S : Set.{u1} M} [_inst_1 : Monoid.{u1} M] {z : M}, Iff (Membership.Mem.{u1, u1} M (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (SetLike.hasMem.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.setLike.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) z (Submonoid.centralizer.{u1} M S _inst_1)) (forall (g : M), (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) g S) -> (Eq.{succ u1} M (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) g z) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) z g)))
but is expected to have type
  forall {M : Type.{u1}} {S : Set.{u1} M} [_inst_1 : Monoid.{u1} M] {z : M}, Iff (Membership.mem.{u1, u1} M (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (SetLike.instMembership.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.instSetLikeSubmonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) z (Submonoid.centralizer.{u1} M S _inst_1)) (forall (g : M), (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) g S) -> (Eq.{succ u1} M (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) g z) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) z g)))
Case conversion may be inaccurate. Consider using '#align submonoid.mem_centralizer_iff Submonoid.mem_centralizer_iffₓ'. -/
@[to_additive]
theorem mem_centralizer_iff {z : M} : z ∈ centralizer S ↔ ∀ g ∈ S, g * z = z * g :=
  Iff.rfl
#align submonoid.mem_centralizer_iff Submonoid.mem_centralizer_iff
#align add_submonoid.mem_centralizer_iff AddSubmonoid.mem_centralizer_iff

/- warning: submonoid.decidable_mem_centralizer -> Submonoid.decidableMemCentralizer is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {S : Set.{u1} M} [_inst_1 : Monoid.{u1} M] (a : M) [_inst_2 : Decidable (forall (b : M), (Membership.Mem.{u1, u1} M (Set.{u1} M) (Set.hasMem.{u1} M) b S) -> (Eq.{succ u1} M (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) b a) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toHasMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) a b)))], Decidable (Membership.Mem.{u1, u1} M (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (SetLike.hasMem.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.setLike.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) a (Submonoid.centralizer.{u1} M S _inst_1))
but is expected to have type
  forall {M : Type.{u1}} {S : Set.{u1} M} [_inst_1 : Monoid.{u1} M] (a : M) [_inst_2 : Decidable (forall (b : M), (Membership.mem.{u1, u1} M (Set.{u1} M) (Set.instMembershipSet.{u1} M) b S) -> (Eq.{succ u1} M (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) b a) (HMul.hMul.{u1, u1, u1} M M M (instHMul.{u1} M (MulOneClass.toMul.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) a b)))], Decidable (Membership.mem.{u1, u1} M (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (SetLike.instMembership.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.instSetLikeSubmonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))) a (Submonoid.centralizer.{u1} M S _inst_1))
Case conversion may be inaccurate. Consider using '#align submonoid.decidable_mem_centralizer Submonoid.decidableMemCentralizerₓ'. -/
@[to_additive]
instance decidableMemCentralizer (a) [Decidable <| ∀ b ∈ S, b * a = a * b] :
    Decidable (a ∈ centralizer S) :=
  decidable_of_iff' _ mem_centralizer_iff
#align submonoid.decidable_mem_centralizer Submonoid.decidableMemCentralizer
#align add_submonoid.decidable_mem_centralizer AddSubmonoid.decidableMemCentralizer

/- warning: submonoid.centralizer_le -> Submonoid.centralizer_le is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {S : Set.{u1} M} {T : Set.{u1} M} [_inst_1 : Monoid.{u1} M], (HasSubset.Subset.{u1} (Set.{u1} M) (Set.hasSubset.{u1} M) S T) -> (LE.le.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Preorder.toLE.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (PartialOrder.toPreorder.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (SetLike.partialOrder.{u1, u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) M (Submonoid.setLike.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1))))) (Submonoid.centralizer.{u1} M T _inst_1) (Submonoid.centralizer.{u1} M S _inst_1))
but is expected to have type
  forall {M : Type.{u1}} {S : Set.{u1} M} {T : Set.{u1} M} [_inst_1 : Monoid.{u1} M], (HasSubset.Subset.{u1} (Set.{u1} M) (Set.instHasSubsetSet.{u1} M) S T) -> (LE.le.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Preorder.toLE.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (PartialOrder.toPreorder.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (CompleteSemilatticeInf.toPartialOrder.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (CompleteLattice.toCompleteSemilatticeInf.{u1} (Submonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)) (Submonoid.instCompleteLatticeSubmonoid.{u1} M (Monoid.toMulOneClass.{u1} M _inst_1)))))) (Submonoid.centralizer.{u1} M T _inst_1) (Submonoid.centralizer.{u1} M S _inst_1))
Case conversion may be inaccurate. Consider using '#align submonoid.centralizer_le Submonoid.centralizer_leₓ'. -/
@[to_additive]
theorem centralizer_le (h : S ⊆ T) : centralizer T ≤ centralizer S :=
  Set.centralizer_subset h
#align submonoid.centralizer_le Submonoid.centralizer_le
#align add_submonoid.centralizer_le AddSubmonoid.centralizer_le

variable (M)

#print Submonoid.centralizer_univ /-
@[simp, to_additive]
theorem centralizer_univ : centralizer Set.univ = center M :=
  SetLike.ext' (Set.centralizer_univ M)
#align submonoid.centralizer_univ Submonoid.centralizer_univ
#align add_submonoid.centralizer_univ AddSubmonoid.centralizer_univ
-/

end

end Submonoid

-- Guard against import creep
assert_not_exists Finset


/-
Copyright (c) 2021 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.Data.Fin.Basic

/-- A max-heap data structure. -/
structure BinaryHeap (α) (lt : α → α → Bool) where
  arr : Array α

namespace BinaryHeap

/-- Core operation for binary heaps, expressed directly on arrays.
Given an array which is a max-heap, push item `i` down to restore the max-heap property. -/
def heapifyDown (lt : α → α → Bool) (a : Array α) (i : Fin a.size) :
  {a' : Array α // a'.size = a.size} :=
  let left := 2 * i.1 + 1
  let right := left + 1
  have left_le : i ≤ left := Nat.le_trans
    (by rw [Nat.succ_mul, Nat.one_mul]; exact Nat.le_add_left i i)
    (Nat.le_add_right ..)
  have right_le : i ≤ right := Nat.le_trans left_le (Nat.le_add_right ..)
  have i_le : i ≤ i := Nat.le_refl _
  have j : {j : Fin a.size // i ≤ j} := if h : left < a.size then
    if lt (a.get i) (a.get ⟨left, h⟩) then ⟨⟨left, h⟩, left_le⟩ else ⟨i, i_le⟩ else ⟨i, i_le⟩
  have j := if h : right < a.size then
    if lt (a.get j) (a.get ⟨right, h⟩) then ⟨⟨right, h⟩, right_le⟩ else j else j
  if h : i.1 = j then ⟨a, rfl⟩ else
    let a' := a.swap i j
    let j' := ⟨j, by rw [a.size_swap i j]; exact j.1.2⟩
    have : a'.size - j < a.size - i := by
      rw [a.size_swap i j]; exact Nat.sub_lt_sub_left i.2 <| Nat.lt_of_le_of_ne j.2 h
    let ⟨a₂, h₂⟩ := heapifyDown lt a' j'
    ⟨a₂, h₂.trans (a.size_swap i j)⟩
termination_by _ => a.size - i
decreasing_by assumption

@[simp] theorem size_heapifyDown (lt : α → α → Bool) (a : Array α) (i : Fin a.size) :
  (heapifyDown lt a i).1.size = a.size := (heapifyDown lt a i).2

/-- Core operation for binary heaps, expressed directly on arrays.
Construct a heap from an unsorted array, by heapifying all the elements. -/
def mkHeap (lt : α → α → Bool) (a : Array α) : {a' : Array α // a'.size = a.size} :=
  let rec loop : (i : Nat) → (a : Array α) → i ≤ a.size → {a' : Array α // a'.size = a.size}
  | 0, a, _ => ⟨a, rfl⟩
  | i+1, a, h =>
    let h := Nat.lt_of_succ_le h
    let a' := heapifyDown lt a ⟨i, h⟩
    let ⟨a₂, h₂⟩ := loop i a' ((heapifyDown ..).2.symm ▸ le_of_lt h)
    ⟨a₂, h₂.trans a'.2⟩
  loop (a.size / 2) a (Nat.div_le_self ..)

@[simp] theorem size_mkHeap (lt : α → α → Bool) (a : Array α) :
  (mkHeap lt a).1.size = a.size := (mkHeap lt a).2

/-- Core operation for binary heaps, expressed directly on arrays.
Given an array which is a max-heap, push item `i` up to restore the max-heap property. -/
def heapifyUp (lt : α → α → Bool) (a : Array α) (i : Fin a.size) :
  {a' : Array α // a'.size = a.size} :=
if i0 : i.1 = 0 then ⟨a, rfl⟩ else
  have : (i.1 - 1) / 2 < i := lt_of_le_of_lt (Nat.div_le_self ..) $
    Nat.sub_lt (Nat.pos_iff_ne_zero.2 i0) Nat.one_pos
  let j := ⟨(i.1 - 1) / 2, lt_trans this i.2⟩
  if lt (a.get j) (a.get i) then
    let a' := a.swap i j
    let ⟨a₂, h₂⟩ := heapifyUp lt a' ⟨j.1, by rw [a.size_swap i j]; exact j.2⟩
    ⟨a₂, h₂.trans (a.size_swap i j)⟩
  else ⟨a, rfl⟩
termination_by _ => i.1
decreasing_by assumption

@[simp] theorem size_heapifyUp (lt : α → α → Bool) (a : Array α) (i : Fin a.size) :
  (heapifyUp lt a i).1.size = a.size := (heapifyUp lt a i).2

/-- `O(1)`. Build a new empty heap. -/
def empty (lt) : BinaryHeap α lt := ⟨#[]⟩

instance (lt) : Inhabited (BinaryHeap α lt) := ⟨empty _⟩
instance (lt) : EmptyCollection (BinaryHeap α lt) := ⟨empty _⟩

/-- `O(1)`. Build a one-element heap. -/
def singleton (lt) (x : α) : BinaryHeap α lt := ⟨#[x]⟩

/-- `O(1)`. Get the number of elements in a `BinaryHeap`. -/
def size {lt} (self : BinaryHeap α lt) : Nat := self.1.size

/-- `O(1)`. Get an element in the heap by index. -/
def get {lt} (self : BinaryHeap α lt) (i : Fin self.size) : α := self.1.get i

/-- `O(log n)`. Insert an element into a `BinaryHeap`, preserving the max-heap property. -/
def insert {lt} (self : BinaryHeap α lt) (x : α) : BinaryHeap α lt where
  arr := let n := self.size;
    heapifyUp lt (self.1.push x) ⟨n, by rw [Array.size_push]; apply Nat.lt_succ_self⟩

@[simp] theorem size_insert {lt} (self : BinaryHeap α lt) (x : α) :
  (self.insert x).size = self.size + 1 := by
  simp [insert, size, size_heapifyUp]

/-- `O(1)`. Get the maximum element in a `BinaryHeap`. -/
def max {lt} (self : BinaryHeap α lt) : Option α := self.1.get? 0

/-- Auxiliary for `popMax`. -/
def popMaxAux {lt} (self : BinaryHeap α lt) : {a' : BinaryHeap α lt // a'.size = self.size - 1} :=
  match e: self.1.size with
  | 0 => ⟨self, by simp [size, e]⟩
  | n+1 =>
    have h0 := by rw [e]; apply Nat.succ_pos
    have hn := by rw [e]; apply Nat.lt_succ_self
    if hn0 : 0 < n then
      let a := self.1.swap ⟨0, h0⟩ ⟨n, hn⟩ |>.pop
      ⟨⟨heapifyDown lt a ⟨0, by rwa [Array.size_pop, Array.size_swap, e]⟩⟩,
        by simp [size]⟩
    else
      ⟨⟨self.1.pop⟩, by simp [size]⟩

/-- `O(log n)`. Remove the maximum element from a `BinaryHeap`.
Call `max` first to actually retrieve the maximum element. -/
def popMax {lt} (self : BinaryHeap α lt) : BinaryHeap α lt := self.popMaxAux

@[simp] theorem size_popMax {lt} (self : BinaryHeap α lt) :
  self.popMax.size = self.size - 1 := self.popMaxAux.2

/-- `O(log n)`. Return and remove the maximum element from a `BinaryHeap`. -/
def extractMax {lt} (self : BinaryHeap α lt) : Option α × BinaryHeap α lt :=
  (self.max, self.popMax)

theorem size_pos_of_max {lt} {self : BinaryHeap α lt} (e : self.max = some x) : 0 < self.size :=
  Decidable.of_not_not fun h: ¬ 0 < self.1.size ↦ by simp [BinaryHeap.max, Array.get?, h] at e

/-- `O(log n)`. Equivalent to `extractMax (self.insert x)`, except that extraction cannot fail. -/
def insertExtractMax {lt} (self : BinaryHeap α lt) (x : α) : α × BinaryHeap α lt :=
  match e: self.max with
  | none => (x, self)
  | some m =>
    if lt x m then
      let a := self.1.set ⟨0, size_pos_of_max e⟩ x
      (m, ⟨heapifyDown lt a ⟨0, by simp; exact size_pos_of_max e⟩⟩)
    else (x, self)

/-- `O(log n)`. Equivalent to `(self.max, self.popMax.insert x)`. -/
def replaceMax {lt} (self : BinaryHeap α lt) (x : α) : Option α × BinaryHeap α lt :=
  match e: self.max with
  | none => (none, ⟨self.1.push x⟩)
  | some m =>
    let a := self.1.set ⟨0, size_pos_of_max e⟩ x
    (some m, ⟨heapifyDown lt a ⟨0, by simp; exact size_pos_of_max e⟩⟩)

/-- `O(log n)`. Replace the value at index `i` by `x`. Assumes that `x ≤ self.get i`. -/
def decreaseKey {lt} (self : BinaryHeap α lt) (i : Fin self.size) (x : α) : BinaryHeap α lt where
  arr := heapifyDown lt (self.1.set i x) ⟨i, by rw [self.1.size_set]; exact i.2⟩

/-- `O(log n)`. Replace the value at index `i` by `x`. Assumes that `self.get i ≤ x`. -/
def increaseKey {lt} (self : BinaryHeap α lt) (i : Fin self.size) (x : α) : BinaryHeap α lt where
  arr := heapifyUp lt (self.1.set i x) ⟨i, by rw [self.1.size_set]; exact i.2⟩

end BinaryHeap

/-- `O(n)`. Convert an unsorted array to a `BinaryHeap`. -/
def Array.toBinaryHeap (lt : α → α → Bool) (a : Array α) : BinaryHeap α lt where
  arr := BinaryHeap.mkHeap lt a

/-- `O(n log n)`. Sort an array using a `BinaryHeap`. -/
@[specialize] def Array.heapSort (a : Array α) (lt : α → α → Bool) : Array α :=
  let gt y x := lt x y
  let rec loop (a : BinaryHeap α gt) (out : Array α) : Array α :=
    match e: a.max with
    | none => out
    | some x =>
      have : a.popMax.size < a.size := by
        simp; exact Nat.sub_lt (BinaryHeap.size_pos_of_max e) Nat.zero_lt_one
      loop a.popMax (out.push x)
  loop (a.toBinaryHeap gt) #[]
termination_by _ => a.size
decreasing_by assumption