/-
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, Floris van Doorn
-/
import category_theory.eq_to_hom
import data.ulift

/-!
# Discrete categories

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

We define `discrete α` as a structure containing a term `a : α` for any type `α`,
and use this type alias to provide a `small_category` instance
whose only morphisms are the identities.

There is an annoying technical difficulty that it has turned out to be inconvenient
to allow categories with morphisms living in `Prop`,
so instead of defining `X ⟶ Y` in `discrete α` as `X = Y`,
one might define it as `plift (X = Y)`.
In fact, to allow `discrete α` to be a `small_category`
(i.e. with morphisms in the same universe as the objects),
we actually define the hom type `X ⟶ Y` as `ulift (plift (X = Y))`.

`discrete.functor` promotes a function `f : I → C` (for any category `C`) to a functor
`discrete.functor f : discrete I ⥤ C`.

Similarly, `discrete.nat_trans` and `discrete.nat_iso` promote `I`-indexed families of morphisms,
or `I`-indexed families of isomorphisms to natural transformations or natural isomorphism.

We show equivalences of types are the same as (categorical) equivalences of the corresponding
discrete categories.
-/

namespace category_theory

-- morphism levels before object levels. See note [category_theory universes].
universes v₁ v₂ v₃ u₁ u₁' u₂ u₃

/--
A wrapper for promoting any type to a category,
with the only morphisms being equalities.
-/
-- This is intentionally a structure rather than a type synonym
-- to enforce using `discrete_equiv` (or `discrete.mk` and `discrete.as`) to move between
-- `discrete α` and `α`. Otherwise there is too much API leakage.
@[ext] structure discrete (α : Type u₁) :=
(as : α)

@[simp] lemma discrete.mk_as {α : Type u₁} (X : discrete α) : discrete.mk X.as = X :=
by { ext, refl, }

/-- `discrete α` is equivalent to the original type `α`.-/
@[simps] def discrete_equiv {α : Type u₁} : discrete α ≃ α :=
{ to_fun := discrete.as,
  inv_fun := discrete.mk,
  left_inv := by tidy,
  right_inv := by tidy, }

instance {α : Type u₁} [decidable_eq α] : decidable_eq (discrete α) :=
discrete_equiv.decidable_eq

/--
The "discrete" category on a type, whose morphisms are equalities.

Because we do not allow morphisms in `Prop` (only in `Type`),
somewhat annoyingly we have to define `X ⟶ Y` as `ulift (plift (X = Y))`.

See <https://stacks.math.columbia.edu/tag/001A>
-/
instance discrete_category (α : Type u₁) : small_category (discrete α) :=
{ hom  := λ X Y, ulift (plift (X.as = Y.as)),
  id   := λ X, ulift.up (plift.up rfl),
  comp := λ X Y Z g f, by { cases X, cases Y, cases Z, rcases f with ⟨⟨⟨⟩⟩⟩, exact g } }

namespace discrete

variables {α : Type u₁}

instance [inhabited α] : inhabited (discrete α) :=
⟨⟨default⟩⟩

instance [subsingleton α] : subsingleton (discrete α) :=
⟨by { intros, ext, apply subsingleton.elim, }⟩

