/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

Environments.
-/
import data.hash_map library_dev.data.list.sort .tensor .id .util .reference

namespace certigrad

def pre_env : Type := hash_map reference (λ (ref : reference), T ref.2)

attribute [reducible] pre_env
namespace pre_env

definition eqv (m₁ m₂ : pre_env) : Prop :=
∀ (ref : reference), m₁^.find ref = m₂^.find ref

local infix ~ := eqv

definition eqv.refl (m : pre_env) : m ~ m :=
assume ref, rfl

definition eqv.symm (m₁ m₂ : pre_env) : m₁ ~ m₂ → m₂ ~ m₁ :=
assume H ref, eq.symm (H ref)

definition eqv.trans (m₁ m₂ m₃ : pre_env) : m₁ ~ m₂ → m₂ ~ m₃ → m₁ ~ m₃ :=
assume H₁ H₂ ref, eq.trans (H₁ ref) (H₂ ref)

instance pdmap.eqv_setoid : setoid pre_env :=
setoid.mk eqv (mk_equivalence eqv eqv.refl eqv.symm eqv.trans)

end pre_env

def env : Type := quot pre_env.eqv

namespace env

def mk : env := quotient.mk (mk_hash_map reference.hash)

def get (ref : reference) (q : env) : T ref.2 := quotient.lift_on q
(λ (m : pre_env),
  match m^.find ref with
  | none := default _
  | some x := x
  end)
begin intros m₁ m₂ H_eqv, simp [H_eqv ref] end

