import Lean4Axiomatic.Rational.Addition
import Lean4Axiomatic.Rational.Impl.Fraction.Core

namespace Lean4Axiomatic.Rational.Impl.Fraction

open Signed (Positive)

variable {ℕ : Type} [Natural ℕ]
variable {ℤ : Type} [Integer (ℕ := ℕ) ℤ]

/-! ## Fraction addition -/

/--
Addition of fractions.

Uses naive fraction addition, and the proof that naive fraction addition always
results in a positive denominator if the input denominators are positive.
-/
def add (p q : Fraction ℤ) : Fraction ℤ :=
  let sum := p.naive + q.naive
  have : Positive p.denominator := p.denominator_positive.ev
  have : Positive q.denominator := q.denominator_positive.ev
  have : Positive sum.denominator :=
    Naive.add_preserves_positive_denominators
      ‹Positive p.denominator›
      ‹Positive q.denominator›
  from_naive sum ‹Positive sum.denominator›

instance addition_ops : Addition.Ops (Fraction ℤ) := {
  add := add
}

/--
Addition of integer fractions is consistent with its equivalent on integers.

**Property intuition**: This must be true if we want integers to be represented
as integer fractions.

**Proof intuition**: Expand the definition of addition and use integer algebra
on the numerator and denominator.
-/
theorem add_compat_from_integer
    {a b : ℤ} : from_integer (a + b) ≃ from_integer a + from_integer b
    := by
  show (a + b)//1 ≃ a//1 + b//1
  have : a//1 + b//1 ≃ (a + b)//1 := calc
    a//1 + b//1              ≃ _ := eqv_refl
    (a * 1 + 1 * b)//(1 * 1) ≃ _ := substN (AA.substL AA.identR)
    (a + 1 * b)//(1 * 1)     ≃ _ := substN (AA.substR AA.identL)
    (a + b)//(1 * 1)         ≃ _ := substD AA.identL
    (a + b)//1               ≃ _ := eqv_refl
  exact eqv_symm this

/--
Addition of integer fractions is commutative.

**Property intuition**: We'd expect this to be true due to the viewpoint that
fractions are scaled integers.

