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

! This file was ported from Lean 3 source module algebraic_geometry.Gamma_Spec_adjunction
! leanprover-community/mathlib commit d39590fc8728fbf6743249802486f8c91ffe07bc
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.AlgebraicGeometry.Scheme
import Mathbin.CategoryTheory.Adjunction.Limits
import Mathbin.CategoryTheory.Adjunction.Reflective

/-!
# Adjunction between `Γ` and `Spec`

We define the adjunction `Γ_Spec.adjunction : Γ ⊣ Spec` by defining the unit (`to_Γ_Spec`,
in multiple steps in this file) and counit (done in Spec.lean) and checking that they satisfy
the left and right triangle identities. The constructions and proofs make use of
maps and lemmas defined and proved in structure_sheaf.lean extensively.

Notice that since the adjunction is between contravariant functors, you get to choose
one of the two categories to have arrows reversed, and it is equally valid to present
the adjunction as `Spec ⊣ Γ` (`Spec.to_LocallyRingedSpace.right_op ⊣ Γ`), in which
case the unit and the counit would switch to each other.

## Main definition

* `algebraic_geometry.identity_to_Γ_Spec` : The natural transformation `𝟭 _ ⟶ Γ ⋙ Spec`.
* `algebraic_geometry.Γ_Spec.LocallyRingedSpace_adjunction` : The adjunction `Γ ⊣ Spec` from
  `CommRingᵒᵖ` to `LocallyRingedSpace`.
* `algebraic_geometry.Γ_Spec.adjunction` : The adjunction `Γ ⊣ Spec` from
  `CommRingᵒᵖ` to `Scheme`.

-/

noncomputable section

universe u

open PrimeSpectrum

namespace AlgebraicGeometry

open Opposite

open CategoryTheory

open StructureSheaf

open Spec (structureSheaf)

open TopologicalSpace

open AlgebraicGeometry.LocallyRingedSpace

open TopCat.Presheaf

open TopCat.Presheaf.SheafCondition

namespace LocallyRingedSpace

variable (X : LocallyRingedSpace.{u})

/-- The map from the global sections to a stalk. -/
def ΓToStalk (x : X) : Γ.obj (op X) ⟶ X.Presheaf.stalk x :=
  X.Presheaf.germ (⟨x, trivial⟩ : (⊤ : Opens X))
#align algebraic_geometry.LocallyRingedSpace.Γ_to_stalk AlgebraicGeometry.LocallyRingedSpace.ΓToStalk

/-- The canonical map from the underlying set to the prime spectrum of `Γ(X)`. -/
def toΓSpecFun : X → PrimeSpectrum (Γ.obj (op X)) := fun x =>
  comap (X.ΓToStalk x) (LocalRing.closedPoint (X.Presheaf.stalk x))
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_fun AlgebraicGeometry.LocallyRingedSpace.toΓSpecFun

theorem not_mem_prime_iff_unit_in_stalk (r : Γ.obj (op X)) (x : X) :
    r ∉ (X.toΓSpecFun x).asIdeal ↔ IsUnit (X.ΓToStalk x r) := by
  erw [LocalRing.mem_maximalIdeal, Classical.not_not]
#align algebraic_geometry.LocallyRingedSpace.not_mem_prime_iff_unit_in_stalk AlgebraicGeometry.LocallyRingedSpace.not_mem_prime_iff_unit_in_stalk

/-- The preimage of a basic open in `Spec Γ(X)` under the unit is the basic
open in `X` defined by the same element (they are equal as sets). -/
theorem to_Γ_Spec_preim_basicOpen_eq (r : Γ.obj (op X)) :
    X.toΓSpecFun ⁻¹' (basicOpen r).1 = (X.toRingedSpace.basicOpen r).1 :=
  by
  ext
  erw [X.to_RingedSpace.mem_top_basic_open]
  apply not_mem_prime_iff_unit_in_stalk
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_preim_basic_open_eq AlgebraicGeometry.LocallyRingedSpace.to_Γ_Spec_preim_basicOpen_eq

/-- `to_Γ_Spec_fun` is continuous. -/
theorem to_Γ_Spec_continuous : Continuous X.toΓSpecFun :=
  by
  apply is_topological_basis_basic_opens.continuous
  rintro _ ⟨r, rfl⟩
  erw [X.to_Γ_Spec_preim_basic_open_eq r]
  exact (X.to_RingedSpace.basic_open r).2
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_continuous AlgebraicGeometry.LocallyRingedSpace.to_Γ_Spec_continuous

/-- The canonical (bundled) continuous map from the underlying topological
space of `X` to the prime spectrum of its global sections. -/
@[simps]
def toΓSpecBase : X.toTop ⟶ Spec.topObj (Γ.obj (op X))
    where
  toFun := X.toΓSpecFun
  continuous_toFun := X.to_Γ_Spec_continuous
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_base AlgebraicGeometry.LocallyRingedSpace.toΓSpecBase

variable (r : Γ.obj (op X))

/-- The preimage in `X` of a basic open in `Spec Γ(X)` (as an open set). -/
abbrev toΓSpecMapBasicOpen : Opens X :=
  (Opens.map X.toΓSpecBase).obj (basicOpen r)
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_map_basic_open AlgebraicGeometry.LocallyRingedSpace.toΓSpecMapBasicOpen

/-- The preimage is the basic open in `X` defined by the same element `r`. -/
theorem toΓSpecMapBasicOpen_eq : X.toΓSpecMapBasicOpen r = X.toRingedSpace.basicOpen r :=
  Opens.ext (X.to_Γ_Spec_preim_basicOpen_eq r)
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_map_basic_open_eq AlgebraicGeometry.LocallyRingedSpace.toΓSpecMapBasicOpen_eq

/-- The map from the global sections `Γ(X)` to the sections on the (preimage of) a basic open. -/
abbrev toToΓSpecMapBasicOpen :
    X.Presheaf.obj (op ⊤) ⟶ X.Presheaf.obj (op <| X.toΓSpecMapBasicOpen r) :=
  X.Presheaf.map (X.toΓSpecMapBasicOpen r).le_top.op
#align algebraic_geometry.LocallyRingedSpace.to_to_Γ_Spec_map_basic_open AlgebraicGeometry.LocallyRingedSpace.toToΓSpecMapBasicOpen

/-- `r` is a unit as a section on the basic open defined by `r`. -/
theorem isUnit_res_toΓSpecMapBasicOpen : IsUnit (X.toToΓSpecMapBasicOpen r r) :=
  by
  convert(X.presheaf.map <| (eq_to_hom <| X.to_Γ_Spec_map_basic_open_eq r).op).isUnit_map
      (X.to_RingedSpace.is_unit_res_basic_open r)
  rw [← comp_apply]
  erw [← functor.map_comp]
  congr
#align algebraic_geometry.LocallyRingedSpace.is_unit_res_to_Γ_Spec_map_basic_open AlgebraicGeometry.LocallyRingedSpace.isUnit_res_toΓSpecMapBasicOpen

/-- Define the sheaf hom on individual basic opens for the unit. -/
def toΓSpecCApp :
    (structureSheaf <| Γ.obj <| op X).val.obj (op <| basicOpen r) ⟶
      X.Presheaf.obj (op <| X.toΓSpecMapBasicOpen r) :=
  IsLocalization.Away.lift r (isUnit_res_toΓSpecMapBasicOpen _ r)
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_c_app AlgebraicGeometry.LocallyRingedSpace.toΓSpecCApp

/-- Characterization of the sheaf hom on basic opens,
    direction ← (next lemma) is used at various places, but → is not used in this file. -/
theorem toΓSpecCApp_iff
    (f :
      (structureSheaf <| Γ.obj <| op X).val.obj (op <| basicOpen r) ⟶
        X.Presheaf.obj (op <| X.toΓSpecMapBasicOpen r)) :
    toOpen _ (basicOpen r) ≫ f = X.toToΓSpecMapBasicOpen r ↔ f = X.toΓSpecCApp r :=
  by
  rw [← IsLocalization.Away.AwayMap.lift_comp r (X.is_unit_res_to_Γ_Spec_map_basic_open r)]
  pick_goal 5; exact is_localization.to_basic_open _ r
  constructor
  · intro h
    refine' IsLocalization.ringHom_ext _ _
    pick_goal 5
    exact is_localization.to_basic_open _ r
    exact h
  apply congr_arg
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_c_app_iff AlgebraicGeometry.LocallyRingedSpace.toΓSpecCApp_iff

theorem toΓSpecCApp_spec : toOpen _ (basicOpen r) ≫ X.toΓSpecCApp r = X.toToΓSpecMapBasicOpen r :=
  (X.toΓSpecCApp_iff r _).2 rfl
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_c_app_spec AlgebraicGeometry.LocallyRingedSpace.toΓSpecCApp_spec

/-- The sheaf hom on all basic opens, commuting with restrictions. -/
def toΓSpecCBasicOpens :
    (inducedFunctor basicOpen).op ⋙ (structureSheaf (Γ.obj (op X))).1 ⟶
      (inducedFunctor basicOpen).op ⋙ ((TopCat.Sheaf.pushforward X.toΓSpecBase).obj X.𝒪).1
    where
  app r := X.toΓSpecCApp r.unop
  naturality' r s f :=
    by
    apply (structure_sheaf.to_basic_open_epi (Γ.obj (op X)) r.unop).1
    simp only [← category.assoc]
    erw [X.to_Γ_Spec_c_app_spec r.unop]
    convert X.to_Γ_Spec_c_app_spec s.unop
    symm
    apply X.presheaf.map_comp
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_c_basic_opens AlgebraicGeometry.LocallyRingedSpace.toΓSpecCBasicOpens

/-- The canonical morphism of sheafed spaces from `X` to the spectrum of its global sections. -/
@[simps]
def toΓSpecSheafedSpace : X.toSheafedSpace ⟶ Spec.toSheafedSpace.obj (op (Γ.obj (op X)))
    where
  base := X.toΓSpecBase
  c :=
    TopCat.Sheaf.restrictHomEquivHom (structureSheaf (Γ.obj (op X))).1 _ isBasis_basic_opens
      X.toΓSpecCBasicOpens
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_SheafedSpace AlgebraicGeometry.LocallyRingedSpace.toΓSpecSheafedSpace

theorem toΓSpecSheafedSpace_app_eq :
    X.toΓSpecSheafedSpace.c.app (op (basicOpen r)) = X.toΓSpecCApp r :=
  TopCat.Sheaf.extend_hom_app _ _ _ _ _
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_SheafedSpace_app_eq AlgebraicGeometry.LocallyRingedSpace.toΓSpecSheafedSpace_app_eq

theorem toΓSpecSheafedSpace_app_spec (r : Γ.obj (op X)) :
    toOpen _ (basicOpen r) ≫ X.toΓSpecSheafedSpace.c.app (op (basicOpen r)) =
      X.toToΓSpecMapBasicOpen r :=
  (X.toΓSpecSheafedSpace_app_eq r).symm ▸ X.toΓSpecCApp_spec r
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec_SheafedSpace_app_spec AlgebraicGeometry.LocallyRingedSpace.toΓSpecSheafedSpace_app_spec

/-- The map on stalks induced by the unit commutes with maps from `Γ(X)` to
    stalks (in `Spec Γ(X)` and in `X`). -/
theorem toStalk_stalkMap_to_Γ_Spec (x : X) :
    toStalk _ _ ≫ PresheafedSpace.stalkMap X.toΓSpecSheafedSpace x = X.ΓToStalk x :=
  by
  rw [PresheafedSpace.stalk_map]
  erw [←
    to_open_germ _ (basic_open (1 : Γ.obj (op X)))
      ⟨X.to_Γ_Spec_fun x, by rw [basic_open_one] <;> trivial⟩]
  rw [← category.assoc, category.assoc (to_open _ _)]
  erw [stalk_functor_map_germ]
  rw [← category.assoc (to_open _ _), X.to_Γ_Spec_SheafedSpace_app_spec 1]
  unfold Γ_to_stalk
  rw [← stalk_pushforward_germ _ X.to_Γ_Spec_base X.presheaf ⊤]
  congr 1
  change (X.to_Γ_Spec_base _* X.presheaf).map le_top.hom.op ≫ _ = _
  apply germ_res
#align algebraic_geometry.LocallyRingedSpace.to_stalk_stalk_map_to_Γ_Spec AlgebraicGeometry.LocallyRingedSpace.toStalk_stalkMap_to_Γ_Spec

/-- The canonical morphism from `X` to the spectrum of its global sections. -/
@[simps val_base]
def toΓSpec : X ⟶ Spec.locallyRingedSpaceObj (Γ.obj (op X))
    where
  val := X.toΓSpecSheafedSpace
  Prop := by
    intro x
    let p : PrimeSpectrum (Γ.obj (op X)) := X.to_Γ_Spec_fun x
    constructor
    -- show stalk map is local hom ↓
    let S := (structure_sheaf _).Presheaf.stalk p
    rintro (t : S) ht
    obtain ⟨⟨r, s⟩, he⟩ := IsLocalization.surj p.as_ideal.prime_compl t
    dsimp at he
    apply isUnit_of_mul_isUnit_left
    rw [he]
    refine' IsLocalization.map_units S (⟨r, _⟩ : p.as_ideal.prime_compl)
    apply (not_mem_prime_iff_unit_in_stalk _ _ _).mpr
    rw [← to_stalk_stalk_map_to_Γ_Spec, comp_apply]
    erw [← he]
    rw [RingHom.map_mul]
    exact
      ht.mul
        ((IsLocalization.map_units S s : _).map
          (PresheafedSpace.stalk_map X.to_Γ_Spec_SheafedSpace x))
#align algebraic_geometry.LocallyRingedSpace.to_Γ_Spec AlgebraicGeometry.LocallyRingedSpace.toΓSpec

theorem comp_ring_hom_ext {X : LocallyRingedSpace} {R : CommRingCat} {f : R ⟶ Γ.obj (op X)}
    {β : X ⟶ Spec.locallyRingedSpaceObj R}
    (w : X.toΓSpec.1.base ≫ (Spec.locallyRingedSpaceMap f).1.base = β.1.base)
    (h :
      ∀ r : R,
        f ≫ X.Presheaf.map (homOfLE le_top : (Opens.map β.1.base).obj (basicOpen r) ⟶ _).op =
          toOpen R (basicOpen r) ≫ β.1.c.app (op (basicOpen r))) :
    X.toΓSpec ≫ Spec.locallyRingedSpaceMap f = β :=
  by
  ext1
  apply Spec.basic_open_hom_ext
  · intro r _
    rw [LocallyRingedSpace.comp_val_c_app]
    erw [to_open_comp_comap_assoc]
    rw [category.assoc]
    erw [to_Γ_Spec_SheafedSpace_app_spec, ← X.presheaf.map_comp]
    convert h r
  exact w
#align algebraic_geometry.LocallyRingedSpace.comp_ring_hom_ext AlgebraicGeometry.LocallyRingedSpace.comp_ring_hom_ext

/-- `to_Spec_Γ _` is an isomorphism so these are mutually two-sided inverses. -/
theorem Γ_Spec_left_triangle : toSpecΓ (Γ.obj (op X)) ≫ X.toΓSpec.1.c.app (op ⊤) = 𝟙 _ :=
  by
  unfold to_Spec_Γ
  rw [← to_open_res _ (basic_open (1 : Γ.obj (op X))) ⊤ (eq_to_hom basic_open_one.symm)]
  erw [category.assoc]
  rw [nat_trans.naturality, ← category.assoc]
  erw [X.to_Γ_Spec_SheafedSpace_app_spec 1, ← functor.map_comp]
  convert eq_to_hom_map X.presheaf _; rfl