def insert (ref : reference) (x : T ref.2) (q : env) : env := quotient.lift_on q
(λ (m : pre_env), quotient.mk $ m^.insert ref x)
begin
intros m₁ m₂ H_eqv, dsimp, apply quotient.sound,
intros ref',
cases (decidable.em (ref = ref')) with H_eq H_neq,
simp [hash_map.find_insert, dif_ctx_simp_congr, H_eq, dif_pos],
simp [hash_map.find_insert, dif_ctx_simp_congr, H_neq, dif_neg, H_eqv ref'],
end

def has_key (ref : reference) (q : env) : Prop := quotient.lift_on q
(λ (m : pre_env), m^.contains ref)
begin intros m₁ m₂ H_eqv, simp [hash_map.contains, H_eqv ref] end

def get_ks : Π (refs : list reference) (m : env), dvec T refs^.p2
| []          m := ⟦⟧
| (ref::refs) m := dvec.cons (get ref m) (get_ks refs m)

def insert_all : Π (refs : list reference) (vs : dvec T refs^.p2), env
| []      ⟦⟧        := env.mk
| (k::ks) (v:::vs) := env.insert k v (insert_all ks vs)

-- Facts
@[simp] lemma get.def (ref : reference) (m : pre_env) :
get ref (quotient.mk m) = match m^.find ref with | none := default _ | some x := x end := rfl

@[simp] lemma insert.def {ref : reference} {x : T ref.2} (m : pre_env) :
insert ref x (quotient.mk m) = quotient.mk (m^.insert ref x) :=
begin apply quotient.sound, apply pre_env.eqv.refl end

@[simp] lemma has_key.def (ref : reference) (m : pre_env) :
has_key ref (quotient.mk m) = m^.contains ref := rfl

@[simp] lemma bool_lift_t (b : bool) : (lift_t b : Prop) = (b = tt) := rfl

-- TODO(dhs): PR to standard library
lemma not_has_key_empty (ref : reference) : ¬ env.has_key ref env.mk :=
begin
simp [mk],
rw hash_map.contains_iff,
simp [hash_map.keys, hash_map.entries, mk_hash_map, bucket_array.as_list,
      mk_array, array.foldl, array.iterate, array.iterate_aux, list.map, array.read],
end

lemma has_key_insert {ref₁ ref₂ : reference} {x₂ : T ref₂.2} {m : env} :
  has_key ref₁ m → has_key ref₁ (insert ref₂ x₂ m) :=
begin
apply @quotient.induction_on _ _ (λ m, has_key ref₁ m → has_key ref₁ (insert ref₂ x₂ m)),
clear m,
intro m,
intro H_hk,
simp at *,
dsimp [hash_map.contains] at *,
rw hash_map.find_insert,
cases decidable.em (ref₂ = ref₁) with H_eq H_neq,
{
subst H_eq,
simp [dif_ctx_simp_congr, dif_pos],
dunfold option.is_some,
reflexivity,
},
{
simp [H_neq, dif_ctx_simp_congr, dif_neg],
exact H_hk
}
end

lemma has_key_insert_same (ref : reference) {x : T ref.2} (m : env) : has_key ref (insert ref x m) :=
begin
apply quotient.induction_on m,
clear m,
intro m,
simp,
dunfold hash_map.contains,
rw hash_map.find_insert_eq,
dsimp [option.is_some],
reflexivity
end

lemma has_key_insert_diff {ref₁ ref₂ : reference} {x : T ref₂.2} {m : env} :
  ref₁ ≠ ref₂ → has_key ref₁ (insert ref₂ x m) → has_key ref₁ m :=
begin
apply @quotient.induction_on _ _ (λ m, ref₁ ≠ ref₂ → has_key ref₁ (insert ref₂ x m) → has_key ref₁ m),
clear m,
simp [hash_map.contains],
intros m H_neq,
rw hash_map.find_insert_ne,
intro H, exact H,
exact ne.symm H_neq
end

lemma get_insert_same (ref : reference) (x : T ref.2) (m : env) : get ref (insert ref x m) = x :=
begin
apply quotient.induction_on m, clear m, intro m,
simp,
rw hash_map.find_insert_eq,
end

lemma get_insert_diff {ref₁ ref₂ : reference} (x₂ : T ref₂.2) (m : env) : ref₁ ≠ ref₂ → get ref₁ (insert ref₂ x₂ m) = get ref₁ m :=
begin
apply @quotient.induction_on _ _ (λ m, ref₁ ≠ ref₂ → get ref₁ (insert ref₂ x₂ m) = get ref₁ m),
clear m,
intros m H_neq,
simp,
rw hash_map.find_insert,
-- TODO(dhs): annoying that we can't simplify inside the major premise
assert H_dif : (dite (ref₂ = ref₁) (λ h, some (eq.rec_on h x₂ : T ref₁.2)) (λ h, hash_map.find m ref₁)) = hash_map.find m ref₁,
simp [dif_ctx_simp_congr, dif_neg, ne.symm H_neq],
rw H_dif,
end

-- TODO(dhs): propagate precondition
lemma insert_get_same {ref : reference} {m : env} : has_key ref m → insert ref (get ref m) m = m :=
begin
apply @quotient.induction_on _ _ (λ m, has_key ref m → insert ref (get ref m) m = m),
clear m,
simp [hash_map.contains],
intros m H_has_key,
apply quotient.sound,
intro ref',
cases decidable.em (ref' = ref) with H_eq H_neq,
{
subst H_eq,
rw hash_map.find_insert_eq,
cases (hash_map.find m ref'),
{ dsimp [option.is_some] at H_has_key, injection H_has_key },
dsimp,
reflexivity
},
{
rw hash_map.find_insert_ne,
exact ne.symm H_neq
}
end

lemma insert_insert_flip {ref₁ ref₂ : reference} (x₁ : T ref₁.2) (x₂ : T ref₂.2) (m : env) :
  ref₁ ≠ ref₂ → insert ref₁ x₁ (insert ref₂ x₂ m) = insert ref₂ x₂ (insert ref₁ x₁ m) :=
begin
apply @quotient.induction_on _ _ (λ m, ref₁ ≠ ref₂ → insert ref₁ x₁ (insert ref₂ x₂ m) = insert ref₂ x₂ (insert ref₁ x₁ m)),
clear m,
simp,
intros m H_neq,
apply quot.sound,
intro ref,
simp [hash_map.find_insert],
cases decidable.em (ref₁ = ref) with H_eq₁ H_neq₁,
cases decidable.em (ref₂ = ref) with H_eq₂ H_neq₂,
{ exfalso, exact H_neq (eq.trans H_eq₁ (eq.symm H_eq₂)) },
{ subst H_eq₁, simp [H_neq₂, dif_ctx_simp_congr, dif_neg, dif_pos] },
cases decidable.em (ref₂ = ref) with H_eq₂ H_neq₂,
{ subst H_eq₂, simp [H_neq₁, dif_ctx_simp_congr, dif_neg, dif_pos] },
{ simp [H_neq₁, H_neq₂, dif_ctx_simp_congr, dif_neg], }
end

lemma insert_insert_same (ref : reference) (x₁ x₂ : T ref.2) (m : env) :
  insert ref x₁ (insert ref x₂ m) = insert ref x₁ m :=
begin
apply quotient.induction_on m,
clear m,
simp,
intros m,
apply quot.sound,
intro ref',
cases decidable.em (ref' = ref) with H_eq H_neq,
{ subst H_eq, simp [hash_map.find_insert_eq] },
-- TODO(dhs): simp fails for annoying reasons
rw hash_map.find_insert_ne _ _ _ _ (ne.symm H_neq),
rw hash_map.find_insert_ne _ _ _ _ (ne.symm H_neq),
rw hash_map.find_insert_ne _ _ _ _ (ne.symm H_neq)
end

lemma get_ks_env_eq (m₁ m₂ : env) :
  ∀ (refs : list reference), (∀ (ref : reference), ref ∈ refs → get ref m₁ = get ref m₂) → get_ks refs m₁ = get_ks refs m₂
| [] H := rfl
| (ref::refs) H :=
show get ref m₁ ::: get_ks refs m₁ = get ref m₂ ::: get_ks refs m₂, from
have H_get : get ref m₁ = get ref m₂, from H ref list.mem_of_cons_same,
have H_pre : ∀ (ref : reference), ref ∈ refs → get ref m₁ = get ref m₂, from
  assume r H_r_mem,
  H r (list.mem_cons_of_mem _ H_r_mem),
by rw [H_get, get_ks_env_eq _ H_pre]

lemma get_ks_insert_diff :
  ∀ {refs : list reference} {ref : reference} {x : T ref.2} {m : env}, ref ∉ refs → get_ks refs (insert ref x m) = get_ks refs m
| [] _ _ _ _ := rfl
| (ref::refs) ref₀ x m H_ref₀_notin :=
show get ref (insert ref₀ x m) ::: get_ks refs (insert ref₀ x m) = get ref m ::: get_ks refs m, from
have H_ne : ref ≠ ref₀, from ne.symm (list.ne_of_not_mem_cons H_ref₀_notin),
begin
rw (env.get_insert_diff _ _ H_ne),
rw get_ks_insert_diff (list.not_mem_of_not_mem_cons H_ref₀_notin),
end

lemma dvec_update_at_env {refs : list reference} {idx : ℕ} {ref : reference} (m : env) :
      list.at_idx refs idx ref →
      dvec.update_at (get ref m) (get_ks refs m) idx = get_ks refs m :=
begin
intro H_at_idx,
assert H_elem_at_idx : list.elem_at_idx refs idx ref, { exact list.elem_at_idx_of_at_idx H_at_idx },
induction H_elem_at_idx with xs x xs idx' x y H_elem_at_idx IH,
{ dsimp [get_ks], simp [dif_ctx_simp_congr, dif_pos] },
{ dsimp [get_ks], erw IH (list.at_idx_of_cons H_at_idx) }
end

lemma dvec_get_get_ks {refs : list reference} {idx : ℕ} {ref : reference} (m : env) :
      list.at_idx refs idx ref →
      dvec.get ref.2 (get_ks refs m) idx = get ref m :=
begin
intro H_at_idx,
assert H_elem_at_idx : list.elem_at_idx refs idx ref, { exact list.elem_at_idx_of_at_idx H_at_idx },
induction H_elem_at_idx with xs x xs idx' x y H_elem_at_idx IH,
{ dunfold get_ks, erw dvec.get.equations._eqn_2, simp [dif_ctx_simp_congr, dif_pos] },
{ dunfold get_ks, erw dvec.get.equations._eqn_3, exact IH (list.at_idx_of_cons H_at_idx) }
end

end env
attribute [semireducible] pre_env
end certigrad


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import ring_theory.subsemiring.pointwise
import group_theory.subgroup.pointwise
import ring_theory.subring.basic

/-! # Pointwise instances on `subring`s

This file provides the action `subring.pointwise_mul_action` which matches the action of
`mul_action_set`.

This actions is available in the `pointwise` locale.

## Implementation notes

This file is almost identical to `ring_theory/subsemiring/pointwise.lean`. Where possible, try to
keep them in sync.

-/

variables {M R : Type*}

namespace subring

section monoid
variables [monoid M] [ring R] [mul_semiring_action M R]

/-- The action on a subring corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action M (subring R) :=
{ smul := λ a S, S.map (mul_semiring_action.to_ring_hom _ _ a),
  one_smul := λ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact one_smul M)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (ring_hom.ext $ by exact mul_smul _ _)).trans (S.map_map _ _).symm }

localized "attribute [instance] subring.pointwise_mul_action" in pointwise
open_locale pointwise

lemma pointwise_smul_def {a : M} (S : subring R) :
  a • S = S.map (mul_semiring_action.to_ring_hom _ _ a) := rfl

@[simp] lemma coe_pointwise_smul (m : M) (S : subring R) : ↑(m • S) = m • (S : set R) := rfl

@[simp] lemma pointwise_smul_to_add_subgroup (m : M) (S : subring R) :
  (m • S).to_add_subgroup = m • S.to_add_subgroup := rfl

@[simp] lemma pointwise_smul_to_subsemiring (m : M) (S : subring R) :
  (m • S).to_subsemiring = m • S.to_subsemiring := rfl

lemma smul_mem_pointwise_smul (m : M) (r : R) (S : subring R) : r ∈ S → m • r ∈ m • S :=
(set.smul_mem_smul_set : _ → _ ∈ m • (S : set R))

end monoid

section group
variables [group M] [ring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff {a : M} {S : subring R} {x : R} :
  a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {a : M} {S : subring R} {x : R} :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem

lemma mem_inv_pointwise_smul_iff {a : M} {S : subring R} {x : R} : x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {a : M} {S T : subring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff

lemma pointwise_smul_subset_iff {a : M} {S T : subring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff

lemma subset_pointwise_smul_iff {a : M} {S T : subring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff

/-! TODO: add `equiv_smul` like we have for subgroup. -/

end group

section group_with_zero
variables [group_with_zero M] [ring R] [mul_semiring_action M R]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subring R)
  (x : R) : a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff₀ ha (S : set R) x

lemma mem_pointwise_smul_iff_inv_smul_mem₀ {a : M} (ha : a ≠ 0) (S : subring R) (x : R) :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem₀ ha (S : set R) x

lemma mem_inv_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) (S : subring R) (x : R) :
  x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff₀ ha (S : set R) x

@[simp] lemma pointwise_smul_le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff₀ ha

lemma pointwise_smul_le_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff₀ ha

lemma le_pointwise_smul_iff₀ {a : M} (ha : a ≠ 0) {S T : subring R} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff₀ ha

end group_with_zero

end subring


import sheaves.locally_ringed_space
import instances.affine_scheme

universes u v w

instance ring_equiv.hom {α : Type u} {β : Type v} [ring α] [ring β] (e : α ≃+* β) : is_ring_hom e :=
ring_hom.is_ring_hom e.to_ring_hom

def opens.indefinite_description {α : Type u} [topological_space α] (p : topological_space.opens α → Prop) (hp : ∃ U, p U) : {U // p U} :=
⟨⟨↑(classical.some hp), subtype.property _⟩, by rw subtype.coe_eta; exact classical.some_spec hp⟩

def opens.some {α : Type u} [topological_space α] {p : topological_space.opens α → Prop} (hp : ∃ U, p U) : topological_space.opens α :=
(opens.indefinite_description p hp).1

theorem opens.some_spec {α : Type u} [topological_space α] {p : topological_space.opens α → Prop} (hp : ∃ U, p U) : p (opens.some hp) :=
(opens.indefinite_description p hp).2

section presheaf_of_rings

variables {α : Type u} [topological_space α]
variables (F : presheaf_of_rings α)
variables (U V : topological_space.opens α) (HVU : V ⊆ U)
variables (x y : F U)

@[simp] lemma res_add : F.res U V HVU (x + y) = F.res U V HVU x + F.res U V HVU y := is_ring_hom.map_add _
@[simp] lemma res_zero : F.res U V HVU 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma res_neg : F.res U V HVU (-x) = -F.res U V HVU x := is_ring_hom.map_neg _
@[simp] lemma res_sub : F.res U V HVU (x - y) = F.res U V HVU x - F.res U V HVU y := is_ring_hom.map_sub _
@[simp] lemma res_mul : F.res U V HVU (x * y) = F.res U V HVU x * F.res U V HVU y := is_ring_hom.map_mul _
@[simp] lemma res_one : F.res U V HVU 1 = 1 := is_ring_hom.map_one _

end presheaf_of_rings

section presheaf_of_rings_on_basis

variables {α : Type u} [topological_space α] {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B)
variables (F : presheaf_of_rings_on_basis α HB)
variables (U V : topological_space.opens α) (HUB : U ∈ B) (HVB : V ∈ B) (HVU : V ⊆ U)
variables (x y : F.F HUB)

@[simp] lemma bres_add : F.res HUB HVB HVU (x + y) = F.res HUB HVB HVU x + F.res HUB HVB HVU y := is_ring_hom.map_add _
@[simp] lemma bres_zero : F.res HUB HVB HVU 0 = 0 := is_ring_hom.map_zero _
@[simp] lemma bres_neg : F.res HUB HVB HVU (-x) = -F.res HUB HVB HVU x := is_ring_hom.map_neg _
@[simp] lemma bres_sub : F.res HUB HVB HVU (x - y) = F.res HUB HVB HVU x - F.res HUB HVB HVU y := is_ring_hom.map_sub _
@[simp] lemma bres_mul : F.res HUB HVB HVU (x * y) = F.res HUB HVB HVU x * F.res HUB HVB HVU y := is_ring_hom.map_mul _
@[simp] lemma bres_one : F.res HUB HVB HVU 1 = 1 := is_ring_hom.map_one _

end presheaf_of_rings_on_basis

theorem is_unit.map'' {α : Type u} [monoid α] {β : Type v} [monoid β] {y : β}
  (f : α → β) [is_monoid_hom f] (x : α) (hx : is_unit x) (hxy : f x = y) : is_unit y :=
hxy ▸ hx.map' f

section opens_comap

open topological_space lattice lattice.lattice

variables {α : Type u} [topological_space α]
variables {β : Type v} [topological_space β]
variables {f : α → β} (Hf : continuous f)

@[mono] theorem opens.comap_mono' (U V : opens β) (HUV : U ≤ V) : opens.comap Hf U ≤ opens.comap Hf V :=
set.preimage_mono HUV

@[simp] lemma opens.comap_top : opens.comap Hf ⊤ = ⊤ :=
opens.ext set.preimage_univ

end opens_comap

namespace topological_space

namespace opens

variables {X : Type u} [topological_space X] {B : set (opens X)} (HB : is_basis B)

def covering_of_is_basis (U : opens X) : covering U :=
⟨λ V : { V : opens X // V ∈ B ∧ V ⊆ U }, V,
opens.ext $ set.subset.antisymm (set.sUnion_subset $ λ s ⟨t, ⟨V, hVt⟩, hts⟩, hts ▸ hVt ▸ V.2.2) $
let ⟨S, HSB, HUS⟩ := is_basis_iff_cover.1 HB U in HUS.symm ▸ set.sUnion_subset (λ s ⟨V, HVS, HVs⟩, HVs ▸ set.subset_sUnion_of_mem
  ⟨V, ⟨⟨V, HSB HVS, set.subset_sUnion_of_mem ⟨V, HVS, rfl⟩⟩, rfl⟩, rfl⟩)⟩

variables (B)
def of_is_basis (U : opens X) (i : U) : opens X :=
⟨@classical.epsilon (opens X) ⟨⊥⟩ (λ V, i.1 ∈ V ∧ V ∈ B ∧ V ⊆ U), subtype.property _⟩
variables {B}

theorem of_is_basis_spec {U : opens X} {i : U} : i.1 ∈ of_is_basis B U i ∧ of_is_basis B U i ∈ B ∧ of_is_basis B U i ⊆ U :=
have ∀ i : U, ∃ V : opens X, i.1 ∈ V ∧ V ∈ B ∧ V ⊆ U,
from let ⟨S, HSB, HUS⟩ := is_basis_iff_cover.1 HB U in HUS.symm ▸ λ i,
  let ⟨t, ⟨V, HVS, rfl⟩, hiV⟩ := set.mem_sUnion.1 i.2 in ⟨V, hiV, HSB HVS, set.subset_sUnion_of_mem ⟨V, HVS, rfl⟩⟩,
by rw [of_is_basis, subtype.coe_eta]; exact classical.epsilon_spec (this i)

theorem mem_of_is_basis {U : opens X} {i : U} : i.1 ∈ of_is_basis B U i :=
(of_is_basis_spec HB).1

theorem of_is_basis_mem_basis {U : opens X} {i : U} : of_is_basis B U i ∈ B:=
(of_is_basis_spec HB).2.1

theorem of_is_basis_subset {U : opens X} {i : U} : of_is_basis B U i ⊆ U :=
(of_is_basis_spec HB).2.2

def covering_of_is_basis' (U : opens X) : covering U :=
⟨λ i : U, of_is_basis B U i,
opens.ext $ set.subset.antisymm (set.sUnion_subset $ λ s ⟨t, ⟨i, hit⟩, hts⟩, hts ▸ hit ▸ (of_is_basis_subset HB)) $
λ i hiu, set.mem_sUnion.2 ⟨of_is_basis B U ⟨i, hiu⟩, set.mem_image_of_mem _ $ set.mem_range_self _, mem_of_is_basis HB⟩⟩

def covering_of_opens (U : opens X) (f : Π i : U, opens X) (hf : ∀ i : U, i.1 ∈ f i) : covering U :=
⟨λ i, f i ∩ U,
opens.ext $ set.subset.antisymm (set.sUnion_subset $ λ s ⟨t, ⟨i, hit⟩, hts⟩, hts ▸ hit ▸ set.inter_subset_right (f i) U) $
λ i hiu, set.mem_sUnion.2 ⟨f ⟨i, hiu⟩ ∩ U, set.mem_image_of_mem _ $ set.mem_range_self _, hf ⟨i, hiu⟩, hiu⟩⟩

def covering_comap {Y : Type u} [topological_space Y] {f : X → Y} (Hf : continuous f)
  (V : opens Y) (OC : covering V) : covering (opens.comap Hf V) :=
{ γ := OC.γ,
  Uis := λ i, opens.comap Hf (OC.Uis i),
  Hcov := opens.ext $ set.subset.antisymm (set.sUnion_subset $ λ t ⟨U, ⟨V, hVU⟩, hUt⟩, hUt ▸ hVU ▸ set.preimage_mono (subset_covering V)) $
    λ i hi, let ⟨V, ⟨U, ⟨j, hjU⟩, hUV⟩, hfiV⟩ := set.mem_sUnion.1 (((set.ext_iff _ _).1 (congr_arg subtype.val OC.Hcov) (f i)).2 hi) in
    set.mem_sUnion.2 ⟨f ⁻¹' V, ⟨opens.comap Hf ⟨V, hUV ▸ U.2⟩, ⟨j, congr_arg (opens.comap Hf) $ hjU.trans $ by exact subtype.eq hUV⟩, rfl⟩, hfiV⟩ }

end opens

end topological_space

instance presheaf_of_rings.comm_ring {α : Type u} [topological_space α]
  (f : presheaf_of_rings α) (U : topological_space.opens α) : comm_ring (f U) := f.Fring U

instance sheaf_of_rings.has_coe_to_fun {α : Type u} [topological_space α] :
  has_coe_to_fun (sheaf_of_rings.{u v} α) :=
⟨λ _, topological_space.opens α → Type v, λ F, F.F⟩

instance sheaf_of_rings.comm_ring {α : Type u} [topological_space α]
  (f : sheaf_of_rings α) (U : topological_space.opens α) : comm_ring (f U) := f.F.Fring U

attribute [instance] to_stalk.is_ring_hom
attribute [irreducible] sheaf_on_standard_basis.is_sheaf_on_standard_basis

def to_Spec_top (R : Type v) [comm_ring R] : R → (Spec.locally_ringed_space R).O ⊤ :=
to_presheaf_of_rings_extension (D_fs_standard_basis R) (structure_presheaf_on_basis R) (D_fs_standard_basis R).1 ∘ localization.of

instance (R : Type v) [comm_ring R] : is_ring_hom (to_Spec_top R) :=
@@is_ring_hom.comp _ _ _ _ _ _ $ to_presheaf_of_rings_extension.is_ring_hom _ _ _

namespace locally_ringed_space

variables {X : Type u} [topological_space X] (OX : locally_ringed_space X)

def D' (f : OX.O ⊤) : set X := { x | is_unit (to_stalk OX.O.F x ⊤ trivial f) }

theorem is_open_D' (f : OX.O ⊤) : is_open (OX.D' f) :=
begin
  refine is_open_iff_forall_mem_open.2 (λ x hxf, _),
  cases is_unit_iff_exists_inv.1 hxf with y hxy,
  refine quotient.induction_on y (λ g hfg, _) hxy,
  cases g with U hxU g, rcases quotient.exact hfg with ⟨V, hxV, HVU', HVtop, hfgV⟩,
  exact ⟨V, λ y hyV, is_unit_iff_exists_inv.2 ⟨to_stalk ((OX.O).F) y U (HVU' hyV).2 g, quotient.sound ⟨V, hyV, HVU', HVtop, hfgV⟩⟩, V.2, hxV⟩
end

def D (f : OX.O ⊤) : topological_space.opens X :=
⟨OX.D' f, OX.is_open_D' f⟩

theorem is_unit_res_D (f : OX.O ⊤) : is_unit (OX.O.F.res ⊤ (OX.D f) (set.subset_univ _) f) :=
begin
  rw is_unit_iff_exists_inv,
  have : ∀ i : OX.D f, ∃ U : topological_space.opens X, ∃ H : i.1 ∈ U, ∃ g : OX.O U, OX.O.F.res ⊤ U (set.subset_univ U.1) f * g = 1,
  { refine λ ⟨i, hi⟩, exists.elim (is_unit_iff_exists_inv.1 hi) (λ gq, quotient.induction_on gq $
      λ ⟨U, hiU, g⟩ H, let ⟨V, hiV, HVU, HVtop, hfgV⟩ := quotient.exact H in
      ⟨V, hiV, OX.O.F.res U V (λ j hjv, (HVU hjv).2) g,
      begin
        dsimp only at hfgV,
        rw [res_mul, ← presheaf.Hcomp', ← presheaf.Hcomp'] at hfgV,
        convert hfgV.trans (res_one _ _ _ _)
      end⟩), },
  choose U hu g hg,
  have, refine OX.O.gluing (topological_space.opens.covering_of_opens (OX.D f) U hu) _ _,
  { exact (λ i, OX.O.F.res _ _ (set.inter_subset_left _ _) (g i)) },
  { intros j k, dsimp only [res_to_inter_left, res_to_inter_right, topological_space.opens.covering_of_opens],
    iterate 2 { rw ← presheaf.Hcomp' },
    have hj : (U j ∩ D OX f) ∩ (U k ∩ D OX f) ⊆ U j :=
      set.subset.trans (set.inter_subset_left _ _) (set.inter_subset_left _ _),
    have : set.subset.trans (res_to_inter_left._proof_1 (U j ∩ D OX f) (U k ∩ D OX f))
      (set.inter_subset_left ((U j).val) ((D OX f).val)) = hj := rfl, rw this at *, clear this,
    have hk : (U j ∩ D OX f) ∩ (U k ∩ D OX f) ⊆ U k :=
      set.subset.trans (set.inter_subset_right _ _) (set.inter_subset_left _ _),
    have : set.subset.trans (res_to_inter_right._proof_1 (U j ∩ D OX f) (U k ∩ D OX f))
      (set.inter_subset_left ((U k).val) ((D OX f).val)) = hk := rfl, rw this at *, clear this,
    have := congr_arg (OX.O.F.res (U k) ((U j ∩ D OX f) ∩ (U k ∩ D OX f)) hk) (hg k),
    rw [res_mul, res_one] at this,
    rw [← presheaf.Hcomp', presheaf.Hcomp' _ ⊤ (U j) _ hj (set.subset_univ _)] at this,
    rw [← mul_one (OX.O.F.res (U j) ((U j ∩ D OX f) ∩ (U k ∩ D OX f)) _ (g j)), ← this],
    rw [← mul_assoc, ← res_mul, mul_comm (g j), hg j, res_one, one_mul] },
  cases this with S hS, use S, apply OX.O.locality (topological_space.opens.covering_of_opens (D OX f) U hu),
  intros i, specialize hS i,
  rw [res_mul, hS, ← presheaf.Hcomp'],
  rw [presheaf.Hcomp' _ ⊤ (U i) ((topological_space.opens.covering_of_opens (D OX f) U hu).Uis i)
        (set.inter_subset_left ((U i).val) ((D OX f).val)) (set.subset_univ _)],
  rw [← res_mul, hg, res_one, res_one]
end

end locally_ringed_space

namespace sheaf_of_rings

open topological_space
variables {X : Type u} [topological_space X]
variables {B : set (opens X)} (HB : opens.is_basis B) (Bstd : opens.univ ∈ B ∧ ∀ {U V}, U ∈ B → V ∈ B → U ∩ V ∈ B)
variables (O : sheaf_of_rings X)
include HB
set_option pp.universes true

theorem ext (U : opens X) (f g : O U) (hfg : ∀ x ∈ U, to_stalk O.F x U H f = to_stalk O.F x U H g) : f = g :=
begin
  have := λ x : U, quotient.exact (hfg x.1 x.2), choose C hc1 hc2 hc3 hc4,
  refine O.locality (opens.covering_of_opens U C hc1) f g (λ i, _),
  calc  O.F.res U (C i ∩ U) _ f
      = O.F.res (C i) (C i ∩ U) (set.inter_subset_left _ _) (O.F.res U (C i) _ f) : presheaf.Hcomp' _ _ _ _ _ _ _
  ... = O.F.res (C i) (C i ∩ U) _ (O.F.res U (C i) _ g) : congr_arg _ (hc4 i)
  ... = O.F.res U (C i ∩ U) _ g : (presheaf.Hcomp' _ _ _ _ _ _ _).symm
end

theorem is_sheaf_on_standard_basis_presheaf_of_rings_to_presheaf_of_rings_on_basis :
  sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd (presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F : presheaf_of_rings_on_basis X HB).to_presheaf_on_basis :=
begin
  dsimp only [sheaf_on_standard_basis.is_sheaf_on_standard_basis],
  intros U HUB OC, exact ⟨O.locality OC.to_covering, O.gluing OC.to_covering⟩
end

noncomputable def of_extension_basis (U : opens X) (HUB : U ∈ B)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U) : O U :=
classical.some $ to_presheaf_of_rings_extension.surjective Bstd (presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)
  (is_sheaf_on_standard_basis_presheaf_of_rings_to_presheaf_of_rings_on_basis HB Bstd O) HUB f

def of_extension.aux1 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U) : opens X :=
opens.some $ f.2 i.1 i.2

theorem of_extension.aux2 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U) :
  of_extension.aux1 HB Bstd U f i ∈ B :=
classical.some $ opens.some_spec $ f.2 i.1 i.2

theorem of_extension.aux3 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U) :
  i.1 ∈ of_extension.aux1 HB Bstd U f i :=
classical.some $ classical.some_spec $ opens.some_spec $ f.2 i.1 i.2

noncomputable def of_extension.aux4 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U) :
  F.to_presheaf_on_basis (of_extension.aux2 HB Bstd U f i) :=
classical.some $ classical.some_spec $ classical.some_spec $ opens.some_spec $ f.2 i.1 i.2

theorem of_extension.aux5 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U) :
  ∀ (y : X) (H : y ∈ U ∩ of_extension.aux1 HB Bstd U f i),
    f.1 y = λ (_x : y ∈ U), ⟦{U := of_extension.aux1 HB Bstd U f i, BU := _, Hx := H.2, s := of_extension.aux4 HB Bstd U f i}⟧ :=
classical.some_spec $ classical.some_spec $ classical.some_spec $ opens.some_spec $ f.2 i.1 i.2

theorem of_extension.aux6 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U)
  (y : X) (hyU : y ∈ U) (hyi : y ∈ of_extension.aux1 HB Bstd U f i) :
  ⟦quotient.out (f.1 y hyU)⟧ = ⟦{U := of_extension.aux1 HB Bstd U f i, BU := _, Hx := hyi, s := of_extension.aux4 HB Bstd U f i}⟧ :=
by rw [of_extension.aux5 HB Bstd U f i y ⟨hyU, hyi⟩, quotient.out_eq]

theorem of_extension.aux7 {F : presheaf_of_rings_on_basis X HB} (U : opens X) (f : (F ᵣₑₓₜ Bstd) U) (i : U)
  (y : X) (hyU : y ∈ U) (hyi : y ∈ of_extension.aux1 HB Bstd U f i) :
  quotient.out (f.1 y hyU) ≈ {U := of_extension.aux1 HB Bstd U f i, BU := _, Hx := hyi, s := of_extension.aux4 HB Bstd U f i} :=
quotient.exact $ of_extension.aux6 HB Bstd U f i y hyU hyi

lemma of_extension.aux8 (U : opens X)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U) :
  ∃ f' : O U, ∀ i : U,
    O.F.res U ((opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) (of_extension.aux3 HB Bstd U f)).Uis i)
      (subset_covering i)
      f' =
    O.F.res (of_extension.aux1 HB Bstd U f i) _ (set.inter_subset_left _ _)
      (of_extension.aux4 HB Bstd U f i) :=
begin
  refine quotient.induction_on
    (quotient.choice (λ i:U, (f.1 i.1 i.2 : stalk_on_basis ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd (O.F)).to_presheaf_on_basis) i.1)))
    (λ f', _),
  have, refine (O.gluing (opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) (of_extension.aux3 HB Bstd U f)) _ _),
  { exact (λ i, O.F.res _ _ (set.inter_subset_left _ _) $ of_extension.aux4 HB Bstd U f i) },
  { have := of_extension.aux7 HB Bstd U f, choose g hg1 hg2 hg3 hg4 hg5,
    refine (λ j k : U, O.locality (opens.covering_of_opens _
        (λ i, g j i.1 i.2.1.2 i.2.1.1 ∩ g k i.1 i.2.2.2 i.2.2.1)
        (λ i, ⟨hg2 _ _ _ _, hg2 _ _ _ _⟩)) _ _ _),
    intros i, dsimp only [opens.covering_of_opens, res_to_inter_left, res_to_inter_right],
    iterate 4 { rw ← presheaf.Hcomp' },
    have hg5j := hg5 j i.1 i.2.1.2 i.2.1.1, have hg5k := hg5 k i.1 i.2.2.2 i.2.2.1,
    dsimp only [presheaf_of_rings_to_presheaf_of_rings_on_basis] at hg5j hg5k,
    rw [O.F.to_presheaf.Hcomp' (of_extension.aux1 HB Bstd U f j) (g j i.1 i.2.1.2 i.2.1.1), ← hg5j],
    rw [O.F.to_presheaf.Hcomp' (of_extension.aux1 HB Bstd U f k) (g k i.1 i.2.2.2 i.2.2.1), ← hg5k],
    iterate 2 { rw ← presheaf.Hcomp' },
    { exact set.subset.trans (set.inter_subset_left _ _) (set.inter_subset_right _ _) },
    { exact set.subset.trans (set.inter_subset_left _ _) (set.inter_subset_left _ _) } },
  exact this
end

noncomputable def of_extension (U : opens X)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U) : O U :=
classical.some $ of_extension.aux8 HB Bstd O U f

lemma of_extension_spec' (U : opens X)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U) :
  ∀ i : U,
    O.F.res U ((opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) (of_extension.aux3 HB Bstd U f)).Uis i)
      (subset_covering i)
      (of_extension HB Bstd O U f) =
    O.F.res (of_extension.aux1 HB Bstd U f i) _ (set.inter_subset_left _ _)
      (of_extension.aux4 HB Bstd U f i) :=
classical.some_spec $ of_extension.aux8 HB Bstd O U f

lemma of_extension_spec (U : opens X)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U)
  (x : X) (hxU : x ∈ U) :
  ∃ (V : opens X) (HVB : V ∈ B) (hxV : x ∈ V) (HVU : V ⊆ U), f.1 x hxU = ⟦⟨V, HVB, hxV, O.F.res U V HVU (of_extension HB Bstd O U f)⟩⟧ :=
begin
  have hx : x ∈ of_extension.aux1 HB Bstd U f ⟨x, hxU⟩ ∩ U := ⟨of_extension.aux3 HB Bstd U f ⟨x, hxU⟩, hxU⟩,
  rcases opens.is_basis_iff_nbhd.1 HB hx with ⟨V, HVB, hxV, HV⟩,
  refine ⟨V, HVB, hxV, set.subset.trans HV (set.inter_subset_right _ _), _⟩,
  rw [congr_fun (of_extension.aux5 HB Bstd U f ⟨x, hxU⟩ x ⟨hxU, of_extension.aux3 HB Bstd U f ⟨x, hxU⟩⟩) hxU],
  refine quotient.sound ⟨V, HVB, hxV, set.subset.trans HV (set.inter_subset_left _ _), set.subset.refl _, _⟩,
  dsimp only [presheaf_of_rings_to_presheaf_of_rings_on_basis], rw [← presheaf.Hcomp'],
  calc  O.F.res (of_extension.aux1 HB Bstd U f ⟨x, hxU⟩) V _ (of_extension.aux4 HB Bstd U f ⟨x, hxU⟩)
      = O.F.res ((opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) _).Uis ⟨x, hxU⟩) V _
          (O.F.res (of_extension.aux1 HB Bstd U f ⟨x, hxU⟩)
            ((opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) _).Uis ⟨x, hxU⟩) _
            (of_extension.aux4 HB Bstd U f ⟨x, hxU⟩)) : presheaf.Hcomp' _ _ _ _ _ _ _
  ... = O.F.res ((opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) _).Uis ⟨x, hxU⟩) V HV
          (O.F.res U ((opens.covering_of_opens U (of_extension.aux1 HB Bstd U f) _).Uis ⟨x, hxU⟩) _
            (of_extension HB Bstd O U f)) : congr_arg _ (of_extension_spec' HB Bstd O U f ⟨x, hxU⟩).symm
  ... = O.F.res U V _ (of_extension HB Bstd O U f) : (presheaf.Hcomp' _ _ _ _ _ _ _).symm
end

theorem of_extension_res (U V : opens X) (HVU : V ⊆ U)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U) :
  of_extension HB Bstd O V (presheaf.res _ U V HVU f) = O.F.res U V HVU (of_extension HB Bstd O U f) :=
begin
  apply sheaf_of_rings.ext, { exact HB }, intros x hxV, apply quotient.sound,
  rcases of_extension_spec HB Bstd O U f x (HVU hxV) with ⟨W1, HWB1, hxW1, HWU1, hw1⟩,
  rcases of_extension_spec HB Bstd O V (presheaf.res _ U V HVU f) x hxV with ⟨W2, HWB2, hxW2, HWV2, hw2⟩,
  rcases quotient.exact (hw1.symm.trans hw2) with ⟨W3, HWB3, hxW3, HW31, HW32, hw3⟩,
  refine ⟨W3, hxW3, set.subset.trans HW32 HWV2, set.subset.trans HW32 HWV2, _⟩,
  change O.F.res W1 W3 HW31 (O.F.res U W1 HWU1 (of_extension HB Bstd O U f)) =
    O.F.res W2 W3 HW32 (O.F.res V W2 HWV2 (of_extension HB Bstd O V $ presheaf.res _ U V HVU f)) at hw3,
  change O.F.res V W3 _ (of_extension HB Bstd O V $ presheaf.res _ U V HVU f) =
    (O.F.res V W3 _ (O.F.res U V HVU (of_extension HB Bstd O U f))),
  rw [← presheaf.Hcomp', ← presheaf.Hcomp'] at hw3, rw [← presheaf.Hcomp'], exact hw3.symm
end
set_option pp.proofs true

def to_extension (U : opens X) (f : O U) :
  ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F : presheaf_of_rings_on_basis X HB)ᵣₑₓₜ Bstd) U :=
{ val := λ x hxU, ⟦{ U := opens.some (opens.is_basis_iff_nbhd.1 HB hxU),
    BU := classical.some $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hxU),
    Hx := (classical.some_spec $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hxU)).1,
    s := O.F.res _ _ (classical.some_spec $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hxU)).2 f }⟧,
  property := λ x hxU, ⟨opens.some (opens.is_basis_iff_nbhd.1 HB hxU),
    classical.some $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hxU),
    (classical.some_spec $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hxU)).1,
    O.F.res _ _ (classical.some_spec $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hxU)).2 f,
    λ y hy, funext $ λ hyU, have y ∈ opens.some (opens.is_basis_iff_nbhd.1 HB hxU) ∩ opens.some (opens.is_basis_iff_nbhd.1 HB hyU),
      from ⟨hy.2, (classical.some_spec $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB hyU)).1⟩,
      let ⟨V, HVB, hyV, HV⟩ := opens.is_basis_iff_nbhd.1 HB this in quotient.sound $
      ⟨V, HVB, hyV, set.subset.trans HV (set.inter_subset_right _ _),
        set.subset.trans HV (set.inter_subset_left _ _),
        show O.F.res _ _ _ (O.F.res _ _ _ _) = O.F.res _ _ _ (O.F.res _ _ _ _),
        by rw [← presheaf.Hcomp', ← presheaf.Hcomp']⟩⟩ }

