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

import .limits.shapes.products basic data.dvector
       .limits.shapes.equalizers
       category_theory.limits.limits

universes v u

open category_theory

namespace category_theory.limits

@[derive decidable_eq] inductive two : Type u
| left | right

def two.map {C : Sort*} (X Y : C) : two → C
| two.left := X
| two.right := Y

def two.functor {C : Sort u} (X Y : C) [category.{v+1} C] : discrete two ⥤ C :=
functor.of_function (two.map X Y)

def empty.functor (C : Sort*) [category.{v+1} C] : discrete pempty ⥤ C :=
functor.of_function (λ x, by {cases x} : pempty → C)

def empty_cone {C : Sort u} [category.{v+1} C] (A : C) : limits.cone (empty.functor C) :=
{ X := A,
  π := { app := λ x, by cases x,
  naturality' := by tidy}}

def commutative_square {C : Sort u} [category.{v u} C] {A B A' B' : C}
  (f_top : A ⟶ B) (d_left : A ⟶ A') (d_right : B ⟶ B') (f_bot : A' ⟶ B') :=
f_top ≫ d_right = d_left ≫ f_bot

variables {C : Type u} [𝒞 : category.{v+1} C]
include 𝒞

variable(C)
@[class] def has_binary_products := has_limits_of_shape (discrete two.{v}) C
@[class] def has_terminal_object : Sort* := has_limits_of_shape.{v} (discrete pempty) C

@[class] def has_binary_coproducts := has_colimits_of_shape (discrete two.{v}) C
@[class] def has_initial_object : Sort* := has_colimits_of_shape.{v} (discrete pempty) C

@[instance] def has_limit_two_of_has_binary_products [H : has_binary_products C] {X Y : C} :
  has_limit $ two.functor X Y :=
@has_limits_of_shape.has_limit _ _ _ _ H (two.functor X Y)

@[instance] def has_limit_empty_of_has_terminal_object [H : has_terminal_object C] :
  has_limit $ empty.functor C :=
@has_limits_of_shape.has_limit _ _ _ _ H (empty.functor C)

variable{C}

def has_terminal_object.mk (T : C) (h₁ : ∀(X : C), X ⟶ T)
  (h₂ : ∀{{X : C}} (f g : X ⟶ T), f = g) : has_terminal_object C :=
⟨λ F, { cone := ⟨T, ⟨pempty.rec _, pempty.rec _⟩⟩,
  is_limit :=
  { lift := λ s, h₁ s.X,
    fac' := λ s, pempty.rec _,
    uniq' := λ s m h, h₂ _ _ } }⟩

def has_binary_products.mk (m : C → C → C) (p1 : ∀{X Y : C}, m X Y ⟶ X)
  (p2 : ∀{X Y : C}, m X Y ⟶ Y) (lft : ∀{{X Y Z : C}} (f : Z ⟶ X) (g : Z ⟶ Y), Z ⟶ m X Y)
  (lft1 : ∀{{X Y Z : C}} (f : Z ⟶ X) (g : Z ⟶ Y), lft f g ≫ p1 = f)
  (lft2 : ∀{{X Y Z : C}} (f : Z ⟶ X) (g : Z ⟶ Y), lft f g ≫ p2 = g)
  (lft_unique : ∀{{X Y Z : C}} (f g : Z ⟶ m X Y) (h1 : f ≫ p1 = g ≫ p1) (h2 : f ≫ p2 = g ≫ p2),
    f = g) : has_binary_products C :=
begin
  constructor, intro F, fsplit,
  { use m (F.obj two.left) (F.obj two.right),
    apply nat_trans.of_homs, refine two.rec _ _, exact p1, exact p2 },
  refine limits.is_limit.mk _ _ _,
  { rintro ⟨X, f⟩, apply lft (f.app two.left), dsimp, exact f.app two.right },
  { rintro ⟨X, f⟩ (_|_), apply lft1, apply lft2 },
  { rintro ⟨X, f⟩ g h, dsimp, apply lft_unique,
    rw [lft1], exact h two.left, rw [lft2], exact h two.right }
end

def has_initial_object.mk (I : C) (h₁ : ∀(X : C), I ⟶ X)
  (h₂ : ∀{{X : C}} (f g : I ⟶ X), f = g) : has_initial_object C :=
⟨λ F, { cocone := ⟨I, ⟨pempty.rec _, pempty.rec _⟩⟩,
  is_colimit :=
  { desc := λ s, h₁ s.X,
    fac' := λ s, pempty.rec _,
    uniq' := λ s m h, h₂ _ _ } }⟩

def has_binary_coproducts.mk (p : C → C → C) (i1 : ∀{X Y : C}, X ⟶ p X Y)
  (i2 : ∀{X Y : C}, Y ⟶ p X Y) (dsc : ∀{{X Y Z : C}} (f : X ⟶ Z) (g : Y ⟶ Z), p X Y ⟶ Z)
  (dsc1 : ∀{{X Y Z : C}} (f : X ⟶ Z) (g : Y ⟶ Z), i1 ≫ dsc f g = f)
  (dsc2 : ∀{{X Y Z : C}} (f : X ⟶ Z) (g : Y ⟶ Z), i2 ≫ dsc f g = g)
  (dsc_unique : ∀{{X Y Z : C}} (f g : p X Y ⟶ Z) (h1 : i1 ≫ f = i1 ≫ g) (h2 : i2 ≫ f = i2 ≫ g),
    f = g) : has_binary_coproducts C :=
begin
  constructor, intro F, fsplit,
  { use p (F.obj two.left) (F.obj two.right),
    apply nat_trans.of_homs, refine two.rec _ _, exact i1, exact i2 },
  refine limits.is_colimit.mk _ _ _,
  { rintro ⟨X, f⟩, apply dsc (f.app two.left), dsimp, exact f.app two.right },
  { rintro ⟨X, f⟩ (_|_), apply dsc1, apply dsc2 },
  { rintro ⟨X, f⟩ g h, dsimp, apply dsc_unique,
    rw [dsc1], exact h two.left, rw [dsc2], exact h two.right }
end

/-- The binary product is the vertex of the limiting cone to the canonical functor two → 𝒞
    associated to X and Y -/
def binary_product (X Y : C) [has_limit $ two.functor X Y] : C :=
limit (two.functor X Y)

namespace binary_product

local infix ` × `:60 := binary_product

def π₁ {X Y : C} [has_limit $ two.functor X Y] : X × Y ⟶ X := limit.π _ two.left

def π₂ {X Y : C} [has_limit $ two.functor X Y] : X × Y ⟶ Y := limit.π _ two.right

/-- An alternative version of `π₁` if type-class inference fails -/
def π₁' {X Y : C} {H : has_binary_products C} : X × Y ⟶ X := π₁
/-- An alternative version of `π₂` if type-class inference fails -/
def π₂' {X Y : C} {H : has_binary_products C} : X × Y ⟶ Y := π₂

def dfin.map {n : ℕ} : dvector C n → dfin n → C :=
λ v d, by {induction v, cases d, cases d, exact v_x, exact v_ih d_a}

example {X : C} [has_binary_products C] : X × X × X = (X × X) × X := by refl

def cone_of_two_maps {W A₁ A₂: C} (f₁ : W ⟶ A₁) (f₂ : W ⟶ A₂) : cone (two.functor A₁ A₂) :=
{ X := W,
  π := { app := λ l, two.rec_on l f₁ f₂,
  naturality' := by tidy}}

lemma cone_of_two_maps_object [has_binary_products C] {B₁ B₂ A₁ A₂: C} {f₁ : B₁ × B₂ ⟶ A₁}
  {f₂ : B₁ × B₂ ⟶ A₂} : (cone_of_two_maps f₁ f₂).X = B₁ × B₂ := by refl

def map_to_product.mk {H : has_binary_products C} {W B₁ B₂ : C} (f₁ : W ⟶ B₁) (f₂ : W ⟶ B₂) :
  W ⟶ B₁ × B₂ :=
is_limit.lift (limit.is_limit _) (cone_of_two_maps f₁ f₂)

def diag [H : has_binary_products C] {B : C} : B ⟶ B × B :=
map_to_product.mk (𝟙 B) (𝟙 B)

protected def map {H : has_binary_products C} {A A' B B' : C} (f : A ⟶ A') (g : B ⟶ B') :
  A × B ⟶ A' × B' :=
map_to_product.mk (π₁ ≫ f) (π₂ ≫ g)

local infix ` ×.map `:90 := binary_product.map

protected def iso {H : has_binary_products C} {A A' B B' : C} (f : A ≅ A') (g : B ≅ B') :
  A × B ≅ A' × B' :=
{ hom := f.hom ×.map g.hom,
  inv := f.inv ×.map g.inv,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted }

local infix ` ×.iso `:90 := binary_product.iso

def assoc_hom {H : has_binary_products C} {X Y Z : C} : (X × Y) × Z ⟶ X × (Y × Z) :=
by apply map_to_product.mk (π₁ ≫ π₁) (π₂ ×.map (𝟙 Z))

def assoc_inv {H : has_binary_products C} {X Y Z : C} : X × (Y × Z) ⟶ (X × Y) × Z :=
by apply map_to_product.mk (𝟙 X ×.map π₁) (π₂ ≫ π₂)

def product_assoc {H : has_binary_products C} {X Y Z : C} : (X × Y) × Z ≅ X × (Y × Z) :=
{ hom := assoc_hom,
  inv := assoc_inv,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted}

def product_comm {H : has_binary_products C} {X Y : C} : X × Y ≅ Y × X :=
{ hom := map_to_product.mk π₂ π₁,
  inv := map_to_product.mk π₂ π₁,
  hom_inv_id' := omitted,
  inv_hom_id' := omitted}

def product_assoc4 {H : has_binary_products C} {X Y Z W : C} :
  (X × Y) × (Z × W) ≅ (X × Z) × (Y × W) :=
product_assoc ≪≫
iso.refl X ×.iso (product_assoc.symm ≪≫ product_comm ×.iso iso.refl W ≪≫ product_assoc) ≪≫
product_assoc.symm

example :
  commutative_square
         /-unit-/ (𝟙 unit) /- unit  -/
         (𝟙 unit)            (𝟙 unit)
         /-unit-/ (𝟙 unit) /- unit -/
  := by tidy

end binary_product
open binary_product

section terminal_object

local infix ` × `:60 := binary_product

def terminal_object [has_terminal_object C] : C :=
limit (empty.functor C)

notation `term` := terminal_object

def terminal_map [has_terminal_object C] (A : C) : A ⟶ term :=
is_limit.lift (limit.is_limit (empty.functor C)) (empty_cone A)

lemma terminal_map_eq [has_terminal_object C] {A : C} (f g : A ⟶ term) : f = g :=
omitted

lemma mul_one [has_terminal_object C] [has_binary_products C] (G : C) :
  nonempty $ term × G ≅ G := omitted

lemma one_mul [has_terminal_object C] [has_binary_products C] (G : C) :
  nonempty $ G × term ≅ G := omitted

def mul_one_inv [has_terminal_object C] [has_binary_products C] {G : C} : G ⟶ G × term :=
by apply map_to_product.mk (𝟙 _) (terminal_map G)

def one_mul_inv [has_terminal_object C] [has_binary_products C] {G : C} : G ⟶ term × G :=
by apply map_to_product.mk (terminal_map G) (𝟙 _)

end terminal_object

section pow

local infix ` × `:60 := binary_product

/-- The n-fold product of an object with itself -/
def category.pow [has_binary_products C] [has_terminal_object C] (X : C) : ℕ → C
| 0     := term
| 1     := X
| (n+2) := X × category.pow (n+1)

end pow

namespace finite_limits
open binary_product

instance fintype_two : fintype two :=
{elems := { val := ⟦[two.left, two.right]⟧,
  nodup := by tidy },
  complete := λ x, by cases x; tidy}

example : fintype pempty := by apply_instance

section finite_products

variable (C)
@[class]def has_finite_products := Π α : Type*, fintype α → has_limits_of_shape.{v} (discrete α) C

@[class]def has_equalizers := has_limits_of_shape.{v} (walking_pair) C

@[instance] def has_binary_products_of_has_finite_products [H : has_finite_products C] :
  has_binary_products C := H _ infer_instance

@[instance] def has_terminal_object_of_has_finite_products [H : has_finite_products C] :
  has_limits_of_shape.{v} (discrete pempty) C := H _ infer_instance

@[class]def has_finite_limits := @has_finite_products C 𝒞 × @has_equalizers C 𝒞

end finite_products

end finite_limits

end category_theory.limits


import topology.category.Top.limits
import category_theory.limits.shapes
import topology.instances.real

/- This file contains some demos of using the (co)limits API to do topology. -/

noncomputable theory

open category_theory
open category_theory.limits

def R : Top := Top.of ℝ
def I : Top := Top.of (set.Icc 0 1 : set ℝ)
def pt : Top := Top.of unit

section MappingCylinder
-- Let's construct the mapping cylinder.
def to_pt (X : Top) : X ⟶ pt :=
{ val := λ _, unit.star, property := continuous_const }
def I₀ : pt ⟶ I :=
{ val := λ _, ⟨(0 : ℝ), begin rw [set.left_mem_Icc], norm_num, end⟩,
  property := continuous_const }
def I₁ : pt ⟶ I :=
{ val := λ _, ⟨(1 : ℝ), begin rw [set.right_mem_Icc], norm_num, end⟩,
  property := continuous_const }

def cylinder (X : Top) : Top := prod X I
-- To define a map to the cylinder, we give a map to each factor.
-- `prod.lift` is a helper method, providing a wrapper around `limit.lift` for binary products.
def cylinder₀ (X : Top) : X ⟶ cylinder X :=
prod.lift (𝟙 X) (to_pt X ≫ I₀)
def cylinder₁ (X : Top) : X ⟶ cylinder X :=
prod.lift (𝟙 X) (to_pt X ≫ I₁)

-- The mapping cylinder is the pushout of the diagram
--    X
--   ↙ ↘
--  Y   (X x I)
-- (`pushout` is implemented just as a wrapper around `colimit`) is
def mapping_cylinder {X Y : Top} (f : X ⟶ Y) : Top := pushout f (cylinder₁ X)

/-- We construct the map from `X` into the "bottom" of the mapping cylinder
for `f : X ⟶ Y`, as the composition of the inclusion of `X` into the bottom of the
cylinder `prod X I`, followed by the map `pushout.inr` of `prod X I` into `mapping_cylinder f`. -/
def mapping_cylinder₀ {X Y : Top} (f : X ⟶ Y) : X ⟶ mapping_cylinder f :=
cylinder₀ X ≫ pushout.inr

/--
The mapping cone is defined as the pushout of
```
         X
        ↙ ↘
 (Cyl f)   pt
```
(where the left arrow is `mapping_cylinder₀`).
This makes it an iterated colimit; one could also define it in one step as the colimit of
```
--    X        X
--   ↙ ↘      ↙ ↘
--  Y   (X x I)  pt
```
-/
def mapping_cone {X Y : Top} (f : X ⟶ Y) : Top := pushout (mapping_cylinder₀ f) (to_pt X)

-- TODO Hopefully someone will write a nice tactic for generating diagrams quickly,
-- and we'll be able to verify that this iterated construction is the same as the colimit
-- over a single diagram.
end MappingCylinder

section Gluing

-- Here's two copies of the real line glued together at a point.
def f : pt ⟶ R := { val := λ _, (0 : ℝ), property := continuous_const }

/-- Two copies of the real line glued together at 0. -/
def X : Top := pushout f f

-- To define a map out of it, we define maps out of each copy of the line,
-- and check the maps agree at 0.
def g : X ⟶ R :=
pushout.desc (𝟙 _) (𝟙 _) rfl

end Gluing

universes v u w

section Products

/-- The countably infinite product of copies of `ℝ`. -/
def Y : Top := ∏ (λ n : ℕ, R)

/-- We define a point of this infinite product by specifying its coordinates. -/
def q : pt ⟶ Y :=
pi.lift (λ (n : ℕ), ⟨λ (_ : pt), (n : ℝ), continuous_const⟩)

-- "Looking under the hood", we see that `q` is a `subtype`, whose `val` is a function `unit → Y.α`.
-- #check q.val -- q.val : pt.α → Y.α
-- `q.property` is the fact this function is continous (i.e. no content)

-- We can check that this function is definitionally just the function we specified.
example : (q.val ()).val (57 : ℕ) = ((57 : ℕ) : ℝ) := rfl

end Products


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.basic
import Mathlib.PostPort

universes u_1 u_2 u_4 u_5 u_3

namespace Mathlib

/-!
# Renaming variables of polynomials

This file establishes the `rename` operation on multivariate polynomials,
which modifies the set of variables.

## Main declarations

* `mv_polynomial.rename`

## Notation

As in other polynomial files, we typically use the notation:

+ `σ τ α : Type*` (indexing the variables)

+ `R S : Type*` `[comm_semiring R]` `[comm_semiring S]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `mv_polynomial σ R` which mathematicians might call `X^s`

+ `r : R` elements of the coefficient ring

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : mv_polynomial σ α`

-/

namespace mv_polynomial

/-- Rename all the variables in a multivariable polynomial. -/
def rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) : alg_hom R (mv_polynomial σ R) (mv_polynomial τ R) :=
  aeval (X ∘ f)

@[simp] theorem rename_C {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (r : R) : coe_fn (rename f) (coe_fn C r) = coe_fn C r :=
  eval₂_C (algebra_map R (mv_polynomial τ R)) (fun (n : σ) => function.comp X f n) r

@[simp] theorem rename_X {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (i : σ) : coe_fn (rename f) (X i) = X (f i) :=
  eval₂_X (algebra_map R (mv_polynomial τ R)) (fun (n : σ) => function.comp X f n) i

theorem map_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (g : σ → τ) (p : mv_polynomial σ R) : coe_fn (map f) (coe_fn (rename g) p) = coe_fn (rename g) (coe_fn (map f) p) := sorry

@[simp] theorem rename_rename {σ : Type u_1} {τ : Type u_2} {α : Type u_3} {R : Type u_4} [comm_semiring R] (f : σ → τ) (g : τ → α) (p : mv_polynomial σ R) : coe_fn (rename g) (coe_fn (rename f) p) = coe_fn (rename (g ∘ f)) p := sorry

@[simp] theorem rename_id {σ : Type u_1} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) : coe_fn (rename id) p = p :=
  eval₂_eta p

theorem rename_monomial {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (d : σ →₀ ℕ) (r : R) : coe_fn (rename f) (monomial d r) = monomial (finsupp.map_domain f d) r := sorry

theorem rename_eq {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (p : mv_polynomial σ R) : coe_fn (rename f) p = finsupp.map_domain (finsupp.map_domain f) p := sorry

theorem rename_injective {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (hf : function.injective f) : function.injective ⇑(rename f) := sorry

theorem eval₂_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (k : σ → τ) (g : τ → S) (p : mv_polynomial σ R) : eval₂ f g (coe_fn (rename k) p) = eval₂ f (g ∘ k) p := sorry

theorem eval₂_hom_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (k : σ → τ) (g : τ → S) (p : mv_polynomial σ R) : coe_fn (eval₂_hom f g) (coe_fn (rename k) p) = coe_fn (eval₂_hom f (g ∘ k)) p :=
  eval₂_rename f k (fun (n : τ) => g n) p

theorem aeval_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (k : σ → τ) (g : τ → S) (p : mv_polynomial σ R) [algebra R S] : coe_fn (aeval g) (coe_fn (rename k) p) = coe_fn (aeval (g ∘ k)) p :=
  eval₂_hom_rename (algebra_map R S) k (fun (n : τ) => g n) p

theorem rename_eval₂ {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (k : σ → τ) (p : mv_polynomial σ R) (g : τ → mv_polynomial σ R) : coe_fn (rename k) (eval₂ C (g ∘ k) p) = eval₂ C (⇑(rename k) ∘ g) (coe_fn (rename k) p) := sorry

theorem rename_prodmk_eval₂ {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) (j : τ) (g : σ → mv_polynomial σ R) : coe_fn (rename (Prod.mk j)) (eval₂ C g p) = eval₂ C (fun (x : σ) => coe_fn (rename (Prod.mk j)) (g x)) p := sorry

theorem eval₂_rename_prodmk {σ : Type u_1} {τ : Type u_2} {R : Type u_4} {S : Type u_5} [comm_semiring R] [comm_semiring S] (f : R →+* S) (g : σ × τ → S) (i : σ) (p : mv_polynomial τ R) : eval₂ f g (coe_fn (rename (Prod.mk i)) p) = eval₂ f (fun (j : τ) => g (i, j)) p := sorry

theorem eval_rename_prodmk {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (g : σ × τ → R) (i : σ) (p : mv_polynomial τ R) : coe_fn (eval g) (coe_fn (rename (Prod.mk i)) p) = coe_fn (eval fun (j : τ) => g (i, j)) p :=
  eval₂_rename_prodmk (ring_hom.id R) (fun (n : σ × τ) => g n) i p

/-- Every polynomial is a polynomial in finitely many variables. -/
theorem exists_finset_rename {σ : Type u_1} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) : ∃ (s : finset σ), ∃ (q : mv_polynomial (Subtype fun (x : σ) => x ∈ s) R), p = coe_fn (rename coe) q := sorry

/-- Every polynomial is a polynomial in finitely many variables. -/
theorem exists_fin_rename {σ : Type u_1} {R : Type u_4} [comm_semiring R] (p : mv_polynomial σ R) : ∃ (n : ℕ), ∃ (f : fin n → σ), ∃ (hf : function.injective f), ∃ (q : mv_polynomial (fin n) R), p = coe_fn (rename f) q := sorry

theorem eval₂_cast_comp {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (c : ℤ →+* R) (g : τ → R) (p : mv_polynomial σ ℤ) : eval₂ c (g ∘ f) p = eval₂ c g (coe_fn (rename f) p) := sorry

@[simp] theorem coeff_rename_map_domain {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (hf : function.injective f) (φ : mv_polynomial σ R) (d : σ →₀ ℕ) : coeff (finsupp.map_domain f d) (coe_fn (rename f) φ) = coeff d φ := sorry

theorem coeff_rename_eq_zero {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (φ : mv_polynomial σ R) (d : τ →₀ ℕ) (h : ∀ (u : σ →₀ ℕ), finsupp.map_domain f u = d → coeff u φ = 0) : coeff d (coe_fn (rename f) φ) = 0 := sorry

theorem coeff_rename_ne_zero {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ) (φ : mv_polynomial σ R) (d : τ →₀ ℕ) (h : coeff d (coe_fn (rename f) φ) ≠ 0) : ∃ (u : σ →₀ ℕ), finsupp.map_domain f u = d ∧ coeff u φ ≠ 0 := sorry

@[simp] theorem constant_coeff_rename {σ : Type u_1} {R : Type u_4} [comm_semiring R] {τ : Type u_2} (f : σ → τ) (φ : mv_polynomial σ R) : coe_fn constant_coeff (coe_fn (rename f) φ) = coe_fn constant_coeff φ := sorry


import data.real.nnreal

open_locale nnreal

namespace nnreal

variables (r r' k c c₁ c₂ c₃ : ℝ≥0)

instance fact_le_of_lt [h : fact (c₁ < c₂)] : fact (c₁ ≤ c₂) := ⟨h.1.le⟩

instance fact_pos_of_one_le [hk : fact (1 ≤ c)] : fact (0 < c) :=
⟨lt_of_lt_of_le zero_lt_one hk.1⟩

instance fact_mul_pos [h1 : fact (0 < c₁)] [h2 : fact (0 < c₂)] : fact (0 < c₁ * c₂) :=
⟨mul_pos h1.out h2.out⟩

instance fact_le_mul_of_one_le_left [hk : fact (1 ≤ k)] [hc : fact (c₁ ≤ c₂)] :
  fact (c₁ ≤ k * c₂) :=
⟨calc c₁ = 1 * c₁ : (one_mul _).symm ... ≤ k * c₂ : mul_le_mul' hk.1 hc.1⟩

instance fact_le_mul_of_one_le_right [hc : fact (c₁ ≤ c₂)] [hk : fact (1 ≤ k)] :
  fact (c₁ ≤ c₂ * k) :=
⟨calc c₁ = c₁ * 1 : (mul_one _).symm ... ≤ c₂ * k : mul_le_mul' hc.1 hk.1⟩

instance fact_mul_le_of_le_one_left [hk : fact (k ≤ 1)] [hc : fact (c₁ ≤ c₂)] :
  fact (k * c₁ ≤ c₂) :=
⟨calc k * c₁ ≤ 1 * c₂ : mul_le_mul' hk.1 hc.1 ... = c₂     : one_mul _⟩

instance fact_mul_le_of_le_one_right [hk : fact (k ≤ 1)] [hc : fact (c₁ ≤ c₂)] :
  fact (c₁ * k ≤ c₂) :=
⟨calc c₁ * k ≤ c₂ * 1 : mul_le_mul' hc.1 hk.1 ... = c₂ : mul_one _⟩

instance fact_one_le_add_one : fact (1 ≤ k + 1) :=
⟨self_le_add_left 1 k⟩

instance fact_le_refl : fact (c ≤ c) := ⟨le_rfl⟩

instance fact_le_subst_right [fact (c₁ ≤ c₂)] [h : fact (c₂ = c₃)]: fact (c₁ ≤ c₃) :=
by rwa ← h.1

instance fact_le_subst_right' [fact (c₁ ≤ c₂)] [h : fact (c₃ = c₂)]: fact (c₁ ≤ c₃) :=
by rwa ← h.1.symm

instance fact_le_subst_left [fact (c₁ ≤ c₂)] [h : fact (c₁ = c₃)]: fact (c₃ ≤ c₂) :=
by rwa ← h.1

instance fact_le_subst_left' [fact (c₁ ≤ c₂)] [h : fact (c₃ = c₁)]: fact (c₃ ≤ c₂) :=
by rwa ← h.1.symm

instance fact_inv_mul_le [h : fact (0 < r')] : fact (r'⁻¹ * (r' * c) ≤ c) :=
⟨le_of_eq $ inv_mul_cancel_left₀ (ne_of_gt h.1) _⟩

instance fact_mul_le_mul_left [h : fact (c₁ ≤ c₂)] : fact (r' * c₁ ≤ r' * c₂) :=
⟨mul_le_mul' le_rfl h.1⟩

instance fact_mul_le_mul_right [h : fact (c₁ ≤ c₂)] : fact (c₁ * r' ≤ c₂ * r') :=
⟨mul_le_mul' h.1 le_rfl⟩

instance fact_le_inv_mul_self [h1 : fact (0 < r')] [h2 : fact (r' ≤ 1)] : fact (c ≤ r'⁻¹ * c) :=
begin
  constructor,
  rw mul_comm,
  apply le_mul_inv_of_mul_le (ne_of_gt h1.1),
  nth_rewrite 1 ← mul_one c,
  exact mul_le_mul (le_of_eq rfl) h2.1 (le_of_lt h1.1) zero_le',
end

instance fact_le_max_left (a b c : ℝ≥0) [h : fact (a ≤ b)] : fact (a ≤ max b c) :=
⟨h.1.trans $ le_max_left _ _⟩

instance fact_one_le_mul_self (a : ℝ≥0) [h : fact (1 ≤ a)] : fact (1 ≤ a * a) :=
⟨calc (1 : ℝ≥0) = 1 * 1 : (mul_one 1).symm
           ... ≤ a * a : mul_le_mul' h.1 h.1⟩

instance one_le_add {a b : ℝ≥0} [ha : fact (1 ≤ a)] : fact (1 ≤ a + b) :=
⟨le_trans ha.1 $ by simp⟩
instance one_le_add' {a b : ℝ≥0} [hb : fact (1 ≤ b)] : fact (1 ≤ a + b) :=
⟨le_trans hb.1 $ by simp⟩

instance fact_one_le_pow {n : ℕ} {a : ℝ≥0} [h : fact (1 ≤ a)] : fact (1 ≤ a^n) :=
begin
  cases n,
  { simpa only [pow_zero] using nnreal.fact_le_refl _ },
  { rwa @one_le_pow_iff _ _ _ nnreal.covariant_mul, apply nat.succ_ne_zero }
end

instance fact_pow_le_one {n : ℕ} {a : ℝ≥0} [h : fact (a ≤ 1)] : fact (a^n ≤ 1) :=
begin
  cases n,
  { simpa only [pow_zero] using nnreal.fact_le_refl _ },
  { rwa @pow_le_one_iff _ _ _ nnreal.covariant_mul, apply nat.succ_ne_zero }
end

lemma fact_le_pow_mul_of_le_pow_succ_mul {n : ℕ} (r : ℝ≥0)
  [fact (r ≤ 1)] [h : fact (c₂ ≤ r ^ (n+1) * c₁)] :
  fact (c₂ ≤ r ^ n * c₁) :=
begin
  refine ⟨h.1.trans _⟩,
  rw [pow_succ, mul_assoc],
  apply fact.out
end

instance fact_le_mul_add : fact (c * c₁ + c * c₂ ≤ c * (c₁ + c₂)) :=
by { rw mul_add, exact nnreal.fact_le_refl _ }

instance fact_nat_cast_pos (N : ℕ) [hN: fact (0 < N)] : fact (0 < (N:ℝ≥0)) :=
⟨nat.cast_pos.mpr hN.1⟩

instance fact_nat_cast_inv_le_one (N : ℕ) : fact ((N:ℝ≥0)⁻¹ ≤ 1) :=
begin
  by_cases hN : N = 0,
  { subst hN, simp only [nat.cast_zero, inv_zero, zero_le'], exact ⟨trivial⟩ },
  { rw [inv_le, mul_one], swap, { exact_mod_cast hN },
    norm_cast,
    rw nat.add_one_le_iff,
    exact ⟨nat.pos_of_ne_zero hN⟩, }
end

instance fact_inv_le_one [H : fact (1 ≤ c)] : fact (c⁻¹ ≤ 1) :=
begin
  by_cases hc : c = 0,
  { rw hc at H, exact (not_le_of_lt zero_lt_one H.1).elim },
  rwa [inv_le hc, mul_one]
end

instance fact_one_le_two : fact ((1:ℝ≥0) ≤ 2) := ⟨one_le_two⟩

instance fact_two_pow_inv_le_two_pow_inv (N : ℕ) : fact ((2 ^ N : ℝ≥0)⁻¹ ≤ (2 ^ N : ℕ)⁻¹) :=
⟨le_of_eq $ by norm_cast⟩

instance fact_two_pow_inv_le_one (N : ℕ) : fact ((2 ^ N : ℝ≥0)⁻¹ ≤ 1) :=
⟨le_trans (nnreal.fact_two_pow_inv_le_two_pow_inv N).1 $ fact.out _⟩

end nnreal

#lint- only unused_arguments def_lemma doc_blame


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Justus Springer
-/
import topology.category.Top.open_nhds
import topology.sheaves.presheaf
import topology.sheaves.sheaf_condition.unique_gluing
import category_theory.limits.types
import category_theory.limits.preserves.filtered
import category_theory.limits.final
import topology.sober
import tactic.elementwise
import algebra.category.CommRing

/-!
# Stalks

For a presheaf `F` on a topological space `X`, valued in some category `C`, the *stalk* of `F`
at the point `x : X` is defined as the colimit of the following functor

(nhds x)ᵒᵖ ⥤ (opens X)ᵒᵖ ⥤ C

where the functor on the left is the inclusion of categories and the functor on the right is `F`.
For an open neighborhood `U` of `x`, we define the map `F.germ x : F.obj (op U) ⟶ F.stalk x` as the
canonical morphism into this colimit.

Taking stalks is functorial: For every point `x : X` we define a functor `stalk_functor C x`,
sending presheaves on `X` to objects of `C`. Furthermore, for a map `f : X ⟶ Y` between
topological spaces, we define `stalk_pushforward` as the induced map on the stalks
`(f _* ℱ).stalk (f x) ⟶ ℱ.stalk x`.

Some lemmas about stalks and germs only hold for certain classes of concrete categories. A basic
property of forgetful functors of categories of algebraic structures (like `Mon`, `CommRing`,...)
is that they preserve filtered colimits. Since stalks are filtered colimits, this ensures that
the stalks of presheaves valued in these categories behave exactly as for `Type`-valued presheaves.
For example, in `germ_exist` we prove that in such a category, every element of the stalk is the
germ of a section.

Furthermore, if we require the forgetful functor to reflect isomorphisms and preserve limits (as
is the case for most algebraic structures), we have access to the unique gluing API and can prove
further properties. Most notably, in `is_iso_iff_stalk_functor_map_iso`, we prove that in such
a category, a morphism of sheaves is an isomorphism if and only if all of its stalk maps are
isomorphisms.

See also the definition of "algebraic structures" in the stacks project:
https://stacks.math.columbia.edu/tag/007L

-/

noncomputable theory

universes v u v' u'

open category_theory
open Top
open category_theory.limits
open topological_space
open opposite

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

variables [has_colimits.{v} C]

variables {X Y Z : Top.{v}}

namespace Top.presheaf

variables (C)
/-- Stalks are functorial with respect to morphisms of presheaves over a fixed `X`. -/
def stalk_functor (x : X) : X.presheaf C ⥤ C :=
((whiskering_left _ _ C).obj (open_nhds.inclusion x).op) ⋙ colim

variables {C}

/--
The stalk of a presheaf `F` at a point `x` is calculated as the colimit of the functor
nbhds x ⥤ opens F.X ⥤ C
-/
def stalk (ℱ : X.presheaf C) (x : X) : C :=
(stalk_functor C x).obj ℱ -- -- colimit ((open_nhds.inclusion x).op ⋙ ℱ)

@[simp] lemma stalk_functor_obj (ℱ : X.presheaf C) (x : X) :
  (stalk_functor C x).obj ℱ = ℱ.stalk x := rfl

/--
The germ of a section of a presheaf over an open at a point of that open.
-/
def germ (F : X.presheaf C) {U : opens X} (x : U) : F.obj (op U) ⟶ stalk F x :=
colimit.ι ((open_nhds.inclusion x.1).op ⋙ F) (op ⟨U, x.2⟩)

@[simp, elementwise]
lemma germ_res (F : X.presheaf C) {U V : opens X} (i : U ⟶ V) (x : U) :
  F.map i.op ≫ germ F x = germ F (i x : V) :=
let i' : (⟨U, x.2⟩ : open_nhds x.1) ⟶ ⟨V, (i x : V).2⟩ := i in
colimit.w ((open_nhds.inclusion x.1).op ⋙ F) i'.op

/--
A morphism from the stalk of `F` at `x` to some object `Y` is completely determined by its
composition with the `germ` morphisms.
-/
lemma stalk_hom_ext (F : X.presheaf C) {x} {Y : C} {f₁ f₂ : F.stalk x ⟶ Y}
  (ih : ∀ (U : opens X) (hxU : x ∈ U), F.germ ⟨x, hxU⟩ ≫ f₁ = F.germ ⟨x, hxU⟩ ≫ f₂) : f₁ = f₂ :=
colimit.hom_ext $ λ U, by { induction U using opposite.rec, cases U with U hxU, exact ih U hxU }

@[simp, reassoc, elementwise]
lemma stalk_functor_map_germ {F G : X.presheaf C} (U : opens X) (x : U)
  (f : F ⟶ G) : germ F x ≫ (stalk_functor C x.1).map f = f.app (op U) ≫ germ G x :=
colimit.ι_map (whisker_left ((open_nhds.inclusion x.1).op) f) (op ⟨U, x.2⟩)

variables (C)

/--
For a presheaf `F` on a space `X`, a continuous map `f : X ⟶ Y` induces a morphisms between the
stalk of `f _ * F` at `f x` and the stalk of `F` at `x`.
-/
def stalk_pushforward (f : X ⟶ Y) (F : X.presheaf C) (x : X) : (f _* F).stalk (f x) ⟶ F.stalk x :=
begin
  -- This is a hack; Lean doesn't like to elaborate the term written directly.
  transitivity,
  swap,
  exact colimit.pre _ (open_nhds.map f x).op,
  exact colim.map (whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) F),
end

@[simp, elementwise, reassoc]
lemma stalk_pushforward_germ (f : X ⟶ Y) (F : X.presheaf C) (U : opens Y)
  (x : (opens.map f).obj U) :
  (f _* F).germ ⟨f x, x.2⟩ ≫ F.stalk_pushforward C f x = F.germ x :=
begin
  rw [stalk_pushforward, germ, colimit.ι_map_assoc, colimit.ι_pre, whisker_right_app],
  erw [category_theory.functor.map_id, category.id_comp],
  refl,
end

-- Here are two other potential solutions, suggested by @fpvandoorn at
-- <https://github.com/leanprover-community/mathlib/pull/1018#discussion_r283978240>
-- However, I can't get the subsequent two proofs to work with either one.

-- def stalk_pushforward (f : X ⟶ Y) (ℱ : X.presheaf C) (x : X) :
--   (f _* ℱ).stalk (f x) ⟶ ℱ.stalk x :=
-- colim.map ((functor.associator _ _ _).inv ≫
--   whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) ℱ) ≫
-- colimit.pre ((open_nhds.inclusion x).op ⋙ ℱ) (open_nhds.map f x).op

-- def stalk_pushforward (f : X ⟶ Y) (ℱ : X.presheaf C) (x : X) :
--   (f _* ℱ).stalk (f x) ⟶ ℱ.stalk x :=
-- (colim.map (whisker_right (nat_trans.op (open_nhds.inclusion_map_iso f x).inv) ℱ) :
--   colim.obj ((open_nhds.inclusion (f x) ⋙ opens.map f).op ⋙ ℱ) ⟶ _) ≫
-- colimit.pre ((open_nhds.inclusion x).op ⋙ ℱ) (open_nhds.map f x).op

namespace stalk_pushforward
local attribute [tidy] tactic.op_induction'

@[simp] lemma id (ℱ : X.presheaf C) (x : X) :
  ℱ.stalk_pushforward C (𝟙 X) x = (stalk_functor C x).map ((pushforward.id ℱ).hom) :=
begin
  dsimp [stalk_pushforward, stalk_functor],
  ext1,
  tactic.op_induction',
  cases j, cases j_val,
  rw [colimit.ι_map_assoc, colimit.ι_map, colimit.ι_pre, whisker_left_app, whisker_right_app,
       pushforward.id_hom_app, eq_to_hom_map, eq_to_hom_refl],
  dsimp,
  -- FIXME A simp lemma which unfortunately doesn't fire:
  erw [category_theory.functor.map_id],
end

-- This proof is sadly not at all robust:
-- having to use `erw` at all is a bad sign.
@[simp] lemma comp (ℱ : X.presheaf C) (f : X ⟶ Y) (g : Y ⟶ Z) (x : X) :
  ℱ.stalk_pushforward C (f ≫ g) x =
  ((f _* ℱ).stalk_pushforward C g (f x)) ≫ (ℱ.stalk_pushforward C f x) :=
begin
  dsimp [stalk_pushforward, stalk_functor],
  ext U,
  induction U using opposite.rec,
  cases U,
  cases U_val,
  simp only [colimit.ι_map_assoc, colimit.ι_pre_assoc,
             whisker_right_app, category.assoc],
  dsimp,
  -- FIXME: Some of these are simp lemmas, but don't fire successfully:
  erw [category_theory.functor.map_id, category.id_comp, category.id_comp, category.id_comp,
       colimit.ι_pre, colimit.ι_pre],
  refl,
end

lemma stalk_pushforward_iso_of_open_embedding {f : X ⟶ Y} (hf : open_embedding f)
   (F : X.presheaf C) (x : X) : is_iso (F.stalk_pushforward _ f x) :=
 begin
   haveI := functor.initial_of_adjunction (hf.is_open_map.adjunction_nhds x),
   convert is_iso.of_iso ((functor.final.colimit_iso (hf.is_open_map.functor_nhds x).op
     ((open_nhds.inclusion (f x)).op ⋙ f _* F) : _).symm ≪≫ colim.map_iso _),
   swap,
   { fapply nat_iso.of_components,
     { intro U,
       refine F.map_iso (eq_to_iso _),
       dsimp only [functor.op],
       exact congr_arg op (subtype.eq $ set.preimage_image_eq (unop U).1.1 hf.inj) },
     { intros U V i, erw [← F.map_comp, ← F.map_comp], congr } },
   { ext U,
     rw ← iso.comp_inv_eq,
     erw colimit.ι_map_assoc,
     rw [colimit.ι_pre, category.assoc],
     erw [colimit.ι_map_assoc, colimit.ι_pre, ← F.map_comp_assoc],
     apply colimit.w ((open_nhds.inclusion (f x)).op ⋙ f _* F) _,
     dsimp only [functor.op],
     refine ((hom_of_le _).op : op (unop U) ⟶ _),
     exact set.image_preimage_subset _ _ },
 end

end stalk_pushforward

section stalk_pullback

/-- The morphism `ℱ_{f x} ⟶ (f⁻¹ℱ)ₓ` that factors through `(f_*f⁻¹ℱ)_{f x}`. -/
def stalk_pullback_hom (f : X ⟶ Y) (F : Y.presheaf C) (x : X) :
  F.stalk (f x) ⟶ (pullback_obj f F).stalk x :=
(stalk_functor _ (f x)).map ((pushforward_pullback_adjunction C f).unit.app F) ≫
  stalk_pushforward _ _ _ x

/-- The morphism `(f⁻¹ℱ)(U) ⟶ ℱ_{f(x)}` for some `U ∋ x`. -/
def germ_to_pullback_stalk (f : X ⟶ Y) (F : Y.presheaf C) (U : opens X) (x : U) :
  (pullback_obj f F).obj (op U) ⟶ F.stalk (f x) :=
colimit.desc (Lan.diagram (opens.map f).op F (op U))
{ X := F.stalk (f x),
  ι := { app := λ V, F.germ ⟨f x, V.hom.unop.le x.2⟩,
          naturality' := λ _ _ i, by { erw category.comp_id, exact F.germ_res i.left.unop _ } } }

/-- The morphism `(f⁻¹ℱ)ₓ ⟶ ℱ_{f(x)}`. -/
def stalk_pullback_inv (f : X ⟶ Y) (F : Y.presheaf C) (x : X) :
  (pullback_obj f F).stalk x ⟶ F.stalk (f x) :=
colimit.desc ((open_nhds.inclusion x).op ⋙ presheaf.pullback_obj f F)
{ X := F.stalk (f x),
  ι := { app := λ U, F.germ_to_pullback_stalk _ f (unop U).1 ⟨x, (unop U).2⟩,
          naturality' := λ _ _ _, by { erw [colimit.pre_desc, category.comp_id], congr } } }

/-- The isomorphism `ℱ_{f(x)} ≅ (f⁻¹ℱ)ₓ`. -/
def stalk_pullback_iso (f : X ⟶ Y) (F : Y.presheaf C) (x : X) :
  F.stalk (f x) ≅ (pullback_obj f F).stalk x :=
{ hom := stalk_pullback_hom _ _ _ _,
  inv := stalk_pullback_inv _ _ _ _,
  hom_inv_id' :=
  begin
    delta stalk_pullback_hom stalk_pullback_inv stalk_functor presheaf.pullback stalk_pushforward
      germ_to_pullback_stalk germ,
    ext j,
    induction j using opposite.rec,
    cases j,
    simp only [topological_space.open_nhds.inclusion_map_iso_inv, whisker_right_app,
      whisker_left_app, whiskering_left_obj_map, functor.comp_map, colimit.ι_map_assoc,
      nat_trans.op_id, Lan_obj_map, pushforward_pullback_adjunction_unit_app_app, category.assoc,
      colimit.ι_pre_assoc],
    erw [colimit.ι_desc, colimit.pre_desc, colimit.ι_desc, category.comp_id],
    simpa
  end,
  inv_hom_id' :=
  begin
    delta stalk_pullback_hom stalk_pullback_inv stalk_functor presheaf.pullback stalk_pushforward,
    ext U j,
    induction U using opposite.rec,
    cases U, cases j, cases j_right,
    erw [colimit.map_desc, colimit.map_desc, colimit.ι_desc_assoc,
      colimit.ι_desc_assoc, colimit.ι_desc, category.comp_id],
    simp only [cocone.whisker_ι, colimit.cocone_ι, open_nhds.inclusion_map_iso_inv,
      cocones.precompose_obj_ι, whisker_right_app, whisker_left_app, nat_trans.comp_app,
      whiskering_left_obj_map, nat_trans.op_id, Lan_obj_map,
      pushforward_pullback_adjunction_unit_app_app],
    erw ←colimit.w _
      (@hom_of_le (open_nhds x) _
         ⟨_, U_property⟩ ⟨(opens.map f).obj (unop j_left), j_hom.unop.le U_property⟩
         j_hom.unop.le).op,
    erw colimit.ι_pre_assoc (Lan.diagram _ F _) (costructured_arrow.map _),
    erw colimit.ι_pre_assoc (Lan.diagram _ F _) (costructured_arrow.map _),
    congr,
    simp only [category.assoc, costructured_arrow.map_mk],
    delta costructured_arrow.mk,
    congr
  end }

end stalk_pullback

section stalk_specializes

variables {C}

/-- If `x` specializes to `y`, then there is a natural map `F.stalk y ⟶ F.stalk x`. -/
noncomputable
def stalk_specializes (F : X.presheaf C) {x y : X} (h : x ⤳ y) : F.stalk y ⟶ F.stalk x :=
begin
  refine colimit.desc _ ⟨_,λ U, _,_⟩,
  { exact colimit.ι ((open_nhds.inclusion x).op ⋙ F)
      (op ⟨(unop U).1, (specializes_iff_forall_open.mp h _ (unop U).1.2 (unop U).2 : _)⟩) },
  { intros U V i,
    dsimp,
    rw category.comp_id,
    let U' : open_nhds x := ⟨_, (specializes_iff_forall_open.mp h _ (unop U).1.2 (unop U).2 : _)⟩,
    let V' : open_nhds x := ⟨_, (specializes_iff_forall_open.mp h _ (unop V).1.2 (unop V).2 : _)⟩,
    exact colimit.w ((open_nhds.inclusion x).op ⋙ F) (show V' ⟶ U', from i.unop).op }
end

@[simp, reassoc, elementwise]
lemma germ_stalk_specializes (F : X.presheaf C) {U : opens X} {y : U} {x : X} (h : x ⤳ y) :
  F.germ y ≫ F.stalk_specializes h =
    F.germ ⟨x, specializes_iff_forall_open.mp h _ U.2 y.prop⟩ := colimit.ι_desc _ _

@[simp, reassoc, elementwise]
lemma germ_stalk_specializes' (F : X.presheaf C) {U : opens X} {x y : X} (h : x ⤳ y) (hy : y ∈ U) :
  F.germ ⟨y, hy⟩ ≫ F.stalk_specializes h =
    F.germ ⟨x, specializes_iff_forall_open.mp h _ U.2 hy⟩ := colimit.ι_desc _ _

@[simp, reassoc, elementwise]
lemma stalk_specializes_stalk_functor_map {F G : X.presheaf C} (f : F ⟶ G) {x y : X} (h : x ⤳ y) :
  F.stalk_specializes h ≫ (stalk_functor C x).map f =
    (stalk_functor C y).map f ≫ G.stalk_specializes h :=
by { ext, delta stalk_functor, simpa [stalk_specializes] }

@[simp, reassoc, elementwise]
lemma stalk_specializes_stalk_pushforward (f : X ⟶ Y) (F : X.presheaf C) {x y : X} (h : x ⤳ y) :
  (f _* F).stalk_specializes (f.map_specialization h) ≫ F.stalk_pushforward _ f x =
    F.stalk_pushforward _ f y ≫ F.stalk_specializes h :=
by { ext, delta stalk_pushforward, simpa [stalk_specializes] }

end stalk_specializes

section concrete

variables {C}
variables [concrete_category.{v} C]

local attribute [instance] concrete_category.has_coe_to_sort concrete_category.has_coe_to_fun

@[ext]
lemma germ_ext (F : X.presheaf C) {U V : opens X} {x : X} {hxU : x ∈ U} {hxV : x ∈ V}
  (W : opens X) (hxW : x ∈ W) (iWU : W ⟶ U) (iWV : W ⟶ V) {sU : F.obj (op U)} {sV : F.obj (op V)}
  (ih : F.map iWU.op sU = F.map iWV.op sV) :
  F.germ ⟨x, hxU⟩ sU = F.germ ⟨x, hxV⟩ sV :=
by erw [← F.germ_res iWU ⟨x, hxW⟩,
    ← F.germ_res iWV ⟨x, hxW⟩, comp_apply, comp_apply, ih]

variables [preserves_filtered_colimits (forget C)]

/--
For presheaves valued in a concrete category whose forgetful functor preserves filtered colimits,
every element of the stalk is the germ of a section.
-/
lemma germ_exist (F : X.presheaf C) (x : X) (t : stalk F x) :
  ∃ (U : opens X) (m : x ∈ U) (s : F.obj (op U)), F.germ ⟨x, m⟩ s = t :=
begin
  obtain ⟨U, s, e⟩ := types.jointly_surjective _
    (is_colimit_of_preserves (forget C) (colimit.is_colimit _)) t,
  revert s e,
  rw [(show U = op (unop U), from rfl)],
  generalize : unop U = V, clear U,
  cases V with V m,
  intros s e,
  exact ⟨V, m, s, e⟩,
end

lemma germ_eq (F : X.presheaf C) {U V : opens X} (x : X) (mU : x ∈ U) (mV : x ∈ V)
  (s : F.obj (op U)) (t : F.obj (op V))
  (h : germ F ⟨x, mU⟩ s = germ F ⟨x, mV⟩ t) :
  ∃ (W : opens X) (m : x ∈ W) (iU : W ⟶ U) (iV : W ⟶ V), F.map iU.op s = F.map iV.op t :=
begin
  obtain ⟨W, iU, iV, e⟩ := (types.filtered_colimit.is_colimit_eq_iff _
    (is_colimit_of_preserves _ (colimit.is_colimit ((open_nhds.inclusion x).op ⋙ F)))).mp h,
  exact ⟨(unop W).1, (unop W).2, iU.unop, iV.unop, e⟩,
end

lemma stalk_functor_map_injective_of_app_injective {F G : presheaf C X} (f : F ⟶ G)
  (h : ∀ U : opens X, function.injective (f.app (op U))) (x : X) :
  function.injective ((stalk_functor C x).map f) := λ s t hst,
begin
  rcases germ_exist F x s with ⟨U₁, hxU₁, s, rfl⟩,
  rcases germ_exist F x t with ⟨U₂, hxU₂, t, rfl⟩,
  simp only [stalk_functor_map_germ_apply _ ⟨x,_⟩] at hst,
  obtain ⟨W, hxW, iWU₁, iWU₂, heq⟩ := G.germ_eq x hxU₁ hxU₂ _ _ hst,
  rw [← comp_apply, ← comp_apply, ← f.naturality, ← f.naturality, comp_apply, comp_apply] at heq,
  replace heq := h W heq,
  convert congr_arg (F.germ ⟨x,hxW⟩) heq,
  exacts [(F.germ_res_apply iWU₁ ⟨x,hxW⟩ s).symm,
          (F.germ_res_apply iWU₂ ⟨x,hxW⟩ t).symm],
end

variables [has_limits C] [preserves_limits (forget C)] [reflects_isomorphisms (forget C)]

/--
Let `F` be a sheaf valued in a concrete category, whose forgetful functor reflects isomorphisms,
preserves limits and filtered colimits. Then two sections who agree on every stalk must be equal.
-/
lemma section_ext (F : sheaf C X) (U : opens X) (s t : F.1.obj (op U))
  (h : ∀ x : U, F.1.germ x s = F.1.germ x t) :
  s = t :=
begin
  -- We use `germ_eq` and the axiom of choice, to pick for every point `x` a neighbourhood
  -- `V x`, such that the restrictions of `s` and `t` to `V x` coincide.
  choose V m i₁ i₂ heq using λ x : U, F.1.germ_eq x.1 x.2 x.2 s t (h x),
  -- Since `F` is a sheaf, we can prove the equality locally, if we can show that these
  -- neighborhoods form a cover of `U`.
  apply F.eq_of_locally_eq' V U i₁,
  { intros x hxU,
    rw [opens.mem_coe, opens.mem_supr],
    exact ⟨⟨x, hxU⟩, m ⟨x, hxU⟩⟩ },
  { intro x,
    rw [heq, subsingleton.elim (i₁ x) (i₂ x)] }
end

/-
Note that the analogous statement for surjectivity is false: Surjectivity on stalks does not
imply surjectivity of the components of a sheaf morphism. However it does imply that the morphism
is an epi, but this fact is not yet formalized.
-/
lemma app_injective_of_stalk_functor_map_injective {F : sheaf C X} {G : presheaf C X}
  (f : F.1 ⟶ G) (U : opens X) (h : ∀ x : U, function.injective ((stalk_functor C x.val).map f)) :
  function.injective (f.app (op U)) :=
λ s t hst, section_ext F _ _ _ $ λ x, h x $ by
  rw [stalk_functor_map_germ_apply, stalk_functor_map_germ_apply, hst]

lemma app_injective_iff_stalk_functor_map_injective {F : sheaf C X}
  {G : presheaf C X} (f : F.1 ⟶ G) :
  (∀ x : X, function.injective ((stalk_functor C x).map f)) ↔
  (∀ U : opens X, function.injective (f.app (op U))) :=
⟨λ h U, app_injective_of_stalk_functor_map_injective f U (λ x, h x.1),
  stalk_functor_map_injective_of_app_injective f⟩

/-- For surjectivity, we are given an arbitrary section `t` and need to find a preimage for it.
We claim that it suffices to find preimages *locally*. That is, for each `x : U` we construct
a neighborhood `V ≤ U` and a section `s : F.obj (op V))` such that `f.app (op V) s` and `t`
agree on `V`. -/
lemma app_surjective_of_injective_of_locally_surjective {F G : sheaf C X} (f : F ⟶ G)
  (U : opens X) (hinj : ∀ x : U, function.injective ((stalk_functor C x.1).map f))
  (hsurj : ∀ (t) (x : U), ∃ (V : opens X) (m : x.1 ∈ V) (iVU : V ⟶ U) (s : F.1.obj (op V)),
    f.app (op V) s = G.1.map iVU.op t) :
  function.surjective (f.app (op U)) :=
begin
  intro t,
  -- We use the axiom of choice to pick around each point `x` an open neighborhood `V` and a
  -- preimage under `f` on `V`.
  choose V mV iVU sf heq using hsurj t,
  -- These neighborhoods clearly cover all of `U`.
  have V_cover : U ≤ supr V,
  { intros x hxU,
    rw [opens.mem_coe, opens.mem_supr],
    exact ⟨⟨x, hxU⟩, mV ⟨x, hxU⟩⟩ },
  -- Since `F` is a sheaf, we can glue all the local preimages together to get a global preimage.
  obtain ⟨s, s_spec, -⟩ := F.exists_unique_gluing' V U iVU V_cover sf _,
  { use s,
    apply G.eq_of_locally_eq' V U iVU V_cover,
    intro x,
    rw [← comp_apply, ← f.naturality, comp_apply, s_spec, heq] },
  { intros x y,
    -- What's left to show here is that the secions `sf` are compatible, i.e. they agree on
    -- the intersections `V x ⊓ V y`. We prove this by showing that all germs are equal.
    apply section_ext,
    intro z,
    -- Here, we need to use injectivity of the stalk maps.
    apply (hinj ⟨z, (iVU x).le ((inf_le_left : V x ⊓ V y ≤ V x) z.2)⟩),
    dsimp only,
    erw [stalk_functor_map_germ_apply, stalk_functor_map_germ_apply],
    simp_rw [← comp_apply, f.naturality, comp_apply, heq, ← comp_apply, ← G.1.map_comp],
    refl }
end

lemma app_surjective_of_stalk_functor_map_bijective {F G : sheaf C X} (f : F ⟶ G)
  (U : opens X) (h : ∀ x : U, function.bijective ((stalk_functor C x.val).map f)) :
  function.surjective (f.app (op U)) :=
begin
  refine app_surjective_of_injective_of_locally_surjective f U (λ x, (h x).1) (λ t x, _),
  -- Now we need to prove our initial claim: That we can find preimages of `t` locally.
  -- Since `f` is surjective on stalks, we can find a preimage `s₀` of the germ of `t` at `x`
  obtain ⟨s₀,hs₀⟩ := (h x).2 (G.1.germ x t),
  -- ... and this preimage must come from some section `s₁` defined on some open neighborhood `V₁`
  obtain ⟨V₁,hxV₁,s₁,hs₁⟩ := F.1.germ_exist x.1 s₀,
  subst hs₁, rename hs₀ hs₁,
  erw stalk_functor_map_germ_apply V₁ ⟨x.1,hxV₁⟩ f s₁ at hs₁,
  -- Now, the germ of `f.app (op V₁) s₁` equals the germ of `t`, hence they must coincide on
  -- some open neighborhood `V₂`.
  obtain ⟨V₂, hxV₂, iV₂V₁, iV₂U, heq⟩ := G.1.germ_eq x.1 hxV₁ x.2 _ _ hs₁,
  -- The restriction of `s₁` to that neighborhood is our desired local preimage.
  use [V₂, hxV₂, iV₂U, F.1.map iV₂V₁.op s₁],
  rw [← comp_apply, f.naturality, comp_apply, heq],
end

lemma app_bijective_of_stalk_functor_map_bijective {F G : sheaf C X} (f : F ⟶ G)
   (U : opens X) (h : ∀ x : U, function.bijective ((stalk_functor C x.val).map f)) :
  function.bijective (f.app (op U)) :=
⟨app_injective_of_stalk_functor_map_injective f U (λ x, (h x).1),
  app_surjective_of_stalk_functor_map_bijective f U h⟩

lemma app_is_iso_of_stalk_functor_map_iso {F G : sheaf C X} (f : F ⟶ G) (U : opens X)
  [∀ x : U, is_iso ((stalk_functor C x.val).map f)] : is_iso (f.app (op U)) :=
begin
  -- Since the forgetful functor of `C` reflects isomorphisms, it suffices to see that the
  -- underlying map between types is an isomorphism, i.e. bijective.
  suffices : is_iso ((forget C).map (f.app (op U))),
  { exactI is_iso_of_reflects_iso (f.app (op U)) (forget C) },
  rw is_iso_iff_bijective,
  apply app_bijective_of_stalk_functor_map_bijective,
  intro x,
  apply (is_iso_iff_bijective _).mp,
  exact functor.map_is_iso (forget C) ((stalk_functor C x.1).map f)
end

/--
Let `F` and `G` be sheaves valued in a concrete category, whose forgetful functor reflects
isomorphisms, preserves limits and filtered colimits. Then if the stalk maps of a morphism
`f : F ⟶ G` are all isomorphisms, `f` must be an isomorphism.
-/
-- Making this an instance would cause a loop in typeclass resolution with `functor.map_is_iso`
lemma is_iso_of_stalk_functor_map_iso {F G : sheaf C X} (f : F ⟶ G)
  [∀ x : X, is_iso ((stalk_functor C x).map f)] : is_iso f :=
begin
  -- Since the inclusion functor from sheaves to presheaves is fully faithful, it suffices to
  -- show that `f`, as a morphism between _presheaves_, is an isomorphism.
  suffices : is_iso ((sheaf.forget C X).map f),
  { exactI is_iso_of_fully_faithful (sheaf.forget C X) f },
  -- We show that all components of `f` are isomorphisms.
  suffices : ∀ U : (opens X)ᵒᵖ, is_iso (f.app U),
  { exact @nat_iso.is_iso_of_is_iso_app _ _ _ _ F.1 G.1 f this, },
  intro U, induction U using opposite.rec,
  apply app_is_iso_of_stalk_functor_map_iso
end

/--
Let `F` and `G` be sheaves valued in a concrete category, whose forgetful functor reflects
isomorphisms, preserves limits and filtered colimits. Then a morphism `f : F ⟶ G` is an
isomorphism if and only if all of its stalk maps are isomorphisms.
-/
lemma is_iso_iff_stalk_functor_map_iso {F G : sheaf C X} (f : F ⟶ G) :
  is_iso f ↔ ∀ x : X, is_iso ((stalk_functor C x).map f) :=
begin
  split,
  { intros h x, resetI,
    exact @functor.map_is_iso _ _ _ _ _ _ (stalk_functor C x) f
      ((sheaf.forget C X).map_is_iso f) },
  { intro h,
    exactI is_iso_of_stalk_functor_map_iso f }
end

end concrete

instance (F : X.presheaf CommRing) {U : opens X} (x : U) :
  algebra (F.obj $ op U) (F.stalk x) :=
(F.germ x).to_algebra

@[simp]
lemma stalk_open_algebra_map {X : Top} (F : X.presheaf CommRing) {U : opens X} (x : U) :
  algebra_map (F.obj $ op U) (F.stalk x) = F.germ x := rfl

end Top.presheaf


import data.mv_polynomial ring_theory.ideal_operations ring_theory.adjoin_root
import ring_theory.integral_closure

namespace adjoin_root
variables {α : Type*} [comm_ring α] {f : polynomial α}
open polynomial ideal

lemma coe_injective_of_degree_pos_of_monic (hf : 0 < degree f) (hm : monic f) :
  function.injective (coe : α → adjoin_root f) :=
λ x y hxy,
begin
  rcases mem_span_singleton.1 (ideal.quotient.eq.1 hxy) with ⟨g, hg⟩,
  classical,
  by_cases hg0 : g = 0,
  { rwa [hg0, mul_zero, sub_eq_zero, C_inj] at hg },
  { have hlc : leading_coeff f * leading_coeff g ≠ 0,
    { rwa [monic.def.1 hm, one_mul, ne.def, leading_coeff_eq_zero] },
    exact false.elim (not_le_of_gt hf $
      calc degree f = nat_degree f : degree_eq_nat_degree (λ hf0, by simp * at *)
      ... ≤ nat_degree f + nat_degree g : with_bot.coe_le_coe.2 (nat.le_add_right _ _)
      ... = 0 : by rw [← with_bot.coe_add, ← nat_degree_mul_eq' hlc, ← hg, ← C_sub, nat_degree_C,
        with_bot.coe_zero]) }
end
end adjoin_root
#print ideal.leading_coeff
namespace ideal
variables {R : Type*} [comm_ring R]

@[simp] lemma span_empty : (span ∅ : ideal R) = ⊥ :=
submodule.span_empty

lemma quotient.mk_eq_zero {I : ideal R} {x : R} : ideal.quotient.mk I x = 0 ↔ x ∈ I :=
submodule.quotient.mk_eq_zero _

lemma ext_iff {I J : ideal R} : I = J ↔ (∀ x, x ∈ I ↔ x ∈ J) :=
⟨λ h _, h ▸ iff.rfl, ideal.ext⟩

end ideal

namespace mv_polynomial

lemma C_inj {R σ : Type*} [comm_semiring R] {x y : R} : (C x : mv_polynomial σ R) = C y ↔ x = y :=
sorry

noncomputable instance {R σ : Type*} [nonzero_comm_semiring R] :
  nonzero_comm_semiring (mv_polynomial σ R) :=
{ zero_ne_one := sorry,
  ..show comm_semiring (mv_polynomial σ R), by apply_instance }

end mv_polynomial

namespace polynomial

open ideal set
open_locale classical
end polynomial

open mv_polynomial ideal
universes u v
variables (K : Type u) [discrete_field K]
noncomputable theory

section name
variables {α : Type*} {β : Type*} {σ : Type*} [comm_ring α] [comm_ring β]

def mname (i : σ) (p : polynomial α) : mv_polynomial σ α :=
p.eval₂ C (X i)

@[simp] lemma mname_one (i : σ)  :
  mname i (1 : polynomial α) = 1 :=
by simp [mname]

@[simp] lemma mname_zero (i : σ)  :
  mname i (0 : polynomial α) = 0 :=
by simp [mname]

@[simp] lemma mname_add (i : σ) (p q : polynomial α) :
  mname i (p + q) =  mname i p + mname i q :=
by simp [mname]

@[simp] lemma mname_mul (i : σ) (p q : polynomial α) :
  mname i (p * q) =  mname i p * mname i q :=
by simp [mname]

@[simp] lemma mname_pow (i : σ) (p : polynomial α) (n : ℕ) :
  mname i (p ^ n) =  mname i p ^ n :=
by induction n; simp [pow_succ, *]

@[simp] lemma mname_sub (i : σ) (p q : polynomial α) :
  mname i (p - q) =  mname i p - mname i q :=
by simp [mname]

@[simp] lemma mname_neg (i : σ) (p : polynomial α) :
  mname i (-p) = -mname i p :=
by simp [mname]

@[simp] lemma mname_C (i : σ) (a : α) :
  mname i (polynomial.C a) = C a :=
by simp [mname]

@[simp] lemma mname_X (i : σ) :
  mname i (polynomial.X : polynomial α) = X i :=
by simp [mname]

@[simp] lemma eval₂_mname (i : σ) (f : α → β) [is_semiring_hom f] (s : σ → β) (p : polynomial α) :
  eval₂ f s (mname i p) = polynomial.eval₂ f (s i) p :=
polynomial.induction_on p
  (λ a, by simp)
  (by simp {contextual := tt})
  (by simp [pow_succ', (mul_assoc _ _ _).symm] {contextual := tt})

end name

@[reducible] def posd : Type u := {p : polynomial K // 0 < p.degree ∧ p.monic}

@[reducible] def pac : Type u :=
mv_polynomial (posd K) K

variable {K}

namespace pac
variable (K)
def relt (s : set (posd K)) : set (pac K) :=
(λ p : posd K, p.1.eval₂ C (X p)) '' s

end pac
open pac

set_option class.instance_max_depth 50

@[instance, priority 100000] instance :
  comm_ring (pac K) := mv_polynomial.comm_ring

def F1 (s : set (posd K)) : K →+* ideal.quotient (span (relt K s)) :=
(ring_hom.of (ideal.quotient.mk (span (relt K s)))).comp (ring_hom.of (C : K → pac K))

def F2 (s : set (posd K)) (p : posd K) : K →+* adjoin_root (p.1.map (F1 s)) :=
(ring_hom.of coe).comp $ (ring_hom.of $ ideal.quotient.mk (span (relt K s))).comp $
  ring_hom.of (C : K → pac K)

open_locale classical

lemma isom2 (s : set (posd K)) (p : posd K) (hps : p ∉ s) :
  ideal.quotient (span (relt K (insert p s))) →+* adjoin_root (p.1.map (F1 s)) :=
ring_hom.of $ ideal.quotient.lift _
  (eval₂ (F2 s p) (λ q, if q ∈ s
    then (↑(ideal.quotient.mk (span (relt K s)) (X q : pac K)) : adjoin_root _)
      else if q = p then adjoin_root.root
      else 0))
  begin
    assume x hx,
    refine submodule.span_induction hx _ (by simp) (by simp {contextual := tt})
      (by simp {contextual := tt}),
    assume x hx,
    rcases hx with ⟨q, hq, rfl⟩,
    { rcases hq with rfl | hq,
      { dsimp only [F2, F1],
        rw [← mname, ← adjoin_root.eval₂_root, eval₂_mname, if_pos rfl,
          if_neg hps, polynomial.eval₂_map],
        refl },
      { dsimp only,
        have : ideal.quotient.mk (span (relt K s)) (mname q q) = 0,
        { rw [ideal.quotient.mk_eq_zero],
          exact subset_span (set.mem_image_of_mem _ hq) },
        erw [← mname, eval₂_mname, if_pos hq,
          ← is_ring_hom.map_zero (coe : ideal.quotient (span (relt K s)) →
            adjoin_root (p.1.map (F1 s))), ← this, mname, F2],
        exact eq.symm (polynomial.hom_eval₂ (q : polynomial K) _
          (ring_hom.comp (ring_hom.of (coe : ideal.quotient (span (relt K s)) →
            adjoin_root (p.1.map (F1 s))))
          (ring_hom.of (ideal.quotient.mk (span (relt K s))))) (X q)) } }
  end

open polynomial

lemma map1 (s : set (posd K)) (p : posd K)
  (h01' : (0 :  ideal.quotient (span (relt K s))) ≠ 1) :
  (0 : adjoin_root (p.1.map (F1 s))) ≠ 1 :=
λ h01,
  by rw [← is_ring_hom.map_zero (coe : ideal.quotient (span (relt K s)) →
    adjoin_root (p.1.map (F1 s))),
   ← is_ring_hom.map_one (coe : ideal.quotient (span (relt K s)) →
    adjoin_root (p.1.map (F1 s)))] at h01; exact
h01' (adjoin_root.coe_injective_of_degree_pos_of_monic
  begin
    refine lt_of_not_ge' _,
    rw [degree_le_zero_iff],
    assume h,
    have : (p.1.map (F1 s)).coeff p.1.nat_degree =
      (polynomial.C ((p.1.map (F1 s)).coeff 0)).coeff p.1.nat_degree, { rw ← h },
    have h0 : nat_degree p.1 ≠ 0,
    { rw [← nat.pos_iff_ne_zero, ← with_bot.coe_lt_coe],
      exact lt_of_lt_of_le p.2.1 degree_le_nat_degree },
    rw [polynomial.coeff_C, polynomial.coeff_map, ← polynomial.leading_coeff,
      monic.def.1 p.2.2, ring_hom.map_one, if_neg h0] at this,
    exact h01'.symm this
  end
  (monic_map _ p.2.2)
  h01).

lemma ne_top_aux (s : finset (posd K)) : span (relt K ↑s) ≠ ⊤ :=
finset.induction_on s
  (by simp [ne_top_iff_one, relt, ideal.ext_iff, classical.not_forall]; exact ⟨1, by simp⟩)
  (λ p s hps ih,
    have (0 : ideal.quotient (span (relt K ↑s))) ≠ 1,
      from ne.symm $ mt (ideal.quotient.mk_eq_zero).1 ((ne_top_iff_one _).1 ih),
    have (0 :  adjoin_root (p.1.map (F1 (↑s : set (posd K))))) ≠ 1,
      from map1 ↑s p this,
    have (0 : ideal.quotient (span (relt K (insert p ↑s)))) ≠ 1,
      from λ h, this $ by rw [← ring_hom.map_zero (isom2 ↑s p hps), h, ring_hom.map_one],
    by rw [finset.coe_insert, ne_top_iff_one, ← ideal.quotient.mk_eq_zero, eq_comm];
      exact this)

lemma ne_top : span (relt K ⊤) ≠ ⊤ :=
(ne_top_iff_one _).2 $ λ h : 1 ∈ span (relt K ⊤),
have hs : ∃ s : finset (posd K), (1 : pac K) ∈ span (relt K ↑s),
  from submodule.span_induction h
    (by rintros x ⟨p, hp, rfl⟩; exact ⟨{p}, subset_span (by simp [relt])⟩)
    ⟨∅, by simp⟩
    (by rintros x y ⟨s, hs⟩ ⟨t, ht⟩;
      exact ⟨s ∪ t, ideal.add_mem _ (span_mono (by simp [relt, set.image_union]) hs)
                                    (span_mono (by simp [relt, set.image_union]) ht)⟩)
    (by rintros a x ⟨s, hs⟩; exact ⟨s, ideal.mul_mem_left _ hs⟩),
by cases hs with s hs;
  exact ne_top_aux s ((not_iff_not.1 (ne_top_iff_one _)).2 hs)

variable (K)
def big_ideal : ideal (pac K) :=
classical.some (exists_le_maximal (span (relt K ⊤)) ne_top)

def K1 : Type u :=
ideal.quotient (@big_ideal K _)

instance : discrete_field (K1 K) :=
@ideal.quotient.field _ _ _
  (classical.some_spec (exists_le_maximal (span (relt K ⊤)) ne_top)).1

variables {K}

def of : K → K1 K := ideal.quotient.mk _ ∘ mv_polynomial.C

instance of.is_ring_hom : is_ring_hom (@of K _) := is_ring_hom.comp _ _

instance : algebra K (K1 K) := algebra.of_ring_hom of of.is_ring_hom

lemma algebra_map_eq_of : algebra_map (K1 K) = of := rfl

lemma aeval_posd {f : posd K} : (polynomial.aeval K (K1 K)
  (ideal.quotient.mk (big_ideal K) (X f)) :
    polynomial K → K1 K) f.1 = 0 :=
begin
  rw [polynomial.aeval_def, algebra_map_eq_of, of,
    ← hom_eval₂ _ mv_polynomial.C (ideal.quotient.mk (big_ideal K)), ← mname],
  exact ideal.quotient.mk_eq_zero.2
    ((classical.some_spec (exists_le_maximal (span (relt K ⊤)) ne_top)).2
      (subset_span (set.mem_image_of_mem _ (set.mem_univ _))))
end

lemma is_integral_aux {f : posd K} : @is_integral K (K1 K) _ _ _
  (ideal.quotient.mk _ (X f) : K1 K) :=
⟨f, f.2.2, aeval_posd⟩

lemma mem_integral_closure (x : K1 K) : is_integral K x :=
quotient.induction_on' x $ λ x,
  show ideal.quotient.mk _ x ∈ integral_closure K (K1 K),
  from mv_polynomial.induction_on x
    (λ k, is_integral_algebra_map)
    sorry -- subalgebra.add_mem
    (λ x p, sorry)


import category_theory.base
import category_theory.eq_to_hom
import category_theory.groupoid
import category_theory.full_subcategory

universes v x z u u' w w' y y'

local notation f ` ∘ `:80 g:80 := g ≫ f

namespace category_theory

-- TODO: merge with category_theory.full_subcategory

local attribute [simps] induced_category.category

variables {C : Type u} {C' : Type u'} (k : C' → C)
variables {D : Type w} {D' : Type w'} (l : D' → D)

def induced_functor' {catC : category.{v} C} {catD : category.{x} D} (F : C ↝ D)
  (F' : C' → D') (e : ∀ a, F.obj (k a) = l (F' a)) :
  induced_category C k ↝ induced_category D l :=
{ obj := F',
  map := λ X Y f,
    show l (F' X) ⟶ l (F' Y), from
    eq_to_hom (e Y) ∘ (F &> f) ∘ eq_to_hom (e X).symm,
  map_id' := λ X, by dsimp; rw F.map_id; simp,
  map_comp' := λ X Y Z f g, by dsimp; rw F.map_comp; simp }

lemma induced_functor_id [catC : category.{v} C] :
  induced_functor' k k (functor.id C) id (λ a, rfl) =
  functor.id (induced_category C k) :=
begin
  fapply functor.ext,
  { intro a, refl },
  { intros a b f, dsimp [induced_functor'], simp }
end

variables {E : Type y} {E' : Type y'} (m : E' → E)
lemma induced_functor_comp [catC : category.{v} C]
  [catD : category.{x} D] [catE : category.{z} E]
  {F : C ↝ D} {F' : C' → D'} (eF : ∀ a, F.obj (k a) = l (F' a))
  {G : D ↝ E} {G' : D' → E'} (eG : ∀ a, G.obj (l a) = m (G' a)) :
  induced_functor' k m (F.comp G) (function.comp G' F')
    (by intro a; change G.obj (F.obj (k a)) = _; rw [eF, eG]) =
    induced_functor' k l F F' eF ⋙ induced_functor' l m G G' eG :=
begin
  fapply functor.ext,
  { intro a, refl },
  { intros a b f,
    -- This proof mysteriously broke
    dsimp [induced_functor'],
    rw category.id_comp,
    erw category.comp_id,
    -- FIXME: Why was this lemma removed from simp?
    simp [eq_to_hom_map], refl }
end

end category_theory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import data.equiv.transfer_instance

/-!
# If `C` is preadditive, `Cᵒᵖ` has a natural preadditive structure.

-/

open opposite

namespace category_theory

variables (C : Type*) [category C] [preadditive C]

instance : preadditive Cᵒᵖ :=
{ hom_group := λ X Y, equiv.add_comm_group (op_equiv X Y),
  add_comp' := λ X Y Z f f' g,
    congr_arg quiver.hom.op (preadditive.comp_add _ _ _ g.unop f.unop f'.unop),
  comp_add' := λ X Y Z f g g',
    congr_arg quiver.hom.op (preadditive.add_comp _ _ _ g.unop g'.unop f.unop), }

instance module_End_left {X : Cᵒᵖ} {Y : C} : module (End X) (unop X ⟶ Y) :=
{ smul_add := λ r f g, preadditive.comp_add _ _ _ _ _ _,
  smul_zero := λ r, limits.comp_zero,
  add_smul := λ r s f, preadditive.add_comp _ _ _ _ _ _,
  zero_smul := λ f, limits.zero_comp }

@[simp] lemma unop_zero (X Y : Cᵒᵖ) : (0 : X ⟶ Y).unop = 0 := rfl
@[simp] lemma unop_add {X Y : Cᵒᵖ} (f g : X ⟶ Y) : (f + g).unop = f.unop + g.unop := rfl
@[simp] lemma op_zero (X Y : C) : (0 : X ⟶ Y).op = 0 := rfl
@[simp]

variables {C} {D : Type*} [category D] [preadditive D]

instance functor.op_additive (F : C ⥤ D) [F.additive] : F.op.additive := {}

instance functor.right_op_additive (F : Cᵒᵖ ⥤ D) [F.additive] : F.right_op.additive := {}

instance functor.left_op_additive (F : C ⥤ Dᵒᵖ) [F.additive] : F.left_op.additive := {}

instance functor.unop_additive (F : Cᵒᵖ ⥤ Dᵒᵖ) [F.additive] : F.unop.additive := {}

end category_theory


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Adam Topaz
-/
import category_theory.preadditive
import category_theory.preadditive.additive_functor
import logic.equiv.transfer_instance

/-!
# If `C` is preadditive, `Cᵒᵖ` has a natural preadditive structure.

-/

open opposite

namespace category_theory

variables (C : Type*) [category C] [preadditive C]

instance : preadditive Cᵒᵖ :=
{ hom_group := λ X Y, equiv.add_comm_group (op_equiv X Y),
  add_comp' := λ X Y Z f f' g,
    congr_arg quiver.hom.op (preadditive.comp_add _ _ _ g.unop f.unop f'.unop),
  comp_add' := λ X Y Z f g g',
    congr_arg quiver.hom.op (preadditive.add_comp _ _ _ g.unop g'.unop f.unop), }

instance module_End_left {X : Cᵒᵖ} {Y : C} : module (End X) (unop X ⟶ Y) :=
{ smul_add := λ r f g, preadditive.comp_add _ _ _ _ _ _,
  smul_zero := λ r, limits.comp_zero,
  add_smul := λ r s f, preadditive.add_comp _ _ _ _ _ _,
  zero_smul := λ f, limits.zero_comp }

@[simp] lemma unop_zero (X Y : Cᵒᵖ) : (0 : X ⟶ Y).unop = 0 := rfl
@[simp] lemma unop_add {X Y : Cᵒᵖ} (f g : X ⟶ Y) : (f + g).unop = f.unop + g.unop := rfl
@[simp] lemma op_zero (X Y : C) : (0 : X ⟶ Y).op = 0 := rfl
@[simp]

variables {C} {D : Type*} [category D] [preadditive D]

instance functor.op_additive (F : C ⥤ D) [F.additive] : F.op.additive := {}

instance functor.right_op_additive (F : Cᵒᵖ ⥤ D) [F.additive] : F.right_op.additive := {}

instance functor.left_op_additive (F : C ⥤ Dᵒᵖ) [F.additive] : F.left_op.additive := {}

instance functor.unop_additive (F : Cᵒᵖ ⥤ Dᵒᵖ) [F.additive] : F.unop.additive := {}

end category_theory


import category_theory.isomorphism
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.reflexive
import category_theory.limits.opposites
import category_theory.closed.cartesian
import category_theory.adjunction.basic
import category_theory.functor.epi_mono
import category_theory.monad.basic
import category_theory.monad.monadicity

import subobject_classifier
import adjunction
import image

open category_theory category_theory.category category_theory.limits category_theory.cartesian_closed classifier opposite

/-!
# Topos

Basic definitions of a topos
From Sheaves IV
-/

universes v u

noncomputable theory

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

class topos :=
[lim : has_finite_limits.{v} C]
[sub : has_subobject_classifier.{v} C]
[cc : cartesian_closed.{v} C]

attribute [instance] topos.lim topos.sub topos.cc

variables [topos C]

-- It doesn't seem to bee infered automatically
instance : has_finite_colimits Cᵒᵖ := has_finite_colimits_opposite

variables {C} (c : C)

def sub_to_hom : subobject c → (c ⟶ Ω C) := λ s, classifier_of s.arrow
def hom_to_sub : (c ⟶ Ω C) → subobject c := λ σ, canonical_sub σ

lemma sub_equiv_hom : subobject c ≃ (c ⟶ Ω C) :=
{ to_fun := sub_to_hom c,
  inv_fun := hom_to_sub c,
  left_inv := λ S, sub_eq_canonical_sub_of_classifier S,
  right_inv := λ σ, classifier.uniquely _ _
                   (classifying_pullback.mk _ (is_pullback_canonical_arrow _)) }

def δ := classifier_of (diag c)
def singleton_map := curry (δ c)

variables (C) {a b : C}

def P : Cᵒᵖ ⥤ C := {
  obj := λ c, (exp c.unop).obj (Ω C),
  map := λ c d f, (pre f.unop).app (Ω C),
  map_id' := λ c, by {rw [unop_id, pre_id, nat_trans.id_app]},
  map_comp' := λ _ _ _ f g, by {rw [unop_comp, pre_map, nat_trans.comp_app]} }

def P_op : C ⥤ Cᵒᵖ := functor.right_op (P C)

variable {C}

def in_map : c ⨯ (P C).obj (op c) ⟶ Ω C := (exp.ev c).app (Ω C)

variable {c}

lemma in_map_natural (g : a ⟶ (P C).obj (op b)) :
  uncurry g = limits.prod.map (𝟙 _) g ≫ in_map b := uncurry_eq g

lemma in_map_dinatural (h : b ⟶ c) :
  limits.prod.map h (𝟙 _) ≫ in_map c = limits.prod.map (𝟙 _) ((P C).map h.op) ≫ in_map b :=
begin
  erw [←in_map_natural, uncurry_pre],
  refl
end

variables {C c} {d : C} {f : c ⟶ d}

namespace delta

open category_theory.limits.prod

def pullback_cone_map_diag (f : c ⟶ d) : pullback_cone (map f (𝟙 _)) (diag d) :=
pullback_cone.mk (lift (𝟙 _) f) f (by simp only [lift_map,comp_lift, id_comp, comp_id])

lemma cone_map_diag_fst (s : pullback_cone (map f (𝟙 _)) (diag d)) : s.fst ≫ fst ≫ f = s.snd :=
by { rw [←map_fst f (𝟙 _), ←assoc, s.condition, assoc, lift_fst, comp_id] }

lemma cone_map_diag_snd (s : pullback_cone (map f (𝟙 _)) (diag d)) : s.fst ≫ snd = s.snd :=
by { rw [←comp_id (s.fst ≫ snd), assoc, ←map_snd f (𝟙 _),
         ←assoc, s.condition, assoc, lift_snd, comp_id] }

lemma cone_map_diag_fst_snd (s : pullback_cone (map f (𝟙 _)) (diag d)) :
  s.fst ≫ fst ≫ f = s.fst ≫ snd := eq.trans (cone_map_diag_fst s) (cone_map_diag_snd s).symm

def is_limit_pullback_cone_map_diag : is_limit (pullback_cone_map_diag f) :=
begin
  apply pullback_cone.is_limit.mk (pullback_cone_map_diag f).condition (λ s, s.fst ≫ fst);
  intro s,
  { simp only [assoc], dunfold pullback_cone_map_diag, rw pullback_cone.mk_fst,
    rw [comp_lift], nth_rewrite 1 ←comp_id s.fst, simp only [comp_id],
    apply hom_ext,
      rw [assoc, lift_fst, ←assoc, comp_id (s.fst ≫ fst)],
      rw [assoc, lift_snd], apply cone_map_diag_fst_snd },
  { simp only [assoc], erw pullback_cone.mk_snd, apply cone_map_diag_fst, },
  { intros l fst' snd', simp only,
    rw ←eq_whisker fst' fst, erw [assoc, lift_fst, comp_id] }
end

variable (f)

def big_square_cone : pullback_cone (map f (𝟙 d) ≫ δ d) (truth C) :=
pullback_cone.mk (lift (𝟙 c) f) (f ≫ terminal.from d)
(by { erw [←assoc, (pullback_cone_map_diag f).condition, assoc, classifier.comm (diag d),
      ←assoc, terminal.comp_from] })

lemma is_limit_big_square_cone : is_limit (big_square_cone f) :=
begin
  apply big_square_is_pullback f (terminal.from _) (map f (𝟙 _)) (δ _)
    (lift (𝟙 _) f) (diag _) (truth C),
  apply classifier.is_pb,
  apply is_limit_pullback_cone_map_diag,
end

lemma big_square_classifying : classifying (truth C) (lift (𝟙 c) f) (map f (𝟙 d) ≫ δ d) :=
{ comm := by { rw ←terminal.comp_from f, erw (big_square_cone f).condition, refl },
  is_pb :=
  begin
    let g := is_limit_big_square_cone f, unfold big_square_cone at g,
    simp [terminal.comp_from f] at g, assumption,
  end }

lemma classifies : classifier_of (lift (𝟙 _) f) = map f (𝟙 _) ≫ δ d :=
classifier.uniquely _ _ (big_square_classifying f)

variable (g : c ⟶ d)

lemma cancel_classifier:  (classifier_of (lift (𝟙 _) f) =  classifier_of (lift (𝟙 _) g)) ↔ f = g :=
begin
  split; intro heq,
  { have k := (pullback_cone.is_limit.lift' (classifier.is_pb (lift (𝟙 _) f))
    ((lift (𝟙 _) g)) (terminal.from _) (by rw [heq, classifier.comm])).prop.left,
    have eq_id := eq_whisker k fst,
    erw [assoc, lift_fst, lift_fst, comp_id] at eq_id,
    rw [eq_id, id_comp] at k,
    convert eq_whisker k snd,
    erw lift_snd, rw lift_snd },
  { rw heq }
end

end delta

-- We show that a topos is balanced
namespace balanced

lemma iso_of_is_limit_fork_id {f : c ⟶ d} {s : fork f f} (is_lim : is_limit s) : is_iso s.ι :=
begin
  apply is_iso.mk,
  use is_lim.lift (fork.of_ι (𝟙 c) (by simp)),
  split,
  { apply fork.is_limit.hom_ext is_lim,
    rw [assoc, fork.is_limit.lift_ι, fork.ι_of_ι, id_comp],
    apply comp_id },
  { apply fork.is_limit.lift_ι }
end

lemma is_limit_of_is_limit_fork_eq {f g : c ⟶ d} {s : fork f g} (is_lim : is_limit s) (heq : f = g) :
  is_limit (fork.of_ι s.ι (by rw s.condition) : fork f f) :=
begin
  refine fork.is_limit.mk _
    (λ t : fork f f, (fork.is_limit.lift' is_lim t.ι (by rw ←heq)).val) _ _;
  intro t,
  { apply fork.is_limit.lift_ι },
  { intros r ht, apply fork.is_limit.hom_ext is_lim, erw fork.is_limit.lift_ι, apply ht }
end

lemma iso_of_is_limit_fork_eq {f g : c ⟶ d} {s : fork f g} (is_lim : is_limit s) (heq : f = g) :
  is_iso s.ι := iso_of_is_limit_fork_id (is_limit_of_is_limit_fork_eq is_lim heq)

variable (C)

instance topos_balanced : balanced C :=
{ is_iso_of_mono_of_epi := λ c d f m e,
  begin
    resetI,
    apply iso_of_is_limit_fork_eq (image.monic_is_limit_fork f),
    rw ←cancel_epi f,
    exact (image.monic_to_canonical_fork f).condition
  end }

end balanced