#align algebraic_geometry.LocallyRingedSpace.Γ_Spec_left_triangle AlgebraicGeometry.LocallyRingedSpace.Γ_Spec_left_triangle

end LocallyRingedSpace

/-- The unit as a natural transformation. -/
def identityToΓSpec : 𝟭 LocallyRingedSpace.{u} ⟶ Γ.rightOp ⋙ Spec.toLocallyRingedSpace
    where
  app := LocallyRingedSpace.toΓSpec
  naturality' X Y f := by
    symm
    apply LocallyRingedSpace.comp_ring_hom_ext
    · ext1 x
      dsimp [Spec.Top_map, LocallyRingedSpace.to_Γ_Spec_fun]
      rw [← LocalRing.comap_closedPoint (PresheafedSpace.stalk_map _ x), ←
        PrimeSpectrum.comap_comp_apply, ← PrimeSpectrum.comap_comp_apply]
      congr 2
      exact (PresheafedSpace.stalk_map_germ f.1 ⊤ ⟨x, trivial⟩).symm
      infer_instance
    · intro r
      rw [LocallyRingedSpace.comp_val_c_app, ← category.assoc]
      erw [Y.to_Γ_Spec_SheafedSpace_app_spec, f.1.c.naturality]
      rfl
#align algebraic_geometry.identity_to_Γ_Spec AlgebraicGeometry.identityToΓSpec

namespace ΓSpec

theorem left_triangle (X : LocallyRingedSpace) :
    specΓIdentity.inv.app (Γ.obj (op X)) ≫ (identityToΓSpec.app X).val.c.app (op ⊤) = 𝟙 _ :=
  X.Γ_Spec_left_triangle
#align algebraic_geometry.Γ_Spec.left_triangle AlgebraicGeometry.ΓSpec.left_triangle

/-- `Spec_Γ_identity` is iso so these are mutually two-sided inverses. -/
theorem right_triangle (R : CommRingCat) :
    identityToΓSpec.app (Spec.toLocallyRingedSpace.obj <| op R) ≫
        Spec.toLocallyRingedSpace.map (specΓIdentity.inv.app R).op =
      𝟙 _ :=
  by
  apply LocallyRingedSpace.comp_ring_hom_ext
  · ext ((p : PrimeSpectrum R)x)
    erw [←
      IsLocalization.AtPrime.to_map_mem_maximal_iff ((structure_sheaf R).Presheaf.stalk p)
        p.as_ideal x]
    rfl
  · intro r
    apply to_open_res
#align algebraic_geometry.Γ_Spec.right_triangle AlgebraicGeometry.ΓSpec.right_triangle

-- Removing this makes the following definition time out.
/-- The adjunction `Γ ⊣ Spec` from `CommRingᵒᵖ` to `LocallyRingedSpace`. -/
@[simps Unit counit]
def locallyRingedSpaceAdjunction : Γ.rightOp ⊣ Spec.toLocallyRingedSpace :=
  Adjunction.mkOfUnitCounit
    { Unit := identityToΓSpec
      counit := (NatIso.op specΓIdentity).inv
      left_triangle := by
        ext X
        erw [category.id_comp]
        exact congr_arg Quiver.Hom.op (left_triangle X)
      right_triangle := by
        ext1
        ext1 R
        erw [category.id_comp]
        exact right_triangle R.unop }
#align algebraic_geometry.Γ_Spec.LocallyRingedSpace_adjunction AlgebraicGeometry.ΓSpec.locallyRingedSpaceAdjunction

attribute [local semireducible] Spec.to_LocallyRingedSpace

/-- The adjunction `Γ ⊣ Spec` from `CommRingᵒᵖ` to `Scheme`. -/
def adjunction : Scheme.Γ.rightOp ⊣ Scheme.spec :=
  locallyRingedSpaceAdjunction.restrictFullyFaithful Scheme.forgetToLocallyRingedSpace (𝟭 _)
    (NatIso.ofComponents (fun X => Iso.refl _) fun _ _ f => by simpa)
    (NatIso.ofComponents (fun X => Iso.refl _) fun _ _ f => by simpa)
#align algebraic_geometry.Γ_Spec.adjunction AlgebraicGeometry.ΓSpec.adjunction

theorem adjunction_homEquiv_apply {X : Scheme} {R : CommRingCatᵒᵖ}
    (f : (op <| Scheme.Γ.obj <| op X) ⟶ R) :
    ΓSpec.adjunction.homEquiv X R f = locallyRingedSpaceAdjunction.homEquiv X.1 R f :=
  by
  dsimp [adjunction, adjunction.restrict_fully_faithful]
  simp
#align algebraic_geometry.Γ_Spec.adjunction_hom_equiv_apply AlgebraicGeometry.ΓSpec.adjunction_homEquiv_apply

theorem adjunction_homEquiv (X : Scheme) (R : CommRingCatᵒᵖ) :
    ΓSpec.adjunction.homEquiv X R = locallyRingedSpaceAdjunction.homEquiv X.1 R :=
  Equiv.ext fun f => adjunction_homEquiv_apply f
#align algebraic_geometry.Γ_Spec.adjunction_hom_equiv AlgebraicGeometry.ΓSpec.adjunction_homEquiv

theorem adjunction_homEquiv_symm_apply {X : Scheme} {R : CommRingCatᵒᵖ}
    (f : X ⟶ Scheme.spec.obj R) :
    (ΓSpec.adjunction.homEquiv X R).symm f = (locallyRingedSpaceAdjunction.homEquiv X.1 R).symm f :=
  by
  congr 2
  exact adjunction_hom_equiv _ _
#align algebraic_geometry.Γ_Spec.adjunction_hom_equiv_symm_apply AlgebraicGeometry.ΓSpec.adjunction_homEquiv_symm_apply

@[simp]
theorem adjunction_counit_app {R : CommRingCatᵒᵖ} :
    ΓSpec.adjunction.counit.app R = locallyRingedSpaceAdjunction.counit.app R :=
  by
  rw [← adjunction.hom_equiv_symm_id, ← adjunction.hom_equiv_symm_id,
    adjunction_hom_equiv_symm_apply]
  rfl
#align algebraic_geometry.Γ_Spec.adjunction_counit_app AlgebraicGeometry.ΓSpec.adjunction_counit_app

@[simp]
theorem adjunction_unit_app {X : Scheme} :
    ΓSpec.adjunction.Unit.app X = locallyRingedSpaceAdjunction.Unit.app X.1 :=
  by
  rw [← adjunction.hom_equiv_id, ← adjunction.hom_equiv_id, adjunction_hom_equiv_apply]
  rfl
#align algebraic_geometry.Γ_Spec.adjunction_unit_app AlgebraicGeometry.ΓSpec.adjunction_unit_app

attribute [local semireducible] LocallyRingedSpace_adjunction Γ_Spec.adjunction

instance isIso_locallyRingedSpaceAdjunction_counit : IsIso locallyRingedSpaceAdjunction.counit :=
  IsIso.of_iso_inv _
#align algebraic_geometry.Γ_Spec.is_iso_LocallyRingedSpace_adjunction_counit AlgebraicGeometry.ΓSpec.isIso_locallyRingedSpaceAdjunction_counit

instance isIso_adjunction_counit : IsIso ΓSpec.adjunction.counit :=
  by
  apply (config := { instances := false }) nat_iso.is_iso_of_is_iso_app
  intro R
  rw [adjunction_counit_app]
  infer_instance
#align algebraic_geometry.Γ_Spec.is_iso_adjunction_counit AlgebraicGeometry.ΓSpec.isIso_adjunction_counit

-- This is just
-- `(Γ_Spec.adjunction.unit.app X).1.c.app (op ⊤) = Spec_Γ_identity.hom.app (X.presheaf.obj (op ⊤))`
-- But lean times out when trying to unify the types of the two sides.
theorem adjunction_unit_app_app_top (X : Scheme) :
    @Eq
      ((Scheme.spec.obj (op <| X.Presheaf.obj (op ⊤))).Presheaf.obj (op ⊤) ⟶
        ((ΓSpec.adjunction.Unit.app X).1.base _* X.Presheaf).obj (op ⊤))
      ((ΓSpec.adjunction.Unit.app X).val.c.app (op ⊤))
      (specΓIdentity.Hom.app (X.Presheaf.obj (op ⊤))) :=
  by
  have := congr_app Γ_Spec.adjunction.left_triangle X
  dsimp at this
  rw [← is_iso.eq_comp_inv] at this
  simp only [Γ_Spec.LocallyRingedSpace_adjunction_counit, nat_trans.op_app, category.id_comp,
    Γ_Spec.adjunction_counit_app] at this
  rw [← op_inv, nat_iso.inv_inv_app, quiver.hom.op_inj.eq_iff] at this
  exact this
#align algebraic_geometry.Γ_Spec.adjunction_unit_app_app_top AlgebraicGeometry.ΓSpec.adjunction_unit_app_app_top

end ΓSpec

/-! Immediate consequences of the adjunction. -/

/-- Spec preserves limits. -/
instance : Limits.PreservesLimits Spec.toLocallyRingedSpace :=
  ΓSpec.locallyRingedSpaceAdjunction.rightAdjointPreservesLimits

instance Spec.preservesLimits : Limits.preservesLimits Scheme.spec :=
  ΓSpec.adjunction.rightAdjointPreservesLimits
#align algebraic_geometry.Spec.preserves_limits AlgebraicGeometry.Spec.preservesLimits

/-- Spec is a full functor. -/
instance : Full Spec.toLocallyRingedSpace :=
  rFullOfCounitIsIso ΓSpec.locallyRingedSpaceAdjunction

instance Spec.full : Full Scheme.spec :=
  rFullOfCounitIsIso ΓSpec.adjunction
#align algebraic_geometry.Spec.full AlgebraicGeometry.Spec.full

/-- Spec is a faithful functor. -/
instance : Faithful Spec.toLocallyRingedSpace :=
  R_faithful_of_counit_isIso ΓSpec.locallyRingedSpaceAdjunction

instance Spec.faithful : Faithful Scheme.spec :=
  R_faithful_of_counit_isIso ΓSpec.adjunction
#align algebraic_geometry.Spec.faithful AlgebraicGeometry.Spec.faithful

instance : IsRightAdjoint Spec.toLocallyRingedSpace :=
  ⟨_, ΓSpec.locallyRingedSpaceAdjunction⟩

instance : IsRightAdjoint Scheme.spec :=
  ⟨_, ΓSpec.adjunction⟩

instance : Reflective Spec.toLocallyRingedSpace :=
  ⟨⟩

instance Spec.reflective : Reflective Scheme.spec :=
  ⟨⟩
#align algebraic_geometry.Spec.reflective AlgebraicGeometry.Spec.reflective

end AlgebraicGeometry


namespace hidden

constant and : Prop → Prop → Prop
constant or : Prop → Prop → Prop
constant imp : Prop → Prop → Prop
constant neg : Prop → Prop
constant top : Prop
constant bot : Prop

notation a `or` b := or a b
notation a `imp` b := imp a b
notation a `and` b := and a b

axiom cl₁ : ∀ {a b : Prop}, a → (a imp b) → b
axiom cl₂ : ∀ {a b : Prop}, a imp (b imp a)
axiom cl₃ : ∀ {a b c : Prop}, (a imp (b imp c)) imp ((a imp b) imp (a imp c))
axiom cl₄ : ∀ {a b : Prop}, (a and b) imp a
axiom cl₅ : ∀ {a b : Prop}, (a and b) imp b
axiom cl₆ : ∀ {a b : Prop}, a imp (b imp (a and b))
axiom cl₇ : ∀ {a b : Prop}, a imp (a or b)
axiom cl₈ : ∀ {a b : Prop}, b imp (a or b)
axiom cl₉ : ∀ {a b c : Prop}, (a imp c) imp ((b imp c) imp ((a or b) imp c))
axiom cl₁₀ : ∀ {a b : Prop}, (a imp b) imp ((a imp (neg b)) imp (neg a))
axiom cl₁₁ : ∀ {a : Prop}, (neg (neg a)) imp a
axiom cl₁₂ : top
axiom cl₁₃ : ∀ {a : Prop}, bot imp a

example {a : Prop} : a imp a :=
    have h₁ : (a imp ((a imp a) imp a)) imp ((a imp (a imp a)) imp (a imp a)), from cl₃,
    have h₂ : a imp ((a imp a) imp a), from cl₂,
    have h₃ : ((a imp (a imp a)) imp (a imp a)), from cl₁ h₂ h₁,
    have h₄ : a imp (a imp a), from cl₂,
    show a imp a, from cl₁ h₄ h₃

theorem cl₁₄ {a b c : Prop} (h₁ : a imp b) (h₂ : b imp c) : a imp c :=
    have h₃ : (a imp (b imp c)) imp ((a imp b) imp (a imp c)), from cl₃,
    have h₄ : (b imp c) imp (a imp (b imp c)), from cl₂,
    have h₅ : a imp (b imp c), from cl₁ h₂ h₄,
    have h₆ : (a imp b) imp (a imp c), from cl₁ h₅ h₃,
    show a imp c, from cl₁ h₁ h₆

end hidden


import order.bounded_lattice
import order.complete_lattice
import prop

open lattice

class has_impl (α : Type*) :=
(impl : α → α → α)

-- infixr ` ⇒ `:60 := has_impl.impl
infixr ` ⇒ ` := has_impl.impl

set_option old_structure_cmd true

class heyting_algebra (α : Type*) extends bounded_lattice α, has_impl α :=
(le_impl_iff : ∀ x y z : α, z ≤ (x ⇒ y) ↔ x ⊓ z ≤ y)

class complete_heyting_algebra (α : Type*) extends complete_lattice α, heyting_algebra α
-- (le_impl_iff : ∀ x y z : α, z ≤ (x ⇒ y) ↔ x ⊓ z ≤ y)

variables {α : Type*}

namespace heyting_algebra

variables [heyting_algebra α]
variables {x y z : α}

lemma inf_div_le : x ⊓ (x ⇒ y) ≤ y :=
(le_impl_iff _ _ _).mp (le_refl _)

lemma le_impl (h : x ⊓ z ≤ y) : z ≤ (x ⇒ y) :=
(le_impl_iff _ _ _).mpr h

end heyting_algebra

class residuated_lattice (α : Type*) extends lattice α, monoid α, has_div α, has_sdiff α :=
(le_div_iff :   ∀ x y z : α, z ≤ x / y ↔ x * z ≤ y)
(le_sdiff_iff : ∀ x y z : α, z ≤ y \ x ↔ z * x ≤ y)

class comm_residuated_lattice (α : Type*)
extends comm_monoid α, residuated_lattice α

namespace residuated_lattice

end residuated_lattice

class bunched_implication_logic (α : Type*)
extends comm_residuated_lattice α, complete_heyting_algebra α

open separation separation.hProp
-- #exit

instance {value} : complete_lattice (hProp value) :=
pi.complete_lattice

instance {value} : complete_heyting_algebra (hProp value) :=
{ impl := λ x y h, x h → y h,
  le_impl_iff := λ x y z, ⟨λ H h ⟨hx,hz⟩, H _ hz hx,λ H, λ h hz hx, H h ⟨hx,hz⟩⟩,
  .. separation.hProp.lattice.complete_lattice }

instance {value} : comm_monoid (hProp value) :=
{ mul := and,
  mul_assoc := and_assoc,
  one := emp,
  one_mul := emp_and,
  mul_one := and_emp,
  mul_comm := and_comm }