theorem of_to_extension (U : opens X) (f : O U) :
  of_extension HB Bstd O U (to_extension HB Bstd O U f) = f :=
begin
  apply sheaf_of_rings.ext, { exact HB }, intros x hxU,
  rcases of_extension_spec HB Bstd O U (to_extension HB Bstd O U f) x hxU with ⟨V, HVB, hsV, HVU, hv⟩,
  rcases quotient.exact hv with ⟨W, HWB, hxW, HW1, HW2, hw⟩,
  refine quotient.sound ⟨W, hxW, set.subset.trans HW2 HVU, set.subset.trans HW2 HVU, _⟩,
  change O.F.res _ _ _ (O.F.res _ _ _ _) = O.F.res _ _ _ (O.F.res _ _ _ _) at hw,
  rw [← presheaf.Hcomp', ← presheaf.Hcomp'] at hw, exact hw.symm
end

theorem to_of_extension (U : opens X)
  (f : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U) :
  to_extension HB Bstd O U (of_extension HB Bstd O U f) = f :=
subtype.eq $ funext $ λ x, funext $ λ hxU, eq.symm $ let ⟨V, HVB, hxV, HVU, hv⟩ := of_extension_spec HB Bstd O U f x hxU in
have x ∈ V ∩ classical.some (to_extension._proof_1 HB U x hxU) := ⟨hxV, to_extension._proof_3 HB U x hxU⟩,
let ⟨W, HWB, hxW, HWV⟩ := opens.is_basis_iff_nbhd.1 HB this in
hv.trans $ quotient.sound ⟨W, HWB, hxW, set.subset.trans HWV (set.inter_subset_left _ _), set.subset.trans HWV (set.inter_subset_right _ _),
show O.F.res _ _ _ (O.F.res _ _ _ _) = O.F.res _ _ _ (O.F.res _ _ _ _),
by rw [← presheaf.Hcomp', ← presheaf.Hcomp']⟩

