/-
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