/-- A simple tactic to run `cases` on any `discrete α` hypotheses. -/
meta def _root_.tactic.discrete_cases : tactic unit :=
`[cases_matching* [discrete _, (_ : discrete _) ⟶ (_ : discrete _), plift _]]

run_cmd add_interactive [``tactic.discrete_cases]

local attribute [tidy] tactic.discrete_cases

instance [unique α] : unique (discrete α) :=
unique.mk' (discrete α)

/-- Extract the equation from a morphism in a discrete category. -/

/-- Promote an equation between the wrapped terms in `X Y : discrete α` to a morphism `X ⟶ Y`
in the discrete category. -/
abbreviation eq_to_hom {X Y : discrete α} (h : X.as = Y.as) : X ⟶ Y :=
eq_to_hom (by { ext, exact h, })

/-- Promote an equation between the wrapped terms in `X Y : discrete α` to an isomorphism `X ≅ Y`
in the discrete category. -/
abbreviation eq_to_iso {X Y : discrete α} (h : X.as = Y.as) : X ≅ Y :=
eq_to_iso (by { ext, exact h, })

/-- A variant of `eq_to_hom` that lifts terms to the discrete category. -/
abbreviation eq_to_hom' {a b : α} (h : a = b) : discrete.mk a ⟶ discrete.mk b :=
eq_to_hom h

/-- A variant of `eq_to_iso` that lifts terms to the discrete category. -/
abbreviation eq_to_iso' {a b : α} (h : a = b) : discrete.mk a ≅ discrete.mk b :=
eq_to_iso h

@[simp] lemma id_def (X : discrete α) : ulift.up (plift.up (eq.refl X.as)) = 𝟙 X := rfl

variables {C : Type u₂} [category.{v₂} C]

instance {I : Type u₁} {i j : discrete I} (f : i ⟶ j) : is_iso f :=
⟨⟨eq_to_hom (eq_of_hom f).symm, by tidy⟩⟩

/--
Any function `I → C` gives a functor `discrete I ⥤ C`.
-/
def functor {I : Type u₁} (F : I → C) : discrete I ⥤ C :=
{ obj := F ∘ discrete.as,
  map := λ X Y f, by { discrete_cases, cases f, exact 𝟙 (F X), } }

@[simp] lemma functor_obj  {I : Type u₁} (F : I → C) (i : I) :
  (discrete.functor F).obj (discrete.mk i) = F i := rfl

lemma functor_map  {I : Type u₁} (F : I → C) {i : discrete I} (f : i ⟶ i) :
  (discrete.functor F).map f = 𝟙 (F i.as) :=
by tidy

/--
The discrete functor induced by a composition of maps can be written as a
composition of two discrete functors.
-/
@[simps]
def functor_comp {I : Type u₁} {J : Type u₁'} (f : J → C) (g : I → J) :
  discrete.functor (f ∘ g) ≅ discrete.functor (discrete.mk ∘ g) ⋙ discrete.functor f :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

/--
For functors out of a discrete category,
a natural transformation is just a collection of maps,
as the naturality squares are trivial.
-/
@[simps]
def nat_trans {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ⟶ G.obj i) : F ⟶ G :=
{ app := f,
  naturality' := λ X Y g, by { discrete_cases, cases g, simp, } }

/--
For functors out of a discrete category,
a natural isomorphism is just a collection of isomorphisms,
as the naturality squares are trivial.
-/
@[simps]
def nat_iso {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) : F ≅ G :=
nat_iso.of_components f (λ X Y g, by { discrete_cases, cases g, simp, })

@[simp]
lemma nat_iso_app {I : Type u₁} {F G : discrete I ⥤ C}
  (f : Π i : discrete I, F.obj i ≅ G.obj i) (i : discrete I) :
  (discrete.nat_iso f).app i = f i :=
by tidy

/-- Every functor `F` from a discrete category is naturally isomorphic (actually, equal) to
  `discrete.functor (F.obj)`. -/
@[simp]
def nat_iso_functor {I : Type u₁} {F : discrete I ⥤ C} :
  F ≅ discrete.functor (F.obj ∘ discrete.mk) :=
nat_iso $ λ i, by { discrete_cases, refl, }

/-- Composing `discrete.functor F` with another functor `G` amounts to composing `F` with `G.obj` -/
@[simp]
def comp_nat_iso_discrete {I : Type u₁} {D : Type u₃} [category.{v₃} D]
 (F : I → C) (G : C ⥤ D) : discrete.functor F ⋙ G ≅ discrete.functor (G.obj ∘ F) :=
nat_iso $ λ i, iso.refl _

/--
We can promote a type-level `equiv` to
an equivalence between the corresponding `discrete` categories.
-/
@[simps]
def equivalence {I : Type u₁} {J : Type u₂} (e : I ≃ J) : discrete I ≌ discrete J :=
{ functor := discrete.functor (discrete.mk ∘ (e : I → J)),
  inverse := discrete.functor (discrete.mk ∘ (e.symm : J → I)),
  unit_iso := discrete.nat_iso (λ i, eq_to_iso (by { discrete_cases, simp })),
  counit_iso := discrete.nat_iso (λ j, eq_to_iso (by { discrete_cases, simp })), }

/-- We can convert an equivalence of `discrete` categories to a type-level `equiv`. -/
@[simps]
def equiv_of_equivalence {α : Type u₁} {β : Type u₂} (h : discrete α ≌ discrete β) : α ≃ β :=
{ to_fun := discrete.as ∘ h.functor.obj ∘ discrete.mk,
  inv_fun := discrete.as ∘ h.inverse.obj ∘ discrete.mk,
  left_inv := λ a, by simpa using eq_of_hom (h.unit_iso.app (discrete.mk a)).2,
  right_inv := λ a, by simpa using eq_of_hom (h.counit_iso.app (discrete.mk a)).1, }

end discrete

namespace discrete
variables {J : Type v₁}

open opposite

/-- A discrete category is equivalent to its opposite category. -/
@[simps functor_obj_as inverse_obj]
protected def opposite (α : Type u₁) : (discrete α)ᵒᵖ ≌ discrete α :=
let F : discrete α ⥤ (discrete α)ᵒᵖ := discrete.functor (λ x, op (discrete.mk x)) in
begin
  refine equivalence.mk (functor.left_op F) F _
    (discrete.nat_iso $ λ X, by { discrete_cases, simp [F] }),
  refine nat_iso.of_components (λ X, by { tactic.op_induction', discrete_cases, simp [F], }) _,
  tidy
end

variables {C : Type u₂} [category.{v₂} C]

@[simp] lemma functor_map_id
  (F : discrete J ⥤ C) {j : discrete J} (f : j ⟶ j) : F.map f = 𝟙 (F.obj j) :=
begin
  have h : f = 𝟙 j, { cases f, cases f, ext, },
  rw h,
  simp,
end

end discrete

end category_theory


--import subfield_stuff
import field_theory.subfield
import field_theory.separable
import field_theory.tower
import group_theory.subgroup
import field_theory.minimal_polynomial
import linear_algebra.dimension
import linear_algebra.finite_dimensional
import ring_theory.adjoin_root
import data.zmod.basic

variables (F : Type*) [field F] {E : Type*} [field E] [algebra F E] (S : set E)

def adjoin : set E := field.closure (set.range (algebra_map F E) ∪ S)

lemma adjoin.field_mem (x : F) : algebra_map F E x ∈ adjoin F S :=
field.mem_closure (or.inl (set.mem_range_self x))

lemma adjoin.field_subset : set.range (algebra_map F E) ⊆ adjoin F S :=
begin
    intros x hx,
    cases hx with f hf,
    rw ←hf,
    exact adjoin.field_mem F S f,
end

instance adjoin.field_coe : has_coe_t F (adjoin F S) :=
{coe := λ x, ⟨algebra_map F E x, adjoin.field_mem F S x⟩}

lemma adjoin.set_mem (x : S) : ↑x ∈ adjoin F S :=
field.mem_closure (or.inr (subtype.mem x))

lemma adjoin.set_subset : S ⊆ adjoin F S :=
λ x hx, adjoin.set_mem F S ⟨x,hx⟩

instance adjoin.set_coe : has_coe_t S (adjoin F S) :=
{coe := λ x, ⟨↑x, adjoin.set_mem F S x⟩}

lemma adjoin.mono (T : set E) (h : S ⊆ T) : adjoin F S ⊆ adjoin F T :=
field.closure_mono (set.union_subset (set.subset_union_left _ _) (set.subset_union_of_subset_right h _))

instance adjoin.is_subfield : is_subfield (adjoin F S) := field.closure.is_subfield

lemma adjoin_contains_field_as_subfield (F : set E) {HF : is_subfield F} : F ⊆ adjoin F S :=
λ x hx, adjoin.field_mem F S ⟨x, hx⟩

lemma adjoin_contains_subset {T : set E} {H : T ⊆ S} : T ⊆ adjoin F S :=
begin
    intros x hx,
    exact adjoin.set_mem F S ⟨x,H hx⟩,
end

instance adjoin.is_algebra : algebra F (adjoin F S) := {
    smul := λ x y, ⟨algebra_map F E x, adjoin.field_mem F S x⟩ * y,
    to_fun := λ x, ⟨algebra_map F E x, adjoin.field_mem F S x⟩,
    map_one' := by simp only [ring_hom.map_one];refl,
    map_mul' := λ x y, by simp only [ring_hom.map_mul];refl,
    map_zero' := by simp only [ring_hom.map_zero];refl,
    map_add' := λ x y, by simp only [ring_hom.map_add];refl,
    commutes' := λ x y, by rw mul_comm,
    smul_def' := λ x y, rfl,
}

def adjoin_as_submodule : submodule F E := {
    carrier := adjoin F S,
    zero_mem' := is_add_submonoid.zero_mem,
    add_mem' := λ a b, is_add_submonoid.add_mem,
    smul_mem' :=
    begin
        intros a b hb,
        rw algebra.smul_def,
        exact is_submonoid.mul_mem (adjoin.field_mem F S a) hb,
    end
}

definition adjoin_as_submodule_equiv : (adjoin F S) ≃ₗ[F] (adjoin_as_submodule F S) := {
    to_fun := λ x, x,
    map_add' := λ x y, rfl,
    map_smul' :=
    begin
        intros x y,
        ext1,
        change _ = x • ↑y,
        rw algebra.smul_def,
        rw algebra.smul_def,
        refl,
    end,
    inv_fun := λ x, x,
    left_inv := λ x, rfl,
    right_inv := λ x, rfl,
}

lemma adjoin_subset {T : set E} [is_subfield T] (HF : set.range (algebra_map F E) ⊆ T) (HS : S ⊆ T) : adjoin F S ⊆ T :=
begin
    apply field.closure_subset,
    rw set.union_subset_iff,
    exact ⟨HF,HS⟩,
end

/-- If S ⊆ F[T] then F[S] ⊆ F[T] -/
lemma adjoin_subset' {T : set E} (HT : S ⊆ adjoin F T) : adjoin F S ⊆ adjoin F T :=
adjoin_subset F S (adjoin.field_subset F T) HT

lemma set_range_subset {T₁ T₂ : set E} [is_subfield T₁] [is_subfield T₂] {hyp : T₁ ⊆ T₂} :
set.range (algebra_map T₁ E) ⊆ T₂ :=
begin
    intros x hx,
    cases hx with f hf,
    rw ←hf,
    cases f with t ht,
    exact hyp ht,
end

/- The range of the embedding of F into E is equal to the range of the inclusion embedding of
    range(F → E) into E. -/
lemma algebra_map_twice : set.range (algebra_map (set.range (algebra_map F E)) E) = set.range (algebra_map F E) :=
begin
    ext, split,
    {   rintros ⟨⟨y, ⟨z, rfl⟩⟩, rfl⟩,
        exact ⟨z, rfl⟩,
    },
    {   exact λ hx, ⟨⟨x, hx⟩, rfl⟩, },
end

/- Adjoining S to F is the same as adjoining S to the range of the embedding of F into E. -/
lemma adjoin_equals_adjoin_range : adjoin F S = adjoin (set.range (algebra_map F E)) S :=
by simp only [adjoin, algebra_map_twice]

lemma adjoin_contains_field_subset {F : set E} {HF : is_subfield F} {T : set E} {HT : T ⊆ F} : T ⊆ adjoin F S :=
λ x hx, adjoin.field_mem F S ⟨x,HT hx⟩

lemma adjoin_twice (T : set E) : adjoin (adjoin F S) T = adjoin F (S ∪ T) :=
begin
    apply set.eq_of_subset_of_subset,
    apply adjoin_subset,
    apply set_range_subset,
    apply adjoin_subset,
    apply adjoin.field_subset,
    apply adjoin_contains_subset,
    apply set.subset_union_left,
    apply adjoin_contains_subset,
    apply set.subset_union_right,
    apply adjoin_subset,
    transitivity adjoin F S,
    apply adjoin.field_subset,
    apply adjoin_subset,
    apply adjoin_contains_field_subset,
    apply adjoin.field_subset,
    apply adjoin_contains_field_subset,
    apply adjoin.set_subset,
    apply set.union_subset,
    apply adjoin_contains_field_subset,
    apply adjoin.set_subset,
    apply adjoin.set_subset,
end

lemma adjoin.composition : (algebra_map F E) = (algebra_map (adjoin F S) E).comp (algebra_map F (adjoin F S)) :=
begin
    ext,
    refl,
end

instance adjoin_algebra_tower : is_scalar_tower F (adjoin F S) E := {
    smul_assoc :=
    begin
        intros x y z,
        rw algebra.smul_def,
        rw algebra.smul_def,
        rw algebra.smul_def,
        rw ring_hom.map_mul,
        rw mul_assoc,
        refl,
    end
}

lemma adjoin_separable [F_sep : is_separable F E] : is_separable (adjoin F S) E :=
begin
    intro x,
    cases F_sep x with hx hs,
    have hx' : is_integral (adjoin F S) x := is_integral_of_is_scalar_tower x hx,
    use hx',
    have key : (minimal_polynomial hx') ∣ (minimal_polynomial hx).map(algebra_map F (adjoin F S)),
    apply minimal_polynomial.dvd,
    dsimp[polynomial.aeval],
    rw polynomial.eval₂_map,
    rw ← adjoin.composition,
    apply minimal_polynomial.aeval,
    cases key with q hq,
    apply polynomial.separable.of_mul_left,
    rw ←hq,
    exact polynomial.separable.map hs,
end

variables (α : E) (h : is_integral F α)

-- Let's try out this notation?
notation K`[`:std.prec.max_plus β`]` := adjoin K (@singleton _ _ set.has_singleton β)
notation K`[`:std.prec.max_plus β `,` γ`]` := adjoin K {β,γ}
-- This notation would allow us to write F[α, β] for adjoin_simple (adjoin_simple F α) β
-- notation K`⟨`L:(foldr `,` (x M, adjoin_simple M x) K `⟩`) := L
-- notation K`[[` binders `]]`s:(scoped β, set.insert β) := adjoin K s

lemma adjoin_simple_contains_element : α ∈ F[α] :=
adjoin.set_mem F {α} (⟨α,set.mem_singleton α⟩ : ({α} : set E))

instance adjoin_is_algebra : algebra F F[α] :=
adjoin.is_algebra F {α}

def adjoin_simple_as_submodule : submodule F E :=
adjoin_as_submodule F {α}

definition adjoin_simple_as_submodule_equiv : F[α] ≃ₗ[F] (adjoin_simple_as_submodule F α) :=
adjoin_as_submodule_equiv F {α}

/-- A subfield of E that contains F and α also contains F[α] -/
lemma adjoin_simple_subset {T : set E} [is_subfield T] (HF : set.range (algebra_map F E) ⊆ T) (Hα : α ∈ T) : F[α] ⊆ T :=
adjoin_subset F {α} HF (set.singleton_subset_iff.mpr Hα)

/-- If α is in F[T] then F[α] ⊆ F[T] -/
lemma adjoin_simple_subset' {T : set E} (HT : α ∈ adjoin F T) : F[α] ⊆ adjoin F T :=
adjoin_subset' F {α} (set.singleton_subset_iff.mpr HT)

--generator of F(α)
def adjoin_simple.gen : F[α] := ⟨α, adjoin_simple_contains_element F α⟩

lemma adjoin_simple.gen_eq_alpha : algebra_map F[α] E (adjoin_simple.gen F α) = α := rfl

/-- If the generator is not in the inclusion of F in E then it's also not in the inclusion of
    F in F[α]. -/
lemma adjoin_simple_gen_nontrivial {α : E} (hα : α ∉ set.range (algebra_map F E)) :
    adjoin_simple.gen F α ∉ set.range (algebra_map F F[α]) :=
begin
    revert hα,
    contrapose!,
    rintros ⟨x, hx⟩,
    injections_and_clear,
    use x, assumption,
end

lemma adjoin_simple_twice (β : E) : F[α][β] = adjoin F {α,β} :=
adjoin_twice _ _ _

def submodule_restrict_field (α : E) (p : submodule F[α] E) : submodule F E := {
    carrier := p.carrier,
    zero_mem' := p.zero_mem',
    add_mem' := p.add_mem',
    smul_mem' :=
    begin
        intros c x hx,
        rw algebra.smul_def,
        rw adjoin.composition F {α},
        rw ring_hom.comp_apply,
        rw ←algebra.smul_def,
        exact p.smul_mem' _ hx,
    end
}

instance adjoin_simple_algebra_tower : is_scalar_tower F (F[α]) E :=
adjoin_algebra_tower F {α}

section
open finite_dimensional

/-- If a subset of a set is infinite then the set is infinite. -/
lemma inf_of_subset_inf {X : Type*} {s : set X} {t : set X} (hst : s ⊆ t) (hs : s.infinite) : t.infinite :=
mt (λ ht, ht.subset hst) hs

/-- If E is a finite extension of F then it is also a finite extension of F adjoin alpha. -/
instance adjoin_findim_of_findim [F_findim : finite_dimensional F E] (α : E) :
    finite_dimensional F[α] E :=
begin
    rw iff_fg,
    rw submodule.fg_iff_finite_dimensional,
    cases (finite_dimensional.exists_is_basis_finite F E) with B hB,
    have key : submodule.span F[α] B = ⊤,
    {   ext,
        simp only [submodule.mem_top, iff_true],
        have hx : x ∈ submodule.span F (set.range coe),
        {   rw hB.1.2,
            exact submodule.mem_top, },
        rw submodule.mem_span,
        intros p hp,
        rw submodule.mem_span at hx,
        apply hx (submodule_restrict_field F α p),
        rw subtype.range_coe,
        exact hp, },
    rw ← key,
    apply finite_dimensional.span_of_finite F[α] hB.2,
end

instance adjoin_findim_of_findim_base [F_findim : finite_dimensional F E] (α : E) :
    finite_dimensional F F[α] :=
begin
    have h := finite_dimensional.finite_dimensional_submodule (adjoin_simple_as_submodule F α),
    exact linear_equiv.finite_dimensional (adjoin_simple_as_submodule_equiv F α).symm,
end

/-- If the field extension E has an element not in the base field F then the degree of E over F is
    greater than 1. -/
lemma algebra_findim_lt [hF : finite_dimensional F E] : (∃ x : E, x ∉ set.range (algebra_map F E)) →
    1 < findim F E :=
begin
    contrapose!,
    intros E_dim x,
    have : 0 < findim F E := findim_pos_iff_exists_ne_zero.mpr ⟨1, one_ne_zero⟩,
    replace E_dim : findim F E = 1 := by omega,
    set s : set E := {1} with hs,
    have : fintype s := unique.fintype,
    have s_lin_ind : linear_independent F (coe : s → E) := linear_independent_singleton one_ne_zero,
    have s_card : s.to_finset.card = findim F E := by change s.to_finset.card with 1; rw E_dim,
    obtain ⟨_, s_spans⟩ := set_is_basis_of_linear_independent_of_card_eq_findim s_lin_ind s_card,
    have x_in_span_one : x ∈ submodule.span F s :=
    begin
        rw subtype.range_coe at s_spans,
        rw s_spans,
        exact submodule.mem_top,
    end,
    obtain ⟨a, ha⟩ := submodule.mem_span_singleton.mp x_in_span_one,
    exact ⟨a, by rw [← ha, algebra.smul_def, mul_one]⟩,
end

/-- Adjoining an element from outside of F strictly decreases the degree of a finite extension. -/
lemma adjoin_dim_lt [hF : finite_dimensional F E] {α : E} (hα : α ∉ set.range (algebra_map F E)) :
    findim F[α] E < findim F E :=
begin
    rw ← findim_mul_findim F F[α] E,
    have : 0 < findim F[α] E := findim_pos_iff_exists_ne_zero.mpr ⟨1, one_ne_zero⟩,
    have : adjoin_simple.gen F α ∉ set.range (algebra_map F F[α]) := adjoin_simple_gen_nontrivial F hα,
    have : findim F F[α] > 1 := algebra_findim_lt F (by tauto),
    nlinarith,
end

/-- If F is infinite then its inclusion into E is infinite. -/
lemma inclusion.infinite (hF : infinite F) : (set.range (algebra_map F E)).infinite :=
begin
    apply set.infinite_coe_iff.mp,
    apply infinite.of_injective (set.range_factorization (algebra_map F E)),
    exact subtype.coind_injective (λ (a : F), set.mem_range_self a) ((algebra_map F E).injective),
end

lemma adjoin_inf_of_inf (S : set E) (hF : infinite F) : infinite (adjoin F S) :=
begin
    rw adjoin_equals_adjoin_range,
    apply set.infinite_coe_iff.mpr,
    exact inf_of_subset_inf (adjoin_contains_field_as_subfield S (set.range (algebra_map F E))) (inclusion.infinite F hF),
end

end

variables {E' : Type*} [field E'] [algebra F E'] (α' : E') (hα' : (minimal_polynomial h).eval₂ (algebra_map F E') α' = 0)

noncomputable def quotient_embedding_ring_hom :
(adjoin_root (minimal_polynomial h)) →+* E' :=
adjoin_root.lift (algebra_map F E') α' hα'

noncomputable def quotient_embedding : (adjoin_root (minimal_polynomial h)) →ₐ[F] E' := {
    to_fun := (quotient_embedding_ring_hom F α h α' hα').to_fun,
    map_one' := (quotient_embedding_ring_hom F α h α' hα').map_one',
    map_mul' := (quotient_embedding_ring_hom F α h α' hα').map_mul',
    map_zero' := (quotient_embedding_ring_hom F α h α' hα').map_zero',
    map_add' := (quotient_embedding_ring_hom F α h α' hα').map_add',
    commutes' :=
    begin
        intro r,
        change (quotient_embedding_ring_hom F α h α' hα') r = _,
        exact adjoin_root.lift_of,
    end
}

@[simp] lemma quotient_embedding_of_field (f : F) : quotient_embedding F α h α' hα' f = algebra_map F E' f :=
begin
    change quotient_embedding_ring_hom F α h α' hα' f = algebra_map F E' f,
    exact adjoin_root.lift_of,
end

@[simp] lemma quotient_embedding_of_root : quotient_embedding F α h α' hα' (adjoin_root.root (minimal_polynomial h)) = α' :=
begin
    change quotient_embedding_ring_hom F α h α' hα' (adjoin_root.root (minimal_polynomial h)) = α',
    exact adjoin_root.lift_root,
end

noncomputable instance yes_its_a_field_but_lean_want_me_to_give_this_instance_a_name : field (adjoin_root (minimal_polynomial h)) :=
@adjoin_root.field F _ (minimal_polynomial h) (minimal_polynomial.irreducible h)

lemma adjoin_simple.eval_gen : polynomial.eval₂ (algebra_map F F[α]) (adjoin_simple.gen F α) (minimal_polynomial h) = 0 :=
begin
    ext,
    have eval := minimal_polynomial.aeval h,
    dsimp[polynomial.aeval] at eval,
    rw adjoin.composition F {α} at eval,
    have h := polynomial.hom_eval₂ (minimal_polynomial h) (algebra_map F F[α]) (algebra_map F[α] E) (adjoin_simple.gen F α),
    rw adjoin_simple.gen_eq_alpha at h,
    rw ←h at eval,
    exact eval,
end

noncomputable def quotient_to_adjunction_algebra_hom : (adjoin_root (minimal_polynomial h)) →ₐ[F] F[α] :=
quotient_embedding F α h (adjoin_simple.gen F α) (adjoin_simple.eval_gen F α h)

noncomputable def algebra_equiv_of_bij_hom' {A : Type*} [ring A] [algebra F A] {B : Type*} [ring B] [algebra F B] (f : A →ₐ[F] B) (h : function.bijective f) : A ≃ₐ[F] B :=
{ .. f, .. equiv.of_bijective _ h }

noncomputable def quotient_to_adjunction : adjoin_root (minimal_polynomial h) ≃ₐ[F] F[α] :=
algebra_equiv_of_bij_hom' F (quotient_to_adjunction_algebra_hom F α h)
begin
    set f := (algebra_map F[α] E).comp((quotient_to_adjunction_algebra_hom F α h) : (adjoin_root (minimal_polynomial h)) →+* F[α]),
    split,
    apply ring_hom.injective,
    have inclusion : (set.range (algebra_map F E) ∪ {α}) ⊆ set.range(f),
    rw set.union_subset_iff,
    split,
    intros x hx,
    rw set.mem_range at hx,
    cases hx with y hy,
    rw ←hy,
    use y,
    dsimp[f,quotient_to_adjunction_algebra_hom],
    rw quotient_embedding_of_field F α h (adjoin_simple.gen F α) (adjoin_simple.eval_gen F α h) y,
    refl,
    intros x hx,
    rw set.mem_singleton_iff at hx,
    rw hx,
    use adjoin_root.root (minimal_polynomial h),
    dsimp[f,quotient_to_adjunction_algebra_hom],
    rw quotient_embedding_of_root F α h (adjoin_simple.gen F α) (adjoin_simple.eval_gen F α h),
    refl,
    have key : F[α] ⊆ set.range(f) := field.closure_subset inclusion,
    intro x,
    specialize key (subtype.mem x),
    cases key with a ah,
    use a,
    ext1,
    assumption,
end

@[simp] lemma quotient_to_adjunction_of_field (f : F) : quotient_to_adjunction F α h f = f :=
quotient_embedding_of_field F α h (adjoin_simple.gen F α) (adjoin_simple.eval_gen F α h) f

@[simp] lemma quotient_to_adjunction_of_root : quotient_to_adjunction F α h (adjoin_root.root (minimal_polynomial h)) = adjoin_simple.gen F α :=
quotient_embedding_of_root F α h (adjoin_simple.gen F α) (adjoin_simple.eval_gen F α h)

noncomputable def adjunction_embedding : F[α] →ₐ[F] E' :=
(quotient_embedding F α h α' hα').comp((quotient_to_adjunction F α h).symm)

@[simp] lemma adjunction_embedding_of_field (f : F) : adjunction_embedding F α h α' hα' f = algebra_map F E' f :=
begin
    dsimp[adjunction_embedding],
    rw ←quotient_to_adjunction_of_field,
    rw alg_equiv.symm_apply_apply,
    rw quotient_embedding_of_field,
end

@[simp] lemma adjunction_embedding_of_root : adjunction_embedding F α h α' hα' (adjoin_simple.gen F α) = α' :=
begin
    dsimp[adjunction_embedding],
    rw ←quotient_to_adjunction_of_root,
    rw alg_equiv.symm_apply_apply,
    rw quotient_embedding_of_root,
end

variables (ϕ ψ : (adjoin F S) →+* E')

def adjoin_equalizer : set (adjoin F S) :=
(λ f, ϕ f = ψ f)

instance to_adjunction_embedding_equalizer_is_subfield : is_subfield (adjoin_equalizer F S ϕ ψ) := {
    zero_mem :=
    begin
        change ϕ 0 = ψ 0,
        rw ring_hom.map_zero,
        rw ring_hom.map_zero,
    end,
    add_mem :=
    begin
        intros a b ha hb,
        change ϕ a = ψ a at ha,
        change ϕ b = ψ b at hb,
        change ϕ (a + b) = ψ (a + b),
        rw ring_hom.map_add,
        rw ring_hom.map_add,
        rw ha,
        rw hb,
    end,
    neg_mem :=
    begin
        intros a ha,
        change ϕ a = ψ a at ha,
        change ϕ (-a) = ψ (-a),
        rw ring_hom.map_neg,
        rw ring_hom.map_neg,
        rw ha,
    end,
    one_mem :=
    begin
        change ϕ 1 = ψ 1,
        rw ring_hom.map_one,
        rw ring_hom.map_one,
    end,
    mul_mem :=
    begin
        intros a b ha hb,
        change ϕ a = ψ a at ha,
        change ϕ b = ψ b at hb,
        change ϕ (a * b) = ψ (a * b),
        rw ring_hom.map_mul,
        rw ring_hom.map_mul,
        rw ha,
        rw hb,
    end,
    inv_mem :=
    begin
        intros a ha,
        change ϕ a = ψ a at ha,
        change ϕ a⁻¹ = ψ a⁻¹,
        rw ring_hom.map_inv,
        rw ring_hom.map_inv,
        rw ha,
    end
}

instance to_adjunction_embedding_equalizer_coe_is_subfield : is_subfield ((coe '' adjoin_equalizer F S ϕ ψ) : set E) := {
    zero_mem := ⟨0,⟨is_add_submonoid.zero_mem,rfl⟩⟩,
    add_mem :=
    begin
        intros a b ha hb,
        cases ha with a' ha',
        cases hb with b' hb',
        rw[←ha'.2,←hb'.2],
        exact ⟨a'+b',⟨is_add_submonoid.add_mem ha'.1 hb'.1,rfl⟩⟩,
    end,
    neg_mem :=
    begin
        intros a ha,
        cases ha with a' ha',
        rw ←ha'.2,
        exact ⟨-a',⟨is_add_subgroup.neg_mem ha'.1,rfl⟩⟩,
    end,
    one_mem := ⟨1,⟨is_submonoid.one_mem,rfl⟩⟩,
    mul_mem :=
    begin
        intros a b ha hb,
        cases ha with a' ha',
        cases hb with b' hb',
        rw[←ha'.2,←hb'.2],
        exact ⟨a'*b',⟨is_submonoid.mul_mem ha'.1 hb'.1,rfl⟩⟩,
    end,
    inv_mem :=
    begin
        intros a ha,
        cases ha with a' ha',
        rw ←ha'.2,
        exact ⟨a'⁻¹,⟨is_subfield.inv_mem ha'.1,rfl⟩⟩,
    end
}

lemma ring_hom_determined_by_generators (hF : ∀ f : F, ϕ f = ψ f) (hS : ∀ s : S, ϕ s = ψ s) : ϕ = ψ :=
begin
    suffices key : adjoin F S ⊆ coe '' adjoin_equalizer F S ϕ ψ,
    ext,
    specialize key (subtype.mem x),
    cases key with y hy,
    rw ←subtype.ext hy.2,
    exact hy.1,
    dsimp[adjoin],
    rw field.closure_subset_iff,
    rw set.union_subset_iff,
    split,
    intros x hx,
    cases hx with y hy,
    exact ⟨↑y,⟨hF y,hy⟩⟩,
    intros x hx,
    exact ⟨⟨x,adjoin.set_mem F S ⟨x,hx⟩⟩,⟨hS ⟨x,hx⟩,rfl⟩⟩,
end

variable (ι : F[α] →ₐ[F] E')

lemma adjunction_embedding_classification_aux : polynomial.eval₂ (algebra_map F E') (ι (adjoin_simple.gen F α)) (minimal_polynomial h) = 0 :=
begin
    have key2 : ((ι : F[α] →+* E').comp(algebra_map F F[α]) = algebra_map F E'),
    ext,
    simp only [alg_hom.coe_to_ring_hom, function.comp_app, ring_hom.coe_comp, alg_hom.commutes],
    rw ←key2,
    change polynomial.eval₂ ((ι : F[α] →+* E').comp(algebra_map F F[α])) ((ι : F[α] →+* E') (adjoin_simple.gen F α)) (minimal_polynomial h) = 0,
    rw ←polynomial.hom_eval₂ (minimal_polynomial h) (algebra_map F F[α]) (ι : F[α] →+* E') (adjoin_simple.gen F α),
    rw adjoin_simple.eval_gen,
    simp only [alg_hom.coe_to_ring_hom, alg_hom.map_zero],
end

noncomputable def to_adjunction_embedding : F[α] →ₐ[F] E' :=
adjunction_embedding F α h (ι (adjoin_simple.gen F α)) (adjunction_embedding_classification_aux F α h ι)

--proves that every map F(α) → E' is comes from adjunction_embedding
lemma adjunction_embedding_classification : ι = to_adjunction_embedding F α h ι :=
begin
    have key := ring_hom_determined_by_generators F {α} (ι : F[α] →+* E') (to_adjunction_embedding F α h ι : F[α] →+* E'),
    have hF : ∀ f : F, ι f = to_adjunction_embedding F α h ι f,
    intro f,
    dsimp[to_adjunction_embedding],
    rw adjunction_embedding_of_field,
    exact alg_hom.commutes ι f,
    specialize key hF,
    rw ring_hom.ext_iff at key,
    rw alg_hom.ext_iff,
    apply key,
    intro s,
    have h' : (↑s : adjoin F {α}) = adjoin_simple.gen F α,
    ext,
    cases s with s hs,
    exact set.mem_singleton_iff.2 hs,
    rw h',
    dsimp[to_adjunction_embedding],
    rw adjunction_embedding_of_root,
end

/-lemma quotient_degree_finite : finite_dimensional F (adjoin_root (minimal_polynomial h)) :=
begin
    sorry
end

lemma quotient_degree : (finite_dimensional.findim F (adjoin_root (minimal_polynomial h))) = (minimal_polynomial h).nat_degree :=
begin
    sorry
end

lemma adjunction_degree_finite : finite_dimensional F (adjoin_root (minimal_polynomial h)) :=
begin
    sorry
end

lemma adjunction_degree : (finite_dimensional.findim F (adjoin_simple F α)) = (minimal_polynomial h).nat_degree :=
begin
    have algequiv : adjoin_root (minimal_polynomial h) ≃ₐ[F] adjoin_simple F α := quotient_to_adjunction F α h,
    have linequiv : adjoin_root (minimal_polynomial h) ≃ₗ[F] adjoin_simple F α,
    fconstructor,
    exact algequiv.to_fun,
    exact algequiv.map_add,
    intro c,
    intro x,
    change algequiv (c * x) = ((algebra_map F (adjoin_simple F α) c) * (algequiv x)),
    rw[algequiv.map_mul,←algequiv.commutes],
    refl,
    exact algequiv.inv_fun,
    exact algequiv.left_inv,
    exact algequiv.right_inv,
    rw ← @linear_equiv.findim_eq F (adjoin_root (minimal_polynomial h)) _ _ _ (adjoin_simple F α) _ _ linequiv (quotient_degree_finite F α h),
    exact quotient_degree F α h,
end-/


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel

! This file was ported from Lean 3 source module category_theory.limits.constructions.filtered
! leanprover-community/mathlib commit 10bf4f825ad729c5653adc039dafa3622e7f93c9
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Limits.Constructions.LimitsOfProductsAndEqualizers
import Mathbin.CategoryTheory.Limits.Opposites

/-!
# Constructing colimits from finite colimits and filtered colimits

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

We construct colimits of size `w` from finite colimits and filtered colimits of size `w`. Since
`w`-sized colimits are constructured from coequalizers and `w`-sized coproducts, it suffices to
construct `w`-sized coproducts from finite coproducts and `w`-sized filtered colimits.

The idea is simple: to construct coproducts of shape `α`, we take the colimit of the filtered
diagram of all coproducts of finite subsets of `α`.

We also deduce the dual statement by invoking the original statement in `Cᵒᵖ`.
-/

universe w v u

noncomputable section

open CategoryTheory

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

namespace CategoryTheory.Limits

namespace CoproductsFromFiniteFiltered

attribute [local tidy] tactic.case_bash

#print CategoryTheory.Limits.CoproductsFromFiniteFiltered.liftToFinset /-
/-- If `C` has finite coproducts, a functor `discrete α ⥤ C` lifts to a functor
    `finset (discrete α) ⥤ C` by taking coproducts. -/
@[simps]
def liftToFinset [HasFiniteCoproducts C] (F : Discrete α ⥤ C) : Finset (Discrete α) ⥤ C
    where
  obj s := ∐ fun x : s => F.obj x
  map s t h := Sigma.desc fun y => Sigma.ι (fun x : t => F.obj x) ⟨y, h.down.down y.2⟩
#align category_theory.limits.coproducts_from_finite_filtered.lift_to_finset CategoryTheory.Limits.CoproductsFromFiniteFiltered.liftToFinset
-/

#print CategoryTheory.Limits.CoproductsFromFiniteFiltered.liftToFinsetColimitCocone /-
/-- If `C` has finite coproducts and filtered colimits, we can construct arbitrary coproducts by
    taking the colimit of the diagram formed by the coproducts of finite sets over the indexing
    type. -/
@[simps]
def liftToFinsetColimitCocone [HasFiniteCoproducts C] [HasFilteredColimitsOfSize.{w, w} C]
    [DecidableEq α] (F : Discrete α ⥤ C) : ColimitCocone F
    where
  Cocone :=
    { pt := colimit (liftToFinset F)
      ι :=
        Discrete.natTrans fun j =>
          @Sigma.ι _ _ _ (fun x : ({j} : Finset (Discrete α)) => F.obj x) _ ⟨j, by simp⟩ ≫
            colimit.ι (liftToFinset F) {j} }
  IsColimit :=
    { desc := fun s =>
        colimit.desc (liftToFinset F)
          { pt := s.pt
            ι := { app := fun t => Sigma.desc fun x => s.ι.app x } }
      uniq := fun s m h => by
        ext (t⟨⟨j, hj⟩⟩)
        convert h j using 1
        · simp [← colimit.w (lift_to_finset F) ⟨⟨Finset.singleton_subset_iff.2 hj⟩⟩]
          rfl
        · tidy }
#align category_theory.limits.coproducts_from_finite_filtered.lift_to_finset_colimit_cocone CategoryTheory.Limits.CoproductsFromFiniteFiltered.liftToFinsetColimitCocone
-/

end CoproductsFromFiniteFiltered

open CoproductsFromFiniteFiltered

#print CategoryTheory.Limits.hasCoproducts_of_finite_and_filtered /-
theorem hasCoproducts_of_finite_and_filtered [HasFiniteCoproducts C]
    [HasFilteredColimitsOfSize.{w, w} C] : HasCoproducts.{w} C := fun α => by
  classical exact ⟨fun F => has_colimit.mk (lift_to_finset_colimit_cocone F)⟩
#align category_theory.limits.has_coproducts_of_finite_and_filtered CategoryTheory.Limits.hasCoproducts_of_finite_and_filtered
-/

#print CategoryTheory.Limits.has_colimits_of_finite_and_filtered /-
theorem has_colimits_of_finite_and_filtered [HasFiniteColimits C]
    [HasFilteredColimitsOfSize.{w, w} C] : HasColimitsOfSize.{w, w} C :=
  have : HasCoproducts.{w} C := hasCoproducts_of_finite_and_filtered
  has_colimits_of_has_coequalizers_and_coproducts
#align category_theory.limits.has_colimits_of_finite_and_filtered CategoryTheory.Limits.has_colimits_of_finite_and_filtered
-/

#print CategoryTheory.Limits.hasProducts_of_finite_and_cofiltered /-
theorem hasProducts_of_finite_and_cofiltered [HasFiniteProducts C]
    [HasCofilteredLimitsOfSize.{w, w} C] : HasProducts.{w} C :=
  have : HasCoproducts.{w} Cᵒᵖ := hasCoproducts_of_finite_and_filtered
  has_products_of_opposite
#align category_theory.limits.has_products_of_finite_and_cofiltered CategoryTheory.Limits.hasProducts_of_finite_and_cofiltered
-/

#print CategoryTheory.Limits.has_limits_of_finite_and_cofiltered /-
theorem has_limits_of_finite_and_cofiltered [HasFiniteLimits C]
    [HasCofilteredLimitsOfSize.{w, w} C] : HasLimitsOfSize.{w, w} C :=
  have : HasProducts.{w} C := hasProducts_of_finite_and_cofiltered
  has_limits_of_has_equalizers_and_products
#align category_theory.limits.has_limits_of_finite_and_cofiltered CategoryTheory.Limits.has_limits_of_finite_and_cofiltered
-/

end CategoryTheory.Limits


/-
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, Yaël Dillies

! This file was ported from Lean 3 source module order.disjointed
! leanprover-community/mathlib commit 68d1483e8a718ec63219f0e227ca3f0140361086
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Order.PartialSups

/-!
# Consecutive differences of sets

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

This file defines the way to make a sequence of elements into a sequence of disjoint elements with
the same partial sups.

For a sequence `f : ℕ → α`, this new sequence will be `f 0`, `f 1 \ f 0`, `f 2 \ (f 0 ⊔ f 1)`.
It is actually unique, as `disjointed_unique` shows.

## Main declarations

* `disjointed f`: The sequence `f 0`, `f 1 \ f 0`, `f 2 \ (f 0 ⊔ f 1)`, ....
* `partial_sups_disjointed`: `disjointed f` has the same partial sups as `f`.
* `disjoint_disjointed`: The elements of `disjointed f` are pairwise disjoint.
* `disjointed_unique`: `disjointed f` is the only pairwise disjoint sequence having the same partial
  sups as `f`.
* `supr_disjointed`: `disjointed f` has the same supremum as `f`. Limiting case of
  `partial_sups_disjointed`.

We also provide set notation variants of some lemmas.

## TODO

Find a useful statement of `disjointed_rec_succ`.

One could generalize `disjointed` to any locally finite bot preorder domain, in place of `ℕ`.
Related to the TODO in the module docstring of `order.partial_sups`.
-/

variable {α β : Type _}

section GeneralizedBooleanAlgebra

variable [GeneralizedBooleanAlgebra α]

#print disjointed /-
/-- If `f : ℕ → α` is a sequence of elements, then `disjointed f` is the sequence formed by
subtracting each element from the nexts. This is the unique disjoint sequence whose partial sups
are the same as the original sequence. -/
def disjointed (f : ℕ → α) : ℕ → α
  | 0 => f 0
  | n + 1 => f (n + 1) \ partialSups f n
#align disjointed disjointed
-/

#print disjointed_zero /-
@[simp]
theorem disjointed_zero (f : ℕ → α) : disjointed f 0 = f 0 :=
  rfl
#align disjointed_zero disjointed_zero
-/

/- warning: disjointed_succ -> disjointed_succ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] (f : Nat -> α) (n : Nat), Eq.{succ u1} α (disjointed.{u1} α _inst_1 f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toHasSdiff.{u1} α _inst_1) (f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (coeFn.{succ u1, succ u1} (OrderHom.{0, u1} Nat α (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))) (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1)))))) (fun (_x : OrderHom.{0, u1} Nat α (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))) (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1)))))) => Nat -> α) (OrderHom.hasCoeToFun.{0, u1} Nat α (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))) (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1)))))) (partialSups.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1))) f) n))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] (f : Nat -> α) (n : Nat), Eq.{succ u1} α (disjointed.{u1} α _inst_1 f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toSDiff.{u1} α _inst_1) (f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (OrderHom.toFun.{0, u1} Nat α (PartialOrder.toPreorder.{0} Nat (StrictOrderedSemiring.toPartialOrder.{0} Nat Nat.strictOrderedSemiring)) (PartialOrder.toPreorder.{u1} α (SemilatticeSup.toPartialOrder.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1))))) (partialSups.{u1} α (Lattice.toSemilatticeSup.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1))) f) n))
Case conversion may be inaccurate. Consider using '#align disjointed_succ disjointed_succₓ'. -/
theorem disjointed_succ (f : ℕ → α) (n : ℕ) : disjointed f (n + 1) = f (n + 1) \ partialSups f n :=
  rfl
#align disjointed_succ disjointed_succ

#print disjointed_le_id /-
theorem disjointed_le_id : disjointed ≤ (id : (ℕ → α) → ℕ → α) :=
  by
  rintro f n
  cases n
  · rfl
  · exact sdiff_le
#align disjointed_le_id disjointed_le_id
-/

#print disjointed_le /-
theorem disjointed_le (f : ℕ → α) : disjointed f ≤ f :=
  disjointed_le_id f
#align disjointed_le disjointed_le
-/

#print disjoint_disjointed /-
theorem disjoint_disjointed (f : ℕ → α) : Pairwise (Disjoint on disjointed f) :=
  by
  refine' (Symmetric.pairwise_on Disjoint.symm _).2 fun m n h => _
  cases n
  · exact (Nat.not_lt_zero _ h).elim
  exact
    disjoint_sdiff_self_right.mono_left
      ((disjointed_le f m).trans (le_partialSups_of_le f (Nat.lt_add_one_iff.1 h)))
#align disjoint_disjointed disjoint_disjointed
-/

/- warning: disjointed_rec -> disjointedRec is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] {f : Nat -> α} {p : α -> Sort.{u2}}, (forall {{t : α}} {{i : Nat}}, (p t) -> (p (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toHasSdiff.{u1} α _inst_1) t (f i)))) -> (forall {{n : Nat}}, (p (f n)) -> (p (disjointed.{u1} α _inst_1 f n)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] {f : Nat -> α} {p : α -> Sort.{u2}}, (forall {{t : α}} {{i : Nat}}, (p t) -> (p (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toSDiff.{u1} α _inst_1) t (f i)))) -> (forall {{n : Nat}}, (p (f n)) -> (p (disjointed.{u1} α _inst_1 f n)))
Case conversion may be inaccurate. Consider using '#align disjointed_rec disjointedRecₓ'. -/
/-- An induction principle for `disjointed`. To define/prove something on `disjointed f n`, it's
enough to define/prove it for `f n` and being able to extend through diffs. -/
def disjointedRec {f : ℕ → α} {p : α → Sort _} (hdiff : ∀ ⦃t i⦄, p t → p (t \ f i)) :
    ∀ ⦃n⦄, p (f n) → p (disjointed f n)
  | 0 => id
  | n + 1 => fun h => by
    suffices H : ∀ k, p (f (n + 1) \ partialSups f k)
    · exact H n
    rintro k
    induction' k with k ih
    · exact hdiff h
    rw [partialSups_succ, ← sdiff_sdiff_left]
    exact hdiff ih
#align disjointed_rec disjointedRec

/- warning: disjointed_rec_zero -> disjointedRec_zero is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] {f : Nat -> α} {p : α -> Sort.{u2}} (hdiff : forall {{t : α}} {{i : Nat}}, (p t) -> (p (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toHasSdiff.{u1} α _inst_1) t (f i)))) (h₀ : p (f (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))))), Eq.{u2} (p (disjointed.{u1} α _inst_1 (fun (i : Nat) => f i) (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))))) (disjointedRec.{u1, u2} α _inst_1 (fun (i : Nat) => f i) (fun (t : α) => p t) hdiff (OfNat.ofNat.{0} Nat 0 (OfNat.mk.{0} Nat 0 (Zero.zero.{0} Nat Nat.hasZero))) h₀) h₀
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] {f : Nat -> α} {p : α -> Sort.{u2}} (hdiff : forall {{t : α}} {{i : Nat}}, (p t) -> (p (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toSDiff.{u1} α _inst_1) t (f i)))) (h₀ : p (f (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)))), Eq.{u2} (p (disjointed.{u1} α _inst_1 (fun (i : Nat) => f i) (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)))) (disjointedRec.{u1, u2} α _inst_1 (fun (i : Nat) => f i) (fun (t : α) => p t) hdiff (OfNat.ofNat.{0} Nat 0 (instOfNatNat 0)) h₀) h₀
Case conversion may be inaccurate. Consider using '#align disjointed_rec_zero disjointedRec_zeroₓ'. -/
@[simp]
theorem disjointedRec_zero {f : ℕ → α} {p : α → Sort _} (hdiff : ∀ ⦃t i⦄, p t → p (t \ f i))
    (h₀ : p (f 0)) : disjointedRec hdiff h₀ = h₀ :=
  rfl
#align disjointed_rec_zero disjointedRec_zero

/- warning: monotone.disjointed_eq -> Monotone.disjointed_eq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] {f : Nat -> α}, (Monotone.{0, u1} Nat α (PartialOrder.toPreorder.{0} Nat (OrderedCancelAddCommMonoid.toPartialOrder.{0} Nat (StrictOrderedSemiring.toOrderedCancelAddCommMonoid.{0} Nat Nat.strictOrderedSemiring))) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1))))) f) -> (forall (n : Nat), Eq.{succ u1} α (disjointed.{u1} α _inst_1 f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toHasSdiff.{u1} α _inst_1) (f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) n (OfNat.ofNat.{0} Nat 1 (OfNat.mk.{0} Nat 1 (One.one.{0} Nat Nat.hasOne))))) (f n)))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : GeneralizedBooleanAlgebra.{u1} α] {f : Nat -> α}, (Monotone.{0, u1} Nat α (PartialOrder.toPreorder.{0} Nat (StrictOrderedSemiring.toPartialOrder.{0} Nat Nat.strictOrderedSemiring)) (PartialOrder.toPreorder.{u1} α (SemilatticeInf.toPartialOrder.{u1} α (Lattice.toSemilatticeInf.{u1} α (GeneralizedCoheytingAlgebra.toLattice.{u1} α (GeneralizedBooleanAlgebra.toGeneralizedCoheytingAlgebra.{u1} α _inst_1))))) f) -> (forall (n : Nat), Eq.{succ u1} α (disjointed.{u1} α _inst_1 f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (SDiff.sdiff.{u1} α (GeneralizedBooleanAlgebra.toSDiff.{u1} α _inst_1) (f (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) n (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)))) (f n)))
Case conversion may be inaccurate. Consider using '#align monotone.disjointed_eq Monotone.disjointed_eqₓ'. -/
-- TODO: Find a useful statement of `disjointed_rec_succ`.
theorem Monotone.disjointed_eq {f : ℕ → α} (hf : Monotone f) (n : ℕ) :
    disjointed f (n + 1) = f (n + 1) \ f n := by rw [disjointed_succ, hf.partial_sups_eq]
#align monotone.disjointed_eq Monotone.disjointed_eq

#print partialSups_disjointed /-
@[simp]
theorem partialSups_disjointed (f : ℕ → α) : partialSups (disjointed f) = partialSups f :=
  by
  ext n
  induction' n with k ih
  · rw [partialSups_zero, partialSups_zero, disjointed_zero]
  · rw [partialSups_succ, partialSups_succ, disjointed_succ, ih, sup_sdiff_self_right]
#align partial_sups_disjointed partialSups_disjointed
-/

#print disjointed_unique /-
/-- `disjointed f` is the unique sequence that is pairwise disjoint and has the same partial sups
as `f`. -/
theorem disjointed_unique {f d : ℕ → α} (hdisj : Pairwise (Disjoint on d))
    (hsups : partialSups d = partialSups f) : d = disjointed f :=
  by
  ext n
  cases n
  · rw [← partialSups_zero d, hsups, partialSups_zero, disjointed_zero]
  suffices h : d n.succ = partialSups d n.succ \ partialSups d n
  · rw [h, hsups, partialSups_succ, disjointed_succ, sup_sdiff, sdiff_self, bot_sup_eq]
  rw [partialSups_succ, sup_sdiff, sdiff_self, bot_sup_eq, eq_comm, sdiff_eq_self_iff_disjoint]
  suffices h : ∀ m ≤ n, Disjoint (partialSups d m) (d n.succ)
  · exact h n le_rfl
  rintro m hm
  induction' m with m ih
  · exact hdisj (Nat.succ_ne_zero _).symm
  rw [partialSups_succ, disjoint_iff, inf_sup_right, sup_eq_bot_iff, ← disjoint_iff, ← disjoint_iff]
  exact ⟨ih (Nat.le_of_succ_le hm), hdisj (Nat.lt_succ_of_le hm).Ne⟩
#align disjointed_unique disjointed_unique
-/

end GeneralizedBooleanAlgebra

section CompleteBooleanAlgebra

variable [CompleteBooleanAlgebra α]

/- warning: supr_disjointed -> supᵢ_disjointed is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CompleteBooleanAlgebra.{u1} α] (f : Nat -> α), Eq.{succ u1} α (supᵢ.{u1, 1} α (ConditionallyCompleteLattice.toHasSup.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) Nat (fun (n : Nat) => disjointed.{u1} α (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} α (CompleteBooleanAlgebra.toBooleanAlgebra.{u1} α _inst_1)) f n)) (supᵢ.{u1, 1} α (ConditionallyCompleteLattice.toHasSup.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) Nat (fun (n : Nat) => f n))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CompleteBooleanAlgebra.{u1} α] (f : Nat -> α), Eq.{succ u1} α (supᵢ.{u1, 1} α (ConditionallyCompleteLattice.toSupSet.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) Nat (fun (n : Nat) => disjointed.{u1} α (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} α (CompleteBooleanAlgebra.toBooleanAlgebra.{u1} α _inst_1)) f n)) (supᵢ.{u1, 1} α (ConditionallyCompleteLattice.toSupSet.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) Nat (fun (n : Nat) => f n))
Case conversion may be inaccurate. Consider using '#align supr_disjointed supᵢ_disjointedₓ'. -/
theorem supᵢ_disjointed (f : ℕ → α) : (⨆ n, disjointed f n) = ⨆ n, f n :=
  supᵢ_eq_supᵢ_of_partialSups_eq_partialSups (partialSups_disjointed f)
#align supr_disjointed supᵢ_disjointed

/- warning: disjointed_eq_inf_compl -> disjointed_eq_inf_compl is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : CompleteBooleanAlgebra.{u1} α] (f : Nat -> α) (n : Nat), Eq.{succ u1} α (disjointed.{u1} α (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} α (CompleteBooleanAlgebra.toBooleanAlgebra.{u1} α _inst_1)) f n) (Inf.inf.{u1} α (SemilatticeInf.toHasInf.{u1} α (Lattice.toSemilatticeInf.{u1} α (ConditionallyCompleteLattice.toLattice.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))))) (f n) (infᵢ.{u1, 1} α (ConditionallyCompleteLattice.toHasInf.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) Nat (fun (i : Nat) => infᵢ.{u1, 0} α (ConditionallyCompleteLattice.toHasInf.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) (LT.lt.{0} Nat Nat.hasLt i n) (fun (H : LT.lt.{0} Nat Nat.hasLt i n) => HasCompl.compl.{u1} α (BooleanAlgebra.toHasCompl.{u1} α (CompleteBooleanAlgebra.toBooleanAlgebra.{u1} α _inst_1)) (f i)))))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : CompleteBooleanAlgebra.{u1} α] (f : Nat -> α) (n : Nat), Eq.{succ u1} α (disjointed.{u1} α (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} α (CompleteBooleanAlgebra.toBooleanAlgebra.{u1} α _inst_1)) f n) (Inf.inf.{u1} α (Lattice.toInf.{u1} α (ConditionallyCompleteLattice.toLattice.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1)))))) (f n) (infᵢ.{u1, 1} α (ConditionallyCompleteLattice.toInfSet.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) Nat (fun (i : Nat) => infᵢ.{u1, 0} α (ConditionallyCompleteLattice.toInfSet.{u1} α (CompleteLattice.toConditionallyCompleteLattice.{u1} α (Order.Coframe.toCompleteLattice.{u1} α (CompleteDistribLattice.toCoframe.{u1} α (CompleteBooleanAlgebra.toCompleteDistribLattice.{u1} α _inst_1))))) (LT.lt.{0} Nat instLTNat i n) (fun (H : LT.lt.{0} Nat instLTNat i n) => HasCompl.compl.{u1} α (BooleanAlgebra.toHasCompl.{u1} α (CompleteBooleanAlgebra.toBooleanAlgebra.{u1} α _inst_1)) (f i)))))
Case conversion may be inaccurate. Consider using '#align disjointed_eq_inf_compl disjointed_eq_inf_complₓ'. -/
theorem disjointed_eq_inf_compl (f : ℕ → α) (n : ℕ) : disjointed f n = f n ⊓ ⨅ i < n, f iᶜ :=
  by
  cases n
  · rw [disjointed_zero, eq_comm, inf_eq_left]
    simp_rw [le_infᵢ_iff]
    exact fun i hi => (i.not_lt_zero hi).elim
  simp_rw [disjointed_succ, partialSups_eq_bsupᵢ, sdiff_eq, compl_supᵢ]
  congr
  ext i
  rw [Nat.lt_succ_iff]
#align disjointed_eq_inf_compl disjointed_eq_inf_compl

end CompleteBooleanAlgebra

/-! ### Set notation variants of lemmas -/

/- warning: disjointed_subset -> disjointed_subset is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (f : Nat -> (Set.{u1} α)) (n : Nat), HasSubset.Subset.{u1} (Set.{u1} α) (Set.hasSubset.{u1} α) (disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) f n) (f n)
but is expected to have type
  forall {α : Type.{u1}} (f : Nat -> (Set.{u1} α)) (n : Nat), HasSubset.Subset.{u1} (Set.{u1} α) (Set.instHasSubsetSet.{u1} α) (disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) f n) (f n)
Case conversion may be inaccurate. Consider using '#align disjointed_subset disjointed_subsetₓ'. -/
theorem disjointed_subset (f : ℕ → Set α) (n : ℕ) : disjointed f n ⊆ f n :=
  disjointed_le f n
#align disjointed_subset disjointed_subset

/- warning: Union_disjointed -> unionᵢ_disjointed is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {f : Nat -> (Set.{u1} α)}, Eq.{succ u1} (Set.{u1} α) (Set.unionᵢ.{u1, 1} α Nat (fun (n : Nat) => disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) f n)) (Set.unionᵢ.{u1, 1} α Nat (fun (n : Nat) => f n))
but is expected to have type
  forall {α : Type.{u1}} {f : Nat -> (Set.{u1} α)}, Eq.{succ u1} (Set.{u1} α) (Set.unionᵢ.{u1, 1} α Nat (fun (n : Nat) => disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) f n)) (Set.unionᵢ.{u1, 1} α Nat (fun (n : Nat) => f n))
Case conversion may be inaccurate. Consider using '#align Union_disjointed unionᵢ_disjointedₓ'. -/
theorem unionᵢ_disjointed {f : ℕ → Set α} : (⋃ n, disjointed f n) = ⋃ n, f n :=
  supᵢ_disjointed f
#align Union_disjointed unionᵢ_disjointed

/- warning: disjointed_eq_inter_compl -> disjointed_eq_inter_compl is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (f : Nat -> (Set.{u1} α)) (n : Nat), Eq.{succ u1} (Set.{u1} α) (disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) f n) (Inter.inter.{u1} (Set.{u1} α) (Set.hasInter.{u1} α) (f n) (Set.interᵢ.{u1, 1} α Nat (fun (i : Nat) => Set.interᵢ.{u1, 0} α (LT.lt.{0} Nat Nat.hasLt i n) (fun (H : LT.lt.{0} Nat Nat.hasLt i n) => HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) (f i)))))
but is expected to have type
  forall {α : Type.{u1}} (f : Nat -> (Set.{u1} α)) (n : Nat), Eq.{succ u1} (Set.{u1} α) (disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) f n) (Inter.inter.{u1} (Set.{u1} α) (Set.instInterSet.{u1} α) (f n) (Set.interᵢ.{u1, 1} α Nat (fun (i : Nat) => Set.interᵢ.{u1, 0} α (LT.lt.{0} Nat instLTNat i n) (fun (H : LT.lt.{0} Nat instLTNat i n) => HasCompl.compl.{u1} (Set.{u1} α) (BooleanAlgebra.toHasCompl.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) (f i)))))
Case conversion may be inaccurate. Consider using '#align disjointed_eq_inter_compl disjointed_eq_inter_complₓ'. -/
theorem disjointed_eq_inter_compl (f : ℕ → Set α) (n : ℕ) : disjointed f n = f n ∩ ⋂ i < n, f iᶜ :=
  disjointed_eq_inf_compl f n
#align disjointed_eq_inter_compl disjointed_eq_inter_compl

/- warning: preimage_find_eq_disjointed -> preimage_find_eq_disjointed is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} (s : Nat -> (Set.{u1} α)) (H : forall (x : α), Exists.{1} Nat (fun (n : Nat) => Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) x (s n))) [_inst_1 : forall (x : α) (n : Nat), Decidable (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) x (s n))] (n : Nat), Eq.{succ u1} (Set.{u1} α) (Set.preimage.{u1, 0} α Nat (fun (x : α) => Nat.find (fun (n : Nat) => Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) x (s n)) (fun (a : Nat) => _inst_1 x a) (H x)) (Singleton.singleton.{0, 0} Nat (Set.{0} Nat) (Set.hasSingleton.{0} Nat) n)) (disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.booleanAlgebra.{u1} α)) s n)
but is expected to have type
  forall {α : Type.{u1}} (s : Nat -> (Set.{u1} α)) (H : forall (x : α), Exists.{1} Nat (fun (n : Nat) => Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) x (s n))) [_inst_1 : forall (x : α) (n : Nat), Decidable (Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) x (s n))] (n : Nat), Eq.{succ u1} (Set.{u1} α) (Set.preimage.{u1, 0} α Nat (fun (x : α) => Nat.find (fun (n : Nat) => Membership.mem.{u1, u1} α (Set.{u1} α) (Set.instMembershipSet.{u1} α) x (s n)) (fun (a : Nat) => _inst_1 x a) (H x)) (Singleton.singleton.{0, 0} Nat (Set.{0} Nat) (Set.instSingletonSet.{0} Nat) n)) (disjointed.{u1} (Set.{u1} α) (BooleanAlgebra.toGeneralizedBooleanAlgebra.{u1} (Set.{u1} α) (Set.instBooleanAlgebraSet.{u1} α)) s n)
Case conversion may be inaccurate. Consider using '#align preimage_find_eq_disjointed preimage_find_eq_disjointedₓ'. -/
theorem preimage_find_eq_disjointed (s : ℕ → Set α) (H : ∀ x, ∃ n, x ∈ s n)
    [∀ x n, Decidable (x ∈ s n)] (n : ℕ) : (fun x => Nat.find (H x)) ⁻¹' {n} = disjointed s n :=
  by
  ext x
  simp [Nat.find_eq_iff, disjointed_eq_inter_compl]
#align preimage_find_eq_disjointed preimage_find_eq_disjointed


/-
Copyright (c) 2018 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Scott Morrison
-/
import category_theory.opposites

/-!
# Morphisms from equations between objects.

When working categorically, sometimes one encounters an equation `h : X = Y` between objects.

Your initial aversion to this is natural and appropriate:
you're in for some trouble, and if there is another way to approach the problem that won't
rely on this equality, it may be worth pursuing.

You have two options:
1. Use the equality `h` as one normally would in Lean (e.g. using `rw` and `subst`).
   This may immediately cause difficulties, because in category theory everything is dependently
   typed, and equations between objects quickly lead to nasty goals with `eq.rec`.
2. Promote `h` to a morphism using `eq_to_hom h : X ⟶ Y`, or `eq_to_iso h : X ≅ Y`.

This file introduces various `simp` lemmas which in favourable circumstances
result in the various `eq_to_hom` morphisms to drop out at the appropriate moment!
-/

universes v₁ v₂ v₃ u₁ u₂ u₃
-- morphism levels before object levels. See note [category_theory universes].

namespace category_theory
open opposite

variables {C : Type u₁} [category.{v₁} C]

/--
An equality `X = Y` gives us a morphism `X ⟶ Y`.

It is typically better to use this, rather than rewriting by the equality then using `𝟙 _`
which usually leads to dependent type theory hell.
-/
def eq_to_hom {X Y : C} (p : X = Y) : X ⟶ Y := by rw p; exact 𝟙 _

@[simp] lemma eq_to_hom_refl (X : C) (p : X = X) : eq_to_hom p = 𝟙 X := rfl
@[simp, reassoc] lemma eq_to_hom_trans {X Y Z : C} (p : X = Y) (q : Y = Z) :
  eq_to_hom p ≫ eq_to_hom q = eq_to_hom (p.trans q) :=
by { cases p, cases q, simp, }

/--
If we (perhaps unintentionally) perform equational rewriting on
the source object of a morphism,
we can replace the resulting `_.mpr f` term by a composition with an `eq_to_hom`.

It may be advisable to introduce any necessary `eq_to_hom` morphisms manually,
rather than relying on this lemma firing.
-/
@[simp]
lemma congr_arg_mpr_hom_left {X Y Z : C} (p : X = Y) (q : Y ⟶ Z) :
  (congr_arg (λ W : C, W ⟶ Z) p).mpr q = eq_to_hom p ≫ q :=
by { cases p, simp, }

/--
If we (perhaps unintentionally) perform equational rewriting on
the target object of a morphism,
we can replace the resulting `_.mpr f` term by a composition with an `eq_to_hom`.

It may be advisable to introduce any necessary `eq_to_hom` morphisms manually,
rather than relying on this lemma firing.
-/
@[simp]
lemma congr_arg_mpr_hom_right {X Y Z : C} (p : X ⟶ Y) (q : Z = Y) :
  (congr_arg (λ W : C, X ⟶ W) q).mpr p = p ≫ eq_to_hom q.symm :=
by { cases q, simp, }

/--
An equality `X = Y` gives us an isomorphism `X ≅ Y`.

It is typically better to use this, rather than rewriting by the equality then using `iso.refl _`
which usually leads to dependent type theory hell.
-/
def eq_to_iso {X Y : C} (p : X = Y) : X ≅ Y :=
⟨eq_to_hom p, eq_to_hom p.symm, by simp, by simp⟩

@[simp] lemma eq_to_iso.hom {X Y : C} (p : X = Y) : (eq_to_iso p).hom = eq_to_hom p :=
rfl
@[simp] lemma eq_to_iso.inv {X Y : C} (p : X = Y) : (eq_to_iso p).inv = eq_to_hom p.symm :=
rfl

@[simp]

@[simp] lemma eq_to_hom_op {X Y : C} (h : X = Y) :
  (eq_to_hom h).op = eq_to_hom (congr_arg op h.symm) :=
by { cases h, refl, }

@[simp] lemma eq_to_hom_unop {X Y : Cᵒᵖ} (h : X = Y) :
  (eq_to_hom h).unop = eq_to_hom (congr_arg unop h.symm) :=
by { cases h, refl, }

instance {X Y : C} (h : X = Y) : is_iso (eq_to_hom h) := is_iso.of_iso (eq_to_iso h)

@[simp] lemma inv_eq_to_hom {X Y : C} (h : X = Y) : inv (eq_to_hom h) = eq_to_hom h.symm :=
by { ext, simp, }

variables {D : Type u₂} [category.{v₂} D]

namespace functor

/-- Proving equality between functors. This isn't an extensionality lemma,
  because usually you don't really want to do this. -/
lemma ext {F G : C ⥤ D} (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ X Y f, F.map f = eq_to_hom (h_obj X) ≫ G.map f ≫ eq_to_hom (h_obj Y).symm) :
  F = G :=
begin
  cases F with F_obj _ _ _, cases G with G_obj _ _ _,
  have : F_obj = G_obj, by ext X; apply h_obj,
  subst this,
  congr,
  funext X Y f,
  simpa using h_map X Y f
end

/-- Two morphisms are conjugate via eq_to_hom if and only if they are heterogeneously equal. --/
lemma conj_eq_to_hom_iff_heq {W X Y Z : C} (f : W ⟶ X) (g : Y ⟶ Z) (h : W = Y) (h' : X = Z) :
  f = eq_to_hom h ≫ g ≫ eq_to_hom h'.symm ↔ f == g :=
by { cases h, cases h', simp }

/-- Proving equality between functors using heterogeneous equality. -/
lemma hext {F G : C ⥤ D} (h_obj : ∀ X, F.obj X = G.obj X)
  (h_map : ∀ X Y (f : X ⟶ Y), F.map f == G.map f) : F = G :=
functor.ext h_obj (λ _ _ f,
  (conj_eq_to_hom_iff_heq _ _ (h_obj _) (h_obj _)).2 $ h_map _ _ f)

-- Using equalities between functors.

lemma congr_obj {F G : C ⥤ D} (h : F = G) (X) : F.obj X = G.obj X :=
by subst h

lemma congr_hom {F G : C ⥤ D} (h : F = G) {X Y} (f : X ⟶ Y) :
  F.map f = eq_to_hom (congr_obj h X) ≫ G.map f ≫ eq_to_hom (congr_obj h Y).symm :=
by subst h; simp

section heq

/- Composition of functors and maps w.r.t. heq -/

variables {E : Type u₃} [category.{v₃} E] {F G : C ⥤ D} {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z}

lemma map_comp_heq (hx : F.obj X = G.obj X) (hy : F.obj Y = G.obj Y) (hz : F.obj Z = G.obj Z)
  (hf : F.map f == G.map f) (hg : F.map g == G.map g) : F.map (f ≫ g) == G.map (f ≫ g) :=
by { rw [F.map_comp, G.map_comp], congr' }

lemma map_comp_heq' (hobj : ∀ X : C, F.obj X = G.obj X)
  (hmap : ∀ {X Y} (f : X ⟶ Y), F.map f == G.map f) :
  F.map (f ≫ g) == G.map (f ≫ g) :=
by rw functor.hext hobj (λ _ _, hmap)

lemma precomp_map_heq (H : E ⥤ C)
  (hmap : ∀ {X Y} (f : X ⟶ Y), F.map f == G.map f) {X Y : E} (f : X ⟶ Y) :
  (H ⋙ F).map f == (H ⋙ G).map f := hmap _

lemma postcomp_map_heq (H : D ⥤ E) (hx : F.obj X = G.obj X) (hy : F.obj Y = G.obj Y)
  (hmap : F.map f == G.map f) : (F ⋙ H).map f == (G ⋙ H).map f :=
by { dsimp, congr' }

lemma postcomp_map_heq' (H : D ⥤ E) (hobj : ∀ X : C, F.obj X = G.obj X)
  (hmap : ∀ {X Y} (f : X ⟶ Y), F.map f == G.map f) :
  (F ⋙ H).map f == (G ⋙ H).map f :=
by rw functor.hext hobj (λ _ _, hmap)

lemma hcongr_hom {F G : C ⥤ D} (h : F = G) {X Y} (f : X ⟶ Y) : F.map f == G.map f :=
by subst h

end heq

end functor

@[simp] lemma eq_to_hom_map (F : C ⥤ D) {X Y : C} (p : X = Y) :
  F.map (eq_to_hom p) = eq_to_hom (congr_arg F.obj p) :=
by cases p; simp

@[simp] lemma eq_to_iso_map (F : C ⥤ D) {X Y : C} (p : X = Y) :
  F.map_iso (eq_to_iso p) = eq_to_iso (congr_arg F.obj p) :=
by ext; cases p; simp

@[simp] lemma eq_to_hom_app {F G : C ⥤ D} (h : F = G) (X : C) :
  (eq_to_hom h : F ⟶ G).app X = eq_to_hom (functor.congr_obj h X) :=
by subst h; refl

lemma nat_trans.congr {F G : C ⥤ D} (α : F ⟶ G) {X Y : C} (h : X = Y) :
  α.app X = F.map (eq_to_hom h) ≫ α.app Y ≫ G.map (eq_to_hom h.symm) :=
by { rw [α.naturality_assoc], simp }

lemma eq_conj_eq_to_hom {X Y : C} (f : X ⟶ Y) :
  f = eq_to_hom rfl ≫ f ≫ eq_to_hom rfl :=
by simp only [category.id_comp, eq_to_hom_refl, category.comp_id]

lemma dcongr_arg {ι : Type*} {F G : ι → C} (α : ∀ i, F i ⟶ G i) {i j : ι} (h : i = j) :
  α i = eq_to_hom (congr_arg F h) ≫ α j ≫ eq_to_hom (congr_arg G h.symm) :=
by { subst h, simp }

end category_theory


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

import category_theory.sites.sheaf_of_types
import category_theory.limits.yoneda
import category_theory.limits.preserves.shapes.equalizers
import category_theory.limits.preserves.shapes.products
import category_theory.concrete_category

/-!
# Sheaves taking values in a category

If C is a category with a Grothendieck topology, we define the notion of a sheaf taking values in
an arbitrary category `A`. We follow the definition in https://stacks.math.columbia.edu/tag/00VR,
noting that the presheaf of sets "defined above" can be seen in the comments between tags 00VQ and
00VR on the page https://stacks.math.columbia.edu/tag/00VL. The advantage of this definition is
that we need no assumptions whatsoever on `A` other than the assumption that the morphisms in `C`
and `A` live in the same universe.

* An `A`-valued presheaf `P : Cᵒᵖ ⥤ A` is defined to be a sheaf (for the topology `J`) iff for
  every `X : A`, the type-valued presheaves of sets given by sending `U : Cᵒᵖ` to `Hom_{A}(X, P U)`
  are all sheaves of sets, see `category_theory.presheaf.is_sheaf`.
* When `A = Type`, this recovers the basic definition of sheaves of sets, see
  `category_theory.is_sheaf_iff_is_sheaf_of_type`.
* An alternate definition when `C` is small, has pullbacks and `A` has products is given by an
  equalizer condition `category_theory.presheaf.is_sheaf'`. This is equivalent to the earlier
  definition, shown in `category_theory.presheaf.is_sheaf_iff_is_sheaf'`.