instance {value} : comm_residuated_lattice (hProp value) :=
{ div := wand,
  sdiff := flip wand,
  le_div_iff := λ p q r,
    show r ≤ p ⊸ q ↔ p ⊛ r ≤ q,
    from (@separation.hProp.and_comm value r p) ▸ sorry,
  le_sdiff_iff := λ p q r,
    show r ≤ p ⊸ q ↔ r ⊛ p ≤ q,
    from (@separation.hProp.and_comm value r p) ▸ sorry,
  .. separation.hProp.comm_monoid,
  .. separation.hProp.lattice.complete_lattice, }
-- #exit

instance {value} : bunched_implication_logic (hProp value) :=
{ .. separation.hProp.complete_heyting_algebra,
  .. separation.hProp.comm_residuated_lattice, }
-- { le := impl,
--   top := True,
--   bot := False,
--   one := emp,
--   mul := hProp.and,
--   div := wand,
--   sdiff := flip wand,
--   inf := p_and,
--   sup := p_or,
--   mul_one := and_emp,
--   one_mul := emp_and,
--   mul_comm := and_comm,
--   mul_assoc := and_assoc,
--   le_Sup := _,
--   sup_le := _,
--   -- le_inf := _
--   }

-- class bunched_impl (α : Type) extends  :=

-- universes u v w

-- def Flift (F : Type v → Type w) (α : Type u) : Type* :=
-- Σ β, F β × (β → α)

-- class foldable (F : Type u → Type v) :=
-- (foldl : ∀ {α β : Type u}, (α → β → α) → α → F β → α)

-- variables {F : Type u → Type v} [foldable F]
-- open ulift

-- def Flift.foldl {α β : Type w} (f : α → β → α) (x : α) : Flift F β → α
-- | ⟨γ,y,g⟩ := sorry -- ulift.down $ foldable.foldl.{u v} (λ a b, up $ f (down a) _) (up x) y

-- instance : foldable (Flift.{w} F) :=
-- ⟨ @Flift.foldl F _  ⟩

-- def Flift.mk {α} (x : F α) : Flift F (ulift.{w} α) :=
-- ⟨_, x, up⟩

-- -- set_option pp.implicit true

-- def foldl {α : Type w} {β : Type u} (f : α → β → α) (x : α) (xs : F β) : α :=
-- down $ @foldable.foldl (Flift F) _ _ _ (λ a (b : ulift.{w} β), up $ f (down a) (down b)) (up.{u} x) (Flift.mk.{u} xs)


import Playground.Category.Functor.Hom
import Playground.Category.Instances.MetaCat

namespace Category.Functor
section

  def yoneda (C) [Category C] : C ⥤ Cᵒᵖ ⥤ Type _ := (hom C).swap.curry

  namespace yoneda
  -- define yoneda's lemma's pairing bifunctor: X, F ↦ (hom(_,X) ⟹ F)
  def pairing (C) [Category.{u,v} C] : Bi Cᵒᵖ (Cᵒᵖ ⥤ Type v) (Type (max u v)) :=
    (yoneda C).opp.prod (𝟭 (Cᵒᵖ ⥤ Type _)) ⋙ hom (Cᵒᵖ ⥤ Type _)

  def evaluation.{u,v} (C) [Category.{u,v} C] : Bi Cᵒᵖ (Cᵒᵖ ⥤ Type v) (Type (max u v)) :=
    Bi.evaluation Cᵒᵖ (Type v) ⋙ Functor.ulift.{v,u}

  -- This is yoneda's lemma stated compactly as an explicit natural isomorphism
  open Natural_Transformation in
  def isomorphism.{u,v} (C) [Category.{u,v} C] : pairing C ≅ evaluation C := {
      hom := {
        component := λ ⟨op U, P⟩ => λ (s : yoneda _ U ⟹ P) =>
          show ULift $ P (op U) from
          ULift.up $ s (op U) (𝟙 U)
        naturality := @λ ⟨op U₁, P₁⟩ ⟨op U₂, P₂⟩ ⟨op f, α⟩ => by
          funext (s : _ ⟹ P₁)
          apply congrArg ULift.up
          apply congrArg (α.component (op U₂))
          show (s (op U₂) ((𝟙 _ ≫ 𝟙 _) ≫ f)) = (s (op U₁) ≫ P₁.hom_map (op f)) (𝟙 U₁)
          rw [←s.naturality]
          show (s (op U₂) ((𝟙 _ ≫ 𝟙 _) ≫ f)) = (s (op U₂) ((f ≫ 𝟙 _) ≫ 𝟙 _))
          simp
      }
      inv := {
        component := λ ⟨op U, P⟩ => λ (⟨ξ⟩ : ULift $ P (op U)) => show yoneda _ U ⟹ P from {
          component := λ (op V) => λ f => P.hom_map f.op ξ
          naturality := @λ (op V₁) (op V₂) (op g) => by
            funext (f : _ ⟶ _)
            show P.hom_map ((g ≫ f) ≫ 𝟙 U).op ξ = (P.hom_map f.op ≫ P.hom_map g.op) ξ
            apply congrFun
            simp
        }
        naturality := @λ ⟨op U₁, P₁⟩ ⟨op U₂, P₂⟩ ⟨op f, (α : _ ⟹ _)⟩ => by
          funext ⟨ξ⟩
          apply eq_of_component_eq
          funext (op V)
          funext g
          show (P₁.hom_map f.op ≫ (α (op U₂) ≫ P₂.hom_map g.op)) ξ
            = (P₁.hom_map (f.op ≫ (𝟙 _ ≫ g).op) ≫ α (op V)) ξ
          rw [←α.naturality]
          simp
          rfl
      }
      inv_hom := by
        apply eq_of_component_eq
        funext ⟨op U, P⟩
        funext (⟨ξ⟩ : ULift $ P (op U))
        apply congrArg ULift.up
        show (P.hom_map (𝟙 _) ξ) = ξ
        rw [hom_map_id]
        rfl
      hom_inv := by
        apply eq_of_component_eq
        funext ⟨op U, P⟩
        funext (s : yoneda _ U ⟹ P)
        apply eq_of_component_eq
        funext (op V)
        funext (f : _ ⟶ _)
        show (s (op U) ≫ P.hom_map f.op) (𝟙 U) = s (op V) f
        rw [←naturality]
        show ((yoneda _ U).hom_map f.op ≫ s (op V)) (𝟙 U) = s (op V) f
        apply congrArg (s (op V))
        show _ ≫ 𝟙 U = f
        simp
    }

  open Natural_Transformation in
  theorem hom_map_eq_isomorphism_inv_component {C} [Category C] (U V : C)
    : (yoneda C).hom_map = ((isomorphism C).inv.component (op U, yoneda C V)) ∘ ULift.up := by
    funext _
    apply eq_of_component_eq
    funext _ _
    show (𝟙 _ ≫ _) ≫ _ = _ ≫ 𝟙 _
    simp

  def isomorphismAt.{u,v} {C} [Category.{u,v} C] (U : C) (P : Cᵒᵖ ⥤ Type v)
    : (yoneda C U ⟹ P) ≅ (ULift.{u,v} $ P (op U)) :=
      isom_images_of_isom_functors (isomorphism C) (op U, P)

  theorem isomorphism_inv_at_eq_isomorphismAt_inv.{u,v} {C} [Category.{u,v} C] (U : C) (P : Cᵒᵖ ⥤ Type v)
    : (isomorphism C).inv.component (op U, P) = (isomorphismAt U P).inv := by
    simp [isom_images_of_isom_functors, isomorphismAt, isom_images_of_isom_objects]
    simp [Bi.fixLeft, Bi.evaluation, Bi.swap]
    simp [uncurry]
    rfl

  theorem faithful {C} [Category C] : (yoneda C).Faithful := by
    intro U V
    rw [hom_map_eq_isomorphism_inv_component]
    rw [isomorphism_inv_at_eq_isomorphismAt_inv]
    apply flip Function.Injective.comp (λ _ _ => congrArg ULift.down)
    have : ∀ x, ((isomorphismAt ..).hom ∘ (isomorphismAt ..).inv) x = x := congrFun (isomorphismAt U (yoneda C V)).inv_hom
    exact Function.LeftInverse.injective this

  theorem full {C} [Category C] : (yoneda C).Full := by
    intro U V
    rw [hom_map_eq_isomorphism_inv_component]
    rw [isomorphism_inv_at_eq_isomorphismAt_inv]
    apply flip Function.Surjective.comp (λ ⟨y⟩ => ⟨y, rfl⟩)
    exact Function.RightInverse.surjective <| congrFun <| (isomorphismAt U (yoneda C V)).hom_inv

  -- yoneda corollary 2: structure of arrows to U is same as structure of arrows to V iff U is same as V
  theorem isomorphism_of_yoneda_isomorphism {C} [Category C] (U V : C)
    : yoneda C U ≅ yoneda C V → U ≅ V :=
    (yoneda C).isom_objects_of_isom_images_of_FullFaithful full faithful

  end yoneda

end
end Category.Functor


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.fintype.sum
! leanprover-community/mathlib commit 6623e6af705e97002a9054c1c05a980180276fc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.Fintype.Card
import Mathlib.Data.Finset.Sum
import Mathlib.Logic.Embedding.Set

/-!
## Instances

We provide the `Fintype` instance for the sum of two fintypes.
-/

universe u v

variable {α β : Type _}

open Finset

instance (α : Type u) (β : Type v) [Fintype α] [Fintype β] : Fintype (Sum α β) where
  elems := univ.disjSum univ
  complete := by rintro (_ | _) <;> simp

@[simp]
theorem Finset.univ_disjSum_univ {α β : Type _} [Fintype α] [Fintype β] :
    univ.disjSum univ = (univ : Finset (Sum α β)) :=
  rfl
#align finset.univ_disj_sum_univ Finset.univ_disjSum_univ

@[simp]
theorem Fintype.card_sum [Fintype α] [Fintype β] :
    Fintype.card (Sum α β) = Fintype.card α + Fintype.card β :=
  card_disjSum _ _
#align fintype.card_sum Fintype.card_sum