instance is_ring_hom_to_extension (U : opens X) : is_ring_hom (to_extension HB Bstd O U) :=
{ map_one := subtype.eq $ funext $ λ x, funext $ λ hxU, quotient.sound
    ⟨opens.some (to_extension._proof_1 HB U x hxU),
    to_extension._proof_2 HB U x hxU, to_extension._proof_3 HB U x hxU,
    set.subset.refl _, set.subset_univ _,
    show O.F.res _ _ _ (O.F.res _ _ _ 1) = O.F.res _ _ _ 1,
    by rw [res_one, res_one, res_one]⟩,
  map_mul := λ s1 s2, subtype.eq $ funext $ λ x, funext $ λ hxU, quotient.sound
    ⟨opens.some (to_extension._proof_1 HB U x hxU),
    to_extension._proof_2 HB U x hxU, to_extension._proof_3 HB U x hxU,
    set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _),
    show O.F.res _ _ _ (O.F.res _ _ _ (s1 * s2)) = O.F.res _ _ _ (O.F.res _ _ _ (O.F.res _ _ _ _) * O.F.res _ _ _ (O.F.res _ _ _ _)),
    by iterate 3 { rw res_mul }; iterate 6 { rw ← presheaf.Hcomp' }⟩,
  map_add := λ s1 s2, subtype.eq $ funext $ λ x, funext $ λ hxU, quotient.sound
    ⟨opens.some (to_extension._proof_1 HB U x hxU),
    to_extension._proof_2 HB U x hxU, to_extension._proof_3 HB U x hxU,
    set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _),
    show O.F.res _ _ _ (O.F.res _ _ _ (s1 + s2)) = O.F.res _ _ _ (O.F.res _ _ _ (O.F.res _ _ _ _) + O.F.res _ _ _ (O.F.res _ _ _ _)),
    by iterate 3 { rw res_add }; iterate 6 { rw ← presheaf.Hcomp' }⟩ }

noncomputable def ring_equiv_extension (U : opens X) :
  O U ≃+* ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U :=
ring_equiv.of
{ to_fun := to_extension HB Bstd O U,
  inv_fun := of_extension HB Bstd O U,
  left_inv := of_to_extension HB Bstd O U,
  right_inv := to_of_extension HB Bstd O U }

instance is_ring_hom_of_extension (U : opens X) : is_ring_hom (of_extension HB Bstd O U) :=
ring_equiv.hom (ring_equiv_extension _ _ _ _).symm

def stalk_on_basis_to_stalk (F : presheaf_of_rings X) (U : opens X) (p : X) (hpU : p ∈ U)
  (σ : stalk_on_basis (presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd F : presheaf_of_rings_on_basis X HB).to_presheaf_on_basis p) :
  stalk_of_rings F p :=
quotient.lift_on σ (λ e, to_stalk F p e.U e.Hx e.s) $ λ e₁ e₂ ⟨V, HVB, hpV, HV1, HV2, HV⟩,
quotient.sound ⟨V, hpV, HV1, HV2, HV⟩

def stalk_to_stalk_on_basis (F : presheaf_of_rings.{u v} X) (U : opens X) (p : X) (hpU : p ∈ U)
  (σ : stalk_of_rings F p) :
  stalk_on_basis (presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd F : presheaf_of_rings_on_basis X HB).to_presheaf_on_basis p :=
quotient.lift_on σ (λ e, (⟦⟨opens.some (opens.is_basis_iff_nbhd.1 HB e.HxU),
    Exists.fst $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB e.HxU),
    and.left $ Exists.snd $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB e.HxU),
    presheaf.res _ _ _ (and.right $ Exists.snd $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB e.HxU)) e.s⟩⟧ :
      stalk_on_basis (presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd F : presheaf_of_rings_on_basis X HB).to_presheaf_on_basis p)) $
λ e₁ e₂ ⟨V, hpV, HV1, HV2, HV⟩,
have p ∈ V ∩ (opens.some (opens.is_basis_iff_nbhd.1 HB e₁.HxU) ∩ opens.some (opens.is_basis_iff_nbhd.1 HB e₂.HxU)),
from ⟨hpV, and.left $ Exists.snd $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB e₁.HxU),
  and.left $ Exists.snd $ opens.some_spec (opens.is_basis_iff_nbhd.1 HB e₂.HxU)⟩,
let ⟨W, HWB, hpW, HWV⟩ := opens.is_basis_iff_nbhd.1 HB this in
quotient.sound ⟨W, HWB, hpW, set.subset.trans HWV (set.subset.trans (set.inter_subset_right _ _) (set.inter_subset_left _ _)),
set.subset.trans HWV (set.subset.trans (set.inter_subset_right _ _) (set.inter_subset_right _ _)),
have _ := congr_arg (F.res _ W (set.subset.trans HWV (set.inter_subset_left _ _))) HV,
show F.res _ _ _ (F.res _ _ _ _) = F.res _ _ _ (F.res _ _ _ _),
by rw [← presheaf.Hcomp', ← presheaf.Hcomp'] at this ⊢; exact this⟩

theorem to_stalk_of_extension (U : opens X)
  (F : ((presheaf_of_rings_to_presheaf_of_rings_on_basis Bstd O.F)ᵣₑₓₜ Bstd) U)
  (p : X) (hpU : p ∈ U) :
  to_stalk O.F p U hpU (of_extension HB Bstd O U F) = stalk_on_basis_to_stalk _ _ _ U _ hpU (F.1 p hpU) :=
let ⟨V, HVB, hpV, HVU, hv⟩ := of_extension_spec HB Bstd O U F p hpU in
hv.symm ▸ quotient.sound ⟨V, hpV, HVU, set.subset.refl V, presheaf.Hcomp' _ _ _ _ _ _ _⟩

end sheaf_of_rings

namespace sheaf_of_rings

variables {α : Type u} [topological_space α]
variables {β : Type u} [topological_space β]

variables {f : α → β} (Hf : continuous f)

def pushforward (O : sheaf_of_rings α) : sheaf_of_rings β :=
{ F := O.F.pushforward Hf,
  locality := λ U OC s t H, O.locality (topological_space.opens.covering_comap Hf U OC) _ _ (λ i, by convert H i),
  gluing := λ U OC s H, by convert O.gluing (topological_space.opens.covering_comap Hf U OC) s H }

end sheaf_of_rings

theorem presheaf.fmap.commutes' {α : Type u} [topological_space α] {β : Type v} [topological_space β]
  {f : α → β} {hf : continuous f} {F : presheaf α} {G : presheaf β} (m : presheaf.fmap hf F G)
  (U V : topological_space.opens β) (HVU : V ⊆ U) (s : G U) (h : opens.comap hf V ⊆ opens.comap hf U) :
  F.res (opens.comap hf U) (opens.comap hf V) h (m.map U s) = m.map V (G.res U V HVU s) :=
(congr_fun (m.commutes U V HVU) s).symm

def presheaf.fmap.stalk {α : Type u} [topological_space α] {β : Type v} [topological_space β]
  {f : α → β} {hf : continuous f} {F : presheaf α} {G : presheaf β} (m : presheaf.fmap hf F G) (x : α) :
  stalk G (f x) → stalk F x :=
quotient.lift (λ s : stalk.elem G (f x), (⟦⟨opens.comap hf s.U, s.HxU, m.map s.U s.s⟩⟧ : stalk F x)) $
λ s1 s2 ⟨U, hfxU, HUs1, HUs2, HU⟩, quotient.sound ⟨opens.comap hf U, hfxU, opens.comap_mono _ _ _ HUs1, opens.comap_mono _ _ _ HUs2,
show F.res (opens.comap hf s1.U) (opens.comap hf U) _ (m.map s1.U s1.s) =
  F.res (opens.comap hf s2.U) (opens.comap hf U) _ (m.map s2.U s2.s),
by rw [m.commutes', m.commutes', HU]⟩

def presheaf.fmap.stalk_of_rings {α : Type u} [topological_space α] {β : Type v} [topological_space β]
  {f : α → β} {hf : continuous f} {F : presheaf_of_rings α} {G : presheaf_of_rings β} (m : presheaf_of_rings.fmap hf F G)
  (x : α) (s : stalk_of_rings G (f x)) : stalk_of_rings F x :=
m.stalk x s

theorem is_ring_hom_stalk_of_rings {α : Type u} [topological_space α] {β : Type v} [topological_space β]
  {f : α → β} {hf : continuous f} {F : presheaf_of_rings α} {G : presheaf_of_rings β} (m : presheaf_of_rings.fmap hf F G) [hm : ∀ U, is_ring_hom (m.map U)]
  (x : α) : is_ring_hom (presheaf.fmap.stalk_of_rings m x) :=
{ map_one := quotient.sound ⟨⊤, trivial, set.subset.refl _, set.subset.refl _, congr_arg _ (is_ring_hom.map_one (m.map ⊤))⟩,
  map_mul := λ s1 s2, quotient.induction_on₂ s1 s2 $ λ e1 e2, quotient.sound ⟨opens.comap hf (e1.U ∩ e2.U),
    ⟨e1.HxU, e2.HxU⟩, set.subset.refl _,
    set.subset_inter (opens.comap_mono _ _ _ (set.inter_subset_left _ _)) (opens.comap_mono _ _ _ (set.inter_subset_right _ _)),
    show F.res (opens.comap hf (e1.U ∩ e2.U)) (opens.comap hf (e1.U ∩ e2.U)) _ (m.map (e1.U ∩ e2.U) (G.res _ _ _ e1.s * G.res _ _ _ e2.s)) =
      F.res (opens.comap hf e1.U ∩ opens.comap hf e2.U) (opens.comap hf (e1.U ∩ e2.U)) _ (F.res _ _ _ (m.map e1.U e1.s) * F.res _ _ _ (m.map e2.U e2.s)),
    by rw [m.commutes' _ _ (set.subset.refl _),
        res_mul,
        is_ring_hom.map_mul (F.res (opens.comap hf e1.U ∩ opens.comap hf e2.U) (opens.comap hf (e1.U ∩ e2.U))
          (set.subset_inter (opens.comap_mono _ _ _ (set.inter_subset_left _ _)) (opens.comap_mono _ _ _ (set.inter_subset_right _ _)))),
        ← presheaf.Hcomp', ← presheaf.Hcomp', ← presheaf.Hcomp', ← presheaf.Hcomp',
        m.commutes' e1.U (e1.U ∩ e2.U) (set.inter_subset_left _ _),
        m.commutes' e2.U (e1.U ∩ e2.U) (set.inter_subset_right _ _),
        is_ring_hom.map_mul (m.map (e1.U ∩ e2.U))]; refl⟩,
  map_add := λ s1 s2, quotient.induction_on₂ s1 s2 $ λ e1 e2, quotient.sound ⟨opens.comap hf (e1.U ∩ e2.U),
    ⟨e1.HxU, e2.HxU⟩, set.subset.refl _,
    set.subset_inter (opens.comap_mono _ _ _ (set.inter_subset_left _ _)) (opens.comap_mono _ _ _ (set.inter_subset_right _ _)),
    show F.res (opens.comap hf (e1.U ∩ e2.U)) (opens.comap hf (e1.U ∩ e2.U)) _ (m.map (e1.U ∩ e2.U) (G.res _ _ _ e1.s + G.res _ _ _ e2.s)) =
      F.res (opens.comap hf e1.U ∩ opens.comap hf e2.U) (opens.comap hf (e1.U ∩ e2.U)) _ (F.res _ _ _ (m.map e1.U e1.s) + F.res _ _ _ (m.map e2.U e2.s)),
    by rw [m.commutes' _ _ (set.subset.refl _),
        is_ring_hom.map_add (G.res (e1.U ∩ e2.U) (e1.U ∩ e2.U) (set.subset.refl _)),
        is_ring_hom.map_add (F.res (opens.comap hf e1.U ∩ opens.comap hf e2.U) (opens.comap hf (e1.U ∩ e2.U))
          (set.subset_inter (opens.comap_mono _ _ _ (set.inter_subset_left _ _)) (opens.comap_mono _ _ _ (set.inter_subset_right _ _)))),
        ← presheaf.Hcomp', ← presheaf.Hcomp', ← presheaf.Hcomp', ← presheaf.Hcomp',
        m.commutes' e1.U (e1.U ∩ e2.U) (set.inter_subset_left _ _),
        m.commutes' e2.U (e1.U ∩ e2.U) (set.inter_subset_right _ _),
        is_ring_hom.map_add (m.map (e1.U ∩ e2.U))]; refl⟩ }

namespace locally_ringed_space