* When `A = Type`, this is *definitionally* equal to the equalizer condition for presieves in
  `category_theory.sites.sheaf_of_types`.
* When `A` has limits and there is a functor `s : A ⥤ Type` which is faithful, reflects isomorphisms
  and preserves limits, then `P : C^op ⥤ A` is a sheaf iff the underlying presheaf of types
  `P ⋙ s : C^op ⥤ Type` is a sheaf (`category_theory.presheaf.is_sheaf_iff_is_sheaf_forget`).
  Cf https://stacks.math.columbia.edu/tag/0073, which is a weaker version of this statement (it's
  only over spaces, not sites) and https://stacks.math.columbia.edu/tag/00YR (a), which
  additionally assumes filtered colimits.
-/

universes v v' u' u

noncomputable theory

namespace category_theory

open opposite category_theory category limits sieve classical

namespace presheaf

variables {C : Type u} [category.{v} C]
variables {A : Type u'} [category.{v} A]
variables (J : grothendieck_topology C)

-- We follow https://stacks.math.columbia.edu/tag/00VL definition 00VR

/--
A sheaf of A is a presheaf P : C^op => A such that for every X : A, the
presheaf of types given by sending U : C to Hom_{A}(X, P U) is a sheaf of types.

https://stacks.math.columbia.edu/tag/00VR
-/
def is_sheaf (P : Cᵒᵖ ⥤ A) : Prop :=
∀ X : A, presieve.is_sheaf J (P ⋙ coyoneda.obj (op X))

end presheaf

variables {C : Type u} [category.{v} C]
variables (J : grothendieck_topology C)
variables (A : Type u') [category.{v} A]

/-- The category of sheaves taking values in `A` on a grothendieck topology. -/
@[derive category]
def Sheaf : Type* :=
{P : Cᵒᵖ ⥤ A // presheaf.is_sheaf J P}

/-- The inclusion functor from sheaves to presheaves. -/
@[simps {rhs_md := semireducible}, derive [full, faithful]]
def Sheaf_to_presheaf : Sheaf J A ⥤ (Cᵒᵖ ⥤ A) :=
full_subcategory_inclusion (presheaf.is_sheaf J)

lemma is_sheaf_iff_is_sheaf_of_type (P : Cᵒᵖ ⥤ Type v) :
  presheaf.is_sheaf J P ↔ presieve.is_sheaf J P :=
begin
  split,
  { intros hP,
    exact presieve.is_sheaf_iso J (coyoneda.iso_comp_punit _) (hP punit) },
  { intros hP X Y S hS z hz,
    refine ⟨λ x, (hP S hS).amalgamate (λ Z f hf, z f hf x) _, _, _⟩,
    { intros Y₁ Y₂ Z g₁ g₂ f₁ f₂ hf₁ hf₂ h,
      exact congr_fun (hz g₁ g₂ hf₁ hf₂ h) x },
    { intros Z f hf,
      ext x,
      apply presieve.is_sheaf_for.valid_glue },
    { intros y hy,
      ext x,
      apply (hP S hS).is_separated_for.ext,
      intros Y' f hf,
      rw [presieve.is_sheaf_for.valid_glue _ _ _ hf, ← hy _ hf],
      refl } }
end

/--
The category of sheaves taking values in Type is the same as the category of set-valued sheaves.
-/
@[simps]
def Sheaf_equiv_SheafOfTypes : Sheaf J (Type v) ≌ SheafOfTypes J :=
{ functor :=
  { obj := λ S, ⟨S.1, (is_sheaf_iff_is_sheaf_of_type _ _).1 S.2⟩,
    map := λ S₁ S₂ f, f },
  inverse :=
  { obj := λ S, ⟨S.1, (is_sheaf_iff_is_sheaf_of_type _ _).2 S.2⟩,
    map := λ S₁ S₂ f, f },
  unit_iso := nat_iso.of_components (λ X, ⟨𝟙 _, 𝟙 _, by tidy, by tidy⟩) (by tidy),
  counit_iso := nat_iso.of_components (λ X, ⟨𝟙 _, 𝟙 _, by tidy, by tidy⟩) (by tidy) }

instance : inhabited (Sheaf (⊥ : grothendieck_topology C) (Type v)) :=
⟨(Sheaf_equiv_SheafOfTypes _).inverse.obj (default _)⟩

end category_theory

namespace category_theory

open opposite category_theory category limits sieve classical

namespace presheaf

-- Under here is the equalizer story, which is equivalent if A has products (and doesn't
-- make sense otherwise). It's described in https://stacks.math.columbia.edu/tag/00VL,
-- between 00VQ and 00VR.

variables {C : Type v} [small_category C]
variables {A : Type u} [category.{v} A]
variables (J : grothendieck_topology C)
variables {U : C} (R : presieve U)
variables (P : Cᵒᵖ ⥤ A)

section

variables [has_products A]

/--
The middle object of the fork diagram given in Equation (3) of [MM92], as well as the fork diagram
of https://stacks.math.columbia.edu/tag/00VM.
-/
def first_obj : A :=
∏ (λ (f : Σ V, {f : V ⟶ U // R f}), P.obj (op f.1))

/--
The left morphism of the fork diagram given in Equation (3) of [MM92], as well as the fork diagram
of https://stacks.math.columbia.edu/tag/00VM.
-/
def fork_map : P.obj (op U) ⟶ first_obj R P :=
pi.lift (λ f, P.map f.2.1.op)

variables [has_pullbacks C]

/--
The rightmost object of the fork diagram of https://stacks.math.columbia.edu/tag/00VM, which
contains the data used to check a family of elements for a presieve is compatible.
-/
def second_obj : A :=
∏ (λ (fg : (Σ V, {f : V ⟶ U // R f}) × (Σ W, {g : W ⟶ U // R g})),
  P.obj (op (pullback fg.1.2.1 fg.2.2.1)))

/-- The map `pr₀*` of https://stacks.math.columbia.edu/tag/00VM. -/
def first_map : first_obj R P ⟶ second_obj R P :=
pi.lift (λ fg, pi.π _ _ ≫ P.map pullback.fst.op)

/-- The map `pr₁*` of https://stacks.math.columbia.edu/tag/00VM. -/
def second_map : first_obj R P ⟶ second_obj R P :=
pi.lift (λ fg, pi.π _ _ ≫ P.map pullback.snd.op)

lemma w : fork_map R P ≫ first_map R P = fork_map R P ≫ second_map R P :=
begin
  apply limit.hom_ext,
  rintro ⟨⟨Y, f, hf⟩, ⟨Z, g, hg⟩⟩,
  simp only [first_map, second_map, fork_map, limit.lift_π, limit.lift_π_assoc, assoc,
    fan.mk_π_app, subtype.coe_mk, subtype.val_eq_coe],
  rw [← P.map_comp, ← op_comp, pullback.condition],
  simp,
end

/--
An alternative definition of the sheaf condition in terms of equalizers. This is shown to be
equivalent in `category_theory.presheaf.is_sheaf_iff_is_sheaf'`.
-/
def is_sheaf' (P : Cᵒᵖ ⥤ A) : Prop := ∀ (U : C) (R : presieve U) (hR : generate R ∈ J U),
nonempty (is_limit (fork.of_ι _ (w R P)))

/-- (Implementation). An auxiliary lemma to convert between sheaf conditions. -/
def is_sheaf_for_is_sheaf_for' (P : Cᵒᵖ ⥤ A) (s : A ⥤ Type v)
  [Π J, preserves_limits_of_shape (discrete J) s] (U : C) (R : presieve U) :
  is_limit (s.map_cone (fork.of_ι _ (w R P))) ≃
    is_limit (fork.of_ι _ (equalizer.presieve.w (P ⋙ s) R)) :=
begin
  apply equiv.trans (is_limit_map_cone_fork_equiv _ _) _,
  apply (is_limit.postcompose_hom_equiv _ _).symm.trans (is_limit.equiv_iso_limit _),
  { apply nat_iso.of_components _ _,
    { rintro (_ | _),
      { apply preserves_product.iso s },
      { apply preserves_product.iso s } },
    { rintro _ _ (_ | _),
      { ext : 1,
        dsimp [equalizer.presieve.first_map, first_map],
        simp only [limit.lift_π, map_lift_pi_comparison, assoc, fan.mk_π_app, functor.map_comp],
        erw pi_comparison_comp_π_assoc },
      { ext : 1,
        dsimp [equalizer.presieve.second_map, second_map],
        simp only [limit.lift_π, map_lift_pi_comparison, assoc, fan.mk_π_app, functor.map_comp],
        erw pi_comparison_comp_π_assoc },
      { dsimp,
        simp } } },
  { refine fork.ext (iso.refl _) _,
    dsimp [equalizer.fork_map, fork_map],
    simp }
end

/-- The equalizer definition of a sheaf given by `is_sheaf'` is equivalent to `is_sheaf`. -/
theorem is_sheaf_iff_is_sheaf' :
  is_sheaf J P ↔ is_sheaf' J P :=
begin
  split,
  { intros h U R hR,
    refine ⟨_⟩,
    apply coyoneda_jointly_reflects_limits,
    intro X,
    have q : presieve.is_sheaf_for (P ⋙ coyoneda.obj X) _ := h X.unop _ hR,
    rw ←presieve.is_sheaf_for_iff_generate at q,
    rw equalizer.presieve.sheaf_condition at q,
    replace q := classical.choice q,
    apply (is_sheaf_for_is_sheaf_for' _ _ _ _).symm q },
  { intros h U X S hS,
    rw equalizer.presieve.sheaf_condition,
    refine ⟨_⟩,
    refine is_sheaf_for_is_sheaf_for' _ _ _ _ _,
    apply is_limit_of_preserves,
    apply classical.choice (h _ S _),
    simpa }
end

end

section concrete

variables [has_pullbacks C]

/--
For a concrete category `(A, s)` where the forgetful functor `s : A ⥤ Type v` preserves limits and
reflects isomorphisms, and `A` has limits, an `A`-valued presheaf `P : Cᵒᵖ ⥤ A` is a sheaf iff its
underlying `Type`-valued presheaf `P ⋙ s : Cᵒᵖ ⥤ Type` is a sheaf.

Note this lemma applies for "algebraic" categories, eg groups, abelian groups and rings, but not
for the category of topological spaces, topological rings, etc since reflecting isomorphisms doesn't
hold.
-/
lemma is_sheaf_iff_is_sheaf_forget (s : A ⥤ Type v)
  [has_limits A] [preserves_limits s] [reflects_isomorphisms s] :
  is_sheaf J P ↔ is_sheaf J (P ⋙ s) :=
begin
  rw [is_sheaf_iff_is_sheaf', is_sheaf_iff_is_sheaf'],
  apply forall_congr (λ U, _),
  apply ball_congr (λ R hR, _),
  letI : reflects_limits s := reflects_limits_of_reflects_isomorphisms,
  have : is_limit (s.map_cone (fork.of_ι _ (w R P))) ≃ is_limit (fork.of_ι _ (w R (P ⋙ s))) :=
    is_sheaf_for_is_sheaf_for' P s U R,
  rw ←equiv.nonempty_iff_nonempty this,
  split,
  { exact nonempty.map (λ t, is_limit_of_preserves s t) },
  { exact nonempty.map (λ t, is_limit_of_reflects s t) }
end

end concrete

end presheaf

end category_theory


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.category.BddLat
import order.hom.complete_lattice

/-!
# The category of complete lattices

This file defines `CompleteLat`, the category of complete lattices.
-/

universes u

open category_theory

/-- The category of complete lattices. -/
def CompleteLat := bundled complete_lattice

namespace CompleteLat

instance : has_coe_to_sort CompleteLat Type* := bundled.has_coe_to_sort
instance (X : CompleteLat) : complete_lattice X := X.str

/-- Construct a bundled `CompleteLat` from a `complete_lattice`. -/
def of (α : Type*) [complete_lattice α] : CompleteLat := bundled.of α

@[simp] lemma coe_of (α : Type*) [complete_lattice α] : ↥(of α) = α := rfl

instance : inhabited CompleteLat := ⟨of punit⟩

instance : bundled_hom @complete_lattice_hom :=
{ to_fun := λ _ _ _ _, coe_fn,
  id := @complete_lattice_hom.id,
  comp := @complete_lattice_hom.comp,
  hom_ext := λ X Y _ _, by exactI fun_like.coe_injective }
instance : large_category.{u} CompleteLat := bundled_hom.category complete_lattice_hom
instance : concrete_category CompleteLat := bundled_hom.concrete_category complete_lattice_hom

instance has_forget_to_BddLat : has_forget₂ CompleteLat BddLat :=
{ forget₂ := { obj := λ X, BddLat.of X,
               map := λ X Y, complete_lattice_hom.to_bounded_lattice_hom },
  forget_comp := rfl }

/-- Constructs an isomorphism of complete lattices from an order isomorphism between them. -/
@[simps] def iso.mk {α β : CompleteLat.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : CompleteLat ⥤ CompleteLat :=
{ obj := λ X, of Xᵒᵈ, map := λ X Y, complete_lattice_hom.dual }

/-- The equivalence between `CompleteLat` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : CompleteLat ≌ CompleteLat :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end CompleteLat

lemma CompleteLat_dual_comp_forget_to_BddLat :
  CompleteLat.dual ⋙ forget₂ CompleteLat BddLat =
    forget₂ CompleteLat BddLat ⋙ BddLat.dual := rfl


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro

! This file was ported from Lean 3 source module algebra.order.ring.with_top
! leanprover-community/mathlib commit 0111834459f5d7400215223ea95ae38a1265a907
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Hom.Ring
import Mathlib.Algebra.Order.Monoid.WithTop
import Mathlib.Algebra.Order.Ring.Canonical
import Std.Data.Option.Lemmas

/-! # Structures involving `*` and `0` on `WithTop` and `WithBot`
The main results of this section are `WithTop.canonicallyOrderedCommSemiring` and
`WithBot.orderedCommSemiring`.
-/

variable {α : Type _}

namespace WithTop

variable [DecidableEq α]

instance : DecidableEq (WithTop α) := instDecidableEqOption

section Mul

variable [Zero α] [Mul α]

instance : MulZeroClass (WithTop α) where
  zero := 0
  mul m n := if m = 0 ∨ n = 0 then 0 else Option.map₂ (· * ·) m n
  zero_mul _ := if_pos <| Or.inl rfl
  mul_zero _ := if_pos <| Or.inr rfl

theorem mul_def {a b : WithTop α} :
    a * b = (if a = 0 ∨ b = 0 then 0 else Option.map₂ (· * ·) a b : WithTop α) :=
  rfl
#align with_top.mul_def WithTop.mul_def

-- Porting note: commented out @[simp] to placate the `simp can prove this` linter
-- @[simp]
theorem top_mul_top : (⊤ * ⊤ : WithTop α) = ⊤ := by simp [mul_def]; rfl
#align with_top.top_mul_top WithTop.top_mul_top

theorem mul_top' (a : WithTop α) : a * ⊤ = if a = 0 then 0 else ⊤ := by
  induction a using recTopCoe <;> simp [mul_def] <;> rfl
#align with_top.mul_top' WithTop.mul_top'

@[simp] theorem mul_top {a : WithTop α} (h : a ≠ 0) : a * ⊤ = ⊤ := by rw [mul_top', if_neg h]
#align with_top.mul_top WithTop.mul_top

theorem top_mul' (a : WithTop α) : ⊤ * a = if a = 0 then 0 else ⊤ := by
  induction a using recTopCoe <;> simp [mul_def] <;> rfl
#align with_top.top_mul' WithTop.top_mul'

@[simp] theorem top_mul {a : WithTop α} (h : a ≠ 0) : ⊤ * a = ⊤ := by rw [top_mul', if_neg h]
#align with_top.top_mul WithTop.top_mul

theorem mul_eq_top_iff {a b : WithTop α} : a * b = ⊤ ↔ a ≠ 0 ∧ b = ⊤ ∨ a = ⊤ ∧ b ≠ 0 := by
  rw [mul_def, ite_eq_iff, ← none_eq_top, Option.map₂_eq_none_iff]
  have ha : a = 0 → a ≠ none := fun h => h.symm ▸ zero_ne_top
  have hb : b = 0 → b ≠ none := fun h => h.symm ▸ zero_ne_top
  tauto
#align with_top.mul_eq_top_iff WithTop.mul_eq_top_iff

theorem mul_lt_top' [LT α] {a b : WithTop α} (ha : a < ⊤) (hb : b < ⊤) : a * b < ⊤ := by
  rw [WithTop.lt_top_iff_ne_top] at *
  simp only [Ne.def, mul_eq_top_iff, *, and_false, false_and, false_or]
#align with_top.mul_lt_top' WithTop.mul_lt_top'

theorem mul_lt_top [LT α] {a b : WithTop α} (ha : a ≠ ⊤) (hb : b ≠ ⊤) : a * b < ⊤ :=
  mul_lt_top' (WithTop.lt_top_iff_ne_top.2 ha) (WithTop.lt_top_iff_ne_top.2 hb)
#align with_top.mul_lt_top WithTop.mul_lt_top

instance noZeroDivisors [NoZeroDivisors α] : NoZeroDivisors (WithTop α) := by
  refine ⟨fun h₁ => Decidable.by_contradiction <| fun h₂ => ?_⟩
  rw [mul_def, if_neg h₂] at h₁
  rcases Option.mem_map₂_iff.1 h₁ with ⟨a, b, (rfl : _ = _), (rfl : _ = _), hab⟩
  exact h₂ ((eq_zero_or_eq_zero_of_mul_eq_zero hab).imp (congr_arg some) (congr_arg some))

end Mul

section MulZeroClass

variable [MulZeroClass α]

@[simp, norm_cast]
theorem coe_mul {a b : α} : (↑(a * b) : WithTop α) = a * b := by
  by_cases ha : a = 0
  · simp [ha]
  · by_cases hb : b = 0
    · simp [hb]
    · simp [*, mul_def]
      rfl
#align with_top.coe_mul WithTop.coe_mul

theorem mul_coe {b : α} (hb : b ≠ 0) : ∀ {a : WithTop α},
    a * (b : WithTop α) = a.bind fun a : α => ↑(a * b)
  | none =>
    show (if (⊤ : WithTop α) = 0 ∨ (b : WithTop α) = 0 then 0 else ⊤ : WithTop α) = ⊤ by simp [hb]
  | Option.some a => by
    rw [some_eq_coe, ← coe_mul]
    rfl
#align with_top.mul_coe WithTop.mul_coe

@[simp]
theorem untop'_zero_mul (a b : WithTop α) : (a * b).untop' 0 = a.untop' 0 * b.untop' 0 := by
  by_cases ha : a = 0; · rw [ha, zero_mul, ← coe_zero, untop'_coe, zero_mul]
  by_cases hb : b = 0; · rw [hb, mul_zero, ← coe_zero, untop'_coe, mul_zero]
  induction a using WithTop.recTopCoe; · rw [top_mul hb, untop'_top, zero_mul]
  induction b using WithTop.recTopCoe; · rw [mul_top ha, untop'_top, mul_zero]
  rw [← coe_mul, untop'_coe, untop'_coe, untop'_coe]
#align with_top.untop'_zero_mul WithTop.untop'_zero_mul

end MulZeroClass

/-- `Nontrivial α` is needed here as otherwise we have `1 * ⊤ = ⊤` but also `0 * ⊤ = 0`. -/
instance [MulZeroOneClass α] [Nontrivial α] : MulZeroOneClass (WithTop α) :=
  { WithTop.instMulZeroClassWithTop with
    mul := (· * ·)
    one := 1, zero := 0
    one_mul := fun a =>
      match a with
      | ⊤ => mul_top (mt coe_eq_coe.1 one_ne_zero)
      | (a : α) => by rw [← coe_one, ← coe_mul, one_mul],
    mul_one := fun a =>
      match a with
      | ⊤ => top_mul (mt coe_eq_coe.1 one_ne_zero)
      | (a : α) => by rw [← coe_one, ← coe_mul, mul_one] }

/-- A version of `WithTop.map` for `MonoidWithZeroHom`s. -/
@[simps (config := { fullyApplied := false })]
protected def _root_.MonoidWithZeroHom.withTopMap {R S : Type _} [MulZeroOneClass R] [DecidableEq R]
    [Nontrivial R] [MulZeroOneClass S] [DecidableEq S] [Nontrivial S] (f : R →*₀ S)
    (hf : Function.Injective f) : WithTop R →*₀ WithTop S :=
  { f.toZeroHom.withTopMap, f.toMonoidHom.toOneHom.withTopMap with
    toFun := WithTop.map f
    map_mul' := fun x y => by
      have : ∀ z, map f z = 0 ↔ z = 0 := fun z =>
        (Option.map_injective hf).eq_iff' f.toZeroHom.withTopMap.map_zero
      rcases Decidable.eq_or_ne x 0 with (rfl | hx)
      · simp
      rcases Decidable.eq_or_ne y 0 with (rfl | hy)
      · simp
      induction' x using WithTop.recTopCoe with x
      · simp [hy, this]
      induction' y using WithTop.recTopCoe with y
      · have : (f x : WithTop S) ≠ 0 := by simpa [hf.eq_iff' (map_zero f)] using hx
        simp [mul_top hx, mul_top this]
      · simp only [map_coe, ← coe_mul, map_mul] } -- porting note: todo: `simp [← coe_mul]` fails
#align monoid_with_zero_hom.with_top_map MonoidWithZeroHom.withTopMap

instance [SemigroupWithZero α] [NoZeroDivisors α] : SemigroupWithZero (WithTop α) :=
  { WithTop.instMulZeroClassWithTop with
    mul := (· * ·)
    zero := 0
    mul_assoc := fun a b c => by
      rcases eq_or_ne a 0 with (rfl | ha); · simp only [zero_mul]
      rcases eq_or_ne b 0 with (rfl | hb); · simp only [zero_mul, mul_zero]
      rcases eq_or_ne c 0 with (rfl | hc); · simp only [mul_zero]
    -- Porting note: below needed to be rewritten due to changed `simp` behaviour for `coe`
      induction' a using WithTop.recTopCoe with a; · simp [hb, hc]
      induction' b using WithTop.recTopCoe with b; · simp [mul_top ha, top_mul hc]
      induction' c using WithTop.recTopCoe with c
      · rw [mul_top hb, mul_top ha]
        rw [← coe_zero, ne_eq, coe_eq_coe] at ha hb
        simp [ha, hb]
      simp only [← coe_mul, mul_assoc] }

instance monoidWithZero [MonoidWithZero α] [NoZeroDivisors α] [Nontrivial α] :
    MonoidWithZero (WithTop α) :=
  { WithTop.instMulZeroOneClassWithTop, WithTop.instSemigroupWithZeroWithTop with }

instance commMonoidWithZero [CommMonoidWithZero α] [NoZeroDivisors α] [Nontrivial α] :
    CommMonoidWithZero (WithTop α) :=
  { WithTop.monoidWithZero with
    mul := (· * ·)
    zero := 0,
    mul_comm := fun _ _ => ite_congr (propext or_comm) (fun _ => rfl)
      (fun _ => Option.map₂_comm mul_comm) }

variable [CanonicallyOrderedCommSemiring α]

private theorem distrib' (a b c : WithTop α) : (a + b) * c = a * c + b * c := by
  induction' c using WithTop.recTopCoe with c
  · by_cases ha : a = 0 <;> simp [ha]
  · by_cases hc : c = 0
    · simp [hc]
    simp [mul_coe hc]
    cases a <;> cases b
    repeat' first | rfl |exact congr_arg some (add_mul _ _ _)

/-- This instance requires `CanonicallyOrderedCommSemiring` as it is the smallest class
that derives from both `NonAssocNonUnitalSemiring` and `CanonicallyOrderedAddMonoid`, both
of which are required for distributivity. -/
instance commSemiring [Nontrivial α] : CommSemiring (WithTop α) :=
  { WithTop.addCommMonoidWithOne, WithTop.commMonoidWithZero with
    right_distrib := distrib'
    left_distrib := fun a b c => by
      rw [mul_comm, distrib', mul_comm b, mul_comm c] }

instance [Nontrivial α] : CanonicallyOrderedCommSemiring (WithTop α) :=
  { WithTop.commSemiring, WithTop.canonicallyOrderedAddMonoid with
  eq_zero_or_eq_zero_of_mul_eq_zero := eq_zero_or_eq_zero_of_mul_eq_zero}

/-- A version of `WithTop.map` for `RingHom`s. -/
@[simps (config := { fullyApplied := false })]
protected def _root_.RingHom.withTopMap {R S : Type _} [CanonicallyOrderedCommSemiring R]
    [DecidableEq R] [Nontrivial R] [CanonicallyOrderedCommSemiring S] [DecidableEq S] [Nontrivial S]
    (f : R →+* S) (hf : Function.Injective f) : WithTop R →+* WithTop S :=
  {MonoidWithZeroHom.withTopMap f.toMonoidWithZeroHom hf, f.toAddMonoidHom.withTopMap with}
#align ring_hom.with_top_map RingHom.withTopMap

end WithTop

namespace WithBot

variable [DecidableEq α]

instance : DecidableEq (WithBot α) := instDecidableEqOption

section Mul

variable [Zero α] [Mul α]

instance : MulZeroClass (WithBot α) :=
  WithTop.instMulZeroClassWithTop

theorem mul_def {a b : WithBot α} :
    a * b = if a = 0 ∨ b = 0 then (0 : WithBot α) else Option.map₂ (· * ·) a b :=
  rfl
#align with_bot.mul_def WithBot.mul_def

@[simp]
theorem mul_bot {a : WithBot α} (h : a ≠ 0) : a * ⊥ = ⊥ :=
  WithTop.mul_top h
#align with_bot.mul_bot WithBot.mul_bot

@[simp]
theorem bot_mul {a : WithBot α} (h : a ≠ 0) : ⊥ * a = ⊥ :=
  WithTop.top_mul h
#align with_bot.bot_mul WithBot.bot_mul

@[simp]
theorem bot_mul_bot : (⊥ * ⊥ : WithBot α) = ⊥ :=
  WithTop.top_mul_top
#align with_bot.bot_mul_bot WithBot.bot_mul_bot

theorem mul_eq_bot_iff {a b : WithBot α} : a * b = ⊥ ↔ a ≠ 0 ∧ b = ⊥ ∨ a = ⊥ ∧ b ≠ 0 :=
  WithTop.mul_eq_top_iff
#align with_bot.mul_eq_bot_iff WithBot.mul_eq_bot_iff

theorem bot_lt_mul' [LT α] {a b : WithBot α} (ha : ⊥ < a) (hb : ⊥ < b) : ⊥ < a * b :=
  WithTop.mul_lt_top' (α := αᵒᵈ) ha hb
#align with_bot.bot_lt_mul' WithBot.bot_lt_mul'

theorem bot_lt_mul [LT α] {a b : WithBot α} (ha : a ≠ ⊥) (hb : b ≠ ⊥) : ⊥ < a * b :=
  WithTop.mul_lt_top (α := αᵒᵈ) ha hb
#align with_bot.bot_lt_mul WithBot.bot_lt_mul

end Mul

section MulZeroClass

variable [MulZeroClass α]

@[simp, norm_cast] -- porting note: added `simp`
theorem coe_mul {a b : α} : (↑(a * b) : WithBot α) = a * b :=
  WithTop.coe_mul
#align with_bot.coe_mul WithBot.coe_mul

theorem mul_coe {b : α} (hb : b ≠ 0) {a : WithBot α} :
    a * (b : WithBot α) = a.bind fun a : α => ↑(a * b) :=
  WithTop.mul_coe hb
#align with_bot.mul_coe WithBot.mul_coe

end MulZeroClass

/-- `Nontrivial α` is needed here as otherwise we have `1 * ⊥ = ⊥` but also `= 0 * ⊥ = 0`. -/
instance [MulZeroOneClass α] [Nontrivial α] : MulZeroOneClass (WithBot α) :=
  WithTop.instMulZeroOneClassWithTop

instance [MulZeroClass α] [NoZeroDivisors α] : NoZeroDivisors (WithBot α) :=
  WithTop.noZeroDivisors

instance [SemigroupWithZero α] [NoZeroDivisors α] : SemigroupWithZero (WithBot α) :=
  WithTop.instSemigroupWithZeroWithTop

instance [MonoidWithZero α] [NoZeroDivisors α] [Nontrivial α] : MonoidWithZero (WithBot α) :=
  WithTop.monoidWithZero

instance commMonoidWithZero [CommMonoidWithZero α] [NoZeroDivisors α] [Nontrivial α] :
    CommMonoidWithZero (WithBot α) :=
  WithTop.commMonoidWithZero

instance commSemiring [CanonicallyOrderedCommSemiring α] [Nontrivial α] :
    CommSemiring (WithBot α) :=
  WithTop.commSemiring

instance [MulZeroClass α] [Preorder α] [PosMulMono α] : PosMulMono (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk]
    rcases eq_or_ne x 0 with rfl | x0'
    · simp
    lift x to α
    · rintro rfl
      exact (WithBot.bot_lt_coe (0 : α)).not_le x0
    induction a using WithBot.recBotCoe
    · simp_rw [mul_bot x0', bot_le]
    induction b using WithBot.recBotCoe
    · exact absurd h (bot_lt_coe _).not_le
    simp only [← coe_mul, coe_le_coe] at *
    norm_cast at x0
    exact mul_le_mul_of_nonneg_left h x0 ⟩

instance [MulZeroClass α] [Preorder α] [MulPosMono α] : MulPosMono (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk]
    rcases eq_or_ne x 0 with rfl | x0'
    · simp
    lift x to α
    · rintro rfl
      exact (WithBot.bot_lt_coe (0 : α)).not_le x0
    induction a using WithBot.recBotCoe
    · simp_rw [bot_mul x0', bot_le]
    induction b using WithBot.recBotCoe
    · exact absurd h (bot_lt_coe _).not_le
    simp only [← coe_mul, coe_le_coe] at *
    norm_cast at x0
    exact mul_le_mul_of_nonneg_right h x0 ⟩

instance [MulZeroClass α] [Preorder α] [PosMulStrictMono α] : PosMulStrictMono (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk]
    lift x to α using x0.ne_bot
    induction b using WithBot.recBotCoe
    · exact absurd h not_lt_bot
    induction a using WithBot.recBotCoe
    · simp_rw [mul_bot x0.ne.symm, ← coe_mul, bot_lt_coe]
    simp only [← coe_mul, coe_lt_coe] at *
    norm_cast at x0
    exact mul_lt_mul_of_pos_left h x0 ⟩

instance [MulZeroClass α] [Preorder α] [MulPosStrictMono α] : MulPosStrictMono (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk]
    lift x to α using x0.ne_bot
    induction b using WithBot.recBotCoe
    · exact absurd h not_lt_bot
    induction a using WithBot.recBotCoe
    · simp_rw [bot_mul x0.ne.symm, ← coe_mul, bot_lt_coe]
    simp only [← coe_mul, coe_lt_coe] at *
    norm_cast at x0
    exact mul_lt_mul_of_pos_right h x0 ⟩

instance [MulZeroClass α] [Preorder α] [PosMulReflectLT α] : PosMulReflectLT (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk] at h
    rcases eq_or_ne x 0 with rfl | x0'
    · simp at h
    lift x to α
    · rintro rfl
      exact (WithBot.bot_lt_coe (0 : α)).not_le x0
    induction b using WithBot.recBotCoe
    · rw [mul_bot x0'] at h
      exact absurd h bot_le.not_lt
    induction a using WithBot.recBotCoe
    · exact WithBot.bot_lt_coe _
    simp only [← coe_mul, coe_lt_coe] at *
    norm_cast at x0
    exact lt_of_mul_lt_mul_left h x0 ⟩

instance [MulZeroClass α] [Preorder α] [MulPosReflectLT α] : MulPosReflectLT (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk] at h
    rcases eq_or_ne x 0 with rfl | x0'
    · simp at h
    lift x to α
    · rintro rfl
      exact (WithBot.bot_lt_coe (0 : α)).not_le x0
    induction b using WithBot.recBotCoe
    · rw [bot_mul x0'] at h
      exact absurd h bot_le.not_lt
    induction a using WithBot.recBotCoe
    · exact WithBot.bot_lt_coe _
    simp only [← coe_mul, coe_lt_coe] at *
    norm_cast at x0
    exact lt_of_mul_lt_mul_right h x0 ⟩

instance [MulZeroClass α] [Preorder α] [PosMulMonoRev α] : PosMulMonoRev (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk] at h
    lift x to α using x0.ne_bot
    induction a using WithBot.recBotCoe
    · exact bot_le
    induction b using WithBot.recBotCoe
    · rw [mul_bot x0.ne.symm, ← coe_mul] at h
      exact absurd h (bot_lt_coe _).not_le
    simp only [← coe_mul, coe_le_coe] at *
    norm_cast at x0
    exact le_of_mul_le_mul_left h x0 ⟩

instance [MulZeroClass α] [Preorder α] [MulPosMonoRev α] : MulPosMonoRev (WithBot α) :=
  ⟨by
    intro ⟨x, x0⟩ a b h
    simp only [Subtype.coe_mk] at h
    lift x to α using x0.ne_bot
    induction a using WithBot.recBotCoe
    · exact bot_le
    induction b using WithBot.recBotCoe
    · rw [bot_mul x0.ne.symm, ← coe_mul] at h
      exact absurd h (bot_lt_coe _).not_le
    simp only [← coe_mul, coe_le_coe] at *
    norm_cast at x0
    exact le_of_mul_le_mul_right h x0 ⟩

instance orderedCommSemiring [CanonicallyOrderedCommSemiring α] [Nontrivial α] :
    OrderedCommSemiring (WithBot α) :=
  { WithBot.zeroLEOneClass, WithBot.orderedAddCommMonoid, WithBot.commSemiring with
    mul_le_mul_of_nonneg_left  := fun _ _ _ => mul_le_mul_of_nonneg_left
    mul_le_mul_of_nonneg_right := fun _ _ _ => mul_le_mul_of_nonneg_right }

end WithBot