Theory Comm_Ring


text ‹Authors: Anthony Bordg and Lawrence Paulson,
with some contributions from Wenda Li›

theory Comm_Ring
  imports
    "Group_Extras"
    "Topological_Space"
    "Jacobson_Basic_Algebra.Ring_Theory"
    "Set_Extras"
begin

(*Suppresses the built-in plus sign, but why does
 no_notation minus (infixl "-" 65)
cause errors with monoid subtraction below? --LCP
*)
no_notation plus (infixl "+" 65)

lemma (in monoid_homomorphism) monoid_preimage: "Group_Theory.monoid (η ¯ M M') (⋅) 𝟭"
  by (simp add: Int_absorb1 source.monoid_axioms subsetI)

lemma (in group_homomorphism) group_preimage: "Group_Theory.group (η ¯ G G') (⋅) 𝟭"
  by (simp add: Int_absorb1 source.group_axioms subsetI)

lemma (in ring_homomorphism) ring_preimage: "ring (η ¯ R R') (+) (⋅) 𝟬 𝟭"
  by (simp add: Int_absorb2 Int_commute source.ring_axioms subset_iff)

section ‹Commutative Rings›

subsection ‹Commutative Rings›

locale comm_ring = ring +
  assumes comm_mult: " a  R; b  R   a  b = b  a"

text ‹The zero ring is a commutative ring.›

lemma invertible_0: "monoid.invertible {0} (λn m. 0) 0 0"
    using Group_Theory.monoid.intro monoid.unit_invertible by force

interpretation ring0: ring "{0::nat}" "λn m. 0" "λn m. 0" 0 0
  using invertible_0 by unfold_locales auto

declare ring0.additive.left_unit [simp del] ring0.additive.invertible [simp del]
declare ring0.additive.invertible_left_inverse [simp del] ring0.right_zero [simp del]

interpretation cring0: comm_ring "{0::nat}" "λn m. 0" "λn m. 0" 0 0
  by (metis comm_ring_axioms_def comm_ring_def ring0.ring_axioms)

(* def 0.13 *)
definition (in ring) zero_divisor :: "'a  'a  bool"
  where "zero_divisor x y  (x  𝟬)  (y  𝟬)  (x  y = 𝟬)"

subsection ‹Entire Rings›

(* def 0.14 *)
locale entire_ring = comm_ring + assumes units_neq: "𝟭  𝟬" and
no_zero_div: " x  R; y  R  ¬(zero_divisor x y)"

subsection ‹Ideals›

context comm_ring begin

lemma mult_left_assoc: " a  R; b  R; c  R   b  (a  c) = a  (b  c)"
  using comm_mult multiplicative.associative by auto

lemmas ring_mult_ac = comm_mult multiplicative.associative mult_left_assoc

(* ex. 0.16 *)
lemma ideal_R_R: "ideal R R (+) (⋅) 𝟬 𝟭"
proof qed auto

lemma ideal_0_R: "ideal {𝟬} R (+) (⋅) 𝟬 𝟭"
proof
  show "monoid.invertible {𝟬} (+) 𝟬 u"
    if "u  {𝟬}"
    for u :: 'a
  proof (rule monoid.invertibleI)
    show "Group_Theory.monoid {𝟬} (+) 𝟬"
    proof qed (use that in auto)
  qed (use that in auto)
qed auto

definition ideal_gen_by_prod :: "'a set  'a set  'a set"
  where "ideal_gen_by_prod 𝔞 𝔟  additive.subgroup_generated {x. a b. x = a  b  a  𝔞  b  𝔟}"

lemma ideal_zero: "ideal A R add mult zero unit  zero  A"
  by (simp add: ideal_def subgroup_of_additive_group_of_ring_def subgroup_def submonoid_def submonoid_axioms_def)

lemma ideal_implies_subset:
  assumes "ideal A R add mult zero unit"
  shows "A  R"
  by (meson assms ideal_def subgroup_def subgroup_of_additive_group_of_ring_def submonoid_axioms_def submonoid_def)

lemma ideal_inverse:
  assumes "a  A" "ideal A R (+) mult zero unit"
  shows "additive.inverse a  A"
  by (meson additive.invertible assms comm_ring.ideal_implies_subset comm_ring_axioms ideal_def subgroup.subgroup_inverse_iff subgroup_of_additive_group_of_ring_def subsetD)

lemma ideal_add:
  assumes "a  A"  "b  A" "ideal A R add mult zero unit"
  shows "add a b  A"
  by (meson Group_Theory.group_def assms ideal_def monoid.composition_closed subgroup_def subgroup_of_additive_group_of_ring_def)

lemma ideal_mult_in_subgroup_generated:
  assumes 𝔞: "ideal 𝔞 R (+) (⋅) 𝟬 𝟭" and 𝔟: "ideal 𝔟 R (+) (⋅) 𝟬 𝟭" and "a  𝔞" "b  𝔟"
  shows "a  b  ideal_gen_by_prod 𝔞 𝔟"
  proof -
  have "x y. a  b = x  y  x  𝔞  y  𝔟"
    using assms ideal_implies_subset by blast
  with ideal_implies_subset show ?thesis
    unfolding additive.subgroup_generated_def ideal_gen_by_prod_def
    using assms ideal_implies_subset by (blast intro: additive.generate.incl)
qed

subsection ‹Ideals generated by an Element›

definition gen_ideal:: "'a  'a set" ("_")
  where "x  {y. rR. y = r  x}"

lemma zero_in_gen_ideal:
  assumes "x  R"
  shows "𝟬  x"
proof -
  have "a. a  R  𝟬 = a  x"
    by (metis (lifting) additive.unit_closed assms left_zero)
  then show ?thesis
    using gen_ideal_def by blast
qed

lemma add_in_gen_ideal:
  "x  R; a  x; b  x  a + b  x"
    apply (clarsimp simp : gen_ideal_def)
  by (metis (no_types) additive.composition_closed distributive(2))

lemma gen_ideal_subset:
  assumes "x  R"
  shows "x  R"
  using assms comm_ring.gen_ideal_def local.comm_ring_axioms by fastforce

lemma gen_ideal_monoid:
  assumes "x  R"
  shows "Group_Theory.monoid x (+) 𝟬"
proof
  show "a + b  x" if "a  x" "b  x" for a b
    by (simp add: add_in_gen_ideal assms that)
qed (use assms zero_in_gen_ideal gen_ideal_def in auto)

lemma gen_ideal_group:
  assumes "x  R"
  shows "Group_Theory.group x (+) 𝟬"
proof
  fix a b c
  assume "a  x" "b  x" "c  x"
  then show "a + b + c = a + (b + c)"
    by (meson assms gen_ideal_monoid monoid.associative)
next
  fix a
  assume a: "a  x"
  show "𝟬 + a = a"
    by (meson a assms gen_ideal_monoid monoid.left_unit)
  show "a + 𝟬 = a"
    by (meson a assms gen_ideal_monoid monoid.right_unit)
  interpret M: monoid "x" "(+)" 𝟬
    by (simp add: assms gen_ideal_monoid)
  obtain r where r: "rR" "a = r  x"
    using a gen_ideal_def by auto
  show "monoid.invertible x (+) 𝟬 a"
  proof (rule M.invertibleI)
    have "rR. - a = r  x"
      by (metis assms ideal_R_R ideal_inverse local.left_minus r)
    then show "-a  x" by (simp add: gen_ideal_def)
  qed (use a r assms in auto)
qed (auto simp: zero_in_gen_ideal add_in_gen_ideal assms)

lemma gen_ideal_ideal:
  assumes "x  R"
  shows "ideal x R (+) (⋅) 𝟬 𝟭"
proof intro_locales
  show "submonoid_axioms x R (+) 𝟬"
    by (simp add: add_in_gen_ideal assms gen_ideal_subset submonoid_axioms.intro zero_in_gen_ideal)
  show "Group_Theory.group_axioms x (+) 𝟬"
    by (meson Group_Theory.group_def assms gen_ideal_group)
  show "ideal_axioms x R (⋅)"
  proof
    fix a b
    assume "a  R" "b  x"
    then obtain r where r: "rR" "b = r  x"
      by (auto simp add: gen_ideal_def)
    have "a  (r  x) = (a  r)  x"
      using a  R r  R assms multiplicative.associative by presburger
    then show "a  b  x"
      using a  R r gen_ideal_def by blast
    then show "b  a  x"
      by (simp add: a  R assms comm_mult r)
  qed
qed (auto simp add: assms gen_ideal_monoid)


subsection ‹Exercises›

lemma in_ideal_gen_by_prod:
  assumes 𝔞: "ideal 𝔞 R (+) (⋅) 𝟬 𝟭" and 𝔟: "ideal 𝔟 R (+) (⋅) 𝟬 𝟭"
    and "a  R" and b: "b  ideal_gen_by_prod 𝔞 𝔟"
  shows "a  b  ideal_gen_by_prod 𝔞 𝔟"
  using b a  R
  unfolding additive.subgroup_generated_def ideal_gen_by_prod_def
proof (induction arbitrary: a)
  case unit
  then show ?case
    by (simp add: additive.generate.unit)
next
  case (incl x u)
  with 𝔞 𝔟 have "a b. a  b  R; a  𝔞; b  𝔟  x y. u  (a  b) = x  y  x  𝔞  y  𝔟"
    by simp (metis ideal.ideal(1) ideal_implies_subset multiplicative.associative subset_iff)
  then show ?case
    using additive.generate.incl incl.hyps incl.prems by force
next
  case (inv u v)
  then show ?case
  proof clarsimp
    fix a b
    assume "v  R" "a  b  R" "a  𝔞" "b  𝔟"
    then have "v  (- a  b) = v  a  (- b)  v  a  𝔞  - b  𝔟"
      by (metis 𝔞 𝔟 ideal.ideal(1) ideal_implies_subset ideal_inverse in_mono local.right_minus multiplicative.associative)
    then show "v  (- a  b)  additive.generate (R  {a  b |a b. a  𝔞  b  𝔟})"
      using 𝔞 𝔟 additive.subgroup_generated_def ideal_mult_in_subgroup_generated
      unfolding ideal_gen_by_prod_def
      by presburger
  qed
next
  case (mult u v)
  then show ?case
    using additive.generate.mult additive.generate_into_G distributive(1) by force
qed

(* ex. 0.12 *)
lemma ideal_subgroup_generated:
  assumes "ideal 𝔞 R (+) (⋅) 𝟬 𝟭" and "ideal 𝔟 R (+) (⋅) 𝟬 𝟭"
  shows "ideal (ideal_gen_by_prod 𝔞 𝔟) R (+) (⋅) 𝟬 𝟭"
  proof
  show "ideal_gen_by_prod 𝔞 𝔟  R"
    by (simp add: additive.subgroup_generated_is_subset ideal_gen_by_prod_def)
  show "a + b  ideal_gen_by_prod 𝔞 𝔟"
    if "a  ideal_gen_by_prod 𝔞 𝔟" "b  ideal_gen_by_prod 𝔞 𝔟"
    for a b
    using that additive.subgroup_generated_is_monoid monoid.composition_closed
    by (fastforce simp: ideal_gen_by_prod_def)
  show "𝟬  ideal_gen_by_prod 𝔞 𝔟"
    using additive.generate.unit additive.subgroup_generated_def ideal_gen_by_prod_def by presburger
  show "a + b + c = a + (b + c)"
    if "a  ideal_gen_by_prod 𝔞 𝔟" "b  ideal_gen_by_prod 𝔞 𝔟" "c  ideal_gen_by_prod 𝔞 𝔟"
    for a b c
    using that additive.subgroup_generated_is_subset
    unfolding ideal_gen_by_prod_def
    by blast
  show "𝟬 + a = a" "a + 𝟬 = a"
    if "a  ideal_gen_by_prod 𝔞 𝔟" for a
    using that additive.subgroup_generated_is_subset unfolding ideal_gen_by_prod_def
    by blast+
  show "monoid.invertible (ideal_gen_by_prod 𝔞 𝔟) (+) 𝟬 u"
    if "u  ideal_gen_by_prod 𝔞 𝔟" for u
    using that additive.subgroup_generated_is_subgroup group.invertible
    unfolding ideal_gen_by_prod_def subgroup_def
    by fastforce
  show "a  b  ideal_gen_by_prod 𝔞 𝔟"
    if "a  R" "b  ideal_gen_by_prod 𝔞 𝔟" for a b
    using that by (simp add: assms in_ideal_gen_by_prod)
  then show "b  a  ideal_gen_by_prod 𝔞 𝔟"
    if "a  R" "b  ideal_gen_by_prod 𝔞 𝔟" for a b
    using that
    by (metis ideal_gen_by_prod 𝔞 𝔟  R comm_mult in_mono)
qed

lemma ideal_gen_by_prod_is_inter:
  assumes "ideal 𝔞 R (+) (⋅) 𝟬 𝟭" and "ideal 𝔟 R (+) (⋅) 𝟬 𝟭"
  shows "ideal_gen_by_prod 𝔞 𝔟 =  {I. ideal I R (+) (⋅) 𝟬 𝟭  {a  b |a b. a  𝔞  b  𝔟}  I}"
    (is "?lhs = ?rhs")
proof
  have "x  ?rhs" if "x  ?lhs" for x
    using that
    unfolding ideal_gen_by_prod_def additive.subgroup_generated_def
    by induction (force simp: ideal_zero ideal_inverse ideal_add)+
  then show "?lhs  ?rhs" by blast
  show "?rhs  ?lhs"
    using assms ideal_subgroup_generated by (force simp: ideal_mult_in_subgroup_generated)
qed

end (* comm_ring *)

text ‹def. 0.18, see remark 0.20›
locale pr_ideal = comm:comm_ring R "(+)" "(⋅)" "𝟬" "𝟭" + ideal I R "(+)" "(⋅)" "𝟬" "𝟭"
  for R and I and addition (infixl "+" 65) and multiplication (infixl "" 70) and zero ("𝟬") and
unit ("𝟭")
+ assumes carrier_neq: "I  R" and absorbent: "x  R; y  R  (x  y  I)  (x  I  y  I)"
begin

text ‹
Note that in the locale prime ideal the order of I and R is reversed with respect to the locale
ideal, so that we can introduce some syntactic sugar later.
›

text ‹remark 0.21›
lemma not_1 [simp]:
  shows "𝟭  I"
proof
  assume "𝟭  I"
  then have "x. 𝟭  I; x  R  x  I"
    by (metis ideal(1) comm.multiplicative.right_unit)
  with 𝟭  I have "I = R"
    by auto
  then show False
    using carrier_neq by blast
qed

lemma not_invertible:
  assumes "x  I"
  shows "¬ comm.multiplicative.invertible x"
  using assms ideal(2) not_1 by blast

text ‹ex. 0.22›
lemma submonoid_notin:
  assumes "S = {x  R. x  I}"
  shows "submonoid S R (⋅) 𝟭"
proof
  show "S  R"
    using assms by force
  show "a  b  S"
    if "a  S"
      and "b  S"
    for a :: 'a
      and b :: 'a
    using that
    using absorbent assms by blast
  show "𝟭  S"
    using assms carrier_neq ideal(1) by fastforce
qed

end (* pr_ideal *)


section ‹Spectrum of a ring›

subsection ‹The Zariski Topology›

context comm_ring begin

text ‹Notation 1›
definition closed_subsets :: "'a set  ('a set) set" ("𝒱 _" [900] 900)
  where "𝒱 𝔞  {I. pr_ideal R I (+) (⋅) 𝟬 𝟭  𝔞  I}"

text ‹Notation 2›
definition spectrum :: "('a set) set" ("Spec")
  where "Spec  {I. pr_ideal R I (+) (⋅) 𝟬 𝟭}"

lemma cring0_spectrum_eq [simp]: "cring0.spectrum = {}"
  unfolding cring0.spectrum_def pr_ideal_def
  by (metis (no_types, lifting) Collect_empty_eq cring0.ideal_zero pr_ideal.intro pr_ideal.not_1)

text ‹remark 0.11›
lemma closed_subsets_R [simp]:
  shows "𝒱 R = {}"
  using ideal_implies_subset
  by (auto simp: closed_subsets_def pr_ideal_axioms_def pr_ideal_def)

lemma closed_subsets_zero [simp]:
  shows "𝒱 {𝟬} = Spec"
  unfolding closed_subsets_def spectrum_def pr_ideal_def pr_ideal_axioms_def
  by (auto dest: ideal_zero)

lemma closed_subsets_ideal_aux:
  assumes 𝔞: "ideal 𝔞 R (+) (⋅) 𝟬 𝟭" and 𝔟: "ideal 𝔟 R (+) (⋅) 𝟬 𝟭"
      and prime: "pr_ideal R x (+) (⋅) 𝟬 𝟭" and disj: "𝔞  x  𝔟  x"
  shows "ideal_gen_by_prod 𝔞 𝔟  x"
  unfolding ideal_gen_by_prod_def additive.subgroup_generated_def
proof
  fix u
  assume u: "u  additive.generate (R  {a  b |a b. a  𝔞  b  𝔟})"
  have "𝔞  R" "𝔟  R"
    using 𝔞 𝔟 ideal_implies_subset by auto
  show "u  x" using u
  proof induction
    case unit
    then show ?case
      by (meson comm_ring.ideal_zero prime pr_ideal_def)
  next
    case (incl a)
    then have "a  R"
      by blast
    with incl pr_ideal.axioms [OF prime] show ?case
      by clarsimp (metis 𝔞  R 𝔟  R disj ideal.ideal subset_iff)
  next
    case (inv a)
    then have "a  R"
      by blast
    with inv pr_ideal.axioms [OF prime] show ?case
      by clarsimp (metis 𝔞  R 𝔟  R disj ideal.ideal ideal_inverse subset_iff)
  next
    case (mult a b)
    then show ?case
      by (meson prime comm_ring.ideal_add pr_ideal_def)
  qed
qed


text ‹ex. 0.13›
lemma closed_subsets_ideal_iff:
  assumes "ideal 𝔞 R (+) (⋅) 𝟬 𝟭" and "ideal 𝔟 R (+) (⋅) 𝟬 𝟭"
  shows "𝒱 (ideal_gen_by_prod 𝔞 𝔟) = (𝒱 𝔞)  (𝒱 𝔟)" (is "?lhs = ?rhs")
proof
  show "?lhs  ?rhs"
    unfolding closed_subsets_def
    by clarsimp (meson assms ideal_implies_subset ideal_mult_in_subgroup_generated in_mono pr_ideal.absorbent)
  show "?rhs  ?lhs"
    unfolding closed_subsets_def
    using closed_subsets_ideal_aux [OF assms] by auto
qed

abbreviation finsum:: "'b set  ('b  'a)  'a"
  where "finsum I f  additive.finprod I f"

lemma finsum_empty [simp]: "finsum {} f = 𝟬"
  by (simp add: additive.finprod_def)

lemma finsum_insert:
  assumes "finite I" "i  I"
    and R: "f i  R" "j. j  I  f j  R"
  shows "finsum (insert i I) f = f i + finsum I f"
  unfolding additive.finprod_def
proof (subst LCD.foldD_insert [where B = "insert i I"])
  show "LCD (insert i I) R ((+)  f)"
  proof
    show "((+)  f) x (((+)  f) y z) = ((+)  f) y (((+)  f) x z)"
      if "x  insert i I" "y  insert i I" "z  R" for x y z
      using that additive.associative additive.commutative R by auto
    show "((+)  f) x y  R"
      if "x  insert i I" "y  R" for x y
      using that R by force
  qed
qed (use assms in auto)

lemma finsum_singleton [simp]:
  assumes "f i  R"
  shows "finsum {i} f = f i"
  by (metis additive.right_unit assms finite.emptyI finsum_empty finsum_insert insert_absorb insert_not_empty)


(* ex. 0.15 *)
lemma ex_15:
  fixes J :: "'b set" and 𝔞 :: "'b  'a set"
  assumes "J  {}" and J: "j. jJ  ideal (𝔞 j) R (+) (⋅) 𝟬 𝟭"
  shows "𝒱 ({x. I f. x = finsum I f  I  J  finite I  (i. iI  f i  𝔞 i)}) = (jJ. 𝒱 (𝔞 j))"
  proof -
  have "y  U"
    if j: "j  J" "y  𝔞 j"
      and "pr_ideal R U (+) (⋅) 𝟬 𝟭"
      and U: "{finsum I f |I f. I  J  finite I  (i. i  I  f i  𝔞 i)}  U"
    for U j y
  proof -
    have "y  R"
      using J j ideal_implies_subset by blast
    then have y: "y = finsum {j} (λ_. y)"
      by simp
    then have "y  {finsum I f |I f. I  J  finite I  (i. i  I  f i  𝔞 i)}"
      using that by blast
    then show ?thesis
      by (rule subsetD [OF U])
  qed
  moreover have PI: "pr_ideal R x (+) (⋅) 𝟬 𝟭" if "jJ. pr_ideal R x (+) (⋅) 𝟬 𝟭  𝔞 j  x" for x
    using that assms(1) by fastforce
  moreover have "finsum I f  U"
    if "finite I"
      and "jJ. pr_ideal R U (+) (⋅) 𝟬 𝟭  𝔞 j  U"
      and "I  J" "i. i  I  f i  𝔞 i" for U I f
    using that
  proof (induction I rule: finite_induct)
    case empty
    then show ?case
      using PI assms ideal_zero by fastforce
  next
    case (insert i I)
    then have "finsum (insert i I) f = f i + finsum I f"
      by (metis assms(2) finsum_insert ideal_implies_subset insertCI subset_iff)
    also have "...  U"
      using insert by (metis ideal_add insertCI pr_ideal.axioms(2) subset_eq)
    finally show ?case .
  qed
  ultimately show ?thesis
    by (auto simp: closed_subsets_def)
qed

(* ex 0.16 *)
definition is_zariski_open:: "'a set set  bool" where
"is_zariski_open U  generated_topology Spec {U. (𝔞. ideal 𝔞 R (+) (⋅) 𝟬 𝟭  U = Spec - 𝒱 𝔞)} U"

lemma is_zariski_open_empty [simp]: "is_zariski_open {}"
  using UNIV is_zariski_open_def generated_topology_is_topology topological_space.open_empty
  by simp

lemma is_zariski_open_Spec [simp]: "is_zariski_open Spec"
  by (simp add: UNIV is_zariski_open_def)

lemma is_zariski_open_Union [intro]:
  "(x. x  F  is_zariski_open x)  is_zariski_open ( F)"
  by (simp add: UN is_zariski_open_def)

lemma is_zariski_open_Int [simp]:
  "is_zariski_open U; is_zariski_open V  is_zariski_open (U  V)"
  using Int is_zariski_open_def by blast

lemma zariski_is_topological_space [iff]:
  shows "topological_space Spec is_zariski_open"
  unfolding is_zariski_open_def using generated_topology_is_topology
  by blast

lemma zariski_open_is_subset:
  assumes "is_zariski_open U"
  shows "U  Spec"
  using assms zariski_is_topological_space topological_space.open_imp_subset by auto

lemma cring0_is_zariski_open [simp]: "cring0.is_zariski_open = (λU. U={})"
  using cring0.cring0_spectrum_eq cring0.is_zariski_open_empty cring0.zariski_open_is_subset by blast

subsection ‹Standard Open Sets›

definition standard_open:: "'a  'a set set" ("𝒟'(_')")
  where "𝒟(x)  (Spec  𝒱(x))"

lemma standard_open_is_zariski_open:
  assumes "x  R"
  shows "is_zariski_open 𝒟(x)"
  unfolding is_zariski_open_def standard_open_def
  using assms gen_ideal_ideal generated_topology.simps by fastforce

lemma standard_open_is_subset:
  assumes "x  R"
  shows "𝒟(x)  Spec"
  by (simp add: assms standard_open_is_zariski_open zariski_open_is_subset)

lemma belongs_standard_open_iff:
  assumes "x  R" and "𝔭  Spec"
  shows "x  𝔭  𝔭  𝒟(x)"
  using assms
  apply (auto simp: standard_open_def closed_subsets_def spectrum_def gen_ideal_def subset_iff)
  apply (metis pr_ideal.absorbent)
  by (meson ideal.ideal(1) pr_ideal_def)

end (* comm_ring *)


subsection ‹Presheaves of Rings›

(* def 0.17 *)
locale presheaf_of_rings = Topological_Space.topological_space
  + fixes 𝔉:: "'a set  'b set"
  and ρ:: "'a set  'a set  ('b  'b)" and b:: "'b"
  and add_str:: "'a set  ('b  'b  'b)" ("+⇘_")
  and mult_str:: "'a set  ('b  'b  'b)" ("⋅⇘_")
  and zero_str:: "'a set  'b" ("𝟬⇘_") and one_str:: "'a set  'b" ("𝟭⇘_")
assumes is_ring_morphism:
  "U V. is_open U  is_open V  V  U  ring_homomorphism (ρ U V)
                                                  (𝔉 U) (+⇘U) (⋅⇘U) 𝟬⇘U⇙ 𝟭⇘U(𝔉 V) (+⇘V) (⋅⇘V) 𝟬⇘V⇙ 𝟭⇘V⇙"
  and ring_of_empty: "𝔉 {} = {b}"
  and identity_map [simp]: "U. is_open U  (x. x  𝔉 U  ρ U U x = x)"
  and assoc_comp:
  "U V W. is_open U  is_open V  is_open W  V  U  W  V 
(x. x  (𝔉 U)  ρ U W x = (ρ V W  ρ U V) x)"
begin

lemma is_ring_from_is_homomorphism:
  shows "U. is_open U  ring (𝔉 U) (+⇘U) (⋅⇘U) 𝟬⇘U⇙ 𝟭⇘U⇙"
  using is_ring_morphism ring_homomorphism.axioms(2) by fastforce

lemma is_map_from_is_homomorphism:
  assumes "is_open U" and "is_open V" and "V  U"
  shows "Set_Theory.map (ρ U V) (𝔉 U) (𝔉 V)"
  using assms by (meson is_ring_morphism ring_homomorphism.axioms(1))

lemma eq_ρ:
  assumes "is_open U" and "is_open V" and "is_open W" and "W  U  V" and "s  𝔉 U" and "t  𝔉 V"
    and "ρ U W s = ρ V W t" and "is_open W'" and "W'  W"
  shows "ρ U W' s = ρ V W' t"
  by (metis Int_subset_iff assms assoc_comp comp_apply)

end (* presheaf_of_rings *)

locale morphism_presheaves_of_rings =
source: presheaf_of_rings X is_open 𝔉 ρ b add_str mult_str zero_str one_str
  + target: presheaf_of_rings X is_open 𝔉' ρ' b' add_str' mult_str' zero_str' one_str'
  for X and is_open
    and 𝔉 and ρ and b and add_str ("+⇘_") and mult_str ("⋅⇘_")
    and zero_str ("𝟬⇘_") and one_str ("𝟭⇘_")
    and 𝔉' and ρ' and b' and add_str' ("+''⇘_") and mult_str' ("⋅''⇘_")
    and zero_str' ("𝟬''⇘_") and one_str' ("𝟭''⇘_") +
  fixes fam_morphisms:: "'a set  ('b  'c)"
  assumes is_ring_morphism: "U. is_open U  ring_homomorphism (fam_morphisms U)
                                                                (𝔉 U) (+⇘U) (⋅⇘U) 𝟬⇘U⇙ 𝟭⇘U(𝔉' U) (+'⇘U) (⋅'⇘U) 𝟬'⇘U⇙ 𝟭'⇘U⇙"
    and comm_diagrams: "U V. is_open U  is_open V  V  U 
               (x. x  𝔉 U  (ρ' U V  fam_morphisms U) x = (fam_morphisms V  ρ U V) x)"
begin

lemma fam_morphisms_are_maps:
  assumes "is_open U"
  shows "Set_Theory.map (fam_morphisms U) (𝔉 U) (𝔉' U)"
  using assms is_ring_morphism by (simp add: ring_homomorphism_def)

end (* morphism_presheaves_of_rings *)

(* Identity presheaf *)
lemma (in presheaf_of_rings) id_is_mor_pr_rngs:
  shows "morphism_presheaves_of_rings S is_open 𝔉 ρ b add_str mult_str zero_str one_str 𝔉 ρ b add_str mult_str zero_str one_str (λU. identity (𝔉 U))"
proof (intro morphism_presheaves_of_rings.intro morphism_presheaves_of_rings_axioms.intro)
  show "U. is_open U  ring_homomorphism (identity (𝔉 U))
                                            (𝔉 U) (add_str U) (mult_str U) (zero_str U) (one_str U)
                                            (𝔉 U) (add_str U) (mult_str U) (zero_str U) (one_str U)"
    by (metis identity_map is_map_from_is_homomorphism is_ring_morphism restrict_ext restrict_on_source subset_eq)
  show "U V. is_open U; is_open V; V  U
            (x. x  (𝔉 U)  (ρ U V  identity (𝔉 U)) x = (identity (𝔉 V)  ρ U V) x)"
    using map.map_closed by (metis comp_apply is_map_from_is_homomorphism restrict_apply')
qed (use presheaf_of_rings_axioms in auto)

lemma comp_ring_morphisms:
  assumes "ring_homomorphism η A addA multA zeroA oneA B addB multB zeroB oneB"
and "ring_homomorphism θ B addB multB zeroB oneB C addC multC zeroC oneC"
shows "ring_homomorphism (compose A θ η) A addA multA zeroA oneA C addC multC zeroC oneC"
  using comp_monoid_morphisms comp_group_morphisms assms
  by (metis monoid_homomorphism_def ring_homomorphism_def)

(* Composition of presheaves *)
 lemma comp_of_presheaves:
  assumes 1: "morphism_presheaves_of_rings X is_open 𝔉 ρ b add_str mult_str zero_str one_str 𝔉' ρ' b' add_str' mult_str' zero_str' one_str' φ"
    and 2: "morphism_presheaves_of_rings X is_open 𝔉' ρ' b' add_str' mult_str' zero_str' one_str' 𝔉'' ρ'' b'' add_str'' mult_str'' zero_str'' one_str'' φ'"
  shows "morphism_presheaves_of_rings X is_open 𝔉 ρ b add_str mult_str zero_str one_str 𝔉'' ρ'' b'' add_str'' mult_str'' zero_str'' one_str'' (λU. (φ' U  φ U  𝔉 U))"
proof (intro morphism_presheaves_of_rings.intro morphism_presheaves_of_rings_axioms.intro)
  show "ring_homomorphism (φ' U  φ U  𝔉 U) (𝔉 U) (add_str U) (mult_str U) (zero_str U) (one_str U) (𝔉'' U) (add_str'' U) (mult_str'' U) (zero_str'' U) (one_str'' U)"
    if "is_open U"
    for U :: "'a set"
    using that
    by (metis assms comp_ring_morphisms morphism_presheaves_of_rings.is_ring_morphism)
next
  show "x. x  (𝔉 U)  (ρ'' U V  (φ' U  φ U  𝔉 U)) x = (φ' V  φ V  𝔉 V  ρ U V) x"
    if "is_open U" "is_open V" "V  U" for U V
    using that
    using morphism_presheaves_of_rings.comm_diagrams [OF 1]
    using morphism_presheaves_of_rings.comm_diagrams [OF 2]
    using presheaf_of_rings.is_map_from_is_homomorphism [OF morphism_presheaves_of_rings.axioms(1) [OF 1]]
    by (metis "1" comp_apply compose_eq map.map_closed morphism_presheaves_of_rings.fam_morphisms_are_maps)
qed (use assms in auto simp: morphism_presheaves_of_rings_def)

locale iso_presheaves_of_rings = mor:morphism_presheaves_of_rings
+ assumes is_inv:
"ψ. morphism_presheaves_of_rings X is_open 𝔉' ρ' b' add_str' mult_str' zero_str' one_str' 𝔉 ρ b add_str mult_str zero_str one_str ψ
 (U. is_open U  (x  (𝔉' U). (fam_morphisms U  ψ U) x = x)  (x  (𝔉 U). (ψ U  fam_morphisms U) x = x))"


subsection ‹Sheaves of Rings›

(* def 0.19 *)
locale sheaf_of_rings = presheaf_of_rings +
  assumes locality: "U I V s. open_cover_of_open_subset S is_open U I V  (i. iI  V i  U) 
s  𝔉 U  (i. iI  ρ U (V i) s = 𝟬⇘(V i))  s = 𝟬⇘U⇙"
and
glueing: "U I V s. open_cover_of_open_subset S is_open U I V  (i. iI  V i  U  s i  𝔉 (V i)) 
(i j. iI  jI  ρ (V i) (V i  V j) (s i) = ρ (V j) (V i  V j) (s j)) 
(t. t  𝔉 U  (i. iI  ρ U (V i) t = s i))"

(* def. 0.20 *)
locale morphism_sheaves_of_rings = morphism_presheaves_of_rings

locale iso_sheaves_of_rings = iso_presheaves_of_rings

(* ex. 0.21 *)
locale ind_sheaf = sheaf_of_rings +
  fixes U:: "'a set"
  assumes is_open_subset: "is_open U"
begin

interpretation it: ind_topology S is_open U
  by (simp add: ind_topology.intro ind_topology_axioms.intro is_open_subset open_imp_subset topological_space_axioms)

definition ind_sheaf:: "'a set  'b set"
  where "ind_sheaf V  𝔉 (U  V)"

definition ind_ring_morphisms:: "'a set  'a set  ('b  'b)"
  where "ind_ring_morphisms V W  ρ (U  V) (U  W)"

definition ind_add_str:: "'a set  ('b  'b  'b)"
  where "ind_add_str V  λx y. +⇘(U  V)x y"

definition ind_mult_str:: "'a set  ('b  'b  'b)"
  where "ind_mult_str V  λx y. ⋅⇘(U  V)x y"

definition ind_zero_str:: "'a set  'b"
  where "ind_zero_str V  𝟬⇘(UV)⇙"

definition ind_one_str:: "'a set  'b"
  where "ind_one_str V  𝟭⇘(UV)⇙"

lemma ind_is_open_imp_ring:
  "U. it.ind_is_open U
    ring (ind_sheaf U) (ind_add_str U) (ind_mult_str U) (ind_zero_str U) (ind_one_str U)"
  unfolding ind_add_str_def it.ind_is_open_def ind_mult_str_def ind_one_str_def ind_sheaf_def ind_zero_str_def 
  using is_open_subset is_ring_from_is_homomorphism it.is_subset open_inter by force

lemma ind_sheaf_is_presheaf:
  shows "presheaf_of_rings U (it.ind_is_open) ind_sheaf ind_ring_morphisms b
ind_add_str ind_mult_str ind_zero_str ind_one_str"
proof -
  have "topological_space U it.ind_is_open" by (simp add: it.ind_space_is_top_space)
  moreover have "ring_homomorphism (ind_ring_morphisms W V)
                     (ind_sheaf W) (ind_add_str W) (ind_mult_str W) (ind_zero_str W) (ind_one_str W)
                     (ind_sheaf V) (ind_add_str V) (ind_mult_str V) (ind_zero_str V) (ind_one_str V)"
    if "it.ind_is_open W" "it.ind_is_open V" "V  W" for W V
  proof (intro ring_homomorphism.intro ind_is_open_imp_ring)
    show "Set_Theory.map (ind_ring_morphisms W V) (ind_sheaf W) (ind_sheaf V)"
      unfolding ind_ring_morphisms_def ind_sheaf_def
      by (metis that it.ind_is_open_def inf.left_idem is_open_subset is_ring_morphism 
          open_inter ring_homomorphism_def)
    from that
    obtain o: "is_open (U  V)" "is_open (U  W)" "U  V  U  W"
      by (metis (no_types) it.ind_is_open_def inf.absorb_iff2 is_open_subset open_inter)
    then show "group_homomorphism (ind_ring_morphisms W V) (ind_sheaf W) (ind_add_str W) (ind_zero_str W) (ind_sheaf V) (ind_add_str V) (ind_zero_str V)"
      unfolding ind_ring_morphisms_def ind_sheaf_def ind_zero_str_def
      by (metis ind_sheaf.ind_add_str_def ind_sheaf_axioms is_ring_morphism ring_homomorphism.axioms(4))
    show "monoid_homomorphism (ind_ring_morphisms W V) (ind_sheaf W) (ind_mult_str W) (ind_one_str W) (ind_sheaf V) (ind_mult_str V) (ind_one_str V)"
      using o by (metis ind_mult_str_def ind_one_str_def ind_ring_morphisms_def ind_sheaf_def is_ring_morphism ring_homomorphism_def)
  qed (use that in auto)
  moreover have "ind_sheaf {} = {b}"
    by (simp add: ring_of_empty ind_sheaf_def)
  moreover have "U. it.ind_is_open U  (x. x  (ind_sheaf U)  ind_ring_morphisms U U x = x)"
    by (simp add: Int_absorb1 it.ind_is_open_def ind_ring_morphisms_def ind_sheaf_def it.is_open_from_ind_is_open is_open_subset)
  moreover have "U V W. it.ind_is_open U  it.ind_is_open V  it.ind_is_open W  V  U  W  V
              (x. x  (ind_sheaf U)  ind_ring_morphisms U W x = (ind_ring_morphisms V W  ind_ring_morphisms U V) x)"
    by (metis Int_absorb1 assoc_comp it.ind_is_open_def ind_ring_morphisms_def ind_sheaf_def it.is_open_from_ind_is_open is_open_subset)
  ultimately show ?thesis
    unfolding presheaf_of_rings_def presheaf_of_rings_axioms_def by blast
qed

lemma ind_sheaf_is_sheaf:
  shows "sheaf_of_rings U it.ind_is_open ind_sheaf ind_ring_morphisms b ind_add_str ind_mult_str ind_zero_str ind_one_str"
proof (intro sheaf_of_rings.intro sheaf_of_rings_axioms.intro)
  show "presheaf_of_rings U it.ind_is_open ind_sheaf ind_ring_morphisms b ind_add_str ind_mult_str ind_zero_str ind_one_str"
    using ind_sheaf_is_presheaf by blast
next
  fix V I W s
  assume oc: "open_cover_of_open_subset U it.ind_is_open V I W"
    and WV: "i. i  I  W i  V"
    and s: "s  ind_sheaf V"
    and eq: "i. i  I  ind_ring_morphisms V (W i) s = ind_zero_str (W i)"
  have "it.ind_is_open V"
    using oc open_cover_of_open_subset.is_open_subset by blast
  then have "s  𝔉 V"
    by (metis ind_sheaf.ind_sheaf_def ind_sheaf_axioms it.ind_is_open_def inf.absorb2 s)
  then have "s = 𝟬⇘V⇙"
    by (metis Int_absorb1 Int_subset_iff WV ind_sheaf.ind_zero_str_def ind_sheaf_axioms eq it.ind_is_open_def ind_ring_morphisms_def is_open_subset locality oc it.open_cover_from_ind_open_cover open_cover_of_open_subset.is_open_subset)
  then show "s = ind_zero_str V"
    by (metis Int_absorb1 it.ind_is_open_def ind_zero_str_def oc open_cover_of_open_subset.is_open_subset)
next
  fix V I W s
  assume oc: "open_cover_of_open_subset U it.ind_is_open V I W"
    and WV: "i. i  I  W i  V  s i  ind_sheaf (W i)"
    and eq: "i j. i  I; j  I  ind_ring_morphisms (W i) (W i  W j) (s i) = ind_ring_morphisms (W j) (W i  W j) (s j)"
  have "is_open V"
    using it.is_open_from_ind_is_open is_open_subset oc open_cover_of_open_subset.is_open_subset by blast
  moreover have "open_cover_of_open_subset S is_open V I W"
    using it.open_cover_from_ind_open_cover oc ind_topology.intro ind_topology_axioms_def is_open_subset it.is_subset topological_space_axioms by blast
  moreover have "ρ (W i) (W i  W j) (s i) = ρ (W j) (W i  W j) (s j)"
    if "iI" "jI" for i j
  proof -
    have "U  W i = W i" and "U  W j = W j"
      by (metis Int_absorb1 WV it.ind_is_open_def oc open_cover_of_open_subset.is_open_subset
            subset_trans that)+
    then show ?thesis
      using eq[unfolded ind_ring_morphisms_def,OF that] by (metis inf_sup_aci(2))
  qed
  moreover have "i. iI  W i  V  s i  𝔉 (W i)"
    by (metis WV it.ind_is_open_def ind_sheaf_def inf.orderE inf_idem inf_aci(3) oc open_cover_of_open_subset.is_open_subset)
  ultimately
  obtain t where "t  (𝔉 V)  (i. iI  ρ V (W i) t = s i)"
    using glueing by blast
  then have "t  ind_sheaf V"
    unfolding ind_sheaf_def using oc
    by (metis Int_absorb1 cover_of_subset_def open_cover_of_open_subset_def open_cover_of_subset_def)
  moreover have "i. iI  ind_ring_morphisms V (W i) t = s i"
    unfolding ind_ring_morphisms_def
    by (metis oc Int_absorb1 t  𝔉 V  (i. i  I  ρ V (W i) t = s i) cover_of_subset_def open_cover_of_open_subset_def open_cover_of_subset_def)
  ultimately show "t. t  (ind_sheaf V)  (i. iI  ind_ring_morphisms V (W i) t = s i)" by blast
qed

end (* ind_sheaf *)

(* construction 0.22 *)
locale im_sheaf = sheaf_of_rings + continuous_map
begin

(* def 0.24 *)
definition im_sheaf:: "'c set => 'b set"
  where "im_sheaf V  𝔉 (f¯ S V)"

definition im_sheaf_morphisms:: "'c set  'c set  ('b  'b)"
  where "im_sheaf_morphisms U V  ρ (f¯ S U) (f¯ S V)"

definition add_im_sheaf:: "'c set  'b  'b  'b"
  where "add_im_sheaf  λV x y. +⇘(f¯ S V)x y"

definition mult_im_sheaf:: "'c set  'b  'b  'b"
  where "mult_im_sheaf  λV x y. ⋅⇘(f¯ S V)x y"

definition zero_im_sheaf:: "'c set  'b"
  where "zero_im_sheaf  λV. 𝟬⇘(f¯ S V)⇙"

definition one_im_sheaf:: "'c set  'b"
  where "one_im_sheaf  λV. 𝟭⇘(f¯ S V)⇙"

lemma im_sheaf_is_presheaf:
  "presheaf_of_rings S' (is_open') im_sheaf im_sheaf_morphisms b
add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf"
proof (intro presheaf_of_rings.intro presheaf_of_rings_axioms.intro)
  show "topological_space S' is_open'"
    by (simp add: target.topological_space_axioms)
  show "U V. is_open' U; is_open' V; V  U
            ring_homomorphism (im_sheaf_morphisms U V)
(im_sheaf U) (add_im_sheaf U) (mult_im_sheaf U) (zero_im_sheaf U) (one_im_sheaf U)
(im_sheaf V) (add_im_sheaf V) (mult_im_sheaf V) (zero_im_sheaf V) (one_im_sheaf V)"
    unfolding add_im_sheaf_def mult_im_sheaf_def zero_im_sheaf_def one_im_sheaf_def
    by (metis Int_commute Int_mono im_sheaf_def im_sheaf_morphisms_def is_continuous is_ring_morphism subset_refl vimage_mono)
  show "im_sheaf {} = {b}" using im_sheaf_def ring_of_empty by simp
  show "U. is_open' U  (x. x  (im_sheaf U)  im_sheaf_morphisms U U x = x)"
    using im_sheaf_morphisms_def by (simp add: im_sheaf_def is_continuous)
  show "U V W.
       is_open' U; is_open' V; is_open' W; V  U; W  V
        (x. x  (im_sheaf U)  im_sheaf_morphisms U W x = (im_sheaf_morphisms V W  im_sheaf_morphisms U V) x)"
    by (metis Int_mono assoc_comp im_sheaf_def im_sheaf_morphisms_def ind_topology.is_subset is_continuous ind_topology_is_open_self vimage_mono)
qed

(* ex 0.23 *)
lemma im_sheaf_is_sheaf:
  shows "sheaf_of_rings S' (is_open') im_sheaf im_sheaf_morphisms b
add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf"
proof (intro sheaf_of_rings.intro sheaf_of_rings_axioms.intro)
  show "presheaf_of_rings S' is_open' im_sheaf im_sheaf_morphisms b
add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf"
    using im_sheaf_is_presheaf by force
next
  fix U I V s
  assume oc: "open_cover_of_open_subset S' is_open' U I V"
    and VU: "i. i  I  V i  U"
    and s: "s  im_sheaf U"
    and eq0: "i. i  I  im_sheaf_morphisms U (V i) s =zero_im_sheaf (V i)"
  have "open_cover_of_open_subset S is_open (f¯ S U) I (λi. f¯ S (V i))"
    by (simp add: oc open_cover_of_open_subset_from_target_to_source)
  then show "s = zero_im_sheaf U" using zero_im_sheaf_def
    by (smt VU im_sheaf_def im_sheaf_morphisms_def eq0 inf.absorb_iff2 inf_le2 inf_sup_aci(1) inf_sup_aci(3) locality s vimage_Int)
next
  fix U I V s
  assume oc: "open_cover_of_open_subset S' is_open' U I V"
    and VU: "i. i  I  V i  U  s i  im_sheaf (V i)"
    and eq: "i j. i  I; j  I  im_sheaf_morphisms (V i) (V i  V j) (s i) = im_sheaf_morphisms (V j) (V i  V j) (s j)"
  have "t. t  𝔉 (f  ¯ S U)  (i. i  I  ρ (f  ¯ S U) (f  ¯ S (V i)) t = s i)"
  proof (rule glueing)
    show "open_cover_of_open_subset S is_open (f ¯ S U) I (λi. f ¯ S (V i))"
      using oc open_cover_of_open_subset_from_target_to_source by presburger
    show "i. i  I  f ¯ S (V i)  f ¯ S U  s i  𝔉 (f ¯ S (V i))"
      using VU im_sheaf_def by blast
    show "ρ (f ¯ S (V i)) (f ¯ S (V i)  f ¯ S (V j)) (s i) = ρ (f ¯ S (V j)) (f ¯ S (V i)  f ¯ S (V j)) (s j)"
      if "i  I" "j  I" for i j
      using im_sheaf_morphisms_def eq that
      by (smt Int_commute Int_left_commute inf.left_idem vimage_Int)
  qed
  then obtain t where "t  𝔉 (f¯ S U)  (i. iI  ρ (f¯ S U) (f¯ S (V i)) t = s i)" ..
  then show "t. t  im_sheaf U  (i. i  I  im_sheaf_morphisms U (V i) t = s i)"
    using im_sheaf_def im_sheaf_morphisms_def by auto
qed

sublocale sheaf_of_rings S' is_open' im_sheaf im_sheaf_morphisms b
    add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf
  using im_sheaf_is_sheaf .

end (* im_sheaf *)

lemma (in sheaf_of_rings) id_to_iso_of_sheaves:
  shows "iso_sheaves_of_rings S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            (im_sheaf.im_sheaf S 𝔉 (identity S))
            (im_sheaf.im_sheaf_morphisms S ρ (identity S))
            b
            (λV. +⇘identity S ¯ S V) (λV. ⋅⇘identity S ¯ S V) (λV. 𝟬⇘identity S ¯ S V) (λV. 𝟭⇘identity S ¯ S V) (λU. identity (𝔉 U))"
    (is "iso_sheaves_of_rings S is_open 𝔉 ρ b _ _ _ _ _ _ b  ?add ?mult ?zero ?one ?F")
proof-
  have preq[simp]: "V. V  S  (identity S ¯ S V) = V"
    by auto
  interpret id: im_sheaf S is_open 𝔉 ρ b add_str mult_str zero_str one_str S is_open "identity S"
    by intro_locales (auto simp add: Set_Theory.map_def continuous_map_axioms_def open_imp_subset)
  have 1[simp]: "V. V  S  im_sheaf.im_sheaf S 𝔉 (identity S) V = 𝔉 V"
    by (simp add: id.im_sheaf_def)
  have 2[simp]: "U V. U  S; V  S  im_sheaf.im_sheaf_morphisms S ρ (identity S) U V  ρ U V"
    using id.im_sheaf_morphisms_def by auto
  show ?thesis
  proof intro_locales
    have rh: "U. is_open U 
         ring_homomorphism (identity (𝔉 U)) (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U(𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U⇙"
      using id_is_mor_pr_rngs morphism_presheaves_of_rings.is_ring_morphism by fastforce
    show "morphism_presheaves_of_rings_axioms is_open 𝔉 ρ add_str mult_str zero_str one_str
           id.im_sheaf id.im_sheaf_morphisms ?add ?mult ?zero ?one ?F"
      unfolding morphism_presheaves_of_rings_axioms_def
      by (auto simp: rh open_imp_subset intro: is_map_from_is_homomorphism map.map_closed)
    have ρ: "U V W x. is_open U; is_open V; is_open W; V  U; W  V; x  𝔉 U  ρ V W (ρ U V x) = ρ U W x"
      by (metis assoc_comp comp_def)
    show "presheaf_of_rings_axioms is_open id.im_sheaf id.im_sheaf_morphisms b ?add ?mult ?zero ?one"
      by (auto simp: ρ presheaf_of_rings_axioms_def is_ring_morphism open_imp_subset ring_of_empty)
    then have "presheaf_of_rings S is_open id.im_sheaf id.im_sheaf_morphisms b ?add ?mult ?zero ?one"
      by (metis id.im_sheaf_is_presheaf presheaf_of_rings_def)
    moreover
    have "morphism_presheaves_of_rings_axioms is_open
          id.im_sheaf id.im_sheaf_morphisms ?add ?mult ?zero ?one 𝔉 ρ add_str
          mult_str zero_str one_str (λU. λx𝔉 U. x)"
      unfolding morphism_presheaves_of_rings_axioms_def
      by (auto simp: rh open_imp_subset intro: is_map_from_is_homomorphism map.map_closed)
    ultimately
    show "iso_presheaves_of_rings_axioms S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            id.im_sheaf id.im_sheaf_morphisms b ?add ?mult ?zero ?one ?F"
      by (auto simp: presheaf_of_rings_axioms iso_presheaves_of_rings_axioms_def morphism_presheaves_of_rings_def open_imp_subset)
  qed
qed


subsection ‹Quotient Ring›

(*Probably for Group_Theory*)
context group begin

lemma cancel_imp_equal:
  " u  inverse v = 𝟭;  u  G; v  G   u = v"
  by (metis invertible invertible_inverse_closed invertible_right_cancel invertible_right_inverse)

end

(*Probably for Ring_Theory*)
context ring begin

lemma inverse_distributive: " a  R; b  R; c  R   a  (b - c) = a  b - a  c"
    " a  R; b  R; c  R   (b - c)  a = b  a - c  a"
  using additive.invertible additive.invertible_inverse_closed distributive
        local.left_minus local.right_minus by presburger+

end

locale quotient_ring = comm:comm_ring R "(+)" "(⋅)" "𝟬" "𝟭" + submonoid S R "(⋅)" "𝟭"
  for S and R and addition (infixl "+" 65) and multiplication (infixl "" 70) and zero ("𝟬") and
unit ("𝟭")
begin

lemmas comm_ring_simps =
  comm.multiplicative.associative
  comm.additive.associative
  comm.comm_mult
  comm.additive.commutative
  right_minus

definition rel:: "('a × 'a)  ('a × 'a)  bool" (infix "" 80)
  where "x  y  s1. s1  S  s1  (snd y  fst x - snd x  fst y) = 𝟬"

lemma rel_refl: "x. x  R × S  x  x"
    by (auto simp: rel_def)

lemma rel_sym:
  assumes "x  y" "x  R × S" "y  R × S" shows "y  x"
proof -
  obtain rx sx ry sy s
    where §: "rx  R" "sx  S" "ry  R" "s  S" "sy  S" "s  (sy  rx - sx  ry) = 𝟬" "x = (rx,sx)" "y = (ry,sy)"
    using assms by (auto simp: rel_def)
  then have "s  (sx  ry - sy  rx) = 𝟬"
    by (metis sub comm.additive.cancel_imp_equal comm.inverse_distributive(1) comm.multiplicative.composition_closed)
  with § show ?thesis
    by (auto simp: rel_def)
qed

lemma rel_trans:
  assumes "x  y" "y  z" "x  R × S" "y  R × S" "z  R × S" shows "x  z"
  using assms
proof (clarsimp simp: rel_def)
  fix r s r2 s2 r1 s1 sx sy
  assume §: "r  R" "s  S" "r1  R" "s1  S" "sx  S" "r2  R" "s2  S" "sy  S"
    and sx0: "sx  (s1  r2 - s2  r1) = 𝟬" and sy0: "sy  (s2  r - s  r2) = 𝟬"
  show "u. u  S  u  (s1  r - s  r1) = 𝟬"
  proof (intro exI conjI)
    show "sx  sy  s1  s2  S"
      using § by blast
    have sx: "sx  s1  r2 = sx  s2  r1" and sy: "sy  s2  r = sy  s  r2"
      using sx0 sy0 § comm.additive.cancel_imp_equal comm.inverse_distributive(1)
        comm.multiplicative.associative comm.multiplicative.composition_closed sub
      by metis+
    then
    have "sx  sy  s1  s2  (s1  r - s  r1) = sx  sy  s1  s2  s1  r - sx  sy  s1  s2  s  r1"
      using "§" sx  sy  s1  s2  S
        comm.inverse_distributive(1) comm.multiplicative.associative comm.multiplicative.composition_closed
        sub
      by presburger
    also have "... = sx  sy  s1  s  s1  r2 - sx  sy  s1  s2  s  r1"
      using §
      by (smt sy comm.comm_mult comm.multiplicative.associative comm.multiplicative.composition_closed sub)
    also have "... = sx  sy  s1  s  s1  r2 - sx  sy  s1  s1  s  r2"
      using § by (smt sx comm.comm_mult comm.multiplicative.associative
          comm.multiplicative.composition_closed sub)
    also have "... = 𝟬"
      using § by (simp add: comm.ring_mult_ac)
    finally show "sx  sy  s1  s2  (s1  r - s  r1) = 𝟬" .
  qed
qed

interpretation rel: equivalence "R × S" "{(x,y)  (R×S)×(R×S). x  y}"
  by (blast intro: equivalence.intro rel_refl rel_sym rel_trans)


notation equivalence.Partition (infixl "'/" 75)

definition frac:: "'a  'a  ('a × 'a) set" (infixl "'/" 75)
  where "r / s  rel.Class (r, s)"

lemma frac_Pow:"(r, s)  R × S  frac r s  Pow (R × S) "
  using local.frac_def rel.Class_closed2 by auto

lemma frac_eqI:
  assumes "s1S" and "(r, s)  R × S" "(r', s')  R × S"
     and eq:"s1  s'  r = s1  s  r'"
  shows "frac r s = frac r' s'"
  unfolding frac_def
proof (rule rel.Class_eq)
  have "s1  (s'  r - s  r') = 𝟬"
    using assms comm.inverse_distributive(1) comm.multiplicative.associative by auto
  with s1S have "(r, s)  (r', s')"
    unfolding rel_def by auto
  then show "((r, s), r', s')  {(x, y). (x, y)  (R × S) × R × S  x  y}"
    using assms(2,3) by auto
qed

lemma frac_eq_Ex:
  assumes "(r, s)  R × S" "(r', s')  R × S" "frac r s = frac r' s'"
  obtains s1 where "s1S" "s1  (s'  r - s  r') = 𝟬"
proof -
  have "(r, s)  (r', s')"
    using frac r s = frac r' s' rel.Class_equivalence[OF assms(1,2)]
    unfolding frac_def by auto
  then show ?thesis unfolding rel_def
    by (metis fst_conv snd_conv that)
qed

lemma frac_cancel:
  assumes "s1S" and "(r, s)  R × S"
  shows "frac (s1r) (s1s) = frac r s"
  apply (rule frac_eqI[of 𝟭])
  using assms comm_ring_simps by auto

lemma frac_eq_obtains:
  assumes "(r,s)  R × S" and x_def:"x=(SOME x. x(frac r s))"
  obtains s1 where "s1S" "s1  s  fst x = s1  snd x  r" and "x  R × S"
proof -
  have "x(r/s)"
    unfolding x_def
    apply (rule someI[of _ "(r,s)"])
    using assms(1) local.frac_def by blast
  from rel.ClassD[OF this[unfolded frac_def] (r,s)  R × S]
  have x_RS:"xR × S" and "x  (r,s)" by auto
  from this(2) obtain s1 where "s1S" and "s1  (s  fst x - snd x  r) = 𝟬"
    unfolding rel_def by auto
  then have x_eq:"s1  s  fst x = s1  snd x  r"
    using comm.distributive x_RS assms(1)
    by (smt comm.additive.group_axioms group.cancel_imp_equal comm.inverse_distributive(1)
        mem_Sigma_iff comm.multiplicative.associative comm.multiplicative.composition_closed prod.collapse sub)
  then show ?thesis using that x_RS s1S by auto
qed

definition valid_frac::"('a × 'a) set  bool" where
  "valid_frac X  rR. sS. r / s = X"

lemma frac_non_empty[simp]:"(a,b)  R × S  valid_frac (frac a b)"
  unfolding frac_def valid_frac_def by blast

definition add_rel_aux:: "'a  'a  'a  'a  ('a × 'a) set"
  where "add_rel_aux r s r' s'  (rs' + r's) / (ss')"

definition add_rel:: "('a × 'a) set  ('a × 'a) set  ('a × 'a) set"
  where "add_rel X Y 
  let x = (SOME x. x  X) in
  let y = (SOME y. y  Y) in
  add_rel_aux (fst x) (snd x) (fst y) (snd y)"

lemma add_rel_frac:
  assumes "(r,s)  R × S" "(r',s') R × S"
  shows "add_rel (r/s) (r'/s') = (rs' + r's) / (ss')"
proof -
  define x where "x=(SOME x. x(r/s))"
  define y where "y=(SOME y. y(r'/s'))"

  obtain s1 where [simp]:"s1  S" and x_eq:"s1  s  fst x = s1  snd x  r" and x_RS:"x  R × S"
    using frac_eq_obtains[OF (r,s)  R × S x_def] by auto
  obtain s2 where [simp]:"s2  S" and y_eq:"s2  s'  fst y = s2  snd y  r'" and y_RS:"y  R × S"
    using frac_eq_obtains[OF (r',s')  R × S y_def] by auto

  have "add_rel (r/s) (r'/s') = (fst x  snd y + fst y  snd x) / (snd x  snd y)"
    unfolding add_rel_def add_rel_aux_def x_def y_def Let_def by auto
  also have "... = (rs' + r's) / (ss')"
  proof (rule frac_eqI[of "s1  s2"])
    have "snd y   s'  s2  (s1   s  fst x)  = snd y  s'  s2  (s1   snd x   r)"
      using x_eq by simp
    then have "s1  s2  s  s'  fst x  snd y =  s1  s2  snd x  snd y  r  s'"
      using comm.multiplicative.associative assms x_RS y_RS comm.comm_mult by auto
    moreover have "snd x  s s1  (s2  s'  fst y) = snd x  s s1  (s2  snd y  r')"
      using y_eq by simp
    then have "s1  s2  s  s'  fst y  snd x = s1  s2  snd x  snd y  r'  s"
      using comm.multiplicative.associative assms x_RS y_RS comm.comm_mult
      by auto
    ultimately show "s1  s2  (s  s')  (fst x  snd y + fst y  snd x)
        = s1  s2  (snd x  snd y)  (r  s' + r'  s)"
      using comm.multiplicative.associative assms x_RS y_RS comm.distributive
      by auto
    show "s1  s2  S" "(fst x  snd y + fst y  snd x, snd x  snd y)  R × S"
        "(r  s' + r'  s, s  s')  R × S"
      using assms x_RS y_RS by auto
  qed
  finally show ?thesis by auto
qed

lemma valid_frac_add[intro,simp]:
  assumes "valid_frac X" "valid_frac Y"
  shows "valid_frac (add_rel X Y)"
proof -
  obtain r s r' s' where "rR" "sS" "r'R" "s'S"
      and *:"add_rel X Y = (rs' + r's) / (ss')"
  proof -
    define x where "x=(SOME x. xX)"
    define y where "y=(SOME y. yY)"
    have "xX" "yY"
      using assms unfolding x_def y_def valid_frac_def some_in_eq local.frac_def
      by blast+
    then obtain "x  R × S" "y  R × S"
      using assms
      by (simp add: valid_frac_def x_def y_def) (metis frac_eq_obtains mem_Sigma_iff)
    moreover have "add_rel X Y = (fst x  snd y + fst y  snd x) / (snd x  snd y)"
      unfolding add_rel_def add_rel_aux_def x_def y_def Let_def by auto
    ultimately show ?thesis using that by auto
  qed
  from this(1-4)
  have "(rs' + r's,ss')  R × S"
    by auto
  with * show ?thesis by auto
qed

definition uminus_rel:: "('a × 'a) set  ('a × 'a) set"
  where "uminus_rel X  let x = (SOME x. x  X) in (comm.additive.inverse (fst x) / snd x)"

lemma uminus_rel_frac:
  assumes "(r,s)  R × S"
  shows "uminus_rel (r/s) = (comm.additive.inverse r) / s"
proof -
  define x where "x=(SOME x. x(r/s))"

  obtain s1 where [simp]:"s1  S" and x_eq:"s1  s  fst x = s1  snd x  r" and x_RS:"x  R × S"
    using frac_eq_obtains[OF (r,s)  R × S x_def] by auto

  have "uminus_rel (r/s)= (comm.additive.inverse (fst x)) / (snd x )"
    unfolding uminus_rel_def x_def Let_def by auto
  also have "... = (comm.additive.inverse r) / s"
    apply (rule frac_eqI[of s1])
    using x_RS assms x_eq by (auto simp add: comm.right_minus)
  finally show ?thesis .
qed

lemma valid_frac_uminus[intro,simp]:
  assumes "valid_frac X"
  shows "valid_frac (uminus_rel X)"
proof -
  obtain r s where "rR" "sS"
      and *:"uminus_rel X = (comm.additive.inverse r) / s"
  proof -
    define x where "x=(SOME x. xX)"
    have "xX"
      using assms unfolding x_def valid_frac_def some_in_eq local.frac_def
      by blast
    then have "x R × S"
      using assms valid_frac_def
      by (metis frac_eq_obtains mem_Sigma_iff x_def)
    moreover have "uminus_rel X = (comm.additive.inverse (fst x) ) / (snd x)"
      unfolding uminus_rel_def x_def Let_def by auto
    ultimately show ?thesis using that by auto
  qed
  from this(1-3)
  have "(comm.additive.inverse r,s)  R × S" by auto
  with * show ?thesis by auto
qed

definition mult_rel_aux:: "'a  'a  'a  'a  ('a × 'a) set"
  where "mult_rel_aux r s r' s'  (rr') / (ss')"

definition mult_rel:: "('a × 'a) set  ('a × 'a) set  ('a × 'a) set"
  where "mult_rel X Y 
  let x = (SOME x. x  X) in
  let y = (SOME y. y  Y) in
  mult_rel_aux (fst x) (snd x) (fst y) (snd y)"

lemma mult_rel_frac:
  assumes "(r,s)  R × S" "(r',s') R × S"
  shows "mult_rel (r/s) (r'/s') = (r r') / (ss')"
proof -
   define x where "x=(SOME x. x(r/s))"
  define y where "y=(SOME y. y(r'/s'))"

  obtain s1 where [simp]:"s1  S" and x_eq:"s1  s  fst x = s1  snd x  r" and x_RS:"x  R × S"
    using frac_eq_obtains[OF (r,s)  R × S x_def] by auto
  obtain s2 where [simp]:"s2  S" and y_eq:"s2  s'  fst y = s2  snd y  r'" and y_RS:"y  R × S"
    using frac_eq_obtains[OF (r',s')  R × S y_def] by auto

  have "mult_rel (r/s) (r'/s') = (fst x  fst y ) / (snd x  snd y)"
    unfolding mult_rel_def mult_rel_aux_def x_def y_def Let_def by auto
  also have "... = (r r') / (ss')"
  proof (rule frac_eqI[of "s1  s2"])
    have "(s1  s  fst x)  (s2  s'  fst y)  = (s1  snd x  r)  (s2  snd y  r')"
      using x_eq y_eq by auto
    then show "s1  s2  (s  s')  (fst x  fst y) = s1  s2  (snd x  snd y)  (r  r')"
      using comm.multiplicative.associative assms x_RS y_RS comm.distributive comm.comm_mult by auto
    show "s1  s2  S" "(fst x  fst y, snd x  snd y)  R × S"
        "(r  r', s  s')  R × S"
      using assms x_RS y_RS by auto
  qed
  finally show ?thesis by auto
qed

lemma valid_frac_mult[intro,simp]:
  assumes "valid_frac X" "valid_frac Y"
  shows "valid_frac (mult_rel X Y)"
proof -
  obtain r s r' s' where "rR" "sS" "r'R" "s'S"
      and *:"mult_rel X Y = (r r') / (ss')"
  proof -
    define x where "x=(SOME x. xX)"
    define y where "y=(SOME y. yY)"
    have "xX" "yY"
      using assms unfolding x_def y_def valid_frac_def some_in_eq local.frac_def
      by blast+
    then obtain "x  R × S" "y  R × S"
      using assms
      by (simp add: valid_frac_def x_def y_def) (metis frac_eq_obtains mem_Sigma_iff)
    moreover have "mult_rel X Y = (fst x  fst y) / (snd x  snd y)"
      unfolding mult_rel_def mult_rel_aux_def x_def y_def Let_def by auto
    ultimately show ?thesis using that by auto
  qed
  from this(1-4)
  have "(rr',ss')  R × S"
    by auto
  with * show ?thesis by auto
qed

definition zero_rel::"('a × 'a) set" where
  "zero_rel = frac 𝟬 𝟭"

definition one_rel::"('a × 'a) set" where
  "one_rel = frac 𝟭 𝟭"

lemma valid_frac_zero[simp]:
  "valid_frac zero_rel"
  unfolding zero_rel_def valid_frac_def by blast

lemma valid_frac_one[simp]:
  "valid_frac one_rel"
  unfolding one_rel_def valid_frac_def by blast

definition carrier_quotient_ring:: "('a × 'a) set set"
  where "carrier_quotient_ring  rel.Partition"

lemma carrier_quotient_ring_iff[iff]: "X  carrier_quotient_ring  valid_frac X "
  unfolding valid_frac_def carrier_quotient_ring_def
  using local.frac_def rel.natural.map_closed rel.representant_exists by fastforce

lemma frac_from_carrier:
  assumes "X  carrier_quotient_ring"
  obtains r s where "r  R" "s  S" "X = rel.Class (r,s)"
  using assms carrier_quotient_ring_def
  by (metis (no_types, lifting) SigmaE rel.representant_exists)

lemma add_minus_zero_rel:
  assumes "valid_frac a"
  shows "add_rel a (uminus_rel a) = zero_rel"
proof -
  obtain a1 a2 where a_RS:"(a1, a2)R × S" and a12:"a = a1 / a2 "
    using valid_frac a unfolding valid_frac_def by auto
  have "add_rel a (uminus_rel a) =  𝟬 / (a2  a2)"
    unfolding a12 using comm_ring_simps a_RS
    by (simp add:add_rel_frac uminus_rel_frac comm.right_minus)
  also have "... = 𝟬 / 𝟭"
    apply (rule frac_eqI[of 𝟭])
    using a_RS by auto
  also have "... = zero_rel" unfolding zero_rel_def ..
  finally show "add_rel a (uminus_rel a) = zero_rel" .
qed


(* ex. 0.26 *)
sublocale comm_ring carrier_quotient_ring add_rel mult_rel zero_rel one_rel
proof (unfold_locales; unfold carrier_quotient_ring_iff)
  show add_assoc:"add_rel (add_rel a b) c = add_rel a (add_rel b c)" and
       mult_assoc:"mult_rel (mult_rel a b) c = mult_rel a (mult_rel b c)" and
       distr:"mult_rel a (add_rel b c) = add_rel (mult_rel a b) (mult_rel a c)"
    if "valid_frac a" and "valid_frac b" and "valid_frac c" for a b c
  proof -
    obtain a1 a2 where a_RS:"(a1, a2)R × S" and a12:"a = a1 / a2 "
      using valid_frac a unfolding valid_frac_def by auto
    obtain b1 b2 where b_RS:"(b1, b2)R × S" and b12:"b = b1 / b2 "
      using valid_frac b unfolding valid_frac_def by auto
    obtain c1 c2 where c_RS:"(c1, c2)R × S" and c12:"c = c1 / c2"
      using valid_frac c unfolding valid_frac_def by auto

    have "add_rel (add_rel a b) c = add_rel (add_rel (a1/a2) (b1/b2)) (c1/c2)"
      using a12 b12 c12 by auto
    also have "... = ((a1  b2 + b1  a2)  c2 + c1  (a2  b2)) / (a2  b2  c2)"
      using a_RS b_RS c_RS by (simp add:add_rel_frac)
    also have "... = add_rel (a1/a2) (add_rel (b1/b2) (c1/c2))"
      using a_RS b_RS c_RS comm.distributive comm_ring_simps
      by (auto simp add:add_rel_frac)
    also have "... = add_rel a (add_rel b c)"
      using a12 b12 c12 by auto
    finally show "add_rel (add_rel a b) c = add_rel a (add_rel b c)" .

    show "mult_rel (mult_rel a b) c = mult_rel a (mult_rel b c)"
      unfolding a12 b12 c12 using comm_ring_simps a_RS b_RS c_RS
      by (auto simp add:mult_rel_frac)

    have "mult_rel a (add_rel b c) = (a1  (b1  c2 + c1  b2)) / (a2  (b2  c2))"
      unfolding a12 b12 c12 using a_RS b_RS c_RS
      by (simp add:mult_rel_frac add_rel_frac)
    also have "... = (a2  (a1  (b1  c2 + c1  b2))) / (a2  (a2  (b2  c2)))"
      using a_RS b_RS c_RS by (simp add:frac_cancel)
    also have "... = add_rel (mult_rel a b) (mult_rel a c)"
      unfolding a12 b12 c12 using comm_ring_simps a_RS b_RS c_RS comm.distributive
      by (auto simp add:mult_rel_frac add_rel_frac)
    finally show "mult_rel a (add_rel b c) = add_rel (mult_rel a b) (mult_rel a c)"
      .
  qed
  show add_0:"add_rel zero_rel a = a"
      and mult_1:"mult_rel one_rel a = a"
     if "valid_frac a" for a
  proof -
    obtain a1 a2 where a_RS:"(a1, a2)R × S" and a12:"a = a1 / a2 "
      using valid_frac a unfolding valid_frac_def by auto
    have "add_rel zero_rel a = add_rel zero_rel (a1/a2)"
      using a12 by simp
    also have "... = (a1/a2)"
      using a_RS comm_ring_simps comm.distributive zero_rel_def
      by (auto simp add:add_rel_frac)
    also have "... = a"
      using a12 by auto
    finally show "add_rel zero_rel a = a" .
    show "mult_rel one_rel a = a"
      unfolding a12 one_rel_def using a_RS by (auto simp add:mult_rel_frac)
  qed
  show add_commute:"add_rel a b = add_rel b a"
    and mult_commute:"mult_rel a b = mult_rel b a"
    if "valid_frac a" and "valid_frac b" for a b
  proof -
    obtain a1 a2 where a_RS:"(a1, a2)R × S" and a12:"a = a1 / a2 "
      using valid_frac a unfolding valid_frac_def by auto
    obtain b1 b2 where b_RS:"(b1, b2)R × S" and b12:"b = b1 / b2 "
      using valid_frac b unfolding valid_frac_def by auto

    show "add_rel a b = add_rel b a" "mult_rel a b = mult_rel b a"
      unfolding a12 b12  using comm_ring_simps a_RS b_RS
      by (auto simp add:mult_rel_frac add_rel_frac)
  qed
  show "add_rel a zero_rel = a" if "valid_frac a" for a
    using that add_0 add_commute by auto
  show "mult_rel a one_rel = a" if "valid_frac a" for a
    using that mult_commute mult_1 by auto
  show "monoid.invertible carrier_quotient_ring add_rel zero_rel a"
    if "valid_frac a" for a
  proof -
    have "Group_Theory.monoid carrier_quotient_ring add_rel zero_rel"
      apply (unfold_locales)
      using add_0 add_assoc add_commute by simp_all
    moreover have "add_rel a (uminus_rel a) = zero_rel" "add_rel (uminus_rel a) a = zero_rel"
      using add_minus_zero_rel add_commute that by auto
    ultimately show "monoid.invertible carrier_quotient_ring add_rel zero_rel a"
      unfolding monoid.invertible_def
      apply (rule monoid.invertibleI)
      using add_commute valid_frac a by auto
  qed
  show "mult_rel (add_rel b c) a = add_rel (mult_rel b a) (mult_rel c a)"
    if "valid_frac a" and "valid_frac b" and "valid_frac c" for a b c
    using that mult_commute add_commute distr by (simp add: valid_frac_add)
qed auto

end (* quotient_ring *)

notation quotient_ring.carrier_quotient_ring
           ("(_ ¯ _/ (2_ _ _))" [60,1000,1000,1000,1000]1000)


subsection ‹Local Rings at Prime Ideals›

context pr_ideal
begin

lemma submonoid_pr_ideal:
  shows "submonoid (R  I) R (⋅) 𝟭"
proof
  show "a  b  RI" if "a  RI" "b  RI" for a b
    using that by (metis Diff_iff absorbent comm.multiplicative.composition_closed)
  show "𝟭  RI"
    using ideal.ideal(2) ideal_axioms pr_ideal.carrier_neq pr_ideal_axioms by fastforce
qed auto

interpretation local:quotient_ring "(R  I)" R "(+)" "(⋅)" 𝟬 𝟭
  by intro_locales (meson submonoid_def submonoid_pr_ideal)

(* definition 0.28 *)
definition carrier_local_ring_at:: "('a × 'a) set set"
  where "carrier_local_ring_at  (R  I)¯ R(+) (⋅) 𝟬⇙"

definition add_local_ring_at:: "('a × 'a) set  ('a × 'a) set  ('a × 'a) set"
  where "add_local_ring_at  local.add_rel "

definition mult_local_ring_at:: "('a × 'a) set  ('a × 'a) set  ('a × 'a) set"
  where "mult_local_ring_at  local.mult_rel "

definition uminus_local_ring_at:: "('a × 'a) set  ('a × 'a) set"
  where "uminus_local_ring_at  local.uminus_rel "

definition zero_local_ring_at:: "('a × 'a) set"
  where "zero_local_ring_at  local.zero_rel"

definition one_local_ring_at:: "('a × 'a) set"
  where "one_local_ring_at  local.one_rel"

sublocale comm_ring carrier_local_ring_at add_local_ring_at mult_local_ring_at
            zero_local_ring_at one_local_ring_at
  by (simp add: add_local_ring_at_def carrier_local_ring_at_def local.local.comm_ring_axioms
      mult_local_ring_at_def one_local_ring_at_def zero_local_ring_at_def)


lemma frac_from_carrier_local:
  assumes "X  carrier_local_ring_at"
  obtains r s where "r  R" "s  R" "s  I" "X = local.frac r s"
proof-
  have "X  (R  I)¯ R(+) (⋅) 𝟬⇙" using assms by (simp add: carrier_local_ring_at_def)
  then have "X  quotient_ring.carrier_quotient_ring (R  I) R (+) (⋅) 𝟬" by blast
  then obtain r s where "r  R" "s  (R  I)" "X = local.frac r s"
    using local.frac_from_carrier by (metis local.frac_def)
  thus thesis using that by blast
qed

lemma eq_from_eq_frac:
  assumes "local.frac r s = local.frac r' s'"
    and "s  (R  I)" and "s'  (R  I)" and "r  R" "r'  R"
  obtains h where "h  (R  I)" "h  (s'  r - s  r') = 𝟬"
    using local.frac_eq_Ex[of r s r' s'] assms by blast

end (* pr_ideal *)

abbreviation carrier_of_local_ring_at::
"'a set  'a set  ('a  'a  'a)  ('a  'a  'a)  'a  ('a × 'a) set set" ("_ _ _ _ _" [1000]1000)
where "RI add mult zero pr_ideal.carrier_local_ring_at R I add mult zero"


subsection ‹Spectrum of a Ring›

(* construction 0.29 *)
context comm_ring
begin

interpretation zariski_top_space: topological_space Spec is_zariski_open
  unfolding is_zariski_open_def using generated_topology_is_topology
  by blast

lemma spectrum_imp_cxt_quotient_ring:
  "𝔭  Spec  quotient_ring (R  𝔭) R (+) (⋅) 𝟬 𝟭"
  apply (intro_locales)
  using pr_ideal.submonoid_pr_ideal spectrum_def submonoid_def by fastforce

lemma spectrum_imp_pr:
  "𝔭  Spec  pr_ideal R 𝔭 (+) (⋅) 𝟬 𝟭"
  unfolding spectrum_def by auto

lemma frac_in_carrier_local:
  assumes "𝔭  Spec" and "r  R" and "s  R" and "s  𝔭"
  shows "(quotient_ring.frac (R  𝔭) R (+) (⋅) 𝟬 r s)  R𝔭 (+) (⋅) 𝟬⇙"
proof -
  interpret qr:quotient_ring "R  𝔭" R "(+)" "(⋅)" 𝟬 𝟭
    using spectrum_imp_cxt_quotient_ring[OF 𝔭  Spec] .
  interpret pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
    using spectrum_imp_pr[OF 𝔭  Spec] .
  show ?thesis unfolding pi.carrier_local_ring_at_def
    using assms(2-) by (auto intro:qr.frac_non_empty)
qed

definition is_locally_frac:: "('a set  ('a × 'a) set)  'a set set  bool"
  where "is_locally_frac s V  (r f. r  R  f  R  (𝔮  V. f  𝔮 
            s 𝔮 = quotient_ring.frac (R  𝔮) R (+) (⋅) 𝟬 r f))"

lemma is_locally_frac_subset:
  assumes "is_locally_frac s U" "V  U"
  shows "is_locally_frac s V"
  using assms unfolding is_locally_frac_def
  by (meson subsetD)

lemma is_locally_frac_cong:
  assumes "x. xU  f x=g x"
  shows "is_locally_frac f U = is_locally_frac g U"
  unfolding is_locally_frac_def using assms by simp

definition is_regular:: "('a set  ('a × 'a) set)  'a set set  bool"
  where "is_regular s U 
𝔭. 𝔭  U  (V. is_zariski_open V  V  U  𝔭  V  (is_locally_frac s V))"

lemma map_on_empty_is_regular:
  fixes s:: "'a set  ('a × 'a) set"
  shows "is_regular s {}"
  by (simp add: is_regular_def)

lemma cring0_is_regular [simp]: "cring0.is_regular x = (λU. U={})"
  unfolding cring0.is_regular_def cring0_is_zariski_open
  by blast

definition sheaf_spec:: "'a set set  ('a set  ('a × 'a) set) set" ("𝒪 _" [90]90)
  where "𝒪 U  {s(ΠE 𝔭U. (R𝔭 (+) (⋅) 𝟬)). is_regular s U}"

lemma cring0_sheaf_spec_empty [simp]: "cring0.sheaf_spec {} = {λx. undefined}"
  by (simp add: cring0.sheaf_spec_def)

lemma sec_has_right_codom:
  assumes "s  𝒪 U" and "𝔭  U"
  shows "s 𝔭  (R𝔭 (+) (⋅) 𝟬)"
using assms sheaf_spec_def by auto


lemma is_regular_has_right_codom:
  assumes "U  Spec" "𝔭  U" "is_regular s U"
  shows "s 𝔭  R𝔭 ¯ R(+) (⋅) 𝟬⇙"
proof -
  interpret qr:quotient_ring "(R  𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
    using spectrum_imp_cxt_quotient_ring assms by auto
  show ?thesis using assms
    by (smt frac_in_carrier_local is_locally_frac_def is_regular_def
          pr_ideal.carrier_local_ring_at_def spectrum_imp_pr subset_eq)
qed

lemma sec_is_extensional:
  assumes "s  𝒪 U"
  shows "s  extensional U"
  using assms sheaf_spec_def by (simp add: PiE_iff)

definition 𝒪b::"'a set  ('a × 'a) set"
  where "𝒪b = (λ𝔭. undefined)"

lemma 𝒪_on_emptyset: "𝒪 {} = {𝒪b}"
  unfolding sheaf_spec_def 𝒪b_def
  by (auto simp:Set_Theory.map_def map_on_empty_is_regular)

lemma sheaf_spec_of_empty_is_singleton:
  fixes U:: "'a set set"
  assumes "U = {}" and "s  extensional U" and "t  extensional U"
  shows "s = t"
  using assms by (simp add: Set_Theory.map_def)

definition add_sheaf_spec:: "('a set) set  ('a set  ('a × 'a) set)  ('a set  ('a × 'a) set)  ('a set  ('a × 'a) set)"
  where "add_sheaf_spec U s s'  λ𝔭U. quotient_ring.add_rel (R  𝔭) R (+) (⋅) 𝟬 (s 𝔭) (s' 𝔭)"

lemma is_regular_add_sheaf_spec:
  assumes "is_regular s U" and "is_regular s' U" and "U  Spec"
  shows "is_regular (add_sheaf_spec U s s') U"
proof -
  have "add_sheaf_spec U s s' 𝔭  R𝔭 (+) (⋅) 𝟬⇙" if "𝔭  U" for 𝔭
  proof -
    interpret pi: pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      using U  Spec[unfolded spectrum_def] 𝔭  U by blast
    have "s 𝔭  pi.carrier_local_ring_at"
      "s' 𝔭  pi.carrier_local_ring_at"
      using is_regular s U is_regular s' U
      unfolding is_regular_def is_locally_frac_def using that
      using assms(3) frac_in_carrier_local by fastforce+
    then show ?thesis
      unfolding add_sheaf_spec_def using that
      by (simp flip:pi.add_local_ring_at_def)
  qed
  moreover have "(VU. is_zariski_open V  𝔭  V  is_locally_frac (add_sheaf_spec U s s') V)"
    if "𝔭  U" for 𝔭
  proof -
    obtain V1 r1 f1 where "V1 U" "is_zariski_open V1" "𝔭  V1" "r1  R" "f1  R" and
        q_V1:"(𝔮. 𝔮  V1  f1  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r1 f1)"
      using is_regular s U[unfolded is_regular_def] 𝔭  U
      unfolding is_locally_frac_def by auto
    obtain V2 r2 f2 where "V2 U" "is_zariski_open V2" "𝔭  V2" "r2  R" "f2  R" and
        q_V2:"(𝔮. 𝔮  V2  f2  𝔮  s' 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r2 f2)"
      using is_regular s' U[unfolded is_regular_def]  𝔭  U
      unfolding is_locally_frac_def by auto

    define V3 where "V3 = V1  V2"
    define r3 where "r3 = r1  f2 + r2  f1 "
    define f3 where "f3 = f1  f2"
    have "V3 U" "𝔭  V3" "r3  R" "f3  R"
      unfolding V3_def r3_def f3_def
      using V1  U 𝔭  V1 V2  U 𝔭  V2 f1  R f2  R r1  R r2  R by blast+
    moreover have "is_zariski_open V3" using is_zariski_open V1 is_zariski_open V2 topological_space.open_inter by (simp add: V3_def)
    moreover have "f3  𝔮"
        "add_sheaf_spec U s s' 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r3 f3"
        if "𝔮  V3" for 𝔮
    proof -
      interpret q:quotient_ring "R𝔮" R "(+)" "(⋅)" 𝟬
        using U  Spec V3  U 𝔮  V3 quotient_ring_def local.comm_ring_axioms
          pr_ideal.submonoid_pr_ideal spectrum_def
        by fastforce
      have "f1  𝔮" "s 𝔮 = q.frac r1 f1"
        using q_V1 𝔮  V3  unfolding V3_def by auto
      have "f2  𝔮" "s' 𝔮 = q.frac r2 f2"
        using q_V2 𝔮  V3  unfolding V3_def by auto

      have "q.add_rel (q.frac r1 f1) (q.frac r2 f2) = q.frac (r1  f2 + r2  f1) (f1  f2)"
        apply (rule q.add_rel_frac)
        subgoal by (simp add: f1  R f1  𝔮 r1  R r2  R)
        subgoal using f2  R f2  𝔮 r2  R by blast
        done
      then have "q.add_rel (s 𝔮) (s' 𝔮) = q.frac r3 f3"
        unfolding r3_def f3_def using s 𝔮 = q.frac r1 f1 s' 𝔮 = q.frac r2 f2
        by auto
      then show "add_sheaf_spec U s s' 𝔮 = q.frac r3 f3"
        unfolding add_sheaf_spec_def using V3  U 𝔮  V3 by auto
      show "f3  𝔮" using that unfolding V3_def f3_def
        using f1  R f1  𝔮 f2  R f2  𝔮 q.sub_composition_closed by auto
    qed
    ultimately show ?thesis using is_locally_frac_def by metis
  qed
  ultimately show ?thesis unfolding is_regular_def is_locally_frac_def by meson
qed

lemma add_sheaf_spec_in_sheaf_spec:
  assumes "s  𝒪 U" and "t  𝒪 U" and "U  Spec"
  shows "add_sheaf_spec U s t  𝒪 U"
proof -
  have "add_sheaf_spec U s t 𝔭  R𝔭 (+) (⋅) 𝟬⇙"
      if "𝔭  U" for 𝔭
  proof -
    interpret qr:quotient_ring "(R𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
      apply (rule spectrum_imp_cxt_quotient_ring)
      using that U  Spec by auto
    interpret pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      using that U  Spec by (auto intro:spectrum_imp_pr)
    have "qr.valid_frac (s 𝔭)" "qr.valid_frac (t 𝔭)"
      using sec_has_right_codom[OF _ that] s  𝒪 U t  𝒪 U
      by (auto simp:pi.carrier_local_ring_at_def)
    then show ?thesis
      using that unfolding add_sheaf_spec_def pi.carrier_local_ring_at_def
      by auto
  qed
  moreover have "is_regular (add_sheaf_spec U s t) U"
    using s  𝒪 U t  𝒪 U U  Spec is_regular_add_sheaf_spec
    unfolding sheaf_spec_def by auto
  moreover have "add_sheaf_spec U s t  extensional U"
    unfolding add_sheaf_spec_def by auto
  ultimately show ?thesis
    unfolding sheaf_spec_def by (simp add: PiE_iff)
qed

definition mult_sheaf_spec:: "('a set) set  ('a set  ('a × 'a) set)  ('a set  ('a × 'a) set)  ('a set  ('a × 'a) set)"
  where "mult_sheaf_spec U s s'  λ𝔭U. quotient_ring.mult_rel (R  𝔭) R (+) (⋅) 𝟬 (s 𝔭) (s' 𝔭)"

lemma is_regular_mult_sheaf_spec:
  assumes "is_regular s U" and "is_regular s' U" and "U  Spec"
  shows "is_regular (mult_sheaf_spec U s s') U"
proof -
  have "mult_sheaf_spec U s s' 𝔭  R𝔭 (+) (⋅) 𝟬⇙" if "𝔭  U" for 𝔭
  proof -
    interpret pi: pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      using U  Spec[unfolded spectrum_def] 𝔭  U by blast
    have "s 𝔭  pi.carrier_local_ring_at"
      "s' 𝔭  pi.carrier_local_ring_at"
      using is_regular s U is_regular s' U
      unfolding is_regular_def using that
      using assms(3) frac_in_carrier_local in_mono is_locally_frac_def by fastforce+
    then show ?thesis
      unfolding mult_sheaf_spec_def using that
      by (simp flip:pi.mult_local_ring_at_def)
  qed
  moreover have "(VU. is_zariski_open V  𝔭  V  is_locally_frac (mult_sheaf_spec U s s') V)"
    if "𝔭  U" for 𝔭
  proof -
    obtain V1 r1 f1 where "V1 U" "is_zariski_open V1" "𝔭  V1" "r1  R" "f1  R" and
        q_V1:"(𝔮. 𝔮  V1  f1  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r1 f1)"
      using is_regular s U[unfolded is_regular_def] 𝔭  U unfolding is_locally_frac_def
      by auto
    obtain V2 r2 f2 where "V2 U" "is_zariski_open V2" "𝔭  V2" "r2  R" "f2  R" and
        q_V2:"(𝔮. 𝔮  V2  f2  𝔮  s' 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r2 f2)"
      using is_regular s' U[unfolded is_regular_def] 𝔭  U unfolding is_locally_frac_def
      by auto

    define V3 where "V3 = V1  V2"
    define r3 where "r3 = r1  r2  "
    define f3 where "f3 = f1  f2"
    have "V3 U" "𝔭  V3" "r3  R" "f3  R"
      unfolding V3_def r3_def f3_def
      using V1  U 𝔭  V1 𝔭  V2 f1  R f2  R r1  R r2  R by blast+
    moreover have "is_zariski_open V3"
      using topological_space.open_inter by (simp add: V3_def is_zariski_open V1 is_zariski_open V2)
    moreover have "f3  𝔮"
        "mult_sheaf_spec U s s' 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r3 f3"
        if "𝔮  V3" for 𝔮
    proof -
      interpret q:quotient_ring "R𝔮" R "(+)" "(⋅)" 𝟬
        using U  Spec V3  U 𝔮  V3 quotient_ring_def local.comm_ring_axioms
          pr_ideal.submonoid_pr_ideal spectrum_def
        by fastforce
      have "f1  𝔮" "s 𝔮 = q.frac r1 f1"
        using q_V1 𝔮  V3  unfolding V3_def by auto
      have "f2  𝔮" "s' 𝔮 = q.frac r2 f2"
        using q_V2 𝔮  V3  unfolding V3_def by auto

      have "q.mult_rel (q.frac r1 f1) (q.frac r2 f2) = q.frac (r1  r2 ) (f1  f2)"
        apply (rule q.mult_rel_frac)
        subgoal by (simp add: f1  R f1  𝔮 r1  R r2  R)
        subgoal using f2  R f2  𝔮 r2  R by blast
        done
      then have "q.mult_rel (s 𝔮) (s' 𝔮) = q.frac r3 f3"
        unfolding r3_def f3_def using s 𝔮 = q.frac r1 f1 s' 𝔮 = q.frac r2 f2
        by auto
      then show "mult_sheaf_spec U s s' 𝔮 = q.frac r3 f3"
        unfolding mult_sheaf_spec_def using V3  U 𝔮  V3 by auto
      show "f3  𝔮" using that unfolding V3_def f3_def
        using f1  R f1  𝔮 f2  R f2  𝔮 q.sub_composition_closed by auto
    qed
    ultimately show ?thesis using is_locally_frac_def by metis
  qed
  ultimately show ?thesis unfolding is_regular_def is_locally_frac_def by meson
qed

lemma mult_sheaf_spec_in_sheaf_spec:
  assumes "s  𝒪 U" and "t  𝒪 U" and "U  Spec"
  shows "mult_sheaf_spec U s t  𝒪 U"
proof -
  have "mult_sheaf_spec U s t 𝔭  R𝔭 (+) (⋅) 𝟬⇙"
      if "𝔭  U" for 𝔭
  proof -
    interpret qr:quotient_ring "(R𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
      apply (rule spectrum_imp_cxt_quotient_ring)
      using that U  Spec by auto
    interpret pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      using that U  Spec by (auto intro:spectrum_imp_pr)
    have "qr.valid_frac (s 𝔭)" "qr.valid_frac (t 𝔭)"
      using sec_has_right_codom[OF _ that] s  𝒪 U t  𝒪 U
      by (auto simp:pi.carrier_local_ring_at_def)
    then show ?thesis
      using that unfolding mult_sheaf_spec_def pi.carrier_local_ring_at_def
      by auto
  qed
  moreover have "is_regular (mult_sheaf_spec U s t) U"
    using s  𝒪 U t  𝒪 U U  Spec is_regular_mult_sheaf_spec
    unfolding sheaf_spec_def by auto
  moreover have "mult_sheaf_spec U s t  extensional U"
    unfolding mult_sheaf_spec_def by auto
  ultimately show ?thesis
    unfolding sheaf_spec_def by (simp add: PiE_iff)
qed

definition uminus_sheaf_spec::"('a set) set  ('a set  ('a × 'a) set)  ('a set  ('a × 'a) set)"
  where "uminus_sheaf_spec U s  λ𝔭U. quotient_ring.uminus_rel (R  𝔭) R (+) (⋅) 𝟬 (s 𝔭) "

lemma is_regular_uminus_sheaf_spec:
  assumes "is_regular s U" and "U  Spec"
  shows "is_regular (uminus_sheaf_spec U s) U"
proof -
  have "uminus_sheaf_spec U s 𝔭  R𝔭 (+) (⋅) 𝟬⇙" if "𝔭  U" for 𝔭
  proof -
    interpret pi: pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      using U  Spec[unfolded spectrum_def] 𝔭  U by blast
    interpret qr:quotient_ring "(R𝔭)"
      by (simp add: quotient_ring_def local.comm_ring_axioms pi.submonoid_pr_ideal)

    have "s 𝔭  pi.carrier_local_ring_at"
      using is_regular s U
      unfolding is_regular_def using that
      using assms(2) frac_in_carrier_local in_mono is_locally_frac_def by fastforce
    then show ?thesis
      unfolding uminus_sheaf_spec_def pi.carrier_local_ring_at_def using that
      by simp
  qed
  moreover have "(VU. is_zariski_open V  𝔭  V  is_locally_frac (uminus_sheaf_spec U s) V)"
    if "𝔭  U" for 𝔭
  proof -
    obtain V1 r1 f1 where "V1 U" "is_zariski_open V1" "𝔭  V1" "r1  R" "f1  R" and
        q_V1:"(𝔮. 𝔮  V1  f1  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r1 f1)"
      using is_regular s U[unfolded is_regular_def] 𝔭  U unfolding is_locally_frac_def
      by auto

    define V3 where "V3 = V1 "
    define r3 where "r3 = additive.inverse r1"
    define f3 where "f3 = f1"
    have "V3 U" "𝔭  V3" "r3  R" "f3  R"
      unfolding V3_def r3_def f3_def
      using V1  U 𝔭  V1 f1  R  r1  R by blast+
    moreover have "is_zariski_open V3"
      using topological_space.open_inter by (simp add: V3_def is_zariski_open V1)
    moreover have "f3  𝔮"
        "uminus_sheaf_spec U s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r3 f3"
        if "𝔮  V3" for 𝔮
    proof -
      interpret q:quotient_ring "R𝔮" R "(+)" "(⋅)" 𝟬
        using U  Spec V3  U 𝔮  V3 quotient_ring_def local.comm_ring_axioms
          pr_ideal.submonoid_pr_ideal spectrum_def
        by fastforce
      have "f1  𝔮" "s 𝔮 = q.frac r1 f1"
        using q_V1 𝔮  V3  unfolding V3_def by auto

      have "q.uminus_rel (q.frac r1 f1) = q.frac (additive.inverse r1) f1"
        apply (rule q.uminus_rel_frac)
        by (simp add: f1  R f1  𝔮 r1  R)
      then have "q.uminus_rel (s 𝔮) = q.frac r3 f3"
        unfolding r3_def f3_def using s 𝔮 = q.frac r1 f1 by auto
      then show "uminus_sheaf_spec U s 𝔮 = q.frac r3 f3"
        unfolding uminus_sheaf_spec_def using V3  U 𝔮  V3 by auto
      show "f3  𝔮" using that unfolding V3_def f3_def
        using f1  R f1  𝔮 q.sub_composition_closed by auto
    qed
    ultimately show ?thesis using is_locally_frac_def by metis
  qed
  ultimately show ?thesis unfolding is_regular_def is_locally_frac_def by meson
qed

lemma uminus_sheaf_spec_in_sheaf_spec:
  assumes "s  𝒪 U" and "U  Spec"
  shows "uminus_sheaf_spec U s  𝒪 U"
proof -
  have "uminus_sheaf_spec U s 𝔭  R𝔭 (+) (⋅) 𝟬⇙"
      if "𝔭  U" for 𝔭
  proof -
    interpret qr:quotient_ring "(R𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
      apply (rule spectrum_imp_cxt_quotient_ring)
      using that U  Spec by auto
    interpret pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      using that U  Spec by (auto intro:spectrum_imp_pr)
    have "qr.valid_frac (s 𝔭)"
      using sec_has_right_codom[OF _ that] s  𝒪 U
      by (auto simp:pi.carrier_local_ring_at_def)
    then show ?thesis
      using that unfolding uminus_sheaf_spec_def pi.carrier_local_ring_at_def
      by auto
  qed
  moreover have "is_regular (uminus_sheaf_spec U s) U"
    using s  𝒪 U  U  Spec is_regular_uminus_sheaf_spec
    unfolding sheaf_spec_def by auto
  moreover have "uminus_sheaf_spec U s  extensional U"
    unfolding uminus_sheaf_spec_def by auto
  ultimately show ?thesis
    unfolding sheaf_spec_def by (simp add: PiE_iff)
qed

definition zero_sheaf_spec:: "'a set set  ('a set  ('a × 'a) set)"
  where "zero_sheaf_spec U  λ𝔭U. quotient_ring.zero_rel (R  𝔭) R (+) (⋅) 𝟬 𝟭"

lemma is_regular_zero_sheaf_spec:
  assumes "is_zariski_open U"
  shows "is_regular (zero_sheaf_spec U) U"
proof -
  have "zero_sheaf_spec U 𝔭  R𝔭 (+) (⋅) 𝟬⇙" if "𝔭  U" for 𝔭
    unfolding zero_sheaf_spec_def
    using assms comm_ring.frac_in_carrier_local local.comm_ring_axioms pr_ideal.not_1 
          quotient_ring.zero_rel_def spectrum_imp_cxt_quotient_ring spectrum_imp_pr subsetD that 
          zariski_top_space.open_imp_subset by fastforce
  moreover have "(VU. is_zariski_open V  𝔭  V  is_locally_frac (zero_sheaf_spec U) V)"
    if "𝔭  U" for 𝔭
  proof -
    define V3 where "V3 = U"
    define r3 where "r3 = 𝟬 "
    define f3 where "f3 = 𝟭"
    have "V3 U" "𝔭  V3" "r3  R" "f3  R"
      unfolding V3_def r3_def f3_def using that by auto
    moreover have "is_zariski_open V3" using assms by (simp add: V3_def)
    moreover have "f3  𝔮"
        "zero_sheaf_spec U 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r3 f3"
        if "𝔮  V3" for 𝔮
      subgoal using V3_def assms f3_def pr_ideal.submonoid_pr_ideal spectrum_def
          submonoid.sub_unit_closed that zariski_open_is_subset by fastforce
      subgoal
      proof -
        interpret q:quotient_ring "R𝔮" R
          using V3_def assms quotient_ring_def local.comm_ring_axioms
            pr_ideal.submonoid_pr_ideal spectrum_def that zariski_open_is_subset by fastforce
        show ?thesis unfolding zero_sheaf_spec_def
          using V3_def f3_def q.zero_rel_def r3_def that by auto
      qed
      done
    ultimately show ?thesis using is_locally_frac_def  by metis
  qed
  ultimately show ?thesis unfolding is_regular_def is_locally_frac_def  by meson
qed

lemma zero_sheaf_spec_in_sheaf_spec:
  assumes "is_zariski_open U"
  shows "zero_sheaf_spec U  𝒪 U"
proof -
  have "zero_sheaf_spec U 𝔭  R𝔭 (+) (⋅) 𝟬⇙"if "𝔭  U" for 𝔭
  proof -
    interpret qr:quotient_ring "(R𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
      by (meson assms comm_ring.zariski_open_is_subset local.comm_ring_axioms
          spectrum_imp_cxt_quotient_ring subsetD that)
    interpret pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      by (meson assms spectrum_imp_pr subsetD that zariski_open_is_subset)
    show ?thesis unfolding zero_sheaf_spec_def pi.carrier_local_ring_at_def
      using that by auto
  qed
  moreover have "is_regular (zero_sheaf_spec U) U"
    using is_regular_zero_sheaf_spec assms by auto
  moreover have "zero_sheaf_spec U  extensional U"
    by (simp add: zero_sheaf_spec_def)
  ultimately show ?thesis unfolding sheaf_spec_def by (simp add: PiE_iff)
qed

definition one_sheaf_spec:: "'a set set  ('a set  ('a × 'a) set)"
  where "one_sheaf_spec U  λ𝔭U. quotient_ring.one_rel (R  𝔭) R (+) (⋅) 𝟬 𝟭"

lemma is_regular_one_sheaf_spec:
  assumes "is_zariski_open U"
  shows "is_regular (one_sheaf_spec U) U"
proof -
  have "one_sheaf_spec U 𝔭  R𝔭 (+) (⋅) 𝟬⇙" if "𝔭  U" for 𝔭
    unfolding one_sheaf_spec_def
    by (smt assms closed_subsets_zero comm_ring.closed_subsets_def
        quotient_ring.carrier_quotient_ring_iff quotient_ring.valid_frac_one
        quotient_ring_def local.comm_ring_axioms mem_Collect_eq
        pr_ideal.carrier_local_ring_at_def pr_ideal.submonoid_pr_ideal
        restrict_apply subsetD that zariski_open_is_subset)
  moreover have "(VU. is_zariski_open V  𝔭  V  is_locally_frac (one_sheaf_spec U) V)"
    if "𝔭  U" for 𝔭
  proof -
    define V3 where "V3 = U"
    define r3 where "r3 = 𝟭"
    define f3 where "f3 = 𝟭"
    have "V3 U" "𝔭  V3" "r3  R" "f3  R"
      unfolding V3_def r3_def f3_def using that by auto
    moreover have "is_zariski_open V3" using assms by (simp add: V3_def)
    moreover have "f3  𝔮"
        "one_sheaf_spec U 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 r3 f3"
        if "𝔮  V3" for 𝔮
      subgoal using V3_def assms f3_def pr_ideal.submonoid_pr_ideal spectrum_def
          submonoid.sub_unit_closed that zariski_open_is_subset by fastforce
      subgoal
      proof -
        interpret q:quotient_ring "R𝔮" R
          using V3_def assms quotient_ring_def local.comm_ring_axioms
            pr_ideal.submonoid_pr_ideal spectrum_def that zariski_open_is_subset by fastforce
        show ?thesis unfolding one_sheaf_spec_def
          using V3_def f3_def q.one_rel_def r3_def that by auto
      qed
      done
    ultimately show ?thesis using is_locally_frac_def by metis
  qed
  ultimately show ?thesis unfolding is_regular_def is_locally_frac_def by meson
qed

lemma one_sheaf_spec_in_sheaf_spec:
  assumes "is_zariski_open U"
  shows "one_sheaf_spec U  𝒪 U"
proof -
  have "one_sheaf_spec U 𝔭  R𝔭 (+) (⋅) 𝟬⇙"if "𝔭  U" for 𝔭
  proof -
    interpret qr:quotient_ring "(R𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
      by (meson assms comm_ring.zariski_open_is_subset local.comm_ring_axioms
          spectrum_imp_cxt_quotient_ring subsetD that)
    interpret pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      by (meson assms spectrum_imp_pr subsetD that zariski_open_is_subset)
    show ?thesis unfolding one_sheaf_spec_def pi.carrier_local_ring_at_def
      using that by auto
  qed
  moreover have "is_regular (one_sheaf_spec U) U"
    using is_regular_one_sheaf_spec assms by auto
  moreover have "one_sheaf_spec U  extensional U"
    by (simp add: one_sheaf_spec_def)
  ultimately show ?thesis unfolding sheaf_spec_def by (simp add: PiE_iff)
qed

lemma zero_sheaf_spec_extensional[simp]:
  "zero_sheaf_spec U  extensional U"
  unfolding zero_sheaf_spec_def by simp

lemma one_sheaf_spec_extensional[simp]:
  "one_sheaf_spec U  extensional U"
  unfolding one_sheaf_spec_def by simp

lemma add_sheaf_spec_extensional[simp]:
  "add_sheaf_spec U a b  extensional U"
  unfolding add_sheaf_spec_def by simp

lemma mult_sheaf_spec_extensional[simp]:
  "mult_sheaf_spec U a b  extensional U"
  unfolding mult_sheaf_spec_def by simp

lemma sheaf_spec_extensional[simp]:
  "a  𝒪 U  a  extensional U"
  unfolding sheaf_spec_def by (simp add: PiE_iff Set_Theory.map_def)

lemma sheaf_spec_on_open_is_comm_ring:
  assumes "is_zariski_open U"
  shows "comm_ring (𝒪 U) (add_sheaf_spec U) (mult_sheaf_spec U) (zero_sheaf_spec U) (one_sheaf_spec U)"
proof unfold_locales
  show add_𝒪:"add_sheaf_spec U a b  𝒪 U"
    and "mult_sheaf_spec U a b  𝒪 U"
    if "a  𝒪 U" "b  𝒪 U" for a b
    subgoal by (simp add: add_sheaf_spec_in_sheaf_spec assms that(1,2) zariski_open_is_subset)
    subgoal by (simp add: assms mult_sheaf_spec_in_sheaf_spec that(1,2) zariski_open_is_subset)
    done
  show "zero_sheaf_spec U  𝒪 U" "one_sheaf_spec U  𝒪 U"
    subgoal by (simp add: assms zero_sheaf_spec_in_sheaf_spec)
    subgoal by (simp add: assms one_sheaf_spec_in_sheaf_spec)
    done

  have imp_qr:"quotient_ring (R𝔭) R (+) (⋅) 𝟬 𝟭" if "𝔭  U" for 𝔭
    using that
    by (meson assms comm_ring.spectrum_imp_cxt_quotient_ring in_mono local.comm_ring_axioms
          zariski_open_is_subset)
  have qr_valid_frac:"quotient_ring.valid_frac (R𝔭) R (+) (⋅) 𝟬 (s 𝔭)"
      if "s  𝒪 U" "𝔭  U" for s 𝔭
    using assms comm_ring.zariski_open_is_subset quotient_ring.carrier_quotient_ring_iff
      imp_qr local.comm_ring_axioms pr_ideal.carrier_local_ring_at_def sec_has_right_codom
      spectrum_imp_pr that(1) that(2) by fastforce

  show add_zero:"add_sheaf_spec U (zero_sheaf_spec U) a = a" if "a  𝒪 U" for a
  proof -
    have "add_sheaf_spec U (zero_sheaf_spec U) a 𝔭 = a 𝔭" if "𝔭  U" for 𝔭
    proof -
      interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭
        using imp_qr that by auto
      show ?thesis unfolding add_sheaf_spec_def zero_sheaf_spec_def
        using that by (simp add: a  𝒪 U qr_valid_frac)
    qed
    then show "add_sheaf_spec U (zero_sheaf_spec U) a = a"
      using that by(auto intro: extensionalityI[where A=U])
  qed
  show add_assoc:"add_sheaf_spec U (add_sheaf_spec U a b) c
      = add_sheaf_spec U a (add_sheaf_spec U b c)"
    if "a  𝒪 U" and "b  𝒪 U" and "c  𝒪 U"
    for a b c
  proof (rule extensionalityI)
    fix 𝔭 assume "𝔭  U"
    interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto
    show "add_sheaf_spec U (add_sheaf_spec U a b) c 𝔭 = add_sheaf_spec U a (add_sheaf_spec U b c) 𝔭"
      unfolding add_sheaf_spec_def using 𝔭  U
      by (simp add: cq.additive.associative qr_valid_frac that(1) that(2) that(3))
  qed (auto simp add:add_sheaf_spec_def)
  show add_comm:"add_sheaf_spec U x y = add_sheaf_spec U y x"
    if "x  𝒪 U" and "y  𝒪 U" for x y
  proof (rule extensionalityI)
    fix 𝔭 assume "𝔭  U"
    interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto
    show " add_sheaf_spec U x y 𝔭 = add_sheaf_spec U y x 𝔭"
      unfolding add_sheaf_spec_def using 𝔭  U
      by (simp add: cq.additive.commutative qr_valid_frac that(1) that(2))
  qed auto
  show mult_comm:"mult_sheaf_spec U x y = mult_sheaf_spec U y x"
    if "x  𝒪 U" and "y  𝒪 U" for x y
  proof (rule extensionalityI)
    fix 𝔭 assume "𝔭  U"
    interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto
    show "mult_sheaf_spec U x y 𝔭 = mult_sheaf_spec U y x 𝔭"
      unfolding mult_sheaf_spec_def using 𝔭  U
      by (simp add: cq.comm_mult qr_valid_frac that(1) that(2))
  qed auto
  show add_zero:"add_sheaf_spec U a (zero_sheaf_spec U) = a"
      if "a  𝒪 U" for a
    using add_zero add_comm that by (simp add: zero_sheaf_spec U  𝒪 U)

  show "mult_sheaf_spec U (mult_sheaf_spec U a b) c = mult_sheaf_spec U a (mult_sheaf_spec U b c)"
    if "a  𝒪 U" and "b  𝒪 U"
      and "c  𝒪 U"
    for a b c
  proof (rule extensionalityI)
    fix 𝔭 assume "𝔭  U"
    interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto
    show "mult_sheaf_spec U (mult_sheaf_spec U a b) c 𝔭
                = mult_sheaf_spec U a (mult_sheaf_spec U b c) 𝔭"
      unfolding mult_sheaf_spec_def using 𝔭  U
      by (simp add: cq.multiplicative.associative qr_valid_frac that(1) that(2) that(3))
  qed (auto simp add:add_sheaf_spec_def)

  show "mult_sheaf_spec U (one_sheaf_spec U) a = a"
    if "a  𝒪 U" for a
  proof (rule extensionalityI)
    fix 𝔭 assume "𝔭  U"
    interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto
    show "mult_sheaf_spec U (one_sheaf_spec U) a 𝔭 = a 𝔭"
      unfolding mult_sheaf_spec_def using 𝔭  U
      by (simp add: one_sheaf_spec_def qr_valid_frac that)
  qed (auto simp add: a  𝒪 U)
  then show "mult_sheaf_spec U a (one_sheaf_spec U) = a"
    if "a  𝒪 U" for a
    by (simp add: one_sheaf_spec U  𝒪 U mult_comm that)

  show "mult_sheaf_spec U a (add_sheaf_spec U b c)
          = add_sheaf_spec U (mult_sheaf_spec U a b) (mult_sheaf_spec U a c)"
    if "a  𝒪 U" and "b  𝒪 U" and "c  𝒪 U" for a b c
  proof (rule extensionalityI)
    fix 𝔭 assume "𝔭  U"
    interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto
    show "mult_sheaf_spec U a (add_sheaf_spec U b c) 𝔭 =
         add_sheaf_spec U (mult_sheaf_spec U a b) (mult_sheaf_spec U a c) 𝔭"
      unfolding mult_sheaf_spec_def add_sheaf_spec_def
      by (simp add: cq.distributive(1) qr_valid_frac that(1) that(2) that(3))
  qed auto
  then show "mult_sheaf_spec U (add_sheaf_spec U b c) a
                = add_sheaf_spec U (mult_sheaf_spec U b a) (mult_sheaf_spec U c a)"
    if "a  𝒪 U" and "b  𝒪 U" and "c  𝒪 U" for a b c
    by (simp add: add_𝒪 mult_comm that(1) that(2) that(3))
  show "monoid.invertible (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U) u"
    if "u  𝒪 U" for u
  proof (rule monoid.invertibleI)
    show "Group_Theory.monoid (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U)"
      apply unfold_locales
      using add_𝒪 zero_sheaf_spec U  𝒪 U add_assoc zero_sheaf_spec U  𝒪 U
        add_comm add_zero  add_zero
      by simp_all
    show "add_sheaf_spec U u (uminus_sheaf_spec U u) = zero_sheaf_spec U"
    proof (rule extensionalityI)
      fix 𝔭 assume "𝔭  U"
      interpret cq:quotient_ring "R𝔭" R "(+)" "(⋅)" 𝟬 𝟭 using 𝔭  U imp_qr by auto

      have "cq.add_rel (u 𝔭) (cq.uminus_rel (u 𝔭)) = cq.zero_rel"
        by (simp add: 𝔭  U cq.add_minus_zero_rel qr_valid_frac that)
      then show "add_sheaf_spec U u (uminus_sheaf_spec U u) 𝔭 = zero_sheaf_spec U 𝔭"
        unfolding add_sheaf_spec_def uminus_sheaf_spec_def zero_sheaf_spec_def
        using 𝔭  U by simp
    qed auto
    then show "add_sheaf_spec U (uminus_sheaf_spec U u) u = zero_sheaf_spec U"
      by (simp add: add_comm assms comm_ring.zariski_open_is_subset local.comm_ring_axioms
          that uminus_sheaf_spec_in_sheaf_spec)
    show "u  𝒪 U" using that .
    show "uminus_sheaf_spec U u  𝒪 U"
      by (simp add: assms comm_ring.zariski_open_is_subset local.comm_ring_axioms
            that uminus_sheaf_spec_in_sheaf_spec)
  qed
qed

definition sheaf_spec_morphisms::
"'a set set  'a set set  (('a set  ('a × 'a) set)  ('a set  ('a × 'a) set))"
where "sheaf_spec_morphisms U V  λs(𝒪 U). restrict s V"

lemma sheaf_morphisms_sheaf_spec:
  assumes "s  𝒪 U"
  shows "sheaf_spec_morphisms U U s = s"
  using assms sheaf_spec_def restrict_on_source sheaf_spec_morphisms_def
  by auto

lemma sheaf_spec_morphisms_are_maps:
  assumes (*this assumption seems redundant: "is_zariski_open U" and*)
    "is_zariski_open V" and "V  U"
  shows "Set_Theory.map (sheaf_spec_morphisms U V) (𝒪 U) (𝒪 V)"
proof -
  have "sheaf_spec_morphisms U V  extensional (𝒪 U)"
    unfolding sheaf_spec_morphisms_def by auto
  moreover have "sheaf_spec_morphisms U V  (𝒪 U)  (𝒪 V)"
    unfolding sheaf_spec_morphisms_def
  proof
    fix s assume "s  𝒪 U"
    then have "s  (ΠE 𝔭U. R𝔭 (+) (⋅) 𝟬)"
        and p:"𝔭. 𝔭  U  (V. is_zariski_open V  V  U  𝔭  V  is_locally_frac s V)"
      unfolding sheaf_spec_def is_regular_def by auto
    have "restrict s V  (ΠE 𝔭V. R𝔭 (+) (⋅) 𝟬)"
      using s  (ΠE 𝔭U. R𝔭 (+) (⋅) 𝟬) using V  U by auto
    moreover have "(Va. is_zariski_open Va  Va  V  𝔭  Va  is_locally_frac (restrict s V) Va)"
      if "𝔭  V" for 𝔭
    proof -
      obtain U1 where "is_zariski_open U1" "U1  U" "𝔭  U1" "is_locally_frac s U1"
        using p[rule_format, of 𝔭] that V  U 𝔭  V by auto
      define V1 where "V1 = U1  V"
      have "is_zariski_open V1"
        using is_zariski_open V is_zariski_open U1 by (simp add: V1_def)
      moreover have "is_locally_frac s V1"
        using is_locally_frac_subset[OF is_locally_frac s U1] unfolding V1_def by simp
      then have "is_locally_frac (restrict s V) V1"
        unfolding restrict_def V1_def using is_locally_frac_cong by (smt in_mono inf_le2)
      moreover have "V1  V" "𝔭  V1"
        unfolding V1_def using V  U 𝔭  U1 that by auto
      ultimately show ?thesis by auto
    qed
    ultimately show "restrict s V  𝒪 V"
      unfolding sheaf_spec_def is_regular_def by auto
  qed
  ultimately show ?thesis
    by (simp add: extensional_funcset_def map.intro)
qed

lemma sheaf_spec_morphisms_are_ring_morphisms:
  assumes U: "is_zariski_open U" and V: "is_zariski_open V" and "V  U"
  shows "ring_homomorphism (sheaf_spec_morphisms U V)
                           (𝒪 U) (add_sheaf_spec U) (mult_sheaf_spec U) (zero_sheaf_spec U) (one_sheaf_spec U)
                           (𝒪 V) (add_sheaf_spec V) (mult_sheaf_spec V) (zero_sheaf_spec V) (one_sheaf_spec V)"
proof intro_locales
  show "Set_Theory.map (sheaf_spec_morphisms U V) (𝒪 U) (𝒪 V)"
    by (simp add: assms sheaf_spec_morphisms_are_maps)
  show "Group_Theory.monoid (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U)"
    using sheaf_spec_on_open_is_comm_ring [OF U]
    by (auto simp: comm_ring_def ring_def abelian_group_def commutative_monoid_def)
  show "Group_Theory.group_axioms (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U)"
    using sheaf_spec_on_open_is_comm_ring [OF U]
    by (auto simp: comm_ring_def ring_def abelian_group_def commutative_monoid_def group_def)
  show "commutative_monoid_axioms (𝒪 U) (add_sheaf_spec U)"
    using sheaf_spec_on_open_is_comm_ring [OF U]
    by (auto simp: comm_ring_def ring_def abelian_group_def commutative_monoid_def group_def)
  show "Group_Theory.monoid (𝒪 U) (mult_sheaf_spec U) (one_sheaf_spec U)"
    by (meson U comm_ring_def ring_def sheaf_spec_on_open_is_comm_ring)
  show "ring_axioms (𝒪 U) (add_sheaf_spec U) (mult_sheaf_spec U)"
    by (meson U comm_ring.axioms(1) ring_def sheaf_spec_on_open_is_comm_ring)
  show "Group_Theory.monoid (𝒪 V) (add_sheaf_spec V) (zero_sheaf_spec V)"
    using sheaf_spec_on_open_is_comm_ring [OF V]
    by (auto simp: comm_ring_def ring_def abelian_group_def commutative_monoid_def)
  show "Group_Theory.group_axioms (𝒪 V) (add_sheaf_spec V) (zero_sheaf_spec V)"
    using sheaf_spec_on_open_is_comm_ring [OF V]
    by (auto simp: comm_ring_def ring_def abelian_group_def commutative_monoid_def group_def)
  show "commutative_monoid_axioms (𝒪 V) (add_sheaf_spec V)"
    using sheaf_spec_on_open_is_comm_ring [OF V]
    by (auto simp: comm_ring_def ring_def abelian_group_def commutative_monoid_def group_def)
  show "Group_Theory.monoid (𝒪 V) (mult_sheaf_spec V) (one_sheaf_spec V)"
    by (meson V comm_ring.axioms(1) ring_def sheaf_spec_on_open_is_comm_ring)
  show "ring_axioms (𝒪 V) (add_sheaf_spec V) (mult_sheaf_spec V)"
    by (meson V comm_ring_def ring_def sheaf_spec_on_open_is_comm_ring)
  show "monoid_homomorphism_axioms (sheaf_spec_morphisms U V) (𝒪 U)
              (add_sheaf_spec U) (zero_sheaf_spec U) (add_sheaf_spec V) (zero_sheaf_spec V)"
  proof
    fix x y
    assume xy: "x  𝒪 U" "y  𝒪 U"
    have "sheaf_spec_morphisms U V (add_sheaf_spec U x y) = restrict (add_sheaf_spec U x y) V"
      by (simp add: U add_sheaf_spec_in_sheaf_spec comm_ring.zariski_open_is_subset local.comm_ring_axioms sheaf_spec_morphisms_def xy)
    also have "... = add_sheaf_spec V (restrict x V) (restrict y V)"
      using add_sheaf_spec_def V  U by force
    also have "... = add_sheaf_spec V (sheaf_spec_morphisms U V x) (sheaf_spec_morphisms U V y)"
      by (simp add: sheaf_spec_morphisms_def xy)
    finally show "sheaf_spec_morphisms U V (add_sheaf_spec U x y) = add_sheaf_spec V (sheaf_spec_morphisms U V x) (sheaf_spec_morphisms U V y)" .
  next
    have "sheaf_spec_morphisms U V (zero_sheaf_spec U) = restrict (zero_sheaf_spec U) V"
      by (simp add: U comm_ring.sheaf_spec_morphisms_def local.comm_ring_axioms zero_sheaf_spec_in_sheaf_spec)
    also have "... = zero_sheaf_spec V"
      by (metis FuncSet.restrict_restrict assms(3) inf.absorb_iff2 zero_sheaf_spec_def)
    finally show "sheaf_spec_morphisms U V (zero_sheaf_spec U) = zero_sheaf_spec V" .
  qed
  show "monoid_homomorphism_axioms (sheaf_spec_morphisms U V) (𝒪 U)
              (mult_sheaf_spec U) (one_sheaf_spec U) (mult_sheaf_spec V) (one_sheaf_spec V)"
  proof
    fix x y
    assume xy: "x  𝒪 U" "y  𝒪 U"
        have "sheaf_spec_morphisms U V (mult_sheaf_spec U x y) = restrict (mult_sheaf_spec U x y) V"
      by (simp add: U mult_sheaf_spec_in_sheaf_spec comm_ring.zariski_open_is_subset local.comm_ring_axioms sheaf_spec_morphisms_def xy)
    also have "... = mult_sheaf_spec V (restrict x V) (restrict y V)"
      using mult_sheaf_spec_def V  U by force
    also have "... = mult_sheaf_spec V (sheaf_spec_morphisms U V x) (sheaf_spec_morphisms U V y)"
      by (simp add: sheaf_spec_morphisms_def xy)
    finally show "sheaf_spec_morphisms U V (mult_sheaf_spec U x y) = mult_sheaf_spec V (sheaf_spec_morphisms U V x) (sheaf_spec_morphisms U V y)" .
  next
    have "sheaf_spec_morphisms U V (one_sheaf_spec U) = restrict (one_sheaf_spec U) V"
      by (simp add: U comm_ring.sheaf_spec_morphisms_def local.comm_ring_axioms one_sheaf_spec_in_sheaf_spec)
    also have "... = one_sheaf_spec V"
      by (metis FuncSet.restrict_restrict assms(3) inf.absorb_iff2 one_sheaf_spec_def)
    finally show "sheaf_spec_morphisms U V (one_sheaf_spec U) = one_sheaf_spec V" .
  qed
qed

lemma sheaf_spec_is_presheaf:
  shows "presheaf_of_rings Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b
add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
proof intro_locales
  have "sheaf_spec {} = {𝒪b}"
  proof
    show "{𝒪b}  𝒪 {}"
      using undefined_is_map_on_empty map_on_empty_is_regular sheaf_spec_def 𝒪_on_emptyset by auto
    thus "𝒪 {}  {𝒪b}"
      using sheaf_spec_def sheaf_spec_of_empty_is_singleton by auto
  qed
  moreover have "U. is_zariski_open U  (s. s  (𝒪 U)  sheaf_spec_morphisms U U s = s)"
    using sheaf_spec_morphisms_def sheaf_morphisms_sheaf_spec by simp
  moreover have "sheaf_spec_morphisms U W s = (sheaf_spec_morphisms V W  sheaf_spec_morphisms U V) s"
    if "is_zariski_open U" "is_zariski_open V" "is_zariski_open W" "V  U" "W  V" and "s  𝒪 U"
    for U V W s
  proof -
    have "restrict s V  𝒪 V"
      using that by (smt map.map_closed restrict_apply sheaf_spec_morphisms_are_maps sheaf_spec_morphisms_def)
    with that show ?thesis
      by (simp add: sheaf_spec_morphisms_def inf_absorb2)
  qed
  ultimately show "presheaf_of_rings_axioms is_zariski_open sheaf_spec
                    sheaf_spec_morphisms 𝒪b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
    unfolding presheaf_of_rings_def presheaf_of_rings_axioms_def using sheaf_spec_morphisms_are_ring_morphisms
    by blast
qed

(* ex. 0.30 *)
lemma sheaf_spec_is_sheaf:
  shows "sheaf_of_rings Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b
add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
proof (intro sheaf_of_rings.intro sheaf_of_rings_axioms.intro)
  show "presheaf_of_rings Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b
     add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
    using sheaf_spec_is_presheaf by simp
next
  fix U I V s assume H: "open_cover_of_open_subset Spec is_zariski_open U I V"
                        "i. i  I  V i  U"
                        "s  𝒪 U"
                        "i. i  I  sheaf_spec_morphisms U (V i) s = zero_sheaf_spec (V i)"
  then have "s 𝔭 = zero_sheaf_spec U 𝔭" if "𝔭  U" for 𝔭
  proof -
    from that obtain i where F: "i  I" "𝔭  (V i)" "is_zariski_open (V i)"
      using H(1) unfolding open_cover_of_subset_def open_cover_of_open_subset_def
      by (metis cover_of_subset.cover_of_select_index cover_of_subset.select_index_belongs open_cover_of_subset_axioms_def)
    then have "sheaf_spec_morphisms U (V i) s 𝔭 = quotient_ring.zero_rel (R  𝔭) R (+) (⋅) 𝟬 𝟭"
      using H(2,4) F by (simp add: zero_sheaf_spec_def)
    thus "s 𝔭 = zero_sheaf_spec U 𝔭"
      using sheaf_spec_morphisms_def zero_sheaf_spec_def F(2) by (simp add: H(3) 𝔭  U)
  qed
  moreover have "s  extensional U" " zero_sheaf_spec U  extensional U"
    by (simp_all add: H(3))
  ultimately show "s = zero_sheaf_spec U" using extensionalityI by blast
next
  fix U I V s assume H: "open_cover_of_open_subset Spec is_zariski_open U I V"
                        "i. i  I  V i  U  s i  𝒪 (V i)"
                        "i j. i  I 
                                  j  I 
                                    sheaf_spec_morphisms (V i) (V i  V j) (s i) =
                                    sheaf_spec_morphisms (V j) (V i  V j) (s j)"
  define t where D: "t  λ𝔭U. s (cover_of_subset.select_index I V 𝔭) 𝔭"
  then have F1: "s i 𝔭 = s j 𝔭" if "i  I" "j  I" "𝔭  V i" "𝔭  V j" for 𝔭 i j
  proof -
    have "s i 𝔭 = sheaf_spec_morphisms (V i) (V i  V j) (s i) 𝔭"
      using that sheaf_spec_morphisms_def by (simp add: H(2))
    moreover have " = sheaf_spec_morphisms (V j) (V i  V j) (s j) 𝔭"
      using H(3) that by fastforce
    moreover have " = s j 𝔭"
      using sheaf_spec_morphisms_def that by (simp add: H(2))
    ultimately show "s i 𝔭 = s j 𝔭" by blast
  qed
  have "t  𝒪 U"
  proof-
    have "t 𝔭  (R𝔭 (+) (⋅) 𝟬)" if "𝔭U" for 𝔭
      using D H(1) H(2) cover_of_subset.cover_of_select_index
        cover_of_subset.select_index_belongs open_cover_of_open_subset.axioms(1)
        open_cover_of_subset_def sec_has_right_codom that by fastforce
    moreover have "t  extensional U"
      using D by blast
    moreover have "is_regular t U"
      unfolding is_regular_def
    proof (intro strip conjI)
      fix 𝔭
      assume "𝔭  U"
      show "V. is_zariski_open V  V  U  𝔭  V  is_locally_frac t V"
      proof -
        have cov_in_I: "cover_of_subset.select_index I V 𝔭  I"
          by (meson H(1) 𝔭  U cover_of_subset.select_index_belongs open_cover_of_open_subset_def open_cover_of_subset_def)
        have V: "V (cover_of_subset.select_index I V 𝔭)  U"
          using H(2) by (meson H(1) 𝔭  U cover_of_subset.select_index_belongs open_cover_of_open_subset_def open_cover_of_subset_def)
        have V2: "V'. is_zariski_open V'  V' V (cover_of_subset.select_index I V 𝔭)  𝔭  V' 
                 is_locally_frac (s (cover_of_subset.select_index I V 𝔭)) V'"
          using H(1,2)
          unfolding sheaf_spec_def open_cover_of_open_subset_def open_cover_of_subset_def is_regular_def
          using 𝔭  U cov_in_I cover_of_subset.cover_of_select_index by fastforce
        have "V' 𝔮. is_zariski_open V'  V'  V (cover_of_subset.select_index I V 𝔭)  𝔮  V'  t 𝔮 = s (cover_of_subset.select_index I V 𝔭) 𝔮"
          by (smt D F1 H(1) V 𝔭  U cover_of_subset.cover_of_select_index cover_of_subset.select_index_belongs open_cover_of_open_subset_def open_cover_of_subset_def restrict_apply subsetD)
        with V V2 show ?thesis unfolding is_locally_frac_def
          by (smt subset_trans)
      qed
    qed
    ultimately show ?thesis unfolding sheaf_spec_def by (simp add:PiE_iff)
  qed
  have "sheaf_spec_morphisms U (V i) t = s i" if "i  I" for i
  proof
    fix 𝔭
    have "sheaf_spec_morphisms U (V i) t 𝔭 = s i 𝔭" if "𝔭  U"
    proof-
      from that H(1)
      obtain j where "j  I  𝔭  V j  t 𝔭 = s j 𝔭"
        unfolding D open_cover_of_subset_def open_cover_of_open_subset_def
        by (meson cover_of_subset.cover_of_select_index cover_of_subset.select_index_belongs restrict_apply')
      thus "sheaf_spec_morphisms U (V i) t 𝔭 = s i 𝔭"
        using t  𝒪 U i  I H(2) that
        unfolding sheaf_spec_morphisms_def
        apply (simp add: D split: if_split_asm)
        by (metis (mono_tags, opaque_lifting) F1  extensional_arb [OF sec_is_extensional])
    qed
    thus "sheaf_spec_morphisms U (V i) t 𝔭 = s i 𝔭"
      using sheaf_spec_morphisms_def D F1
      by (smt H(2) i  I t  𝒪 U comm_ring.sheaf_morphisms_sheaf_spec local.comm_ring_axioms restrict_apply subsetD)
  qed
  thus "t. t  (𝒪 U)  (i. i  I  sheaf_spec_morphisms U (V i) t = s i)"
    using t  𝒪 U by blast
qed

lemma shrinking:
  assumes "is_zariski_open U" and "𝔭  U" and "s  𝒪 U" and "t  𝒪 U"
  obtains V a f b g where "is_zariski_open V" "V  U" "𝔭  V" "a  R" "f  R" "b  R" "g  R"
"f  𝔭" "g  𝔭"
"𝔮. 𝔮  V  f  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f"
"𝔮. 𝔮  V  g  𝔮  t 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g"
proof-
  obtain Vs a f where "is_zariski_open Vs" "Vs  U" "𝔭  Vs" "a  R" "f  R"
"𝔮. 𝔮  Vs  f  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f"
    using assms(2,3) sheaf_spec_def is_regular_def is_locally_frac_def by auto
  obtain Vt b g where "is_zariski_open Vt" "Vt  U" "𝔭  Vt" "b  R" "g  R"
"𝔮. 𝔮  Vt  g  𝔮  t 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g"
    using assms(2,4) sheaf_spec_def is_regular_def is_locally_frac_def by auto
  then have "is_zariski_open (Vs  Vt)" "Vs  Vt  U" "𝔭  Vs  Vt"
"𝔮. 𝔮  (Vs  Vt)  f  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f"
"𝔮. 𝔮  (Vs  Vt)  g  𝔮  t 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g"
    using topological_space.open_inter apply (simp add: is_zariski_open Vs)
    using Vs  U apply auto[1] apply (simp add: 𝔭  Vs 𝔭  Vt)
    apply (simp add: 𝔮. 𝔮  Vs  f  𝔮  s 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f)
    by (simp add: 𝔮. 𝔮  Vt  g  𝔮  t 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g)
  thus ?thesis using a  R b  R f  R g  R that by presburger
qed

end (* comm_ring *)


section ‹Schemes›

subsection ‹Ringed Spaces›

(* definition 0.32 *)
locale ringed_space = sheaf_of_rings

context comm_ring
begin

lemma spec_is_ringed_space:
  shows "ringed_space Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b
add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
proof (intro ringed_space.intro)
  show "sheaf_of_rings Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b
     add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
    using sheaf_spec_is_sheaf by simp
qed

end (* comm_ring *)

(* definition 0.33 *)
locale morphism_ringed_spaces =
im_sheaf X is_openX 𝒪X ρX b add_strX mult_strX zero_strX one_strX Y is_openY f +
 codom: ringed_space Y is_openY 𝒪Y ρY d add_strY mult_strY zero_strY one_strY
for X and is_openX and 𝒪X and ρX and b and add_strX and mult_strX and zero_strX and one_strX
and Y and is_openY and 𝒪Y and ρY and d and add_strY and mult_strY and zero_strY and one_strY
and f +
fixes φf:: "'c set  ('d  'b)"
assumes is_morphism_of_sheaves: "morphism_sheaves_of_rings
Y is_openY 𝒪Y ρY d add_strY mult_strY zero_strY one_strY
im_sheaf im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf
φf"


subsection ‹Direct Limits of Rings›

(* construction 0.34 *)
locale direct_lim = sheaf_of_rings +
  fixes I:: "'a set set"
  assumes subset_of_opens: "U. U  I  is_open U"
    and has_lower_bound: "U V.  UI; VI   WI. W  U  V"
begin

definition get_lower_bound:: "'a set  'a set  'a set" where
  "get_lower_bound U V= (SOME W. W  I  W  U  W  V)"

lemma get_lower_bound[intro]:
  assumes "U  I" "V  I"
  shows "get_lower_bound U V  I" "get_lower_bound U V  U" "get_lower_bound U V  V"
proof -
  have "W. W  I  W  U  W  V"
    using has_lower_bound[OF assms] by auto
  from someI_ex[OF this]
  show "get_lower_bound U V  I" "get_lower_bound U V  U" "get_lower_bound U V  V"
    unfolding get_lower_bound_def by auto
qed

lemma obtain_lower_bound_finite:
  assumes "finite Us"  "Us  {}" "Us  I"
  obtains W where "W  I" "UUs. W  U"
  using assms
proof (induct Us arbitrary:thesis)
  case (insert U F)
  have ?case when "F={}"
    using insert.prems(1) insert.prems(3) that by blast
  moreover have ?case when "F{}"
  proof -
    obtain W where "W  I" "UF. W  U"
      using insert.hyps(3) insert.prems(3) by auto
    obtain W1 where "W1 I" "W1  U" "W1  W"
      by (meson W  I get_lower_bound(1) get_lower_bound(2) get_lower_bound(3)
          insert.prems(3) insert_subset)
    then have "ainsert U F. W1  a"
      using UF. W  U by auto
    with W1 I show ?thesis
      using insert(4) by auto
  qed
  ultimately show ?case by auto
qed simp

definition principal_subs :: "'a set set  'a set  'a set filter" where
  "principal_subs As A = Abs_filter (λP. x. (xAs  x  A)  P x)"

lemma eventually_principal_subs: "eventually P (principal_subs As A)  (x. xAs  xA  P x)"
  unfolding principal_subs_def
  by (rule eventually_Abs_filter, rule is_filter.intro) auto

lemma principal_subs_UNIV[simp]: "principal_subs UNIV UNIV = top"
  by (auto simp: filter_eq_iff eventually_principal_subs)

lemma principal_subs_empty[simp]: "principal_subs {} s = bot"
  (*"principal_subs ss {} = bot"*)
  by (auto simp: filter_eq_iff eventually_principal_subs)

lemma principal_subs_le_iff[iff]:
  "principal_subs As A  principal_subs As' A'
             {x. xAs  x  A}  {x. xAs'  x  A'}"
  unfolding le_filter_def eventually_principal_subs by blast

lemma principal_subs_eq_iff[iff]:
    "principal_subs As A = principal_subs As' A' {x. xAs  x  A} = {x. xAs'  x  A'}"
  unfolding eq_iff by simp

lemma principal_subs_inj_on[simp]:"inj_on (principal_subs As) As"
  unfolding inj_on_def by auto

definition lbound :: "'a set set  ('a set) filter" where
  "lbound Us = (INF S{S. SI  (uUs. S  u)}. principal_subs I S)"

lemma eventually_lbound_finite:
  assumes "finite A" "A{}" "AI"
  shows "(F w in lbound A. P w)  (w0. w0  I  (aA. w0  a)  (w. (ww0  wI)  P w))"
proof -
  have "x. x  I  (xaA. x  xa)"
    by (metis Int_iff assms inf.order_iff obtain_lower_bound_finite)
  moreover have " x. x  I  Ball A ((⊆) x)
               {xa  I. xa  x}  {x  I. x  a}
                 {xa  I. xa  x}  {x  I. x  b}"
    if "a  I  (xA. a  x)" "b  I  (xA. b  x)" for a b
    apply (rule exI[where x="get_lower_bound a b"])
    using that apply auto
    subgoal using get_lower_bound(2) by blast
    subgoal by (meson get_lower_bound(2) subsetD)
    subgoal by (meson get_lower_bound(3) subsetD)
    done
  moreover have "(b{S  I. Ball A ((⊆) S)}. eventually P (principal_subs I b)) =
    (w0. w0  I  Ball A ((⊆) w0)  (w. w  w0  w  I  P w))"
    unfolding eventually_principal_subs by force
  ultimately show ?thesis unfolding lbound_def
    by (subst eventually_INF_base) auto
qed

lemma lbound_eq:
  assumes A:"finite A" "A{}" "AI"
  assumes B:"finite B" "B{}" "BI"
  shows "lbound A = lbound B"
proof -
  have "eventually P (lbound A')" if "eventually P (lbound B')"
    and A':"finite A'" "A'{}" "A'  I"
    and B':"finite B'" "B'{}" "B'  I"
  for P A' B'
  proof -
    obtain w0 where w0:"w0  I" "(aB'. w0  a)" "(w. w  w0  w  I  P w)"
      using eventually P (lbound B') unfolding eventually_lbound_finite[OF B',of P]
      by auto
    obtain w1 where w1:"w1  I" "UA'. w1  U"
      using obtain_lower_bound_finite[OF A'] by auto
    define w2 where "w2=get_lower_bound w0 w1"
    have "w2  I" using w0  I w1  I unfolding w2_def by auto
    moreover have "aA'. w2  a"
      unfolding w2_def by (meson dual_order.trans get_lower_bound(3) w0(1) w1(1) w1(2))
    moreover have "w. w  w2  w  I  P w"
      unfolding w2_def by (meson dual_order.trans get_lower_bound(2) w0(1) w0(3) w1(1))
    ultimately show ?thesis unfolding eventually_lbound_finite[OF A',of P] by auto
  qed
  then have "eventually P (lbound A) = eventually P (lbound B)" for P
    using A B by auto
  then show ?thesis unfolding filter_eq_iff by auto
qed

lemma lbound_leq:
  assumes "A  B"
  shows "lbound A lbound B"
  unfolding lbound_def
  apply (rule Inf_superset_mono)
  apply (rule image_mono)
  using assms by auto

definition llbound::"('a set) filter" where
  "llbound = lbound {SOME a. aI}"

lemma llbound_not_bot:
  assumes "I {}"
  shows "llbound  bot"
  unfolding trivial_limit_def llbound_def
  apply (subst eventually_lbound_finite)
  using assms by (auto simp add: some_in_eq)

lemma llbound_lbound:
  assumes "finite A" "A{}" "AI"
  shows "lbound A = llbound"
  unfolding llbound_def
  apply (rule lbound_eq)
  using assms by (auto simp add: some_in_eq)

definition rel:: "('a set × 'b)  ('a set × 'b)  bool" (infix "" 80)
  where "x  y  (fst x  I  fst y  I)  (snd x  𝔉 (fst x)  snd y  𝔉 (fst y)) 
(W. (W  I)  (W  fst x  fst y)  ρ (fst x) W (snd x) = ρ (fst y) W (snd y))"

lemma rel_is_equivalence:
  shows "equivalence (Sigma I 𝔉) {(x, y). x  y}"
  unfolding equivalence_def
proof (intro conjI strip)
  show "(a, c)  {(x, y). x  y}"
    if "(a, b)  {(x, y). x  y}" "(b, c)  {(x, y). x  y}" for a b c
  proof -
    obtain W1 where W1:"fst a  I" "fst b  I" "snd a  𝔉 (fst a)" "snd b  𝔉 (fst b)"
                    "W1  I" "W1  fst a" "W1  fst b"
                    "ρ (fst a) W1 (snd a) = ρ (fst b) W1 (snd b)"
      using (a, b)  {(x, y). x  y} unfolding rel_def by auto
    obtain W2 where W2:"fst b  I" "fst c  I" "snd b  𝔉 (fst b)" "snd c  𝔉 (fst c)"
                    "W2  I" "W2  fst b" "W2  fst c"
                    "ρ (fst b) W2 (snd b) = ρ (fst c) W2 (snd c)"
      using (b, c)  {(x, y). x  y} unfolding rel_def by auto
    obtain W3 where W3:"W3 I" "W3  W1  W2"
      using has_lower_bound[OF W1I W2I] by auto
    from W3  W1  W2
    have "W3  fst a  fst c" using W1(6) W2(7) by blast
    moreover have "ρ (fst a) W3 (snd a) = ρ (fst c) W3 (snd c)"
      using W1 W2 by (metis W3(1) W3(2) eq_ρ le_inf_iff subset_of_opens)
    moreover note W3 I W1 W2
    ultimately show ?thesis
      unfolding rel_def by auto
  qed
qed (auto simp: rel_def Int_commute)

interpretation rel:equivalence "(Sigma I 𝔉)" "{(x, y). x  y}"
  using rel_is_equivalence .

definition class_of:: "'a set  'b  ('a set × 'b) set" ("(_,/ _)")
  where "U,s  rel.Class (U, s)"

lemma class_of_eqD:
  assumes "U1,s1 = U2,s2" "(U1,s1)  Sigma I 𝔉" "(U2,s2)  Sigma I 𝔉"
  obtains W where "W  I" "W  U1  U2" "ρ U1 W s1 = ρ U2 W s2"
  using rel.Class_equivalence[OF assms(2,3)] assms(1)
  unfolding class_of_def rel_def by auto

lemma class_of_eqI:
  assumes "(U1,s1)  Sigma I 𝔉" "(U2,s2)  Sigma I 𝔉"
  assumes "W  I" "W  U1  U2" "ρ U1 W s1 = ρ U2 W s2"
  shows "U1,s1 = U2,s2"
  unfolding class_of_def
  apply (rule rel.Class_eq)
  using assms  by (auto simp: rel_def)

lemma class_of_0_in:
  assumes "U  I"
  shows "𝟬⇘U 𝔉 U"
proof -
  have "ring (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U⇙"
    using assms subset_of_opens is_ring_from_is_homomorphism by blast
  then show ?thesis
    unfolding ring_def abelian_group_def Group_Theory.group_def by (meson monoid.unit_closed)
qed

lemma rel_Class_iff: "x  y  y  Sigma I 𝔉  x  rel.Class y"
  by blast

lemma class_of_0_eq:
  assumes "U  I" "U'  I"
  shows "U, 𝟬⇘U = U', 𝟬⇘U'"
proof -
  obtain W where W: "W  I" "W  U" "W  U'"
    by (metis Int_subset_iff assms has_lower_bound)
  then have "is_open W" "is_open U" "is_open U'"
    by (auto simp add: assms subset_of_opens)
  then have "ρ U W 𝟬⇘U= ρ U' W 𝟬⇘U'⇙"
    using W is_ring_morphism [of U W] is_ring_morphism [of U' W]
    by (simp add: ring_homomorphism_def group_homomorphism_def monoid_homomorphism_def
               monoid_homomorphism_axioms_def)
  with W have "W. W  I  W  U  W  U'  ρ U W 𝟬⇘U= ρ U' W 𝟬⇘U'⇙" by blast
  moreover have "𝟬⇘U 𝔉 U" "𝟬⇘U' 𝔉 U'"
    by (auto simp add: assms class_of_0_in)
  ultimately have "(U, 𝟬⇘U)  (U', 𝟬⇘U')"
    using assms by (auto simp: rel_def)
  then show ?thesis
    unfolding class_of_def by (simp add: rel.Class_eq)
qed

lemma class_of_1_in:
  assumes "U  I"
  shows "𝟭⇘U 𝔉 U"
proof -
  have "ring (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U⇙"
    using assms subset_of_opens is_ring_from_is_homomorphism by blast
  then show ?thesis
    unfolding ring_def by (meson monoid.unit_closed)
qed

lemma class_of_1_eq:
  assumes "U  I" and "U'  I"
  shows "U, 𝟭⇘U = U', 𝟭⇘U'"
proof -
  obtain W where W: "W  I" "W  U" "W  U'"
    by (metis Int_subset_iff assms has_lower_bound)
  then have "is_open W" "is_open U" "is_open U'"
    by (auto simp add: assms subset_of_opens)
  then have "ρ U W 𝟭⇘U= ρ U' W 𝟭⇘U'⇙"
    using W is_ring_morphism [of U W] is_ring_morphism [of U' W]
    by (simp add: ring_homomorphism_def group_homomorphism_def monoid_homomorphism_def
               monoid_homomorphism_axioms_def)
  with W have "W. W  I  W  U  W  U'  ρ U W 𝟭⇘U= ρ U' W 𝟭⇘U'⇙" by blast
  moreover
  have "𝟭⇘U 𝔉 U" "𝟭⇘U' 𝔉 U'"
    by (auto simp add: assms class_of_1_in)
  ultimately have "(U, 𝟭⇘U)  (U', 𝟭⇘U')"
    using assms by (auto simp: rel_def)
  then show ?thesis
    unfolding class_of_def by (simp add: rel.Class_eq)
qed

definition add_rel :: "('a set × 'b) set  ('a set × 'b) set  ('a set × 'b) set"
  where "add_rel X Y  let
              x = (SOME x. x  X);
              y = (SOME y. y  Y);
              w = get_lower_bound (fst x) (fst y)
            in
              w, add_str w (ρ (fst x) w (snd x)) (ρ (fst y) w (snd y))"

definition mult_rel :: "('a set × 'b) set  ('a set × 'b) set  ('a set × 'b) set"
  where "mult_rel X Y  let
              x = (SOME x. x  X);
              y = (SOME y. y  Y);
              w = get_lower_bound (fst x) (fst y)
            in
              w, mult_str w (ρ (fst x) w (snd x)) (ρ (fst y) w (snd y))"

definition carrier_direct_lim:: "('a set × 'b) set set"
  where "carrier_direct_lim  rel.Partition"

lemma zero_rel_carrier[intro]:
  assumes "U  I"
  shows "U, 𝟬⇘U  carrier_direct_lim"
  unfolding carrier_direct_lim_def class_of_def
proof (rule rel.Block_closed)
  interpret ring "(𝔉 U)" "+⇘U⇙" "⋅⇘U⇙" "𝟬⇘U⇙" "𝟭⇘U⇙"
    by (simp add: assms is_ring_from_is_homomorphism subset_of_opens)
  show "(U, 𝟬⇘U)  Sigma I 𝔉"
    by (simp add: assms)
qed

lemma one_rel_carrier[intro]:
  assumes "U  I"
  shows "U, 𝟭⇘U  carrier_direct_lim"
  unfolding carrier_direct_lim_def class_of_def
  apply (rule rel.Block_closed)
  by (simp add: assms class_of_1_in)

lemma rel_carrier_Eps_in:
  fixes X :: "('a set × 'b) set"
  defines "a(SOME x. x  X)"
  assumes "X  carrier_direct_lim"
  shows "a  X" "a Sigma I 𝔉"  "X = fst a, snd a"
proof -
  have "aSigma I 𝔉. a  X  X = rel.Class a"
    using rel.representant_exists[OF X  carrier_direct_lim[unfolded carrier_direct_lim_def]]
    by simp
  then have "a  X  a Sigma I 𝔉  X = fst a, snd a"
    unfolding class_of_def
    by (metis a_def assms(2) carrier_direct_lim_def ex_in_conv prod.collapse rel.Block_self
        rel.Class_closed some_in_eq)
  then show "a  X" "a Sigma I 𝔉"  "X = fst a, snd a" by auto
qed

lemma add_rel_carrier[intro]:
  assumes "X  carrier_direct_lim" "Y  carrier_direct_lim"
  shows "add_rel X Y  carrier_direct_lim"
proof -
  define x where "x=(SOME x. x  X)"
  define y where "y=(SOME y. y  Y)"
  define z where "z=get_lower_bound (fst x) (fst y)"

  have "xX" "xSigma I 𝔉"
    using rel_carrier_Eps_in[OF X  carrier_direct_lim] unfolding x_def by auto
  have "yY" "y  Sigma I 𝔉"
    using rel_carrier_Eps_in[OF Y  carrier_direct_lim] unfolding y_def by auto

  have "add_rel X Y = z, add_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y))"
    unfolding add_rel_def Let_def
    by (fold x_def y_def z_def,rule)
  also have "...  carrier_direct_lim"
    unfolding carrier_direct_lim_def class_of_def
  proof (rule rel.Block_closed)
    have "zI" using xSigma I 𝔉 ySigma I 𝔉 unfolding z_def by auto
    then interpret ring "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
      using is_ring_from_is_homomorphism subset_of_opens by auto
    show "(z, +⇘z(ρ (fst x) z (snd x)) (ρ (fst y) z (snd y)))  Sigma I 𝔉"
      using zI
      apply simp
      by (metis x  Sigma I 𝔉 y  Sigma I 𝔉 additive.composition_closed
          direct_lim.subset_of_opens direct_lim_axioms get_lower_bound(2) get_lower_bound(3)
          is_map_from_is_homomorphism map.map_closed mem_Sigma_iff prod.exhaust_sel z_def)
  qed
  finally show ?thesis .
qed


lemma rel_eventually_llbound:
  assumes "x  y"
  shows "F w in llbound. ρ (fst x) w (snd x) = ρ (fst y) w (snd y)"
proof -
  have xy:"fst x  I" "fst y  I" "snd x  𝔉 (fst x)" "snd y  𝔉 (fst y)"
    using x  y unfolding rel_def by auto
  obtain w0 where w0:"w0  I" "w0  fst x  fst y" "ρ (fst x) w0 (snd x) = ρ (fst y) w0 (snd y)"
    using x  y unfolding rel_def by auto

  interpret xw0:ring_homomorphism "ρ (fst x) w0" "𝔉 (fst x)" "+⇘fst x⇙" "⋅⇘fst x⇙" "𝟬⇘fst x⇙"
        "𝟭⇘fst x⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
    by (meson is_ring_morphism le_inf_iff subset_of_opens w0 xy(1))
  interpret yw0:ring_homomorphism "ρ (fst y) w0" "𝔉 (fst y)" "+⇘fst y⇙" "⋅⇘fst y⇙" "𝟬⇘fst y⇙"
        "𝟭⇘fst y⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
    using w0 by (metis is_ring_morphism le_inf_iff subset_of_opens  xy(2))
  have "ρ (fst x) w (snd x) = ρ (fst y) w (snd y)" if "w  w0" "w  I" for w
  proof -
    interpret w0w:ring_homomorphism "ρ w0 w" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙" "𝔉 w"
                  "+⇘w⇙" "⋅⇘w⇙" "𝟬⇘w⇙" "𝟭⇘w⇙"
      using is_ring_morphism subset_of_opens that w0(1) by presburger

    have "ρ (fst x) w (snd x) = (ρ w0 w  ρ (fst x) w0) (snd x)"
      by (meson assoc_comp le_inf_iff subset_of_opens that w0 xy)
    also have "... = (ρ w0 w  ρ (fst y) w0) (snd y)"
      unfolding comp_def
      using w0(3) by auto
    also have "... = ρ (fst y) w (snd y)"
      using w0 xy by (metis Int_subset_iff assoc_comp subset_of_opens that)
    finally show ?thesis .
  qed
  with w0 have "w0. w0  I  w0  fst x  fst y
             (w. (ww0  wI)  ρ (fst x) w (snd x) = ρ (fst y) w (snd y))"
    by auto
  then have "F w in lbound {fst x,fst y}. ρ (fst x) w (snd x) = ρ (fst y) w (snd y)"
    apply (subst eventually_lbound_finite)
    using xy(1,2) by auto
  then show ?thesis
    using llbound_lbound[of "{fst x,fst y}"] xy(1,2) by auto
qed

lemma
  fixes x y:: "'a set × 'b" and z z':: "'a set"
  assumes xy:"x  Sigma I 𝔉" "y  Sigma I 𝔉"
  assumes z:"zI" "z  fst x" "z  fst y"
  assumes z':"z'I" "z'  fst x" "z'  fst y"
  shows add_rel_well_defined:"z, add_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y)) =
          z', add_str z' (ρ (fst x) z' (snd x)) (ρ (fst y) z' (snd y))" (is "?add")
    and mult_rel_well_defined:
        "z, mult_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y)) =
         z', mult_str z' (ρ (fst x) z' (snd x)) (ρ (fst y) z' (snd y))" (is "?mult")
proof -
  interpret xz:ring_homomorphism "(ρ (fst x) z)" "(𝔉 (fst x))"
              "+⇘fst x⇙" "⋅⇘fst x⇙" "𝟬⇘fst x⇙" "𝟭⇘fst x⇙" "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
    using is_ring_morphism x  Sigma I 𝔉 z subset_of_opens by force
  interpret yz:ring_homomorphism "(ρ (fst y) z)" "(𝔉 (fst y))"
              "+⇘fst y⇙" "⋅⇘fst y⇙" "𝟬⇘fst y⇙" "𝟭⇘fst y⇙" "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
    using is_ring_morphism y  Sigma I 𝔉 z subset_of_opens by force
  interpret xz':ring_homomorphism "(ρ (fst x) z')" "(𝔉 (fst x))"
              "+⇘fst x⇙" "⋅⇘fst x⇙" "𝟬⇘fst x⇙" "𝟭⇘fst x⇙" "(𝔉 z')" "+⇘z'⇙" "⋅⇘z'⇙" "𝟬⇘z'⇙" "𝟭⇘z'⇙"
    using is_ring_morphism x  Sigma I 𝔉 z' subset_of_opens by force
  interpret yz':ring_homomorphism "(ρ (fst y) z')" "(𝔉 (fst y))"
              "+⇘fst y⇙" "⋅⇘fst y⇙" "𝟬⇘fst y⇙" "𝟭⇘fst y⇙" "(𝔉 z')" "+⇘z'⇙" "⋅⇘z'⇙" "𝟬⇘z'⇙" "𝟭⇘z'⇙"
    using is_ring_morphism y  Sigma I 𝔉 z' subset_of_opens by force

  obtain w where w:"w  I" "w  z  z'"
    using has_lower_bound zI z'I by meson

  interpret zw:ring_homomorphism "ρ z w" "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
      "𝔉 w" "+⇘w⇙" "⋅⇘w⇙" "𝟬⇘w⇙" "𝟭⇘w⇙"
    using w by (meson is_ring_morphism le_inf_iff subset_of_opens z(1))
  interpret z'w:ring_homomorphism "ρ z' w" "(𝔉 z')" "+⇘z'⇙" "⋅⇘z'⇙" "𝟬⇘z'⇙" "𝟭⇘z'⇙"
      "𝔉 w" "+⇘w⇙" "⋅⇘w⇙" "𝟬⇘w⇙" "𝟭⇘w⇙"
    using w  I w  z  z' z' by (meson is_ring_morphism le_inf_iff subset_of_opens)

  show ?add
  proof (rule class_of_eqI[OF _ _ w  I w  z  z'])
    define xz yz where "xz = ρ (fst x) z (snd x)" and "yz = ρ (fst y) z (snd y)"
    define xz' yz' where "xz' = ρ (fst x) z' (snd x)" and "yz' = ρ (fst y) z' (snd y)"
    show "(z, +⇘zxz yz)  Sigma I 𝔉" "(z', +⇘z'xz' yz')  Sigma I 𝔉"
      subgoal using assms(1) assms(2) xz_def yz_def z(1) by fastforce
      subgoal using assms(1) assms(2) xz'_def yz'_def z'(1) by fastforce
      done
    have "ρ z w (+⇘zxz yz) = +⇘w(ρ z w xz) (ρ z w yz)"
      apply (rule zw.additive.commutes_with_composition)
      using assms(1,2) xz_def yz_def by force+
    also have "... = +⇘w(ρ (fst x) w (snd x)) (ρ (fst y) w (snd y))"
      unfolding xz_def yz_def
      using assoc_comp w z subset_of_opens assms
      by (metis SigmaE le_inf_iff o_def prod.sel)
    also have "... = +⇘w(ρ z' w xz') (ρ z' w yz')"
      unfolding xz'_def yz'_def
      using assoc_comp  w z' subset_of_opens assms
      by (metis SigmaE le_inf_iff o_def prod.sel)
    also have "... = ρ z' w (+⇘z'xz' yz')"
      using assms(2) xy(1) xz'_def yz'_def z'w.additive.commutes_with_composition by force
    finally show "ρ z w (+⇘zxz yz) = ρ z' w (+⇘z'xz' yz')" .
  qed

  show ?mult
  proof (rule class_of_eqI[OF _ _ w  I w  z  z'])
    define xz yz where "xz = ρ (fst x) z (snd x)" and "yz = ρ (fst y) z (snd y)"
    define xz' yz' where "xz' = ρ (fst x) z' (snd x)" and "yz' = ρ (fst y) z' (snd y)"
    show "(z, ⋅⇘zxz yz)  Sigma I 𝔉" "(z', ⋅⇘z'xz' yz')  Sigma I 𝔉"
      unfolding xz_def yz_def xz'_def yz'_def
      using assms by auto
    have "ρ z w (⋅⇘zxz yz) = ⋅⇘w(ρ z w xz) (ρ z w yz)"
      apply (rule zw.multiplicative.commutes_with_composition)
      using xy xz_def yz_def by force+
    also have "... = ⋅⇘w(ρ (fst x) w (snd x)) (ρ (fst y) w (snd y))"
      unfolding xz_def yz_def
      using xy w z assoc_comp
      by (metis SigmaE fst_conv le_inf_iff o_def snd_conv subset_of_opens)
    also have "... = ⋅⇘w(ρ z' w xz') (ρ z' w yz')"
      unfolding xz'_def yz'_def
      using xy w z' assoc_comp
      by (metis SigmaE fst_conv le_inf_iff o_def snd_conv subset_of_opens)
    also have "... = ρ z' w (⋅⇘z'xz' yz')"
      unfolding xz'_def yz'_def
      using monoid_homomorphism.commutes_with_composition xy z'w.multiplicative.monoid_homomorphism_axioms by fastforce
    finally show "ρ z w (⋅⇘zxz yz) = ρ z' w (⋅⇘z'xz' yz')" .
  qed
qed

lemma add_rel_well_defined_llbound:
  fixes x y:: "'a set × 'b" and z z':: "'a set"
  assumes "x  Sigma I 𝔉" "y  Sigma I 𝔉"
  assumes z:"zI" "z  fst x" "z  fst y"
  shows "F w in llbound. z, add_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y)) =
          w, add_str w (ρ (fst x) w (snd x)) (ρ (fst y) w (snd y))" (is "F w in _. ?P w")
proof -
  have  "w. w  z  w  I ?P w "
    by (meson add_rel_well_defined assms(1) assms(2) dual_order.trans z(1) z(2) z(3))
  then have "F w in lbound {fst x,fst y}. ?P w"
    apply (subst eventually_lbound_finite)
    using assms by auto
  then show ?thesis
    using llbound_lbound[of "{fst x,fst y}"] assms(1,2) by auto
qed

lemma mult_rel_well_defined_llbound:
  fixes x y:: "'a set × 'b" and z z':: "'a set"
  assumes "x  Sigma I 𝔉" "y  Sigma I 𝔉"
  assumes z:"zI" "z  fst x" "z  fst y"
  shows "F w in llbound. z, mult_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y)) =
          w, mult_str w (ρ (fst x) w (snd x)) (ρ (fst y) w (snd y))" (is "F w in _. ?P w")
proof -
  have  "w. w  z  w  I ?P w "
    by (meson mult_rel_well_defined assms(1) assms(2) dual_order.trans z(1) z(2) z(3))
  then have "F w in lbound {fst x,fst y}. ?P w"
    apply (subst eventually_lbound_finite)
    using assms by auto
  then show ?thesis
    using llbound_lbound[of "{fst x,fst y}"] assms(1,2) by auto
qed

lemma add_rel_class_of:
  fixes U V W :: "'a set" and x y :: 'b
  assumes uv_sigma:"(U, x)  Sigma I 𝔉" "(V, y)  Sigma I 𝔉"
  assumes w:"W  I" "W  U" "W  V"
  shows "add_rel U, x V, y = W, +⇘W(ρ U W x) (ρ V W y)"
proof -
  define ux where "ux = (SOME ux. ux  U, x)"
  define vy where "vy = (SOME ux. ux  V, y)"
  have "ux  U, x" "vy  V, y "
    unfolding ux_def vy_def using uv_sigma class_of_def some_in_eq by blast+
  then have "ux  Sigma I 𝔉" "vy  Sigma I 𝔉"
    using class_of_def uv_sigma by blast+
  then have "fst ux  I" "fst vy  I" by auto

  define w1 where "w1 = get_lower_bound (fst ux) (fst vy)"
  have w1:"w1  I" "w1  fst ux" "w1  fst vy"
    using get_lower_bound[OF fst ux  I fst vy  I] unfolding w1_def by auto

  have "add_rel U, x V, y = w1, +⇘w1(ρ (fst ux) w1 (snd ux)) (ρ (fst vy) w1 (snd vy))"
    unfolding add_rel_def
    apply (fold ux_def vy_def)
    by (simp add:Let_def w1_def)
  moreover have "F w in llbound.
            ... = w, add_str w (ρ (fst ux) w (snd ux)) (ρ (fst vy) w (snd vy))"
    apply (rule add_rel_well_defined_llbound)
    using ux  Sigma I 𝔉 vy  Sigma I 𝔉 w1 by auto
  ultimately have "F w in llbound. add_rel U, x V, y
      = w, add_str w (ρ (fst ux) w (snd ux)) (ρ (fst vy) w (snd vy))"
    by simp
  moreover have
    "F w in llbound. ρ (fst ux) w (snd ux) = ρ (fst (U, x)) w (snd (U, x))"
    "F w in llbound. ρ (fst vy) w (snd vy) = ρ (fst (V, y)) w (snd (V, y))"
    subgoal
      apply (rule rel_eventually_llbound)
      using ux  U, x class_of_def uv_sigma(1) by auto
    subgoal
      apply (rule rel_eventually_llbound)
      using vy  V, y class_of_def uv_sigma(2) by auto
    done
  ultimately have "F w in llbound. add_rel U, x V, y
      = w, add_str w (ρ U w x) (ρ V w y)"
    apply eventually_elim
    by auto
  moreover have "F w in llbound. W, +⇘W(ρ U W x) (ρ V W y) = w, +⇘w(ρ U w x) (ρ V w y)"
    apply (rule add_rel_well_defined_llbound[of "(U,x)" "(V,y)" W,simplified])
    using w uv_sigma by auto
  ultimately have "F w in llbound.
      add_rel U, x V, y = W, +⇘W(ρ U W x) (ρ V W y)"
    apply eventually_elim
    by auto
  moreover have "llboundbot" using llbound_not_bot w(1) by blast
  ultimately show ?thesis by auto
qed

lemma mult_rel_class_of:
  fixes U V W :: "'a set" and x y :: 'b
  assumes uv_sigma:"(U, x)  Sigma I 𝔉" "(V, y)  Sigma I 𝔉"
  assumes w:"W  I" "W  U" "W  V"
  shows "mult_rel U, x V, y = W, ⋅⇘W(ρ U W x) (ρ V W y)"
proof -
  define ux where "ux = (SOME ux. ux  U, x)"
  define vy where "vy = (SOME ux. ux  V, y)"
  have "ux  U, x" "vy  V, y "
    unfolding ux_def vy_def using uv_sigma class_of_def some_in_eq by blast+
  then have "ux  Sigma I 𝔉" "vy  Sigma I 𝔉"
    using class_of_def uv_sigma by blast+
  then have "fst ux  I" "fst vy  I" by auto

  define w1 where "w1 = get_lower_bound (fst ux) (fst vy)"
  have w1:"w1  I" "w1  fst ux" "w1  fst vy"
    using get_lower_bound[OF fst ux  I fst vy  I] unfolding w1_def by auto

  have "mult_rel U, x V, y = w1, ⋅⇘w1(ρ (fst ux) w1 (snd ux)) (ρ (fst vy) w1 (snd vy))"
    unfolding mult_rel_def
    apply (fold ux_def vy_def)
    by (simp add:Let_def w1_def)
  moreover have "F w in llbound.
            ... = w, mult_str w (ρ (fst ux) w (snd ux)) (ρ (fst vy) w (snd vy))"
    apply (rule mult_rel_well_defined_llbound)
    using ux  Sigma I 𝔉 vy  Sigma I 𝔉 w1 by auto
  ultimately have "F w in llbound. mult_rel U, x V, y
      = w, mult_str w (ρ (fst ux) w (snd ux)) (ρ (fst vy) w (snd vy))"
    by simp
  moreover have
    "F w in llbound. ρ (fst ux) w (snd ux) = ρ (fst (U, x)) w (snd (U, x))"
    "F w in llbound. ρ (fst vy) w (snd vy) = ρ (fst (V, y)) w (snd (V, y))"
    subgoal
      apply (rule rel_eventually_llbound)
      using ux  U, x class_of_def uv_sigma(1) by auto
    subgoal
      apply (rule rel_eventually_llbound)
      using vy  V, y class_of_def uv_sigma(2) by auto
    done
  ultimately have "F w in llbound. mult_rel U, x V, y
      = w, mult_str w (ρ U w x) (ρ V w y)"
    apply eventually_elim
    by auto
  moreover have "F w in llbound. W, ⋅⇘W(ρ U W x) (ρ V W y) = w, ⋅⇘w(ρ U w x) (ρ V w y)"
    apply (rule mult_rel_well_defined_llbound[of "(U,x)" "(V,y)" W,simplified])
    using w uv_sigma by auto
  ultimately have "F w in llbound.
      mult_rel U, x V, y = W, ⋅⇘W(ρ U W x) (ρ V W y)"
    apply eventually_elim
    by auto
  moreover have "llboundbot" using llbound_not_bot w(1) by blast
  ultimately show ?thesis by auto
qed

lemma mult_rel_carrier[intro]:
  assumes "X  carrier_direct_lim" "Y  carrier_direct_lim"
  shows "mult_rel X Y  carrier_direct_lim"
proof -
  define x where "x=(SOME x. x  X)"
  define y where "y=(SOME y. y  Y)"

  have "xX" "xSigma I 𝔉"
    using rel_carrier_Eps_in[OF X  carrier_direct_lim] unfolding x_def by auto
  have "yY" "y  Sigma I 𝔉"
    using rel_carrier_Eps_in[OF Y  carrier_direct_lim] unfolding y_def by auto

  define z where "z=get_lower_bound (fst x) (fst y)"
  have "z  I" "z  fst x" "z  fst y"
  proof -
    have "fst x  I" "fst y  I"
      using x  Sigma I 𝔉 y  Sigma I 𝔉 by auto
    then show "z  I" "z  fst x" "z  fst y"
      using get_lower_bound[of "fst x" "fst y",folded z_def] by auto
  qed

  have "mult_rel X Y = z, mult_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y))"
    unfolding mult_rel_def Let_def
    by (fold x_def y_def z_def,rule)
  also have "...  carrier_direct_lim"
    unfolding carrier_direct_lim_def class_of_def
  proof (rule rel.Block_closed)
    interpret ring "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
      by (simp add: z  I is_ring_from_is_homomorphism subset_of_opens)
    show "(z, ⋅⇘z(ρ (fst x) z (snd x)) (ρ (fst y) z (snd y)))  Sigma I 𝔉"
      by (metis SigmaE SigmaI x  Sigma I 𝔉 y  Sigma I 𝔉 z  I z  fst x z  fst y
          direct_lim.subset_of_opens direct_lim_axioms fst_conv
          is_map_from_is_homomorphism map.map_closed multiplicative.composition_closed snd_conv)
  qed
  finally show ?thesis .
qed

(* exercise 0.35 *)
lemma direct_lim_is_ring:
  assumes "U  I"
  shows "ring carrier_direct_lim add_rel mult_rel U, 𝟬⇘U U, 𝟭⇘U"
proof unfold_locales
  show add_rel: "add_rel a b  carrier_direct_lim" and mult_rel: "mult_rel a b  carrier_direct_lim"
    if "a  carrier_direct_lim" "b  carrier_direct_lim" for a b
    using U  I that by auto
  show zero_rel: "U, 𝟬⇘U  carrier_direct_lim" and one_rel: "U, 𝟭⇘U  carrier_direct_lim"
    using U  I by auto

  show add_rel_0: "add_rel U, 𝟬⇘U X = X"
    and "mult_rel U, 𝟭⇘U X = X"
    and "mult_rel X U, 𝟭⇘U = X"
      if "X  carrier_direct_lim" for X
  proof -
    define x where "x=(SOME x. x  X)"
    have x:"xX" "xSigma I 𝔉" "fst xI" and X_alt:"X= fst x, snd x"
      using rel_carrier_Eps_in[OF X  carrier_direct_lim]
      unfolding x_def by auto

    obtain w0 where w0:"w0I" "w0  U" "w0  fst x"
      using has_lower_bound[OF UI fst xI] by blast

    interpret uw0:ring_homomorphism "ρ U w0" "𝔉 U" "+⇘U⇙" "⋅⇘U⇙" "𝟬⇘U⇙" "𝟭⇘U⇙" "𝔉 w0" "+⇘w0⇙"
                    "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism UI w0 subset_of_opens by auto
    interpret xw0:ring_homomorphism "ρ (fst x) w0" "𝔉 (fst x)" "+⇘fst x⇙" "⋅⇘fst x⇙" "𝟬⇘fst x⇙"
                    "𝟭⇘fst x⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism fst xI w0 subset_of_opens by auto

    have "add_rel U, 𝟬⇘U X = w0, +⇘w0(ρ U w0 𝟬⇘U) (ρ (fst x) w0 (snd x))"
      unfolding X_alt
      apply (subst add_rel_class_of)
      using U  I w0 x by simp_all
    also have "... = w0, +⇘w0⇙ 𝟬⇘w0(ρ (fst x) w0 (snd x))"
      by (simp add:uw0.additive.commutes_with_unit )
    also have "... = w0, ρ (fst x) w0 (snd x)"
      apply (subst uw0.target.additive.left_unit)
      using carrier_direct_lim_def rel.block_closed that x(1) by auto
    also have "... = X"
      unfolding X_alt
      apply (rule class_of_eqI[where W=w0])
      using w0 x subset_of_opens by auto
    finally show "add_rel U, 𝟬⇘U X = X" .

    have "mult_rel U, 𝟭⇘U X = w0, ⋅⇘w0(ρ U w0 𝟭⇘U) (ρ (fst x) w0 (snd x))"
      unfolding X_alt
      apply (subst mult_rel_class_of)
      using U  I w0 x by simp_all
    also have "... = w0, ⋅⇘w0⇙ 𝟭⇘w0(ρ (fst x) w0 (snd x))"
      by (simp add: uw0.multiplicative.commutes_with_unit)
    also have "... = w0, ρ (fst x) w0 (snd x)"
      apply (subst uw0.target.multiplicative.left_unit)
      using carrier_direct_lim_def rel.block_closed that x(1) by auto
    also have "... = X"
      using X_alt w0, ρ (fst x) w0 (snd x) = X by force
    finally show "mult_rel U, 𝟭⇘U X = X" .

    have "mult_rel X U, 𝟭⇘U = w0, ⋅⇘w0(ρ (fst x) w0 (snd x)) (ρ U w0 𝟭⇘U)"
      unfolding X_alt
      apply (subst mult_rel_class_of)
      using U  I w0 x by simp_all
    also have "... = w0, ⋅⇘w0(ρ (fst x) w0 (snd x)) 𝟭⇘w0"
      by (simp add: uw0.multiplicative.commutes_with_unit)
    also have "... = w0, ρ (fst x) w0 (snd x)"
      apply (subst uw0.target.multiplicative.right_unit)
      using carrier_direct_lim_def rel.block_closed that x(1) by auto
    also have "... = X"
      using X_alt w0, ρ (fst x) w0 (snd x) = X by force
    finally show "mult_rel X U, 𝟭⇘U = X" .
  qed

  show add_rel_commute: "add_rel X Y = add_rel Y X"
    if "X  carrier_direct_lim" "Y  carrier_direct_lim" for X Y
  proof -
    define x where "x=(SOME x. x  X)"
    define y where "y=(SOME y. y  Y)"

    have x:"xX" "xSigma I 𝔉"
      using rel_carrier_Eps_in[OF X  carrier_direct_lim] unfolding x_def by auto
    have y:"yY" "y  Sigma I 𝔉"
      using rel_carrier_Eps_in[OF Y  carrier_direct_lim] unfolding y_def by auto

    define z where "z=get_lower_bound (fst x) (fst y)"
    have z:"z  I" "z  fst x" "z  fst y" and z_alt:"z=get_lower_bound (fst y) (fst x) "
    proof -
      have "fst x  I" "fst y  I"
        using x  Sigma I 𝔉 y  Sigma I 𝔉 by auto
      then show "z  I" "z  fst x" "z  fst y"
        using get_lower_bound[of "fst x" "fst y",folded z_def] by auto
      show "z=get_lower_bound (fst y) (fst x) "
        by (metis (no_types, lifting) Eps_cong get_lower_bound_def z_def)
    qed

    interpret xz:ring_homomorphism "(ρ (fst x) z)" "(𝔉 (fst x))" "+⇘fst x⇙" "⋅⇘fst x⇙"
                      "𝟬⇘fst x⇙" "𝟭⇘fst x⇙" "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
      using is_ring_morphism z x subset_of_opens by force

    interpret yz:ring_homomorphism "(ρ (fst y) z)" "(𝔉 (fst y))" "+⇘fst y⇙" "⋅⇘fst y⇙"
                      "𝟬⇘fst y⇙" "𝟭⇘fst y⇙" "(𝔉 z)" "+⇘z⇙" "⋅⇘z⇙" "𝟬⇘z⇙" "𝟭⇘z⇙"
      using is_ring_morphism z y subset_of_opens by auto

    have "add_rel X Y = z, add_str z (ρ (fst x) z (snd x)) (ρ (fst y) z (snd y))"
      unfolding add_rel_def Let_def by (fold x_def y_def z_def,rule)
    also have "... = add_rel Y X"
      unfolding add_rel_def Let_def
      apply (fold x_def y_def z_alt)
      using x  Sigma I 𝔉 y  Sigma I 𝔉 xz.target.additive.commutative by auto
    finally show "add_rel X Y = add_rel Y X" .
  qed

  show add_assoc:"add_rel (add_rel X Y) Z = add_rel X (add_rel Y Z)"
       "mult_rel (mult_rel X Y) Z = mult_rel X (mult_rel Y Z)"
       "mult_rel X (add_rel Y Z) = add_rel (mult_rel X Y) (mult_rel X Z)"
       "mult_rel (add_rel Y Z) X = add_rel (mult_rel Y X) (mult_rel Z X)"
    if "X  carrier_direct_lim" "Y  carrier_direct_lim" "Z  carrier_direct_lim" for X Y Z
  proof -
    define x where "x=(SOME x. x  X)"
    define y where "y=(SOME y. y  Y)"
    define z where "z=(SOME z. z  Z)"

    have x:"xX" "xSigma I 𝔉" and x_alt:"X = fst x,snd x"
      using rel_carrier_Eps_in[OF X  carrier_direct_lim] unfolding x_def by auto
    have y:"yY" "y  Sigma I 𝔉" and y_alt:"Y = fst y,snd y"
      using rel_carrier_Eps_in[OF Y  carrier_direct_lim] unfolding y_def by auto
    have z:"zZ" "z  Sigma I 𝔉" and z_alt:"Z = fst z,snd z"
      using rel_carrier_Eps_in[OF Z  carrier_direct_lim] unfolding z_def by auto

    obtain w0 where w0:"w0  I" "w0  fst x" "w0  fst y" "w0  fst z"
      using obtain_lower_bound_finite[of "{fst x,fst y,fst z}"] x y z
      by force

    interpret xw0:ring_homomorphism "ρ (fst x) w0" "𝔉 (fst x)" "+⇘fst x⇙" "⋅⇘fst x⇙" "𝟬⇘fst x⇙"
                    "𝟭⇘fst x⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism x w0 subset_of_opens by auto
    interpret yw0:ring_homomorphism "ρ (fst y) w0" "𝔉 (fst y)" "+⇘fst y⇙" "⋅⇘fst y⇙" "𝟬⇘fst y⇙"
                    "𝟭⇘fst y⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism y w0 subset_of_opens by auto
    interpret zw0:ring_homomorphism "ρ (fst z) w0" "𝔉 (fst z)" "+⇘fst z⇙" "⋅⇘fst z⇙" "𝟬⇘fst z⇙"
                    "𝟭⇘fst z⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism z w0 subset_of_opens by auto

    have "add_rel (add_rel X Y) Z = w0, +⇘w0((+⇘w0(ρ (fst x) w0 (snd x))
                                (ρ (fst y) w0 (snd y)))) (ρ (fst z) w0 (snd z))"
      unfolding x_alt y_alt z_alt
      using x y z w0 subset_of_opens add_rel_class_of
      by (force simp add: add_rel_class_of)
    also have "... = w0, +⇘w0(ρ (fst x) w0 (snd x))
                              (+⇘w0(ρ (fst y) w0 (snd y)) (ρ (fst z) w0 (snd z)))"
      using x(2) xw0.target.additive.associative y(2) z(2) by force
    also have "... =  add_rel X (add_rel Y Z)"
      unfolding x_alt y_alt z_alt
      using x y z w0 add_rel_class_of subset_of_opens by force
    finally show "add_rel (add_rel X Y) Z = add_rel X (add_rel Y Z)" .

    have "mult_rel (mult_rel X Y) Z = w0, ⋅⇘w0((⋅⇘w0(ρ (fst x) w0 (snd x))
                                (ρ (fst y) w0 (snd y)))) (ρ (fst z) w0 (snd z))"
      unfolding x_alt y_alt z_alt
      using x y z w0 mult_rel_class_of subset_of_opens by force
    also have "... = w0, ⋅⇘w0(ρ (fst x) w0 (snd x))
                              (⋅⇘w0(ρ (fst y) w0 (snd y)) (ρ (fst z) w0 (snd z)))"
      apply (subst xw0.target.multiplicative.associative)
      using w0 x y z by auto
    also have "... =  mult_rel X (mult_rel Y Z)"
      unfolding x_alt y_alt z_alt
      using x y z w0 mult_rel_class_of subset_of_opens by force
    finally show "mult_rel (mult_rel X Y) Z = mult_rel X (mult_rel Y Z)" .

    have "mult_rel X (add_rel Y Z) = w0, ⋅⇘w0(ρ (fst x) w0 (snd x))
                  (+⇘w0(ρ (fst y) w0 (snd y)) (ρ (fst z) w0 (snd z)))"
      unfolding x_alt y_alt z_alt
      using x y z w0 add_rel_class_of mult_rel_class_of subset_of_opens by force
    also have "... = w0, +⇘w0(⋅⇘w0(ρ (fst x) w0 (snd x)) (ρ (fst y) w0 (snd y)))
            (⋅⇘w0(ρ (fst x) w0 (snd x)) (ρ (fst z) w0 (snd z)))"
      apply (subst xw0.target.distributive)
      using w0 x y z by auto
    also have "... = add_rel (mult_rel X Y) (mult_rel X Z)"
      unfolding x_alt y_alt z_alt
      using x y z w0 add_rel_class_of mult_rel_class_of subset_of_opens by force
    finally show "mult_rel X (add_rel Y Z) = add_rel (mult_rel X Y) (mult_rel X Z)" .

    have "mult_rel (add_rel Y Z) X = w0, ⋅⇘w0(+⇘w0(ρ (fst y) w0 (snd y))
                                          (ρ (fst z) w0 (snd z))) (ρ (fst x) w0 (snd x))"
      unfolding x_alt y_alt z_alt
      using x y z w0 add_rel_class_of mult_rel_class_of subset_of_opens by force
    also have "... = w0, +⇘w0(⋅⇘w0(ρ (fst y) w0 (snd y)) (ρ (fst x) w0 (snd x)))
            (⋅⇘w0(ρ (fst z) w0 (snd z)) (ρ (fst x) w0 (snd x)))"
      apply (subst xw0.target.distributive)
      using w0 x y z by auto
    also have "... = add_rel (mult_rel Y X) (mult_rel Z X)"
      unfolding x_alt y_alt z_alt
      using x y z w0 add_rel_class_of mult_rel_class_of subset_of_opens by force
    finally show "mult_rel (add_rel Y Z) X = add_rel (mult_rel Y X) (mult_rel Z X)" .
  qed

  show add_rel_0':"a. a  carrier_direct_lim  add_rel a U, 𝟬⇘U = a"
    using add_rel_0 add_rel_commute zero_rel by force

  interpret Group_Theory.monoid carrier_direct_lim add_rel "U, 𝟬⇘U"
    apply unfold_locales
    by (simp_all add: zero_rel add_rel_carrier add_assoc add_rel_0 add_rel_0')

  show "monoid.invertible carrier_direct_lim add_rel U, 𝟬⇘U X"
    if "X  carrier_direct_lim" for X
  proof -
    define x where "x=(SOME x. x  X)"
    have x:"xX" "xSigma I 𝔉" "fst xI" and X_alt:"X= fst x, snd x"
      using rel_carrier_Eps_in[OF X  carrier_direct_lim]
      unfolding x_def by auto

    obtain w0 where w0: "w0  I" "w0  U" "w0  fst x"
      using has_lower_bound[OF UI fst xI] by blast

    interpret uw0:ring_homomorphism "ρ U w0" "𝔉 U" "+⇘U⇙" "⋅⇘U⇙" "𝟬⇘U⇙" "𝟭⇘U⇙" "𝔉 w0" "+⇘w0⇙"
                    "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism UI w0 subset_of_opens by auto
    interpret xw0:ring_homomorphism "ρ (fst x) w0" "𝔉 (fst x)" "+⇘fst x⇙" "⋅⇘fst x⇙" "𝟬⇘fst x⇙"
                    "𝟭⇘fst x⇙" "𝔉 w0" "+⇘w0⇙" "⋅⇘w0⇙" "𝟬⇘w0⇙" "𝟭⇘w0⇙"
      using is_ring_morphism fst xI w0 subset_of_opens by auto

    define Y where "Y=fst x, xw0.source.additive.inverse (snd x)"

    have "add_rel X Y  = w0, +⇘w0(ρ (fst x) w0 (snd x))
                                  (ρ (fst x) w0 (xw0.source.additive.inverse (snd x)))"
      unfolding X_alt Y_def
    proof (subst add_rel_class_of)
      show "(fst x, xw0.source.additive.inverse (snd x))  Sigma I 𝔉"
        using x(2) xw0.source.additive.invertible xw0.source.additive.invertible_inverse_closed
        by force
    qed (use x w0 in auto)
    also have "... =  w0, 𝟬⇘w0"
      apply (subst xw0.additive.invertible_image_lemma)
      subgoal using x(2) xw0.source.additive.invertible by force
      using x(2) by auto
    also have "... =  U, 𝟬⇘U"
      by (simp add: assms class_of_0_eq w0(1))
    finally have "add_rel X Y = U, 𝟬⇘U" .
    moreover have "Y  carrier_direct_lim"
      using Group_Theory.group_def Y_def carrier_direct_lim_def class_of_def
        monoid.invertible_inverse_closed x(2) xw0.source.additive.group_axioms
        xw0.source.additive.invertible by fastforce
    moreover have "add_rel Y X = U, 𝟬⇘U"
      using Y  carrier_direct_lim add_rel X Y = U, 𝟬⇘U
      by (simp add: add_rel_commute that)
    ultimately show ?thesis
      unfolding invertible_def[OF that] by auto
  qed
qed


(* The canonical function from 𝔉 U into lim 𝔉 for U ∈ I:*)
definition canonical_fun:: "'a set  'b  ('a set × 'b) set"
  where "canonical_fun U x = U, x"


lemma rel_I1:
  assumes "s  𝔉 U" "x  U, s" "U  I"
  shows "(U, s)  x"
proof -
  have Us: "U, s  carrier_direct_lim"
    using assms unfolding carrier_direct_lim_def class_of_def
    by (simp add: equivalence.Class_in_Partition rel_is_equivalence)
  then show ?thesis
    using rel_Class_iff assms
    by (metis carrier_direct_lim_def class_of_def mem_Sigma_iff rel.Block_self rel.Class_self rel.block_closed)
qed

lemma rel_I2:
  assumes "s  𝔉 U" "x  U, s" "U  I"
  shows "(U, s)  (SOME x. x  U, s)"
  using carrier_direct_lim_def class_of_def rel_carrier_Eps_in(2) rel_carrier_Eps_in(3) assms
  by fastforce

lemma carrier_direct_limE:
  assumes "X  carrier_direct_lim"
  obtains U s where "U  I" "s  𝔉 U" "X = U,s"
  using assms carrier_direct_lim_def class_of_def by auto



end (* direct_lim *)

abbreviation "dlim  direct_lim.carrier_direct_lim"


subsubsection ‹Universal property of direct limits›

proposition (in direct_lim) universal_property:
  fixes A:: "'c set" and ψ:: "'a set  ('b  'c)" and add:: "'c  'c  'c"
    and mult:: "'c  'c  'c" and zero:: "'c" and one:: "'c"
  assumes "ring A add mult zero one"
    and r_hom: "U. U  I  ring_homomorphism (ψ U) (𝔉 U) (+⇘U) (⋅⇘U) 𝟬⇘U⇙ 𝟭⇘UA add mult zero one"
    and eq: "U V x. U  I; V  I; V  U; x  (𝔉 U)  (ψ V  ρ U V) x = ψ U x"
  shows "VI. ∃!u. ring_homomorphism u carrier_direct_lim add_rel mult_rel V,𝟬⇘V V,𝟭⇘V A add mult zero one
 (UI. x(𝔉 U). (u  canonical_fun U) x = ψ U x)"
proof
  fix V assume "V  I"
  interpret ring_V: ring carrier_direct_lim add_rel mult_rel "V, 𝟬⇘V" "V, 𝟭⇘V"
    using V  I direct_lim_is_ring by blast
  interpret ring_ψV: ring_homomorphism "ψ V" "𝔉 V" "+⇘V⇙" "⋅⇘V⇙" "𝟬⇘V⇙" "𝟭⇘V⇙" A add mult zero one
    using V  I r_hom by presburger

  define u where "u  λX  carrier_direct_lim. let x = (SOME x. x  X) in ψ (fst x) (snd x)"
    ―‹The proposition below proves that @{term u} is well defined.›
  have ψ_eqI: "ψ x1 x2 = ψ y1 y2" if "(x1,x2)  (y1,y2)"
    for x1 x2 y1 y2
    by (smt (verit, best) Int_subset_iff assms(3) comp_apply fst_conv rel_def snd_conv that)
  have u_eval: "u U,s = ψ U s" if "U  I" "s  𝔉 U" for U s
  proof -
    have Us: "U, s  carrier_direct_lim"
      using that unfolding carrier_direct_lim_def class_of_def
      by (simp add: equivalence.Class_in_Partition rel_is_equivalence)
    with that show ?thesis
      apply (simp add: u_def Let_def)
      by (metis ψ_eqI prod.exhaust_sel rel_I2 rel_carrier_Eps_in(1))
  qed

  have u_PiE: "u  carrier_direct_lim E A"
  proof
    fix X
    assume "X  carrier_direct_lim" then show "u X  A"
      by (metis carrier_direct_limE map.map_closed r_hom ring_homomorphism_def u_eval)
  qed (auto simp: u_def)
  have hom_u: "ring_homomorphism u carrier_direct_lim add_rel mult_rel V, 𝟬⇘V V, 𝟭⇘V
                                     A add mult zero one"
  proof
    have "u (add_rel U,s V,t) = add (u U,s) (u V,t)"
      if "U  I" "V  I" "s  𝔉 U" "t  𝔉 V" for U V s t
    proof -
      obtain W where "W  I" and Wsub: "W  U  V"
        using assms has_lower_bound by (metis U  I V  I)
      interpret ring_ψW: ring_homomorphism "ψ W" "𝔉 W" "+⇘W⇙" "⋅⇘W⇙" "𝟬⇘W⇙" "𝟭⇘W⇙" A add mult zero one
        using W  I r_hom by presburger
      have "u (add_rel U,s V,t) = u (W, +⇘W(ρ U W s) (ρ V W t))"
        using Wsub W  I add_rel_class_of that by force
      also have " = ψ W (+⇘W(ρ U W s) (ρ V W t))"
        by (metis Wsub W  I direct_lim.subset_of_opens direct_lim_axioms is_map_from_is_homomorphism le_infE map.map_closed ring_ψW.source.additive.composition_closed that u_eval)
      also have " = add (ψ W ((ρ U W s))) (ψ W ((ρ V W t)))"
        using that
        by (meson W  I W  U  V inf.bounded_iff is_ring_morphism map.map_closed ring_ψW.additive.commutes_with_composition ring_homomorphism_def subset_of_opens)
      also have " = add (ψ U s) (ψ V t)"
        using W  I W  U  V eq that by force
      also have "... = add (u U,s) (u V,t)"
        by (simp add: that u_eval)
      finally show "u (add_rel U,s V,t) = add (u U,s) (u V,t)" .
    qed
    then show "u (add_rel X Y) = add (u X) (u Y)"
      if "X  carrier_direct_lim" and "Y  carrier_direct_lim" for X Y
      by (metis (no_types, lifting) carrier_direct_limE that)
    show "u V, 𝟬⇘V = zero"
      using V  I ring_ψV.additive.commutes_with_unit ring_ψV.source.additive.unit_closed
        u_eval by presburger
    have "u (mult_rel U,s V,t) = mult (u U,s) (u V,t)"
      if "U  I" "V  I" "s  𝔉 U" "t  𝔉 V" for U V s t
    proof -
      obtain W where "W  I" and Wsub: "W  U  V"
        by (meson U  I V  I has_lower_bound)
      interpret ring_ψW: ring_homomorphism "ψ W" "𝔉 W" "+⇘W⇙" "⋅⇘W⇙" "𝟬⇘W⇙" "𝟭⇘W⇙" A add mult zero one
        using W  I r_hom by presburger
      have "u (mult_rel U,s V,t) = u (W, ⋅⇘W(ρ U W s) (ρ V W t))"
        using Wsub W  I mult_rel_class_of that by force
      also have " = ψ W (⋅⇘W(ρ U W s) (ρ V W t))"
        by (metis Wsub W  I direct_lim.subset_of_opens direct_lim_axioms is_map_from_is_homomorphism
            le_infE map.map_closed ring_ψW.source.multiplicative.composition_closed that u_eval)
      also have " = mult (ψ W ((ρ U W s))) (ψ W ((ρ V W t)))"
        by (meson Wsub W  I inf.boundedE is_ring_morphism map.map_closed ring_ψW.multiplicative.commutes_with_composition ring_homomorphism_def subset_of_opens that)
      also have " = mult (ψ U s) (ψ V t)"
        using Wsub W  I eq that by force
      also have "... = mult (u U,s) (u V,t)"
        using that u_eval by presburger
      finally show "u (mult_rel U,s V,t) = mult (u U,s) (u V,t)" .
    qed
    then show "u (mult_rel X Y) = mult (u X) (u Y)"
      if "X  carrier_direct_lim" and "Y  carrier_direct_lim" for X Y
      by (metis (no_types, lifting) carrier_direct_limE that)
    show "u (V, 𝟭⇘V) = one"
      by (simp add: V  I ring_ψV.multiplicative.commutes_with_unit u_eval)
  qed (simp add: u_PiE)
  show "∃!u. ring_homomorphism u carrier_direct_lim add_rel mult_rel V, 𝟬⇘V V, 𝟭⇘V
                                      A add mult zero one 
                  (UI. x𝔉 U. (u  canonical_fun U) x = ψ U x)"
  proof
    show "ring_homomorphism u carrier_direct_lim add_rel mult_rel V, 𝟬⇘V V, 𝟭⇘V A add mult zero one  (UI. x𝔉 U. (u  canonical_fun U) x = ψ U x)"
      by (simp add: canonical_fun_def hom_u u_eval)
    fix v
    assume v: "ring_homomorphism v carrier_direct_lim add_rel mult_rel V, 𝟬⇘V V, 𝟭⇘V A add mult zero one  (UI. x𝔉 U. (v  canonical_fun U) x = ψ U x)"
    have "u X = v X" if "X  carrier_direct_lim" for X
      by (metis v canonical_fun_def carrier_direct_limE comp_apply that u_eval)
    moreover have "v  carrier_direct_lim E A"
      by (metis v Set_Theory.map_def ring_homomorphism_def)
    ultimately show "v = u"
      using PiE_ext u_PiE by blast
  qed
qed


subsection ‹Locally Ringed Spaces›

subsubsection ‹Stalks of a Presheaf›

locale stalk = direct_lim +
  fixes x:: "'a"
  assumes is_elem: "x  S" and index: "I = {U. is_open U  x  U}"
begin

(* definition 0.37 *)
definition carrier_stalk:: "('a set × 'b) set set"
  where "carrier_stalk  dlim 𝔉 ρ (neighborhoods x)"

lemma neighborhoods_eq:"neighborhoods x = I"
  unfolding index neighborhoods_def by simp

definition add_stalk:: "('a set × 'b) set  ('a set × 'b) set  ('a set × 'b) set"
  where "add_stalk  add_rel"

definition mult_stalk:: "('a set × 'b) set  ('a set × 'b) set  ('a set × 'b) set"
  where "mult_stalk  mult_rel"

definition zero_stalk:: "'a set  ('a set × 'b) set"
  where "zero_stalk V  class_of V 𝟬⇘V⇙"

definition one_stalk:: "'a set  ('a set × 'b) set"
  where "one_stalk V  class_of V 𝟭⇘V⇙"

lemma class_of_in_stalk:
  assumes "A  (neighborhoods x)" and "z  𝔉 A"
  shows "class_of A z  carrier_stalk"
proof -
  interpret equivalence "Sigma I 𝔉" "{(x, y). x  y}"
    using rel_is_equivalence by blast
  show ?thesis
    using assms unfolding carrier_stalk_def neighborhoods_def
    by (metis (no_types, lifting) carrier_direct_lim_def class_of_def index mem_Sigma_iff natural.map_closed)
qed

lemma stalk_is_ring:
  assumes "is_open V" and "x  V"
  shows "ring carrier_stalk add_stalk mult_stalk (zero_stalk V) (one_stalk V)"
proof -
  interpret r: ring carrier_direct_lim add_rel mult_rel "V, 𝟬⇘V" "V, 𝟭⇘V"
    using assms direct_lim_is_ring index by blast
  show ?thesis
    using r.additive.monoid_axioms
    unfolding zero_stalk_def one_stalk_def add_stalk_def mult_stalk_def carrier_stalk_def
    using index neighborhoods_def r.ring_axioms by metis
qed


lemma in_zero_stalk [simp]:
  assumes "V  I"
  shows "(V, zero_str V)  zero_stalk V"
  by (simp add: assms zero_stalk_def class_of_def class_of_0_in equivalence.Class_self rel_is_equivalence)

lemma in_one_stalk [simp]:
  assumes "V  I"
  shows "(V, one_str V)  one_stalk V"
  by (simp add: assms one_stalk_def class_of_def class_of_1_in equivalence.Class_self rel_is_equivalence)

lemma universal_property_for_stalk:
  fixes A:: "'c set" and ψ:: "'a set  ('b  'c)"
  assumes ringA: "ring A add mult zero one"
    and hom: "U. U  neighborhoods x  ring_homomorphism (ψ U) (𝔉 U) (+⇘U) (⋅⇘U) 𝟬⇘U⇙ 𝟭⇘UA add mult zero one"
    and eq: "U V s. U  neighborhoods x; V  neighborhoods x; VU; s  𝔉 U  (ψ V  ρ U V) s = ψ U s"
  shows "V(neighborhoods x). ∃!u. ring_homomorphism u
carrier_stalk add_stalk mult_stalk (zero_stalk V) (one_stalk V) A add mult zero one
 (U(neighborhoods x). s(𝔉 U). (u  canonical_fun U) s = ψ U s)"
proof -
  note neighborhoods_eq [simp]
  have "VI. ∃!u. ring_homomorphism u carrier_direct_lim add_rel mult_rel
                      V, 𝟬⇘V V, 𝟭⇘V A add mult zero one 
                          (UI. x𝔉 U. (u  canonical_fun U) x = ψ U x)"
    apply (rule universal_property[OF ringA hom])
    using eq by simp_all
  then show ?thesis
    unfolding carrier_stalk_def add_stalk_def mult_stalk_def zero_stalk_def one_stalk_def
    by simp
qed

end (* stalk *)

sublocale stalk  direct_lim by (simp add: direct_lim_axioms)


subsubsection ‹Maximal Ideals›

(* definition 0.38 *)
locale max_ideal = comm_ring R "(+)" "(⋅)" "𝟬" "𝟭" + ideal I  R "(+)" "(⋅)" "𝟬" "𝟭"
  for R and I and addition (infixl "+" 65) and multiplication (infixl "" 70) and zero ("𝟬") and
unit ("𝟭") +
assumes neq_ring: "I  R" and is_max: "𝔞. ideal 𝔞 R (+) (⋅) 𝟬 𝟭  𝔞  R  I  𝔞  I = 𝔞"
begin

lemma psubset_ring: "I  R"
  using neq_ring by blast

lemma
  shows "¬ (𝔞. ideal 𝔞 R (+) (⋅) 𝟬 𝟭  𝔞  R  I  𝔞)"
  using is_max by blast

text ‹A maximal ideal is prime›
proposition is_pr_ideal: "pr_ideal R I (+) (⋅) 𝟬 𝟭"
proof
  show "I  R"
    using neq_ring by fastforce
  fix x y
  assume "x  R" "y  R" and dot: "x  y  I"
  then show "x  I  y  I"
  proof-
    have "False" if "x  I" "y  I"
    proof-
      define J where "J  {i + r  x |i r. i  I  r  R}"
      have "J  R"
        using x  R by (auto simp: J_def)
      have "x  J"
        apply (simp add: J_def)
        by (metis x  R additive.left_unit additive.sub_unit_closed multiplicative.left_unit multiplicative.unit_closed)
      interpret monJ: monoid J "(+)" 𝟬
      proof
        have "𝟬 = 𝟬 + 𝟬  x"
          by (simp add: x  R)
        then show "𝟬  J"
          by (auto simp: J_def)
      next
        fix a b
        assume "a  J" and "b  J"
        then obtain ia ra ib rb where a: "a = ia + ra  x" "ia  I" "ra  R"
                                  and b: "b = ib + rb  x" "ib  I" "rb  R"
          by (auto simp: J_def)
        then have "ia + ra  x + (ib + rb  x) = ia + ib + (ra + rb)  x"
          by (smt (verit, del_insts) x  R additive.associative additive.commutative additive.composition_closed additive.submonoid_axioms distributive(2) multiplicative.composition_closed submonoid.sub)
        with a b show "a + b  J"
          by (auto simp add: J_def)
      next
        fix a b c
        assume "a  J" and "b  J" and "c  J"
        then show "a + b + c = a + (b + c)"
          by (meson J  R additive.associative subsetD)
      next
        fix a
        assume "a  J"
        then show "𝟬 + a = a" "a + 𝟬 = a"
          using J  R additive.left_unit additive.right_unit by blast+
      qed
      interpret idJ: ideal J R "(+)" "(⋅)" 𝟬 𝟭
      proof
        fix u
        assume "u  J"
        then obtain i r where "u = i + r  x" "i  I" "r  R"
          by (auto simp: J_def)
        then have "-u = -i + (-r)  x"
          by (simp add: x  R additive.commutative additive.inverse_composition_commute local.left_minus)
        with i  I r  R have "-u  J"
          by (auto simp: J_def)
        with u  J show "monoid.invertible J (+) 𝟬 u"
          using  monoid.invertibleI [where v = "-u"]
          by (simp add: u  J monJ.monoid_axioms i  I r  R u = i + r  x x  R)
      next
        fix a b
        assume "a  R" and "b  J"
        then obtain i r where ir: "b = i + r  x" "i  I" "r  R"
          by (auto simp: J_def)
        then have "a  (i + r  x) = a  i + a  r  x"
          by (simp add: a  R x  R distributive(1) multiplicative.associative)
        then show "a  b  J"
          using a  R ideal(1) ir by (force simp add: J_def)
        have "b  a = i  a + r  a  x"
          by (simp add: a  R x  R comm_mult distributive(1) ir mult_left_assoc)
        then show "b  a  J"
          by (metis J  R a  b  J a  R b  J comm_mult subsetD)
      qed (auto simp: J  R)
      have "I  J"
      proof
        show "I  J"
          unfolding J_def
          apply clarify
          by (metis x  R additive.sub.right_unit additive.unit_closed left_zero)
        show "I  J"
          using x  J x  I by blast
      qed
      hence "J = R"
        using idJ.ideal_axioms is_max by auto
      hence "𝟭  J"
        by fastforce
      then obtain a r where "a  I" "r  R" "𝟭 = a + rx"
          unfolding J_def by blast
      then have "y = (a + rx)  y"
        using y  R multiplicative.left_unit by presburger
      also have " = a  y + rxy"
        by (simp add: a  I r  R x  R y  R distributive(2))
      also have "  I"
        by (simp add: a  I r  R x  R y  R dot ideal multiplicative.associative)
      finally have "y  I" .
      thus ?thesis using that(2) by auto
    qed
    thus ?thesis by auto
  qed
qed

end (* locale max_ideal *)


subsubsection ‹Maximal Left Ideals›

locale lideal = subgroup_of_additive_group_of_ring +
  assumes lideal: " r  R; a  I   r  a  I"

begin

lemma subset: "I  R"
  by blast

lemma has_one_imp_equal:
  assumes "𝟭  I"
  shows "I = R"
  by (metis assms lideal subset multiplicative.right_unit subsetI subset_antisym)

end

lemma (in comm_ring) ideal_iff_lideal:
  "ideal I R (+) (⋅) 𝟬 𝟭  lideal I R (+) (⋅) 𝟬 𝟭" (is "?lhs = ?rhs")
proof
  assume ?lhs
  then interpret I: ideal I R "(+)" "(⋅)" 𝟬 𝟭 .
  show ?rhs
  proof qed (use I.ideal in presburger)
next
  assume ?rhs
  then interpret I: lideal I R "(+)" "(⋅)" 𝟬 𝟭 .
  show ?lhs
  proof
    fix r a
    assume "r  R" "a  I"
    then show "r  a  I"
      using I.lideal by blast
    then show "a  r  I"
      by (simp add: a  I r  R comm_mult)
  qed
qed


locale max_lideal = lideal +
  assumes neq_ring: "I  R" and is_max: "𝔞. lideal 𝔞 R (+) (⋅) 𝟬 𝟭  𝔞  R  I  𝔞  I = 𝔞"

(**WHY ARE THE ARGUMENT ORDERS OF max_ideal vs max_lideal INCONSISTENT?**)
lemma (in comm_ring) max_ideal_iff_max_lideal:
  "max_ideal R I (+) (⋅) 𝟬 𝟭  max_lideal I R (+) (⋅) 𝟬 𝟭" (is "?lhs = ?rhs")
proof
  assume ?lhs
  then interpret I: max_ideal R I "(+)" "(⋅)" 𝟬 𝟭 .
  show ?rhs
  proof intro_locales
    show "lideal_axioms I R (⋅)"
      by (simp add: I.ideal(1) lideal_axioms.intro)
    show "max_lideal_axioms I R (+) (⋅) 𝟬 𝟭"
      by (simp add: I.is_max I.neq_ring ideal_iff_lideal max_lideal_axioms.intro)
  qed
next
  assume ?rhs
  then interpret I: max_lideal I R "(+)" "(⋅)" 𝟬 𝟭 .
  show ?lhs
  proof intro_locales
    show "ideal_axioms I R (⋅)"
      by (meson I.lideal_axioms ideal_def ideal_iff_lideal)
    show "max_ideal_axioms R I (+) (⋅) 𝟬 𝟭"
      by (meson I.is_max I.neq_ring ideal_iff_lideal max_ideal_axioms.intro)
  qed
qed

subsubsection ‹Local Rings›

(* definition 0.39 *)
locale local_ring = ring +
  assumes is_unique: "I J. max_lideal I R (+) (⋅) 𝟬 𝟭  max_lideal J R (+) (⋅) 𝟬 𝟭  I = J"
    and has_max_lideal: "𝔴. max_lideal 𝔴 R (+) (⋅) 𝟬 𝟭"

(*Can this be proved from the analogous result for left, right ideals?*)
lemma im_of_ideal_is_ideal:
  assumes I: "ideal I A addA multA zeroA oneA"
    and f: "ring_epimorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "ideal (f ` I) B addB multB zeroB oneB"
proof -
  interpret IA: ideal I A addA multA zeroA oneA
    using I by blast
  interpret fepi: ring_epimorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using f by force
  show ?thesis
  proof intro_locales
    show sma: "submonoid_axioms (f ` I) B addB zeroB"
    proof
      show "f ` I  B"
        by blast
      have "zeroA  I"
        by simp
      then show "zeroB  f ` I"
        using fepi.additive.commutes_with_unit by blast
    next
      fix b1 b2
      assume "b1  f ` I" and "b2  f ` I"
      then show "addB b1 b2  f ` I"
        unfolding image_iff
        by (metis IA.additive.sub IA.additive.sub_composition_closed fepi.additive.commutes_with_composition)
    qed
    show "Group_Theory.monoid (f ` I) addB zeroB"
    proof
      fix a b
      assume "a  f ` I" "b  f ` I"
      then show "addB a b  f ` I"
        by (meson sma submonoid_axioms_def)
    next
      show "zeroB  f ` I"
        using fepi.additive.commutes_with_unit by blast
    qed auto
    show "Group_Theory.group_axioms (f ` I) addB zeroB"
    proof
      fix b
      assume "b  f ` I"
      then obtain i where "b = f i" "i  I"
        by blast
      then obtain j where "addA i j = zeroA" "j  I"
        using IA.additive.sub.invertible_right_inverse by blast
      then show "monoid.invertible (f ` I) addB zeroB b"
        by (metis IA.additive.commutative IA.additive.sub Group_Theory.monoid (f ` I) addB zeroB b = f i i  I fepi.additive.commutes_with_composition fepi.additive.commutes_with_unit image_eqI monoid.invertibleI)
    qed
    show "ideal_axioms (f ` I) B multB"
    proof
      fix b fi
      assume "b  B" and "fi  f ` I"
      then obtain i where i: "fi = f i" "i  I"
        by blast
      obtain a where a: "a  A" "f a = b"
        using b  B fepi.surjective by blast
      then show "multB b fi  f ` I"
        by (metis IA.additive.submonoid_axioms IA.ideal(1) fi = f i i  I fepi.multiplicative.commutes_with_composition image_iff submonoid.sub)
      then show "multB fi b  f ` I"
        by (metis IA.additive.sub IA.ideal(2) a i fepi.multiplicative.commutes_with_composition imageI)
    qed
  qed
qed

lemma im_of_lideal_is_lideal:
  assumes I: "lideal I A addA multA zeroA oneA"
    and f: "ring_epimorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "lideal (f ` I) B addB multB zeroB oneB"
proof -
  interpret IA: lideal I A addA multA zeroA oneA
    using I by blast
  interpret fepi: ring_epimorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using f by force
  show ?thesis
  proof intro_locales
    show sma: "submonoid_axioms (f ` I) B addB zeroB"
    proof
      show "f ` I  B"
        by blast
      have "zeroA  I"
        by simp
      then show "zeroB  f ` I"
        using fepi.additive.commutes_with_unit by blast
    next
      fix b1 b2
      assume "b1  f ` I" and "b2  f ` I"
      then show "addB b1 b2  f ` I"
        unfolding image_iff
        by (metis IA.additive.sub IA.additive.sub_composition_closed fepi.additive.commutes_with_composition)
    qed
    show "Group_Theory.monoid (f ` I) addB zeroB"
    proof
      fix a b
      assume "a  f ` I" "b  f ` I"
      then show "addB a b  f ` I"
        by (meson sma submonoid_axioms_def)
    next
      show "zeroB  f ` I"
        using fepi.additive.commutes_with_unit by blast
    qed auto
    show "Group_Theory.group_axioms (f ` I) addB zeroB"
    proof
      fix b
      assume "b  f ` I"
      then obtain i where "b = f i" "i  I"
        by blast
      then obtain j where "addA i j = zeroA" "j  I"
        using IA.additive.sub.invertible_right_inverse by blast
      then show "monoid.invertible (f ` I) addB zeroB b"
        by (metis IA.additive.commutative IA.additive.sub Group_Theory.monoid (f ` I) addB zeroB b = f i i  I fepi.additive.commutes_with_composition fepi.additive.commutes_with_unit image_eqI monoid.invertibleI)
    qed
    show "lideal_axioms (f ` I) B multB"
    proof
      fix b fi
      assume "b  B" and "fi  f ` I"
      then obtain i where i: "fi = f i" "i  I"
        by blast
      obtain a where a: "a  A" "f a = b"
        using b  B fepi.surjective by blast
      then show "multB b fi  f ` I"
        by (metis IA.additive.submonoid_axioms IA.lideal(1) fi = f i i  I fepi.multiplicative.commutes_with_composition image_iff submonoid.sub)
    qed
  qed
qed


lemma im_of_max_lideal_is_max:
  assumes I: "max_lideal I A addA multA zeroA oneA"
    and f: "ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "max_lideal (f ` I) B addB multB zeroB oneB"
proof -
  interpret maxI: max_lideal I A addA multA zeroA oneA
    using I by blast
  interpret fiso: ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using f by force
  interpret fIB: lideal "f ` I" B addB multB zeroB oneB
  proof intro_locales
    show "submonoid_axioms (f ` I) B addB zeroB"
    proof
      show "addB a b  f ` I"
        if "a  f ` I" "b  f ` I" for a b
        using that
        by (clarsimp simp: image_iff) (metis fiso.additive.commutes_with_composition maxI.additive.sub maxI.additive.sub_composition_closed)
    qed (use fiso.additive.commutes_with_unit in auto)
    then show "Group_Theory.monoid (f ` I) addB zeroB"
      using fiso.target.additive.monoid_axioms
      unfolding submonoid_axioms_def monoid_def
      by (meson subsetD)
    then show "Group_Theory.group_axioms (f ` I) addB zeroB"
      apply (clarsimp simp:  Group_Theory.group_axioms_def image_iff monoid.invertible_def)
      by (metis fiso.additive.commutes_with_composition fiso.additive.commutes_with_unit maxI.additive.sub maxI.additive.sub.invertible maxI.additive.sub.invertible_def)
    have "r x. r  B; x  I  xaI. multB r (f x) = f xa"
      by (metis (no_types, lifting) fiso.multiplicative.commutes_with_composition fiso.surjective image_iff maxI.additive.sub maxI.lideal)
  then show "lideal_axioms (f ` I) B multB"
    by (force intro!: lideal_axioms.intro)
  qed
  show ?thesis
  proof unfold_locales
    show "f ` I  B"
      using maxI.neq_ring fiso.bijective maxI.additive.submonoid_axioms
      unfolding submonoid_axioms_def submonoid_def
      by (metis bij_betw_imp_inj_on fiso.surjective inj_on_image_eq_iff subset_iff)
  next
    fix J
    assume "lideal J B addB multB zeroB oneB" and "J  B" and fim: "f ` I  J"
    then interpret JB: lideal J B addB multB zeroB oneB
      by blast
    have §: "lideal (f ¯ A J) A addA multA zeroA oneA"
    proof intro_locales
      show sma: "submonoid_axioms (f ¯ A J) A addA zeroA"
      proof
        show "addA a b  f ¯ A J" if "a  f ¯ A J" and "b  f ¯ A J" for a b
          using that
          apply clarsimp
          using JB.additive.sub_composition_closed fiso.additive.commutes_with_composition by presburger
      qed blast+
      show "Group_Theory.monoid (f ¯ A J) addA zeroA"
        by (smt (verit, ccfv_threshold) Group_Theory.monoid.intro IntD2 sma maxI.additive.associative maxI.additive.left_unit maxI.additive.right_unit submonoid_axioms_def)
      show "Group_Theory.group_axioms (f ¯ A J) addA zeroA"
      proof
        fix x
        assume "x  f ¯ A J"
        then show "monoid.invertible (f ¯ A J) addA zeroA x"
          apply clarify
          by (smt (verit, best) JB.additive.sub.invertible JB.additive.submonoid_inverse_closed IntI Group_Theory.monoid (f ¯ A J) addA zeroA fiso.additive.invertible_commutes_with_inverse maxI.additive.inverse_equality maxI.additive.invertible maxI.additive.invertibleE monoid.invertible_def vimageI)
      qed
      show "lideal_axioms (f ¯ A J) A multA"
      proof
        fix a j
        assume §: "a  A" "j  f ¯ A J"
        then show "multA a j  f ¯ A J"
          using JB.lideal(1) fiso.map_closed fiso.multiplicative.commutes_with_composition
          by simp
      qed
    qed
    have "I = f ¯ A J"
    proof (rule maxI.is_max [OF §])
      show "f ¯ A J  A"
        using JB.additive.sub J  B fiso.surjective by blast
      show "I  f ¯ A J"
        by (meson fim image_subset_iff_subset_vimage inf_greatest maxI.additive.sub subset_iff)
    qed
    then have "J  f ` I"
      using JB.additive.sub fiso.surjective by blast
    with fim show "f ` I = J" ..
  qed
qed

lemma im_of_max_ideal_is_max:
  assumes I: "max_ideal A I addA multA zeroA oneA"
    and f: "ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "max_ideal B (f ` I) addB multB zeroB oneB"
proof -
  interpret maxI: max_ideal A I addA multA zeroA oneA
    using I by blast
  interpret fiso: ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using f by force
  interpret fIB: ideal "f ` I" B addB multB zeroB oneB
    using maxI.ideal_axioms fiso.ring_homomorphism_axioms
    by (meson fiso.ring_epimorphism_axioms im_of_ideal_is_ideal)
  show ?thesis
  proof intro_locales
    show "comm_ring_axioms B multB"
    proof
      fix b1 b2
      assume "b1  B" and "b2  B"
      then obtain a1 a2 where a1: "a1  A" "f a1 = b1" and a2: "a2  A" "f a2 = b2"
        using fiso.surjective by blast
      then have "multA a1 a2 = multA a2 a1"
        using maxI.comm_mult by presburger
      then show "multB b1 b2 = multB b2 b1"
        by (metis a1 a2 fiso.multiplicative.commutes_with_composition)
    qed
    show "max_ideal_axioms B (f ` I) addB multB zeroB oneB"
    proof
      obtain i where "i  A" "i  I"
        using maxI.neq_ring by blast
      then have "f i  f ` I"
        unfolding image_iff
        by (metis fiso.injective inj_on_def maxI.additive.sub)
      then show "f ` I  B"
        using i  A fiso.map_closed by blast
    next
      fix J
      assume "ideal J B addB multB zeroB oneB" and "J  B" and fim: "f ` I  J"
      then interpret JB: ideal J B addB multB zeroB oneB
        by blast
      have §: "ideal (f ¯ A J) A addA multA zeroA oneA"
      proof intro_locales
        show sma: "submonoid_axioms (f ¯ A J) A addA zeroA"
        proof
          show "addA a b  f ¯ A J" if "a  f ¯ A J" and "b  f ¯ A J" for a b
            using that
            apply clarsimp
            using JB.additive.sub_composition_closed fiso.additive.commutes_with_composition by presburger
        qed blast+
        show "Group_Theory.monoid (f ¯ A J) addA zeroA"
          by (smt (verit, ccfv_threshold) Group_Theory.monoid.intro IntD2 sma maxI.additive.associative maxI.additive.left_unit maxI.additive.right_unit submonoid_axioms_def)
        show "Group_Theory.group_axioms (f ¯ A J) addA zeroA"
        proof
          fix x
          assume "x  f ¯ A J"
          then show "monoid.invertible (f ¯ A J) addA zeroA x"
            apply clarify
            by (smt (verit, best) JB.additive.sub.invertible JB.additive.submonoid_inverse_closed IntI Group_Theory.monoid (f ¯ A J) addA zeroA fiso.additive.invertible_commutes_with_inverse maxI.additive.inverse_equality maxI.additive.invertible maxI.additive.invertibleE monoid.invertible_def vimageI)
        qed
        show "ideal_axioms (f ¯ A J) A multA"
        proof
          fix a j
          assume §: "a  A" "j  f ¯ A J"
          then show "multA a j  f ¯ A J"
            using JB.ideal(1) fiso.map_closed fiso.multiplicative.commutes_with_composition
            by simp
          then show "multA j a  f ¯ A J"
            by (metis Int_iff § maxI.comm_mult)
        qed
      qed
      have "I = f ¯ A J"
        by (metis "§" JB.additive.sub J  B fim fiso.surjective image_subset_iff_subset_vimage
            le_inf_iff maxI.is_max maxI.psubset_ring psubsetE subsetI subset_antisym)
      then show "f ` I = J"
        using JB.additive.sub fiso.surjective
        by blast
    qed
  qed
qed


lemma preim_of_ideal_is_ideal:
  fixes f :: "'a'b"
  assumes J: "ideal J B addB multB zeroB oneB"
    and "ring_homomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "ideal (f¯ A J) A addA multA zeroA oneA"
proof -
  interpret JB: ideal J B addB multB zeroB oneB
    using J by blast
  interpret f: ring_homomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using assms by force
  interpret preB: ring "f ¯ A B" addA multA zeroA oneA
    using f.ring_preimage by blast
  show ?thesis
  proof intro_locales
    show "submonoid_axioms (f ¯ A J) A addA zeroA"
      by (auto simp add: submonoid_axioms_def f.additive.commutes_with_composition f.additive.commutes_with_unit)
    then show grp_fAJ: "Group_Theory.monoid (f ¯ A J) addA zeroA"
      by (auto simp: submonoid_axioms_def Group_Theory.monoid_def)
    show "Group_Theory.group_axioms (f ¯ A J) addA zeroA"
      unfolding group_def
    proof
      fix x
      assume x: "x  f ¯ A J"
      then have "f x  J" "x  A"
        by auto
      then obtain v where "f v  J  v  A  addA x v = zeroA"
        by (metis JB.additive.sub.invertible JB.additive.submonoid_inverse_closed f.additive.invertible_commutes_with_inverse
              f.source.additive.invertible f.source.additive.invertible_inverse_closed f.source.additive.invertible_right_inverse)
      then show "monoid.invertible (f ¯ A J) addA zeroA x"
        by (metis Int_iff f.source.additive.commutative grp_fAJ monoid.invertibleI vimageI x)
    qed
    show "ideal_axioms (f ¯ A J) A multA"
    proof
      fix a j
      assume §: "a  A" "j  f ¯ A J"
      then show "multA j a  f ¯ A J" "multA a j  f ¯ A J"
        using JB.ideal f.map_closed f.multiplicative.commutes_with_composition by force+
    qed
  qed
qed

lemma preim_of_max_ideal_is_max:
  fixes f:: "'a  'b"
  assumes J: "max_ideal B J addB multB zeroB oneB"
    and f: "ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "max_ideal A (f¯ A J) addA multA zeroA oneA"
proof -
  interpret maxJ: max_ideal B J addB multB zeroB oneB
    using J by blast
  interpret fiso: ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using f by force
  interpret fAJ: ideal "f¯ A J" A addA multA zeroA oneA
    using maxJ.ideal_axioms fiso.ring_homomorphism_axioms by (blast intro: preim_of_ideal_is_ideal)
  show ?thesis
  proof intro_locales
    show "comm_ring_axioms A multA"
    proof
      fix a b
      assume "a  A" and "b  A"
      then have "multB (f a) (f b) = multB (f b) (f a)"
        using fiso.map_closed maxJ.comm_mult by presburger
      then show "multA a b = multA b a"
        by (metis bij_betw_iff_bijections a  A b  A fiso.bijective fiso.multiplicative.commutes_with_composition fiso.source.multiplicative.composition_closed)
    qed
    show "max_ideal_axioms A (f ¯ A J) addA multA zeroA oneA"
    proof
      show "f ¯ A J  A"
        using fiso.surjective maxJ.additive.sub maxJ.neq_ring by blast
      fix I
      assume "ideal I A addA multA zeroA oneA"
        and "I  A" and "f ¯ A J  I"
      then interpret IA: ideal I A addA multA zeroA oneA
        by blast
      have mon_fI: "Group_Theory.monoid (f ` I) addB zeroB"
      proof
        fix a b
        assume "a  f ` I" "b  f ` I"
        then show "addB a b  f ` I"
          unfolding image_iff
          by (metis IA.additive.sub IA.additive.sub_composition_closed fiso.additive.commutes_with_composition)
      next
        show "zeroB  f ` I"
          using fiso.additive.commutes_with_unit by blast
      qed blast+
      have ideal_fI: "ideal (f ` I) B addB multB zeroB oneB"
      proof
        show "f ` I  B"
          by blast
        show "zeroB  f ` I"
          using fiso.additive.commutes_with_unit by blast
      next
        fix a b
        assume "a  f ` I" and "b  f ` I"
        then show "addB a b  f ` I"
          unfolding image_iff
          by (metis IA.additive.sub IA.additive.sub_composition_closed fiso.additive.commutes_with_composition)
      next
        fix b
        assume "b  f ` I"
        then obtain i where i: "b = f i" "i  I"
          by blast
        then obtain j where "addA i j = zeroA" "j  I"
          by (meson IA.additive.sub.invertible IA.additive.sub.invertibleE)
        then have "addB b (f j) = zeroB"
          by (metis IA.additive.sub i fiso.additive.commutes_with_composition fiso.additive.commutes_with_unit)
        then show "monoid.invertible (f ` I) addB zeroB b"
          by (metis IA.additive.sub i j  I fiso.map_closed imageI maxJ.additive.commutative mon_fI monoid.invertibleI)
      next
        fix a b
        assume "a  B" and "b  f ` I"
        with IA.ideal show "multB a b  f ` I" "multB b a  f ` I"
          by (smt (verit, best) IA.additive.sub fiso.multiplicative.commutes_with_composition fiso.surjective image_iff)+
      qed blast+
      have "J = f ` I"
      proof (rule maxJ.is_max [OF ideal_fI])
        show "f ` I  B"
          by (metis IA.additive.sub I  A fiso.injective fiso.surjective inj_on_image_eq_iff subsetI)
        show "J  f ` I"
          unfolding image_def
          apply clarify
          by (smt (verit, ccfv_threshold) Int_iff f ¯ A J  I fiso.surjective imageE maxJ.additive.sub subset_eq vimageI)
      qed
      then show "f ¯ A J = I"
        using f ¯ A J  I by blast
    qed
  qed
qed

lemma preim_of_lideal_is_lideal:
  assumes "lideal I B addB multB zeroB oneB"
    and "ring_homomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "lideal (f ¯ A I) (f ¯ A B) addA multA zeroA oneA"
proof -
  interpret A: ring A addA multA zeroA oneA
    by (meson assms ring_homomorphism_def)
  interpret B: ring B addB multB zeroB oneB
    by (meson assms ring_homomorphism_def)
  interpret f: ring_homomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using assms by blast
  interpret preB: ring "f ¯ A B" addA multA zeroA oneA
    using f.ring_preimage by blast
  interpret IB: lideal I B addB multB zeroB oneB
    by (simp add: assms)
  show ?thesis
  proof intro_locales
    show "submonoid_axioms (f ¯ A I) (f ¯ A B) addA zeroA"
      by (auto simp add: submonoid_axioms_def f.additive.commutes_with_composition f.additive.commutes_with_unit)
    have "(A.additive.inverse u)  f ¯ A I" if "f u  I" and "u  A" for u
    proof -
      have "f (A.additive.inverse u) = B.additive.inverse (f u)"
        using A.additive.invertible f.additive.invertible_commutes_with_inverse that by presburger
      then show ?thesis
        using A.additive.invertible_inverse_closed that by blast
    qed
    moreover have "addA (A.additive.inverse u) u = zeroA"  "addA u (A.additive.inverse u) = zeroA" if "u  A" for u
      by (auto simp add: that)
    moreover
    show "Group_Theory.monoid (f ¯ A I) addA zeroA"
      by (auto simp: monoid_def f.additive.commutes_with_composition f.additive.commutes_with_unit)
    ultimately show "Group_Theory.group_axioms (f ¯ A I) addA zeroA"
      unfolding group_axioms_def by (metis IntE monoid.invertibleI vimage_eq)
    show "lideal_axioms (f ¯ A I) (f ¯ A B) multA"
      unfolding lideal_axioms_def
      using IB.lideal f.map_closed f.multiplicative.commutes_with_composition by force
  qed
qed

lemma preim_of_max_lideal_is_max:
  assumes "max_lideal I B addB multB zeroB oneB"
      and "ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "max_lideal (f ¯ A I) (f ¯ A B) addA multA zeroA oneA"
proof -
  interpret f: ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    using assms by blast
  interpret MI: max_lideal I B addB multB zeroB oneB
    by (simp add: assms)
  interpret pre: lideal "f ¯ A I" "f ¯ A B" addA multA zeroA oneA
    by (meson preim_of_lideal_is_lideal MI.lideal_axioms f.ring_homomorphism_axioms)
  show ?thesis
  proof intro_locales
    show "max_lideal_axioms (f ¯ A I) (f ¯ A B) addA multA zeroA oneA"
    proof
      show "f ¯ A I  f ¯ A B"
        using MI.neq_ring MI.subset f.surjective by blast
      fix 𝔞
      assume "lideal 𝔞 (f ¯ A B) addA multA zeroA oneA"
        and "𝔞  f ¯ A B"
        and "f ¯ A I  𝔞"
      then interpret lideal 𝔞 "f ¯ A B" addA multA zeroA oneA
        by metis
      have "f ` 𝔞  B"
        by (metis Int_absorb1 𝔞  f ¯ A B f.injective f.surjective image_subset_iff_subset_vimage inj_on_image_eq_iff subset subset_iff)
      moreover have "I  f ` 𝔞"
        by (smt (verit, ccfv_threshold) Int_iff MI.subset f ¯ A I  𝔞 f.surjective image_iff subset_iff vimageI)
      moreover have "lideal (f ` 𝔞) B addB multB zeroB oneB"
        by (metis f.multiplicative.image.subset f.ring_epimorphism_axioms im_of_lideal_is_lideal image_subset_iff_subset_vimage inf.orderE inf_sup_aci(1) lideal_axioms)
      ultimately show "f ¯ A I = 𝔞"
        by (metis MI.is_max f ¯ A I  𝔞 image_subset_iff_subset_vimage le_inf_iff subset subset_antisym)
    qed
  qed
qed

lemma isomorphic_to_local_is_local:
  assumes lring: "local_ring B addB multB zeroB oneB"
    and iso: "ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "local_ring A addA multA zeroA oneA"
proof intro_locales
  interpret ring A addA multA zeroA oneA
    by (meson iso ring_homomorphism.axioms(2) ring_isomorphism.axioms(1))

  show "Group_Theory.monoid A addA zeroA"
    by (simp add: additive.monoid_axioms)
  show "Group_Theory.group_axioms A addA zeroA"
    by (meson Group_Theory.group_def additive.group_axioms)
  show "commutative_monoid_axioms A addA"
    by (simp add: additive.commutative commutative_monoid_axioms_def)
  show "Group_Theory.monoid A multA oneA"
    by (simp add: multiplicative.monoid_axioms)
  show "ring_axioms A addA multA"
    by (meson local.ring_axioms ring.axioms(3))
  have hom: "monoid_homomorphism f A multA oneA B multB oneB"
    by (meson iso ring_homomorphism_def ring_isomorphism.axioms(1))
  have "bij_betw f A B"
    using iso map.graph
    by (simp add: bijective.bijective ring_isomorphism_def bijective_map_def)
  show "local_ring_axioms A addA multA zeroA oneA"
  proof
    fix I J
    assume I: "max_lideal I A addA multA zeroA oneA" and J: "max_lideal J A addA multA zeroA oneA"
    show "I = J"
    proof-
      have "max_lideal (f ` I) B addB multB zeroB oneB"
        by (meson I im_of_max_lideal_is_max iso)
      moreover have "max_lideal (f ` J) B addB multB zeroB oneB"
        by (meson J im_of_max_lideal_is_max iso)
      ultimately have "f ` I = f ` J"
        by (meson local_ring.is_unique lring)
      thus ?thesis
        using bij_betw_imp_inj_on [OF bij_betw f A B]
        by (meson I J inj_on_image_eq_iff lideal.subset max_lideal.axioms(1))
    qed
  next
    show "𝔴. max_lideal 𝔴 A addA multA zeroA oneA"
      by (meson im_of_max_lideal_is_max iso local_ring.has_max_lideal lring ring_isomorphism.inverse_ring_isomorphism)
  qed
qed


(* ex. 0.40 *)
lemma (in pr_ideal) local_ring_at_is_local:
  shows "local_ring carrier_local_ring_at add_local_ring_at mult_local_ring_at zero_local_ring_at one_local_ring_at"
proof-
  interpret cq: quotient_ring "RI" R "(+)" "(⋅)" 𝟬 𝟭
    by (simp add: Comm_Ring.quotient_ring_def comm.comm_ring_axioms submonoid_pr_ideal)
  define 𝔴 where "𝔴  {quotient_ring.frac (RI) R (+) (⋅) 𝟬 r s| r s. r  I  s  (R  I)}"
    ―‹Now every proper ideal of @{term "RI"} is included in @{term 𝔴}, and the result follows trivially›
  have maximal: "𝔞  𝔴"
    if "lideal 𝔞 carrier_local_ring_at add_local_ring_at mult_local_ring_at zero_local_ring_at one_local_ring_at"
      and ne: "𝔞  carrier_local_ring_at" for 𝔞
  proof
    fix x
    interpret 𝔞: lideal 𝔞 carrier_local_ring_at add_local_ring_at mult_local_ring_at zero_local_ring_at one_local_ring_at
      using that by blast
    assume "x  𝔞"
    have "False" if "x  𝔴"
    proof -
      obtain r s where "r  R" "s  R" "s  I" "r  I" "x = cq.frac r s"
        using frac_from_carrier_local x  𝔞 x  𝔴 [unfolded 𝔴_def, simplified]
        by (metis 𝔞.additive.sub)
      then have sr: "cq.frac s r  carrier_local_ring_at"
        by (simp add: r  R s  R carrier_local_ring_at_def)
      have [simp]: "r  s  I"
        using r  R r  I s  R s  I absorbent by blast
      have "one_local_ring_at = cq.frac 𝟭 𝟭"
        by (simp add: one_local_ring_at_def cq.one_rel_def)
      also have "... = cq.frac (s  r) (r  s)"
        using r  R r  I s  R s  I
        by (intro cq.frac_eqI [of 𝟭]) (auto simp: comm.comm_mult)
      also have "... = cq.mult_rel (cq.frac s r) (cq.frac r s)"
        using  r  R r  I s  R s  I by (simp add: cq.mult_rel_frac)
      also have " = mult_local_ring_at (cq.frac s r) (cq.frac r s)"
        using mult_local_ring_at_def by force
      also have "...  𝔞"
        using 𝔞.lideal x = cq.frac r s x  𝔞 sr by blast
      finally have "one_local_ring_at  𝔞" .
      thus ?thesis
        using ne 𝔞.has_one_imp_equal by force
    qed
    thus "x  𝔴" by auto
  qed
  have uminus_closed: "uminus_local_ring_at u  𝔴" if "u  𝔴" for u
    using that by (force simp: 𝔴_def cq.uminus_rel_frac uminus_local_ring_at_def)
  have add_closed: "add_local_ring_at a b  𝔴" if "a  𝔴" "b  𝔴" for a b
  proof -
    obtain ra sa rb sb where ab: "a = cq.frac ra sa" "b = cq.frac rb sb"
      and "ra  I" "rb  I" "sa  R" "sa  I" "sb  R" "sb  I"
      using a  𝔴 b  𝔴 by (auto simp: 𝔴_def)
    then have "add_local_ring_at (cq.frac ra sa) (cq.frac rb sb) = cq.frac (ra  sb + rb  sa) (sa  sb)"
      by (force simp add: cq.add_rel_frac add_local_ring_at_def)
    moreover have "ra  sb + rb  sa  I"
      by (simp add: ra  I rb  I sa  R sb  R ideal(2))
    ultimately show ?thesis
      unfolding 𝔴_def using sa  R sa  I sb  R sb  I ab absorbent by blast
  qed
  interpret 𝔴: lideal 𝔴 carrier_local_ring_at add_local_ring_at mult_local_ring_at zero_local_ring_at one_local_ring_at
  proof intro_locales
    show subm: "submonoid_axioms 𝔴 carrier_local_ring_at add_local_ring_at zero_local_ring_at"
    proof
      show "𝔴  carrier_local_ring_at"
        using 𝔴_def comm.comm_ring_axioms comm.frac_in_carrier_local comm_ring.spectrum_def pr_ideal_axioms by fastforce
      show "zero_local_ring_at  𝔴"
        using 𝔴_def comm.spectrum_def comm.spectrum_imp_cxt_quotient_ring not_1 pr_ideal_axioms quotient_ring.zero_rel_def zero_local_ring_at_def by fastforce
    qed (auto simp: add_closed)
    show mon: "Group_Theory.monoid 𝔴 add_local_ring_at zero_local_ring_at"
    proof
      show "zero_local_ring_at  𝔴"
        by (meson subm submonoid_axioms_def)
    next
      fix a b c
      assume "a  𝔴" "b  𝔴" "c  𝔴"
      then show "add_local_ring_at (add_local_ring_at a b) c = add_local_ring_at a (add_local_ring_at b c)"
        by (meson additive.associative in_mono subm submonoid_axioms_def)
    next
      fix a assume "a  𝔴"
      show "add_local_ring_at zero_local_ring_at a = a"
        by (meson a  𝔴 subm additive.left_unit in_mono submonoid_axioms_def)
      show "add_local_ring_at a zero_local_ring_at = a"
        by (meson a  𝔴 additive.right_unit in_mono subm submonoid_axioms_def)
    qed (auto simp: add_closed)
    show "Group_Theory.group_axioms 𝔴 add_local_ring_at zero_local_ring_at"
    proof unfold_locales
      fix u
      assume "u  𝔴"
      show "monoid.invertible 𝔴 add_local_ring_at zero_local_ring_at u"
      proof (rule monoid.invertibleI [OF mon])
        show "add_local_ring_at u (uminus_local_ring_at u) = zero_local_ring_at"
          using u  𝔴
          apply (clarsimp simp add: 𝔴_def add_local_ring_at_def zero_local_ring_at_def uminus_local_ring_at_def)
          by (metis Diff_iff  additive.submonoid_axioms cq.add_minus_zero_rel cq.valid_frac_def submonoid.sub)
        then show "add_local_ring_at (uminus_local_ring_at u) u = zero_local_ring_at"
          using subm unfolding submonoid_axioms_def
          by (simp add: u  𝔴 additive.commutative subset_iff uminus_closed)
      qed (use u  𝔴 uminus_closed in auto)
    qed
    show "lideal_axioms 𝔴 carrier_local_ring_at mult_local_ring_at"
    proof
      fix a b
      assume a: "a  carrier_local_ring_at"
      then obtain ra sa where a: "a = cq.frac ra sa" and "ra  R" and sa: "sa  R" "sa  I"
        by (meson frac_from_carrier_local)
      then have "a  carrier_local_ring_at"
        by (simp add: comm.frac_in_carrier_local comm.spectrum_def pr_ideal_axioms)
      assume "b  𝔴"
      then obtain rb sb where b: "b = cq.frac rb sb" and "rb  I" and sb: "sb  R" "sb  I"
        using 𝔴_def by blast
      have "cq.mult_rel (cq.frac ra sa) (cq.frac rb sb) = cq.frac (ra  rb) (sa  sb)"
        using ra  R sa  rb  I sb
        by (force simp: cq.mult_rel_frac)
      then show "mult_local_ring_at a b  𝔴"
        apply (clarsimp simp add: mult_local_ring_at_def 𝔴_def a b)
        by (metis Diff_iff ra  R rb  I cq.sub_composition_closed ideal(1) sa sb)
    qed
  qed
  have max: "max_lideal 𝔴 carrier_local_ring_at add_local_ring_at mult_local_ring_at zero_local_ring_at one_local_ring_at"
  proof
    have False
      if "s  RI" "r  I" and eq: "cq.frac 𝟭 𝟭 = cq.frac r s" for r s
      using that eq_from_eq_frac [OF eq] r  I comm.additive.abelian_group_axioms
      unfolding abelian_group_def
      by (metis Diff_iff absorbent additive.sub comm.additive.cancel_imp_equal comm.inverse_distributive(1) comm.multiplicative.composition_closed cq.sub_unit_closed ideal(1))
    then have "cq.frac 𝟭 𝟭  𝔴"
      using 𝔴_def by blast
    moreover have "cq.frac 𝟭 𝟭  carrier_local_ring_at"
      using carrier_local_ring_at_def cq.multiplicative.unit_closed cq.one_rel_def by force
    ultimately show "𝔴  carrier_local_ring_at"
      by blast
  qed (use maximal in blast)
  have "J. max_lideal J carrier_local_ring_at add_local_ring_at mult_local_ring_at zero_local_ring_at one_local_ring_at
 J = 𝔴"
    by (metis maximal max max_lideal.axioms(1) max_lideal.is_max max_lideal.neq_ring)
  with max show ?thesis
    by (metis local.ring_axioms local_ring_axioms_def local_ring_def)
qed

definition (in stalk) is_local:: "'a set  bool" where
"is_local U  local_ring carrier_stalk add_stalk mult_stalk (zero_stalk U) (one_stalk U)"

(* def. 0.41 *)
locale local_ring_morphism =
source: local_ring A "(+)" "(⋅)" 𝟬 𝟭 + target: local_ring B "(+')" "(⋅')" "𝟬'" "𝟭'"
+ ring_homomorphism f A "(+)" "(⋅)" "𝟬" "𝟭" B "(+')" "(⋅')" "𝟬'" "𝟭'"
for f and
A and addition (infixl "+" 65) and multiplication (infixl "" 70) and zero ("𝟬") and unit ("𝟭") and
B and addition' (infixl "+''" 65) and multiplication' (infixl "⋅''" 70) and zero' ("𝟬''") and unit' ("𝟭''")
+ assumes preimage_of_max_lideal:
"𝔴A 𝔴B. max_lideal 𝔴A A (+) (⋅) 𝟬 𝟭  max_lideal 𝔴B B (+') (⋅') 𝟬' 𝟭'  (f¯ A 𝔴B) = 𝔴A"

lemma id_is_local_ring_morphism:
  assumes "local_ring A add mult zero one"
  shows "local_ring_morphism (identity A) A add mult zero one A add mult zero one"
proof -
  interpret local_ring A add mult zero one
    by (simp add: assms)
  show ?thesis
  proof intro_locales
    show "Set_Theory.map (identity A) A A"
      by (simp add: Set_Theory.map_def)
    show "monoid_homomorphism_axioms (identity A) A add zero add zero"
      by (simp add: monoid_homomorphism_axioms_def)
    show "monoid_homomorphism_axioms (identity A) A mult one mult one"
      by (simp add: monoid_homomorphism_axioms_def)
    show "local_ring_morphism_axioms (identity A) A add mult zero one A add mult zero one"
    proof
      fix 𝔴A 𝔴B
      assume "max_lideal 𝔴A A add mult zero one" "max_lideal 𝔴B A add mult zero one"
      then have "𝔴B  A = 𝔴A"
        by (metis Int_absorb2 is_unique lideal.subset max_lideal.axioms(1))
      then show "identity A ¯ A 𝔴B = 𝔴A"
        by (simp add: preimage_identity_self)
    qed
  qed
qed

lemma (in ring_epimorphism) preim_subset_imp_subset:
  assumes "η ¯ R I  η ¯ R J" and "I  R'"
  shows "I  J"
  using Int_absorb1 assms surjective
  by blast


lemma iso_is_local_ring_morphism:
  assumes "local_ring A addA multA zeroA oneA"
    and "ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB"
  shows "local_ring_morphism f A addA multA zeroA oneA B addB multB zeroB oneB"
proof -
  interpret A: local_ring A addA multA zeroA oneA
    using assms(1) by blast
  interpret B: ring B addB multB zeroB oneB
    by (meson assms(2) ring_homomorphism_def ring_isomorphism_def)
  interpret f: ring_isomorphism f A addA multA zeroA oneA B addB multB zeroB oneB
    by (simp add: assms)
  interpret preB: ring "f ¯ A B" addA multA zeroA oneA
    by (metis (no_types) A.ring_axioms f.multiplicative.image.subset image_subset_iff_subset_vimage inf.absorb2)
  show ?thesis
  proof
    fix I J
    assume "max_lideal I B addB multB zeroB oneB"
    then interpret MI: max_lideal I B addB multB zeroB oneB
      by simp
    assume "max_lideal J B addB multB zeroB oneB"
    then interpret MJ: max_lideal J B addB multB zeroB oneB
      by simp
    interpret GI: subgroup I B addB zeroB
      by unfold_locales
    have "max_lideal (f ¯ A I) (f ¯ A B) addA multA zeroA oneA"
      by (metis (no_types) MI.max_lideal_axioms f.ring_isomorphism_axioms preim_of_max_lideal_is_max)
    moreover have "max_lideal (f ¯ A J) (f ¯ A B) addA multA zeroA oneA"
      by (meson MJ.max_lideal_axioms f.ring_isomorphism_axioms preim_of_max_lideal_is_max)
    ultimately have "f ¯ A I = f ¯ A J"
      by (metis A.is_unique Int_absorb1 f.multiplicative.image.subset image_subset_iff_subset_vimage)
    then show "I = J"
      by (metis MI.lideal_axioms MI.neq_ring MJ.max_lideal_axioms MJ.subset f.preim_subset_imp_subset max_lideal.is_max subset_refl)
  next
    show "𝔴. max_lideal 𝔴 B addB multB zeroB oneB"
      by (meson A.has_max_lideal assms(2) im_of_max_lideal_is_max)
  next
    fix 𝔴A 𝔴B
    assume "max_lideal 𝔴A A addA multA zeroA oneA"
        and "max_lideal 𝔴B B addB multB zeroB oneB"
    then show "f ¯ A 𝔴B = 𝔴A"
      by (metis A.is_unique f.multiplicative.image.subset f.ring_isomorphism_axioms image_subset_iff_subset_vimage inf.absorb2 preim_of_max_lideal_is_max)
  qed
qed

(*these epimorphism aren't actually used*)
lemma (in monoid_homomorphism) monoid_epimorphism_image:
   "monoid_epimorphism η M (⋅) 𝟭 (η ` M) (⋅') 𝟭'"
proof -
  interpret monoid "η ` M" "(⋅')" "𝟭'"
    using image.sub.monoid_axioms by force
  show ?thesis
  proof qed (auto simp: bij_betw_def commutes_with_unit commutes_with_composition)
qed

lemma (in group_homomorphism) group_epimorphism_image:
   "group_epimorphism η G (⋅) 𝟭 (η ` G) (⋅') 𝟭'"
proof -
  interpret group "η ` G" "(⋅')" "𝟭'"
    using image.sub.group_axioms by blast
  show ?thesis
  proof qed (auto simp: bij_betw_def commutes_with_composition)
qed

lemma (in ring_homomorphism) ring_epimorphism_preimage:
   "ring_epimorphism η R (+) (⋅) 𝟬 𝟭 (η ` R) (+') (⋅') 𝟬' 𝟭'"
proof -
  interpret ring "η ` R" "(+')" "(⋅')" "𝟬'" "𝟭'"
  proof qed (auto simp add: target.distributive target.additive.commutative)
  show ?thesis
  proof qed (auto simp: additive.commutes_with_composition additive.commutes_with_unit
      multiplicative.commutes_with_composition multiplicative.commutes_with_unit)
qed

lemma comp_of_local_ring_morphisms:
  assumes "local_ring_morphism f A addA multA zeroA oneA B addB multB zeroB oneB"
      and "local_ring_morphism g B addB multB zeroB oneB C addC multC zeroC oneC"
    shows "local_ring_morphism (compose A g f) A addA multA zeroA oneA C addC multC zeroC oneC"
proof -
  interpret f: local_ring_morphism f A addA multA zeroA oneA B addB multB zeroB oneB
    by (simp add: assms)
  interpret g: local_ring_morphism g B addB multB zeroB oneB C addC multC zeroC oneC
    by (simp add: assms)
  interpret gf: ring_homomorphism "compose A g f" A addA multA zeroA oneA C addC multC zeroC oneC
    using comp_ring_morphisms f.ring_homomorphism_axioms g.ring_homomorphism_axioms
    by fastforce
  obtain 𝔴B where 𝔴B: "max_lideal 𝔴B B addB multB zeroB oneB"
    using f.target.has_max_lideal by force
  show ?thesis
  proof intro_locales
    show "local_ring_morphism_axioms (compose A g f) A addA multA zeroA oneA C addC multC zeroC oneC"
    proof
      fix 𝔴A 𝔴C
      assume max: "max_lideal 𝔴A A addA multA zeroA oneA"
                  "max_lideal 𝔴C C addC multC zeroC oneC"
      interpret maxA: max_lideal 𝔴A A addA multA zeroA oneA
        using max by blast
      interpret maxC: max_lideal 𝔴C C addC multC zeroC oneC
        using max by blast
      have "B  g -` C"
        by blast
      with max interpret maxg: max_lideal "g ¯ B 𝔴C" "g ¯ B C" addB multB zeroB oneB
        by (metis Int_absorb1 𝔴B g.preimage_of_max_lideal)
      interpret maxgf: Group_Theory.monoid "(g  f  A) ¯ A 𝔴C" addA zeroA
        by (simp add: monoid_def vimage_def gf.additive.commutes_with_composition
                      gf.additive.commutes_with_unit f.source.additive.associative)
      show "(g  f  A) ¯ A 𝔴C = 𝔴A"
      proof (rule maxA.is_max [symmetric])
        show "lideal ((g  f  A) ¯ A 𝔴C) A addA multA zeroA oneA"
        proof
          fix u
          assume u: "u  (g  f  A) ¯ A 𝔴C"
          then have "u  A"
            by auto
          show "maxgf.invertible u"
          proof (rule maxgf.invertibleI)
            show "addA u (f.source.additive.inverse u) = zeroA"
              using f.source.additive.invertible_right_inverse u  A by blast
            have "(g  f  A) (f.source.additive.inverse u) = g.target.additive.inverse (g (f u))"
              by (metis f.source.additive.invertible u  A compose_eq
                    gf.additive.invertible_commutes_with_inverse)
            then show "(f.source.additive.inverse u)  (g  f  A) ¯ A 𝔴C"
              by (metis f.source.additive.invertible f.source.additive.invertible_inverse_closed
                    g.target.additive.group_axioms Int_iff compose_eq
                    maxC.additive.subgroup_inverse_iff f.map_closed g.map_axioms group.invertible
                    map.map_closed u vimage_eq)
          qed (use u u  A in auto)
        next
          fix r a
          assume "r  A" and "a  (g  f  A) ¯ A 𝔴C"
          then show "multA r a  (g  f  A) ¯ A 𝔴C"
            by (simp add: maxC.lideal gf.multiplicative.commutes_with_composition)
        qed (use maxgf.unit_closed maxgf.composition_closed in auto)
        have "x. x  𝔴A  g (f x)  𝔴C"
          by (metis IntD1 𝔴B f.preimage_of_max_lideal g.preimage_of_max_lideal max vimageD)
        then show "𝔴A  (g  f  A) ¯ A 𝔴C"
          by (auto simp: compose_eq)
        have "oneB  g -` 𝔴C"
          using maxg.has_one_imp_equal maxg.neq_ring by force
        then have "g oneB  𝔴C"
          by blast
        then show "(g  f  A) ¯ A 𝔴C  A"
          by (metis Int_iff compose_eq f.multiplicative.commutes_with_unit f.source.multiplicative.unit_closed vimage_eq)
      qed
    qed
  qed
qed

subsubsection ‹Locally Ringed Spaces›

(* The key map from the stalk at a prime ideal 𝔭 to the local ring at 𝔭 *)
locale key_map = comm_ring +
  fixes 𝔭:: "'a set" assumes is_prime: "𝔭  Spec"
begin

interpretation pi:pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
  by (simp add: is_prime spectrum_imp_pr)

interpretation top: topological_space Spec is_zariski_open
  by simp

interpretation pr:presheaf_of_rings Spec is_zariski_open sheaf_spec sheaf_spec_morphisms
            𝒪b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
  by (fact local.sheaf_spec_is_presheaf)

interpretation local:quotient_ring "(R  𝔭)" R "(+)" "(⋅)" 𝟬 𝟭
  using is_prime spectrum_imp_cxt_quotient_ring by presburger

interpretation st: stalk "Spec" is_zariski_open sheaf_spec sheaf_spec_morphisms
𝒪b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec "{U. is_zariski_open U  𝔭U}" 𝔭
proof
  fix U I V s
  assume "open_cover_of_open_subset Spec is_zariski_open U I V"
    and "i. i  I  V i  U"
    and "s  𝒪 U"
    and "i. i  I  sheaf_spec_morphisms U (V i) s = zero_sheaf_spec (V i)"
  then show "s = zero_sheaf_spec U"
    by (metis sheaf_of_rings.locality sheaf_spec_is_sheaf)
next
fix U I V s
  assume "open_cover_of_open_subset Spec is_zariski_open U I V"
      and "i. i  I  V i  U  s i  𝒪 V i"
      and "i j. i  I; j  I  sheaf_spec_morphisms (V i) (V i  V j) (s i) = sheaf_spec_morphisms (V j) (V i  V j) (s j)"
  then show "t. t  𝒪 U  (i. i  I  sheaf_spec_morphisms U (V i) t = s i)"
    by (smt (verit, ccfv_threshold) sheaf_of_rings.glueing sheaf_spec_is_sheaf)
qed (use is_prime in auto)

declare st.subset_of_opens [simp del, rule del] ―‹because it loops!›

definition key_map:: "'a set set  (('a set  ('a × 'a) set)  ('a × 'a) set)"
  where "key_map U  λs(𝒪 U). s 𝔭"

lemma key_map_is_map:
  assumes  "𝔭  U"
  shows "Set_Theory.map (key_map U) (𝒪 U) (R𝔭 (+) (⋅) 𝟬)"
proof
  have "s. s  𝒪 U  s 𝔭  (R𝔭 (+) (⋅) 𝟬)"
    using sheaf_spec_def assms is_regular_def by blast
  thus "key_map U  (𝒪 U) E (R𝔭 (+) (⋅) 𝟬)"
    using key_map_def extensional_funcset_def by simp
qed

lemma key_map_is_ring_morphism:
  assumes "𝔭  U" and "is_zariski_open U"
  shows "ring_homomorphism (key_map U)
(𝒪 U) (add_sheaf_spec U) (mult_sheaf_spec U) (zero_sheaf_spec U) (one_sheaf_spec U)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
proof (intro ring_homomorphism.intro)
  show "Set_Theory.map (key_map U) (𝒪 U) (R𝔭 (+) (⋅) 𝟬)" using key_map_is_map assms(1) by simp
next
  show "ring (𝒪 U) (add_sheaf_spec U) (mult_sheaf_spec U) (zero_sheaf_spec U) (one_sheaf_spec U)"
    using is_zariski_open U pr.is_ring_from_is_homomorphism by blast
next
  show "ring (R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
    by (simp add: pi.ring_axioms)
next
  show "group_homomorphism (key_map U) (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U) (R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.zero_local_ring_at)"
  proof intro_locales
    show "Set_Theory.map (local.key_map U) (𝒪 U) pi.carrier_local_ring_at"
      by (simp add: assms(1) key_map_is_map)
    show "Group_Theory.monoid (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U)"
      "Group_Theory.group_axioms (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U)"
      using pr.is_ring_from_is_homomorphism [OF is_zariski_open U]
      unfolding ring_def Group_Theory.group_def abelian_group_def
      by blast+
    have 1: "(key_map U) (zero_sheaf_spec U) = pi.zero_local_ring_at"
      using assms
      unfolding key_map_def pi.zero_local_ring_at_def
      by (metis (no_types, lifting) restrict_apply' zero_sheaf_spec_def zero_sheaf_spec_in_sheaf_spec)
    have 2: "x y. x  𝒪 U; y  𝒪 U 
           (key_map U) (add_sheaf_spec U x y) = pi.add_local_ring_at (key_map U x) (key_map U y)"
      using add_sheaf_spec_in_sheaf_spec key_map_def assms pi.add_local_ring_at_def
        add_sheaf_spec_def spectrum_def zariski_open_is_subset
      by fastforce
    show "monoid_homomorphism_axioms (local.key_map U) (𝒪 U) (add_sheaf_spec U) (zero_sheaf_spec U) pi.add_local_ring_at pi.zero_local_ring_at"
      unfolding monoid_homomorphism_axioms_def
      by (auto simp: 1 2)
  qed
next
  have "(key_map U) (one_sheaf_spec U) = pi.one_local_ring_at"
    using one_sheaf_spec_def key_map_def pi.one_local_ring_at_def assms one_sheaf_spec_in_sheaf_spec spectrum_def by fastforce
  moreover have "x y. x  𝒪 U; y  𝒪 U 
           (key_map U) (mult_sheaf_spec U x y) = pi.mult_local_ring_at (key_map U x) (key_map U y)"
    using mult_sheaf_spec_in_sheaf_spec key_map_def assms pi.mult_local_ring_at_def
      mult_sheaf_spec_def spectrum_def zariski_open_is_subset by fastforce
  ultimately show "monoid_homomorphism (key_map U) (𝒪 U) (mult_sheaf_spec U) (one_sheaf_spec U) (R𝔭 (+) (⋅) 𝟬) (pi.mult_local_ring_at) (pi.one_local_ring_at)"
    using pr.is_ring_from_is_homomorphism [OF is_zariski_open U] 𝔭  U
    unfolding monoid_homomorphism_def monoid_homomorphism_axioms_def ring_def
    using key_map_is_map pi.multiplicative.monoid_axioms by presburger
qed

lemma key_map_is_coherent:
  assumes "V  U" and "is_zariski_open U" and "is_zariski_open V" and "𝔭  V" and "s  𝒪 U"
  shows "(key_map V  sheaf_spec_morphisms U V) s = key_map U s"
proof-
  have "sheaf_spec_morphisms U V s  𝒪 V"
    using assms sheaf_spec_morphisms_are_maps map.map_closed
    by (metis (mono_tags, opaque_lifting))
  thus "(key_map V  sheaf_spec_morphisms U V) s = key_map U s"
    by (simp add: s  𝒪 U assms(4) key_map_def sheaf_spec_morphisms_def)
qed

lemma key_ring_morphism:
  assumes "is_zariski_open V" and "𝔭  V"
  shows "φ. ring_homomorphism φ
st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk V) (st.one_stalk V)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)

(U(top.neighborhoods 𝔭). s𝒪 U. (φ  st.canonical_fun U) s = key_map U s)"
proof -
  have "ring (R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
    by (simp add: pi.ring_axioms)
  moreover have "V  top.neighborhoods 𝔭"
    using assms top.neighborhoods_def sheaf_spec_is_presheaf by fastforce
  moreover have "U. U  top.neighborhoods 𝔭 
          ring_homomorphism (key_map U)
(𝒪 U) (add_sheaf_spec U) (mult_sheaf_spec U) (zero_sheaf_spec U) (one_sheaf_spec U)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
    using key_map_is_ring_morphism top.neighborhoods_def sheaf_spec_is_presheaf by force
  moreover have "U V x. U  top.neighborhoods 𝔭; V  top.neighborhoods 𝔭; V  U; x  𝒪 U
                           (key_map V  sheaf_spec_morphisms U V) x = key_map U x"
    using key_map_is_coherent
    by (metis (no_types, lifting) mem_Collect_eq top.neighborhoods_def)
  ultimately show ?thesis
    using assms local.sheaf_spec_is_presheaf zariski_open_is_subset
      st.universal_property_for_stalk[of "R𝔭 (+) (⋅) 𝟬⇙" "pi.add_local_ring_at" "pi.mult_local_ring_at"
        "pi.zero_local_ring_at" "pi.one_local_ring_at" "key_map"]
    by auto
qed

lemma class_from_belongs_stalk:
  assumes "s  st.carrier_stalk"
  obtains U s' where "is_zariski_open U" "𝔭  U" "s'  𝒪 U" "s = st.class_of U s'"
proof -
  interpret dl: direct_lim Spec is_zariski_open sheaf_spec sheaf_spec_morphisms "𝒪b"
    add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec "top.neighborhoods 𝔭"
    by (simp add: st.direct_lim_axioms top.neighborhoods_def)
  interpret eq: equivalence "Sigma (top.neighborhoods 𝔭) sheaf_spec" "{(x, y). dl.rel x y}"
    using dl.rel_is_equivalence by force
  note dl.subset_of_opens [simp del]
  obtain U s' where seq: "s = eq.Class (U, s')" and U: "U  top.neighborhoods 𝔭" and s': "s'  𝒪 U"
    using assms
    unfolding st.carrier_stalk_def dl.carrier_direct_lim_def
    by (metis SigmaD1 SigmaD2 eq.representant_exists old.prod.exhaust)
  show thesis
  proof
    show "is_zariski_open U"
      using U dl.subset_of_opens by blast
    show "𝔭  U"
      using U top.neighborhoods_def by force
    show "s'  𝒪 U"
      using s' by blast
    show "s = st.class_of U s'"
      using seq st.class_of_def top.neighborhoods_def by presburger
  qed
qed

lemma same_class_from_restrict:
  assumes "is_zariski_open U" "is_zariski_open V" "U  V" "s  𝒪 V" "𝔭  U"
  shows "st.class_of V s = st.class_of U (sheaf_spec_morphisms V U s)"
proof -
  interpret eq: equivalence "Sigma {U. is_zariski_open U  𝔭  U} sheaf_spec" "{(x, y). st.rel x y}"
    using st.rel_is_equivalence by blast
  show ?thesis
    unfolding st.class_of_def
  proof (rule eq.Class_eq)
     have §:"sheaf_spec_morphisms V U s  𝒪 U"
      using assms map.map_closed pr.is_map_from_is_homomorphism by fastforce
    then have "W. is_zariski_open W  𝔭  W  W  V  W  U  sheaf_spec_morphisms V W s = sheaf_spec_morphisms U W (sheaf_spec_morphisms V U s)"
      using assms(1) assms(3) assms(5) by auto
    then show "((V, s), U, sheaf_spec_morphisms V U s)  {(x, y). st.rel x y}"
      using § assms by (auto simp: st.rel_def)
  qed
qed

lemma shrinking_from_belong_stalk:
  assumes "s  st.carrier_stalk" and "t  st.carrier_stalk"
  obtains U s' t' where "is_zariski_open U" "𝔭  U" "s'  𝒪 U" "s = st.class_of U s'"
    "t'  𝒪 U" "t = st.class_of U t'"
proof -
  obtain U s' where HU:"is_zariski_open U" "𝔭  U" "s'  𝒪 U" "s = st.class_of U s'"
    using assms(1) class_from_belongs_stalk by blast
  obtain V t' where HV:"is_zariski_open V" "𝔭  V" "t'  𝒪 V" "t = st.class_of V t'"
    using assms(2) class_from_belongs_stalk by blast
  show thesis
  proof
    have "U  V  Spec"
      using zariski_open_is_subset HU(1) by blast
    show "𝔭  U  V"
      by (simp add: 𝔭  U 𝔭  V)
    show UV: "is_zariski_open (U  V)" using topological_space.open_inter
      by (simp add: is_zariski_open U is_zariski_open V)
    show "s = st.class_of (U  V) (sheaf_spec_morphisms U (U  V) s')"
      using HU UV 𝔭  U  V same_class_from_restrict by blast
    show "t = st.class_of (U  V) (sheaf_spec_morphisms V (U  V) t')"
      using HV UV 𝔭  U  V same_class_from_restrict by blast
    show "sheaf_spec_morphisms U (U  V) s'  𝒪 (U  V)"
      using HU(3) UV map.map_closed sheaf_spec_morphisms_are_maps by fastforce
    show "sheaf_spec_morphisms V (U  V) t'  𝒪 (U  V)"
      using HV(3) UV map.map_closed sheaf_spec_morphisms_are_maps by fastforce
  qed
qed


lemma stalk_at_prime_is_iso_to_local_ring_at_prime_aux:
  assumes "is_zariski_open V" and "𝔭  V" and
    φ: "ring_homomorphism φ
      st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk V) (st.one_stalk V)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
    and all_eq: "U(top.neighborhoods 𝔭). s𝒪 U. (φ  st.canonical_fun U) s = key_map U s"
  shows "ring_isomorphism φ
st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk V) (st.one_stalk V)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
proof (intro ring_isomorphism.intro bijective_map.intro bijective.intro)
  show "ring_homomorphism φ
st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk V) (st.one_stalk V)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
    using assms(3) by simp
next
  show "Set_Theory.map φ st.carrier_stalk (R𝔭 (+) (⋅) 𝟬)"
    using assms(3) by (simp add: ring_homomorphism_def)
next
  show "bij_betw φ st.carrier_stalk (R𝔭 (+) (⋅) 𝟬)"
  proof-
    have "inj_on φ st.carrier_stalk"
    proof
      fix s t assume "s  st.carrier_stalk" "t  st.carrier_stalk" "φ s = φ t"
      obtain U s' t' a f b g where FU [simp]: "is_zariski_open U" "𝔭  U" "s'  𝒪 U" "t'  𝒪 U"
        and s: "s = st.class_of U s'" "t = st.class_of U t'"
        and s': "s' = (λ𝔮U. quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f)"
        and t': "t' = (λ𝔮U. quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g)"
        and "a  R" "b  R" "f  R" "g  R" "f  𝔭" "g  𝔭"
      proof-
        obtain V s' t' where HV: "s = st.class_of V s'" "t = st.class_of V t'"
                            "s'  𝒪 V" "t'  𝒪 V" "is_zariski_open V" "𝔭  V"
          using shrinking_from_belong_stalk by (metis (no_types, lifting) s  st.carrier_stalk t  st.carrier_stalk)
        then obtain U a f b g where HU: "is_zariski_open U" "U  V" "𝔭  U" "a  R" "f  R" "b  R" "g  R"
          "f  𝔭" "g  𝔭"
          "𝔮. 𝔮  U  f  𝔮  s' 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f"
          "𝔮. 𝔮  U  g  𝔮  t' 𝔮 = quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g"
          using shrinking[of V 𝔭 s' t'] by blast
        show ?thesis
        proof
          show "sheaf_spec_morphisms V U s'  𝒪 U"
            by (metis (mono_tags, opaque_lifting) HU(1,2) HV(3) map.map_closed sheaf_spec_morphisms_are_maps)
          show "sheaf_spec_morphisms V U t'  𝒪 U"
            by (metis (mono_tags, opaque_lifting) HU(1,2) HV(4) map.map_closed sheaf_spec_morphisms_are_maps)
          show "s = st.class_of U (sheaf_spec_morphisms V U s')"
            by (simp add: HU(1-3) HV same_class_from_restrict)
          show "t = st.class_of U (sheaf_spec_morphisms V U t')"
            by (simp add: HU(1-3) HV same_class_from_restrict)
          show "sheaf_spec_morphisms V U s' = (λ𝔮U. quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f)"
            using HV(3)  sheaf_spec_morphisms_def HU(10) by fastforce
          show "sheaf_spec_morphisms V U t' = (λ𝔮U. quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 b g)"
            using HV(4) HU(11) sheaf_spec_morphisms_def by fastforce
        qed (use HU in auto)
    qed
    hence fact:"local.frac a f = local.frac b g"
      proof-
        have "local.frac a f = key_map U s'"
          using key_map_def 𝔭  U s' = (λ𝔮U. quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f) s'  𝒪 U by auto
        also have " = φ (st.canonical_fun U s')"
          using 𝔭  U is_zariski_open U s'  𝒪 U assms(4) pr.presheaf_of_rings_axioms top.neighborhoods_def by fastforce
        also have " = φ (st.class_of U s')" using direct_lim.canonical_fun_def is_prime st.canonical_fun_def st.class_of_def by fastforce
        also have " = φ s" by (simp add: s = st.class_of U s')
        also have " = φ t" using φ s = φ t by simp
        also have " = φ (st.class_of U t')" using t = st.class_of U t' by auto
        also have " = φ (st.canonical_fun U t')"
          using direct_lim.canonical_fun_def is_prime st.canonical_fun_def st.class_of_def by fastforce
        also have " = key_map U t'"
          using 𝔭  U is_zariski_open U t'  𝒪 U assms(4) top.neighborhoods_def by auto
        also have " = local.frac b g"
          using FU(4) local.key_map_def t' by force
        finally show ?thesis .
      qed
      then obtain h where Hh: "h  R" "h  𝔭" "h  (g  a - f  b) = 𝟬"
        using pi.eq_from_eq_frac by (metis Diff_iff a  R b  R f  R f  𝔭 g  R g  𝔭)
      have izo: "is_zariski_open (U  𝒟(f)  𝒟(g)  𝒟(h))"
        using local.standard_open_is_zariski_open
        by (simp add: Hh(1) f  R g  R standard_open_is_zariski_open)
      have ssm_s': "sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) s'
                 𝒪 (U  𝒟(f)  𝒟(g)  𝒟(h))"
        by (metis (no_types, opaque_lifting) FU(3) Int_assoc inf_le1 izo map.map_closed sheaf_spec_morphisms_are_maps)
      have ssm_t': "sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) t'
                 𝒪 (U  𝒟(f)  𝒟(g)  𝒟(h))"
        by (metis (no_types, opaque_lifting) FU(4) Int_assoc inf_le1 izo map.map_closed sheaf_spec_morphisms_are_maps)      have [simp]: "𝔭  𝒟(f)" "𝔭  𝒟(g)" "𝔭  𝒟(h)"
        using Hh f  R f  𝔭 g  R g  𝔭 belongs_standard_open_iff st.is_elem by blast+
      have eq: "s' 𝔮 = t' 𝔮" if "𝔮  U  𝒟(f)  𝒟(g)  𝒟(h)" for 𝔮
      proof -
        have "𝔮  Spec"
          using standard_open_def that by auto
        then        interpret q: quotient_ring "R𝔮" R "(+)" "(⋅)" 𝟬
          using spectrum_imp_cxt_quotient_ring by force
        note local.q.sub [simp del]  ―‹Because it definitely loops›
        define RR where "RR  {(x, y). (x, y)  (R × (R𝔮)) × R × (R𝔮)  q.rel x y}"
        interpret eq: equivalence "R × (R𝔮)" "RR"
          unfolding RR_def by (blast intro: equivalence.intro q.rel_refl q.rel_sym q.rel_trans)
        have Fq [simp]: "f  𝔮" "g  𝔮" "h  𝔮"
          using belongs_standard_open_iff that
          apply (meson Int_iff 𝔮  Spec f  R)
          apply (meson Int_iff 𝔮  Spec g  R belongs_standard_open_iff that)
          by (meson Hh(1) IntD2 𝔮  Spec belongs_standard_open_iff that)
        moreover  have "eq.Class (a, f) = eq.Class (b, g)"
        proof (rule eq.Class_eq)
          have "s1. s1  R  s1  𝔮  s1  (g  a - f  b) = 𝟬"
            using Hh h  𝔮 by blast
          then show "((a,f), b,g)  RR"
            by (simp add: RR_def q.rel_def  a  R b  R f  R g  R)
        qed
        ultimately have "q.frac a f = q.frac b g"
          using RR_def q.frac_def by metis
        thus "s' 𝔮 = t' 𝔮"
          by (simp add: s' t')
      qed
      show "s = t"
      proof-
        have "s = st.class_of (U  𝒟(f)  𝒟(g)  𝒟(h)) (sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) s')"
          using 𝔭  𝒟(f) 𝔭  𝒟(g) 𝔭  𝒟(h)
          by (smt (verit, ccfv_threshold) FU(1-3) IntE IntI izo s(1) same_class_from_restrict subsetI)
        also have " = st.class_of (U  𝒟(f)  𝒟(g)  𝒟(h)) (sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) t')"
        proof (rule local.st.class_of_eqI)
          show "sheaf_spec_morphisms (U  𝒟(f)  𝒟(g)  𝒟(h)) (U  𝒟(f)  𝒟(g)  𝒟(h)) (sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) s') = sheaf_spec_morphisms (U  𝒟(f)  𝒟(g)  𝒟(h)) (U  𝒟(f)  𝒟(g)  𝒟(h)) (sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) t')"
          proof (rule local.pr.eq_ρ)
            show "sheaf_spec_morphisms (U  𝒟(f)  𝒟(g)  𝒟(h)) (U  𝒟(f)  𝒟(g)  𝒟(h)) (sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) s') =
                  sheaf_spec_morphisms (U  𝒟(f)  𝒟(g)  𝒟(h)) (U  𝒟(f)  𝒟(g)  𝒟(h)) (sheaf_spec_morphisms U (U  𝒟(f)  𝒟(g)  𝒟(h)) t')"
              using eq FU(3) FU(4)
              apply (simp add: sheaf_spec_morphisms_def)
              apply (metis eq restrict_ext)
              done
          qed (use izo ssm_s' ssm_t' in auto)
        qed (auto simp: izo ssm_s' ssm_t')
        also have " = t"
          using 𝔭  𝒟(f) 𝔭  𝒟(g) 𝔭  𝒟(h)
          by (smt (verit, ccfv_threshold) FU(1-4) IntE IntI izo s(2) same_class_from_restrict subsetI)
        finally show ?thesis .
      qed
    qed
    moreover have "φ ` st.carrier_stalk = (R𝔭 (+) (⋅) 𝟬)"
    proof
      show "φ ` st.carrier_stalk  pi.carrier_local_ring_at"
        using assms(3) by (simp add: image_subset_of_target ring_homomorphism_def)
    next
      show "pi.carrier_local_ring_at  φ ` st.carrier_stalk"
      proof
        fix x assume H:"x  (R𝔭 (+) (⋅) 𝟬)"
        obtain a f where F:"a  R" "f  R" "f  𝔭" "x = local.frac a f"
          using pi.frac_from_carrier_local H by blast
        define s where sec_def:"s  λ𝔮𝒟(f). quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f"
        then have sec:"s  𝒪(𝒟(f))"
        proof-
          have "s 𝔮  (R𝔮 (+) (⋅) 𝟬)" if "𝔮  𝒟(f)" for 𝔮
          proof -
            have "f  𝔮" using that belongs_standard_open_iff F(2) standard_open_is_subset by blast
            then have "quotient_ring.frac (R𝔮) R (+) (⋅) 𝟬 a f  (R𝔮 (+) (⋅) 𝟬)"
              using F(1,2) frac_in_carrier_local 𝔮  𝒟(f) standard_open_is_subset by blast
            thus "s 𝔮  (R𝔮 (+) (⋅) 𝟬)" using sec_def by (simp add: 𝔮  𝒟(f))
          qed
          moreover have "s   extensional (𝒟(f))"
            using sec_def by auto
          moreover have "is_regular s 𝒟(f)"
            using F(1,2) standard_open_is_subset  belongs_standard_open_iff is_regular_def[of s "𝒟(f)"] standard_open_is_zariski_open
            by (smt is_locally_frac_def restrict_apply sec_def subsetD subsetI)
          ultimately show ?thesis unfolding sheaf_spec_def[of "𝒟(f)"]
            by (simp add:PiE_iff)
        qed
        then have im:"φ (st.class_of 𝒟(f) s) = local.frac a f"
        proof-
          have "φ (st.class_of 𝒟(f) s) = φ (st.canonical_fun 𝒟(f) s)"
            using st.canonical_fun_def direct_lim.canonical_fun_def st.class_of_def is_prime by fastforce
          also have " = key_map 𝒟(f) s"
            using all_eq st.is_elem F(2) F(3) sec
            apply (simp add: top.neighborhoods_def)
            by (meson belongs_standard_open_iff standard_open_is_zariski_open)
          also have "... = local.frac a f"
            by (metis (mono_tags, lifting) F(2,3) belongs_standard_open_iff is_prime key_map_def restrict_apply sec sec_def)
          finally show ?thesis .
        qed
        thus "x  φ ` st.carrier_stalk"
        proof-
          have "st.class_of 𝒟(f) s  st.carrier_stalk"
          proof-
            have "𝔭  Spec" using is_prime by simp
            also have "𝒟(f)  (top.neighborhoods 𝔭)"
              using top.neighborhoods_def belongs_standard_open_iff F(2,3) is_prime standard_open_is_zariski_open standard_open_is_subset
              by (metis (no_types, lifting) mem_Collect_eq)
            moreover have "s  𝒪 𝒟(f)" using sec by simp
            ultimately show ?thesis using st.class_of_in_stalk by auto
          qed
          thus ?thesis using F(4) im by blast
        qed
      qed
    qed
    ultimately show ?thesis by (simp add: bij_betw_def)
  qed
qed

lemma stalk_at_prime_is_iso_to_local_ring_at_prime:
  assumes "is_zariski_open V" and "𝔭  V"
  shows "φ. ring_isomorphism φ
st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk V) (st.one_stalk V)
(R𝔭 (+) (⋅) 𝟬) (pi.add_local_ring_at) (pi.mult_local_ring_at) (pi.zero_local_ring_at) (pi.one_local_ring_at)"
  using key_ring_morphism stalk_at_prime_is_iso_to_local_ring_at_prime_aux assms by meson

end (* key_map *)

(* def. 0.42 *)
locale locally_ringed_space = ringed_space +
  assumes stalks_are_local: "x U. x  U  is_open U 
stalk.is_local is_open 𝔉 ρ add_str mult_str zero_str one_str (neighborhoods x) x U"

context comm_ring
begin

interpretation pr: presheaf_of_rings "Spec" is_zariski_open sheaf_spec sheaf_spec_morphisms
            𝒪b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
  by (simp add: comm_ring.sheaf_spec_is_presheaf local.comm_ring_axioms)

(* ex. 0.43 *)
lemma spec_is_locally_ringed_space:
  shows "locally_ringed_space Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b
add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
proof (intro locally_ringed_space.intro locally_ringed_space_axioms.intro)
  interpret sh: sheaf_of_rings Spec is_zariski_open sheaf_spec
     sheaf_spec_morphisms 𝒪b add_sheaf_spec mult_sheaf_spec
     zero_sheaf_spec one_sheaf_spec
    using sheaf_spec_is_sheaf .

  show "ringed_space Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec"
    using spec_is_ringed_space by simp
  show "stalk.is_local is_zariski_open sheaf_spec sheaf_spec_morphisms add_sheaf_spec mult_sheaf_spec
zero_sheaf_spec one_sheaf_spec (pr.neighborhoods 𝔭) 𝔭 U"
    if "𝔭  U" "is_zariski_open U" for 𝔭 U
  proof -
    interpret st: stalk Spec is_zariski_open sheaf_spec sheaf_spec_morphisms 𝒪b add_sheaf_spec
      mult_sheaf_spec zero_sheaf_spec one_sheaf_spec "pr.neighborhoods 𝔭" 𝔭
    proof
      show "𝔭  Spec"
        by (meson in_mono that zariski_open_is_subset)
    qed (auto simp: pr.neighborhoods_def)
    interpret pri: pr_ideal R 𝔭 "(+)" "(⋅)" 𝟬 𝟭
      by (simp add: spectrum_imp_pr st.is_elem)
    interpret km: key_map R "(+)" "(⋅)" 𝟬 𝟭 𝔭
    proof qed (simp add: st.is_elem)
    have "ring st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk U) (st.one_stalk U)"
      using st.stalk_is_ring sheaf_spec_is_presheaf is_zariski_open U 𝔭  U by blast
    also have "local_ring pri.carrier_local_ring_at pri.add_local_ring_at pri.mult_local_ring_at
                 pri.zero_local_ring_at pri.one_local_ring_at"
      using pr_ideal.local_ring_at_is_local
      by (simp add: pr_ideal.local_ring_at_is_local spectrum_imp_pr st.is_elem)
    moreover
    note st.subset_of_opens [simp del]
    have "f. ring_isomorphism f
st.carrier_stalk st.add_stalk st.mult_stalk (st.zero_stalk U) (st.one_stalk U)
(R𝔭 (+) (⋅) 𝟬) (pr_ideal.add_local_ring_at R 𝔭 (+) (⋅) 𝟬) (pr_ideal.mult_local_ring_at R 𝔭 (+) (⋅) 𝟬) (pr_ideal.zero_local_ring_at R 𝔭 (+) (⋅) 𝟬 𝟭) (pr_ideal.one_local_ring_at R 𝔭 (+) (⋅) 𝟬 𝟭)"
      by (simp add: km.stalk_at_prime_is_iso_to_local_ring_at_prime st.index that)
    ultimately show "stalk.is_local is_zariski_open sheaf_spec sheaf_spec_morphisms add_sheaf_spec mult_sheaf_spec
zero_sheaf_spec one_sheaf_spec (pr.neighborhoods 𝔭) 𝔭 U"
      using isomorphic_to_local_is_local 𝔭  U is_zariski_open U st.is_local_def by fastforce
  qed
qed

end (* comm_ring *)

(* Construction 0.44: induced morphism between direct limits *)
locale ind_mor_btw_stalks = morphism_ringed_spaces +
  fixes x::"'a"
  assumes is_elem: "x  X"
begin

interpretation stx:stalk X is_openX 𝒪X ρX b add_strX mult_strX zero_strX one_strX
  "{U. is_openX U  x  U}" "x"
proof qed (auto simp: is_elem)

interpretation stfx: stalk Y is_openY 𝒪Y ρY d add_strY mult_strY zero_strY one_strY
  "{U. is_openY U  (f x)  U}" "f x"
proof qed (auto simp: is_elem)

definition induced_morphism:: "('c set × 'd) set  ('a set × 'b) set" where
"induced_morphism  λC  stfx.carrier_stalk. let r = (SOME r. r  C) in stx.class_of (f¯ X (fst r)) (φf (fst r) (snd r))"

(* One should think of fst r as a V in index, and snd r as a d in 𝒪Y V. *)

lemma phi_in_O:
  assumes "is_openY V" "q  𝒪Y V"
  shows "φf V q  𝒪X (f ¯ X (V))"
  using is_morphism_of_sheaves morphism_presheaves_of_rings.fam_morphisms_are_maps
  unfolding morphism_sheaves_of_rings_def
  by (metis assms local.im_sheaf_def map.map_closed)

lemma induced_morphism_is_well_defined:
  assumes "stfx.rel (V,q) (V',q')"
  shows "stx.class_of (f¯ X V) (φf V q) = stx.class_of (f¯ X V') (φf V' q')"
proof -
  obtain W where W: "is_openY W" "f x  W" "W  V" "W  V'"
    and eq: "ρY V W q = ρY V' W q'"
    using assms stfx.rel_def by auto
  show ?thesis
  proof (rule stx.class_of_eqI)
    show "(f ¯ X V, φf V q)  Sigma {U. is_openX U  x  U} 𝒪X"
      using is_continuous phi_in_O assms stfx.rel_def stx.is_elem by auto
    show "(f ¯ X V', φf V' q')  Sigma {U. is_openX U  x  U} 𝒪X"
      using is_continuous phi_in_O assms stfx.rel_def stx.is_elem by auto
    show "f ¯ X W  {U. is_openX U  x  U}"
      using W is_continuous stx.is_elem by auto
    show "f ¯ X W  f ¯ X V  f ¯ X V'"
      using W by blast
  interpret Y: morphism_sheaves_of_rings Y is_openY 𝒪Y ρY
     d add_strY mult_strY zero_strY one_strY
     local.im_sheaf im_sheaf_morphisms b
      add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf φf
    by (rule is_morphism_of_sheaves)
    have "ρX (f¯ X V) (f¯ X W) (φf V q) = φf W (ρY V W q)"
      using assms Y.comm_diagrams W
      by (simp add: stfx.rel_def im_sheaf_morphisms_def o_def)
  also have " = φf W (ρY V' W q')"
    by (simp add: eq)
    also have " = ρX (f¯ X V') (f¯ X W) (φf V' q')"
      using assms Y.comm_diagrams W
      by (simp add: stfx.rel_def im_sheaf_morphisms_def o_def)
    finally show "ρX (f ¯ X V) (f ¯ X W) (φf V q) = ρX (f ¯ X V') (f ¯ X W) (φf V' q')" .
  qed
qed

lemma induced_morphism_eq:
  assumes "C  stfx.carrier_stalk"
  obtains V q where "(V,q)  C" "induced_morphism C = stx.class_of (f¯ X V) (φf V q)"
  by (metis (mono_tags, lifting) assms induced_morphism_def prod.exhaust_sel restrict_apply
            stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.rel_carrier_Eps_in(1))

lemma induced_morphism_eval:
  assumes "C  stfx.carrier_stalk" and "r  C"
  shows "induced_morphism C = stx.class_of (f¯ X (fst r)) (φf (fst r) (snd r))"
  by (smt (verit, best) assms induced_morphism_eq induced_morphism_is_well_defined
          prod.exhaust_sel stfx.carrier_direct_limE stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.rel_I1)


proposition ring_homomorphism_induced_morphism:
  assumes "is_openY V" and "f x  V"
  shows "ring_homomorphism induced_morphism
stfx.carrier_stalk stfx.add_stalk stfx.mult_stalk (stfx.zero_stalk V) (stfx.one_stalk V)
stx.carrier_stalk stx.add_stalk stx.mult_stalk (stx.zero_stalk (f¯ X V)) (stx.one_stalk (f¯ X V))"
proof intro_locales
  interpret phif: ring_homomorphism "φf V" "𝒪Y V"
    "add_strY V" "mult_strY V" "zero_strY V" "one_strY V" "local.im_sheaf V"
    "add_im_sheaf V" "mult_im_sheaf V" "zero_im_sheaf V" "one_im_sheaf V"
    by (metis assms(1) is_morphism_of_sheaves morphism_presheaves_of_rings.is_ring_morphism morphism_sheaves_of_rings_def)
  interpret V: ring stfx.carrier_direct_lim stfx.add_rel stfx.mult_rel "stfx.class_of V (zero_strY V)"
    "stfx.class_of V (one_strY V)"
    using assms stfx.direct_lim_is_ring by force
  interpret X: ring stx.carrier_direct_lim stx.add_rel stx.mult_rel "stx.class_of X (zero_strX X)"
     "stx.class_of X (one_strX X)"
    using stx.direct_lim_is_ring stx.is_elem by auto
  interpret dlY: direct_lim Y is_openY 𝒪Y ρY d add_strY
    mult_strY zero_strY one_strY "target.neighborhoods (f x)"
    using stfx.direct_lim_axioms stfx.neighborhoods_eq by force
  interpret eqY: equivalence "Sigma {U. is_openY U  f x  U} 𝒪Y" "{(x, y). stfx.rel x y}"
    using stfx.rel_is_equivalence by blast
  interpret morphY: morphism_sheaves_of_rings Y is_openY 𝒪Y ρY
     d add_strY mult_strY zero_strY one_strY
     local.im_sheaf im_sheaf_morphisms b
      add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf φf
    by (rule is_morphism_of_sheaves)

  have 0 [iff]: "stfx.zero_stalk V  stfx.carrier_stalk"
    using stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.zero_stalk_def by auto
  have 1 [iff]: "stfx.one_stalk V  stfx.carrier_stalk"
    using stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.one_stalk_def by auto

  show "Set_Theory.map induced_morphism stfx.carrier_stalk stx.carrier_stalk"
  proof
    show "induced_morphism  stfx.carrier_stalk E stx.carrier_stalk"
    proof
      fix C
      assume C: "C  stfx.carrier_stalk"
      then obtain r where "r  C"
        by (metis stfx.carrier_stalk_def stfx.rel_carrier_Eps_in(1) target.neighborhoods_def)
      moreover have "is_openX (f ¯ X (fst r))"
        by (metis (no_types, lifting) C SigmaD1 r  C eqY.block_closed is_continuous prod.exhaust_sel stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.subset_of_opens)
      ultimately have "stx.class_of (f ¯ X (fst r)) (φf (fst r) (snd r))  stx.carrier_stalk"
        by (smt (verit, best) C IntI dlY.carrier_direct_limE mem_Collect_eq phi_in_O stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.rel_I1 stfx.rel_def stx.class_of_in_stalk stx.is_elem stx.neighborhoods_eq vimage_def)
      then show "induced_morphism C  stx.carrier_stalk"
        using C r  C induced_morphism_eval by presburger
    qed (simp add: induced_morphism_def)
  qed
  show "Group_Theory.monoid stfx.carrier_stalk stfx.add_stalk (stfx.zero_stalk V)"
    by (simp add: V.additive.monoid_axioms stfx.add_stalk_def stfx.carrier_stalk_def stfx.neighborhoods_eq stfx.zero_stalk_def)
  show "Group_Theory.group_axioms stfx.carrier_stalk stfx.add_stalk (stfx.zero_stalk V)"
    using Group_Theory.group_def V.additive.group_axioms stfx.add_stalk_def stfx.carrier_stalk_def stfx.zero_stalk_def target.neighborhoods_def by fastforce
  show "commutative_monoid_axioms stfx.carrier_stalk stfx.add_stalk"
    using V.additive.commutative_monoid_axioms commutative_monoid_def stfx.add_stalk_def stfx.carrier_stalk_def target.neighborhoods_def by fastforce
  show "Group_Theory.monoid stfx.carrier_stalk stfx.mult_stalk (stfx.one_stalk V)"
    by (simp add: V.multiplicative.monoid_axioms stfx.carrier_stalk_def stfx.mult_stalk_def stfx.neighborhoods_eq stfx.one_stalk_def)
  show "ring_axioms stfx.carrier_stalk stfx.add_stalk stfx.mult_stalk"
    by (metis (no_types, lifting) V.additive.unit_closed mem_Collect_eq ring_def stfx.carrier_direct_limE stfx.stalk_is_ring)
  show "Group_Theory.monoid stx.carrier_stalk stx.add_stalk (stx.zero_stalk (f ¯ X V))"
    using abelian_group_def assms commutative_monoid_def is_continuous ring_def stx.is_elem stx.stalk_is_ring by fastforce
  show "Group_Theory.group_axioms stx.carrier_stalk stx.add_stalk (stx.zero_stalk (f ¯ X V))"
    using Group_Theory.group_def abelian_group_def assms is_continuous ring_def stx.is_elem stx.stalk_is_ring by fastforce
  show "commutative_monoid_axioms stx.carrier_stalk stx.add_stalk"
    using X.additive.commutative_monoid_axioms commutative_monoid_def neighborhoods_def stx.add_stalk_def stx.carrier_stalk_def by fastforce
  show "Group_Theory.monoid stx.carrier_stalk stx.mult_stalk (stx.one_stalk (f ¯ X V))"
    using assms is_continuous ring_def stx.is_elem stx.stalk_is_ring by fastforce
  show "ring_axioms stx.carrier_stalk stx.add_stalk stx.mult_stalk"
    using X.ring_axioms ring_def stx.add_stalk_def stx.carrier_stalk_def stx.mult_stalk_def stx.neighborhoods_eq by fastforce
  show "monoid_homomorphism_axioms induced_morphism stfx.carrier_stalk stfx.add_stalk (stfx.zero_stalk V) stx.add_stalk (stx.zero_stalk (f ¯ X V))"
  proof
    fix C C'
    assume CC: "C  stfx.carrier_stalk" "C'  stfx.carrier_stalk"
    show "induced_morphism (stfx.add_stalk C C') = stx.add_stalk (induced_morphism C) (induced_morphism C')"
    proof -
      obtain U q U' q' where Uq: "(U,q)  C" "(U',q')  C'"
         and eq: "induced_morphism C = stx.class_of (f¯ X U) (φf U q)"
         and eq': "induced_morphism C' = stx.class_of (f¯ X U') (φf U' q')"
        by (metis (no_types, lifting) CC induced_morphism_eq)
      then obtain cc [simp]: "is_openY (U  U')" "f x  U" "f x  U'"
        using CC eqY.block_closed stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq target.open_inter by force
      then interpret cc_rh: ring_homomorphism "φf (U  U')" "𝒪Y (U  U')"
        "add_strY (U  U')" "mult_strY (U  U')" "zero_strY (U  U')"
        "one_strY (U  U')" "local.im_sheaf (U  U')"
        "add_im_sheaf (U  U')" "mult_im_sheaf (U  U')"
        "zero_im_sheaf (U  U')" "one_im_sheaf (U  U')"
        by (metis is_morphism_of_sheaves morphism_presheaves_of_rings.is_ring_morphism morphism_sheaves_of_rings_def)
      obtain opeU [simp]: "is_openY U" "is_openY U'"
        by (metis (no_types, lifting) CC SigmaD1 Uq dlY.subset_of_opens eqY.block_closed stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq)
      obtain [simp]: "q  𝒪Y U" "q'  𝒪Y U'"
        using CC Uq stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq by auto

      define add where "add  add_strY (U  U') (ρY U (U  U') q) (ρY U' (U  U') q')"
      have add_stalk_eq_class: "stfx.add_stalk C C' = stfx.class_of (U  U') add"
        using CC
        unfolding add_def stfx.add_stalk_def stfx.carrier_stalk_def dlY.carrier_direct_lim_def
        by (smt (verit, best) IntI Int_commute Uq cc eqY.Block_self eqY.block_closed inf.cobounded1 mem_Collect_eq stfx.add_rel_class_of stfx.class_of_def stfx.neighborhoods_eq)
       then have C: "(stfx.class_of (U  U') add)  stfx.carrier_stalk"
         using CC Group_Theory.monoid stfx.carrier_stalk stfx.add_stalk (stfx.zero_stalk V) monoid.composition_closed by fastforce
      have add_in: "add  𝒪Y (U  U')"
        apply (simp add: add_def)
        using cc_rh.source.additive.composition_closedq  𝒪Y U q'  𝒪Y U'
        by (metis Int_commute cc(1) codom.is_map_from_is_homomorphism inf.cobounded1 map.map_closed opeU)
      obtain V r where Vr: "(V,r)  stfx.add_stalk C C'"
           and eq: "induced_morphism (stfx.add_stalk C C') = stx.class_of (f ¯ X V) (φf V r)"
        using induced_morphism_eq add_stalk_eq_class C by auto
      have "is_openY V"
        by (smt (verit, best) C SigmaD1 Vr add_stalk_eq_class dlY.subset_of_opens eqY.block_closed stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq)
      have "r  𝒪Y V"
        by (smt (verit, best) IntI Vr add_stalk_eq_class add_in cc fst_conv mem_Collect_eq snd_conv stfx.rel_I1 stfx.rel_def)
      have fxV: "f x  V"
        using C Vr add_stalk_eq_class stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq by auto
      have fXUU: "is_openX (f¯ X (U  U'))"
        using cc(1) is_continuous by presburger
      have "(U  U', add)  stfx.class_of V r"
        by (metis (no_types, lifting) IntI Vr add_stalk_eq_class add_in cc mem_Collect_eq stfx.class_of_def stfx.rel_Class_iff stfx.rel_I1)
      then have "stfx.rel (V, r) (U  U', add)"
        by (simp add: fxV is_openY V r  𝒪Y V stfx.rel_I1)
      then have "induced_morphism (stfx.add_stalk C C') = stx.class_of (f¯ X (U  U')) (φf (U  U') add)"
        using eq induced_morphism_is_well_defined by presburger
      moreover have "stx.add_stalk (induced_morphism C) (induced_morphism C') =
                     stx.add_stalk (stx.class_of (f ¯ X U) (φf U q))
                                   (stx.class_of (f ¯ X U') (φf U' q'))"
        using CC(1) Uq(1) eq' induced_morphism_eval by auto
      moreover have " = stx.class_of (f¯ X (U  U'))
                                       (add_strX (f¯ X (U  U'))
                                                 (ρX (f¯ X (U)) (f¯ X (U  U')) (φf (U) (q)))
                                                 (ρX (f¯ X (U')) (f¯ X (U  U')) (φf (U') (q')))
                                        )"
        unfolding stx.add_stalk_def
        using is_continuous phi_in_O stx.is_elem fXUU
        by (intro stx.add_rel_class_of) auto
      moreover have "φf (U  U') add = add_strX (f¯ X (U  U'))
                                       (φf (U  U') (ρY (U) (U  U') (q)))
                                       (φf (U  U') (ρY (U') (U  U') (q')))"
        unfolding add_def
      proof (subst cc_rh.additive.commutes_with_composition)
        show "ρY U (U  U') q  𝒪Y (U  U')"
          by (metis q  𝒪Y U cc(1) codom.is_map_from_is_homomorphism inf.cobounded1 map.map_closed opeU(1))
        show "ρY U' (U  U') q'  𝒪Y (U  U')"
          by (metis q'  𝒪Y U' cc(1) codom.is_map_from_is_homomorphism inf.commute inf_le1 map.map_closed opeU(2))
      qed (auto simp: add_im_sheaf_def)
      moreover have " = add_strX (f¯ X (U  U'))
                            (ρX (f¯ X (U)) (f¯ X (U  U')) (φf (U) (q)))
                            (ρX (f¯ X U') (f¯ X (U  U')) (φf (U') (q')))"
        using assms
        apply (simp add: stfx.rel_def morphY.comm_diagrams [symmetric, unfolded o_def])
        using im_sheaf_morphisms_def by fastforce
      ultimately show ?thesis
        by simp
    qed
  next
    have "induced_morphism (stfx.zero_stalk V) = stx.class_of (f¯ X V) (φf V (zero_strY V))"
      using induced_morphism_eval [OF 0, where r = "(V, zero_strY V)"] assms by force
    also have " = stx.zero_stalk (f ¯ X V)"
      by (simp add: phif.additive.commutes_with_unit zero_im_sheaf_def stx.zero_stalk_def)
    finally show "induced_morphism (stfx.zero_stalk V) = stx.zero_stalk (f ¯ X V)" .
  qed
  show "monoid_homomorphism_axioms induced_morphism stfx.carrier_stalk stfx.mult_stalk (stfx.one_stalk V) stx.mult_stalk (stx.one_stalk (f ¯ X V))"
  proof
    fix C C'
    assume CC: "C  stfx.carrier_stalk" "C'  stfx.carrier_stalk"
    show "induced_morphism (stfx.mult_stalk C C') = stx.mult_stalk (induced_morphism C) (induced_morphism C')"
    proof -
      obtain U q U' q' where Uq: "(U,q)  C" "(U',q')  C'"
         and eq: "induced_morphism C = stx.class_of (f¯ X U) (φf U q)"
         and eq': "induced_morphism C' = stx.class_of (f¯ X U') (φf U' q')"
        by (metis (no_types, lifting) CC induced_morphism_eq)
      then obtain cc [simp]: "is_openY (U  U')" "f x  U" "f x  U'"
        using CC eqY.block_closed stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq target.open_inter by force
      then interpret cc_rh: ring_homomorphism "φf (U  U')" "𝒪Y (U  U')"
        "add_strY (U  U')" "mult_strY (U  U')" "zero_strY (U  U')"
        "one_strY (U  U')" "local.im_sheaf (U  U')"
        "add_im_sheaf (U  U')" "mult_im_sheaf (U  U')"
        "zero_im_sheaf (U  U')" "one_im_sheaf (U  U')"
        by (metis is_morphism_of_sheaves morphism_presheaves_of_rings.is_ring_morphism morphism_sheaves_of_rings_def)
      obtain opeU [simp]: "is_openY U" "is_openY U'"
        by (metis (no_types, lifting) CC SigmaD1 Uq dlY.subset_of_opens eqY.block_closed stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq)
      obtain [simp]: "q  𝒪Y U" "q'  𝒪Y U'"
        using CC Uq stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq by auto

      define mult where "mult  mult_strY (U  U') (ρY U (U  U') q) (ρY U' (U  U') q')"
      have mult_stalk_eq_class: "stfx.mult_stalk C C' = stfx.class_of (U  U') mult"
        using CC
        unfolding mult_def stfx.mult_stalk_def stfx.carrier_stalk_def dlY.carrier_direct_lim_def
        by (smt (verit, best) IntI Int_commute Uq cc eqY.Block_self eqY.block_closed inf.cobounded1 mem_Collect_eq stfx.mult_rel_class_of stfx.class_of_def stfx.neighborhoods_eq)
       then have C: "(stfx.class_of (U  U') mult)  stfx.carrier_stalk"
         by (metis CC V.multiplicative.monoid_axioms monoid.composition_closed stfx.carrier_stalk_def stfx.mult_stalk_def stfx.neighborhoods_eq)
      have mult_in: "mult  𝒪Y (U  U')"
        apply (simp add: mult_def)
        using cc_rh.source.additive.composition_closedq  𝒪Y U q'  𝒪Y U'
        by (meson cc(1) cc_rh.source.multiplicative.composition_closed codom.is_map_from_is_homomorphism inf_le1 inf_le2 map.map_closed opeU)
      obtain V r where Vr: "(V,r)  stfx.mult_stalk C C'"
           and eq: "induced_morphism (stfx.mult_stalk C C') = stx.class_of (f ¯ X V) (φf V r)"
        using induced_morphism_eq mult_stalk_eq_class C by auto
      have "is_openY V"
        by (smt (verit, best) C SigmaD1 Vr mult_stalk_eq_class dlY.subset_of_opens eqY.block_closed stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq)
      have "r  𝒪Y V"
        by (smt (verit, best) IntI Vr mult_stalk_eq_class mult_in cc fst_conv mem_Collect_eq snd_conv stfx.rel_I1 stfx.rel_def)
      have fxV: "f x  V"
        using C Vr mult_stalk_eq_class stfx.carrier_direct_lim_def stfx.carrier_stalk_def stfx.neighborhoods_eq by auto
      have fXUU: "is_openX (f¯ X (U  U'))"
        using cc(1) is_continuous by presburger
      have "(U  U', mult)  stfx.class_of V r"
        by (metis (no_types, lifting) IntI Vr mult_stalk_eq_class mult_in cc mem_Collect_eq stfx.class_of_def stfx.rel_Class_iff stfx.rel_I1)
      then have "stfx.rel (V, r) (U  U', mult)"
        by (simp add: fxV is_openY V r  𝒪Y V stfx.rel_I1)
      then have "induced_morphism (stfx.mult_stalk C C') = stx.class_of (f¯ X (U  U')) (φf (U  U') mult)"
        using eq induced_morphism_is_well_defined by presburger
      moreover have "stx.mult_stalk (induced_morphism C) (induced_morphism C') =
                     stx.mult_stalk (stx.class_of (f ¯ X U) (φf U q))
                                   (stx.class_of (f ¯ X U') (φf U' q'))"
        using CC(1) Uq(1) eq' induced_morphism_eval by auto
      moreover have " = stx.class_of (f¯ X (U  U'))
                               (mult_strX (f¯ X (U  U'))
                                         (ρX (f ¯ X U) (f ¯ X (U  U')) (φf U q))
                                         (ρX (f ¯ X U') (f ¯ X (U  U')) (φf U' q')))"
        unfolding stx.mult_stalk_def
        using is_continuous phi_in_O stx.is_elem fXUU
        by (intro stx.mult_rel_class_of) auto
      moreover have "φf (U  U') mult = mult_strX (f¯ X (U  U'))
                                           (φf (U  U') (ρY U (U  U') q))
                                           (φf (U  U') (ρY U' (U  U') q'))"
        unfolding mult_def
      proof (subst cc_rh.multiplicative.commutes_with_composition)
        show "ρY U (U  U') q  𝒪Y (U  U')"
          by (metis q  𝒪Y U cc(1) codom.is_map_from_is_homomorphism inf.cobounded1 map.map_closed opeU(1))
        show "ρY U' (U  U') q'  𝒪Y (U  U')"
          by (metis q'  𝒪Y U' cc(1) codom.is_map_from_is_homomorphism inf.commute inf_le1 map.map_closed opeU(2))
      qed (auto simp: mult_im_sheaf_def)
      moreover have " = mult_strX (f¯ X (U  U'))
                            (ρX (f ¯ X U) (f ¯ X (U  U')) (φf U q))
                            (ρX (f ¯ X U') (f ¯ X (U  U')) (φf U' q'))"
        using assms im_sheaf_morphisms_def
        by (fastforce simp: stfx.rel_def morphY.comm_diagrams [symmetric, unfolded o_def])
      ultimately show ?thesis
        by simp
    qed
  next
    have "induced_morphism (stfx.one_stalk V) = stx.class_of (f¯ X V) (φf V (one_strY V))"
      using induced_morphism_eval [OF 1, where r = "(V, one_strY V)"] assms by force
    also have " = stx.one_stalk (f ¯ X V)"
      by (simp add: phif.multiplicative.commutes_with_unit one_im_sheaf_def stx.one_stalk_def)
    finally show "induced_morphism (stfx.one_stalk V) = stx.one_stalk (f ¯ X V)" .
  qed
qed


definition is_local:: "'c set  (('c set × 'd) set  ('a set × 'b) set)  bool" where
  "is_local V φ 
      local_ring_morphism φ
      stfx.carrier_stalk stfx.add_stalk stfx.mult_stalk (stfx.zero_stalk V) (stfx.one_stalk V)
      stx.carrier_stalk stx.add_stalk stx.mult_stalk (stx.zero_stalk (f¯ X V)) (stx.one_stalk (f¯ X V))"

end (* ind_mor_btw_stalks *)

notation ind_mor_btw_stalks.induced_morphism ("φ⇘(3_ _ _ _/ _ _ _/ _ _ _)"
    [1000,1000,1000,1000,1000,1000,1000,1000,1000,1000]1000)

lemma (in sheaf_of_rings) induced_morphism_with_id_is_id:
  assumes "x  S"
  shows "φ⇘S is_open 𝔉 ρ is_open 𝔉 ρ (identity S) (λU. identity (𝔉 U)) x= (λC(stalk.carrier_stalk is_open 𝔉 ρ x). C)"
proof -
  interpret im_sheaf S is_open 𝔉 ρ b add_str mult_str zero_str one_str S is_open "identity S"
    by (metis homeomorphism.axioms(3) id_is_homeomorphism im_sheaf_def inverse_map_identity
        sheaf_of_rings_axioms)
  interpret codom: ringed_space S is_open 𝔉 ρ b add_str mult_str zero_str one_str
    by (meson im_sheaf.axioms(1) im_sheaf_axioms ringed_space_def)

  interpret ind_mor_btw_stalks S is_open 𝔉 ρ b add_str mult_str zero_str one_str S
       is_open 𝔉 ρ b add_str mult_str zero_str one_str "identity S" "λU. identity (𝔉 U)" x
    apply intro_locales
    subgoal
    proof -
      have "ring_homomorphism (identity (𝔉 U)) (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U(local.im_sheaf U) (add_im_sheaf U)
          (mult_im_sheaf U) (zero_im_sheaf U) (one_im_sheaf U)" if "is_open U" for U
        by (smt (verit, best) id_is_mor_pr_rngs im_sheaf.add_im_sheaf_def im_sheaf.im_sheaf_def 
            im_sheaf.mult_im_sheaf_def im_sheaf_axioms local.topological_space_axioms 
            morphism_presheaves_of_rings.is_ring_morphism one_im_sheaf_def that 
            topological_space.open_preimage_identity zero_im_sheaf_def)
      moreover have "U V. is_open U 
           is_open V 
           V  U  (x. x  𝔉 U  (im_sheaf_morphisms U V  identity (𝔉 U)) x = (identity (𝔉 V)  ρ U V) x)"
        by (smt (verit, best) comp_apply im_sheaf_morphisms_def is_map_from_is_homomorphism
            local.im_sheaf_def map.map_closed open_preimage_identity restrict_apply')
      ultimately have "morphism_presheaves_of_rings_axioms is_open 𝔉 ρ add_str mult_str
          zero_str one_str local.im_sheaf im_sheaf_morphisms add_im_sheaf mult_im_sheaf
          zero_im_sheaf one_im_sheaf (λU. identity (𝔉 U))"
        unfolding morphism_presheaves_of_rings_axioms_def by auto
      then show ?thesis
        unfolding morphism_ringed_spaces_axioms_def
        by intro_locales

    qed
    subgoal by (meson assms ind_mor_btw_stalks_axioms.intro)
    done

  have "(let r = SOME r. r  C
        in direct_lim.class_of 𝔉 ρ (neighborhoods x) (identity S ¯ S (fst r))
            (identity (𝔉 (fst r)) (snd r))) = C"
    (is "?L= _")
    if "Cstalk.carrier_stalk is_open 𝔉 ρ x" for C
  proof -
    interpret stk:stalk S is_open 𝔉 ρ b add_str mult_str zero_str one_str
                      "neighborhoods x" x
      apply unfold_locales
      using is_elem neighborhoods_def by auto
    define r where "r=(SOME x. x  C)"
    have r:"r  C" "r  Sigma (neighborhoods x) 𝔉" and "C = stk.class_of (fst r) (snd r)"
      using stk.rel_carrier_Eps_in[OF that[unfolded stk.carrier_stalk_def]] unfolding r_def by auto

    have "?L = stk.class_of (identity S ¯ S (fst r)) (identity (𝔉 (fst r)) (snd r))"
      unfolding r_def Let_def by simp
    also have "... =  stk.class_of (fst r) (snd r)"
      by (metis open_preimage_identity r(1) restrict_apply stk.carrier_direct_limE
          stk.carrier_stalk_def stk.rel_I1 stk.rel_def stk.subset_of_opens that)
    also have "... = C"
      using C = stk.class_of (fst r) (snd r) by simp
    finally show ?thesis .
  qed
  then show ?thesis
    unfolding induced_morphism_def
    using is_elem neighborhoods_def by fastforce
qed

lemma (in locally_ringed_space) induced_morphism_with_id_is_local:
  assumes "x  S" and V: "x  V" "is_open V"
  shows "ind_mor_btw_stalks.is_local
S is_open 𝔉 ρ add_str mult_str zero_str one_str is_open 𝔉 ρ add_str mult_str zero_str one_str
(identity S) x V (φ⇘S is_open 𝔉 ρ is_open 𝔉 ρ (identity S) (λU. identity (𝔉 U)) x)"
proof-
  have [simp]: "(identity S)¯ S V = V"
    using assms by auto
  interpret stfx: stalk S is_open 𝔉 ρ b add_str mult_str zero_str one_str
                    "{U. is_open U  (identity S x)  U}" "identity S x"
  proof qed (use assms in auto)
  have "local_ring stfx.carrier_stalk stfx.add_stalk stfx.mult_stalk (stfx.zero_stalk V) (stfx.one_stalk V)"
    by (smt (verit, best) assms restrict_apply' stalks_are_local stfx.is_local_def stfx.neighborhoods_eq)
  interpret stx: stalk S is_open 𝔉 ρ b add_str mult_str zero_str one_str "{U. is_open U  x  U}" "x"
    using x  S stfx.stalk_axioms by fastforce
  interpret local_ring stx.carrier_stalk stx.add_stalk stx.mult_stalk
              "stx.zero_stalk ((identity S)¯ S V)" "stx.one_stalk ((identity S)¯ S V)"
    using V stalks_are_local stx.is_local_def stx.neighborhoods_eq by fastforce
  interpret imS: im_sheaf S is_open 𝔉 ρ b add_str mult_str zero_str one_str S is_open "identity S"
    by (metis homeomorphism.axioms(3) id_is_homeomorphism im_sheaf_def inverse_map_identity
        sheaf_of_rings_axioms)
  have rh: "U. is_open U 
             ring_homomorphism (identity (𝔉 U)) (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U(imS.im_sheaf U)
              (imS.add_im_sheaf U) (imS.mult_im_sheaf U) (imS.zero_im_sheaf U) (imS.one_im_sheaf U)"
    unfolding imS.add_im_sheaf_def imS.mult_im_sheaf_def imS.one_im_sheaf_def
              imS.zero_im_sheaf_def imS.im_sheaf_def
    using id_is_mor_pr_rngs morphism_presheaves_of_rings.is_ring_morphism by fastforce
  interpret ind_mor_btw_stalks S is_open 𝔉 ρ b add_str mult_str zero_str one_str S
    is_open 𝔉 ρ b add_str mult_str zero_str one_str "identity S" "λU. identity (𝔉 U)" x
  proof intro_locales
    show "morphism_ringed_spaces_axioms S 𝔉 ρ b add_str mult_str zero_str one_str
              S is_open 𝔉 ρ b add_str mult_str zero_str one_str (identity S) (λU. identity (𝔉 U))"
      unfolding morphism_ringed_spaces_axioms_def morphism_sheaves_of_rings_def
        morphism_presheaves_of_rings_def morphism_presheaves_of_rings_axioms_def
      using rh
      by (auto simp add: presheaf_of_rings_axioms imS.presheaf_of_rings_axioms
             map.map_closed [OF is_map_from_is_homomorphism] imS.im_sheaf_morphisms_def)
    show "ind_mor_btw_stalks_axioms S x"
      by (simp add: assms(1) ind_mor_btw_stalks_axioms_def)
  qed
  have "φ⇘S is_open 𝔉 ρ is_open 𝔉 ρ (identity S) (λU. identity (𝔉 U)) x= identity stx.carrier_stalk"
    using induced_morphism_with_id_is_id stx.is_elem by simp
  then show ?thesis
    using id_is_local_ring_morphism is_local_def local_ring_axioms stx.is_elem by fastforce
qed

(* definition 0.45 *)

locale morphism_locally_ringed_spaces = morphism_ringed_spaces +
  assumes are_local_morphisms:
    "x V. x  X; is_openY V; f x  V 
ind_mor_btw_stalks.is_local X is_openX 𝒪X ρX add_strX mult_strX zero_strX one_strX
                            is_openY 𝒪Y ρY add_strY mult_strY zero_strY one_strY f
                            x V φ⇘X is_openX 𝒪X ρX is_openY 𝒪Y ρY f φf x⇙"

lemma (in locally_ringed_space) id_to_mor_locally_ringed_spaces:
  shows "morphism_locally_ringed_spaces
            S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            (identity S) (λU. identity (𝔉 U))"
proof intro_locales
  interpret idim: im_sheaf S is_open 𝔉 ρ b add_str mult_str zero_str one_str S is_open "identity S"
  proof
    fix U assume "is_open U"
    then show "is_open (identity S ¯ S U)"
      by (simp add: open_inter preimage_identity_self)
  qed auto
  show "Set_Theory.map (identity S) S S"
    by (simp add: Set_Theory.map_def)
  show "continuous_map_axioms S is_open is_open (identity S)"
    by (simp add: continuous_map_axioms_def open_inter preimage_identity_self)
  have gh: "group_homomorphism (identity (𝔉 U)) (𝔉 U) +⇘U⇙
          𝟬⇘U(idim.im_sheaf U) (idim.add_im_sheaf U) (idim.zero_im_sheaf U)"
    if "is_open U" for U
    using that id_is_mor_pr_rngs idim.add_im_sheaf_def idim.im_sheaf_def idim.zero_im_sheaf_def morphism_presheaves_of_rings.is_ring_morphism ring_homomorphism_def by fastforce
  have "morphism_presheaves_of_rings_axioms is_open 𝔉 ρ add_str mult_str zero_str one_str idim.im_sheaf idim.im_sheaf_morphisms idim.add_im_sheaf idim.mult_im_sheaf idim.zero_im_sheaf idim.one_im_sheaf (λU. identity (𝔉 U))"
    unfolding morphism_presheaves_of_rings_axioms_def
  proof (intro conjI strip)
    fix U
    assume "is_open U"
    then show "ring_homomorphism (identity (𝔉 U)) (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U(idim.im_sheaf U) (idim.add_im_sheaf U) (idim.mult_im_sheaf U) (idim.zero_im_sheaf U) (idim.one_im_sheaf U)"
      using id_is_mor_pr_rngs idim.add_im_sheaf_def idim.im_sheaf_def idim.mult_im_sheaf_def idim.one_im_sheaf_def idim.zero_im_sheaf_def morphism_presheaves_of_rings.is_ring_morphism by fastforce
    fix V x
    assume "is_open V" and "V  U" and "x  𝔉 U"
    then show "(idim.im_sheaf_morphisms U V  identity (𝔉 U)) x = (identity (𝔉 V)  ρ U V) x"
      using is_open U
      by (simp add: idim.im_sheaf_morphisms_def map.map_closed [OF is_map_from_is_homomorphism])
  qed
  then show mrs: "morphism_ringed_spaces_axioms S 𝔉 ρ b add_str mult_str zero_str one_str
                      S is_open 𝔉 ρ b add_str mult_str zero_str one_str (identity S) (λU. identity (𝔉 U))"
    by (simp add: idim.im_sheaf_is_presheaf morphism_presheaves_of_rings_def morphism_ringed_spaces_axioms.intro morphism_sheaves_of_rings.intro presheaf_of_rings_axioms)
  show "morphism_locally_ringed_spaces_axioms S is_open 𝔉 ρ add_str mult_str zero_str one_str
                     is_open 𝔉 ρ add_str mult_str zero_str one_str (identity S) (λU. identity (𝔉 U))"
    using induced_morphism_with_id_is_local
    by (simp add: morphism_locally_ringed_spaces_axioms_def)
qed

locale iso_locally_ringed_spaces = morphism_locally_ringed_spaces +
  assumes is_homeomorphism: "homeomorphism X is_openX Y is_openY f" and
is_iso_of_sheaves: "iso_sheaves_of_rings Y is_openY 𝒪Y ρY d add_strY mult_strY zero_strY one_strY
im_sheaf im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf
φf"

lemma (in locally_ringed_space) id_to_iso_locally_ringed_spaces:
  shows "iso_locally_ringed_spaces
            S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            (identity S) (λU. identity (𝔉 U))"
proof -
  interpret morphism_ringed_spaces S is_open 𝔉 ρ b add_str mult_str zero_str one_str
    S is_open 𝔉 ρ b add_str mult_str zero_str one_str "identity S" "λU. identity (𝔉 U)"
    by (metis id_to_mor_locally_ringed_spaces morphism_locally_ringed_spaces_def)
  show ?thesis
  proof intro_locales
    show "morphism_locally_ringed_spaces_axioms S is_open 𝔉 ρ add_str mult_str zero_str one_str is_open 𝔉 ρ add_str mult_str zero_str one_str (identity S) (λU. identity (𝔉 U))"
      by (metis id_to_mor_locally_ringed_spaces morphism_locally_ringed_spaces_def)
    show "iso_locally_ringed_spaces_axioms S is_open 𝔉 ρ b add_str mult_str zero_str one_str S is_open 𝔉 ρ b add_str mult_str zero_str one_str (identity S) (λU. identity (𝔉 U))"
      unfolding iso_locally_ringed_spaces_axioms_def iso_sheaves_of_rings_def iso_presheaves_of_rings_def iso_presheaves_of_rings_axioms_def
    proof (intro conjI)
      show "homeomorphism S is_open S is_open (identity S)"
        using id_is_homeomorphism by blast
      show mor:"morphism_presheaves_of_rings S is_open 𝔉 ρ b add_str mult_str zero_str one_str
            local.im_sheaf im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf
            (λU. identity (𝔉 U))"
        by (simp add: is_morphism_of_sheaves morphism_sheaves_of_rings.axioms)
      have "morphism_presheaves_of_rings S is_open
               local.im_sheaf im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf
               𝔉 ρ b add_str mult_str zero_str one_str (λU. identity (𝔉 U))"
        unfolding morphism_presheaves_of_rings_def morphism_presheaves_of_rings_axioms_def
      proof (intro conjI strip)
        show "presheaf_of_rings S is_open local.im_sheaf im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf"
          using im_sheaf_is_presheaf by blast
        show "presheaf_of_rings S is_open 𝔉 ρ b add_str mult_str zero_str one_str"
          by (metis mor morphism_presheaves_of_rings_def)
      next
        fix U assume "is_open U"
        then have "ring_homomorphism (identity (𝔉 U)) (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U(𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U⇙"
          by (smt (verit, best) im_sheaf.add_im_sheaf_def im_sheaf.mult_im_sheaf_def im_sheaf_axioms local.im_sheaf_def mor morphism_presheaves_of_rings.is_ring_morphism one_im_sheaf_def open_preimage_identity zero_im_sheaf_def)
        then show "ring_homomorphism (identity (𝔉 U)) (local.im_sheaf U) (add_im_sheaf U) (mult_im_sheaf U) (zero_im_sheaf U) (one_im_sheaf U) (𝔉 U) +⇘U⇙ ⋅⇘U⇙ 𝟬⇘U⇙ 𝟭⇘U⇙"
          using is_open U im_sheaf.add_im_sheaf_def im_sheaf_axioms local.im_sheaf_def mult_im_sheaf_def one_im_sheaf_def zero_im_sheaf_def
          by fastforce
        fix V x
        assume "is_open V" and "V  U" and "x  local.im_sheaf U"
        then show "(ρ U V  identity (𝔉 U)) x = (identity (𝔉 V)  im_sheaf_morphisms U V) x"
          using map.map_closed [OF is_map_from_is_homomorphism] is_open U
          by (simp add: im_sheaf_morphisms_def local.im_sheaf_def)
      qed
      then show "ψ. morphism_presheaves_of_rings S is_open (im_sheaf.im_sheaf S 𝔉 (identity S)) (im_sheaf.im_sheaf_morphisms S ρ (identity S)) b
              (im_sheaf.add_im_sheaf S add_str (identity S)) (im_sheaf.mult_im_sheaf S mult_str (identity S)) (im_sheaf.zero_im_sheaf S zero_str (identity S)) (im_sheaf.one_im_sheaf S one_str (identity S)) 𝔉 ρ b add_str mult_str zero_str one_str ψ  (U. is_open U  (xim_sheaf.im_sheaf S 𝔉 (identity S) U. (identity (𝔉 U)  ψ U) x = x)  (x𝔉 U. (ψ U  identity (𝔉 U)) x = x))"
        using local.im_sheaf_def by auto
    qed
  qed
qed

end