**Proof intuition**: Expand the definition of addition and use integer algebra
on the numerator and denominator.
-/
theorem add_comm {p q : Fraction ℤ} : p + q ≃ q + p := by
  revert p; intro (pn//pd); revert q; intro (qn//qd)
  show pn//pd + qn//qd ≃ qn//qd + pn//pd
  calc
    pn//pd + qn//qd                ≃ _ := eqv_refl
    (pn * qd + pd * qn)//(pd * qd) ≃ _ := substN (AA.substL AA.comm)
    (qd * pn + pd * qn)//(pd * qd) ≃ _ := substN (AA.substR AA.comm)
    (qd * pn + qn * pd)//(pd * qd) ≃ _ := substN AA.comm
    (qn * pd + qd * pn)//(pd * qd) ≃ _ := substD AA.comm
    (qn * pd + qd * pn)//(qd * pd) ≃ _ := eqv_refl
    qn//qd + pn//pd                ≃ _ := eqv_refl

/--
Replacing the left operand in a sum of fractions with an equivalent value gives
an equivalent result.

**Property intuition**: This must be true for addition on fractions to be a
valid function.

**Proof intuition**: Expand all definitions in the hypotheses and goal until
equivalences involving only integers are reached. Show the goal equivalence
using algebra and the equivalence from the `p₁ ≃ p₂` hypothesis.
-/
theorem add_substL {p₁ p₂ q : Fraction ℤ} : p₁ ≃ p₂ → p₁ + q ≃ p₂ + q := by
  revert p₁; intro (p₁n//p₁d); revert p₂; intro (p₂n//p₂d)
  revert q; intro (qn//qd)
  intro (_ : p₁n//p₁d ≃ p₂n//p₂d)
  show p₁n//p₁d + qn//qd ≃ p₂n//p₂d + qn//qd
  show (p₁n * qd + p₁d * qn)//(p₁d * qd) ≃ (p₂n * qd + p₂d * qn)//(p₂d * qd)
  show (p₁n * qd + p₁d * qn) * (p₂d * qd) ≃ (p₂n * qd + p₂d * qn) * (p₁d * qd)
  have : p₁n * p₂d ≃ p₂n * p₁d := ‹p₁n//p₁d ≃ p₂n//p₂d›
  calc
    (p₁n * qd + p₁d * qn) * (p₂d * qd)
      ≃ _ := Rel.symm AA.assoc
    ((p₁n * qd + p₁d * qn) * p₂d) * qd
      ≃ _ := AA.substL AA.distribR
    ((p₁n * qd) * p₂d + (p₁d * qn) * p₂d) * qd
      ≃ _ := AA.substL (AA.substL (AA.substL AA.comm))
    ((qd * p₁n) * p₂d + (p₁d * qn) * p₂d) * qd
      ≃ _ := AA.substL (AA.substL AA.assoc)
    (qd * (p₁n * p₂d) + (p₁d * qn) * p₂d) * qd
      ≃ _ := AA.substL (AA.substL (AA.substR ‹p₁n * p₂d ≃ p₂n * p₁d›))
    (qd * (p₂n * p₁d) + (p₁d * qn) * p₂d) * qd
      ≃ _ := AA.substL (AA.substL (Rel.symm AA.assoc))
    ((qd * p₂n) * p₁d + (p₁d * qn) * p₂d) * qd
      ≃ _ := AA.substL (AA.substR AA.assoc)
    ((qd * p₂n) * p₁d + p₁d * (qn * p₂d)) * qd
      ≃ _ := AA.substL (AA.substR AA.comm)
    ((qd * p₂n) * p₁d + (qn * p₂d) * p₁d) * qd
      ≃ _ := AA.substL (Rel.symm AA.distribR)
    ((qd * p₂n + qn * p₂d) * p₁d) * qd
      ≃ _ := AA.assoc
    (qd * p₂n + qn * p₂d) * (p₁d * qd)
      ≃ _ := AA.substL (AA.substL AA.comm)
    (p₂n * qd + qn * p₂d) * (p₁d * qd)
      ≃ _ := AA.substL (AA.substR AA.comm)
    (p₂n * qd + p₂d * qn) * (p₁d * qd)
      ≃ _ := Rel.refl

/--
Replacing the right operand in a sum of fractions with an equivalent value
gives an equivalent result.

**Property intuition**: This must be true for addition on fractions to be a
valid function.

**Proof intuition**: Flip the sum around using commutativity, perform left
substitution, then flip it back.
-/
theorem add_substR {p q₁ q₂ : Fraction ℤ} : q₁ ≃ q₂ → p + q₁ ≃ p + q₂ := by
  intro (_ : q₁ ≃ q₂)
  show p + q₁ ≃ p + q₂
  calc
    p + q₁ ≃ _ := add_comm
    q₁ + p ≃ _ := add_substL ‹q₁ ≃ q₂›
    q₂ + p ≃ _ := add_comm
    p + q₂ ≃ _ := eqv_refl

/--
Fraction addition is associative.

**Property intuition**: Fractions are scaled integers, so we expect
associativity to carry over.

**Proof intuition**: Expand definitions until each side of the equivalence is a
single fraction. The denominators are clearly equivalent by associativity of
integer multiplication. The numerators are equivalent via distributivity, and
associativity of addition, over integers.
-/
theorem add_assoc {p q r : Fraction ℤ} : (p + q) + r ≃ p + (q + r) := by
  revert p; intro (pn//pd); revert q; intro (qn//qd); revert r; intro (rn//rd)
  show (pn//pd + qn//qd) + rn//rd ≃ pn//pd + (qn//qd + rn//rd)
  calc
    (pn//pd + qn//qd) + rn//rd
      ≃ _ := eqv_refl
    (pn * qd + pd * qn)//(pd * qd) + rn//rd
      ≃ _ := eqv_refl
    ((pn * qd + pd * qn) * rd + (pd * qd) * rn)//((pd * qd) * rd)
      ≃ _ := substN (AA.substL AA.distribR)
    (((pn * qd) * rd + (pd * qn) * rd) + (pd * qd) * rn)//((pd * qd) * rd)
      ≃ _ := substN (AA.substL (AA.substL AA.assoc))
    ((pn * (qd * rd) + (pd * qn) * rd) + (pd * qd) * rn)//((pd * qd) * rd)
      ≃ _ := substN (AA.substL (AA.substR AA.assoc))
    ((pn * (qd * rd) + pd * (qn * rd)) + (pd * qd) * rn)//((pd * qd) * rd)
      ≃ _ := substN (AA.substR AA.assoc)
    ((pn * (qd * rd) + pd * (qn * rd)) + pd * (qd * rn))//((pd * qd) * rd)
      ≃ _ := substN AA.assoc
    (pn * (qd * rd) + (pd * (qn * rd) + pd * (qd * rn)))//((pd * qd) * rd)
      ≃ _ := substN (AA.substR (Rel.symm AA.distribL))
    (pn * (qd * rd) + pd * (qn * rd + qd * rn))//((pd * qd) * rd)
      ≃ _ := substD AA.assoc
    (pn * (qd * rd) + pd * (qn * rd + qd * rn))//(pd * (qd * rd))
      ≃ _ := eqv_refl
    pn//pd + (qn * rd + qd * rn)//(qd * rd)
      ≃ _ := eqv_refl
    pn//pd + (qn//qd + rn//rd)
      ≃ _ := eqv_refl

/--
Zero is a left identity element for fraction addition.

**Property intuition**: Fractions are scaled integers, so we expect
identity elements to carry over.

**Proof intuition**: Expand definitions, add, and simplify.
-/
theorem add_identL {p : Fraction ℤ} : 0 + p ≃ p := by
  revert p; intro (pn//pd)
  show 0//1 + pn//pd ≃ pn//pd
  calc
    (0 : ℤ)//1 + pn//pd         ≃ _ := eqv_refl
    (0 * pd + 1 * pn)//(1 * pd) ≃ _ := substN (AA.substL AA.absorbL)
    (0 + 1 * pn)//(1 * pd)      ≃ _ := substN AA.identL
    (1 * pn)//(1 * pd)          ≃ _ := substN AA.identL
    pn//(1 * pd)                ≃ _ := substD AA.identL
    pn//pd                      ≃ _ := eqv_refl

/--
Zero is a right identity element for fraction addition.

**Property intuition**: Fractions are scaled integers, so we expect
identity elements to carry over.

**Proof intuition**: Combine commutativity with the left identity proof.
-/
theorem add_identR {p : Fraction ℤ} : p + 0 ≃ p :=
  eqv_trans add_comm add_identL

instance addition_props : Addition.Props (Fraction ℤ) := {
  add_substL := add_substL
  add_substR := add_substR
  add_compat_from_integer := add_compat_from_integer
  add_comm := add_comm
  add_assoc := add_assoc
  add_identL := add_identL
  add_identR := add_identR
}

instance addition : Addition (Fraction ℤ) := {
  toOps := addition_ops
  toProps := addition_props
}

end Lean4Axiomatic.Rational.Impl.Fraction


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.adjunction.basic
import Mathlib.category_theory.conj
import Mathlib.category_theory.yoneda
import Mathlib.PostPort

universes u₁ u₂ u₃ u₄ v₁ v₂ v₃ v₄

namespace Mathlib

/-!
# Mate of natural transformations

This file establishes the bijection between the 2-cells

         L₁                  R₁
      C --→ D             C ←-- D
    G ↓  ↗  ↓ H         G ↓  ↘  ↓ H
      E --→ F             E ←-- F
         L₂                  R₂

where `L₁ ⊣ R₁` and `L₂ ⊣ R₂`, and shows that in the special case where `G,H` are identity then the
bijection preserves and reflects isomorphisms (i.e. we have bijections `(L₂ ⟶ L₁) ≃ (R₁ ⟶ R₂)`, and
if either side is an iso then the other side is as well).

On its own, this bijection is not particularly useful but it includes a number of interesting cases
as specializations.

For instance, this generalises the fact that adjunctions are unique (since if `L₁ ≅ L₂` then we
deduce `R₁ ≅ R₂`).
Another example arises from considering the square representing that a functor `H` preserves
products, in particular the morphism `HA ⨯ H- ⟶ H(A ⨯ -)`. Then provided `(A ⨯ -)` and `HA ⨯ -` have
left adjoints (for instance if the relevant categories are cartesian closed), the transferred
natural transformation is the exponential comparison morphism: `H(A ^ -) ⟶ HA ^ H-`.
Furthermore if `H` has a left adjoint `L`, this morphism is an isomorphism iff its mate
`L(HA ⨯ -) ⟶ A ⨯ L-` is an isomorphism, see
https://ncatlab.org/nlab/show/Frobenius+reciprocity#InCategoryTheory.
This also relates to Grothendieck's yoga of six operations, though this is not spelled out in
mathlib: https://ncatlab.org/nlab/show/six+operations.
-/

namespace category_theory

/--
Suppose we have a square of functors (where the top and bottom are adjunctions `L₁ ⊣ R₁` and
`L₂ ⊣ R₂` respectively).

      C ↔ D
    G ↓   ↓ H
      E ↔ F

Then we have a bijection between natural transformations `G ⋙ L₂ ⟶ L₁ ⋙ H` and
`R₁ ⋙ G ⟶ H ⋙ R₂`.
This can be seen as a bijection of the 2-cells:

         L₁                  R₁
      C --→ D             C ←-- D
    G ↓  ↗  ↓ H         G ↓  ↘  ↓ H
      E --→ F             E ←-- F
         L₂                  R₂

Note that if one of the transformations is an iso, it does not imply the other is an iso.
-/
def transfer_nat_trans {C : Type u₁} {D : Type u₂} [category C] [category D] {E : Type u₃}
    {F : Type u₄} [category E] [category F] {G : C ⥤ E} {H : D ⥤ F} {L₁ : C ⥤ D} {R₁ : D ⥤ C}
    {L₂ : E ⥤ F} {R₂ : F ⥤ E} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂) :
    (G ⋙ L₂ ⟶ L₁ ⋙ H) ≃ (R₁ ⋙ G ⟶ H ⋙ R₂) :=
  equiv.mk
    (fun (h : G ⋙ L₂ ⟶ L₁ ⋙ H) =>
      nat_trans.mk
        fun (X : D) =>
          nat_trans.app (adjunction.unit adj₂) (functor.obj G (functor.obj R₁ X)) ≫
            functor.map R₂
              (nat_trans.app h (functor.obj R₁ X) ≫
                functor.map H (nat_trans.app (adjunction.counit adj₁) X)))
    (fun (h : R₁ ⋙ G ⟶ H ⋙ R₂) =>
      nat_trans.mk
        fun (X : C) =>
          functor.map L₂
              (functor.map G (nat_trans.app (adjunction.unit adj₁) X) ≫
                nat_trans.app h (functor.obj L₁ X)) ≫
            nat_trans.app (adjunction.counit adj₂) (functor.obj H (functor.obj L₁ X)))
    sorry sorry

theorem transfer_nat_trans_counit {C : Type u₁} {D : Type u₂} [category C] [category D]
    {E : Type u₃} {F : Type u₄} [category E] [category F] {G : C ⥤ E} {H : D ⥤ F} {L₁ : C ⥤ D}
    {R₁ : D ⥤ C} {L₂ : E ⥤ F} {R₂ : F ⥤ E} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂) (f : G ⋙ L₂ ⟶ L₁ ⋙ H)
    (Y : D) :
    functor.map L₂ (nat_trans.app (coe_fn (transfer_nat_trans adj₁ adj₂) f) Y) ≫
          nat_trans.app (adjunction.counit adj₂) (functor.obj H Y) =
        nat_trans.app f (functor.obj R₁ Y) ≫
          functor.map H (nat_trans.app (adjunction.counit adj₁) Y) :=
  sorry

theorem unit_transfer_nat_trans {C : Type u₁} {D : Type u₂} [category C] [category D] {E : Type u₃}
    {F : Type u₄} [category E] [category F] {G : C ⥤ E} {H : D ⥤ F} {L₁ : C ⥤ D} {R₁ : D ⥤ C}
    {L₂ : E ⥤ F} {R₂ : F ⥤ E} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂) (f : G ⋙ L₂ ⟶ L₁ ⋙ H) (X : C) :
    functor.map G (nat_trans.app (adjunction.unit adj₁) X) ≫
          nat_trans.app (coe_fn (transfer_nat_trans adj₁ adj₂) f) (functor.obj L₁ X) =
        nat_trans.app (adjunction.unit adj₂) (functor.obj G (functor.obj 𝟭 X)) ≫
          functor.map R₂ (nat_trans.app f (functor.obj 𝟭 X)) :=
  sorry

/--
Given two adjunctions `L₁ ⊣ R₁` and `L₂ ⊣ R₂` both between categories `C`, `D`, there is a
bijection between natural transformations `L₂ ⟶ L₁` and natural transformations `R₁ ⟶ R₂`.
This is defined as a special case of `transfer_nat_trans`, where the two "vertical" functors are
identity.
TODO: Generalise to when the two vertical functors are equivalences rather than being exactly `𝟭`.

Furthermore, this bijection preserves (and reflects) isomorphisms, i.e. a transformation is an iso
iff its image under the bijection is an iso, see eg `category_theory.transfer_nat_trans_self_iso`.
This is in contrast to the general case `transfer_nat_trans` which does not in general have this
property.
-/
def transfer_nat_trans_self {C : Type u₁} {D : Type u₂} [category C] [category D] {L₁ : C ⥤ D}
    {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂) :
    (L₂ ⟶ L₁) ≃ (R₁ ⟶ R₂) :=
  equiv.trans
    (equiv.trans (equiv.symm (iso.hom_congr (functor.left_unitor L₂) (functor.right_unitor L₁)))
      (transfer_nat_trans adj₁ adj₂))
    (iso.hom_congr (functor.right_unitor R₁) (functor.left_unitor R₂))

theorem transfer_nat_trans_self_counit {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    (f : L₂ ⟶ L₁) (X : D) :
    functor.map L₂ (nat_trans.app (coe_fn (transfer_nat_trans_self adj₁ adj₂) f) X) ≫
          nat_trans.app (adjunction.counit adj₂) X =
        nat_trans.app f (functor.obj R₁ X) ≫ nat_trans.app (adjunction.counit adj₁) X :=
  sorry

theorem unit_transfer_nat_trans_self {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    (f : L₂ ⟶ L₁) (X : C) :
    nat_trans.app (adjunction.unit adj₁) X ≫
          nat_trans.app (coe_fn (transfer_nat_trans_self adj₁ adj₂) f) (functor.obj L₁ X) =
        nat_trans.app (adjunction.unit adj₂) X ≫ functor.map R₂ (nat_trans.app f X) :=
  sorry

@[simp] theorem transfer_nat_trans_self_id {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {R₁ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) : coe_fn (transfer_nat_trans_self adj₁ adj₁) 𝟙 = 𝟙 :=
  sorry

@[simp] theorem transfer_nat_trans_self_symm_id {C : Type u₁} {D : Type u₂} [category C]
    [category D] {L₁ : C ⥤ D} {R₁ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) :
    coe_fn (equiv.symm (transfer_nat_trans_self adj₁ adj₁)) 𝟙 = 𝟙 :=
  sorry

theorem transfer_nat_trans_self_comp {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {L₃ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} {R₃ : D ⥤ C} (adj₁ : L₁ ⊣ R₁)
    (adj₂ : L₂ ⊣ R₂) (adj₃ : L₃ ⊣ R₃) (f : L₂ ⟶ L₁) (g : L₃ ⟶ L₂) :
    coe_fn (transfer_nat_trans_self adj₁ adj₂) f ≫ coe_fn (transfer_nat_trans_self adj₂ adj₃) g =
        coe_fn (transfer_nat_trans_self adj₁ adj₃) (g ≫ f) :=
  sorry

theorem transfer_nat_trans_self_symm_comp {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {L₃ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} {R₃ : D ⥤ C} (adj₁ : L₁ ⊣ R₁)
    (adj₂ : L₂ ⊣ R₂) (adj₃ : L₃ ⊣ R₃) (f : R₂ ⟶ R₁) (g : R₃ ⟶ R₂) :
    coe_fn (equiv.symm (transfer_nat_trans_self adj₂ adj₁)) f ≫
          coe_fn (equiv.symm (transfer_nat_trans_self adj₃ adj₂)) g =
        coe_fn (equiv.symm (transfer_nat_trans_self adj₃ adj₁)) (g ≫ f) :=
  sorry

theorem transfer_nat_trans_self_comm {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    {f : L₂ ⟶ L₁} {g : L₁ ⟶ L₂} (gf : g ≫ f = 𝟙) :
    coe_fn (transfer_nat_trans_self adj₁ adj₂) f ≫ coe_fn (transfer_nat_trans_self adj₂ adj₁) g =
        𝟙 :=
  sorry

theorem transfer_nat_trans_self_symm_comm {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    {f : R₁ ⟶ R₂} {g : R₂ ⟶ R₁} (gf : g ≫ f = 𝟙) :
    coe_fn (equiv.symm (transfer_nat_trans_self adj₁ adj₂)) f ≫
          coe_fn (equiv.symm (transfer_nat_trans_self adj₂ adj₁)) g =
        𝟙 :=
  sorry

/--
If `f` is an isomorphism, then the transferred natural transformation is an isomorphism.
The converse is given in `transfer_nat_trans_self_of_iso`.
-/
protected instance transfer_nat_trans_self_iso {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    (f : L₂ ⟶ L₁) [is_iso f] : is_iso (coe_fn (transfer_nat_trans_self adj₁ adj₂) f) :=
  is_iso.mk (coe_fn (transfer_nat_trans_self adj₂ adj₁) (inv f))

/--
If `f` is an isomorphism, then the un-transferred natural transformation is an isomorphism.
The converse is given in `transfer_nat_trans_self_symm_of_iso`.
-/
protected instance transfer_nat_trans_self_symm_iso {C : Type u₁} {D : Type u₂} [category C]
    [category D] {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁)
    (adj₂ : L₂ ⊣ R₂) (f : R₁ ⟶ R₂) [is_iso f] :
    is_iso (coe_fn (equiv.symm (transfer_nat_trans_self adj₁ adj₂)) f) :=
  is_iso.mk (coe_fn (equiv.symm (transfer_nat_trans_self adj₂ adj₁)) (inv f))

/--
If `f` is a natural transformation whose transferred natural transformation is an isomorphism,
then `f` is an isomorphism.
The converse is given in `transfer_nat_trans_self_iso`.
-/
def transfer_nat_trans_self_of_iso {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    (f : L₂ ⟶ L₁) [is_iso (coe_fn (transfer_nat_trans_self adj₁ adj₂) f)] : is_iso f :=
  eq.mpr sorry
    (eq.mp sorry
      (category_theory.transfer_nat_trans_self_symm_iso adj₁ adj₂
        (coe_fn (transfer_nat_trans_self adj₁ adj₂) f)))

/--
If `f` is a natural transformation whose un-transferred natural transformation is an isomorphism,
then `f` is an isomorphism.
The converse is given in `transfer_nat_trans_self_symm_iso`.
-/
def transfer_nat_trans_self_symm_of_iso {C : Type u₁} {D : Type u₂} [category C] [category D]
    {L₁ : C ⥤ D} {L₂ : C ⥤ D} {R₁ : D ⥤ C} {R₂ : D ⥤ C} (adj₁ : L₁ ⊣ R₁) (adj₂ : L₂ ⊣ R₂)
    (f : R₁ ⟶ R₂) [is_iso (coe_fn (equiv.symm (transfer_nat_trans_self adj₁ adj₂)) f)] : is_iso f :=
  eq.mpr sorry
    (eq.mp sorry
      (category_theory.transfer_nat_trans_self_iso adj₁ adj₂
        (coe_fn (equiv.symm (transfer_nat_trans_self adj₁ adj₂)) f)))

end Mathlib


/-
Copyright (c) 2022 Julian Kuelshammer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Julian Kuelshammer
-/
import algebra.big_operators.fin
import algebra.big_operators.nat_antidiagonal
import algebra.char_zero.lemmas
import data.finset.nat_antidiagonal
import data.nat.choose.central
import data.tree
import tactic.field_simp
import tactic.linear_combination

/-!
# Catalan numbers

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

The Catalan numbers (http://oeis.org/A000108) are probably the most ubiquitous sequence of integers
in mathematics. They enumerate several important objects like binary trees, Dyck paths, and
triangulations of convex polygons.

## Main definitions

* `catalan n`: the `n`th Catalan number, defined recursively as
  `catalan (n + 1) = ∑ i : fin n.succ, catalan i * catalan (n - i)`.

## Main results

* `catalan_eq_central_binom_div `: The explicit formula for the Catalan number using the central
  binomial coefficient, `catalan n = nat.central_binom n / (n + 1)`.

* `trees_of_nodes_eq_card_eq_catalan`: The number of binary trees with `n` internal nodes
  is `catalan n`

## Implementation details

The proof of `catalan_eq_central_binom_div` follows
https://math.stackexchange.com/questions/3304415/catalan-numbers-algebraic-proof-of-the-recurrence-relation

## TODO

* Prove that the Catalan numbers enumerate many interesting objects.
* Provide the many variants of Catalan numbers, e.g. associated to complex reflection groups,
  Fuss-Catalan, etc.

-/

open_locale big_operators

open finset finset.nat.antidiagonal (fst_le snd_le)

/-- The recursive definition of the sequence of Catalan numbers:
`catalan (n + 1) = ∑ i : fin n.succ, catalan i * catalan (n - i)` -/
def catalan : ℕ → ℕ
| 0       := 1
| (n + 1) := ∑ i : fin n.succ, have _ := i.2, have _ := nat.lt_succ_iff.mpr (n.sub_le i),
             catalan i * catalan (n - i)

@[simp] lemma catalan_zero : catalan 0 = 1 := by rw catalan

lemma catalan_succ (n : ℕ) : catalan (n + 1) = ∑ i : fin n.succ, catalan i * catalan (n - i) :=
by rw catalan

lemma catalan_succ' (n : ℕ) :
  catalan (n + 1) = ∑ ij in nat.antidiagonal n, catalan ij.1 * catalan ij.2 :=
by rw [catalan_succ, nat.sum_antidiagonal_eq_sum_range_succ (λ x y, catalan x * catalan y) n,
    sum_range]

@[simp] lemma catalan_one : catalan 1 = 1 := by simp [catalan_succ]

/-- A helper sequence that can be used to prove the equality of the recursive and the explicit
definition using a telescoping sum argument. -/
private def gosper_catalan (n j : ℕ) : ℚ :=
nat.central_binom j * nat.central_binom (n - j) * (2 * j - n) / (2 * n * (n + 1))

private lemma gosper_trick {n i : ℕ} (h : i ≤ n) :
  gosper_catalan (n+1) (i+1) - gosper_catalan (n+1) i =
  nat.central_binom i / (i + 1) * nat.central_binom (n - i) / (n - i + 1) :=
begin
  have : (n:ℚ) + 1 ≠ 0 := by exact_mod_cast n.succ_ne_zero,
  have : (n:ℚ) + 1 + 1 ≠ 0 := by exact_mod_cast (n + 1).succ_ne_zero,
  have : (i:ℚ) + 1 ≠ 0 := by exact_mod_cast i.succ_ne_zero,
  have : (n:ℚ) - i + 1 ≠ 0 := by exact_mod_cast (n - i).succ_ne_zero,
  have h₁ : ((i:ℚ) + 1) * (i + 1).central_binom = 2 * (2 * i + 1) * i.central_binom,
  { exact_mod_cast nat.succ_mul_central_binom_succ i },
  have h₂ : ((n:ℚ) - i + 1) * (n - i + 1).central_binom
    = 2 * (2 * (n - i) + 1) * (n - i).central_binom,
  { exact_mod_cast nat.succ_mul_central_binom_succ (n - i) },
  simp only [gosper_catalan],
  push_cast,
  field_simp,
  rw (nat.succ_sub h),
  linear_combination
    (2:ℚ) * (n - i).central_binom * (i + 1 - (n - i)) * (n + 1) * (n + 2) * ((n - i) + 1) * h₁
    - 2 * i.central_binom * (n + 1) * (n + 2) * (i - (n - i) - 1) * (i + 1) * h₂,
end

private lemma gosper_catalan_sub_eq_central_binom_div (n : ℕ) :
  gosper_catalan (n + 1) (n + 1) - gosper_catalan (n + 1) 0 = nat.central_binom (n + 1) / (n + 2) :=
begin
  have : (n:ℚ) + 1 ≠ 0 := by exact_mod_cast n.succ_ne_zero,
  have : (n:ℚ) + 1 + 1 ≠ 0 := by exact_mod_cast (n + 1).succ_ne_zero,
  have h : (n:ℚ) + 2 ≠ 0 := by exact_mod_cast (n + 1).succ_ne_zero,
  simp only [gosper_catalan, nat.sub_zero, nat.central_binom_zero, nat.sub_self],
  field_simp,
  ring,
end

theorem catalan_eq_central_binom_div (n : ℕ) :
  catalan n = n.central_binom / (n + 1) :=
begin
  suffices : (catalan n : ℚ) = nat.central_binom n / (n + 1),
  { have h := nat.succ_dvd_central_binom n,
    exact_mod_cast this },
  induction n using nat.case_strong_induction_on with d hd,
  { simp },
  { simp_rw [catalan_succ, nat.cast_sum, nat.cast_mul],
    transitivity (∑ i : fin d.succ, (nat.central_binom i / (i + 1)) * (nat.central_binom (d - i) /
                  (d - i + 1)) : ℚ),
    { refine sum_congr rfl (λ i _, _),
      congr,
      { exact_mod_cast hd i i.is_le },
      { rw_mod_cast hd (d - i),
        push_cast,
        rw nat.cast_sub i.is_le,
        exact tsub_le_self }, },
    { transitivity ∑ i : fin d.succ, (gosper_catalan (d + 1) (i + 1) - gosper_catalan (d + 1) i),
      { refine sum_congr rfl (λ i _, _),
        rw_mod_cast [gosper_trick i.is_le, mul_div] },
      { rw [← sum_range (λi, gosper_catalan (d + 1) (i + 1) - gosper_catalan (d + 1) i),
            sum_range_sub, nat.succ_eq_add_one],
        exact_mod_cast gosper_catalan_sub_eq_central_binom_div d } } }
end

theorem succ_mul_catalan_eq_central_binom (n : ℕ) :
  (n+1) * catalan n = n.central_binom :=
(nat.eq_mul_of_div_eq_right n.succ_dvd_central_binom (catalan_eq_central_binom_div n).symm).symm

lemma catalan_two : catalan 2 = 2 :=
by norm_num [catalan_eq_central_binom_div, nat.central_binom, nat.choose]

lemma catalan_three : catalan 3 = 5 :=
by norm_num [catalan_eq_central_binom_div, nat.central_binom, nat.choose]

namespace tree
open_locale tree

/-- Given two finsets, find all trees that can be formed with
  left child in `a` and right child in `b` -/
@[reducible] def pairwise_node (a b : finset (tree unit)) : finset (tree unit) :=
(a ×ˢ b).map ⟨λ x, x.1 △ x.2, λ ⟨x₁, x₂⟩ ⟨y₁, y₂⟩, λ h, by simpa using h⟩

/-- A finset of all trees with `n` nodes. See `mem_trees_of_nodes_eq` -/
def trees_of_num_nodes_eq : ℕ → finset (tree unit)
| 0 := {nil}
| (n+1) := (finset.nat.antidiagonal n).attach.bUnion $ λ ijh,
  have _ := nat.lt_succ_of_le (fst_le ijh.2),
  have _ := nat.lt_succ_of_le (snd_le ijh.2),
  pairwise_node (trees_of_num_nodes_eq ijh.1.1) (trees_of_num_nodes_eq ijh.1.2)

@[simp] lemma trees_of_nodes_eq_zero : trees_of_num_nodes_eq 0 = {nil} :=
by rw [trees_of_num_nodes_eq]

lemma trees_of_nodes_eq_succ (n : ℕ) : trees_of_num_nodes_eq (n + 1) =
  (nat.antidiagonal n).bUnion (λ ij, pairwise_node (trees_of_num_nodes_eq ij.1)
    (trees_of_num_nodes_eq ij.2)) :=
by { rw trees_of_num_nodes_eq, ext, simp, }

@[simp] theorem mem_trees_of_nodes_eq {x : tree unit} {n : ℕ} :
  x ∈ trees_of_num_nodes_eq n ↔ x.num_nodes = n :=
begin
  induction x using tree.unit_rec_on generalizing n;
  cases n;
  simp [trees_of_nodes_eq_succ, nat.succ_eq_add_one, *],
  trivial,
end

lemma mem_trees_of_nodes_eq_num_nodes (x : tree unit) :
  x ∈ trees_of_num_nodes_eq x.num_nodes := mem_trees_of_nodes_eq.mpr rfl

@[simp, norm_cast] lemma coe_trees_of_nodes_eq (n : ℕ) :
  ↑(trees_of_num_nodes_eq n) = {x : tree unit | x.num_nodes = n} := set.ext (by simp)

lemma trees_of_nodes_eq_card_eq_catalan (n : ℕ) :
  (trees_of_num_nodes_eq n).card = catalan n :=
begin
  induction n using nat.case_strong_induction_on with n ih,
  { simp, },
  rw [trees_of_nodes_eq_succ, card_bUnion, catalan_succ'],
  { apply sum_congr rfl,
    rintro ⟨i, j⟩ H,
    simp [ih _ (fst_le H), ih _ (snd_le H)], },
  { simp_rw disjoint_left,
    rintros ⟨i, j⟩ _ ⟨i', j'⟩ _,
    clear_except,
    tidy, },
end

end tree


/-
Copyright © 2022 Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Heather Macbeth, Floris van Doorn

! This file was ported from Lean 3 source module topology.vector_bundle.hom
! leanprover-community/mathlib commit be2c24f56783935652cefffb4bfca7e4b25d167e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Topology.VectorBundle.Basic
import Mathbin.Analysis.NormedSpace.OperatorNorm

/-!
# The vector bundle of continuous (semi)linear maps

We define the (topological) vector bundle of continuous (semi)linear maps between two vector bundles
over the same base.

Given bundles `E₁ E₂ : B → Type*`, normed spaces `F₁` and `F₂`, and a ring-homomorphism `σ` between
their respective scalar fields, we define `bundle.continuous_linear_map σ F₁ E₁ F₂ E₂ x` to be a
type synonym for `λ x, E₁ x →SL[σ] E₂ x`. If the `E₁` and `E₂` are vector bundles with model fibers
`F₁` and `F₂`, then this will be a vector bundle with fiber `F₁ →SL[σ] F₂`.

The topology is constructed from the trivializations for `E₁` and `E₂` and the norm-topology on the
model fiber `F₁ →SL[𝕜] F₂` using the `vector_prebundle` construction.  This is a bit awkward because
it introduces a spurious (?) dependence on the normed space structure of the model fiber, rather
than just its topological vector space structure; this might be fixable now that we have
`continuous_linear_map.strong_topology`.

Similar constructions should be possible (but are yet to be formalized) for tensor products of
topological vector bundles, exterior algebras, and so on, where again the topology can be defined
using a norm on the fiber model if this helps.

## Main Definitions

* `bundle.continuous_linear_map.vector_bundle`: continuous semilinear maps between
  vector bundles form a vector bundle.

-/

noncomputable section

open Bundle

open Bundle Set ContinuousLinearMap

section Defs

variable {𝕜₁ 𝕜₂ : Type _} [NormedField 𝕜₁] [NormedField 𝕜₂]

variable (σ : 𝕜₁ →+* 𝕜₂)

variable {B : Type _}

variable (F₁ : Type _) (E₁ : B → Type _) [∀ x, AddCommMonoid (E₁ x)] [∀ x, Module 𝕜₁ (E₁ x)]

variable [∀ x : B, TopologicalSpace (E₁ x)]

variable (F₂ : Type _) (E₂ : B → Type _) [∀ x, AddCommMonoid (E₂ x)] [∀ x, Module 𝕜₂ (E₂ x)]

variable [∀ x : B, TopologicalSpace (E₂ x)]

include F₁ F₂

-- In this definition we require the scalar rings `𝕜₁` and `𝕜₂` to be normed fields, although
-- something much weaker (maybe `comm_semiring`) would suffice mathematically -- this is because of
-- a typeclass inference bug with pi-types:
-- https://leanprover.zulipchat.com/#narrow/stream/116395-maths/topic/vector.20bundles.20--.20typeclass.20inference.20issue
/-- The bundle of continuous `σ`-semilinear maps between the topological vector bundles `E₁` and
`E₂`. This is a type synonym for `λ x, E₁ x →SL[σ] E₂ x`.

We intentionally add `F₁` and `F₂` as arguments to this type, so that instances on this type
(that depend on `F₁` and `F₂`) actually refer to `F₁` and `F₂`. -/
@[nolint unused_arguments]
def Bundle.ContinuousLinearMap (x : B) : Type _ :=
  E₁ x →SL[σ] E₂ x deriving Inhabited
#align bundle.continuous_linear_map Bundle.ContinuousLinearMap

instance Bundle.ContinuousLinearMap.addMonoidHomClass (x : B) :
    AddMonoidHomClass (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂ x) (E₁ x) (E₂ x) := by
  delta_instance bundle.continuous_linear_map
#align bundle.continuous_linear_map.add_monoid_hom_class Bundle.ContinuousLinearMap.addMonoidHomClass

variable [∀ x, ContinuousAdd (E₂ x)]

instance (x : B) : AddCommMonoid (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂ x) := by
  delta_instance bundle.continuous_linear_map

variable [∀ x, ContinuousSMul 𝕜₂ (E₂ x)]

instance (x : B) : Module 𝕜₂ (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂ x) := by
  delta_instance bundle.continuous_linear_map

end Defs

variable {𝕜₁ : Type _} [NontriviallyNormedField 𝕜₁] {𝕜₂ : Type _} [NontriviallyNormedField 𝕜₂]
  (σ : 𝕜₁ →+* 𝕜₂) [iσ : RingHomIsometric σ]

variable {B : Type _} [TopologicalSpace B]

variable (F₁ : Type _) [NormedAddCommGroup F₁] [NormedSpace 𝕜₁ F₁] (E₁ : B → Type _)
  [∀ x, AddCommMonoid (E₁ x)] [∀ x, Module 𝕜₁ (E₁ x)] [TopologicalSpace (TotalSpace E₁)]

variable (F₂ : Type _) [NormedAddCommGroup F₂] [NormedSpace 𝕜₂ F₂] (E₂ : B → Type _)
  [∀ x, AddCommMonoid (E₂ x)] [∀ x, Module 𝕜₂ (E₂ x)] [TopologicalSpace (TotalSpace E₂)]

variable {F₁ E₁ F₂ E₂} (e₁ e₁' : Trivialization F₁ (π E₁)) (e₂ e₂' : Trivialization F₂ (π E₂))

namespace Pretrivialization

include iσ

/-- Assume `eᵢ` and `eᵢ'` are trivializations of the bundles `Eᵢ` over base `B` with fiber `Fᵢ`
(`i ∈ {1,2}`), then `continuous_linear_map_coord_change σ e₁ e₁' e₂ e₂'` is the coordinate change
function between the two induced (pre)trivializations
`pretrivialization.continuous_linear_map σ e₁ e₂` and
`pretrivialization.continuous_linear_map σ e₁' e₂'` of `bundle.continuous_linear_map`. -/
def continuousLinearMapCoordChange [e₁.isLinear 𝕜₁] [e₁'.isLinear 𝕜₁] [e₂.isLinear 𝕜₂]
    [e₂'.isLinear 𝕜₂] (b : B) : (F₁ →SL[σ] F₂) →L[𝕜₂] F₁ →SL[σ] F₂ :=
  ((e₁'.coordChangeL 𝕜₁ e₁ b).symm.arrowCongrSL (e₂.coordChangeL 𝕜₂ e₂' b) :
    (F₁ →SL[σ] F₂) ≃L[𝕜₂] F₁ →SL[σ] F₂)
#align pretrivialization.continuous_linear_map_coord_change Pretrivialization.continuousLinearMapCoordChange

variable {σ e₁ e₁' e₂ e₂'}

variable [∀ x : B, TopologicalSpace (E₁ x)] [FiberBundle F₁ E₁]

variable [∀ x : B, TopologicalSpace (E₂ x)] [FiberBundle F₂ E₂]

theorem continuousOn_continuousLinearMapCoordChange [VectorBundle 𝕜₁ F₁ E₁] [VectorBundle 𝕜₂ F₂ E₂]
    [MemTrivializationAtlas e₁] [MemTrivializationAtlas e₁'] [MemTrivializationAtlas e₂]
    [MemTrivializationAtlas e₂'] :
    ContinuousOn (continuousLinearMapCoordChange σ e₁ e₁' e₂ e₂')
      (e₁.baseSet ∩ e₂.baseSet ∩ (e₁'.baseSet ∩ e₂'.baseSet)) :=
  by
  have h₁ := (compSL F₁ F₂ F₂ σ (RingHom.id 𝕜₂)).Continuous
  have h₂ := (ContinuousLinearMap.flip (compSL F₁ F₁ F₂ (RingHom.id 𝕜₁) σ)).Continuous
  have h₃ := continuousOn_coord_change 𝕜₁ e₁' e₁
  have h₄ := continuousOn_coord_change 𝕜₂ e₂ e₂'
  refine' ((h₁.comp_continuous_on (h₄.mono _)).clm_comp (h₂.comp_continuous_on (h₃.mono _))).congr _
  · mfld_set_tac
  · mfld_set_tac
  · intro b hb
    ext (L v)
    simp only [continuous_linear_map_coord_change, ContinuousLinearEquiv.coe_coe,
      ContinuousLinearEquiv.arrowCongrSL_apply, comp_apply, Function.comp, compSL_apply, flip_apply,
      ContinuousLinearEquiv.symm_symm]
#align pretrivialization.continuous_on_continuous_linear_map_coord_change Pretrivialization.continuousOn_continuousLinearMapCoordChange

omit iσ

variable (σ e₁ e₁' e₂ e₂') [e₁.isLinear 𝕜₁] [e₁'.isLinear 𝕜₁] [e₂.isLinear 𝕜₂] [e₂'.isLinear 𝕜₂]

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/-- Given trivializations `e₁`, `e₂` for vector bundles `E₁`, `E₂` over a base `B`,
`pretrivialization.continuous_linear_map σ e₁ e₂` is the induced pretrivialization for the
continuous `σ`-semilinear maps from `E₁` to `E₂`. That is, the map which will later become a
trivialization, after the bundle of continuous semilinear maps is equipped with the right
topological vector bundle structure. -/
def continuousLinearMap :
    Pretrivialization (F₁ →SL[σ] F₂) (π (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂))
    where
  toFun p := ⟨p.1, (e₂.continuousLinearMapAt 𝕜₂ p.1).comp <| p.2.comp <| e₁.symmL 𝕜₁ p.1⟩
  invFun p := ⟨p.1, (e₂.symmL 𝕜₂ p.1).comp <| p.2.comp <| e₁.continuousLinearMapAt 𝕜₁ p.1⟩
  source := Bundle.TotalSpace.proj ⁻¹' (e₁.baseSet ∩ e₂.baseSet)
  target := (e₁.baseSet ∩ e₂.baseSet) ×ˢ Set.univ
  map_source' := fun ⟨x, L⟩ h => ⟨h, Set.mem_univ _⟩
  map_target' := fun ⟨x, f⟩ h => h.1
  left_inv' := fun ⟨x, L⟩ ⟨h₁, h₂⟩ =>
    by
    simp_rw [Sigma.mk.inj_iff, eq_self_iff_true, heq_iff_eq, true_and_iff]
    ext v
    simp only [comp_apply, Trivialization.symmL_continuousLinearMapAt, h₁, h₂]
  right_inv' := fun ⟨x, f⟩ ⟨⟨h₁, h₂⟩, _⟩ =>
    by
    simp_rw [Prod.mk.inj_iff, eq_self_iff_true, true_and_iff]
    ext v
    simp only [comp_apply, Trivialization.continuousLinearMapAt_symmL, h₁, h₂]
  open_target := (e₁.open_baseSet.inter e₂.open_baseSet).Prod isOpen_univ
  baseSet := e₁.baseSet ∩ e₂.baseSet
  open_baseSet := e₁.open_baseSet.inter e₂.open_baseSet
  source_eq := rfl
  target_eq := rfl
  proj_toFun := fun ⟨x, f⟩ h => rfl
#align pretrivialization.continuous_linear_map Pretrivialization.continuousLinearMap

instance continuousLinearMap.isLinear [∀ x, ContinuousAdd (E₂ x)] [∀ x, ContinuousSMul 𝕜₂ (E₂ x)] :
    (Pretrivialization.continuousLinearMap σ e₁ e₂).isLinear 𝕜₂
    where linear x h :=
    { map_add := fun L L' =>
        show (e₂.continuousLinearMapAt 𝕜₂ x).comp ((L + L').comp (e₁.symmL 𝕜₁ x)) = _
          by
          simp_rw [add_comp, comp_add]
          rfl
      map_smul := fun c L =>
        show (e₂.continuousLinearMapAt 𝕜₂ x).comp ((c • L).comp (e₁.symmL 𝕜₁ x)) = _
          by
          simp_rw [smul_comp, comp_smulₛₗ, RingHom.id_apply]
          rfl }
#align pretrivialization.continuous_linear_map.is_linear Pretrivialization.continuousLinearMap.isLinear

theorem continuousLinearMap_apply (p : TotalSpace (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂)) :
    (continuousLinearMap σ e₁ e₂) p =
      ⟨p.1, (e₂.continuousLinearMapAt 𝕜₂ p.1).comp <| p.2.comp <| e₁.symmL 𝕜₁ p.1⟩ :=
  rfl
#align pretrivialization.continuous_linear_map_apply Pretrivialization.continuousLinearMap_apply

theorem continuousLinearMap_symm_apply (p : B × (F₁ →SL[σ] F₂)) :
    (continuousLinearMap σ e₁ e₂).toLocalEquiv.symm p =
      ⟨p.1, (e₂.symmL 𝕜₂ p.1).comp <| p.2.comp <| e₁.continuousLinearMapAt 𝕜₁ p.1⟩ :=
  rfl
#align pretrivialization.continuous_linear_map_symm_apply Pretrivialization.continuousLinearMap_symm_apply

variable [∀ x, ContinuousAdd (E₂ x)]

theorem continuousLinearMap_symm_apply' {b : B} (hb : b ∈ e₁.baseSet ∩ e₂.baseSet)
    (L : F₁ →SL[σ] F₂) :
    (continuousLinearMap σ e₁ e₂).symm b L =
      (e₂.symmL 𝕜₂ b).comp (L.comp <| e₁.continuousLinearMapAt 𝕜₁ b) :=
  by rw [symm_apply]; rfl; exact hb
#align pretrivialization.continuous_linear_map_symm_apply' Pretrivialization.continuousLinearMap_symm_apply'

theorem continuousLinearMapCoordChange_apply [RingHomIsometric σ] (b : B)
    (hb : b ∈ e₁.baseSet ∩ e₂.baseSet ∩ (e₁'.baseSet ∩ e₂'.baseSet)) (L : F₁ →SL[σ] F₂) :
    continuousLinearMapCoordChange σ e₁ e₁' e₂ e₂' b L =
      (continuousLinearMap σ e₁' e₂' (totalSpaceMk b ((continuousLinearMap σ e₁ e₂).symm b L))).2 :=
  by
  ext v
  simp_rw [continuous_linear_map_coord_change, ContinuousLinearEquiv.coe_coe,
    ContinuousLinearEquiv.arrowCongrSL_apply, continuous_linear_map_apply,
    continuous_linear_map_symm_apply' σ e₁ e₂ hb.1, comp_apply, ContinuousLinearEquiv.coe_coe,
    ContinuousLinearEquiv.symm_symm, Trivialization.continuousLinearMapAt_apply,
    Trivialization.symmL_apply]
  dsimp only [total_space_mk]
  rw [e₂.coord_changeL_apply e₂', e₁'.coord_changeL_apply e₁, e₁.coe_linear_map_at_of_mem hb.1.1,
    e₂'.coe_linear_map_at_of_mem hb.2.2]
  exacts[⟨hb.2.1, hb.1.1⟩, ⟨hb.1.2, hb.2.2⟩]
#align pretrivialization.continuous_linear_map_coord_change_apply Pretrivialization.continuousLinearMapCoordChange_apply

end Pretrivialization

open Pretrivialization

variable (F₁ E₁ F₂ E₂) [RingHomIsometric σ]

variable [∀ x : B, TopologicalSpace (E₁ x)] [FiberBundle F₁ E₁] [VectorBundle 𝕜₁ F₁ E₁]

variable [∀ x : B, TopologicalSpace (E₂ x)] [FiberBundle F₂ E₂] [VectorBundle 𝕜₂ F₂ E₂]

variable [∀ x, ContinuousAdd (E₂ x)] [∀ x, ContinuousSMul 𝕜₂ (E₂ x)]

/-- The continuous `σ`-semilinear maps between two topological vector bundles form a
`vector_prebundle` (this is an auxiliary construction for the
`vector_bundle` instance, in which the pretrivializations are collated but no topology
on the total space is yet provided). -/
def Bundle.ContinuousLinearMap.vectorPrebundle :
    VectorPrebundle 𝕜₂ (F₁ →SL[σ] F₂) (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂)
    where
  pretrivializationAtlas :=
    { e |
      ∃ (e₁ : Trivialization F₁ (π E₁))(e₂ : Trivialization F₂ (π E₂))(_ :
        MemTrivializationAtlas e₁)(_ : MemTrivializationAtlas e₂),
        e = Pretrivialization.continuousLinearMap σ e₁ e₂ }
  pretrivialization_linear' := by
    rintro _ ⟨e₁, he₁, e₂, he₂, rfl⟩
    infer_instance
  pretrivializationAt x :=
    Pretrivialization.continuousLinearMap σ (trivializationAt F₁ E₁ x) (trivializationAt F₂ E₂ x)
  mem_base_pretrivializationAt x :=
    ⟨mem_baseSet_trivializationAt F₁ E₁ x, mem_baseSet_trivializationAt F₂ E₂ x⟩
  pretrivialization_mem_atlas x := ⟨trivializationAt F₁ E₁ x, trivializationAt F₂ E₂ x, _, _, rfl⟩
  exists_coord_change :=
    by
    rintro _ ⟨e₁, e₂, he₁, he₂, rfl⟩ _ ⟨e₁', e₂', he₁', he₂', rfl⟩
    skip
    exact
      ⟨continuous_linear_map_coord_change σ e₁ e₁' e₂ e₂',
        continuous_on_continuous_linear_map_coord_change,
        continuous_linear_map_coord_change_apply σ e₁ e₁' e₂ e₂'⟩
#align bundle.continuous_linear_map.vector_prebundle Bundle.ContinuousLinearMap.vectorPrebundle

/-- Topology on the continuous `σ`-semilinear_maps between the respective fibers at a point of two
"normable" vector bundles over the same base. Here "normable" means that the bundles have fibers
modelled on normed spaces `F₁`, `F₂` respectively.  The topology we put on the continuous
`σ`-semilinear_maps is the topology coming from the operator norm on maps from `F₁` to `F₂`. -/
instance (x : B) : TopologicalSpace (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂ x) :=
  (Bundle.ContinuousLinearMap.vectorPrebundle σ F₁ E₁ F₂ E₂).fiberTopology x

/-- Topology on the total space of the continuous `σ`-semilinear_maps between two "normable" vector
bundles over the same base. -/
instance Bundle.ContinuousLinearMap.topologicalSpaceTotalSpace :
    TopologicalSpace (TotalSpace (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂)) :=
  (Bundle.ContinuousLinearMap.vectorPrebundle σ F₁ E₁ F₂ E₂).totalSpaceTopology
#align bundle.continuous_linear_map.topological_space_total_space Bundle.ContinuousLinearMap.topologicalSpaceTotalSpace

/-- The continuous `σ`-semilinear_maps between two vector bundles form a fiber bundle. -/
instance Bundle.ContinuousLinearMap.fiberBundle :
    FiberBundle (F₁ →SL[σ] F₂) (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂) :=
  (Bundle.ContinuousLinearMap.vectorPrebundle σ F₁ E₁ F₂ E₂).toFiberBundle
#align bundle.continuous_linear_map.fiber_bundle Bundle.ContinuousLinearMap.fiberBundle

/-- The continuous `σ`-semilinear_maps between two vector bundles form a vector bundle. -/
instance Bundle.ContinuousLinearMap.vectorBundle :
    VectorBundle 𝕜₂ (F₁ →SL[σ] F₂) (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂) :=
  (Bundle.ContinuousLinearMap.vectorPrebundle σ F₁ E₁ F₂ E₂).to_vectorBundle
#align bundle.continuous_linear_map.vector_bundle Bundle.ContinuousLinearMap.vectorBundle

variable (e₁ e₂) [he₁ : MemTrivializationAtlas e₁] [he₂ : MemTrivializationAtlas e₂] {F₁ E₁ F₂ E₂}

include he₁ he₂

/-- Given trivializations `e₁`, `e₂` in the atlas for vector bundles `E₁`, `E₂` over a base `B`,
the induced trivialization for the continuous `σ`-semilinear maps from `E₁` to `E₂`,
whose base set is `e₁.base_set ∩ e₂.base_set`. -/
def Trivialization.continuousLinearMap :
    Trivialization (F₁ →SL[σ] F₂) (π (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂)) :=
  VectorPrebundle.trivializationOfMemPretrivializationAtlas _ ⟨e₁, e₂, he₁, he₂, rfl⟩
#align trivialization.continuous_linear_map Trivialization.continuousLinearMap

instance Bundle.ContinuousLinearMap.memTrivializationAtlas :
    MemTrivializationAtlas
      (e₁.ContinuousLinearMap σ e₂ :
        Trivialization (F₁ →SL[σ] F₂) (π (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂)))
    where out := ⟨_, ⟨e₁, e₂, by infer_instance, by infer_instance, rfl⟩, rfl⟩
#align bundle.continuous_linear_map.mem_trivialization_atlas Bundle.ContinuousLinearMap.memTrivializationAtlas

variable {e₁ e₂}

@[simp]
theorem Trivialization.baseSet_continuousLinearMap :
    (e₁.ContinuousLinearMap σ e₂).baseSet = e₁.baseSet ∩ e₂.baseSet :=
  rfl
#align trivialization.base_set_continuous_linear_map Trivialization.baseSet_continuousLinearMap

theorem Trivialization.continuousLinearMap_apply
    (p : TotalSpace (Bundle.ContinuousLinearMap σ F₁ E₁ F₂ E₂)) :
    e₁.ContinuousLinearMap σ e₂ p =
      ⟨p.1, (e₂.continuousLinearMapAt 𝕜₂ p.1).comp <| p.2.comp <| e₁.symmL 𝕜₁ p.1⟩ :=
  rfl
#align trivialization.continuous_linear_map_apply Trivialization.continuousLinearMap_apply


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.Spec

/-!
# The category of schemes

A scheme is a locally ringed space such that every point is contained in some open set
where there is an isomorphism of presheaves between the restriction to that open set,
and the structure sheaf of `Spec R`, for some commutative ring `R`.

A morphism of schemes is just a morphism of the underlying locally ringed spaces.

-/

noncomputable theory

open topological_space
open category_theory
open Top
open opposite

namespace algebraic_geometry

/--
We define `Scheme` as a `X : LocallyRingedSpace`,
along with a proof that every point has an open neighbourhood `U`
so that that the restriction of `X` to `U` is isomorphic,
as a locally ringed space, to `Spec.to_LocallyRingedSpace.obj (op R)`
for some `R : CommRing`.
-/
structure Scheme extends X : LocallyRingedSpace :=
(local_affine : ∀ x : X, ∃ (U : open_nhds x) (R : CommRing),
  nonempty (X.restrict U.open_embedding ≅ Spec.to_LocallyRingedSpace.obj (op R)))

namespace Scheme

/--
Every `Scheme` is a `LocallyRingedSpace`.
-/
-- (This parent projection is apparently not automatically generated because
-- we used the `extends X : LocallyRingedSpace` syntax.)
def to_LocallyRingedSpace (S : Scheme) : LocallyRingedSpace := { ..S }

/--
Schemes are a full subcategory of locally ringed spaces.
-/
instance : category Scheme :=
induced_category.category Scheme.to_LocallyRingedSpace

/--
The spectrum of a commutative ring, as a scheme.
-/
def Spec_obj (R : CommRing) : Scheme :=
{ local_affine := λ x,
  ⟨⟨⊤, trivial⟩, R, ⟨(Spec.to_LocallyRingedSpace.obj (op R)).restrict_top_iso⟩⟩,
  .. Spec.LocallyRingedSpace_obj R }

@[simp] lemma Spec_obj_to_LocallyRingedSpace (R : CommRing) :
  (Spec_obj R).to_LocallyRingedSpace = Spec.LocallyRingedSpace_obj R := rfl

/--
The induced map of a ring homomorphism on the ring spectra, as a morphism of schemes.
-/
def Spec_map {R S : CommRing} (f : R ⟶ S) :
  Spec_obj S ⟶ Spec_obj R :=
(Spec.LocallyRingedSpace_map f : Spec.LocallyRingedSpace_obj S ⟶ Spec.LocallyRingedSpace_obj R)

@[simp] lemma Spec_map_id (R : CommRing) :
  Spec_map (𝟙 R) = 𝟙 (Spec_obj R) :=
Spec.LocallyRingedSpace_map_id R

lemma Spec_map_comp {R S T : CommRing} (f : R ⟶ S) (g : S ⟶ T) :
  Spec_map (f ≫ g) = Spec_map g ≫ Spec_map f :=
Spec.LocallyRingedSpace_map_comp f g

/--
The spectrum, as a contravariant functor from commutative rings to schemes.
-/
@[simps] def Spec : CommRingᵒᵖ ⥤ Scheme :=
{ obj := λ R, Spec_obj (unop R),
  map := λ R S f, Spec_map f.unop,
  map_id' := λ R, by rw [unop_id, Spec_map_id],
  map_comp' := λ R S T f g, by rw [unop_comp, Spec_map_comp] }

/--
The empty scheme, as `Spec 0`.
-/
def empty : Scheme :=
Spec_obj (CommRing.of punit)

instance : has_emptyc Scheme := ⟨empty⟩

instance : inhabited Scheme := ⟨∅⟩

/--
The global sections, notated Gamma.
-/
def Γ : Schemeᵒᵖ ⥤ CommRing :=
(induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ

lemma Γ_def : Γ = (induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ := rfl

@[simp] lemma Γ_obj (X : Schemeᵒᵖ) : Γ.obj X = (unop X).presheaf.obj (op ⊤) := rfl

lemma Γ_obj_op (X : Scheme) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

@[simp] lemma Γ_map {X Y : Schemeᵒᵖ} (f : X ⟶ Y) :
  Γ.map f = f.unop.1.c.app (op ⊤) := rfl

lemma Γ_map_op {X Y : Scheme} (f : X ⟶ Y) :
  Γ.map f.op = f.1.c.app (op ⊤) := rfl

-- PROJECTS:
-- 1. Construct `Spec ≫ Γ ≅ functor.id _`.
-- 2. Adjunction between `Γ` and `Spec`.
--

end Scheme

end algebraic_geometry


import data.fintype.basic
import data.set.finite

-- Notas:
-- + Un tipo α es finito si hay un número finito de elementos de tipo
--   α. Se denota por `fintype α` y se define por
--      class fintype (α : Type*) :=
--      (elems [] : finset α)
--      (complete : ∀ x : α, x ∈ elems)
--   donde `elems` es una lista finita (sin repeticiones de los
--   elementos de α y `complete`expresa que todos los elementos de tipo
--   α están en `elems`.
-- + Un tipo α es infinito si no es finito. Se denota por `infinite α` y
--   se define por
--      class infinite (α : Type*) : Prop :=
--      (not_fintype : fintype α → false)
-- + `s.finite` indica que el conjunto `s` es finito. La definición de
--    conjunto finito es
--      def finite (s : set α) : Prop := nonempty (fintype s)
-- + `s.infinite` indica que el conjunto `s` es infinito. La definición
--   de conjunto infinito es
--      def infinite (s : set α) : Prop := ¬ finite s
-- + `sᶜ` es el complementario de `s` y está caracterizado por
--      mem_compl_iff (s : set α) (x : α) : x ∈ sᶜ ↔ x ∉ s
-- + El universo de los tipos infinitos son infinitos:
--      infinite_univ [h : _root_.infinite α] : infinite (@univ α)

lemma infinite_of_finite_compl
  {α : Type} [infinite α]
  {s : set α}
  (hs : sᶜ.finite)
  : s.infinite :=
λ h, set.infinite_univ (by simpa using hs.union h)

lemma compl_infinite_of_finite
  {α : Type} [infinite α]
  {s : set α}
  (hs : s.finite)
  : sᶜ.infinite :=
λ h, set.infinite_univ (by simpa using hs.union h)


import geometry.manifold.smooth_manifold_with_corners

open_locale topology
open metric (hiding mem_nhds_iff ball) set

section
variables {𝕜 E M H : Type*} [nontrivially_normed_field 𝕜]
variables [topological_space H] [topological_space M] [charted_space H M]
variables [normed_add_comm_group E] [normed_space 𝕜 E]
variables (I : model_with_corners 𝕜 E H)

lemma map_ext_chart_at_nhds_of_boundaryless [I.boundaryless] {x : M} :
  filter.map (ext_chart_at I x) (𝓝 x) = 𝓝 (ext_chart_at I x x) :=
by rw [map_ext_chart_at_nhds I x, model_with_corners.boundaryless.range_eq_univ, nhds_within_univ]

lemma ext_chart_at_image_nhd_mem_nhds_of_boundaryless [I.boundaryless]
  {x : M} {s : set M} (h : s ∈ 𝓝 x) :
  (ext_chart_at I x) '' s ∈ 𝓝 (ext_chart_at I x x) :=
begin
  rw [← map_ext_chart_at_nhds_of_boundaryless, filter.mem_map],
  filter_upwards [h] using subset_preimage_image (ext_chart_at I x) s,
end

namespace charted_space

/-- If `M` is a `charted_space` we can use the preferred chart at any point to transfer a
ball in coordinate space into a set in `M`. These can be a useful neighbourhood basis. -/
def ball (x : M) (r : ℝ) := (ext_chart_at I x).symm '' metric.ball (ext_chart_at I x x) r

lemma nhds_has_basis_balls_of_open_cov [I.boundaryless] (x : M)
  {ι : Type*} {s : ι → set M} (s_op : ∀ j, is_open $ s j) (cov : (⋃ j, s j) = univ) :
  (𝓝 x).has_basis (λ r, 0 < r ∧
                         metric.ball (ext_chart_at I x x) r ⊆ (ext_chart_at I x).target ∧
                         ∃ j, charted_space.ball I x r ⊆ s j)
                   (charted_space.ball I x) :=
begin
  -- TODO golf etc
  obtain ⟨j, hj⟩ : ∃ j, x ∈ s j, by { simpa only [mem_Union, ← cov] using mem_univ x, },
  replace hj : s j ∈ 𝓝 x := mem_nhds_iff.mpr ⟨s j, subset.rfl, s_op j, hj⟩,
  have hx : (ext_chart_at I x).source ∈ 𝓝 x := ext_chart_at_source_mem_nhds I x,
  refine filter.has_basis_iff.mpr (λ n, ⟨λ hn, _, _⟩),
  { let m := s j ∩ n ∩ (ext_chart_at I x).source,
    have hm : m ∈ 𝓝 x := filter.inter_mem (filter.inter_mem hj hn) hx,
    replace hm : (ext_chart_at I x) '' m ∈ 𝓝 (ext_chart_at I x x) :=
      ext_chart_at_image_nhd_mem_nhds_of_boundaryless I hm,
    obtain ⟨r, hr₀, hr₁⟩ :=
      (filter.has_basis_iff.mp (@nhds_basis_ball E _ (ext_chart_at I x x)) _).mp hm,
    refine ⟨r, ⟨hr₀, hr₁.trans _, ⟨j, _⟩⟩, _⟩,
    { exact ((ext_chart_at I x).maps_to.mono (inter_subset_right _ _) subset.rfl).image_subset },
    { suffices : m ⊆ s j,
      { refine subset.trans _ this,
        convert monotone_image hr₁,
        exact (local_equiv.symm_image_image_of_subset_source _
          (set.inter_subset_right _ _)).symm, },
      exact (set.inter_subset_left _ _).trans (set.inter_subset_left _ _), },
    { suffices : m ⊆ n,
      { refine subset.trans _ this,
        convert monotone_image hr₁,
        exact (local_equiv.symm_image_image_of_subset_source _
          (set.inter_subset_right _ _)).symm, },
      exact (set.inter_subset_left _ _).trans (set.inter_subset_right _ _), }, },
  { rintros ⟨r, ⟨hr₀, hr₁, -⟩, hr₂⟩,
    replace hr₀ : metric.ball (ext_chart_at I x x) r ∈ 𝓝 (ext_chart_at I x x) := ball_mem_nhds _ hr₀,
    rw [← map_ext_chart_at_nhds_of_boundaryless, filter.mem_map] at hr₀,
    replace hr₀ := filter.inter_mem hx hr₀,
    rw ← (ext_chart_at I x).symm_image_eq_source_inter_preimage hr₁ at hr₀,
    filter_upwards [hr₀] using hr₂, },
end

end charted_space
end

section
variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E] [finite_dimensional ℝ E]
  {H : Type*} [topological_space H] (I : model_with_corners ℝ E H) (M : Type*)
  [topological_space M] [charted_space H M]

lemma locally_compact_manifold  :
  locally_compact_space M :=
@charted_space.locally_compact H M _ _ _ I.locally_compact
end


import .real_axiom .analysis
open set classical real_axiom real_axiom.extended_real
local attribute [instance] prop_decidable
noncomputable theory

universe u

def countable_union {X : Type u} (f : ℕ → set X) : set X :=
{x | ∃ n, x ∈ f n}

variables {X : Type u} (σ : set (set X))
class sigma_algebra :=
(univ_mem : univ ∈ σ)
(closed_under_comp : ∀ s, s ∈ σ → univ \ s ∈ σ)
(closed_under_countable_union : ∀ f : ℕ → set X, (∀ n, f n ∈ σ) → countable_union f ∈ σ)

variable [sigma_algebra σ]

-- alternatively, we could define μ using subtypes, as a function {s : set X // s ∈ σ} → ℝ∞.
-- this complicates some things and simplifies others.
class measure_space (μ : (set X) → ℝ∞) :=
(measure_nonneg : ∀ s ∈ σ, μ s ≥ 0)
(measure_empty : μ ∅ = 0)
(measure_union : ∀ (f : ℕ → set X), (∀ n, f n ∈ σ) → (∀ m n, m ≠ n → f m ∩ f n = ∅) →
   μ (countable_union f) = extended_real.countable_sum (μ ∘ f))

class finite_measure_space (μ : (set X) → ℝ∞) extends measure_space σ μ :=
(measure_univ_finite : ∃ b : ℝ, μ univ = of_real b)

def univ_measure (μ : (set X) → ℝ∞) [finite_measure_space σ μ] : ℝ :=
some (@finite_measure_space.measure_univ_finite X σ (by apply_instance) μ (by apply_instance))

def lebesgue_measurable (f : X → ℝ) :=
∀ t : ℝ, {x | f x > t} ∈ σ

-- note that we assume μ is a total function here. Theorems involving μ should assume the arguments are in σ.
variable μ : (set X) → ℝ∞

section
variable [measure_space σ μ]

-- this assumes s ∈ σ
def indicator_measure (s : set X) : ℝ∞ := μ s

def indicator_function (s : set X) (x : X) : ℝ := if x ∈ s then 1 else 0

def is_simple_function (ls : list (ℝ × (set X))) := ∀ p : ℝ × (set X), p ∈ ls → p.1 ≥ 0 ∧ p.2 ∈ σ

def simple_function (ls : list (ℝ × (set X))) (x : X) : ℝ :=
(ls.map (λ p : ℝ × (set X), p.1 * indicator_function p.2 x)).foldr (+) 0

unfinished simple_function_pos : ∀ {X} (σ : set (set X)) (μ : set X → ℝ∞) [sigma_algebra σ] [measure_space σ μ],
  ∀ (ls : list (ℝ × (set X))), (∀ p : ℝ × (set X), p ∈ ls → p.1 ≥ 0 ∧ p.2 ∈ σ) → ∀ x, simple_function ls x ≥ 0 :=
{ description := "simple functions are nonnegative" }

-- must use 0*∞ = 0
-- this assumes is_simple_function ls
def simple_function_integral (ls : list (ℝ × (set X))) : ℝ∞ :=
(ls.map (λ p : ℝ × (set X), of_real p.1 * indicator_measure μ p.2)).foldr (+) 0

-- this will be better looking once we have better parsing for unfinished
unfinished simple_function_integral_well_defined :
 ∀ {X μ σ} [sigma_algebra σ] [measure_space σ μ] (ls1 : list (ℝ × set X)) (ls2 : list (ℝ × set X)),
    (∀ p : ℝ × (set X), p ∈ ls1 → p.1 ≥ 0 ∧ p.2 ∈ σ) → (∀ p : ℝ × (set X), p ∈ ls2 → p.1 ≥ 0 ∧ p.2 ∈ σ) →
      (lebesgue_measurable σ (simple_function ls1)) → (lebesgue_measurable σ (simple_function ls2)) →
        (simple_function ls1 = simple_function ls2) → (simple_function_integral μ ls1 = simple_function_integral μ ls2) :=
{ description := "the integral of a simple function does not depend on the representation of that function" }

-- assumes (h : ∀ x, f x ≥ 0)
def nonneg_function_integral (f : X → ℝ) : ℝ∞ :=
extended_real.sup
  (image (simple_function_integral μ)
   {ls : list (ℝ × (set X)) | is_simple_function σ ls ∧ ∀ x, 0 ≤ simple_function ls x ∧  (simple_function ls x) ≤ f x})

-- this shorter version should work when unfinished is fixed
/-unfinished simple_function_integral_eq_nonneg_function_integral :
 ∀ {X μ σ} [sigma_algebra σ] [measure_space σ μ] (ls : list (ℝ × set X)),
    (∀ p : ℝ × (set X), p ∈ ls → p.1 ≥ 0 ∧ p.2 ∈ σ) → (lebesgue_measurable σ (simple_function ls)) →
     simple_function_integral μ ls = nonneg_function_integral σ μ (simple_function ls) :=
{ description := "the simple and nonnegative integrals match" }-/
unfinished simple_function_integral_eq_nonneg_function_integral :
 ∀ {X μ σ} [sigma_algebra σ] [measure_space σ μ] (ls : list (ℝ × set X)),
    (∀ p : ℝ × (set X), p ∈ ls → p.1 ≥ 0 ∧ p.2 ∈ σ) → (lebesgue_measurable σ (simple_function ls)) →
     simple_function_integral μ ls = @nonneg_function_integral _ σ _ μ (by apply_instance) (simple_function ls) :=
{ description := "the simple and nonnegative integrals match" }

def pos_part (f : X → ℝ) (x : X) : ℝ := if f x > 0 then f x else 0
def neg_part (f : X → ℝ) (x : X) : ℝ := if f x < 0 then -(f x) else 0

theorem pos_part_nonneg (f : X → ℝ) (x : X) : pos_part f x ≥ 0 :=
begin cases (em (f x > 0)), all_goals {unfold pos_part, simp *}, {apply le_of_lt, assumption}, apply le_refl end

theorem neg_part_nonneg (f : X → ℝ) (x : X) : neg_part f x ≥ 0 :=
begin cases (em (f x < 0)), all_goals {unfold neg_part, simp *}, {apply le_of_lt, apply neg_pos_of_neg, assumption}, apply le_refl end

unfinished pos_part_plus_neg_part : ∀ {X} (f : X → ℝ) (x : X), abs (f x) = pos_part f x + neg_part f x :=
{ description := "abs f decomposes into the sum of pos and neg parts" }

def signed_integral_exists_condition (f : X → ℝ) :=
nonneg_function_integral σ μ (pos_part f) < inf ∨ nonneg_function_integral σ μ (neg_part f) < inf

-- assumes signed_integral_exists_condition f
def signed_function_integral (f : X → ℝ) : ℝ∞ :=
nonneg_function_integral σ μ (pos_part f) + nonneg_function_integral σ μ (neg_part f)

class lebesgue_integrable (f : X → ℝ) :=
(r : ℝ)
(f_integrable : signed_integral_exists_condition σ μ f)
(integral_value : signed_function_integral σ μ f = of_real r)

def lebesgue_integral (f : X → ℝ) [lebesgue_integrable σ μ f] : ℝ :=
 @lebesgue_integrable.r X σ (by apply_instance) μ (by apply_instance) f (by apply_instance)

def almost_everywhere (P : X → Prop) := {x | ¬ P x} ∈ σ ∧ μ {x | ¬ P x} = 0

end


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

import tactic.apply
import control.fix
import order.omega_complete_partial_order

/-!
# Lawful fixed point operators

This module defines the laws required of a `has_fix` instance, using the theory of
omega complete partial orders (ωCPO). Proofs of the lawfulness of all `has_fix` instances in
`control.fix` are provided.

## Main definition

 * class `lawful_fix`
-/

universes u v

open_locale classical
variables {α : Type*} {β : α → Type*}

open omega_complete_partial_order

/-- Intuitively, a fixed point operator `fix` is lawful if it satisfies `fix f = f (fix f)` for all
`f`, but this is inconsistent / uninteresting in most cases due to the existence of "exotic"
functions `f`, such as the function that is defined iff its argument is not, familiar from the
halting problem. Instead, this requirement is limited to only functions that are `continuous` in the
sense of `ω`-complete partial orders, which excludes the example because it is not monotone
(making the input argument less defined can make `f` more defined). -/
class lawful_fix (α : Type*) [omega_complete_partial_order α] extends has_fix α :=
(fix_eq : ∀ {f : α →o α}, continuous f → has_fix.fix f = f (has_fix.fix f))

lemma lawful_fix.fix_eq' {α} [omega_complete_partial_order α] [lawful_fix α]
  {f : α → α} (hf : continuous' f) :
  has_fix.fix f = f (has_fix.fix f) :=
lawful_fix.fix_eq (hf.to_bundled _)

namespace part

open part nat nat.upto

namespace fix

variables (f : (Π a, part $ β a) →o (Π a, part $ β a))

lemma approx_mono' {i : ℕ} : fix.approx f i ≤ fix.approx f (succ i) :=
begin
  induction i, dsimp [approx], apply @bot_le _ _ _ (f ⊥),
  intro, apply f.monotone, apply i_ih
end

lemma approx_mono ⦃i j : ℕ⦄ (hij : i ≤ j) : approx f i ≤ approx f j :=
begin
  induction j with j ih, { cases hij, exact le_rfl },
  cases hij, { exact le_rfl },
  exact le_trans (ih ‹_›) (approx_mono' f)
end

lemma mem_iff (a : α) (b : β a) : b ∈ part.fix f a ↔ ∃ i, b ∈ approx f i a :=
begin
  by_cases h₀ : ∃ (i : ℕ), (approx f i a).dom,
  { simp only [part.fix_def f h₀],
    split; intro hh, exact ⟨_,hh⟩,
    have h₁ := nat.find_spec h₀,
    rw [dom_iff_mem] at h₁,
    cases h₁ with y h₁,
    replace h₁ := approx_mono' f _ _ h₁,
    suffices : y = b, subst this, exact h₁,
    cases hh with i hh,
    revert h₁, generalize : (succ (nat.find h₀)) = j, intro,
    wlog : i ≤ j := le_total i j using [i j b y,j i y b],
    replace hh := approx_mono f case _ _ hh,
    apply part.mem_unique h₁ hh },
  { simp only [fix_def' ⇑f h₀, not_exists, false_iff, not_mem_none],
    simp only [dom_iff_mem, not_exists] at h₀,
    intro, apply h₀ }
end

lemma approx_le_fix (i : ℕ) : approx f i ≤ part.fix f :=
assume a b hh,
by { rw [mem_iff f], exact ⟨_,hh⟩ }

lemma exists_fix_le_approx (x : α) : ∃ i, part.fix f x ≤ approx f i x :=
begin
  by_cases hh : ∃ i b, b ∈ approx f i x,
  { rcases hh with ⟨i,b,hb⟩, existsi i,
    intros b' h',
    have hb' := approx_le_fix f i _ _ hb,
    have hh := part.mem_unique h' hb',
    subst hh, exact hb },
  { simp only [not_exists] at hh, existsi 0,
    intros b' h',
    simp only [mem_iff f] at h',
    cases h' with i h',
    cases hh _ _ h' }
end

include f

/-- The series of approximations of `fix f` (see `approx`) as a `chain` -/
def approx_chain : chain (Π a, part $ β a) := ⟨approx f, approx_mono f⟩

lemma le_f_of_mem_approx {x} (hx : x ∈ approx_chain f) : x ≤ f x :=
begin
  revert hx, simp [(∈)],
  intros i hx, subst x,
  apply approx_mono'
end

lemma approx_mem_approx_chain {i} : approx f i ∈ approx_chain f :=
stream.mem_of_nth_eq rfl

end fix

open fix

variables {α}
variables (f : (Π a, part $ β a) →o (Π a, part $ β a))

open omega_complete_partial_order

open part (hiding ωSup) nat
open nat.upto omega_complete_partial_order

lemma fix_eq_ωSup : part.fix f = ωSup (approx_chain f) :=
begin
  apply le_antisymm,
  { intro x, cases exists_fix_le_approx f x with i hx,
    transitivity' approx f i.succ x,
    { transitivity', apply hx, apply approx_mono' f },
    apply' le_ωSup_of_le i.succ,
    dsimp [approx], refl', },
  { apply ωSup_le _ _ _,
    simp only [fix.approx_chain, order_hom.coe_fun_mk],
    intros y x, apply approx_le_fix f },
end

lemma fix_le {X : Π a, part $ β a} (hX : f X ≤ X) : part.fix f ≤ X :=
begin
  rw fix_eq_ωSup f,
  apply ωSup_le _ _ _,
  simp only [fix.approx_chain, order_hom.coe_fun_mk],
  intros i,
  induction i, dsimp [fix.approx], apply' bot_le,
  transitivity' f X, apply f.monotone i_ih,
  apply hX
end

variables {f} (hc : continuous f)
include hc

lemma fix_eq : part.fix f = f (part.fix f) :=
begin
  rw [fix_eq_ωSup f,hc],
  apply le_antisymm,
  { apply ωSup_le_ωSup_of_le _,
    intros i, existsi [i], intro x, -- intros x y hx,
    apply le_f_of_mem_approx _ ⟨i, rfl⟩, },
  { apply ωSup_le_ωSup_of_le _,
    intros i, existsi i.succ, refl', }
end

end part

namespace part

/-- `to_unit` as a monotone function -/
@[simps]
def to_unit_mono (f : part α →o part α) : (unit → part α) →o (unit → part α) :=
{ to_fun := λ x u, f (x u),
  monotone' := λ x y (h : x ≤ y) u, f.monotone $ h u }

lemma to_unit_cont (f : part α →o part α) (hc : continuous f) : continuous (to_unit_mono f)
| c := begin
  ext ⟨⟩ : 1,
  dsimp [omega_complete_partial_order.ωSup],
  erw [hc, chain.map_comp], refl
end

noncomputable instance : lawful_fix (part α) :=
⟨λ f hc, show part.fix (to_unit_mono f) () = _, by rw part.fix_eq (to_unit_cont f hc); refl⟩

end part

open sigma

namespace pi

noncomputable instance {β} : lawful_fix (α → part β) := ⟨λ f, part.fix_eq⟩

variables {γ : Π a : α, β a → Type*}

section monotone

variables (α β γ)

/-- `sigma.curry` as a monotone function. -/
@[simps]
def monotone_curry [∀ x y, preorder $ γ x y] :
  (Π x : Σ a, β a, γ x.1 x.2) →o (Π a (b : β a), γ a b) :=
{ to_fun := curry,
  monotone' := λ x y h a b, h ⟨a,b⟩ }

/-- `sigma.uncurry` as a monotone function. -/
@[simps]
def monotone_uncurry [∀ x y, preorder $ γ x y] :
  (Π a (b : β a), γ a b) →o (Π x : Σ a, β a, γ x.1 x.2) :=
{ to_fun := uncurry,
  monotone' := λ x y h a, h a.1 a.2 }

variables [∀ x y, omega_complete_partial_order $ γ x y]

open omega_complete_partial_order.chain

lemma continuous_curry : continuous $ monotone_curry α β γ :=
λ c, by { ext x y, dsimp [curry,ωSup], rw [map_comp,map_comp], refl }

lemma continuous_uncurry : continuous $ monotone_uncurry α β γ :=
λ c, by { ext x y, dsimp [uncurry,ωSup], rw [map_comp,map_comp], refl }

end monotone

open has_fix

instance [has_fix $ Π x : sigma β, γ x.1 x.2] : has_fix (Π x (y : β x), γ x y) :=
⟨ λ f, curry (fix $ uncurry ∘ f ∘ curry) ⟩

variables [∀ x y, omega_complete_partial_order $ γ x y]

section curry

variables {f : (Π x (y : β x), γ x y) →o (Π x (y : β x), γ x y)}
variables (hc : continuous f)

lemma uncurry_curry_continuous :
  continuous $ (monotone_uncurry α β γ).comp $ f.comp $ monotone_curry α β γ :=
continuous_comp _ _
  (continuous_comp _ _ (continuous_curry _ _ _) hc)
  (continuous_uncurry _ _ _)

end curry

instance pi.lawful_fix' [lawful_fix $ Π x : sigma β, γ x.1 x.2] : lawful_fix (Π x y, γ x y) :=
{ fix_eq := λ f hc,
    begin
      dsimp [fix],
      conv { to_lhs, erw [lawful_fix.fix_eq (uncurry_curry_continuous hc)] },
      refl,
    end, }

end pi


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Gluing metric spaces
Authors: Sébastien Gouëzel

Gluing two metric spaces along a common subset. Formally, we are given
     Φ
  γ ---> α
  |
  |Ψ
  v
  β
where hΦ : isometry Φ and hΨ : isometry Ψ
We want to complete the square by a space `glue_space hΦ hΨ` and two isometries
`to_glue_l hΦ hΨ` and `to_glue_r hΦ hΨ` that make the square commute.
We start by defining a predistance on the disjoint union α ⊕ β, for which
points Φ p and Ψ p are at distance 0. The (quotient) metric space associated
to this predistance is the desired space.

This is an instance of a more general construction, where Φ and Ψ do not have to be isometries,
but the distances in the image almost coincide, up to 2ε say. Then one can almost glue the two
spaces so that the images of a point under Φ and Ψ are ε-close. If ε > 0, this yields a
metric space structure on α ⊕ β, without the need to take a quotient. In particular, when
α and β are inhabited, this gives a natural metric space structure on α ⊕ β, where the basepoints
are at distance 1, say, and the distances between other points are obtained by going through the
two basepoints.
-/

import topology.metric_space.isometry topology.metric_space.premetric_space

noncomputable theory

universes u v w
variables {α : Type u} {β : Type v} {γ : Type w}

open function set premetric lattice

namespace metric
section approx_gluing

variables [nonempty γ] [metric_space α] [metric_space β]
          {Φ : γ → α} {Ψ : γ → β} {ε : ℝ}
open lattice
open sum (inl inr)

/-- Define a predistance on α ⊕ β, for which Φ p and Ψ p are at distance ε -/
def glue_dist (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) : α ⊕ β → α ⊕ β → ℝ
| (inl x) (inl y) := dist x y
| (inr x) (inr y) := dist x y
| (inl x) (inr y) := infi (λp, dist x (Φ p) + dist y (Ψ p)) + ε
| (inr x) (inl y) := infi (λp, dist y (Φ p) + dist x (Ψ p)) + ε

private lemma glue_dist_self (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) : ∀x, glue_dist Φ Ψ ε x x = 0
| (inl x) := dist_self _
| (inr x) := dist_self _

lemma glue_dist_glued_points (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) (p : γ) :
  glue_dist Φ Ψ ε (inl (Φ p)) (inr (Ψ p)) = ε :=
begin
  have : infi (λq, dist (Φ p) (Φ q) + dist (Ψ p) (Ψ q)) = 0,
  { have A : ∀q, 0 ≤ dist (Φ p) (Φ q) + dist (Ψ p) (Ψ q) :=
      λq, by rw ← add_zero (0 : ℝ); exact add_le_add dist_nonneg dist_nonneg,
    refine le_antisymm _ (le_cinfi A),
    have : 0 = dist (Φ p) (Φ p) + dist (Ψ p) (Ψ p), by simp,
    rw this,
    exact cinfi_le ⟨0, forall_range_iff.2 A⟩ },
  rw [glue_dist, this, zero_add]
end

private lemma glue_dist_comm (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) :
  ∀x y, glue_dist Φ Ψ ε x y = glue_dist Φ Ψ ε y x
| (inl x) (inl y) := dist_comm _ _
| (inr x) (inr y) := dist_comm _ _
| (inl x) (inr y) := rfl
| (inr x) (inl y) := rfl

private lemma glue_dist_triangle (Φ : γ → α) (Ψ : γ → β) (ε : ℝ)
  (H : ∀p q, abs (dist (Φ p) (Φ q) - dist (Ψ p) (Ψ q)) ≤ 2 * ε) :
  ∀x y z, glue_dist Φ Ψ ε x z ≤ glue_dist Φ Ψ ε x y + glue_dist Φ Ψ ε y z
| (inl x) (inl y) (inl z) := dist_triangle _ _ _
| (inr x) (inr y) (inr z) := dist_triangle _ _ _
| (inr x) (inl y) (inl z) := begin
    have B : ∀a b, bdd_below (range (λ (p : γ), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : infi (λp, dist z (Φ p) + dist x (Ψ p)) ≤ infi (λp, dist y (Φ p) + dist x (Ψ p)) + dist y z,
    { have : infi (λp, dist y (Φ p) + dist x (Ψ p)) + dist y z =
            infi ((λt, t + dist y z) ∘ (λp, dist y (Φ p) + dist x (Ψ p))),
      { refine cinfi_of_cinfi_of_monotone_of_continuous (_ : continuous (λt, t + dist y z)) _ (B _ _),
        exact continuous_add continuous_id continuous_const,
        exact λx y hx, by simpa },
      rw [this, comp],
      refine cinfi_le_cinfi (B _ _) (λp, _),
      calc
        dist z (Φ p) + dist x (Ψ p) ≤ (dist y z + dist y (Φ p)) + dist x (Ψ p) :
          add_le_add (dist_triangle_left _ _ _) (le_refl _)
        ... = dist y (Φ p) + dist x (Ψ p) + dist y z : by ring },
    linarith
  end
| (inr x) (inr y) (inl z) := begin
    have B : ∀a b, bdd_below (range (λ (p : γ), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : infi (λp, dist z (Φ p) + dist x (Ψ p)) ≤ dist x y + infi (λp, dist z (Φ p) + dist y (Ψ p)),
    { have : dist x y + infi (λp, dist z (Φ p) + dist y (Ψ p)) =
            infi ((λt, dist x y + t) ∘ (λp, dist z (Φ p) + dist y (Ψ p))),
      { refine cinfi_of_cinfi_of_monotone_of_continuous (_ : continuous (λt, dist x y + t)) _ (B _ _),
        exact continuous_add continuous_const continuous_id,
        exact λx y hx, by simpa },
      rw [this, comp],
      refine cinfi_le_cinfi (B _ _) (λp, _),
      calc
        dist z (Φ p) + dist x (Ψ p) ≤ dist z (Φ p) + (dist x y + dist y (Ψ p)) :
          add_le_add (le_refl _) (dist_triangle _ _ _)
        ... = dist x y + (dist z (Φ p) + dist y (Ψ p)) : by ring },
    linarith
  end
| (inl x) (inl y) (inr z) := begin
    have B : ∀a b, bdd_below (range (λ (p : γ), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : infi (λp, dist x (Φ p) + dist z (Ψ p)) ≤ dist x y + infi (λp, dist y (Φ p) + dist z (Ψ p)),
    { have : dist x y + infi (λp, dist y (Φ p) + dist z (Ψ p)) =
            infi ((λt, dist x y + t) ∘ (λp, dist y (Φ p) + dist z (Ψ p))),
      { refine cinfi_of_cinfi_of_monotone_of_continuous ( _ : continuous (λt, dist x y + t)) _ (B _ _),
        exact continuous_add continuous_const continuous_id,
        exact λx y hx, by simpa },
      rw [this, comp],
      refine cinfi_le_cinfi (B _ _) (λp, _),
      calc
        dist x (Φ p) + dist z (Ψ p) ≤ (dist x y + dist y (Φ p)) + dist z (Ψ p) :
          add_le_add (dist_triangle _ _ _) (le_refl _)
        ... = dist x y + (dist y (Φ p) + dist z (Ψ p)) : by ring },
    linarith
  end
| (inl x) (inr y) (inr z) := begin
    have B : ∀a b, bdd_below (range (λ (p : γ), dist a (Φ p) + dist b (Ψ p))) :=
      λa b, ⟨0, forall_range_iff.2 (λp, add_nonneg dist_nonneg dist_nonneg)⟩,
    unfold glue_dist,
    have : infi (λp, dist x (Φ p) + dist z (Ψ p)) ≤ infi (λp, dist x (Φ p) + dist y (Ψ p)) + dist y z,
    { have : infi (λp, dist x (Φ p) + dist y (Ψ p)) + dist y z =
            infi ((λt, t + dist y z) ∘ (λp, dist x (Φ p) + dist y (Ψ p))),
      { refine cinfi_of_cinfi_of_monotone_of_continuous (_ : continuous (λt, t + dist y z)) _ (B _ _),
        exact continuous_add continuous_id continuous_const,
        exact λx y hx, by simpa },
      rw [this, comp],
      refine cinfi_le_cinfi (B _ _) (λp, _),
      calc
        dist x (Φ p) + dist z (Ψ p) ≤ dist x (Φ p) + (dist y z + dist y (Ψ p)) :
          add_le_add (le_refl _) (dist_triangle_left _ _ _)
        ... = dist x (Φ p) + dist y (Ψ p) + dist y z : by ring },
    linarith
  end
| (inl x) (inr y) (inl z) := real.le_of_forall_epsilon_le $ λδ δpos, begin
    have : ∃a ∈ range (λp, dist x (Φ p) + dist y (Ψ p)), a < infi (λp, dist x (Φ p) + dist y (Ψ p)) + δ/2 :=
      exists_lt_of_cInf_lt (by simp [_inst_1]) (by rw [infi]; linarith),
    rcases this with ⟨a, arange, ha⟩,
    rcases mem_range.1 arange with ⟨p, pa⟩,
    rw ← pa at ha,
    have : ∃b ∈ range (λp, dist z (Φ p) + dist y (Ψ p)), b < infi (λp, dist z (Φ p) + dist y (Ψ p)) + δ/2 :=
      exists_lt_of_cInf_lt (by simp [_inst_1]) (by rw [infi]; linarith),
    rcases this with ⟨b, brange, hb⟩,
    rcases mem_range.1 brange with ⟨q, qb⟩,
    rw ← qb at hb,
    have : dist (Φ p) (Φ q) ≤ dist (Ψ p) (Ψ q) + 2 * ε,
      { have := le_trans (le_abs_self _) (H p q), by linarith },
    calc dist x z ≤ dist x (Φ p) + dist (Φ p) (Φ q) + dist (Φ q) z : dist_triangle4 _ _ _ _
      ... ≤ dist x (Φ p) + dist (Ψ p) (Ψ q) + dist z (Φ q) + 2 * ε : by rw [dist_comm z]; linarith
      ... ≤ dist x (Φ p) + (dist y (Ψ p) + dist y (Ψ q)) + dist z (Φ q) + 2 * ε :
        add_le_add (add_le_add (add_le_add (le_refl _) (dist_triangle_left _ _ _)) (le_refl _)) (le_refl _)
      ... ≤ (infi (λp, dist x (Φ p) + dist y (Ψ p)) + ε) + (infi (λp, dist z (Φ p) + dist y (Ψ p)) + ε) + δ :
        by linarith
  end
| (inr x) (inl y) (inr z) := real.le_of_forall_epsilon_le $ λδ δpos, begin
    have : ∃a ∈ range (λp, dist y (Φ p) + dist x (Ψ p)), a < infi (λp, dist y (Φ p) + dist x (Ψ p)) + δ/2 :=
      exists_lt_of_cInf_lt (by simp [_inst_1]) (by rw [infi]; linarith),
    rcases this with ⟨a, arange, ha⟩,
    rcases mem_range.1 arange with ⟨p, pa⟩,
    rw ← pa at ha,
    have : ∃b ∈ range (λp, dist y (Φ p) + dist z (Ψ p)), b < infi (λp, dist y (Φ p) + dist z (Ψ p)) + δ/2 :=
      exists_lt_of_cInf_lt (by simp [_inst_1]) (by rw [infi]; linarith),
    rcases this with ⟨b, brange, hb⟩,
    rcases mem_range.1 brange with ⟨q, qb⟩,
    rw ← qb at hb,
    have : dist (Ψ p) (Ψ q) ≤ dist (Φ p) (Φ q) + 2 * ε,
      { have := le_trans (neg_le_abs_self _) (H p q), by linarith },
    calc dist x z ≤ dist x (Ψ p) + dist (Ψ p) (Ψ q) + dist (Ψ q) z : dist_triangle4 _ _ _ _
      ... ≤ dist x (Ψ p) + dist (Φ p) (Φ q) + dist z (Ψ q) + 2 * ε : by rw [dist_comm z]; linarith
      ... ≤ dist x (Ψ p) + (dist y (Φ p) + dist y (Φ q)) + dist z (Ψ q) + 2 * ε :
        add_le_add (add_le_add (add_le_add (le_refl _) (dist_triangle_left _ _ _)) (le_refl _)) (le_refl _)
      ... ≤ (infi (λp, dist y (Φ p) + dist x (Ψ p)) + ε) + (infi (λp, dist y (Φ p) + dist z (Ψ p)) + ε) + δ :
        by linarith
  end

private lemma glue_eq_of_dist_eq_zero (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) (ε0 : 0 < ε) :
  ∀p q : α ⊕ β, glue_dist Φ Ψ ε p q = 0 → p = q
| (inl x) (inl y) h := by rw eq_of_dist_eq_zero h
| (inl x) (inr y) h := begin
    have : 0 ≤ infi (λp, dist x (Φ p) + dist y (Ψ p)) :=
      le_cinfi (λp, by simpa using add_le_add (@dist_nonneg _ _ x _) (@dist_nonneg _ _ y _)),
    have : 0 + ε ≤ glue_dist Φ Ψ ε (inl x) (inr y) := add_le_add this (le_refl ε),
    exfalso,
    linarith
  end
| (inr x) (inl y) h := begin
    have : 0 ≤ infi (λp, dist y (Φ p) + dist x (Ψ p)) :=
      le_cinfi (λp, by simpa using add_le_add (@dist_nonneg _ _ x _) (@dist_nonneg _ _ y _)),
    have : 0 + ε ≤ glue_dist Φ Ψ ε (inr x) (inl y) := add_le_add this (le_refl ε),
    exfalso,
    linarith
  end
| (inr x) (inr y) h := by rw eq_of_dist_eq_zero h

/-- Given two maps Φ and Ψ intro metric spaces α and β such that the distances between Φ p and Φ q,
and between Ψ p and Ψ q, coincide up to 2 ε where ε > 0, one can almost glue the two spaces α
and β along the images of Φ and Ψ, so that Φ p and Ψ p are at distance ε. -/
def glue_metric_approx (Φ : γ → α) (Ψ : γ → β) (ε : ℝ) (ε0 : 0 < ε)
  (H : ∀p q, abs (dist (Φ p) (Φ q) - dist (Ψ p) (Ψ q)) ≤ 2 * ε) : metric_space (α ⊕ β) :=
{ dist               := glue_dist Φ Ψ ε,
  dist_self          := glue_dist_self Φ Ψ ε,
  dist_comm          := glue_dist_comm Φ Ψ ε,
  dist_triangle      := glue_dist_triangle Φ Ψ ε H,
  eq_of_dist_eq_zero := glue_eq_of_dist_eq_zero Φ Ψ ε ε0 }

end approx_gluing

section sum
/- A particular case of the previous construction is when one uses basepoints in α and β and one
glues only along the basepoints, putting them at distance 1. We give a direct definition of
the distance, without infi, as it is easier to use in applications, and show that it is equal to
the gluing distance defined above to take advantage of the lemmas we have already proved. -/

variables [metric_space α] [metric_space β] [inhabited α] [inhabited β]
open sum (inl inr)

/- Distance on a disjoint union. There are many (noncanonical) ways to put a distance compatible
with each factor.
If the two spaces are bounded, one can say for instance that each point in the first is at distance
`diam α + diam β + 1` of each point in the second.
Instead, we choose a construction that works for unbounded spaces, but requires basepoints.
We embed isometrically each factor, set the basepoints at distance 1,
arbitrarily, and say that the distance from `a` to `b` is the sum of the distances of `a` and `b` to
their respective basepoints, plus the distance 1 between the basepoints.
Since there is an arbitrary choice in this construction, it is not an instance by default. -/

def sum.dist : α ⊕ β → α ⊕ β → ℝ
| (inl a) (inl a') := dist a a'
| (inr b) (inr b') := dist b b'
| (inl a) (inr b)  := dist a (default α) + 1 + dist (default β) b
| (inr b) (inl a)  := dist b (default β) + 1 + dist (default α) a

lemma sum.dist_eq_glue_dist {p q : α ⊕ β} :
  sum.dist p q = glue_dist (λ_ : unit, default α) (λ_ : unit, default β) 1 p q :=
by cases p; cases q; refl <|> simp [sum.dist, glue_dist, dist_comm]

private lemma sum.dist_comm (x y : α ⊕ β) : sum.dist x y = sum.dist y x :=
by cases x; cases y; simp only [sum.dist, dist_comm, add_comm, add_left_comm]

lemma sum.one_dist_le {x : α} {y : β} : 1 ≤ sum.dist (inl x) (inr y) :=
le_trans (le_add_of_nonneg_right dist_nonneg) $
add_le_add_right (le_add_of_nonneg_left dist_nonneg) _

lemma sum.one_dist_le' {x : α} {y : β} : 1 ≤ sum.dist (inr y) (inl x) :=
by rw sum.dist_comm; exact sum.one_dist_le

private lemma sum.mem_uniformity (s : set ((α ⊕ β) × (α ⊕ β))) :
  s ∈ (@uniformity (α ⊕ β) _).sets ↔ ∃ ε > 0, ∀ a b, sum.dist a b < ε → (a, b) ∈ s :=
begin
  split,
  { rintro ⟨hsα, hsβ⟩,
    rcases mem_uniformity_dist.1 hsα with ⟨εα, εα0, hα⟩,
    rcases mem_uniformity_dist.1 hsβ with ⟨εβ, εβ0, hβ⟩,
    refine ⟨min (min εα εβ) 1, lt_min (lt_min εα0 εβ0) zero_lt_one, _⟩,
    rintro (a|a) (b|b) h,
    { exact hα (lt_of_lt_of_le h (le_trans (min_le_left _ _) (min_le_left _ _))) },
    { cases not_le_of_lt (lt_of_lt_of_le h (min_le_right _ _)) sum.one_dist_le },
    { cases not_le_of_lt (lt_of_lt_of_le h (min_le_right _ _)) sum.one_dist_le' },
    { exact hβ (lt_of_lt_of_le h (le_trans (min_le_left _ _) (min_le_right _ _))) } },
  { rintro ⟨ε, ε0, H⟩,
    split; rw [filter.mem_map, mem_uniformity_dist];
      exact ⟨ε, ε0, λ x y h, H _ _ (by exact h)⟩ }
end

/-- The distance on the disjoint union indeed defines a metric space. All the distance properties follow from our
choice of the distance. The harder work is to show that the uniform structure defined by the distance coincides
with the disjoint union uniform structure. -/
def metric_space_sum : metric_space (α ⊕ β) :=
{ dist               := sum.dist,
  dist_self          := λx, by cases x; simp only [sum.dist, dist_self],
  dist_comm          := sum.dist_comm,
  dist_triangle      := λp q r,
    by simp only [dist, sum.dist_eq_glue_dist]; exact glue_dist_triangle _ _ _ (by simp; norm_num) _ _ _,
  eq_of_dist_eq_zero := λp q,
    by simp only [dist, sum.dist_eq_glue_dist]; exact glue_eq_of_dist_eq_zero _ _ _ zero_lt_one _ _,
  to_uniform_space   := sum.uniform_space,
  uniformity_dist    := uniformity_dist_of_mem_uniformity _ _ sum.mem_uniformity }

local attribute [instance] metric_space_sum

lemma sum.dist_eq {x y : α ⊕ β} : dist x y = sum.dist x y := rfl

/-- The left injection of a space in a disjoint union in an isometry -/
lemma isometry_on_inl : isometry (sum.inl : α → (α ⊕ β)) :=
isometry_emetric_iff_metric.2 $ λx y, rfl

/-- The right injection of a space in a disjoint union in an isometry -/
lemma isometry_on_inr : isometry (sum.inr : β → (α ⊕ β)) :=
isometry_emetric_iff_metric.2 $ λx y, rfl

end sum

section gluing
/- Exact gluing of two metric spaces along isometric subsets. -/

variables [nonempty γ] [metric_space γ] [metric_space α] [metric_space β]
          {Φ : γ → α} {Ψ : γ → β} {ε : ℝ}
open sum (inl inr)
local attribute [instance] premetric.dist_setoid

def glue_premetric (hΦ : isometry Φ) (hΨ : isometry Ψ) : premetric_space (α ⊕ β) :=
{ dist          := glue_dist Φ Ψ 0,
  dist_self     := glue_dist_self Φ Ψ 0,
  dist_comm     := glue_dist_comm Φ Ψ 0,
  dist_triangle := glue_dist_triangle Φ Ψ 0 $ λp q, by rw [hΦ.dist_eq, hΨ.dist_eq]; simp }

def glue_space (hΦ : isometry Φ) (hΨ : isometry Ψ) : Type* :=
@metric_quot _ (glue_premetric hΦ hΨ)

instance metric_space_glue_space (hΦ : isometry Φ) (hΨ : isometry Ψ) :
  metric_space (glue_space hΦ hΨ) :=
@premetric.metric_space_quot _ (glue_premetric hΦ hΨ)

def to_glue_l (hΦ : isometry Φ) (hΨ : isometry Ψ) (x : α) : glue_space hΦ hΨ :=
by letI : premetric_space (α ⊕ β) := glue_premetric hΦ hΨ; exact ⟦inl x⟧

def to_glue_r (hΦ : isometry Φ) (hΨ : isometry Ψ) (y : β) : glue_space hΦ hΨ :=
by letI : premetric_space (α ⊕ β) := glue_premetric hΦ hΨ; exact ⟦inr y⟧

lemma to_glue_commute (hΦ : isometry Φ) (hΨ : isometry Ψ) :
  (to_glue_l hΦ hΨ) ∘ Φ = (to_glue_r hΦ hΨ) ∘ Ψ :=
begin
  letI : premetric_space (α ⊕ β) := glue_premetric hΦ hΨ,
  funext,
  simp only [comp, to_glue_l, to_glue_r, quotient.eq],
  exact glue_dist_glued_points Φ Ψ 0 x
end

lemma to_glue_l_isometry (hΦ : isometry Φ) (hΨ : isometry Ψ) : isometry (to_glue_l hΦ hΨ) :=
isometry_emetric_iff_metric.2 $ λ_ _, rfl

lemma to_glue_r_isometry (hΦ : isometry Φ) (hΨ : isometry Ψ) : isometry (to_glue_r hΦ hΨ) :=
isometry_emetric_iff_metric.2 $ λ_ _, rfl

end gluing --section
end metric --namespace


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

import linear_algebra.finite_dimensional
import linear_algebra.basic
import ring_theory.mv_polynomial.basic
import data.mv_polynomial.expand
import field_theory.finite.basic

/-!
## Polynomials over finite fields
-/

namespace mv_polynomial
variables {σ : Type*}

/-- A polynomial over the integers is divisible by `n : ℕ`
if and only if it is zero over `zmod n`. -/
lemma C_dvd_iff_zmod (n : ℕ) (φ : mv_polynomial σ ℤ) :
  C (n:ℤ) ∣ φ ↔ map (int.cast_ring_hom (zmod n)) φ = 0 :=
C_dvd_iff_map_hom_eq_zero _ _ (char_p.int_cast_eq_zero_iff (zmod n) n) _

section frobenius

variables {p : ℕ} [fact p.prime]

lemma frobenius_zmod (f : mv_polynomial σ (zmod p)) : frobenius _ p f = expand p f :=
begin
  apply induction_on f,
  { intro a, rw [expand_C, frobenius_def, ← C_pow, zmod.pow_card], },
  { simp only [alg_hom.map_add, ring_hom.map_add], intros _ _ hf hg, rw [hf, hg] },
  { simp only [expand_X, ring_hom.map_mul, alg_hom.map_mul],
    intros _ _ hf, rw [hf, frobenius_def], },
end

end frobenius

end mv_polynomial

namespace mv_polynomial

noncomputable theory
open_locale big_operators classical
open set linear_map submodule

variables {K : Type*} {σ : Type*}

section indicator

variables [fintype K] [fintype σ]

/-- Over a field, this is the indicator function as an `mv_polynomial`. -/
def indicator [comm_ring K] (a : σ → K) : mv_polynomial σ K :=
∏ n, (1 - (X n - C (a n)) ^ (fintype.card K - 1))

section comm_ring

variables [comm_ring K]

lemma eval_indicator_apply_eq_one (a : σ → K) :
  eval a (indicator a) = 1 :=
begin
  nontriviality,
  have : 0 < fintype.card K - 1 := tsub_pos_of_lt fintype.one_lt_card,
  simp only [indicator, map_prod, map_sub, map_one, map_pow, eval_X, eval_C,
             sub_self, zero_pow this, sub_zero, finset.prod_const_one]
end

lemma degrees_indicator (c : σ → K) :
  degrees (indicator c) ≤ ∑ s : σ, (fintype.card K - 1) • {s} :=
begin
  rw [indicator],
  refine le_trans (degrees_prod _ _) (finset.sum_le_sum $ assume s hs, _),
  refine le_trans (degrees_sub _ _) _,
  rw [degrees_one, ← bot_eq_zero, bot_sup_eq],
  refine le_trans (degrees_pow _ _) (nsmul_le_nsmul_of_le_right _ _),
  refine le_trans (degrees_sub _ _) _,
  rw [degrees_C, ← bot_eq_zero, sup_bot_eq],
  exact degrees_X' _
end

lemma indicator_mem_restrict_degree (c : σ → K) :
  indicator c ∈ restrict_degree σ K (fintype.card K - 1) :=
begin
  rw [mem_restrict_degree_iff_sup, indicator],
  assume n,
  refine le_trans (multiset.count_le_of_le _ $ degrees_indicator _) (le_of_eq _),
  simp_rw [ ← multiset.coe_count_add_monoid_hom, (multiset.count_add_monoid_hom n).map_sum,
    add_monoid_hom.map_nsmul, multiset.coe_count_add_monoid_hom, nsmul_eq_mul, nat.cast_id],
  transitivity,
  refine finset.sum_eq_single n _ _,
  { assume b hb ne, rw [multiset.count_singleton, if_neg ne.symm, mul_zero] },
  { assume h, exact (h $ finset.mem_univ _).elim },
  { rw [multiset.count_singleton_self, mul_one] }
end

end comm_ring

variables [field K]

lemma eval_indicator_apply_eq_zero (a b : σ → K) (h : a ≠ b) :
  eval a (indicator b) = 0 :=
begin
  obtain ⟨i, hi⟩ : ∃ i, a i ≠ b i := by rwa [(≠), function.funext_iff, not_forall] at h,
  simp only [indicator, map_prod, map_sub, map_one, map_pow, eval_X, eval_C,
             sub_self, finset.prod_eq_zero_iff],
  refine ⟨i, finset.mem_univ _, _⟩,
  rw [finite_field.pow_card_sub_one_eq_one, sub_self],
  rwa [(≠), sub_eq_zero],
end

end indicator

section
variables (K σ)

/-- `mv_polynomial.eval` as a `K`-linear map. -/
@[simps] def evalₗ [comm_semiring K] : mv_polynomial σ K →ₗ[K] (σ → K) → K :=
{ to_fun := λ p e, eval e p,
  map_add' := λ p q, by { ext x, rw ring_hom.map_add, refl, },
  map_smul' := λ a p, by { ext e, rw [smul_eq_C_mul, ring_hom.map_mul, eval_C], refl } }
end

variables [field K] [fintype K] [finite σ]

lemma map_restrict_dom_evalₗ : (restrict_degree σ K (fintype.card K - 1)).map (evalₗ K σ) = ⊤ :=
begin
  casesI nonempty_fintype σ,
  refine top_unique (set_like.le_def.2 $ assume e _, mem_map.2 _),
  refine ⟨∑ n : σ → K, e n • indicator n, _, _⟩,
  { exact sum_mem (assume c _, smul_mem _ _ (indicator_mem_restrict_degree _)) },
  { ext n,
    simp only [linear_map.map_sum, @finset.sum_apply (σ → K) (λ_, K) _ _ _ _ _,
      pi.smul_apply, linear_map.map_smul],
    simp only [evalₗ_apply],
    transitivity,
    refine finset.sum_eq_single n (λ b _ h, _) _,
    { rw [eval_indicator_apply_eq_zero _ _ h.symm, smul_zero] },
    { exact λ h, (h $ finset.mem_univ n).elim },
    { rw [eval_indicator_apply_eq_one, smul_eq_mul, mul_one] } }
end

end mv_polynomial

namespace mv_polynomial

open_locale classical cardinal
open linear_map submodule

universe u
variables (σ : Type u) (K : Type u) [fintype K]

/-- The submodule of multivariate polynomials whose degree of each variable is strictly less
than the cardinality of K. -/
@[derive [add_comm_group, module K, inhabited]]
def R [comm_ring K] : Type u := restrict_degree σ K (fintype.card K - 1)

/-- Evaluation in the `mv_polynomial.R` subtype. -/
def evalᵢ [comm_ring K] : R σ K →ₗ[K] (σ → K) → K :=
((evalₗ K σ).comp (restrict_degree σ K (fintype.card K - 1)).subtype)

section comm_ring

variables [comm_ring K]

noncomputable instance decidable_restrict_degree (m : ℕ) :
  decidable_pred (∈ {n : σ →₀ ℕ | ∀i, n i ≤ m }) :=
by simp only [set.mem_set_of_eq]; apply_instance

end comm_ring

variables [field K]

lemma dim_R [fintype σ] : module.rank K (R σ K) = fintype.card (σ → K) :=
calc module.rank K (R σ K) =
  module.rank K (↥{s : σ →₀ ℕ | ∀ (n : σ), s n ≤ fintype.card K - 1} →₀ K) :
    linear_equiv.dim_eq
      (finsupp.supported_equiv_finsupp {s : σ →₀ ℕ | ∀n:σ, s n ≤ fintype.card K - 1 })
  ... = #{s : σ →₀ ℕ | ∀ (n : σ), s n ≤ fintype.card K - 1} :
    by rw [finsupp.dim_eq, dim_self, mul_one]
  ... = #{s : σ → ℕ | ∀ (n : σ), s n < fintype.card K } :
  begin
    refine quotient.sound ⟨equiv.subtype_equiv finsupp.equiv_fun_on_finite $ assume f, _⟩,
    refine forall_congr (assume n, le_tsub_iff_right _),
    exact fintype.card_pos_iff.2 ⟨0⟩
  end
  ... = #(σ → {n // n < fintype.card K}) :
    (@equiv.subtype_pi_equiv_pi σ (λ_, ℕ) (λs n, n < fintype.card K)).cardinal_eq
  ... = #(σ → fin (fintype.card K)) :
    (equiv.arrow_congr (equiv.refl σ) fin.equiv_subtype.symm).cardinal_eq
  ... = #(σ → K) :
    (equiv.arrow_congr (equiv.refl σ) (fintype.equiv_fin K).symm).cardinal_eq
  ... = fintype.card (σ → K) : cardinal.mk_fintype _

instance [finite σ] : finite_dimensional K (R σ K) :=
by { casesI nonempty_fintype σ, exact is_noetherian.iff_fg.1 (is_noetherian.iff_dim_lt_aleph_0.mpr $
  by simpa only [dim_R] using cardinal.nat_lt_aleph_0 (fintype.card (σ → K))) }

lemma finrank_R [fintype σ] : finite_dimensional.finrank K (R σ K) = fintype.card (σ → K) :=
finite_dimensional.finrank_eq_of_dim_eq (dim_R σ K)

lemma range_evalᵢ [finite σ] : (evalᵢ σ K).range = ⊤ :=
begin
  rw [evalᵢ, linear_map.range_comp, range_subtype],
  exact map_restrict_dom_evalₗ
end

lemma ker_evalₗ [finite σ] : (evalᵢ σ K).ker = ⊥ :=
begin
  casesI nonempty_fintype σ,
  refine (ker_eq_bot_iff_range_eq_top_of_finrank_eq_finrank _).mpr (range_evalᵢ _ _),
  rw [finite_dimensional.finrank_fintype_fun_eq_card, finrank_R]
end

lemma eq_zero_of_eval_eq_zero  [finite σ] (p : mv_polynomial σ K)
  (h : ∀v:σ → K, eval v p = 0) (hp : p ∈ restrict_degree σ K (fintype.card K - 1)) :
  p = 0 :=
let p' : R σ K := ⟨p, hp⟩ in
have p' ∈ (evalᵢ σ K).ker := funext h,
show p'.1 = (0 : R σ K).1, from congr_arg _ $ by rwa [ker_evalₗ, mem_bot] at this

end mv_polynomial


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebraic_geometry.Spec

/-!
# The category of schemes

A scheme is a locally ringed space such that every point is contained in some open set
where there is an isomorphism of presheaves between the restriction to that open set,
and the structure sheaf of `Spec R`, for some commutative ring `R`.

A morphism of schemes is just a morphism of the underlying locally ringed spaces.

-/

open topological_space
open category_theory
open Top
open opposite

namespace algebraic_geometry

/--
We define `Scheme` as a `X : LocallyRingedSpace`,
along with a proof that every point has an open neighbourhood `U`
so that that the restriction of `X` to `U` is isomorphic,
as a space with a presheaf of commutative rings,
to `Spec.PresheafedSpace R` for some `R : CommRing`.

(Note we're not asking in the definition that this is an isomorphism as locally ringed spaces,
although that is a consequence.)
-/
structure Scheme extends X : LocallyRingedSpace :=
(local_affine : ∀ x : X, ∃ (U : open_nhds x) (R : CommRing),
  nonempty (X.to_PresheafedSpace.restrict _ U.open_embedding ≅ Spec.PresheafedSpace R))

-- PROJECT
-- In fact, we can make the isomorphism `i` above an isomorphism in `LocallyRingedSpace`.
-- However this is a consequence of the above definition, and not necessary for defining schemes.
-- We haven't done this yet because we haven't shown that you can restrict a `LocallyRingedSpace`
-- along an open embedding.
-- We can do this already for `SheafedSpace` (as above), but we need to know that
-- the stalks of the restriction are still local rings, which we follow if we knew that
-- the stalks didn't change.
-- This will follow if we define cofinal functors, and show precomposing with a cofinal functor
-- doesn't change colimits, because open neighbourhoods of `x` within `U` are cofinal in
-- all open neighbourhoods of `x`.

namespace Scheme

/--
Every `Scheme` is a `LocallyRingedSpace`.
-/
-- (This parent projection is apparently not automatically generated because
-- we used the `extends X : LocallyRingedSpace` syntax.)
def to_LocallyRingedSpace (S : Scheme) : LocallyRingedSpace := { ..S }

/--
`Spec R` as a `Scheme`.
-/
noncomputable
def Spec (R : CommRing) : Scheme :=
{ local_affine := λ x, ⟨⟨⊤, trivial⟩, R, ⟨(Spec.PresheafedSpace R).restrict_top_iso⟩⟩,
  .. Spec.LocallyRingedSpace R }

/--
The empty scheme, as `Spec 0`.
-/
noncomputable
def empty : Scheme :=
Spec (CommRing.of punit)

noncomputable
instance : has_emptyc Scheme := ⟨empty⟩

noncomputable
instance : inhabited Scheme := ⟨∅⟩

/--
Schemes are a full subcategory of locally ringed spaces.
-/
instance : category Scheme :=
induced_category.category Scheme.to_LocallyRingedSpace

/--
The global sections, notated Gamma.
-/
def Γ : Schemeᵒᵖ ⥤ CommRing :=
(induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ

lemma Γ_def : Γ = (induced_functor Scheme.to_LocallyRingedSpace).op ⋙ LocallyRingedSpace.Γ := rfl

@[simp] lemma Γ_obj (X : Schemeᵒᵖ) : Γ.obj X = (unop X).presheaf.obj (op ⊤) := rfl

lemma Γ_obj_op (X : Scheme) : Γ.obj (op X) = X.presheaf.obj (op ⊤) := rfl

@[simp] lemma Γ_map {X Y : Schemeᵒᵖ} (f : X ⟶ Y) :
  Γ.map f = f.unop.1.c.app (op ⊤) ≫ (unop Y).presheaf.map (opens.le_map_top _ _).op := rfl

lemma Γ_map_op {X Y : Scheme} (f : X ⟶ Y) :
  Γ.map f.op = f.1.c.app (op ⊤) ≫ X.presheaf.map (opens.le_map_top _ _).op := rfl

-- PROJECTS:
-- 1. Make `Spec` a functor.
-- 2. Construct `Spec ≫ Γ ≅ functor.id _`.
-- 3. Adjunction between `Γ` and `Spec`.
--

end Scheme

end algebraic_geometry


import number_theory.legendre_symbol.quadratic_char

/-! # IMO 2007 N2, Extra Version -/

namespace IMOSL
namespace IMO2007N2

variables {F : Type*} [field F] [fintype F]

private lemma not_is_square_ne_zero {a : F} (h : ¬is_square a) : a ≠ 0 :=
  by rintros rfl; exact h (is_square_zero F)

private lemma is_square_or_mul [decidable_eq F] (a b : F) :
  is_square a ∨ is_square b ∨ is_square (a * b) :=
begin
  rw [or_iff_not_imp_left, or_iff_not_imp_left]; intros h h0,
  have h1 : a * b ≠ 0 := mul_ne_zero (not_is_square_ne_zero h) (not_is_square_ne_zero h0),
  rw ← quadratic_char_neg_one_iff_not_is_square at h h0,
  rw [← quadratic_char_one_iff_is_square h1, map_mul, h0, h, neg_mul_neg, mul_one]
end

/-- Final solution, part 2 -/
theorem final_solution_part2 [decidable_eq F] : ∃ a : F, a ^ 8 = 16 :=
begin
  ---- Reduce to finding a square `c : F` such that `c ^ 4 = 16`
  suffices : ∃ a : F, is_square a ∧ a ^ 4 = 2 ^ 4,
  { rcases this with ⟨_, ⟨c, rfl⟩, h⟩,
    refine ⟨c, _⟩,
    rw [bit0, ← two_mul, pow_mul, sq, h],
    norm_num },

  ---- If `2` or `-2` is a square mod `p`, we are easily done
  rcases (is_square_or_mul (-1 : F) (2 : F)).symm with (h | h) | ⟨i, h⟩,
  exact ⟨2, h, rfl⟩,
  exact ⟨(-1) * 2, h, by rw [neg_one_mul, neg_pow_bit0]⟩,

  -- The case where `-1` is a square mod `p` remains
  rw ← sq at h; refine ⟨2 * i, ⟨1 + i, _⟩, _⟩,
  rw [← sq, add_sq', one_pow, ← h, add_neg_self, zero_add, mul_one],
  rw [mul_comm, mul_pow]; change i ^ (2 * 2) * 2 ^ 4 = 2 ^ 4,
  rw [pow_mul, ← h, neg_one_sq, one_mul]
end

end IMO2007N2
end IMOSL