structure morphism {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  {Y : Type v} [topological_space Y] (OY : locally_ringed_space Y) extends morphism OX OY :=
(hom : ∀ U, is_ring_hom (fO.map U))
attribute [instance] morphism.hom

end locally_ringed_space

section tag01I1

variables {X : Type u} [topological_space X] (OX : locally_ringed_space X)
variables (R : Type v) [comm_ring R]

/- https://stacks.math.columbia.edu/tag/01I1 -/
def mor_to_hom (f : OX.morphism (Spec.locally_ringed_space R)) :
  (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤ :=
OX.O.F.res (opens.comap f.Hf ⊤) ⊤ (opens.comap_top f.Hf ▸ set.subset.refl _) ∘ f.fO.map ⊤

instance mor_to_hom.is_ring_hom (f : OX.morphism (Spec.locally_ringed_space R)) :
  is_ring_hom (mor_to_hom OX R f) :=
by unfold mor_to_hom; apply_instance

variables (f : (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤) [is_ring_hom f]

-- variables (R : Type u) [comm_ring R]

def Spec.locally_ringed_space' : locally_ringed_space (Spec R) :=
{ O := structure_sheaf R,
  Hstalks := λ P, structure_sheaf.stalk_local P, }

def induced (x : X) : Spec R :=
⟨ideal.comap (to_stalk OX.O.F x ⊤ trivial ∘ f ∘ to_Spec_top R) (local_ring.nonunits_ideal _),
@ideal.is_prime.comap _ _ _ _ _ _ _ $ (local_ring.nonunits_ideal.is_maximal _).is_prime⟩

@[simp] lemma Spec.DO.val (g : R) : (Spec.DO R g).val = Spec.D' g :=
congr_fun (Spec.DO.val_eq_D' R) g

@[simp] lemma induced_preimage_D' (g : R) :
  induced OX R f ⁻¹' Spec.D' g = OX.D (f $ to_Spec_top R g) :=
set.ext $ λ x, classical.not_not

lemma induced_continuous : continuous (induced OX R f) :=
λ U HU, let ⟨Us, HUs, HUUs⟩ := topological_space.sUnion_basis_of_is_open (D_fs_basis R) HU in
by rw [HUUs, set.preimage_sUnion]; exact is_open_Union (λ S, is_open_Union $ λ HSUs,
let ⟨p, ⟨g, hp⟩, hpS⟩ := HUs HSUs in by rw [← hpS, hp, Spec.DO.val, induced_preimage_D']; exact OX.is_open_D' _)

@[simp] lemma comap_induced_DO (g : R) :
  opens.comap (induced_continuous OX R f) (Spec.DO R g) = OX.D (f $ to_Spec_top R g) :=
topological_space.opens.ext $ induced_preimage_D' OX R f g

noncomputable def induced_basis (U : topological_space.opens $ Spec R) (HUB : U ∈ D_fs R) :
  (structure_presheaf_on_basis R).F HUB → OX.O (opens.comap (induced_continuous OX R f) U) :=
localization.lift (OX.O.F.res ⊤ _ (set.subset_univ _) ∘ f ∘ to_Spec_top R) $ λ r hrSU,
is_unit.map''
  (OX.O.F.res
    (opens.comap (induced_continuous OX R f) (Spec.DO R r))
    (opens.comap (induced_continuous OX R f) U)
    (set.preimage_mono hrSU))
  (OX.O.F.res ⊤ _ (set.subset_univ _) (f $ to_Spec_top R r))
  (by rw comap_induced_DO; exact locally_ringed_space.is_unit_res_D _ _)
  (presheaf.Hcomp' _ _ _ _ _ _ _).symm

noncomputable def induced_stalk_elem (p : Spec R)
  (s : stalk_on_basis.elem (structure_presheaf_on_basis R).to_presheaf_on_basis p) :
  stalk_on_basis.elem
    (presheaf_of_rings_to_presheaf_of_rings_on_basis
      (D_fs_standard_basis R) (presheaf_of_rings.pushforward (induced_continuous OX R f) OX.O.F) :
        presheaf_of_rings_on_basis (Spec R) (D_fs_basis R)).to_presheaf_on_basis
    p :=
⟨s.1, s.2, s.3, induced_basis OX R f s.1 s.2 s.4⟩

noncomputable def induced_stalk (p : Spec R) :
  stalk_of_rings_on_standard_basis.stalk_of_rings_on_standard_basis (D_fs_standard_basis R) (structure_presheaf_on_basis R) p →
  stalk_of_rings_on_standard_basis.stalk_of_rings_on_standard_basis (D_fs_standard_basis R)
    (presheaf_of_rings_to_presheaf_of_rings_on_basis
      (D_fs_standard_basis R) (presheaf_of_rings.pushforward (induced_continuous OX R f) OX.O.F) :
        presheaf_of_rings_on_basis (Spec R) (D_fs_basis R))
    p :=
quotient.lift (λ s, ⟦induced_stalk_elem OX R f p s⟧) $ begin
  rintros s1 s2 ⟨U, HUB, hpU, hUs1, hUs2, hs⟩,
  refine quotient.sound ⟨U, HUB, hpU, hUs1, hUs2, _⟩,
  cases s1 with U1 HUB1 Hx1 s1, cases s2 with U2 HUB2 Hx2 s2,
  dsimp only at hUs1 hUs2, dsimp only [induced_stalk_elem, induced_basis],
  revert hs,
  refine localization.induction_on s1 (λ r1 s1, localization.induction_on s2 (λ r2 s2, _)),
  intros hs, rcases quotient.exact hs with ⟨t, htSU, ht⟩, simp only [subtype.coe_mk] at ht,
  dsimp only [induced_stalk_elem, induced_basis, localization.lift, localization.lift'_mk, function.comp_apply,
    presheaf_of_rings_to_presheaf_of_rings_on_basis, presheaf_of_rings.pushforward, presheaf.pushforward],
  rw [is_ring_hom.map_mul (OX.O.F.res (opens.comap (induced_continuous OX R f) U1)
      (opens.comap (induced_continuous OX R f) U)
      (opens.comap_mono (induced_continuous OX R f) U U1 hUs1))],
  rw [is_ring_hom.map_mul (OX.O.F.res (opens.comap (induced_continuous OX R f) U2)
      (opens.comap (induced_continuous OX R f) U)
      (opens.comap_mono (induced_continuous OX R f) U U2 hUs2))],
  generalize : localization.lift._proof_1 _ _ _ = hu1,
  generalize : localization.lift._proof_1 _ _ _ = hu2,
  dsimp only [function.comp_apply] at hu1 hu2,
  have := classical.some_spec hu2, revert this,
  have := classical.some_spec hu1, revert this,
  cases classical.some hu1 with v1 i1 hvi1 hiv1,
  cases classical.some hu2 with v2 i2 hvi2 hiv2,
  rintros h1 h2, change _ = v1 at h1, subst h1, change _ = v2 at h2, subst h2,
  change _ * OX.O.F.res _ _ _ i1 = _ * OX.O.F.res _ _ _ i2,
  replace ht := congr_arg (λ x, OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _) (f (to_Spec_top R x))) ht,
  dsimp only at ht,
  rw [is_ring_hom.map_mul (to_Spec_top R)] at ht,
  rw [is_ring_hom.map_sub (to_Spec_top R)] at ht,
  rw [is_ring_hom.map_mul (to_Spec_top R)] at ht,
  rw [is_ring_hom.map_mul (to_Spec_top R)] at ht,
  rw [is_ring_hom.map_zero (to_Spec_top R)] at ht,
  rw [is_ring_hom.map_mul f] at ht,
  rw [is_ring_hom.map_sub f] at ht,
  rw [is_ring_hom.map_mul f] at ht,
  rw [is_ring_hom.map_mul f] at ht,
  rw [is_ring_hom.map_zero f] at ht,
  rw [is_ring_hom.map_mul (OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _))] at ht,
  rw [is_ring_hom.map_sub (OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _))] at ht,
  rw [is_ring_hom.map_mul (OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _))] at ht,
  rw [is_ring_hom.map_mul (OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _))] at ht,
  change _ = OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _) 0 at ht,
  rw [is_ring_hom.map_zero (OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U) (set.subset_univ _))] at ht,
  have := OX.is_unit_res_D (f (to_Spec_top R t)), rw ← comap_induced_DO at this,
  replace this := this.map' (OX.O.F.res
    (opens.comap (induced_continuous OX R f) (Spec.DO R t))
    (opens.comap (induced_continuous OX R f) U)
    (opens.comap_mono _ _ _ htSU)),
  rw ← presheaf.Hcomp' at this,
  cases this with u hut,
  change (((OX.O).F).to_presheaf).res ⊤ (opens.comap (induced_continuous OX R f) U)
        (set.subset_univ ((opens.comap (induced_continuous OX R f) U).val))
        (f (to_Spec_top R t)) = _ at hut,
  rw hut at ht, replace ht := congr_arg (λ z : OX.O (opens.comap (induced_continuous OX R f) U), z * (↑(u⁻¹ : units (OX.O (opens.comap (induced_continuous OX R f) U))) : OX.O _)) ht,
  dsimp only at ht, change _ = (0 : OX.O (opens.comap (induced_continuous OX R f) U)) * _ at ht,
  rw [mul_assoc, zero_mul, units.mul_inv, mul_one, sub_eq_zero_iff_eq] at ht,
  rw [← presheaf.Hcomp', presheaf.Hcomp' _ ⊤ (opens.comap (induced_continuous OX R f) U2) (opens.comap (induced_continuous OX R f) U)
      (opens.comap_mono _ _ _ hUs2) (set.subset_univ _)],
  rw [← mul_one (OX.O.F.res ⊤ (opens.comap (induced_continuous OX R f) U2) (set.subset_univ _) (f (to_Spec_top R r1)))],
  change (OX.O.F.res _ _ _ (_ * (1 : OX.O (opens.comap _ U2)))) * _ = _,
  rw [← hvi2, ← mul_assoc, mul_comm (OX.O.F.res _ _ _ (f _))],
  rw [is_ring_hom.map_mul (OX.O.F.res (opens.comap (induced_continuous OX R f) U2) (opens.comap (induced_continuous OX R f) U) (opens.comap_mono _ _ _ hUs2))],
  rw [is_ring_hom.map_mul (OX.O.F.res (opens.comap (induced_continuous OX R f) U2) (opens.comap (induced_continuous OX R f) U) (opens.comap_mono _ _ _ hUs2))],
  rw [← presheaf.Hcomp', ← presheaf.Hcomp', show set.subset.trans (opens.comap_mono (induced_continuous OX R f) U U2 hUs2)
        (induced_basis._proof_1 OX R f U2) = set.subset_univ _, from rfl, ← ht],
  rw [mul_assoc, mul_assoc, mul_comm, mul_assoc, mul_assoc],
  replace hiv1 := congr_arg (OX.O.F.res (opens.comap (induced_continuous OX R f) U1) (opens.comap (induced_continuous OX R f) U) (opens.comap_mono _ _ _ hUs1)) hiv1,
  rw [is_ring_hom.map_mul (OX.O.F.res (opens.comap (induced_continuous OX R f) U1) (opens.comap (induced_continuous OX R f) U) (opens.comap_mono _ _ _ hUs1))] at hiv1,
  change _ = OX.O.F.res (opens.comap (induced_continuous OX R f) U1) (opens.comap (induced_continuous OX R f) U) (opens.comap_mono _ _ _ hUs1) 1 at hiv1,
  rw [is_ring_hom.map_one (OX.O.F.res (opens.comap (induced_continuous OX R f) U1) (opens.comap (induced_continuous OX R f) U) (opens.comap_mono _ _ _ hUs1))] at hiv1,
  rw [← presheaf.Hcomp', show set.subset.trans (opens.comap_mono (induced_continuous OX R f) U U1 hUs1) (induced_basis._proof_1 OX R f U1) = set.subset_univ _, from rfl] at hiv1,
  rw [hiv1, mul_one, ← presheaf.Hcomp'], refl
end

noncomputable def induced_sheafification {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  (R : Type u) [comm_ring R]
  (f : (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤) [is_ring_hom f]
  (U : topological_space.opens (Spec R)) (s : (Spec.locally_ringed_space R).O U) :
  ((presheaf_of_rings_to_presheaf_of_rings_on_basis
      (D_fs_standard_basis R)
      (OX.O.pushforward (induced_continuous OX R f)).F :
    presheaf_of_rings_on_basis (Spec R) (D_fs_basis R))ᵣₑₓₜ (D_fs_standard_basis R)) U :=
⟨λ x hxU, induced_stalk OX R f x (s.1 x hxU),
λ x hxU, let ⟨V, HVB, hxV, s1, hs1⟩ := s.2 x hxU in
⟨V, HVB, hxV, induced_basis OX R f V HVB s1, λ g hg, funext $ λ hgU, by rw hs1 g hg; refl⟩⟩

theorem induced_sheafification_to_presheaf_of_rings_extension
  {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  (R : Type u) [comm_ring R]
  (f : (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤) [is_ring_hom f]
  (U : topological_space.opens (Spec R)) (HUB : U ∈ D_fs R)
  (σ : (structure_presheaf_on_basis R).F HUB) :
  induced_sheafification OX R f U (to_presheaf_of_rings_extension (D_fs_standard_basis R) _ HUB σ) =
    sheaf_of_rings.to_extension _ _ _ _ (induced_basis OX R _ _ HUB σ) :=
subtype.eq $ funext $ λ p, funext $ λ hpU, quotient.sound ⟨U ∩ opens.some (sheaf_of_rings.to_extension._proof_1 (D_fs_basis R) U p hpU),
  (D_fs_standard_basis R).2 HUB (sheaf_of_rings.to_extension._proof_2 (D_fs_basis R) U p hpU),
  ⟨hpU, (sheaf_of_rings.to_extension._proof_3 (D_fs_basis R) U p hpU)⟩,
  set.inter_subset_left _ _, set.inter_subset_right _ _, presheaf.Hcomp' _ _ _ _ _ _ _⟩

instance is_ring_hom_induced_basis (U : topological_space.opens $ Spec R) (HUB : U ∈ D_fs R) :
  is_ring_hom (induced_basis OX R f U HUB) :=
localization.lift.is_ring_hom _ _

theorem induced_basis_res (U V : topological_space.opens $ Spec R) (HUB : U ∈ D_fs R) (HVB : V ∈ D_fs R) (HVU : V ⊆ U)
  (s : ((structure_presheaf_on_basis R).to_presheaf_on_basis).F HUB) :
  induced_basis OX R f V HVB (presheaf_on_basis.res _ HUB HVB HVU s) =
  OX.O.F.res (opens.comap (induced_continuous OX R f) U) (opens.comap (induced_continuous OX R f) V)
    (opens.comap_mono _ _ _ HVU) (induced_basis OX R f U HUB s) :=
suffices induced_basis OX R f V HVB ∘ presheaf_on_basis.res _ HUB HVB HVU =
  OX.O.F.res (opens.comap (induced_continuous OX R f) U) (opens.comap (induced_continuous OX R f) V)
    (opens.comap_mono _ _ _ HVU) ∘ induced_basis OX R f U HUB, from congr_fun this s,
localization.funext _ _ $ λ x, show localization.lift (OX.O.F.res ⊤ (opens.comap _ V) _ ∘ f ∘ to_Spec_top R) _ ↑x =
  OX.O.F.res (opens.comap _ U) (opens.comap _ V) _ (localization.lift (OX.O.F.res ⊤ (opens.comap _ U) _ ∘ f ∘ to_Spec_top R) _ ↑x),
by rw [localization.lift_coe, localization.lift_coe, ← presheaf.Hcomp']; refl

instance is_ring_hom_induced_stalk (p : Spec R) :
  is_ring_hom (induced_stalk OX R f p) :=
{ map_one := congr_arg quotient.mk (congr_arg (stalk_on_basis.elem.mk _ _ _) (by exact is_ring_hom.map_one (induced_basis _ _ _ _ _))),
  map_mul := λ x y, quotient.induction_on₂ x y $ λ s t, congr_arg quotient.mk
    (congr_arg (stalk_on_basis.elem.mk _ _ _) (by exact (is_ring_hom.map_mul (induced_basis _ _ _ _ _)).trans
      (by rw [induced_basis_res, induced_basis_res]; refl))),
  map_add := λ x y, quotient.induction_on₂ x y $ λ s t, congr_arg quotient.mk
    (congr_arg (stalk_on_basis.elem.mk _ _ _) (by exact (is_ring_hom.map_add (induced_basis _ _ _ _ _)).trans
      (by rw [induced_basis_res, induced_basis_res]; refl))) }

instance is_ring_hom_induced_sheafification {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  (R : Type u) [comm_ring R]
  (f : (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤) [is_ring_hom f]
  (U : topological_space.opens (Spec R)) :
  is_ring_hom (induced_sheafification OX R f U) :=
{ map_one := subtype.eq $ funext $ λ x, funext $ λ hxU, by exact is_ring_hom.map_one (induced_stalk OX R f x),
  map_mul := λ x y, subtype.eq $ funext $ λ p, funext $ λ hpU, by change induced_stalk _ _ _ _ _ = _ * _;
    rw [Fext_mul.eq, is_ring_hom.map_mul (induced_stalk OX R f p)],
  map_add := λ x y, subtype.eq $ funext $ λ p, funext $ λ hpU, by change induced_stalk _ _ _ _ _ = _ + _;
    rw [Fext_add.eq, is_ring_hom.map_add (induced_stalk OX R f p)] }

theorem to_stalk_res {X : Type u} [topological_space X] (F : presheaf_of_rings X) (x : X)
  (U V : topological_space.opens X) (hxU : x ∈ U) (hxV : x ∈ V) (HVU : V ⊆ U) (s : F U) :
  to_stalk F x V hxV (F.res U V HVU s) = to_stalk F x U hxU s :=
quotient.sound ⟨V, hxV, set.subset.refl V, HVU, (presheaf.Hcomp' _ _ _ _ _ _ _).symm⟩

theorem is_unit_to_stalk {X : Type u} [topological_space X] (F : presheaf_of_rings X) (x : X)
  (U : topological_space.opens X) (hxU : x ∈ U) (s : F U) :
  is_unit (to_stalk F x U hxU s) ↔
  ∃ V : topological_space.opens X, ∃ hxV : x ∈ V, ∃ HVU : V ⊆ U, is_unit (F.res U V HVU s) :=
⟨λ hu, let ⟨t, ht⟩ := is_unit_iff_exists_inv.1 hu in quotient.induction_on t (λ ⟨V, hxV, τ⟩ H,
let ⟨W, hxW, HWUV, HWtop, HW⟩ := quotient.exact H in ⟨W, hxW, set.subset.trans HWUV (set.inter_subset_left _ _),
is_unit_iff_exists_inv.2 ⟨F.res V W (set.subset.trans HWUV (set.inter_subset_right _ _)) τ,
by dsimp only at HW; rw [res_mul, ← presheaf.Hcomp', ← presheaf.Hcomp'] at HW; exact HW.trans (res_one _ _ _ _)⟩⟩) ht,
λ ⟨V, hxV, HVU, hv⟩, hv.map'' (to_stalk F x V hxV) _ (to_stalk_res _ _ _ _ _ _ _ _)⟩

section presheaf_of_rings_extension

instance to_presheaf_of_rings_extension.is_ring_hom' {α : Type u} [topological_space α]
  {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis α HB)
  {U : topological_space.opens α} (BU : U ∈ B)
: is_ring_hom (to_presheaf_of_rings_extension Bstd F BU) :=
{ map_one :=
    begin
      apply subtype.eq,
      funext x Hx,
      apply quotient.sound,
      use [U, BU, Hx, set.subset.refl _, set.subset_univ _],
      iterate 2 { erw (F.res_is_ring_hom _ _ _).map_one, },
    end,
  map_mul :=
    begin
      intros x y,
      apply subtype.eq,
      funext z Hz,
      apply quotient.sound,
      use [U, BU, Hz],
      use [set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _)],
      erw ←(F.res_is_ring_hom _ _ _).map_mul,
      erw ←presheaf_on_basis.Hcomp',
      refl
    end,
  map_add :=
    begin
      intros x y,
      apply subtype.eq,
      funext z Hz,
      apply quotient.sound,
      use [U, BU, Hz],
      use [set.subset.refl _, set.subset_inter (set.subset.refl _) (set.subset.refl _)],
      erw ←(F.res_is_ring_hom _ _ _).map_add,
      erw ←presheaf_on_basis.Hcomp',
      refl
    end, }

theorem res_to_presheaf_of_rings_extension {α : Type u} [topological_space α]
  {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis α HB) (U V : topological_space.opens α) (HUB : U ∈ B) (HVB : V ∈ B) (HVU : V ⊆ U) (σ : F.F HUB) :
  presheaf.res _ U V HVU (to_presheaf_of_rings_extension Bstd F HUB σ) =
  to_presheaf_of_rings_extension Bstd F HVB (F.res HUB HVB HVU σ) :=
subtype.eq $ funext $ λ x, funext $ λ hxV, quotient.sound ⟨V, HVB, hxV, HVU, set.subset.refl V, presheaf_on_basis.Hcomp' _ _ _ _ _ _ _⟩

noncomputable def of_presheaf_of_rings_extension {α : Type u} [topological_space α]
  {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis α HB)
  (HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
  {U : topological_space.opens α} (HUB : U ∈ B) :
  (F ᵣₑₓₜ Bstd).F U → F.F HUB :=
(to_presheaf_of_rings_extension.ring_equiv Bstd F HF HUB).symm.to_fun

instance of_presheaf_of_rings_extension.is_ring_hom {α : Type u} [topological_space α]
  {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis α HB)
  (HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
  {U : topological_space.opens α} (HUB : U ∈ B) :
  is_ring_hom (of_presheaf_of_rings_extension HB Bstd F HF HUB) :=
(to_presheaf_of_rings_extension.ring_equiv Bstd F HF HUB).symm.hom

theorem of_to_presheaf_of_rings_extension {α : Type u} [topological_space α]
  {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis α HB)
  (HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
  {U : topological_space.opens α} (HUB : U ∈ B) (σ : F.F HUB) :
  of_presheaf_of_rings_extension HB Bstd F HF HUB (to_presheaf_of_rings_extension Bstd F HUB σ) = σ :=
(to_presheaf_of_rings_extension.ring_equiv Bstd F HF HUB).symm_apply_apply σ

theorem to_of_presheaf_of_rings_extension {α : Type u} [topological_space α]
  {B : set (topological_space.opens α)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis α HB)
  (HF : sheaf_on_standard_basis.is_sheaf_on_standard_basis Bstd F.to_presheaf_on_basis)
  {U : topological_space.opens α} (HUB : U ∈ B) (σ : (F ᵣₑₓₜ Bstd) U) :
  to_presheaf_of_rings_extension Bstd F HUB (of_presheaf_of_rings_extension HB Bstd F HF HUB σ) = σ :=
(to_presheaf_of_rings_extension.ring_equiv Bstd F HF HUB).apply_symm_apply σ

end presheaf_of_rings_extension

theorem is_unit_localization_mk {R : Type u} [comm_ring R] {S : set R} [is_submonoid S]
  (r : R) (s : S) : is_unit (localization.mk r s) ↔ ∃ t, r * t ∈ S :=
begin
  rw is_unit_iff_exists_inv, split,
  { intros hu, cases hu with w hu, revert hu,
    refine localization.induction_on w (λ r2 s2 hu, _),
    rcases quotient.exact hu with ⟨t, hts, ht⟩,
    change (s.1 * s2.1 * 1 - 1 * (r * r2)) * t = 0 at ht,
    rw [mul_one, one_mul, sub_mul, sub_eq_zero_iff_eq] at ht,
    refine ⟨r2 * t, _⟩, rw [← mul_assoc, ← ht], exact (s * s2 * ⟨t, hts⟩).2 },
  { rintros ⟨t, hrt⟩, refine ⟨localization.mk (s.1 * t) ⟨r * t, hrt⟩, quotient.sound $ localization.r_of_eq _⟩,
    change (s.1 * (r * t)) * 1 = 1 * (r * (s.val * t)), rw [mul_one, one_mul, mul_left_comm] }
end

theorem is_unit_to_stalk_affine (p : Spec R)
  (U : topological_space.opens (Spec R)) (HUB : U ∈ D_fs R) (hpU : p ∈ U) (σ : (structure_presheaf_on_basis R).F HUB) :
  is_unit (to_stalk (Spec.locally_ringed_space R).O.F p U hpU (to_presheaf_of_rings_extension _ _ HUB σ)) ↔
  ∃ r : R, ∃ s : S U, p ∈ Spec.D' r ∧ localization.mk r s = σ :=
begin
  rw is_unit_to_stalk, split,
  { rintros ⟨V, hpV, HVU, hv⟩,
    rcases topological_space.opens.is_basis_iff_nbhd.1 (D_fs_basis R) hpV with ⟨W, HWB, hpW, HWV⟩,
    have := hv.map' (presheaf.res _ V W HWV), rw ← presheaf.Hcomp' at this,
    dsimp only [Spec.locally_ringed_space, structure_sheaf, structure_sheaf.presheaf] at this,
    rw [res_to_presheaf_of_rings_extension _ _ _ _ _ HUB HWB] at this,
    replace this := this.map' (of_presheaf_of_rings_extension (D_fs_basis R) (D_fs_standard_basis R)
      (structure_presheaf_on_basis R) structure_presheaf_on_basis_is_sheaf_on_basis HWB),
    rw of_to_presheaf_of_rings_extension at this, revert this, refine localization.induction_on σ (λ r s this, _),
    change is_unit (localization.mk r ⟨s.1, _⟩) at this, rw is_unit_localization_mk at this, cases this with t hrt,
    change W.1 ⊆ Spec.D' (r * t) at hrt, rw Spec.D'.product_eq_inter at hrt,
    refine ⟨r, s, (hrt hpW).1, rfl⟩ },
  { rintros ⟨r, s, hrp, rfl⟩, refine ⟨U ∩ Spec.DO R r, ⟨hpU, hrp⟩, set.inter_subset_left _ _, _⟩,
    dsimp only [Spec.locally_ringed_space, structure_sheaf, structure_sheaf.presheaf],
    rw res_to_presheaf_of_rings_extension _ _ _ _ _ _ ((D_fs_standard_basis R).2 HUB (D_fs.mem R r)),
    refine is_unit.map' _ _, rw is_unit_iff_exists_inv, refine ⟨localization.mk s.1 ⟨r, set.inter_subset_right _ _⟩, _⟩,
    change localization.mk r ⟨s.1, _⟩ * localization.mk s.1 ⟨r, _⟩ = _,
    rw [localization.mk_mul_mk, mul_comm], exact localization.mk_self }
end

theorem is_unit_to_stalk_affine' (p : Spec R)
  (U : topological_space.opens (Spec R)) (HUB : U ∈ D_fs R) (hpU : p ∈ U) (σ : (structure_presheaf_on_basis R).F HUB) :
  is_unit (to_stalk (Spec.locally_ringed_space R).O.F p U hpU (to_presheaf_of_rings_extension _ _ HUB σ)) ↔
  ∀ r : R, ∀ s : S U, localization.mk r s = σ → p ∈ Spec.D' r :=
begin
  rw is_unit_to_stalk_affine, split,
  { rintros ⟨r1, s1, hp1, hrs⟩ r2 s2 rfl, rcases quotient.exact hrs with ⟨t, hts, ht⟩,
    change (s1.1 * r2 - s2.1 * r1) * t = 0 at ht, rw [sub_mul, sub_eq_zero_iff_eq] at ht,
    suffices : p ∈ Spec.D' (s1.1 * r2 * t),
    { rw [Spec.D'.product_eq_inter, Spec.D'.product_eq_inter] at this, exact this.1.2 },
    rw ht, rw [Spec.D'.product_eq_inter, Spec.D'.product_eq_inter],
    exact ⟨⟨s2.2 hpU, hp1⟩, hts hpU⟩ },
  { refine localization.induction_on σ (λ r s h, ⟨r, s, h r s rfl, rfl⟩) }
end

theorem is_unit_to_stalk_on_basis {X : Type u} [topological_space X]
  {B : set (topological_space.opens X)} (HB : topological_space.opens.is_basis B) (Bstd)
  (F : presheaf_of_rings_on_basis X HB)
  (p : X) (U : topological_space.opens X) (hpU : p ∈ U) (σ : (F ᵣₑₓₜ Bstd) U) :
  is_unit (to_stalk (F ᵣₑₓₜ Bstd) p U hpU σ) ↔
  @is_unit (stalk_of_rings_on_standard_basis.stalk_of_rings_on_standard_basis Bstd F p) _ (σ.1 p hpU) :=
begin
  rw is_unit_to_stalk, split,
  { rintros ⟨W, hpW, HWU, HW⟩, rcases is_unit_iff_exists_inv.1 HW with ⟨τ, hστ⟩,
    refine is_unit_iff_exists_inv.2 ⟨τ.1 p hpW, _⟩,
    replace hστ := congr_arg subtype.val hστ,
    replace hστ := congr_fun (congr_fun hστ p) hpW,
    rwa Fext_mul.eq at hστ },
  { rcases σ.2 p hpU with ⟨V, HVB, hpV, σ2, HV⟩, rw HV p ⟨hpU, hpV⟩, dsimp only, rintros hu,
    rcases is_unit_iff_exists_inv.1 hu with ⟨e, he⟩, revert he, refine quotient.induction_on e (λ τ hστ, _),
    rcases quotient.exact hστ with ⟨S, HSB, hpS, HSVτ, HStop, HS⟩, dsimp only at HS,
    rcases topological_space.opens.is_basis_iff_nbhd.1 HB (show p ∈ S ∩ U, from ⟨hpS, hpU⟩) with ⟨T, HTB, hpT, HTSU⟩,
    have HTS : T ⊆ S := set.subset.trans HTSU (set.inter_subset_left _ _),
    have HTτ : T ⊆ τ.U := set.subset.trans HTS (set.subset.trans HSVτ (set.inter_subset_right _ _)),
    refine ⟨T, hpT, set.subset.trans HTSU (set.inter_subset_right _ _), is_unit_iff_exists_inv.2
      ⟨⟨λ q hqT, ⟦⟨T, HTB, hqT, F.res τ.BU HTB HTτ τ.s⟩⟧, λ q hqT, ⟨T, HTB, hqT, F.res τ.BU HTB HTτ τ.s, λ _ _, rfl⟩⟩, _⟩⟩,
    replace HS := congr_arg (F.res HSB HTB HTS) HS,
    refine subtype.eq (funext $ λ x, funext $ λ hxT, _), rw Fext_mul.eq,
    change (σ.1 x _ * _ : stalk_of_rings_on_standard_basis.stalk_of_rings_on_standard_basis Bstd F x) = 1,
    rw HV x ⟨(HTSU hxT).2, (HSVτ $ HTS hxT).1⟩,
    refine quotient.sound ⟨T, HTB, hxT, set.subset_inter (set.subset.trans HTS (set.subset.trans HSVτ (set.inter_subset_left _ _)))
      (set.subset.refl T), set.subset_univ _, _⟩,
    dsimp only, rw bres_mul at HS ⊢, rw bres_mul at HS,
    repeat { rw ← presheaf_on_basis.Hcomp' at HS }, repeat { rw ← presheaf_on_basis.Hcomp' }, exact HS }
end

def of_pushforward_stalk {α : Type u} [topological_space α]
  {β : Type u} [topological_space β]
  {f : α → β} (hf : continuous f) (F : presheaf_of_rings α) (p : α) :
  stalk_of_rings (presheaf_of_rings.pushforward hf F) (f p) → stalk_of_rings F p :=
presheaf.fmap.stalk_of_rings ⟨λ U, id, λ U V HVU, rfl⟩ p

instance is_ring_hom_of_pushforward_stalk {α : Type u} [topological_space α]
  {β : Type u} [topological_space β]
  {f : α → β} (hf : continuous f) (F : presheaf_of_rings α) (p : α) :
  is_ring_hom (of_pushforward_stalk hf F p) :=
is_ring_hom_stalk_of_rings _ _

theorem presheafasdf {α : Type u} [topological_space α]
  {β : Type u} [topological_space β]
  {f : α → β} (hf : continuous f) (F : presheaf_of_rings α) (G : presheaf_of_rings β)
  (m : presheaf_of_rings.fmap hf F G) (p : α) (σ) :
  presheaf.fmap.stalk_of_rings m p σ =
  of_pushforward_stalk hf F p
    (presheaf.fmap.stalk_of_rings
      (⟨m.map, m.commutes⟩ : presheaf_of_rings.fmap continuous_id (presheaf_of_rings.pushforward hf F) G)
      (f p)
      σ) :=
quotient.induction_on σ $ λ e, rfl

@[simp] lemma localization.lift_mul {α : Type u} [comm_ring α] {S : set α} [is_submonoid S]
  {β : Type v} [comm_ring β] (f : α → β) [is_ring_hom f] (H) (x y : localization α S) :
  localization.lift f H (x * y) = localization.lift f H x * localization.lift f H y :=
is_ring_hom.map_mul _

/- https://stacks.math.columbia.edu/tag/01I1 -/
noncomputable def hom_to_mor {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  (R : Type u) [comm_ring R]
  (f : (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤) [is_ring_hom f] :
  OX.morphism (Spec.locally_ringed_space R) :=
{ f := induced OX R f,
  Hf := induced_continuous OX R f,
  fO :=
  { map := λ U s, (sheaf_of_rings.of_extension (D_fs_basis R)
      (D_fs_standard_basis R) _ _
      (induced_sheafification OX R f U s) :
      OX.O.pushforward (induced_continuous OX R f) U),
    commutes := λ U V HVU, funext $ λ s, begin
      dsimp only [function.comp_apply],
      change _ = (sheaf_of_rings.pushforward _ (OX.O)).F.res _ _ _ _,
      rw ← sheaf_of_rings.of_extension_res, refl
    end },
  hom := λ U, @is_ring_hom.comp _ _ _ _ _ (is_ring_hom_induced_sheafification OX R f U) _ _ _ _,
  Hstalks := λ p s, quotient.induction_on s $ λ e he, begin
    cases e with U hpU σ, generalize hσ : σ.1 (induced OX R f p) hpU = t,
    revert hσ, refine quotient.induction_on t (λ τ, _), cases τ with V HVB hpV τ,
    refine localization.induction_on τ (λ r s hu, _),
    change is_unit (of_pushforward_stalk (induced_continuous OX R f) OX.O.F p
      (to_stalk (OX.O.pushforward (induced_continuous OX R f)).F (induced OX R f p) U hpU
        (sheaf_of_rings.of_extension _ _ (OX.O.pushforward (induced_continuous OX R f)) U (induced_sheafification OX R f U σ) :
          OX.O.pushforward (induced_continuous OX R f) U))) at he,
    rw sheaf_of_rings.to_stalk_of_extension at he,
    dsimp only [induced_sheafification] at he,
    change σ.val (induced OX R f p) hpU = _ at hu,
    rw hu at he,
    change is_unit (of_pushforward_stalk (induced_continuous OX R f) OX.O.F p
      (to_stalk (OX.O.pushforward (induced_continuous OX R f)).F (induced OX R f p) V hpV
        (localization.lift
          (OX.O.F.to_presheaf.res ⊤ (opens.comap (induced_continuous OX R f) V) (set.subset_univ _) ∘ f ∘ to_Spec_top R)
          (induced_basis._proof_3 OX R f V)
          (localization.mk r s)))) at he,
    rw [localization.mk_eq, localization.lift_mul, localization.lift_coe,
        is_ring_hom.map_mul (to_stalk (OX.O.pushforward (induced_continuous OX R f)).F (induced OX R f p) V hpV),
        is_ring_hom.map_mul (of_pushforward_stalk (induced_continuous OX R f) OX.O.F p)] at he,
    replace he := is_unit_of_mul_is_unit_left he,
    change is_unit (to_stalk OX.O.F p (opens.comap (induced_continuous OX R f) V) hpV
      (OX.O.F.to_presheaf.res ⊤ (opens.comap (induced_continuous OX R f) V) (set.subset_univ _)
        (f (to_Spec_top R r)))) at he,
    rw to_stalk_res _ p ⊤ _ trivial at he,
    change p ∈ (OX.D (f (to_Spec_top R r)) : set X) at he,
    rw ← induced_preimage_D' at he,
    refine (is_unit_to_stalk_on_basis _ _ _ _ _ _ _).2 _, rw hu,
    refine is_unit_iff_exists_inv.2 ⟨⟦⟨V ∩ Spec.DO R r, (D_fs_standard_basis R).2 HVB (D_fs.mem _ _), ⟨hpV, he⟩,
      localization.mk s.1 ⟨r, set.inter_subset_right _ _⟩⟩⟧, quotient.sound ⟨V ∩ Spec.DO R r,
      (D_fs_standard_basis R).2 HVB (D_fs.mem _ _), ⟨hpV, he⟩, set.subset_inter (set.inter_subset_left _ _) (set.subset.refl _),
      set.subset_univ _, _⟩⟩,
    change localization.mk (r * s.1) ⟨s.1 * r, _⟩ = 1,
    rw mul_comm, exact localization.mk_self
  end }

theorem cast_eq_of_heq : ∀ {α β : Sort u} {a : α} {b : β} (H : a == b), cast (type_eq_of_heq H) a = b
| α _ a _ heq.rfl := rfl

@[ext] theorem locally_ringed_space.morphism.ext {X : Type u} [topological_space X] {OX : locally_ringed_space X}
  {Y : Type v} [topological_space Y] {OY : locally_ringed_space Y}
  {m₁ m₂ : OX.morphism OY} (H1 : ∀ x, m₁.f x = m₂.f x)
  (H2 : ∀ U σ, OX.O.F.res (opens.comap m₁.Hf U) (opens.comap m₂.Hf U)
    (show m₂.f⁻¹' U ⊆ m₁.f⁻¹' U, from (funext H1 : m₁.f = m₂.f) ▸ set.subset.refl _)
    (m₁.fO.map U σ) = m₂.fO.map U σ) : m₁ = m₂ :=
begin
  rcases m₁ with ⟨⟨f, hf, ⟨mf, hmf⟩, hf2⟩, hf1⟩,
  rcases m₂ with ⟨⟨g, hg, ⟨mg, hmg⟩, hg2⟩, hg1⟩,
  have : f = g := funext H1, subst this, congr' 3,
  funext U σ, exact (presheaf.Hid' _ _ _).symm.trans (H2 U σ)
end

/- https://stacks.math.columbia.edu/tag/01I1 -/
theorem mor_to_hom_to_mor {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  (R : Type u) [comm_ring R] (f : OX.morphism (Spec.locally_ringed_space R)) :
  hom_to_mor OX R (mor_to_hom OX R f) = f :=
begin
  have : ((hom_to_mor OX R (mor_to_hom OX R f)).to_morphism).f = (f.to_morphism).f,
  { funext x, apply subtype.eq, ext s,
    change ¬ is_unit (to_stalk _ _ _ _ (OX.O.F.res _ _ _ _)) ↔ f.f x ∈ Spec.V' s,
    rw to_stalk_res _ x (opens.comap f.Hf ⊤) _ trivial, split,
    { rintros hu, classical, by_contradiction hfxs, apply hu,
      change is_unit (presheaf.fmap.stalk_of_rings f.fO x (to_stalk _ _ ⊤ trivial (to_Spec_top R s))),
      haveI := is_ring_hom_stalk_of_rings f.fO,
      refine is_unit.map' _ _, refine (is_unit_to_stalk_affine _ _ _ _ _ _).2 ⟨s, 1, hfxs, rfl⟩ },
    { exact λ hsfx HV, (is_unit_to_stalk_affine' _ _ _ _ _ _).1
        (f.Hstalks x (to_stalk _ _ ⊤ trivial (to_Spec_top R s)) HV) _ _ rfl hsfx } },
  fapply locally_ringed_space.morphism.ext, { intros, rw this },
  intros U σ,
  refine @sheaf_of_rings.ext (Spec R) _ _ (D_fs_basis R) (OX.O.pushforward f.Hf) U _ _ (λ p hpU, _),
  rcases topological_space.opens.is_basis_iff_nbhd.1 (D_fs_basis R) hpU with ⟨V, HVB, hpV, HVU⟩,
  refine quotient.sound ⟨V, hpV, HVU, HVU, _⟩,
  change OX.O.F.res _ _ _ (OX.O.F.res _ _ _ _) = OX.O.F.res _ _ _ _,
  rw presheaf.fmap.commutes' f.fO U V HVU,
  rw ← presheaf.Hcomp',
  rw presheaf.Hcomp' _ (opens.comap (hom_to_mor OX R (mor_to_hom OX R f)).Hf U)
      (opens.comap (hom_to_mor OX R (mor_to_hom OX R f)).Hf V) (opens.comap f.Hf V)
      (show f.f ⁻¹' V ⊆ (hom_to_mor OX R (mor_to_hom OX R f)).f ⁻¹' V, by rw this)
      (opens.comap_mono _ _ _ HVU),
  rw presheaf.fmap.commutes' _ U V HVU,
  generalize : ((((Spec.locally_ringed_space R).O).F).to_presheaf).res U V HVU σ = τ,
  rcases to_presheaf_of_rings_extension.surjective _ _ structure_presheaf_on_basis_is_sheaf_on_basis HVB τ with ⟨x, rfl⟩,
  haveI := (hom_to_mor OX R (mor_to_hom OX R f)).hom,
  refine congr_fun (localization.funext
    (OX.O.F.res (opens.comap (hom_to_mor OX R (mor_to_hom OX R f)).Hf V) (opens.comap f.Hf V) _ ∘
      (hom_to_mor OX R (mor_to_hom OX R f)).fO.map V ∘
         to_presheaf_of_rings_extension _ (structure_presheaf_on_basis R) HVB)
    (f.fO.map V ∘ to_presheaf_of_rings_extension _ (structure_presheaf_on_basis R) HVB) _) x,
  intros r, dsimp only [function.comp_apply],
  rw [show ((r : localization R (S V)) : (structure_presheaf_on_basis R).F HVB) =
      (structure_presheaf_on_basis R).res (D_fs_standard_basis R).1 _ _ (localization.of r), from rfl,
    ← res_to_presheaf_of_rings_extension _ _ _ _ _ (D_fs_standard_basis R).1 _ (set.subset_univ _)],
  change (((OX.O).F).to_presheaf).res (opens.comap _ V) (opens.comap _ V) _
      ((((hom_to_mor OX R (mor_to_hom OX R f)).to_morphism).fO).map V
         (((Spec.locally_ringed_space R).O.F.to_presheaf).res opens.univ V _
            (to_presheaf_of_rings_extension _ (structure_presheaf_on_basis R) _ (localization.of r)))) =
    ((f.to_morphism).fO).map V
      (((Spec.locally_ringed_space R).O.F.to_presheaf).res opens.univ V _
         (to_presheaf_of_rings_extension _ (structure_presheaf_on_basis R) _ (localization.of r))),
  rw [← presheaf.fmap.commutes', ← presheaf.fmap.commutes'],
  swap, { exact opens.comap_mono _ _ _ (set.subset_univ _) }, swap, { exact opens.comap_mono _ _ _ (set.subset_univ _) },
  dsimp only [hom_to_mor], rw ← presheaf.Hcomp',
  rw presheaf.Hcomp' OX.O.F.to_presheaf (opens.comap (induced_continuous OX R (mor_to_hom OX R f)) opens.univ)
      (opens.comap f.Hf ⊤) (opens.comap f.Hf V)
      (opens.comap_mono _ _ _ (set.subset_univ _))
      (λ _ _, trivial),
  congr' 1,
  rw [induced_sheafification_to_presheaf_of_rings_extension, sheaf_of_rings.of_to_extension],
  dsimp only [induced_basis], simp only [localization.lift_of, function.comp_apply],
  dsimp only [mor_to_hom], rw [← presheaf.Hcomp', ← presheaf.Hcomp'],
  exact presheaf.Hid' _ _ _,
end

/- https://stacks.math.columbia.edu/tag/01I1 -/
theorem hom_to_mor_to_hom {X : Type u} [topological_space X] (OX : locally_ringed_space X)
  (R : Type u) [comm_ring R] (f : (Spec.locally_ringed_space R).O ⊤ → OX.O ⊤) [is_ring_hom f] :
  mor_to_hom OX R (hom_to_mor OX R f) = f :=
begin
  funext x,
  rcases to_presheaf_of_rings_extension.surjective (D_fs_standard_basis R) _ structure_presheaf_on_basis_is_sheaf_on_basis (D_fs_standard_basis R).1 x with ⟨r, rfl⟩,
  suffices : mor_to_hom OX R (hom_to_mor OX R f) ∘ to_presheaf_of_rings_extension (D_fs_standard_basis R) (structure_presheaf_on_basis R) (D_fs_standard_basis R).1 =
    f ∘ to_presheaf_of_rings_extension (D_fs_standard_basis R) (structure_presheaf_on_basis R) (D_fs_standard_basis R).1,
  { convert congr_fun this r },
  refine localization.funext _ _ (λ r, _),
  dsimp only [function.comp_apply, mor_to_hom, hom_to_mor],
  rw [induced_sheafification_to_presheaf_of_rings_extension, sheaf_of_rings.of_to_extension],
  dsimp only [induced_basis], rw [localization.lift_coe], dsimp only [function.comp_apply],
  rw ← presheaf.Hcomp', exact presheaf.Hid' _ _ _
end

end tag01I1


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.category
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l u₃ v₃

namespace Mathlib

/-!
# (Lax) monoidal functors

A lax monoidal functor `F` between monoidal categories `C` and `D`
is a functor between the underlying categories equipped with morphisms
* `ε : 𝟙_ D ⟶ F.obj (𝟙_ C)` (called the unit morphism)
* `μ X Y : (F.obj X) ⊗ (F.obj Y) ⟶ F.obj (X ⊗ Y)` (called the tensorator, or strength).
satisfying various axioms.

A monoidal functor is a lax monoidal functor for which `ε` and `μ` are isomorphisms.

We show that the composition of (lax) monoidal functors gives a (lax) monoidal functor.

See also `category_theory.monoidal.functorial` for a typeclass decorating an object-level
function with the additional data of a monoidal functor.
This is useful when stating that a pre-existing functor is monoidal.

See `category_theory.monoidal.natural_transformation` for monoidal natural transformations.

We show in `category_theory.monoidal.Mon_` that lax monoidal functors take monoid objects
to monoid objects.

## Future work
* Oplax monoidal functors.

## References

See https://stacks.math.columbia.edu/tag/0FFL.
-/

namespace category_theory

/-- A lax monoidal functor is a functor `F : C ⥤ D` between monoidal categories, equipped with morphisms
    `ε : 𝟙 _D ⟶ F.obj (𝟙_ C)` and `μ X Y : F.obj X ⊗ F.obj Y ⟶ F.obj (X ⊗ Y)`, satisfying the
    the appropriate coherences. -/
-- unit morphism

structure lax_monoidal_functor (C : Type u₁) [category C] [monoidal_category C] (D : Type u₂)
    [category D] [monoidal_category D]
    extends C ⥤ D where
  ε : 𝟙_ ⟶ functor.obj _to_functor 𝟙_
  μ :
    (X Y : C) →
      functor.obj _to_functor X ⊗ functor.obj _to_functor Y ⟶ functor.obj _to_functor (X ⊗ Y)
  μ_natural' :
    autoParam
      (∀ {X Y X' Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y'),
        (functor.map _to_functor f ⊗ functor.map _to_functor g) ≫ μ Y Y' =
          μ X X' ≫ functor.map _to_functor (f ⊗ g))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  associativity' :
    autoParam
      (∀ (X Y Z : C),
        (μ X Y ⊗ 𝟙) ≫ μ (X ⊗ Y) Z ≫ functor.map _to_functor (iso.hom α_) =
          iso.hom α_ ≫ (𝟙 ⊗ μ Y Z) ≫ μ X (Y ⊗ Z))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  left_unitality' :
    autoParam (∀ (X : C), iso.hom λ_ = (ε ⊗ 𝟙) ≫ μ 𝟙_ X ≫ functor.map _to_functor (iso.hom λ_))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  right_unitality' :
    autoParam (∀ (X : C), iso.hom ρ_ = (𝟙 ⊗ ε) ≫ μ X 𝟙_ ≫ functor.map _to_functor (iso.hom ρ_))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

-- tensorator

-- associativity of the tensorator

-- unitality

@[simp] theorem lax_monoidal_functor.μ_natural {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) {X : C} {Y : C}
    {X' : C} {Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') :
    (functor.map (lax_monoidal_functor.to_functor c) f ⊗
            functor.map (lax_monoidal_functor.to_functor c) g) ≫
          lax_monoidal_functor.μ c Y Y' =
        lax_monoidal_functor.μ c X X' ≫ functor.map (lax_monoidal_functor.to_functor c) (f ⊗ g) :=
  sorry

@[simp] theorem lax_monoidal_functor.μ_natural_assoc {C : Type u₁} [category C]
    [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D]
    (c : lax_monoidal_functor C D) {X : C} {Y : C} {X' : C} {Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') :
    ∀ {X'_1 : D} (f' : functor.obj (lax_monoidal_functor.to_functor c) (Y ⊗ Y') ⟶ X'_1),
        (functor.map (lax_monoidal_functor.to_functor c) f ⊗
              functor.map (lax_monoidal_functor.to_functor c) g) ≫
            lax_monoidal_functor.μ c Y Y' ≫ f' =
          lax_monoidal_functor.μ c X X' ≫
            functor.map (lax_monoidal_functor.to_functor c) (f ⊗ g) ≫ f' :=
  sorry

@[simp] theorem lax_monoidal_functor.left_unitality {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) (X : C) :
    iso.hom λ_ =
        (lax_monoidal_functor.ε c ⊗ 𝟙) ≫
          lax_monoidal_functor.μ c 𝟙_ X ≫
            functor.map (lax_monoidal_functor.to_functor c) (iso.hom λ_) :=
  sorry

@[simp] theorem lax_monoidal_functor.right_unitality {C : Type u₁} [category C]
    [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D]
    (c : lax_monoidal_functor C D) (X : C) :
    iso.hom ρ_ =
        (𝟙 ⊗ lax_monoidal_functor.ε c) ≫
          lax_monoidal_functor.μ c X 𝟙_ ≫
            functor.map (lax_monoidal_functor.to_functor c) (iso.hom ρ_) :=
  sorry

@[simp] theorem lax_monoidal_functor.associativity {C : Type u₁} [category C] [monoidal_category C]
    {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) (X : C) (Y : C)
    (Z : C) :
    (lax_monoidal_functor.μ c X Y ⊗ 𝟙) ≫
          lax_monoidal_functor.μ c (X ⊗ Y) Z ≫
            functor.map (lax_monoidal_functor.to_functor c) (iso.hom α_) =
        iso.hom α_ ≫ (𝟙 ⊗ lax_monoidal_functor.μ c Y Z) ≫ lax_monoidal_functor.μ c X (Y ⊗ Z) :=
  sorry

-- When `rewrite_search` lands, add @[search] attributes to

-- lax_monoidal_functor.μ_natural lax_monoidal_functor.left_unitality

-- lax_monoidal_functor.right_unitality lax_monoidal_functor.associativity

/--
A monoidal functor is a lax monoidal functor for which the tensorator and unitor as isomorphisms.

See https://stacks.math.columbia.edu/tag/0FFL.
-/
structure monoidal_functor (C : Type u₁) [category C] [monoidal_category C] (D : Type u₂)
    [category D] [monoidal_category D]
    extends lax_monoidal_functor C D where
  ε_is_iso :
    autoParam (is_iso (lax_monoidal_functor.ε _to_lax_monoidal_functor))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])
  μ_is_iso :
    autoParam ((X Y : C) → is_iso (lax_monoidal_functor.μ _to_lax_monoidal_functor X Y))
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
        (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic")
          "apply_instance")
        [])

/--
The unit morphism of a (strong) monoidal functor as an isomorphism.
-/
def monoidal_functor.ε_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] (F : monoidal_functor C D) :
    𝟙_ ≅
        functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F))
          𝟙_ :=
  as_iso (lax_monoidal_functor.ε (monoidal_functor.to_lax_monoidal_functor F))

/--
The tensorator of a (strong) monoidal functor as an isomorphism.
-/
def monoidal_functor.μ_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂}
    [category D] [monoidal_category D] (F : monoidal_functor C D) (X : C) (Y : C) :
    functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F)) X ⊗
          functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F))
            Y ≅
        functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F))
          (X ⊗ Y) :=
  as_iso (lax_monoidal_functor.μ (monoidal_functor.to_lax_monoidal_functor F) X Y)

namespace lax_monoidal_functor

/-- The identity lax monoidal functor. -/
@[simp] theorem id_ε (C : Type u₁) [category C] [monoidal_category C] : ε (id C) = 𝟙 :=
  Eq.refl (ε (id C))

protected instance inhabited (C : Type u₁) [category C] [monoidal_category C] :
    Inhabited (lax_monoidal_functor C C) :=
  { default := id C }

end lax_monoidal_functor

namespace monoidal_functor

theorem map_tensor {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] (F : monoidal_functor C D) {X : C} {Y : C} {X' : C} {Y' : C} (f : X ⟶ Y)
    (g : X' ⟶ Y') :
    functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) (f ⊗ g) =
        inv (lax_monoidal_functor.μ (to_lax_monoidal_functor F) X X') ≫
          (functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) f ⊗
              functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) g) ≫
            lax_monoidal_functor.μ (to_lax_monoidal_functor F) Y Y' :=
  sorry

theorem map_left_unitor {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] (F : monoidal_functor C D) (X : C) :
    functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) (iso.hom λ_) =
        inv (lax_monoidal_functor.μ (to_lax_monoidal_functor F) 𝟙_ X) ≫
          (inv (lax_monoidal_functor.ε (to_lax_monoidal_functor F)) ⊗ 𝟙) ≫ iso.hom λ_ :=
  sorry

theorem map_right_unitor {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] (F : monoidal_functor C D) (X : C) :
    functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) (iso.hom ρ_) =
        inv (lax_monoidal_functor.μ (to_lax_monoidal_functor F) X 𝟙_) ≫
          (𝟙 ⊗ inv (lax_monoidal_functor.ε (to_lax_monoidal_functor F))) ≫ iso.hom ρ_ :=
  sorry

/-- The tensorator as a natural isomorphism. -/
def μ_nat_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] (F : monoidal_functor C D) :
    functor.prod (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F))
            (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) ⋙
          monoidal_category.tensor D ≅
        monoidal_category.tensor C ⋙ lax_monoidal_functor.to_functor (to_lax_monoidal_functor F) :=
  nat_iso.of_components (fun (X : C × C) => μ_iso F (prod.fst X) (prod.snd X)) sorry