/-- If the subtype of all-but-one elements is a `Fintype` then the type itself is a `Fintype`. -/
def fintypeOfFintypeNe (a : α) (h : Fintype { b // b ≠ a }) : Fintype α :=
  Fintype.ofBijective (Sum.elim ((↑) : { b // b = a } → α) ((↑) : { b // b ≠ a } → α)) <| by
    classical exact (Equiv.sumCompl (· = a)).bijective
#align fintype_of_fintype_ne fintypeOfFintypeNe

theorem image_subtype_ne_univ_eq_image_erase [Fintype α] [DecidableEq β] (k : β) (b : α → β) :
    image (fun i : { a // b a ≠ k } => b ↑i) univ = (image b univ).erase k := by
  apply subset_antisymm
  · rw [image_subset_iff]
    intro i _
    apply mem_erase_of_ne_of_mem i.2 (mem_image_of_mem _ (mem_univ _))
  · intro i hi
    rw [mem_image]
    rcases mem_image.1 (erase_subset _ _ hi) with ⟨a, _, ha⟩
    subst ha
    exact ⟨⟨a, ne_of_mem_erase hi⟩, mem_univ _, rfl⟩
#align image_subtype_ne_univ_eq_image_erase image_subtype_ne_univ_eq_image_erase

theorem image_subtype_univ_ssubset_image_univ [Fintype α] [DecidableEq β] (k : β) (b : α → β)
    (hk : k ∈ Finset.image b univ) (p : β → Prop) [DecidablePred p] (hp : ¬p k) :
    image (fun i : { a // p (b a) } => b ↑i) univ ⊂ image b univ := by
  constructor
  · intro x hx
    rcases mem_image.1 hx with ⟨y, _, hy⟩
    exact hy ▸ mem_image_of_mem b (mem_univ (y : α))
  · intro h
    rw [mem_image] at hk
    rcases hk with ⟨k', _, hk'⟩
    subst hk'
    have := h (mem_image_of_mem b (mem_univ k'))
    rw [mem_image] at this
    rcases this with ⟨j, _, hj'⟩
    exact hp (hj' ▸ j.2)
#align image_subtype_univ_ssubset_image_univ image_subtype_univ_ssubset_image_univ

/-- Any injection from a finset `s` in a fintype `α` to a finset `t` of the same cardinality as `α`
can be extended to a bijection between `α` and `t`. -/
theorem Finset.exists_equiv_extend_of_card_eq [Fintype α] [DecidableEq β] {t : Finset β}
    (hαt : Fintype.card α = t.card) {s : Finset α} {f : α → β} (hfst : Finset.image f s ⊆ t)
    (hfs : Set.InjOn f s) : ∃ g : α ≃ t, ∀ i ∈ s, (g i : β) = f i := by
  classical
    induction' s using Finset.induction with a s has H generalizing f
    · obtain ⟨e⟩ : Nonempty (α ≃ ↥t) := by rwa [← Fintype.card_eq, Fintype.card_coe]
      use e
      simp
    have hfst' : Finset.image f s ⊆ t := (Finset.image_mono _ (s.subset_insert a)).trans hfst
    have hfs' : Set.InjOn f s := hfs.mono (s.subset_insert a)
    obtain ⟨g', hg'⟩ := H hfst' hfs'
    have hfat : f a ∈ t := hfst (mem_image_of_mem _ (s.mem_insert_self a))
    use g'.trans (Equiv.swap (⟨f a, hfat⟩ : t) (g' a))
    simp_rw [mem_insert]
    rintro i (rfl | hi)
    · simp
    rw [Equiv.trans_apply, Equiv.swap_apply_of_ne_of_ne, hg' _ hi]
    · exact
        ne_of_apply_ne Subtype.val
          (ne_of_eq_of_ne (hg' _ hi) <|
            hfs.ne (subset_insert _ _ hi) (mem_insert_self _ _) <| ne_of_mem_of_not_mem hi has)
    · exact g'.injective.ne (ne_of_mem_of_not_mem hi has)
#align finset.exists_equiv_extend_of_card_eq Finset.exists_equiv_extend_of_card_eq

/-- Any injection from a set `s` in a fintype `α` to a finset `t` of the same cardinality as `α`
can be extended to a bijection between `α` and `t`. -/
theorem Set.MapsTo.exists_equiv_extend_of_card_eq [Fintype α] {t : Finset β}
    (hαt : Fintype.card α = t.card) {s : Set α} {f : α → β} (hfst : s.MapsTo f t)
    (hfs : Set.InjOn f s) : ∃ g : α ≃ t, ∀ i ∈ s, (g i : β) = f i := by
  classical
    let s' : Finset α := s.toFinset
    have hfst' : s'.image f ⊆ t := by simpa [← Finset.coe_subset] using hfst
    have hfs' : Set.InjOn f s' := by simpa using hfs
    obtain ⟨g, hg⟩ := Finset.exists_equiv_extend_of_card_eq hαt hfst' hfs'
    refine' ⟨g, fun i hi => _⟩
    apply hg
    simpa using hi
#align set.maps_to.exists_equiv_extend_of_card_eq Set.MapsTo.exists_equiv_extend_of_card_eq

theorem Fintype.card_subtype_or (p q : α → Prop) [Fintype { x // p x }] [Fintype { x // q x }]
    [Fintype { x // p x ∨ q x }] :
    Fintype.card { x // p x ∨ q x } ≤ Fintype.card { x // p x } + Fintype.card { x // q x } := by
  classical
    convert Fintype.card_le_of_embedding (subtypeOrLeftEmbedding p q)
    rw [Fintype.card_sum]
#align fintype.card_subtype_or Fintype.card_subtype_or

theorem Fintype.card_subtype_or_disjoint (p q : α → Prop) (h : Disjoint p q) [Fintype { x // p x }]
    [Fintype { x // q x }] [Fintype { x // p x ∨ q x }] :
    Fintype.card { x // p x ∨ q x } = Fintype.card { x // p x } + Fintype.card { x // q x } := by
  classical
    convert Fintype.card_congr (subtypeOrEquiv p q h)
    simp
#align fintype.card_subtype_or_disjoint Fintype.card_subtype_or_disjoint

section

open Classical

@[simp]
theorem infinite_sum : Infinite (Sum α β) ↔ Infinite α ∨ Infinite β := by
  refine' ⟨fun H => _, fun H => H.elim (@Sum.infinite_of_left α β) (@Sum.infinite_of_right α β)⟩
  contrapose! H; haveI := fintypeOfNotInfinite H.1; haveI := fintypeOfNotInfinite H.2
  exact Infinite.false
#align infinite_sum infinite_sum

end


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Scott Morrison, Mario Carneiro
-/
import category_theory.concrete_category.unbundled_hom
import topology.continuous_function.basic
import topology.opens

/-!
# Category instance for topological spaces

We introduce the bundled category `Top` of topological spaces together with the functors `discrete`
and `trivial` from the category of types to `Top` which equip a type with the corresponding
discrete, resp. trivial, topology. For a proof that these functors are left, resp. right adjoint
to the forgetful functor, see `topology.category.Top.adjunctions`.
-/

open category_theory
open topological_space

universe u

/-- The category of topological spaces and continuous maps. -/
def Top : Type (u+1) := bundled topological_space

namespace Top

instance bundled_hom : bundled_hom @continuous_map :=
⟨@continuous_map.to_fun, @continuous_map.id, @continuous_map.comp, @continuous_map.coe_inj⟩

attribute [derive [has_coe_to_sort, large_category, concrete_category]] Top

instance topological_space_unbundled (x : Top) : topological_space x := x.str

@[simp] lemma id_app (X : Top.{u}) (x : X) :
  (𝟙 X : X → X) x = x := rfl

@[simp] lemma comp_app {X Y Z : Top.{u}} (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  (f ≫ g : X → Z) x = g (f x) := rfl

/-- Construct a bundled `Top` from the underlying type and the typeclass. -/
def of (X : Type u) [topological_space X] : Top := ⟨X⟩

instance (X : Top) : topological_space X := X.str

@[simp] lemma coe_of (X : Type u) [topological_space X] : (of X : Type u) = X := rfl

instance : inhabited Top := ⟨Top.of empty⟩

/-- The discrete topology on any type. -/
def discrete : Type u ⥤ Top.{u} :=
{ obj := λ X, ⟨X, ⊥⟩,
  map := λ X Y f, { to_fun := f, continuous_to_fun := continuous_bot } }

/-- The trivial topology on any type. -/
def trivial : Type u ⥤ Top.{u} :=
{ obj := λ X, ⟨X, ⊤⟩,
  map := λ X Y f, { to_fun := f, continuous_to_fun := continuous_top } }

end Top


/-
Copyright (c) 2018 Andreas Swerdlow. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andreas Swerdlow
-/
import deprecated.subring
import algebra.group_with_zero.power

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

class is_subfield extends is_subring S : Prop :=
(inv_mem : ∀ {x : F}, x ∈ S → x⁻¹ ∈ S)

lemma is_subfield.div_mem {S : set F} [is_subfield S] {x y : F} (hx : x ∈ S) (hy : y ∈ S) :
  x / y ∈ S :=
by { rw div_eq_mul_inv, exact is_submonoid.mul_mem hx (is_subfield.inv_mem hy) }

instance is_subfield.field [is_subfield S] : field S :=
by letI cr_inst : comm_ring S := subset.comm_ring; exact
{ inv := λ x, ⟨x⁻¹, is_subfield.inv_mem x.2⟩,
  div := λ x y, ⟨x / y, is_subfield.div_mem x.2 y.2⟩,
  div_eq_mul_inv := λ x y, subtype.ext $ div_eq_mul_inv (x : F) y,
  exists_pair_ne := ⟨0, 1, λ h, zero_ne_one (subtype.ext_iff_val.1 h)⟩,
  mul_inv_cancel := λ a ha, subtype.ext_iff_val.2 (mul_inv_cancel
    (λ h, ha $ subtype.ext_iff_val.2 h)),
  inv_zero := subtype.ext_iff_val.2 inv_zero,
  .. cr_inst }

lemma is_subfield.pow_mem {a : F} {n : ℤ} {s : set F} [is_subfield s] (h : a ∈ s) :
  a ^ n ∈ s :=
begin
  cases n,
  { rw gpow_of_nat, exact is_submonoid.pow_mem h },
  { rw gpow_neg_succ_of_nat, exact is_subfield.inv_mem (is_submonoid.pow_mem h) },
end

instance univ.is_subfield : is_subfield (@set.univ F) :=
{ inv_mem := by intros; trivial }

/- note: in the next two declarations, if we let type-class inference figure out the instance
  `ring_hom.is_subring_preimage` then that instance only applies when particular instances of
  `is_add_subgroup _` and `is_submonoid _` are chosen (which are not the default ones).
  If we specify it explicitly, then it doesn't complain. -/
instance preimage.is_subfield {K : Type*} [field K]
  (f : F →+* K) (s : set K) [is_subfield s] : is_subfield (f ⁻¹' s) :=
{ inv_mem := λ a (ha : f a ∈ s), show f a⁻¹ ∈ s,
    by { rw [f.map_inv],
         exact is_subfield.inv_mem ha },
  ..f.is_subring_preimage s }

instance image.is_subfield {K : Type*} [field K]
  (f : F →+* K) (s : set F) [is_subfield s] : is_subfield (f '' s) :=
{ inv_mem := λ a ⟨x, xmem, ha⟩, ⟨x⁻¹, is_subfield.inv_mem xmem, ha ▸ f.map_inv _⟩,
  ..f.is_subring_image s }

instance range.is_subfield {K : Type*} [field K]
  (f : F →+* K) : is_subfield (set.range f) :=
by { rw ← set.image_univ, apply_instance }

namespace field

/-- `field.closure s` is the minimal subfield that includes `s`. -/
def closure : set F :=
{ x | ∃ y ∈ ring.closure S, ∃ z ∈ ring.closure S, y / z = x }

variables {S}

theorem ring_closure_subset : ring.closure S ⊆ closure S :=
λ x hx, ⟨x, hx, 1, is_submonoid.one_mem, div_one x⟩

instance closure.is_submonoid : is_submonoid (closure S) :=
{ mul_mem := by rintros _  _ ⟨p, hp, q, hq, hq0, rfl⟩ ⟨r, hr, s, hs, hs0, rfl⟩;
    exact ⟨p * r,
          is_submonoid.mul_mem hp hr,
          q * s,
          is_submonoid.mul_mem hq hs,
          (div_mul_div _ _ _ _).symm⟩,
  one_mem := ring_closure_subset $ is_submonoid.one_mem }

instance closure.is_subfield : is_subfield (closure S) :=
have h0 : (0:F) ∈ closure S, from ring_closure_subset $ is_add_submonoid.zero_mem,
{ add_mem := begin
    intros a b ha hb,
    rcases (id ha) with ⟨p, hp, q, hq, rfl⟩,
    rcases (id hb) with ⟨r, hr, s, hs, rfl⟩,
    classical, by_cases hq0 : q = 0, by simp [hb, hq0], by_cases hs0 : s = 0, by simp [ha, hs0],
    exact ⟨p * s + q * r, is_add_submonoid.add_mem (is_submonoid.mul_mem hp hs)
      (is_submonoid.mul_mem hq hr), q * s, is_submonoid.mul_mem hq hs,
      (div_add_div p r hq0 hs0).symm⟩
  end,
  zero_mem := h0,
  neg_mem := begin
    rintros _ ⟨p, hp, q, hq, rfl⟩,
    exact ⟨-p, is_add_subgroup.neg_mem hp, q, hq, neg_div q p⟩
  end,
  inv_mem := begin
    rintros _ ⟨p, hp, q, hq, rfl⟩,
    classical, by_cases hp0 : p = 0, by simp [hp0, h0],
    exact ⟨q, hq, p, hp, inv_div.symm⟩
  end }

theorem mem_closure {a : F} (ha : a ∈ S) : a ∈ closure S :=
ring_closure_subset $ ring.mem_closure ha

theorem subset_closure : S ⊆ closure S :=
λ _, mem_closure

theorem closure_subset {T : set F} [is_subfield T] (H : S ⊆ T) : closure S ⊆ T :=
by rintros _ ⟨p, hp, q, hq, hq0, rfl⟩; exact is_subfield.div_mem (ring.closure_subset H hp)
  (ring.closure_subset H hq)

theorem closure_subset_iff (s t : set F) [is_subfield t] : closure s ⊆ t ↔ s ⊆ t :=
⟨set.subset.trans subset_closure, closure_subset⟩

theorem closure_mono {s t : set F} (H : s ⊆ t) : closure s ⊆ closure t :=
closure_subset $ set.subset.trans H subset_closure

end field

lemma is_subfield_Union_of_directed {ι : Type*} [hι : nonempty ι]
  (s : ι → set F) [∀ i, is_subfield (s i)]
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subfield (⋃i, s i) :=
{ inv_mem := λ x hx, let ⟨i, hi⟩ := set.mem_Union.1 hx in
    set.mem_Union.2 ⟨i, is_subfield.inv_mem hi⟩,
  to_is_subring := is_subring_Union_of_directed s directed }

instance is_subfield.inter (S₁ S₂ : set F) [is_subfield S₁] [is_subfield S₂] :
  is_subfield (S₁ ∩ S₂) :=
{ inv_mem := λ x hx, ⟨is_subfield.inv_mem hx.1, is_subfield.inv_mem hx.2⟩ }

instance is_subfield.Inter {ι : Sort*} (S : ι → set F) [h : ∀ y : ι, is_subfield (S y)] :
  is_subfield (set.Inter S) :=
{ inv_mem := λ x hx, set.mem_Inter.2 $ λ y, is_subfield.inv_mem $ set.mem_Inter.1 hx y }


/-
Copyright (c) 2022 Michael Stoll. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Stoll
-/
import ring_theory.integral_domain

/-!
# Multiplicative characters of finite rings and fields

Let `R` and `R'` be a commutative rings.
A *multiplicative character* of `R` with values in `R'` is a morphism of
monoids from the multiplicative monoid of `R` into that of `R'`
that sends non-units to zero.

We use the namespace `mul_char` for the definitions and results.

## Tags

multiplicative character
-/

section definition_and_group

/-!
### Definitions related to multiplicative characters

Even though the intended use is when domain and target of the characters
are commutative rings, we define them in the more general setting when
the domain is a commutative monoid and the target is a commutative monoid
with zero. (We need a zero in the target, since non-units are supposed
to map to zero.)

In this setting, there is an equivalence between multiplicative characters
`R → R'` and group homomorphisms `Rˣ → R'ˣ`, and the multiplicative characters
have a natural structure as a commutative group.
-/

universes u v

section defi

-- The domain of our multiplicative characters
variables (R : Type u) [comm_monoid R]
-- The target
variables (R' : Type v) [comm_monoid_with_zero R']

/-- Define a structure for multiplicative characters.
A multiplicative character from a commutative monoid `R` to a commutative monoid with zero `R'`
is a homomorphism of (multiplicative) monoids that sends non-units to zero. -/
structure mul_char extends monoid_hom R R' :=
(map_nonunit' : ∀ a : R, ¬ is_unit a → to_fun a = 0)

/-- This is the corresponding extension of `monoid_hom_class`. -/
class mul_char_class (F : Type*) (R R' : out_param $ Type*) [comm_monoid R]
 [comm_monoid_with_zero R']
  extends monoid_hom_class F R R' :=
(map_nonunit : ∀ (χ : F) {a : R} (ha : ¬ is_unit a), χ a = 0)

attribute [simp] mul_char_class.map_nonunit

end defi

section group

namespace mul_char

-- The domain of our multiplicative characters
variables {R : Type u} [comm_monoid R]
-- The target
variables {R' : Type v} [comm_monoid_with_zero R']

instance coe_to_fun : has_coe_to_fun (mul_char R R') (λ _, R → R') :=
⟨λ χ, χ.to_fun⟩

/-- See note [custom simps projection] -/
protected def simps.apply (χ : mul_char R R') : R → R' := χ
initialize_simps_projections mul_char (to_monoid_hom_to_fun → apply, -to_monoid_hom)

section trivial

variables (R R')

/-- The trivial multiplicative character. It takes the value `0` on non-units and
the value `1` on units. -/
@[simps]
noncomputable
def trivial : mul_char R R' :=
{ to_fun := by { classical, exact λ x, if is_unit x then 1 else 0 },
  map_nonunit' := by { intros a ha, simp only [ha, if_false], },
  map_one' := by simp only [is_unit_one, if_true],
  map_mul' := by { intros x y,
                   simp only [is_unit.mul_iff, boole_mul],
                   split_ifs; tauto, } }

end trivial

@[simp]
lemma coe_coe (χ : mul_char R R') : (χ.to_monoid_hom : R → R') = χ := rfl

@[simp]
lemma to_fun_eq_coe (χ : mul_char R R') : χ.to_fun = χ := rfl

@[simp]
lemma coe_mk (f : R →* R') (hf) : (mul_char.mk f hf : R → R') = f := rfl

/-- Extensionality. See `ext` below for the version that will actually be used. -/
lemma ext' {χ χ' : mul_char R R'} (h : ∀ a, χ a = χ' a) : χ = χ' :=
begin
  cases χ,
  cases χ',
  congr,
  exact monoid_hom.ext h,
end

instance : mul_char_class (mul_char R R') R R' :=
{ coe := λ χ, χ.to_monoid_hom.to_fun,
  coe_injective' := λ f g h, ext' (λ a, congr_fun h a),
  map_mul := λ χ, χ.map_mul',
  map_one := λ χ, χ.map_one',
  map_nonunit := λ χ, χ.map_nonunit', }

lemma map_nonunit (χ : mul_char R R') {a : R} (ha : ¬ is_unit a) : χ a = 0 :=
χ.map_nonunit' a ha

/-- Extensionality. Since `mul_char`s always take the value zero on non-units, it is sufficient
to compare the values on units. -/
@[ext]
lemma ext {χ χ' : mul_char R R'} (h : ∀ a : Rˣ, χ a = χ' a) : χ = χ' :=
begin
  apply ext',
  intro a,
  by_cases ha : is_unit a,
  { exact h ha.unit, },
  { rw [map_nonunit χ ha, map_nonunit χ' ha], },
end

lemma ext_iff {χ χ' : mul_char R R'} : χ = χ' ↔ ∀ a : Rˣ, χ a = χ' a :=
⟨by { rintro rfl a, refl }, ext⟩

/-!
### Equivalence of multiplicative characters with homomorphisms on units

We show that restriction / extension by zero gives an equivalence
between `mul_char R R'` and `Rˣ →* R'ˣ`.
-/

/-- Turn a `mul_char` into a homomorphism between the unit groups. -/
def to_unit_hom (χ : mul_char R R') : Rˣ →* R'ˣ := units.map χ

lemma coe_to_unit_hom (χ : mul_char R R') (a : Rˣ) :
  ↑(χ.to_unit_hom a) = χ a :=
rfl

/-- Turn a homomorphism between unit groups into a `mul_char`. -/
noncomputable
def of_unit_hom (f : Rˣ →* R'ˣ) : mul_char R R' :=
{ to_fun := by { classical, exact λ x, if hx : is_unit x then f hx.unit else 0 },
  map_one' := by { have h1 : (is_unit_one.unit : Rˣ) = 1 := units.eq_iff.mp rfl,
                   simp only [h1, dif_pos, units.coe_eq_one, map_one, is_unit_one], },
  map_mul' :=
  begin
    intros x y,
    by_cases hx : is_unit x,
    { simp only [hx, is_unit.mul_iff, true_and, dif_pos],
      by_cases hy : is_unit y,
      { simp only [hy, dif_pos],
        have hm : (is_unit.mul_iff.mpr ⟨hx, hy⟩).unit = hx.unit * hy.unit := units.eq_iff.mp rfl,
        rw [hm, map_mul],
        norm_cast, },
      { simp only [hy, not_false_iff, dif_neg, mul_zero], }, },
    { simp only [hx, is_unit.mul_iff, false_and, not_false_iff, dif_neg, zero_mul], },
  end ,
  map_nonunit' := by { intros a ha, simp only [ha, not_false_iff, dif_neg], }, }

lemma of_unit_hom_coe (f : Rˣ →* R'ˣ) (a : Rˣ) :
  of_unit_hom f ↑a = f a :=
by simp [of_unit_hom]

/-- The equivalence between multiplicative characters and homomorphisms of unit groups. -/
noncomputable
def equiv_to_unit_hom : mul_char R R' ≃ (Rˣ →* R'ˣ) :=
{ to_fun := to_unit_hom,
  inv_fun := of_unit_hom,
  left_inv :=
  by { intro χ, ext x, rw [of_unit_hom_coe, coe_to_unit_hom] },
  right_inv :=
  by { intro f, ext x, rw [coe_to_unit_hom, of_unit_hom_coe], } }

@[simp]
lemma to_unit_hom_eq (χ : mul_char R R') : to_unit_hom χ = equiv_to_unit_hom χ := rfl

@[simp]
lemma of_unit_hom_eq (χ : Rˣ →* R'ˣ) : of_unit_hom χ = equiv_to_unit_hom.symm χ := rfl

@[simp]
lemma coe_equiv_to_unit_hom (χ : mul_char R R') (a : Rˣ) :
  ↑(equiv_to_unit_hom χ a) = χ a :=
coe_to_unit_hom χ a

@[simp]
lemma equiv_unit_hom_symm_coe (f : Rˣ →* R'ˣ) (a : Rˣ) :
  equiv_to_unit_hom.symm f ↑a = f a :=
of_unit_hom_coe f a

/-!
### Commutative group structure on multiplicative characters

The multiplicative characters `R → R'` form a commutative group.
-/

protected
lemma map_one (χ : mul_char R R') : χ (1 : R) = 1 :=
χ.map_one'

/-- If the domain has a zero (and is nontrivial), then `χ 0 = 0`. -/
protected
lemma map_zero {R : Type u} [comm_monoid_with_zero R] [nontrivial R] (χ : mul_char R R') :
  χ (0 : R) = 0 :=
by rw [map_nonunit χ not_is_unit_zero]

noncomputable
instance has_one : has_one (mul_char R R') := ⟨trivial R R'⟩

noncomputable
instance inhabited : inhabited (mul_char R R') := ⟨1⟩

/-- Evaluation of the trivial character -/
@[simp]
lemma one_apply_coe (a : Rˣ) : (1 : mul_char R R') a = 1 :=
dif_pos a.is_unit

/-- Multiplication of multiplicative characters. (This needs the target to be commutative.) -/
def mul (χ χ' : mul_char R R') : mul_char R R' :=
{ to_fun := χ * χ',
  map_nonunit' := λ a ha, by simp [map_nonunit χ ha],
  ..χ.to_monoid_hom * χ'.to_monoid_hom }

instance has_mul : has_mul (mul_char R R') := ⟨mul⟩

lemma mul_apply (χ χ' : mul_char R R') (a : R) : (χ * χ') a = χ a * χ' a := rfl

@[simp]
lemma coe_to_fun_mul (χ χ' : mul_char R R') : ⇑(χ * χ') = χ * χ' := rfl

protected
lemma one_mul (χ : mul_char R R') : (1 : mul_char R R') * χ = χ := by { ext, simp }

protected
lemma mul_one (χ : mul_char R R') : χ * 1 = χ := by { ext, simp }

/-- The inverse of a multiplicative character. We define it as `inverse ∘ χ`. -/
noncomputable
def inv (χ : mul_char R R') : mul_char R R' :=
{ to_fun := λ a, monoid_with_zero.inverse (χ a),
  map_nonunit' := λ a ha, by simp [map_nonunit _ ha],
  ..monoid_with_zero.inverse.to_monoid_hom.comp χ.to_monoid_hom }

noncomputable
instance has_inv : has_inv (mul_char R R') := ⟨inv⟩

/-- The inverse of a multiplicative character `χ`, applied to `a`, is the inverse of `χ a`. -/
lemma inv_apply_eq_inv (χ : mul_char R R') (a : R) :
  χ⁻¹ a = ring.inverse (χ a) :=
eq.refl $ inv χ a

/-- Variant when the target is a field -/
lemma inv_apply_eq_inv' {R' : Type v} [field R'] (χ : mul_char R R') (a : R) :
  χ⁻¹ a = (χ a)⁻¹ :=
(inv_apply_eq_inv χ a).trans $ ring.inverse_eq_inv (χ a)

/-- When the domain has a zero, we can as well take the inverse first. -/
lemma inv_apply {R : Type u} [comm_monoid_with_zero R] (χ : mul_char R R') (a : R) :
  χ⁻¹ a = χ (ring.inverse a) :=
begin
  by_cases ha : is_unit a,
  { rw [inv_apply_eq_inv],
    have h := is_unit.map χ ha,
    apply_fun ((*) (χ a)) using is_unit.mul_right_injective h,
    rw [ring.mul_inverse_cancel _ h, ← map_mul, ring.mul_inverse_cancel _ ha, mul_char.map_one], },
  { revert ha, nontriviality R, intro ha, -- `nontriviality R` by itself doesn't do it
    rw [map_nonunit _ ha, ring.inverse_non_unit a ha, mul_char.map_zero χ], },
end

/-- When the domain is a field, we can use the field inverse instead. -/
lemma inv_apply' {R : Type u} [field R] (χ : mul_char R R') (a : R) : χ⁻¹ a = χ a⁻¹ :=
(inv_apply χ a).trans $ congr_arg _ (ring.inverse_eq_inv a)

/-- The product of a character with its inverse is the trivial character. -/
@[simp]
lemma inv_mul (χ : mul_char R R') : χ⁻¹ * χ = 1 :=
begin
  ext x,
  rw [coe_to_fun_mul, pi.mul_apply, inv_apply_eq_inv,
      ring.inverse_mul_cancel _ (is_unit.map _ x.is_unit), one_apply_coe],
end

/-- Finally, the commutative group structure on `mul_char R R'`. -/
noncomputable
instance comm_group : comm_group (mul_char R R') :=
{ one := 1,
  mul := (*),
  inv := has_inv.inv,
  mul_left_inv := inv_mul,
  mul_assoc := by { intros χ₁ χ₂ χ₃, ext a, simp [mul_assoc], },
  mul_comm := by { intros χ₁ χ₂, ext a, simp [mul_comm], },
  one_mul := one_mul,
  mul_one := mul_one, }

/-- If `a` is a unit and `n : ℕ`, then `(χ ^ n) a = (χ a) ^ n`. -/
lemma pow_apply_coe (χ : mul_char R R') (n : ℕ) (a : Rˣ) :
  (χ ^ n) a = (χ a) ^ n :=
begin
  induction n with n ih,
  { rw [pow_zero, pow_zero, one_apply_coe], },
  { rw [pow_succ, pow_succ, mul_apply, ih], },
end

/-- If `n` is positive, then `(χ ^ n) a = (χ a) ^ n`. -/
lemma pow_apply' (χ : mul_char R R') {n : ℕ} (hn : 0 < n) (a : R) :
  (χ ^ n) a = (χ a) ^ n :=
begin
  by_cases ha : is_unit a,
  { exact pow_apply_coe χ n ha.unit, },
  { rw [map_nonunit (χ ^ n) ha, map_nonunit χ ha, zero_pow hn], },
end

end mul_char

end group

end definition_and_group

/-!
### Properties of multiplicative characters

We introduce the properties of being nontrivial or quadratic and prove
some basic facts about them.

We now assume that domain and target are commutative rings.
-/

section properties

namespace mul_char

universes u v w

variables {R : Type u} [comm_ring R] {R' : Type v} [comm_ring R'] {R'' : Type w} [comm_ring R'']

/-- A multiplicative character is *nontrivial* if it takes a value `≠ 1` on a unit. -/
def is_nontrivial (χ : mul_char R R') : Prop := ∃ a : Rˣ, χ a ≠ 1

/-- A multiplicative character is nontrivial iff it is not the trivial character. -/
lemma is_nontrivial_iff (χ : mul_char R R') : χ.is_nontrivial ↔ χ ≠ 1 :=
by simp only [is_nontrivial, ne.def, ext_iff, not_forall, one_apply_coe]

/-- A multiplicative character is *quadratic* if it takes only the values `0`, `1`, `-1`. -/
def is_quadratic (χ : mul_char R R') : Prop := ∀ a, χ a = 0 ∨ χ a = 1 ∨ χ a = -1

/-- We can post-compose a multiplicative character with a ring homomorphism. -/
@[simps]
def ring_hom_comp (χ : mul_char R R') (f : R' →+* R'') : mul_char R R'' :=
{ to_fun := λ a, f (χ a),
  map_nonunit' := λ a ha, by simp only [map_nonunit χ ha, map_zero],
  ..f.to_monoid_hom.comp χ.to_monoid_hom }

/-- Composition with an injective ring homomorphism preserves nontriviality. -/
lemma is_nontrivial.comp {χ : mul_char R R'} (hχ : χ.is_nontrivial)
 {f : R' →+* R''} (hf : function.injective f) :
  (χ.ring_hom_comp f).is_nontrivial :=
begin
  obtain ⟨a, ha⟩ := hχ,
  use a,
  rw [ring_hom_comp_apply, ← ring_hom.map_one f],
  exact λ h, ha (hf h),
end

/-- Composition with a ring homomorphism preserves the property of being a quadratic character. -/
lemma is_quadratic.comp {χ : mul_char R R'} (hχ : χ.is_quadratic) (f : R' →+* R'') :
  (χ.ring_hom_comp f).is_quadratic :=
begin
  intro a,
  rcases hχ a with (ha | ha | ha);
    simp [ha],
end

/-- The inverse of a quadratic character is itself. →  -/
lemma is_quadratic.inv {χ : mul_char R R'} (hχ : χ.is_quadratic) : χ⁻¹ = χ :=
begin
  ext x,
  rw [inv_apply_eq_inv],
  rcases hχ x with h₀ | h₁ | h₂,
  { rw [h₀, ring.inverse_zero], },
  { rw [h₁, ring.inverse_one], },
  { rw [h₂, (by norm_cast : (-1 : R') = (-1 : R'ˣ)), ring.inverse_unit (-1 : R'ˣ)],
    refl, },
end

/-- The square of a quadratic character is the trivial character. -/
lemma is_quadratic.sq_eq_one {χ : mul_char R R'} (hχ : χ.is_quadratic) : χ ^ 2 = 1 :=
begin
  convert mul_left_inv _,
  rw [pow_two, hχ.inv],
end

/-- The `p`th power of a quadratic character is itself, when `p` is the (prime) characteristic
of the target ring. -/
lemma is_quadratic.pow_char {χ : mul_char R R'} (hχ : χ.is_quadratic)
 (p : ℕ) [hp : fact p.prime] [char_p R' p] :
  χ ^ p = χ :=
begin
  ext x,
  rw [pow_apply_coe],
  rcases hχ x with (hx | hx | hx); rw hx,
  { rw [zero_pow (fact.out p.prime).pos], },
  { rw [one_pow], },
  { exact char_p.neg_one_pow_char R' p, },
end

/-- The `n`th power of a quadratic character is the trivial character, when `n` is even. -/
lemma is_quadratic.pow_even {χ : mul_char R R'} (hχ : χ.is_quadratic) {n : ℕ} (hn : even n) :
  χ ^ n = 1 :=
begin
  obtain ⟨n, rfl⟩ := even_iff_two_dvd.mp hn,
  rw [pow_mul, hχ.sq_eq_one, one_pow]
end

/-- The `n`th power of a quadratic character is itself, when `n` is odd. -/
lemma is_quadratic.pow_odd {χ : mul_char R R'} (hχ : χ.is_quadratic) {n : ℕ} (hn : odd n) :
  χ ^ n = χ :=
begin
  obtain ⟨n, rfl⟩ := hn,
  rw [pow_add, pow_one, hχ.pow_even (even_two_mul _), one_mul]
end

open_locale big_operators

/-- The sum over all values of a nontrivial multiplicative character on a finite ring is zero
(when the target is a domain). -/
lemma is_nontrivial.sum_eq_zero [fintype R] [is_domain R'] {χ : mul_char R R'}
 (hχ : χ.is_nontrivial) :
  ∑ a, χ a = 0 :=
begin
  rcases hχ with ⟨b, hb⟩,
  refine eq_zero_of_mul_eq_self_left hb _,
  simp only [finset.mul_sum, ← map_mul],
  exact fintype.sum_bijective _ (units.mul_left_bijective b) _ _ (λ x, rfl)
end

/-- The sum over all values of the trivial multiplicative character on a finite ring is
the cardinality of its unit group. -/
lemma sum_one_eq_card_units [fintype R] [decidable_eq R] :
  ∑ a, (1 : mul_char R R') a = fintype.card Rˣ :=
begin
  calc ∑ a, (1 : mul_char R R') a
      = ∑ a : R, if is_unit a then 1 else 0 : finset.sum_congr rfl (λ a _, _)
  ... = ((finset.univ : finset R).filter is_unit).card : finset.sum_boole
  ... = (finset.univ.map (⟨(coe : Rˣ → R), units.ext⟩)).card : _
  ... = fintype.card Rˣ : congr_arg _ (finset.card_map _),
  { split_ifs with h h,
    { exact one_apply_coe h.unit },
    { exact map_nonunit _ h } },
  { congr,
    ext a,
    simp only [finset.mem_filter, finset.mem_univ, true_and, finset.mem_map,
               function.embedding.coe_fn_mk, exists_true_left, is_unit], },
end

end mul_char

end properties


/-
Copyright (c) 2020 Johan Commelin, Damiano Testa. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Damiano Testa, Yaël Dillies
-/
import logic.equiv.basic
import logic.nontrivial
import order.basic

/-!
# Type synonyms

This file provides two type synonyms for order theory:
* `order_dual α`: Type synonym of `α` to equip it with the dual order (`a ≤ b` becomes `b ≤ a`).
* `lex α`: Type synonym of `α` to equip it with its lexicographic order. The precise meaning depends
  on the type we take the lex of. Examples include `prod`, `sigma`, `list`, `finset`.

## Notation

`αᵒᵈ` is notation for `order_dual α`.

The general rule for notation of `lex` types is to append `ₗ` to the usual notation.

## Implementation notes

One should not abuse definitional equality between `α` and `αᵒᵈ`/`lex α`. Instead, explicit
coercions should be inserted:
* `order_dual`: `order_dual.to_dual : α → αᵒᵈ` and `order_dual.of_dual : αᵒᵈ → α`
* `lex`: `to_lex : α → lex α` and `of_lex : lex α → α`.

In fact, those are bundled as `equiv`s to put goals in the right syntactic form for rewriting with
the `equiv` API (`⇑to_lex a` where `⇑` is `coe_fn : (α ≃ lex α) → α → lex α`, instead of a bare
`to_lex a`).

## See also

This file is similar to `algebra.group.type_tags`.
-/

variables {α β γ : Type*}

/-! ### Order dual -/

namespace order_dual

instance [h : nontrivial α] : nontrivial (αᵒᵈ) := h

/-- `to_dual` is the identity function to the `order_dual` of a linear order.  -/
def to_dual : α ≃ αᵒᵈ := equiv.refl _

/-- `of_dual` is the identity function from the `order_dual` of a linear order.  -/
def of_dual : αᵒᵈ ≃ α := equiv.refl _

@[simp] lemma to_dual_symm_eq : (@to_dual α).symm = of_dual := rfl
@[simp] lemma of_dual_symm_eq : (@of_dual α).symm = to_dual := rfl
@[simp] lemma to_dual_of_dual (a : αᵒᵈ) : to_dual (of_dual a) = a := rfl
@[simp] lemma of_dual_to_dual (a : α) : of_dual (to_dual a) = a := rfl
@[simp] lemma to_dual_inj {a b : α} : to_dual a = to_dual b ↔ a = b := iff.rfl
@[simp] lemma of_dual_inj {a b : αᵒᵈ} : of_dual a = of_dual b ↔ a = b := iff.rfl

@[simp] lemma to_dual_le_to_dual [has_le α] {a b : α} : to_dual a ≤ to_dual b ↔ b ≤ a := iff.rfl
@[simp] lemma to_dual_lt_to_dual [has_lt α] {a b : α} : to_dual a < to_dual b ↔ b < a := iff.rfl
@[simp] lemma of_dual_le_of_dual [has_le α] {a b : αᵒᵈ} : of_dual a ≤ of_dual b ↔ b ≤ a := iff.rfl
@[simp] lemma of_dual_lt_of_dual [has_lt α] {a b : αᵒᵈ} : of_dual a < of_dual b ↔ b < a := iff.rfl
lemma le_to_dual [has_le α] {a : αᵒᵈ} {b : α} : a ≤ to_dual b ↔ b ≤ of_dual a := iff.rfl
lemma lt_to_dual [has_lt α] {a : αᵒᵈ} {b : α} : a < to_dual b ↔ b < of_dual a := iff.rfl
lemma to_dual_le [has_le α] {a : α} {b : αᵒᵈ} : to_dual a ≤ b ↔ of_dual b ≤ a := iff.rfl
lemma to_dual_lt [has_lt α] {a : α} {b : αᵒᵈ} : to_dual a < b ↔ of_dual b < a := iff.rfl

/-- Recursor for `αᵒᵈ`. -/
@[elab_as_eliminator]
protected def rec {C : αᵒᵈ → Sort*} (h₂ : Π a : α, C (to_dual a)) : Π a : αᵒᵈ, C a := h₂

@[simp] protected lemma «forall» {p : αᵒᵈ → Prop} : (∀ a, p a) ↔ ∀ a, p (to_dual a) := iff.rfl
@[simp] protected lemma «exists» {p : αᵒᵈ → Prop} : (∃ a, p a) ↔ ∃ a, p (to_dual a) := iff.rfl

alias to_dual_le_to_dual ↔ _ has_le.le.dual
alias to_dual_lt_to_dual ↔ _ has_lt.lt.dual
alias of_dual_le_of_dual ↔ _ has_le.le.of_dual
alias of_dual_lt_of_dual ↔ _ has_lt.lt.of_dual

end order_dual

/-! ### Lexicographic order -/

/-- A type synonym to equip a type with its lexicographic order. -/
def lex (α : Type*) := α

/-- `to_lex` is the identity function to the `lex` of a type.  -/
@[pattern] def to_lex : α ≃ lex α := equiv.refl _

/-- `of_lex` is the identity function from the `lex` of a type.  -/
@[pattern] def of_lex : lex α ≃ α := equiv.refl _

@[simp] lemma to_lex_symm_eq : (@to_lex α).symm = of_lex := rfl
@[simp] lemma of_lex_symm_eq : (@of_lex α).symm = to_lex := rfl
@[simp] lemma to_lex_of_lex (a : lex α) : to_lex (of_lex a) = a := rfl
@[simp] lemma of_lex_to_lex (a : α) : of_lex (to_lex a) = a := rfl
@[simp] lemma to_lex_inj {a b : α} : to_lex a = to_lex b ↔ a = b := iff.rfl
@[simp] lemma of_lex_inj {a b : lex α} :  of_lex a = of_lex b ↔ a = b := iff.rfl

/-- A recursor for `lex`. Use as `induction x using lex.rec`. -/
protected def lex.rec {β : lex α → Sort*} (h : Π a, β (to_lex a)) : Π a, β a := λ a, h (of_lex a)


import
  data.real.golden_ratio
  algebra.order.complete_field
  extra.real_hom.semifield_char0_hom
  extra.real_prop.real_nat_root
  extra.real_prop.real_quadratic_sol

/-! # IMO 2021 A8, Generalized Version -/

namespace IMOSL
namespace IMO2021A8

open function real IMOSL.extra.real

def fn_eq {R : Type*} [ring R] (f : ℝ → R) := ∀ a b c : ℝ, (f a - f b) * (f b - f c) * (f c - f a)
  = f(a * b ^ 2 + b * c ^ 2 + c * a ^ 2) - f(b * a ^ 2 + c * b ^ 2 + a * c ^ 2)

section extra

variables {R : Type*} [add_comm_monoid R] {S : Type*} [comm_ring S] [is_domain S]

private lemma add_cube_cube_add_eq (S3ne0 : (3 : S) ≠ 0) {t u v : S}
    (h : (t + u) ^ 3 + v ^ 3 = (u + v) ^ 3 + t ^ 3) :
  t + u + v = 0 ∨ u = 0 ∨ v = t :=
begin
  rw ← sub_eq_zero at h,
  replace h : -((t + u + v) * (u * (v - t)) * 3) = 0 := by rw ← h; ring,
  rwa [neg_eq_zero, mul_eq_zero, or_iff_left S3ne0, mul_eq_zero, mul_eq_zero, sub_eq_zero] at h
end

private lemma add_cube_cube_add_zero_triple {t u v : S} (h : (t + u) ^ 3 + v ^ 3 = 0)
    (h0 : (u + v) ^ 3 + t ^ 3 = 0) (h1 : (v + t) ^ 3 + u ^ 3 = 0) : t + u + v = 0 :=
begin
  cases eq_or_ne ((3 : ℕ) : S) 0 with S3eq0 S3ne0,
  { replace S3eq0 := char_p.ring_char_of_prime_eq_zero nat.prime_three S3eq0,
    rw ring_char.eq_iff at S3eq0,
    unfreezingI { rw ← add_pow_char at h },
    exact pow_eq_zero h },
  { rw [nat.cast_bit1, nat.cast_one] at S3ne0,
    replace h1 : v + t + u = 0 ∨ t = 0 ∨ u = v :=
      by rw ← h at h1; exact add_cube_cube_add_eq S3ne0 h1,
    replace h : t + u + v = 0 ∨ u = 0 ∨ v = t :=
      by rw ← h0 at h; exact add_cube_cube_add_eq S3ne0 h,
    cases h with h h,
    exact h,
    rw [add_assoc, add_comm] at h1,
    cases h1 with h1 h1,
    exact h1,
    rcases h with rfl | rfl,
    { rw @eq_comm _ 0 v at h1,
      rcases h1 with rfl | rfl,
      rw [zero_pow zero_lt_three, add_zero, zero_add] at h0,
      rw [zero_add, zero_add]; exact pow_eq_zero h0,
      rw [add_zero, zero_pow zero_lt_three, zero_add] at h0,
      rw [add_zero, add_zero]; exact pow_eq_zero h0 },
    { rcases h1 with rfl | rfl,
      rw [add_zero, zero_pow zero_lt_three, add_zero] at h0,
      rw [zero_add, add_zero]; exact pow_eq_zero h0,
      rw [← two_mul, mul_pow, ← add_one_mul, mul_eq_zero, or_iff_right] at h0,
      rw [pow_eq_zero h0, add_zero, add_zero],
      clear h0; intros h0,
      replace h0 : (3 : S) ^ 2 = 0 := by rw ← h0; norm_num,
      exact S3ne0 (pow_eq_zero h0) } },
end

private lemma g_sum_zero_of_g_cube_sum_zero {g : R → S}
  (h : ∀ x y z : R, x + y + z = 0 → (g x + g y) ^ 3 + g z ^ 3 = 0) :
  ∀ x y z : R, x + y + z = 0 → g x + g y + g z = 0 :=
begin
  intros x y z hs,
  have hxyz := h x y z hs,
  rw [add_assoc, add_comm] at hs,
  have hyzx := h y z x hs,
  rw [add_assoc, add_comm] at hs,
  have hzxy := h z x y hs,
  exact add_cube_cube_add_zero_triple hxyz hyzx hzxy
end

private lemma g_sum_cube_eq_sum_g_cube {R : Type*} [add_comm_group R] {g : R → S}
  (h : ∀ x y : R, (g (x + y)) ^ 3 = (g x + g y) ^ 3) (h0 : ∀ x : R, g (-x) = -g x) :
  ∀ x y : R, g (x + y) = g x + g y :=
begin
  suffices : ∀ x y z : R, x + y + z = 0 → g x + g y + g z = 0,
  { intros x y,
    replace this := this x y (-(x + y)) (add_neg_self _),
    rwa [h0, add_neg_eq_zero, eq_comm] at this },
  apply g_sum_zero_of_g_cube_sum_zero; intros x y z h1,
  rw add_eq_zero_iff_neg_eq at h1,
  rw [← h1, h0, ← h, neg_pow_bit1, add_neg_self]
end

end extra

section results

private lemma lem1_1 {R : Type*} [ring R] {f : ℝ → R} (C : R) : fn_eq (f + const ℝ C) ↔ fn_eq f :=
  by simp only [fn_eq, const_apply, add_sub_add_right_eq_sub, pi.add_apply]

private lemma lem1_2 {R : Type*} [ring R] {f : ℝ → R} : fn_eq (-f) ↔ fn_eq f :=
begin
  simp only [fn_eq, pi.neg_apply],
  conv_lhs { find (_ = _) { rw [← neg_sub', ← neg_sub', neg_mul_neg,
    ← neg_sub', ← neg_sub', mul_neg, neg_inj] } }
end

private lemma lem1_3 {t : ℝ} (h : t < 2⁻¹) : ∃ x : ℝ, t ^ 2 + t * x ^ 2 + x = 0 :=
begin
  rcases eq_or_ne t 0 with rfl | h0,
  use 0; rw [zero_mul, sq, zero_mul, add_zero, add_zero],
  obtain ⟨x, h1⟩ : ∃ x : ℝ, x ^ 2 + t⁻¹ * x + t = 0 :=
  begin
    apply extra.exists_root_quadr,
    cases le_or_lt t 0 with h1 h1,
    exact le_trans (mul_nonpos_of_nonneg_of_nonpos zero_le_four h1) (sq_nonneg _),
    rw lt_inv h1 two_pos at h,
    rw [← le_div_iff h1, div_eq_mul_inv, ← pow_succ'],
    refine le_trans (by norm_num) (pow_le_pow_of_le_left zero_le_two (le_of_lt h) 3)
  end,
  replace h1 := congr_arg (has_mul.mul t) h1,
  rw [mul_zero, mul_add, ← sq, mul_add, ← mul_assoc, mul_inv_cancel h0, one_mul] at h1,
  use x; rwa [add_assoc, add_comm]
end

section f_not_inj

variables {R : Type*} [ring R]

/-- Useful definition for the case where f is not injective -/
private def good (f : ℝ → R) (t : ℝ) := ∃ c : ℝ, c ≠ 0 ∧ f (c * t) = f c

variables {f : ℝ → R} (feq : fn_eq f)
include feq

private lemma lem2_1 {t x : ℝ} (h : f (x * t) = f x) (d : ℝ) :
  f (x ^ 3 * (t + d ^ 2 + d * t ^ 2)) = f (x ^ 3 * (t ^ 2 + d + t * d ^ 2)) :=
begin
  replace feq := feq (x * t) x (x * d),
  rwa [h, sub_self, zero_mul, zero_mul, eq_comm, sub_eq_zero] at feq,
  convert feq; ring
end

private lemma lem2_2 (h : ∃ c : ℝ, f c = f 0 ∧ c ≠ 0) (x : ℝ) : f (-x) = f x :=
begin
  rcases h with ⟨c, h, h0⟩,
  replace h := lem2_1 feq (by rw [mul_zero, h] : f (c * 0) = f c),
  ring_nf at h,
  have h1 := h (-(x / c ^ 3)),
  rwa [neg_sq, h, neg_mul, div_mul_cancel x (pow_ne_zero 3 h0), eq_comm] at h1
end

private lemma lem2_3 (h : ∀ x : ℝ, f (-x) = f x) : f = const ℝ (f 0) :=
begin
  ext x; set y := nat_root 3 (x / (2 * golden_ratio)) with hy,
  replace h := h y,
  rw ← mul_neg_one at h,
  replace h := lem2_1 feq h golden_ratio,
  rw [neg_one_sq, gold_sq] at h; ring_nf at h,
  rwa [pow_nat_root_self_bit1, mul_div_cancel' x (mul_ne_zero two_ne_zero gold_ne_zero)] at h
end

private lemma lem2_4 {t : ℝ} (h : t ≠ 0) (h0 : good f t) : good f (t ^ 4) :=
begin
  rcases h0 with ⟨c, h1, h2⟩,
  use c ^ 3 * t; split,
  exact mul_ne_zero (pow_ne_zero 3 h1) h,
  convert (lem2_1 feq h2 (-t ^ 2)).symm using 2,
  rw [add_neg_self, zero_add, mul_assoc, neg_sq, bit0, ← two_mul, pow_mul],
  rw [neg_sq, neg_mul, ← sq, add_neg_cancel_right]
end

private lemma lem2_5 (h : ∃ t : ℝ, t < 2⁻¹ ∧ good f t) : ∃ c : ℝ, f c = f 0 ∧ c ≠ 0 :=
begin
  rcases h with ⟨t, h, c, h0, h1⟩,
  rcases eq_or_ne t 0 with rfl | h2,
  use c; rw [and_iff_left h0, ← h1, mul_zero],
  rcases lem1_3 h with ⟨x, h3⟩,
  use c ^ 3 * (t + x ^ 2 + x * t ^ 2); split,
  replace feq := lem2_1 feq h1 x,
  rwa [add_right_comm (t ^ 2), h3, mul_zero] at feq,
  refine mul_ne_zero (pow_ne_zero 3 h0) _,
  intros h4; rw add_eq_zero_iff_eq_neg at h4,
  rw [sq, ← mul_add, h4, mul_neg, neg_add_eq_zero, mul_left_comm,
      mul_right_eq_self₀, ← pow_succ, bit0, pow_bit1_eq_one_iff 1 t] at h3,
  rcases h3 with rfl | rfl,
  exact not_lt_of_le (by norm_num) h,
  rw [sq, zero_mul, zero_mul, add_zero, neg_zero] at h4,
  exact h2 h4
end

private lemma lem2_6 (h : ∃ t : ℝ, t ≠ 1 ∧ good f t) : ∃ c : ℝ, f c = f 0 ∧ c ≠ 0 :=
begin
  replace h : ∃ t : ℝ, t < 1 ∧ good f t :=
  begin
    rcases h with ⟨t, h, h0⟩,
    rw ne_iff_lt_or_gt at h,
    cases h with h h,
    exact ⟨t, h, h0⟩,
    use t⁻¹; split,
    exact inv_lt_one h,
    rcases h0 with ⟨c, h0, h1⟩,
    replace h := ne_of_gt (gt_trans h one_pos),
    use c * t; split,
    exact mul_ne_zero h0 h,
    rw [h1, mul_assoc, mul_inv_cancel h, mul_one]
  end,
  rcases h with ⟨t, h, h0⟩,
  cases lt_or_le t 2⁻¹ with h1 h1,
  exact lem2_5 feq ⟨t, h1, h0⟩,
  replace h1 : 0 < t := lt_of_lt_of_le (by norm_num) h1,
  obtain ⟨n, h2⟩ : ∃ n : ℕ, t ^ n < 2⁻¹ := exists_pow_lt_of_lt_one (inv_pos.mpr zero_lt_two) h,
  refine lem2_5 feq ⟨t ^ (4 ^ n), _, _⟩,
  { refine lt_trans _ h2,
    rw pow_lt_pow_iff_of_lt_one h1 h,
    exact nat.lt_pow_self (by norm_num) n },
  { clear h2; induction n with n n_ih,
    rwa [pow_zero, pow_one],
    rw [pow_succ', pow_mul],
    exact lem2_4 feq (pow_ne_zero _ (ne_of_gt h1)) n_ih }
end

/-- If f is not injective, then f is constant. -/
private lemma thm2 (h : ¬injective f) : f = const ℝ (f 0) :=
begin
  refine lem2_3 feq (lem2_2 feq _),
  simp only [injective, not_forall] at h,
  rcases h with ⟨a, b, h, h0⟩,
  rcases eq_or_ne b 0 with rfl | h1,
  exact ⟨a, h, h0⟩,
  apply lem2_6 feq,
  use a / b; split,
  intros h2; exact h0 (eq_of_div_eq_one h2),
  use b; rw [and_iff_right h1, mul_div_cancel' a h1, h]
end

end f_not_inj

section f_inj_f0_eq_0

variables {R : Type*} [comm_ring R] [is_domain R]
variables {f : ℝ → R} (feq : fn_eq f) (f_inj : injective f) (f0_eq_0 : f 0 = 0)
include feq f_inj f0_eq_0

private lemma lem3_1 (a b : ℝ) : (f a - f b) * f a * f b = f (b * a ^ 2) - f (a * b ^ 2) :=
begin
  replace feq := feq b a 0,
  rw [f0_eq_0, sub_zero, zero_sub, mul_neg, ← neg_mul, ← neg_mul, neg_sub] at feq,
  rw [feq, zero_pow zero_lt_two]; simp only [add_zero, zero_mul, mul_zero]
end

private lemma lem3_2 {a : ℝ} (h : a ≠ 0) : (f 1 - (f a + f (-a))) * f 1 = 1 :=
begin
  have h0 := lem3_1 feq f_inj f0_eq_0 1,
  simp only [one_pow, mul_one, one_mul] at h0,
  replace h0 : (f a - f (-a)) * ((f 1 - (f a + f (-a))) * f 1) = f a - f (-a) :=
  begin
    convert congr_arg2 has_sub.sub (h0 a) (h0 (-a)) using 1,
    ring,
    rw [neg_sq, sub_sub_sub_cancel_right]
  end,
  rw [mul_right_eq_self₀, sub_eq_zero] at h0,
  revert h0; refine (or_iff_left _).mp,
  intros h0,
  replace h0 := f_inj h0,
  rw eq_neg_self_iff at h0,
  exact h h0
end

private lemma lem3_3 (a : ℝ) : f (-a) = -f a :=
begin
  obtain ⟨C, h⟩ : ∃ C : R, ∀ b : ℝ, b ≠ 0 → f (-b) = C - f b :=
  begin
    use f 1 + f (-1); intros b h,
    rw eq_sub_iff_add_eq',
    replace h := lem3_2 feq f_inj f0_eq_0 h,
    have h0 := lem3_2 feq f_inj f0_eq_0 one_ne_zero,
    rw [← h0, mul_eq_mul_right_iff, sub_right_inj] at h,
    revert h; refine (or_iff_left _).mp,
    intros h,
    rw [h, mul_zero] at h0,
    exact zero_ne_one h0
  end,
  revert a; suffices : C = 0,
  { intros a,
    rcases eq_or_ne a 0 with rfl | h0,
    rw [neg_zero, f0_eq_0, neg_zero],
    rw [h a h0, this, zero_sub] },
  replace feq : ∀ a : ℝ, a ≠ 0 → a⁻¹ ≠ a → f a⁻¹ * f a = 1 :=
  begin
    intros a h0 h1,
    replace feq := lem3_1 feq f_inj f0_eq_0 a⁻¹ a,
    rwa [sq, ← mul_assoc, mul_inv_cancel h0, one_mul, sq, ← mul_assoc,
         inv_mul_cancel h0, one_mul, mul_assoc, mul_right_eq_self₀,
         sub_eq_zero, or_iff_left (λ h2, h1 (f_inj h2))] at feq
  end,
  have h0 := feq (-2) (by norm_num) (by norm_num),
  rwa [h 2 two_ne_zero, ← neg_inv, h 2⁻¹ (by norm_num), sub_mul,
       mul_sub (f 2⁻¹), feq 2 two_ne_zero (by norm_num), ← sub_add,
       add_left_eq_self, mul_comm, ← sub_mul, mul_eq_zero, sub_eq_zero] at h0,
  revert h0; refine (or_iff_right _).mp,
  rw ← h 2 two_ne_zero,
  intros h0; replace h0 := f_inj h0,
  revert h0; norm_num
end

private lemma lem3_4 : (f 1) ^ 2 = 1 :=
begin
  have h := lem3_2 feq f_inj f0_eq_0 one_ne_zero,
  rwa [lem3_3 feq f_inj f0_eq_0, add_neg_self, sub_zero, ← sq] at h
end

private lemma R2ne0 (f1_eq_1 : f 1 = 1) : (2 : R) ≠ 0 :=
begin
  intros h,
  rw [bit0, ← eq_neg_iff_add_eq_zero, ← f1_eq_1, ← lem3_3 feq f_inj f0_eq_0] at h,
  replace h := f_inj h,
  rw [eq_neg_iff_add_eq_zero, ← bit0] at h,
  exact two_ne_zero h
end

private lemma lem3_5 (f1_eq_1 : f 1 = 1) (a b : ℝ) : f (a * b) = f a * f b :=
begin
  revert a b; suffices : ∀ a b : ℝ, 0 ≤ a → f (a * b) = f a * f b,
  { intros a b,
    cases le_total 0 a with h h,
    exact this a b h,
    rw [← neg_le_neg_iff, neg_zero] at h,
    replace this := this _ b h,
    replace h := lem3_3 feq f_inj f0_eq_0,
    rwa [neg_mul, h, h, neg_mul, neg_inj] at this },
  suffices : ∀ a b : ℝ, f (a ^ 2 * b) = f a ^ 2 * f b,
  { intros a b h,
    have h0 := this (sqrt a) 1,
    rw [mul_one, f1_eq_1, sq_sqrt h, mul_one] at h0,
    replace this := this (sqrt a) b,
    rwa [← h0, sq_sqrt h] at this },
  intros a b,
  have h := lem3_1 feq f_inj f0_eq_0 a,
  replace h := congr_arg2 has_sub.sub (h b) (h (-b)),
  simp only [neg_sq, neg_mul, mul_neg, sub_sub_sub_cancel_right,
             sub_neg_eq_add, lem3_3 feq f_inj f0_eq_0] at h,
  rwa [← add_mul, ← add_mul, sub_add_add_cancel, ← two_mul, mul_assoc (2 : R), ← sq,
       mul_comm b, ← two_mul, mul_assoc, eq_comm, mul_eq_mul_left_iff] at h,
  exact (or_iff_left (R2ne0 feq f_inj f0_eq_0 f1_eq_1)).mp h
end

private lemma lem3_6 (f1_eq_1 : f 1 = 1) (a : ℝ) (n : ℕ) : f (a ^ n) = f a ^ n :=
begin
  induction n with n n_ih,
  rw [pow_zero, pow_zero, f1_eq_1],
  rw [pow_succ, pow_succ, lem3_5 feq f_inj f0_eq_0 f1_eq_1, n_ih]
end

variable f1_eq_1 : f 1 = 1
include f1_eq_1

private lemma lem3_7 {t : ℝ} (h : t ≠ 0) :
  f (t ^ 2 + t⁻¹) + f (t ^ 2 - t⁻¹) = f 2 - 2 + 2 * f t ^ 2 :=
begin
  revert t h,
  have fodd := lem3_3 feq f_inj f0_eq_0,
  have fmul := lem3_5 feq f_inj f0_eq_0 f1_eq_1,
  suffices : ∀ t : ℝ, t < 0 → f (t ^ 2 + t⁻¹) + f (t ^ 2 - t⁻¹) = f 2 - 2 + 2 * f t ^ 2,
  { intros t h,
    rw [ne_iff_lt_or_gt, gt_iff_lt, ← neg_neg_iff_pos] at h,
    cases h with h h,
    exact this t h,
    replace this := this (-t) h,
    rwa [neg_sq, ← neg_inv, fodd, neg_sq, add_comm, sub_neg_eq_add, ← sub_eq_add_neg] at this },
  intros t h,
  obtain ⟨x, h0⟩ := lem1_3 (lt_trans h (by norm_num)),
  replace feq := feq 1 t,
  conv at feq { find (_ = _) {
    rw [f1_eq_1, one_mul, one_mul, one_pow, mul_one, mul_one, add_right_comm t] } },
  have h1 : t + x ^ 2 = -x * t⁻¹ := by rw [eq_mul_inv_iff_mul_eq₀ (ne_of_lt h),
    mul_comm, mul_add, ← sq, ← add_eq_zero_iff_eq_neg, h0],
  rw add_eq_zero_iff_eq_neg at h0,
  have h2 := congr_arg2 has_sub.sub (feq (-x)) (feq x),
  rw [neg_sq, h0, h1, neg_add_self, f0_eq_0, zero_sub, sub_neg_eq_add, ← mul_add, ← two_mul,
      fmul, fmul, add_comm ((-x * _)), neg_mul, ← sub_eq_add_neg, ← mul_sub, fmul, fodd] at h2,
  replace h2 : (2 * f t ^ 2 - 2) * f x = (f (t⁻¹ + t ^ 2) + f (t ^ 2 - t⁻¹) - f 2) * f x :=
    by convert h2; ring,
  rw mul_eq_mul_right_iff at h2,
  cases h2 with h2 h2,
  rwa [add_comm t⁻¹, eq_sub_iff_add_eq', add_sub, add_sub_right_comm, eq_comm] at h2,
  rw ← f0_eq_0 at h2; replace h2 := f_inj h2,
  rw [h2, neg_zero, zero_mul, sq, zero_mul, add_zero] at h1,
  exfalso; exact ne_of_lt h h1
end

private lemma lem3_8 : ∀ t u : ℝ, 2 * f (t ^ 3 + u ^ 3) =
 (f 2 - 2) * (f t ^ 2 * f u + f u ^ 2 * f t) + 2 * (f u ^ 3 + f t ^ 3) :=
begin
  have fodd := lem3_3 feq f_inj f0_eq_0,
  have fpow := lem3_6 feq f_inj f0_eq_0 f1_eq_1,
  have fmul := lem3_5 feq f_inj f0_eq_0 f1_eq_1,

  suffices : ∀ t u : ℝ, f (t ^ 3 + u ^ 3) + f (u ^ 3 - t ^ 3)
    = (f 2 - 2) * f t ^ 2 * f u + 2 * f u ^ 3,
  { intros t u,
    replace this := congr_arg2 has_add.add (this t u) (this u t),
    rw [← neg_sub, fodd, ← sub_eq_add_neg, sub_add_add_cancel, add_comm (u ^ 3)] at this,
    rw [two_mul, this, add_add_add_comm, ← mul_add, mul_assoc, mul_assoc, ← mul_add] },

  intros t u,
  rcases eq_or_ne t 0 with rfl | h,
  rw [f0_eq_0, zero_pow three_pos, zero_add, sub_zero, ← two_mul,
      fpow, zero_pow two_pos, mul_zero, zero_mul, zero_add],
  rcases eq_or_ne u 0 with rfl | h0,
  rw [f0_eq_0, zero_pow three_pos, add_zero, zero_sub, fodd,
      add_neg_self, zero_pow three_pos, ← add_mul, mul_zero],
  have h1 := congr_arg (* (f (t ^ 2 * u)))
    (lem3_7 feq f_inj f0_eq_0 f1_eq_1 (div_ne_zero h0 h)),
  simp only [add_mul] at h1,
  rw [← fmul, ← fmul, mul_assoc, ← fpow, ← fmul] at h1,
  field_simp at h1,
  rwa [fmul, fpow, ← mul_assoc, mul_comm (t ^ 2) u, ← mul_assoc, ← pow_succ', ← pow_succ,
       mul_div_cancel _ (pow_ne_zero 2 h), ← pow_succ', add_comm (u ^ _) (t ^ _), fpow] at h1
end

private lemma lem3_9 : f 2 = 2 ∨ f (nat_root 3 2) = 2 :=
begin
  have fpow := lem3_6 feq f_inj f0_eq_0 f1_eq_1,
  have fneg1 : f (-1) = -1 := by rw [lem3_3 feq f_inj f0_eq_0, f1_eq_1],
  have h := lem3_8 feq f_inj f0_eq_0 f1_eq_1 (nat_root 3 2) (-1),
  rw [← fpow (nat_root 3 2) 3, pow_nat_root_self_bit1, neg_pow_bit1, one_pow, fneg1,
      mul_comm, bit0, ← sub_eq_add_neg, add_sub_cancel, f1_eq_1, ← sub_eq_zero] at h,
  set D := f (nat_root 3 2),
  replace h : (f 2 - 2) * (D - 2) * (D + 1) = 0 := by rw ← h; ring,
  rw [mul_eq_zero, add_eq_zero_iff_eq_neg] at h,
  cases h with h h,
  rwa [mul_eq_zero, sub_eq_zero, sub_eq_zero] at h,
  replace h := congr_arg (λ x, x ^ 3) h,
  dsimp only [D] at h,
  rw [← fpow, pow_nat_root_self_bit1, neg_pow_bit1, one_pow, ← fneg1] at h,
  replace h := f_inj h,
  exfalso; revert h; norm_num
end

private theorem thm3_1 (f2_eq_2 : f 2 = 2) : ∃ φ : ℝ →+* R, f = (φ : ℝ → R) :=
begin
  refine ⟨⟨f, f1_eq_1, lem3_5 feq f_inj f0_eq_0 f1_eq_1, f0_eq_0, _⟩, rfl⟩,
  intros x y,
  have h := lem3_8 feq f_inj f0_eq_0 f1_eq_1 (nat_root 3 x) (nat_root 3 y),
  have fpow := lem3_6 feq f_inj f0_eq_0 f1_eq_1,
  rw [f2_eq_2, sub_self, zero_mul, ← fpow, ← fpow, pow_nat_root_self_bit1,
      pow_nat_root_self_bit1, zero_add, mul_eq_mul_left_iff] at h,
  cases h with h h,
  rw [h, add_comm],
  exfalso; exact R2ne0 feq f_inj f0_eq_0 f1_eq_1 h
end

private theorem thm3_2 (froot2_eq_2 : f (nat_root 3 2) = 2) : ∃ φ : ℝ →+* R, f = λ x, φ x ^ 3 :=
begin
  have fpow := lem3_6 feq f_inj f0_eq_0 f1_eq_1,
  use λ x, f (nat_root 3 x),
  rw [nat_root_bit1_one, f1_eq_1],
  intros x y,
  rw [nat_root_bit1_mul, lem3_5 feq f_inj f0_eq_0 f1_eq_1],
  rw [nat_root_bit1_zero, f0_eq_0],
  swap,
  rw ring_hom.coe_mk; funext x,
  rw [← fpow, pow_nat_root_self_bit1 1],
  replace froot2_eq_2 : f 2 - 2 = 2 * 3 :=
    by rw [← pow_nat_root_self_bit1 1 2, fpow, froot2_eq_2]; norm_num,
  have h : ∀ x : ℝ, (λ x, f (nat_root 3 x)) (-x) = -(λ x, f (nat_root 3 x)) x :=
    λ x, by dsimp only []; rw [nat_root_bit1_neg 1 x, lem3_3 feq f_inj f0_eq_0],
  refine g_sum_cube_eq_sum_g_cube (λ x y, _) h,
  replace h := lem3_8 feq f_inj f0_eq_0 f1_eq_1 (nat_root 3 x) (nat_root 3 y),
  rw [pow_nat_root_self_bit1, pow_nat_root_self_bit1, froot2_eq_2,
      mul_assoc, ← mul_add, mul_eq_mul_left_iff] at h,
  cases h with h h,
  rw [← fpow, pow_nat_root_self_bit1, h]; ring,
  exfalso; exact R2ne0 feq f_inj f0_eq_0 f1_eq_1 h
end

end f_inj_f0_eq_0

end results

/- Final solution -/
theorem final_solution_general {R : Type*} [comm_ring R] [is_domain R] (f : ℝ → R) : fn_eq f ↔
  (∃ C : R, f = const ℝ C) ∨
  ((∃ (φ : ℝ →+* R) (C : R), f = φ + const ℝ C) ∨
   (∃ (φ : ℝ →+* R) (C : R), f = (λ x, φ x ^ 3) + const ℝ C)) ∨
  ((∃ (φ : ℝ →+* R) (C : R), f = -φ + const ℝ C) ∨
   (∃ (φ : ℝ →+* R) (C : R), f = -(λ x, φ x ^ 3) + const ℝ C)) :=
begin
  split,
  { intros feq,
    by_cases h : injective f,
    swap,
    left; use (f 0); exact thm2 feq h,
    right; set g := f - const ℝ (f 0) with hg,
    rw [← lem1_1 (-f 0), ← pi.const_neg, ← sub_eq_add_neg, ← hg] at feq,
    replace h : injective g := λ x y h0,
      by simp only [g, pi.sub_apply, const_apply, sub_left_inj] at h0; exact h h0,
    have h0 : g 0 = 0 := by rw [hg, pi.sub_apply, const_apply, sub_self],
    have h1 := lem3_4 feq h h0,
    rw sq_eq_one_iff at h1,
    cases h1 with h1 h1,
    { left; cases lem3_9 feq h h0 h1 with h2 h2,
      left; rcases thm3_1 feq h h0 h1 h2 with ⟨φ, h3⟩; use [φ, (f 0)],
      rw [← h3, hg, sub_add_cancel],
      right; rcases thm3_2 feq h h0 h1 h2 with ⟨φ, h3⟩; use [φ, (f 0)],
      rw [← h3, hg, sub_add_cancel] },
    { right; clear_value g; subst hg,
      set g := -(f - const ℝ (f 0)) with hg,
      rw [← lem1_2, ← hg] at feq,
      replace h : injective g := λ x y h2,
        by rw [hg, pi.neg_apply, pi.neg_apply, neg_inj] at h2; exact h h2,
      rw [← neg_eq_zero, ← pi.neg_apply (f - _) 0, ← hg] at h0,
      rw [eq_neg_iff_eq_neg, eq_comm, ← pi.neg_apply (f - _) 1, ← hg] at h1,
      cases lem3_9 feq h h0 h1 with h2 h2,
      left; rcases thm3_1 feq h h0 h1 h2 with ⟨φ, h3⟩; use [φ, (f 0)],
      rw [← h3, hg, neg_neg, sub_add_cancel],
      right; rcases thm3_2 feq h h0 h1 h2 with ⟨φ, h3⟩; use [φ, (f 0)],
      rw [← h3, hg, neg_neg, sub_add_cancel] } },
  suffices : ∀ φ : ℝ →+* R, fn_eq φ ∧ fn_eq (λ x, φ x ^ 3),
  { rintros (⟨C, rfl⟩ | (⟨φ, C, rfl⟩ | ⟨φ, C, rfl⟩) | (⟨φ, C, rfl⟩ | ⟨φ, C, rfl⟩)),
    rw [← zero_add (const ℝ C), lem1_1],
    intros a b c; simp only [pi.zero_apply, sub_zero, mul_zero],
    all_goals { rw lem1_1 },
    exacts [(this φ).left, (this φ).right, lem1_2.mpr (this φ).left, lem1_2.mpr (this φ).right] },
  { intros φ; split,
    all_goals { intros a b c, simp only [map_add, map_mul, map_pow], ring } }
end

/-- Final solution, case char(R) ≠ 0 -/
theorem final_solution_char_ne_0 {R : Type*} [comm_ring R] [is_domain R]
  (p : ℕ) [fact (p ≠ 0)] [char_p R p] (f : ℝ → R) : fn_eq f ↔ ∃ C : R, f = const ℝ C :=
begin
  rw final_solution_general,
  apply or_iff_left,
  simp only [is_empty.exists_iff, or_false],
  exact not_false
end

/-- Final solution, case R = ℝ -/
theorem final_solution_real (f : ℝ → ℝ) : fn_eq f ↔ (∃ C : ℝ, f = const ℝ C) ∨
  ((∃ C : ℝ, f = id + const ℝ C) ∨ (∃ C : ℝ, f = (λ x, x ^ 3) + const ℝ C)) ∨
  ((∃ C : ℝ, f = -id + const ℝ C) ∨ (∃ C : ℝ, f = -(λ x, x ^ 3) + const ℝ C)) :=
  by simp only [final_solution_general, unique.exists_iff]; congr'

end IMO2021A8
end IMOSL


import tuto_lib

set_option pp.beta true
set_option pp.coercions false

/-
This is the final file in the series. Here we use everything covered
in previous files to prove a couple of famous theorems from
elementary real analysis. Of course they all have more general versions
in mathlib.

As usual, keep in mind the following:

  abs_le {x y : ℝ} : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y

  ge_max_iff (p q r) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q

  le_max_left p q : p ≤ max p q

  le_max_right p q : q ≤ max p q

as well as a lemma from the previous file:

  le_of_le_add_all : (∀ ε > 0, y ≤ x + ε) →  y ≤ x

Let's start with a variation on a known exercise.
-/

-- 0071
lemma le_lim {x y : ℝ} {u : ℕ → ℝ} (hu : seq_limit u x)
  (ineg : ∃ N, ∀ n ≥ N, y ≤ u n) : y ≤ x :=
begin
  sorry
end

/-
Let's now return to the result proved in the `00_` file of this series,
and prove again the sequential characterization of upper bounds (with a slighly
different proof).

For this, and other exercises below, we'll need many things that we proved in previous files,
and a couple of extras.

From the 5th file:

  limit_const (x : ℝ) : seq_limit (λ n, x) x

  squeeze (lim_u : seq_limit u l) (lim_w : seq_limit w l)
    (hu : ∀ n, u n ≤ v n) (hw : ∀ n, v n ≤ w n)  : seq_limit v l

From the 8th:

  def upper_bound (A : set ℝ) (x : ℝ) := ∀ a ∈ A, a ≤ x

  def is_sup (A : set ℝ) (x : ℝ) := upper_bound A x ∧ ∀ y, upper_bound A y → x ≤ y

  lt_sup (hx : is_sup A x) : ∀ y, y < x → ∃ a ∈ A, y < a :=

You can also use:

  nat.one_div_pos_of_nat {n : ℕ} : 0 < 1 / (n + 1 : ℝ)

  inv_succ_le_all :  ∀ ε > 0, ∃ N : ℕ, ∀ n ≥ N, 1/(n + 1 : ℝ) ≤ ε

and their easy consequences:

  limit_of_sub_le_inv_succ (h : ∀ n, |u n - x| ≤ 1/(n+1)) : seq_limit u x

  limit_const_add_inv_succ (x : ℝ) : seq_limit (λ n, x + 1/(n+1)) x

  limit_const_sub_inv_succ (x : ℝ) : seq_limit (λ n, x - 1/(n+1)) x

as well as:

  lim_le (hu : seq_limit u x) (ineg : ∀ n, u n ≤ y) : x ≤ y

The structure of the proof is offered. It features a new tactic:
`choose` which invokes the axiom of choice (observing the tactic state before and
after using it should be enough to understand everything).
-/

-- 0072
lemma is_sup_iff (A : set ℝ) (x : ℝ) :
(is_sup A x) ↔ (upper_bound A x ∧ ∃ u : ℕ → ℝ, seq_limit u x ∧ ∀ n, u n ∈ A ) :=
begin
  split,
  { intro h,
    split,
    {
      sorry
    },
    { have : ∀ n : ℕ, ∃ a ∈ A, x - 1/(n+1) < a,
      { intros n,
        have : 1/(n+1 : ℝ) > 0,
          exact nat.one_div_pos_of_nat,
        sorry
      },
      choose u hu using this,
      sorry
  } },
  { rintro ⟨maj, u, limu, u_in⟩,
    sorry
  },
end

/-- Continuity of a function at a point  -/
def continuous_at_pt (f : ℝ → ℝ) (x₀ : ℝ) : Prop :=
∀ ε > 0, ∃ δ > 0, ∀ x, |x - x₀| ≤ δ → |f x - f x₀| ≤ ε

variables {f : ℝ → ℝ} {x₀ : ℝ} {u : ℕ → ℝ}

-- 0073
lemma seq_continuous_of_continuous (hf : continuous_at_pt f x₀)
  (hu : seq_limit u x₀) : seq_limit (f ∘ u) (f x₀) :=
begin
  sorry
end

-- 0074
example :
  (∀ u : ℕ → ℝ, seq_limit u x₀ → seq_limit (f ∘ u) (f x₀)) →
  continuous_at_pt f x₀ :=
begin
  sorry
end

/-
Recall from the 6th file:

  def extraction (φ : ℕ → ℕ) := ∀ n m, n < m → φ n < φ m

  def cluster_point (u : ℕ → ℝ) (a : ℝ) :=
    ∃ φ, extraction φ ∧ seq_limit (u ∘ φ) a

  id_le_extraction : extraction φ → ∀ n, n ≤ φ n

and from the 8th file:

  def tendsto_infinity (u : ℕ → ℝ) := ∀ A, ∃ N, ∀ n ≥ N, u n ≥ A

  not_seq_limit_of_tendstoinfinity : tendsto_infinity u → ∀ l, ¬ seq_limit u l
-/

variables {φ : ℕ → ℕ}

-- 0075
lemma subseq_tendstoinfinity
  (h : tendsto_infinity u) (hφ : extraction φ) :
tendsto_infinity (u ∘ φ) :=
begin
  sorry
end

-- 0076
lemma squeeze_infinity {u v : ℕ → ℝ} (hu : tendsto_infinity u)
(huv : ∀ n, u n ≤ v n) : tendsto_infinity v :=
begin
  sorry
end

/-
We will use segments: Icc a b := { x | a ≤ x ∧ x ≤ b }
The notation stands for Interval-closed-closed. Variations exist with
o or i instead of c, where o stands for open and i for infinity.

We will use the following version of Bolzano-Weierstrass

  bolzano_weierstrass (h : ∀ n, u n ∈ [a, b]) :
    ∃ c ∈ [a, b], cluster_point u c

as well as the obvious

  seq_limit_id : tendsto_infinity (λ n, n)
-/
open set

-- 0077
lemma bdd_above_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ M, ∀ x ∈ Icc a b, f x ≤ M :=
begin
  sorry
end

/-
In the next exercise, we can use:

  abs_neg x : |-x| = |x|
-/

-- 0078
lemma continuous_opposite {f : ℝ → ℝ} {x₀ : ℝ} (h : continuous_at_pt f x₀) :
  continuous_at_pt (λ x, -f x) x₀ :=
begin
  sorry
end

/-
Now let's combine the two exercises above
-/

-- 0079
lemma bdd_below_segment {f : ℝ → ℝ} {a b : ℝ} (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ m, ∀ x ∈ Icc a b, m ≤ f x :=
begin
  sorry
end

/-
Remember from the 5th file:

 unique_limit : seq_limit u l → seq_limit u l' → l = l'

and from the 6th one:

  subseq_tendsto_of_tendsto (h : seq_limit u l) (hφ : extraction φ) :
    seq_limit (u ∘ φ) l

We now admit the following version of the least upper bound theorem
(that cannot be proved without discussing the construction of real numbers
or admitting another strong theorem).

sup_segment {a b : ℝ} {A : set ℝ} (hnonvide : ∃ x, x ∈ A) (h : A ⊆ Icc a b) :
  ∃ x ∈ Icc a b, is_sup A x

In the next exercise, it can be useful to prove inclusions of sets of real number.
By definition, A ⊆ B means : ∀ x, x ∈ A → x ∈ B.
Hence one can start a proof of A ⊆ B by `intros x x_in`,
which brings `x : ℝ` and `x_in : x ∈ A` in the local context,
and then prove `x ∈ B`.

Note also the use of
  {x | P x}
which denotes the set of x satisfying predicate P.

Hence `x' ∈ { x | P x} ↔ P x'`, by definition.
-/

-- 0080
example {a b : ℝ} (hab : a ≤ b) (hf : ∀ x ∈ Icc a b, continuous_at_pt f x) :
∃ x₀ ∈ Icc a b, ∀ x ∈ Icc a b, f x ≤ f x₀ :=
begin
  sorry
end

lemma stupid {a b x : ℝ} (h : x ∈ Icc a b) (h' : x ≠ b) : x < b :=
lt_of_le_of_ne h.right h'

/-
And now the final boss...
-/

def I := (Icc 0 1 : set ℝ) -- the type ascription makes sure 0 and 1 are real numbers here

-- 0081
example (f : ℝ → ℝ) (hf : ∀ x, continuous_at_pt f x) (h₀ : f 0 < 0) (h₁ : f 1 > 0) :
∃ x₀ ∈ I, f x₀ = 0 :=
begin
  let A := { x | x ∈ I ∧ f x < 0},
  have ex_x₀ : ∃ x₀ ∈ I, is_sup A x₀,
  {
    sorry
  },
  rcases ex_x₀ with ⟨x₀, x₀_in, x₀_sup⟩,
  use [x₀, x₀_in],
  have : f x₀ ≤ 0,
  {
    sorry
  },
  have x₀_1: x₀ < 1,
  {
    sorry
  },
  have : f x₀ ≥ 0,
  { have in_I : ∃ N : ℕ, ∀ n ≥ N, x₀ + 1/(n+1) ∈ I,
    { have : ∃ N : ℕ, ∀ n≥ N, 1/(n+1 : ℝ) ≤ 1-x₀,
      {
        sorry
      },
      sorry
    },
    have not_in : ∀ n : ℕ, x₀ + 1/(n+1) ∉ A,
    -- By definition, x ∉ A means ¬ (x ∈ A).
    {
      sorry
    },
    dsimp [A] at not_in,
    sorry
  },
  linarith,
end