/-- The identity monoidal functor. -/
def id (C : Type u₁) [category C] [monoidal_category C] : monoidal_functor C C :=
  mk (lax_monoidal_functor.mk (functor.mk (functor.obj 𝟭) (functor.map 𝟭)) 𝟙 fun (X Y : C) => 𝟙)

protected instance inhabited (C : Type u₁) [category C] [monoidal_category C] :
    Inhabited (monoidal_functor C C) :=
  { default := id C }

end monoidal_functor

namespace lax_monoidal_functor

-- The proofs here are horrendous; rewrite_search helps a lot.

/-- The composition of two lax monoidal functors is again lax monoidal. -/
@[simp] theorem comp_ε {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] {E : Type u₃} [category E] [monoidal_category E]
    (F : lax_monoidal_functor C D) (G : lax_monoidal_functor D E) :
    ε (comp F G) = ε G ≫ functor.map (to_functor G) (ε F) :=
  Eq.refl (ε (comp F G))

infixr:80 " ⊗⋙ " => Mathlib.category_theory.lax_monoidal_functor.comp

end lax_monoidal_functor

namespace monoidal_functor

/-- The composition of two monoidal functors is again monoidal. -/
def comp {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D]
    [monoidal_category D] {E : Type u₃} [category E] [monoidal_category E]
    (F : monoidal_functor C D) (G : monoidal_functor D E) : monoidal_functor C E :=
  mk
    (lax_monoidal_functor.mk
      (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F ⊗⋙ to_lax_monoidal_functor G))
      (lax_monoidal_functor.ε (to_lax_monoidal_functor F ⊗⋙ to_lax_monoidal_functor G))
      (lax_monoidal_functor.μ (to_lax_monoidal_functor F ⊗⋙ to_lax_monoidal_functor G)))

infixr:80 " ⊗⋙ " => Mathlib.category_theory.monoidal_functor.comp

end Mathlib


/-
Copyright 2022 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    https://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.

Authors: Moritz Firsching
-/
import tactic
/-!
# A theorem of Pólya on polynomials

## TODO
  - Theorem 1
  - Theorem 2
  - Chebyschev's Theorem
  - Corollary
    - proof
  - Proof of Theorem 2
  - Two facts about polynomials with real roots
  - Appendix: Chebyshev's theorem
    - proof
      - (A)
      - (B)
      - proof of (A)
      - proof of (B)
-/