text \<open>Authors: Anthony Bordg and Lawrence Paulson,
with some contributions from Wenda Li\<close>

theory Scheme
imports "Comm_Ring"

begin

section \<open>Misc\<close>

lemma (in Set_Theory.map) set_map_\<alpha>_cong:
  assumes \<alpha>_eq:"\<And>x. x\<in>S \<Longrightarrow> \<alpha>' x  = \<alpha> x" and \<alpha>_ext:"\<alpha>' \<in> extensional S"
  shows "Set_Theory.map \<alpha>' S T"
using map_axioms \<alpha>_eq \<alpha>_ext
unfolding Set_Theory.map_def by (auto simp:extensional_def)

lemma (in monoid_homomorphism) monoid_homomorphism_\<eta>_cong:
  assumes \<eta>_eq:"\<And>x. x\<in>M \<Longrightarrow> \<eta>' x  = \<eta> x" and \<eta>_ext:"\<eta>' \<in> extensional M"
  shows "monoid_homomorphism \<eta>' M (\<cdot>) \<one> M' (\<cdot>') \<one>'"
proof -
  have "Set_Theory.map \<eta>' M M'"
    using set_map_\<alpha>_cong \<eta>_eq \<eta>_ext by auto
  moreover have "monoid_homomorphism_axioms \<eta>' M (\<cdot>) \<one> (\<cdot>') \<one>'"
    unfolding monoid_homomorphism_axioms_def
    by (simp add: \<eta>_eq commutes_with_composition commutes_with_unit)
  ultimately show ?thesis
    unfolding monoid_homomorphism_def
    using source.monoid_axioms target.monoid_axioms by blast
qed

lemma (in group_homomorphism) group_homomorphism_\<eta>_cong:
  assumes \<eta>_eq:"\<And>x. x\<in>G \<Longrightarrow> \<eta>' x  = \<eta> x" and \<eta>_ext:"\<eta>' \<in> extensional G"
  shows "group_homomorphism \<eta>' G (\<cdot>) \<one> G' (\<cdot>') \<one>'"
  by (simp add: \<eta>_eq \<eta>_ext group_homomorphism_def monoid_homomorphism_\<eta>_cong source.group_axioms
      target.group_axioms)

lemma (in ring_homomorphism) ring_homomorphism_\<eta>_cong:
  assumes \<eta>_eq:"\<And>x. x\<in>R \<Longrightarrow> \<eta>' x  = \<eta> x" and \<eta>_ext:"\<eta>' \<in> extensional R"
  shows "ring_homomorphism \<eta>' R (+) (\<cdot>) \<zero> \<one> R' (+') (\<cdot>') \<zero>' \<one>'"
  unfolding ring_homomorphism_def
  using \<eta>_eq \<eta>_ext additive.group_homomorphism_\<eta>_cong multiplicative.monoid_homomorphism_\<eta>_cong
    set_map_\<alpha>_cong source.ring_axioms target.ring_axioms by presburger

lemma (in morphism_presheaves_of_rings) morphism_presheaves_of_rings_fam_cong:
  assumes fam_eq:"\<And>U x. \<lbrakk> is_open U; x\<in>\<FF> U\<rbrakk> \<Longrightarrow> fam_morphisms' U x= fam_morphisms U x"
    and fam_ext:"\<And>U. is_open U \<Longrightarrow> fam_morphisms' U \<in> extensional (\<FF> U)"
  shows "morphism_presheaves_of_rings X is_open \<FF> \<rho> b add_str mult_str zero_str one_str \<FF>' \<rho>' b'
      add_str' mult_str'
      zero_str' one_str' fam_morphisms'"
proof -
  have " presheaf_of_rings X is_open \<FF> \<rho> b add_str mult_str zero_str one_str"
    using source.presheaf_of_rings_axioms .
  moreover have "presheaf_of_rings X is_open \<FF>' \<rho>' b' add_str' mult_str' zero_str' one_str'"
    using target.presheaf_of_rings_axioms .
  moreover have "
    morphism_presheaves_of_rings_axioms is_open \<FF> \<rho> add_str mult_str zero_str one_str \<FF>' \<rho>' add_str' mult_str'
     zero_str' one_str' fam_morphisms'"
  proof -
    have "ring_homomorphism (fam_morphisms' U) (\<FF> U) +\<^bsub>U\<^esub> \<cdot>\<^bsub>U\<^esub> \<zero>\<^bsub>U\<^esub> \<one>\<^bsub>U\<^esub> (\<FF>' U) +'\<^bsub>U\<^esub> \<cdot>'\<^bsub>U\<^esub> \<zero>'\<^bsub>U\<^esub> \<one>'\<^bsub>U\<^esub>"
      if "is_open U" for U
      apply (rule is_ring_morphism[OF that,THEN ring_homomorphism.ring_homomorphism_\<eta>_cong])
      using fam_eq fam_ext
      by (auto simp add: that)
    moreover have "(\<rho>' U V \<circ> fam_morphisms' U) x = (fam_morphisms' V \<circ> \<rho> U V) x"
      if "is_open U" "is_open V" "V \<subseteq> U" "x \<in> \<FF> U" for U V x
      by (metis calculation comm_diagrams fam_eq fam_morphisms_are_maps map_eq ring_homomorphism_def
          that(1) that(2) that(3) that(4))
    ultimately show ?thesis
      using comm_diagrams is_ring_morphism
      unfolding morphism_presheaves_of_rings_axioms_def by auto
  qed
  ultimately show ?thesis
    unfolding morphism_presheaves_of_rings_def by auto
qed

section \<open>Affine Schemes\<close>

text \<open>Computational affine schemes take the isomorphism with Spec as part of their data,
while in the locale for affine schemes we merely assert the existence of such an isomorphism.\<close>

locale affine_scheme = comm_ring +
locally_ringed_space X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str +
iso_locally_ringed_spaces X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str
"Spec" is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b "\<lambda>U. add_sheaf_spec U"
"\<lambda>U. mult_sheaf_spec U" "\<lambda>U. zero_sheaf_spec U" "\<lambda>U. one_sheaf_spec U" f \<phi>\<^sub>f
for X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str f \<phi>\<^sub>f

section \<open>Schemes\<close>

(* def. 0.47 *)
locale scheme = locally_ringed_space X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str
  for X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str univ +
  assumes are_affine_schemes: "\<And>x. x \<in> X \<Longrightarrow> (\<exists>U. x\<in>U \<and> is_open U \<and>
(\<exists>R add mult zero one f \<phi>\<^sub>f. R \<subseteq> univ \<and> comm_ring R add mult zero one \<and>
  affine_scheme R add mult zero one U (ind_topology.ind_is_open X is_open U)
  (ind_sheaf.ind_sheaf \<O>\<^sub>X U)
(ind_sheaf.ind_ring_morphisms \<rho> U) b (ind_sheaf.ind_add_str add_str U)
(ind_sheaf.ind_mult_str mult_str U) (ind_sheaf.ind_zero_str zero_str U)
(ind_sheaf.ind_one_str one_str U) f \<phi>\<^sub>f))"

locale iso_stalks =
  stk1:stalk S is_open \<FF>1 \<rho>1 b add_str1 mult_str1 zero_str1 one_str1 I x +
  stk2:stalk S is_open \<FF>2 \<rho>2 b add_str2 mult_str2 zero_str2 one_str2 I x
  for S is_open \<FF>1 \<rho>1 b add_str1 mult_str1 zero_str1 one_str1 I x
        \<FF>2 \<rho>2 add_str2 mult_str2 zero_str2 one_str2 +
  assumes
    stalk_eq:"\<forall>U\<in>I. \<FF>1 U = \<FF>2 U \<and> add_str1 U = add_str2 U \<and> mult_str1 U = mult_str2 U
            \<and> zero_str1 U = zero_str2 U \<and> one_str1 U = one_str2 U"
    and stalk\<rho>_eq:"\<forall>U V. U\<in>I \<and> V \<in>I \<longrightarrow> \<rho>1 U V = \<rho>2 U V"
begin

lemma
  assumes "U \<in> I"
  shows has_ring_isomorphism:"ring_isomorphism (identity stk1.carrier_stalk) stk1.carrier_stalk
          stk1.add_stalk stk1.mult_stalk (stk1.zero_stalk U) (stk1.one_stalk U)
          stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk (stk2.zero_stalk U) (stk2.one_stalk U)"
   and carrier_stalk_eq:"stk1.carrier_stalk = stk2.carrier_stalk"
   and class_of_eq:"stk1.class_of = stk2.class_of"
proof -
  have "is_open U" "x \<in> U"
    using stk1.index assms by auto
  interpret ring1:ring stk1.carrier_stalk stk1.add_stalk stk1.mult_stalk "stk1.zero_stalk U"
                  "stk1.one_stalk U"
    using stk1.stalk_is_ring[OF \<open>is_open U\<close> \<open>x \<in> U\<close>] .
  interpret ring2:ring stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk "stk2.zero_stalk U"
                  "stk2.one_stalk U"
    using stk2.stalk_is_ring[OF \<open>is_open U\<close> \<open>x \<in> U\<close>] .

  interpret e1:equivalence "Sigma I \<FF>1" "{(x, y). stk1.rel x y}"
    using stk1.rel_is_equivalence .
  interpret e2:equivalence "Sigma I \<FF>2" "{(x, y). stk2.rel x y}"
    using stk2.rel_is_equivalence .

  have Sigma_eq:"Sigma I \<FF>1  =  Sigma I \<FF>2"
  proof (rule Sigma_cong[OF refl])
    fix x assume "x \<in> I"
    from stalk_eq[rule_format,OF this]
    show "\<FF>1 x = \<FF>2 x" by simp
  qed
  moreover have "stk1.rel xx yy \<longleftrightarrow> stk2.rel xx yy"
                  if "xx\<in>Sigma I \<FF>1" "yy\<in>Sigma I \<FF>2"
                  for xx yy
    unfolding stk1.rel_def stk2.rel_def
    by (metis stalk\<rho>_eq stalk_eq)
  ultimately have Class_eq: "e1.Class = e2.Class"
    unfolding e1.Class_def e2.Class_def
    by (auto intro!:ext)
  then show class_of_eq:"stk1.class_of = stk2.class_of"
    unfolding stk1.class_of_def stk2.class_of_def by auto

  show "stk1.carrier_stalk = stk2.carrier_stalk"
    using Class_eq Sigma_eq e1.natural.surjective e2.natural.surjective
      stk1.carrier_direct_lim_def stk1.carrier_stalk_def stk2.carrier_direct_lim_def
      stk2.carrier_stalk_def stk2.neighborhoods_eq by force

  let ?id = "identity stk1.carrier_stalk"
  show "ring_isomorphism (identity stk1.carrier_stalk) stk1.carrier_stalk
          stk1.add_stalk stk1.mult_stalk (stk1.zero_stalk U) (stk1.one_stalk U)
          stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk (stk2.zero_stalk U) (stk2.one_stalk U)"
  proof
    show "?id (stk1.one_stalk U) = stk2.one_stalk U"
    proof -
      have "stk1.one_stalk U \<in> stk1.carrier_stalk" by blast
      then have "?id (stk1.one_stalk U) = stk1.one_stalk U" by auto
      also have "... = stk2.one_stalk U"
        unfolding stk1.one_stalk_def stk2.one_stalk_def class_of_eq
        by (simp add: assms stalk_eq)
      finally show ?thesis .
    qed
    show "?id (stk1.zero_stalk U) = stk2.zero_stalk U"
    proof -
      have "stk1.zero_stalk U \<in> stk1.carrier_stalk" by blast
      then have "?id (stk1.zero_stalk U) = stk1.zero_stalk U" by auto
      also have "... = stk2.zero_stalk U"
        unfolding stk1.zero_stalk_def stk2.zero_stalk_def class_of_eq
        by (simp add: assms stalk_eq)
      finally show ?thesis .
    qed

    show "?id (stk1.add_stalk X' Y') = stk2.add_stalk (?id X') (?id Y')"
      "?id (stk1.mult_stalk X' Y') = stk2.mult_stalk (?id X') (?id Y')"
      if "X' \<in> stk1.carrier_stalk" "Y' \<in> stk1.carrier_stalk" for X' Y'
    proof -
      define x where "x=(SOME x. x \<in> X')"
      define y where "y=(SOME y. y \<in> Y')"
      have x:"x\<in>X'" "x\<in>Sigma I \<FF>1" and x_alt:"X' = stk1.class_of (fst x) (snd x)"
        using stk1.rel_carrier_Eps_in that(1) stk1.carrier_stalk_def stk2.neighborhoods_eq x_def
        by auto
      have y:"y\<in>Y'" "y\<in>Sigma I \<FF>1" and y_alt:"Y' = stk1.class_of (fst y) (snd y)"
        using stk1.rel_carrier_Eps_in that(2) stk1.carrier_stalk_def stk2.neighborhoods_eq y_def
        by auto
      obtain "fst x \<subseteq> S" "fst y \<subseteq> S"
        using x(2) y(2) stk1.index
        by (metis mem_Sigma_iff prod.collapse stk1.open_imp_subset stk2.subset_of_opens)
      obtain w where w: "w\<in>I" "w \<subseteq> fst x" "w \<subseteq> fst y"
        using stk1.has_lower_bound x(2) y(2) by force
      have "w \<subseteq> S"
        by (simp add: stk1.open_imp_subset stk1.subset_of_opens w(1))

      have "stk1.add_stalk X' Y' = stk1.class_of w (add_str1 w (\<rho>1 (fst x) w (snd x))
                                         (\<rho>1 (fst y) w (snd y)))"
        unfolding x_alt y_alt stk1.add_stalk_def
        apply (subst stk1.add_rel_class_of[where W=w])
        using x y w by auto
      also have "... = stk2.class_of w (add_str2 w (\<rho>2 (fst x) w (snd x)) (\<rho>2 (fst y) w (snd y)))"
        using class_of_eq stalk\<rho>_eq stalk_eq w(1) x(2) y(2) by force
      also have "... = stk2.add_stalk X' Y'"
        unfolding stk2.add_stalk_def x_alt y_alt class_of_eq
        apply (subst stk2.add_rel_class_of[where W=w])
        using x y w by (auto simp add: Sigma_eq)
      finally have "stk1.add_stalk X' Y' = stk2.add_stalk X' Y'" .
      moreover have "stk1.add_stalk X' Y' \<in> stk1.carrier_stalk"
        by (simp add: that(1) that(2))
      ultimately show "?id (stk1.add_stalk X' Y') = stk2.add_stalk (?id X') (?id Y')"
        using that by simp

      have "stk1.mult_stalk X' Y' = stk1.class_of w (mult_str1 w (\<rho>1 (fst x) w (snd x))
                                         (\<rho>1 (fst y) w (snd y)))"
        unfolding x_alt y_alt stk1.mult_stalk_def
        apply (subst stk1.mult_rel_class_of[where W=w])
        using x y w by auto
      also have "... = stk2.class_of w (mult_str2 w (\<rho>2 (fst x) w (snd x)) (\<rho>2 (fst y) w (snd y)))"
        using class_of_eq stalk\<rho>_eq stalk_eq w(1) x(2) y(2) by force
      also have "... = stk2.mult_stalk X' Y'"
        unfolding stk2.mult_stalk_def x_alt y_alt class_of_eq
        apply (subst stk2.mult_rel_class_of[where W=w])
        using x y w by (auto simp add: Sigma_eq)
      finally have "stk1.mult_stalk X' Y' = stk2.mult_stalk X' Y'" .
      moreover have "stk1.mult_stalk X' Y' \<in> stk1.carrier_stalk"
        by (simp add: that(1) that(2))
      ultimately show "?id (stk1.mult_stalk X' Y') = stk2.mult_stalk (?id X') (?id Y')"
        using that by simp
    qed

    from \<open>stk1.carrier_stalk = stk2.carrier_stalk\<close>
    show "?id \<in> stk1.carrier_stalk \<rightarrow>\<^sub>E stk2.carrier_stalk"
      "bij_betw ?id stk1.carrier_stalk stk2.carrier_stalk"
      by (auto simp flip: id_def)
  qed
qed
end

lemma (in affine_scheme) affine_scheme_is_scheme:
  shows "scheme X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str (UNIV::'a set)"
proof -
  interpret ind_sheaf X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str X
    by (metis ind_sheaf_axioms_def ind_sheaf_def open_space ringed_space_axioms ringed_space_def)
  have ind_is_open[simp]: "ind_topology.ind_is_open X is_open X = is_open"
    by (rule ext) (meson ind_is_open_iff_open open_imp_subset)

  interpret sheaf_of_rings X is_open local.ind_sheaf ind_ring_morphisms b ind_add_str
    ind_mult_str ind_zero_str ind_one_str
    using ind_sheaf_is_sheaf by force

  have eq_\<O>\<^sub>X: "local.ind_sheaf U = \<O>\<^sub>X U" if "U \<subseteq> X" for U
    using that by (simp add: Int_absorb2 Int_commute local.ind_sheaf_def)
  have eq_\<rho>: "\<And>U V. U \<subseteq> X \<and> V \<subseteq> X \<Longrightarrow> ind_ring_morphisms U V = \<rho> U V"
    by (simp add: ind_ring_morphisms_def inf.absorb_iff2)
  have eq_add_str: "\<And>U. U \<subseteq> X \<Longrightarrow> ind_add_str U = add_str U"
    by (simp add: ind_add_str_def inf.absorb_iff2)
  have eq_mult_str : "\<And>U. U \<subseteq> X \<Longrightarrow> ind_mult_str U = mult_str U"
    by (simp add: ind_mult_str_def inf.absorb_iff2)
  have eq_zero_str : "\<And>U. U \<subseteq> X \<Longrightarrow> ind_zero_str U = zero_str U"
    by (simp add: Int_absorb2 Int_commute ind_zero_str_def)
  have eq_one_str : "\<And>U. U \<subseteq> X \<Longrightarrow> ind_one_str U = one_str U"
    by (simp add: ind_one_str_def inf.absorb_iff2)

  have "affine_scheme R (+) (\<cdot>) \<zero> \<one> X is_open local.ind_sheaf ind_ring_morphisms b
          ind_add_str ind_mult_str ind_zero_str ind_one_str f \<phi>\<^sub>f"
  proof -
    have "locally_ringed_space X is_open local.ind_sheaf ind_ring_morphisms b ind_add_str ind_mult_str ind_zero_str
     ind_one_str"
    proof -
      have "stalk.is_local is_open local.ind_sheaf ind_ring_morphisms ind_add_str
                ind_mult_str ind_zero_str ind_one_str
                (neighborhoods u) u U"
        if "u \<in> U" and opeU: "is_open U" for u U
      proof -
        have UX: "U \<subseteq> X" by (simp add: opeU open_imp_subset)

        interpret stX: stalk X is_open local.ind_sheaf ind_ring_morphisms b ind_add_str
          ind_mult_str ind_zero_str ind_one_str "neighborhoods u" u
          apply (unfold_locales)
          unfolding neighborhoods_def using \<open>U \<subseteq> X\<close> \<open>u\<in>U\<close> by auto
        interpret stalk X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str "neighborhoods u" u
          by (meson direct_lim_def ind_sheaf.axioms(1) ind_sheaf_axioms stX.stalk_axioms stalk_def)

        have "local_ring carrier_stalk add_stalk mult_stalk (zero_stalk U) (one_stalk U)"
          using is_local_def opeU stalks_are_local that(1) by blast
        moreover have "ring_isomorphism (identity stX.carrier_stalk)
            stX.carrier_stalk stX.add_stalk stX.mult_stalk (stX.zero_stalk U) (stX.one_stalk U)
            carrier_stalk add_stalk mult_stalk (zero_stalk U) (one_stalk U)"
        proof -
          interpret iso_stalks X is_open local.ind_sheaf ind_ring_morphisms b ind_add_str
              ind_mult_str ind_zero_str ind_one_str "neighborhoods u" u \<O>\<^sub>X \<rho>  add_str mult_str
              zero_str one_str
            apply unfold_locales
            subgoal
              by (simp add: eq_\<O>\<^sub>X eq_add_str eq_mult_str eq_one_str eq_zero_str open_imp_subset
                  subset_of_opens)
            subgoal using eq_\<rho> open_imp_subset subset_of_opens by auto
            done
          have "U \<in> neighborhoods u"
            by (simp add: opeU stX.index that(1))
          from has_ring_isomorphism[OF this]
          show ?thesis .
        qed
        ultimately show ?thesis unfolding stX.is_local_def
          using isomorphic_to_local_is_local by fast
      qed
      then show ?thesis
        by (simp add: locally_ringed_space_axioms_def locally_ringed_space_def
            ringed_space_def sheaf_of_rings_axioms)
    qed
    moreover have "iso_locally_ringed_spaces X is_open local.ind_sheaf ind_ring_morphisms b
        ind_add_str ind_mult_str ind_zero_str ind_one_str Spec is_zariski_open sheaf_spec
        sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec f \<phi>\<^sub>f"
    proof-
      interpret im_sheafXS: Comm_Ring.im_sheaf X is_open local.ind_sheaf
              ind_ring_morphisms b ind_add_str ind_mult_str ind_zero_str ind_one_str Spec
              is_zariski_open f
        by intro_locales
      interpret iso_sheaves_of_rings Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b
          add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec local.im_sheaf
          im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf \<phi>\<^sub>f
        using is_iso_of_sheaves by blast

      have ring_homoU:"ring_homomorphism (\<phi>\<^sub>f U) (\<O> U) (add_sheaf_spec U) (mult_sheaf_spec U) (zero_sheaf_spec U)
          (one_sheaf_spec U) (im_sheafXS.im_sheaf U) (im_sheafXS.add_im_sheaf U) (im_sheafXS.mult_im_sheaf U)
          (im_sheafXS.zero_im_sheaf U) (im_sheafXS.one_im_sheaf U)"
        if "is_zariski_open U " for U
        using mor.is_ring_morphism
        by (metis Int_commute Int_left_absorb add_im_sheaf_def im_sheafXS.add_im_sheaf_def
            im_sheafXS.im_sheaf_def im_sheafXS.mult_im_sheaf_def im_sheafXS.one_im_sheaf_def
            im_sheafXS.zero_im_sheaf_def ind_add_str_def ind_mult_str_def ind_one_str_def
            ind_zero_str_def local.im_sheaf_def local.ind_sheaf_def
            mult_im_sheaf_def one_im_sheaf_def that zero_im_sheaf_def)

      note ring_homoU
      moreover have "(\<forall>U V. is_zariski_open U \<longrightarrow>
       is_zariski_open V \<longrightarrow>
       V \<subseteq> U \<longrightarrow>
       (\<forall>x. x \<in> \<O> U \<longrightarrow> (im_sheafXS.im_sheaf_morphisms U V \<circ> \<phi>\<^sub>f U) x = (\<phi>\<^sub>f V \<circ> sheaf_spec_morphisms U V) x))"
        using eq_\<rho> im_sheafXS.im_sheaf_morphisms_def im_sheaf_morphisms_def mor.comm_diagrams by auto
      ultimately interpret morphism_ringed_spaces X is_open local.ind_sheaf ind_ring_morphisms b
          ind_add_str ind_mult_str ind_zero_str ind_one_str Spec is_zariski_open sheaf_spec
          sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec
          zero_sheaf_spec one_sheaf_spec f \<phi>\<^sub>f
        apply intro_locales
        unfolding morphism_ringed_spaces_axioms_def morphism_ringed_spaces_def
        apply intro_locales
        unfolding morphism_presheaves_of_rings_axioms_def
        by auto

      have "iso_locally_ringed_spaces X is_open local.ind_sheaf ind_ring_morphisms b
            ind_add_str ind_mult_str ind_zero_str ind_one_str
            Spec is_zariski_open sheaf_spec sheaf_spec_morphisms
            \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec f \<phi>\<^sub>f"
        apply intro_locales
        subgoal
        proof -
          have "ind_mor_btw_stalks.is_local X is_open local.ind_sheaf ind_ring_morphisms ind_add_str
                ind_mult_str ind_zero_str ind_one_str is_zariski_open sheaf_spec sheaf_spec_morphisms
                add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec f x U
               \<phi>\<^bsub>X is_open local.ind_sheaf ind_ring_morphisms is_zariski_open sheaf_spec
                        sheaf_spec_morphisms f \<phi>\<^sub>f x\<^esub>"
            if "x \<in> X" "is_zariski_open U" "f x \<in> U" for x U
          proof -
            interpret ind_btw:ind_mor_btw_stalks X is_open local.ind_sheaf ind_ring_morphisms b ind_add_str
                ind_mult_str ind_zero_str ind_one_str Spec is_zariski_open sheaf_spec
                sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec
                zero_sheaf_spec one_sheaf_spec f \<phi>\<^sub>f x
              apply intro_locales
              using \<open>x \<in> X\<close> by (simp add: ind_mor_btw_stalks_axioms.intro)

            interpret ind_mor_btw_stalks X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str
                Spec is_zariski_open sheaf_spec
                sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec
                zero_sheaf_spec one_sheaf_spec f \<phi>\<^sub>f x
              apply intro_locales
              using \<open>x \<in> X\<close> by (simp add: ind_mor_btw_stalks_axioms.intro)

            interpret stk1:stalk X is_open \<O>\<^sub>X \<rho> b add_str mult_str zero_str one_str
                              "{U. is_open U \<and> x \<in> U}" x
              apply unfold_locales
              using \<open>x \<in> X\<close> by auto
            interpret stk2:stalk X is_open local.ind_sheaf ind_ring_morphisms b ind_add_str
                ind_mult_str ind_zero_str ind_one_str "{U. is_open U \<and> x \<in> U}" x
              apply unfold_locales
              using \<open>x \<in> X\<close> by auto
            interpret stk3:stalk Spec is_zariski_open sheaf_spec
                sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec
                zero_sheaf_spec one_sheaf_spec "{U. is_zariski_open U \<and> f x \<in> U}" "f x"
              apply unfold_locales
              by (auto simp add: stk2.is_elem)
            interpret ring31:ring_homomorphism induced_morphism stk3.carrier_stalk stk3.add_stalk
              stk3.mult_stalk "stk3.zero_stalk U" "stk3.one_stalk U" stk1.carrier_stalk
              stk1.add_stalk stk1.mult_stalk "stk1.zero_stalk (f \<^sup>\<inverse> X U)" "stk1.one_stalk (f \<^sup>\<inverse> X U)"
              using ring_homomorphism_induced_morphism[OF \<open>is_zariski_open U\<close> \<open>f x \<in> U\<close>] .
            interpret ring32:ring_homomorphism ind_btw.induced_morphism stk3.carrier_stalk
              stk3.add_stalk
              stk3.mult_stalk "stk3.zero_stalk U" "stk3.one_stalk U" stk2.carrier_stalk
              stk2.add_stalk stk2.mult_stalk "stk2.zero_stalk (f \<^sup>\<inverse> X U)" "stk2.one_stalk (f \<^sup>\<inverse> X U)"
              using ind_btw.ring_homomorphism_induced_morphism[OF \<open>is_zariski_open U\<close> \<open>f x \<in> U\<close>] .

            interpret iso:iso_stalks X is_open \<O>\<^sub>X \<rho>  b add_str mult_str zero_str one_str
                      "{U. is_open U \<and> x \<in> U}" x local.ind_sheaf ind_ring_morphisms
                      ind_add_str
                      ind_mult_str ind_zero_str ind_one_str
              apply unfold_locales
              subgoal
                by (metis eq_\<O>\<^sub>X eq_add_str eq_mult_str eq_one_str eq_zero_str open_imp_subset
                    stk2.subset_of_opens)
              subgoal
                using eq_\<rho> open_imp_subset stk2.subset_of_opens by presburger
              done
            have fU:"f \<^sup>\<inverse> X U \<in> {U. is_open U \<and> x \<in> U}"
              using is_continuous[OF \<open>is_zariski_open U\<close>]
              using stk2.is_elem that(3) by blast

            have is_local:"is_local U induced_morphism"
              using are_local_morphisms[of x U] using that by auto
            from this[unfolded is_local_def]
            have "local_ring_morphism (identity stk2.carrier_stalk \<circ> induced_morphism \<down> stk3.carrier_stalk)
                    stk3.carrier_stalk stk3.add_stalk stk3.mult_stalk (stk3.zero_stalk U)
                    (stk3.one_stalk U) stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk
                     (stk2.zero_stalk (f \<^sup>\<inverse> X U)) (stk2.one_stalk (f \<^sup>\<inverse> X U))"
            proof (elim comp_of_local_ring_morphisms)
              interpret local_ring_morphism induced_morphism stk3.carrier_stalk stk3.add_stalk
                stk3.mult_stalk "stk3.zero_stalk U" "stk3.one_stalk U" stk1.carrier_stalk
                stk1.add_stalk stk1.mult_stalk "stk1.zero_stalk (f \<^sup>\<inverse> X U)"
                "stk1.one_stalk (f \<^sup>\<inverse> X U)"
                using is_local[unfolded is_local_def] .

              have "local_ring stk1.carrier_stalk stk1.add_stalk stk1.mult_stalk
                      (stk1.zero_stalk (f \<^sup>\<inverse> X U)) (stk1.one_stalk (f \<^sup>\<inverse> X U))"
                using target.local_ring_axioms .
              moreover have "ring_isomorphism (identity stk1.carrier_stalk) stk1.carrier_stalk
                    stk1.add_stalk stk1.mult_stalk (stk1.zero_stalk (f \<^sup>\<inverse> X U))
                    (stk1.one_stalk (f \<^sup>\<inverse> X U)) stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk
                    (stk2.zero_stalk (f \<^sup>\<inverse> X U)) (stk2.one_stalk (f \<^sup>\<inverse> X U))"
                using iso.has_ring_isomorphism[OF fU] .
              ultimately have "local_ring_morphism (identity stk1.carrier_stalk) stk1.carrier_stalk
                    stk1.add_stalk stk1.mult_stalk (stk1.zero_stalk (f \<^sup>\<inverse> X U))
                    (stk1.one_stalk (f \<^sup>\<inverse> X U)) stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk
                    (stk2.zero_stalk (f \<^sup>\<inverse> X U)) (stk2.one_stalk (f \<^sup>\<inverse> X U))"
                by (rule iso_is_local_ring_morphism)
              then show "local_ring_morphism (identity stk2.carrier_stalk) stk1.carrier_stalk
                    stk1.add_stalk stk1.mult_stalk (stk1.zero_stalk (f \<^sup>\<inverse> X U))
                    (stk1.one_stalk (f \<^sup>\<inverse> X U)) stk2.carrier_stalk stk2.add_stalk stk2.mult_stalk
                    (stk2.zero_stalk (f \<^sup>\<inverse> X U)) (stk2.one_stalk (f \<^sup>\<inverse> X U))"
                using iso.carrier_stalk_eq[OF fU] by simp
            qed
            moreover have "identity stk2.carrier_stalk \<circ> induced_morphism \<down> stk3.carrier_stalk
                              = ind_btw.induced_morphism"
            proof -
              have "(identity stk2.carrier_stalk \<circ> induced_morphism \<down> stk3.carrier_stalk) x
                        = ind_btw.induced_morphism x" (is "?L=?R") if "x\<in>stk3.carrier_stalk" for x
              proof -
                have "?L = identity stk2.carrier_stalk (induced_morphism x)"
                  unfolding compose_def using that by simp
                also have "... = induced_morphism x"
                  using that iso.carrier_stalk_eq[OF fU] by auto
                also have "... = ?R"
                  unfolding induced_morphism_def ind_btw.induced_morphism_def
                  using iso.class_of_eq[OF fU] by auto
                finally show ?thesis .
              qed
              then show ?thesis unfolding ind_btw.induced_morphism_def compose_def
                by (smt (verit, best) restrict_apply' restrict_ext)
            qed
            ultimately show ?thesis unfolding is_local_def ind_btw.is_local_def
              by auto
          qed
          then show ?thesis
            by (simp add: morphism_locally_ringed_spaces_axioms_def)
        qed
        subgoal
        proof -
          obtain \<psi> where  \<psi>_morph:"morphism_presheaves_of_rings Spec is_zariski_open local.im_sheaf
            im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf sheaf_spec
            sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec \<psi>"
            and \<psi>_comp:"(\<forall>U. is_zariski_open U \<longrightarrow> (\<forall>x\<in>local.im_sheaf U. (\<phi>\<^sub>f U \<circ> \<psi> U) x = x)
                      \<and> (\<forall>x\<in>\<O> U. (\<psi> U \<circ> \<phi>\<^sub>f U) x = x))"
            using is_inv by auto

          interpret \<psi>_morph:morphism_presheaves_of_rings Spec is_zariski_open local.im_sheaf
            im_sheaf_morphisms b add_im_sheaf mult_im_sheaf zero_im_sheaf one_im_sheaf sheaf_spec
            sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec \<psi>
            using \<psi>_morph .

          have "morphism_presheaves_of_rings Spec is_zariski_open
                  im_sheafXS.im_sheaf im_sheafXS.im_sheaf_morphisms b im_sheafXS.add_im_sheaf
                  im_sheafXS.mult_im_sheaf im_sheafXS.zero_im_sheaf im_sheafXS.one_im_sheaf
                  im_sheaf im_sheaf_morphisms b add_im_sheaf
                  mult_im_sheaf zero_im_sheaf one_im_sheaf (\<lambda>U. identity (im_sheafXS.im_sheaf U))"
          proof -
            have "ring_homomorphism (identity (im_sheafXS.im_sheaf U)) (im_sheafXS.im_sheaf U)
                  (im_sheafXS.add_im_sheaf U) (im_sheafXS.mult_im_sheaf U) (im_sheafXS.zero_im_sheaf U)
                  (im_sheafXS.one_im_sheaf U) (local.im_sheaf U) (add_im_sheaf U) (mult_im_sheaf U)
                  (zero_im_sheaf U) (one_im_sheaf U)"
              if "is_zariski_open U" for U
            proof -
              have "bijective_map (\<phi>\<^sub>f U \<circ> \<psi> U \<down> local.im_sheaf U) (local.im_sheaf U)
                                    (im_sheafXS.im_sheaf U)"
                apply unfold_locales
                subgoal
                  by (smt (verit, ccfv_threshold) Int_commute Int_left_absorb Pi_I \<psi>_comp
                      compose_def im_sheafXS.im_sheaf_def local.im_sheaf_def local.ind_sheaf_def
                      o_apply restrict_PiE that)
                subgoal
                  by (smt (verit, best) \<psi>_comp bij_betw_iff_bijections comp_apply compose_eq eq_\<O>\<^sub>X
                      im_sheafXS.im_sheaf_def is_continuous local.im_sheaf_def open_imp_subset that)
                done
              with comp_ring_morphisms[OF \<psi>_morph.is_ring_morphism[OF that] ring_homoU[OF that]]
              interpret ring_isomorphism "\<phi>\<^sub>f U \<circ> \<psi> U \<down> local.im_sheaf U" "local.im_sheaf U"
                "add_im_sheaf U" "mult_im_sheaf U" "zero_im_sheaf U" "one_im_sheaf U"
                "im_sheafXS.im_sheaf U" "im_sheafXS.add_im_sheaf U" "im_sheafXS.mult_im_sheaf U"
                "im_sheafXS.zero_im_sheaf U" "im_sheafXS.one_im_sheaf U"
                using ring_isomorphism.intro by fast

              have "ring_homomorphism (restrict (inv_into (local.im_sheaf U)
                      (\<phi>\<^sub>f U \<circ> \<psi> U \<down> local.im_sheaf U)) (im_sheafXS.im_sheaf U))
                      (im_sheafXS.im_sheaf U) (im_sheafXS.add_im_sheaf U)
                      (im_sheafXS.mult_im_sheaf U) (im_sheafXS.zero_im_sheaf U)
                      (im_sheafXS.one_im_sheaf U) (local.im_sheaf U) (add_im_sheaf U)
                      (mult_im_sheaf U) (zero_im_sheaf U) (one_im_sheaf U)"
                using inverse_ring_isomorphism[unfolded ring_isomorphism_def] by auto
              moreover have "(restrict (inv_into (local.im_sheaf U)
                      (\<phi>\<^sub>f U \<circ> \<psi> U \<down> local.im_sheaf U)) (im_sheafXS.im_sheaf U))
                       = identity (im_sheafXS.im_sheaf U)"
                by (smt (verit, best) Int_commute Int_left_absorb \<psi>_comp compose_eq
                    im_sheafXS.im_sheaf_def injective inv_into_f_f local.im_sheaf_def
                    local.ind_sheaf_def o_apply restrict_ext that)
              ultimately show ?thesis by auto
            qed
            moreover have "(im_sheaf_morphisms U V \<circ> identity (im_sheafXS.im_sheaf U)) x =
                (identity (im_sheafXS.im_sheaf V) \<circ> im_sheafXS.im_sheaf_morphisms U V) x"
              (is "?L=?R")
              if "is_zariski_open U" "is_zariski_open V" "V \<subseteq> U" "x \<in> im_sheafXS.im_sheaf U"
              for U V x
            proof -
              have "?L = im_sheaf_morphisms U V x"
                by (simp add: that(4))
              also have "... = im_sheafXS.im_sheaf_morphisms U V x"
                by (simp add: eq_\<rho> im_sheafXS.im_sheaf_morphisms_def im_sheaf_morphisms_def)
              also have "... = ?R"
                using im_sheafXS.is_map_from_is_homomorphism[OF that(1,2,3)] map.map_closed that(4)
                by fastforce
              finally show ?thesis .
            qed
            ultimately show ?thesis
              apply intro_locales
              unfolding morphism_presheaves_of_rings_axioms_def by auto
          qed
          from comp_of_presheaves[OF this \<psi>_morph]
          have "morphism_presheaves_of_rings Spec is_zariski_open im_sheafXS.im_sheaf
                  im_sheafXS.im_sheaf_morphisms b im_sheafXS.add_im_sheaf im_sheafXS.mult_im_sheaf
                im_sheafXS.zero_im_sheaf im_sheafXS.one_im_sheaf sheaf_spec
              sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
                (\<lambda>U. \<psi> U \<circ> identity (im_sheafXS.im_sheaf U) \<down> im_sheafXS.im_sheaf U)"
            by simp
          then have "morphism_presheaves_of_rings Spec is_zariski_open im_sheafXS.im_sheaf
            im_sheafXS.im_sheaf_morphisms b im_sheafXS.add_im_sheaf im_sheafXS.mult_im_sheaf
            im_sheafXS.zero_im_sheaf im_sheafXS.one_im_sheaf sheaf_spec sheaf_spec_morphisms \<O>b
            add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec \<psi>"
          proof (elim morphism_presheaves_of_rings.morphism_presheaves_of_rings_fam_cong)
            fix U x assume "is_zariski_open U" "x \<in> im_sheafXS.im_sheaf U"
            then show " \<psi> U x = (\<psi> U \<circ> identity (im_sheafXS.im_sheaf U) \<down> im_sheafXS.im_sheaf U) x"
              by (simp add: compose_eq)
          next
            show "\<And>U. is_zariski_open U \<Longrightarrow> \<psi> U \<in> extensional (im_sheafXS.im_sheaf U)"
              by (metis PiE_iff \<psi>_morph.fam_morphisms_are_maps eq_\<O>\<^sub>X im_sheafXS.im_sheaf_def
                  is_continuous local.im_sheaf_def map.graph open_imp_subset)
          qed
          moreover have " (\<forall>U. is_zariski_open U \<longrightarrow> (\<forall>x\<in>im_sheafXS.im_sheaf U. (\<phi>\<^sub>f U \<circ> \<psi> U) x = x)
                        \<and> (\<forall>x\<in>\<O> U. (\<psi> U \<circ> \<phi>\<^sub>f U) x = x))"
            using \<psi>_comp
            by (metis Int_commute Int_left_absorb im_sheafXS.im_sheaf_def local.im_sheaf_def
                local.ind_sheaf_def)
          moreover have "homeomorphism X is_open Spec is_zariski_open f"
            using is_homeomorphism by blast
          ultimately show ?thesis
            unfolding iso_locally_ringed_spaces_axioms_def
            apply clarify
            apply (auto intro!: iso_presheaves_of_rings.intro iso_sheaves_of_rings.intro
                        simp:iso_presheaves_of_rings_axioms_def)
            by (meson is_morphism_of_sheaves morphism_sheaves_of_rings.axioms)
        qed
        done
      then show ?thesis by (simp add: iso_locally_ringed_spaces_def)
    qed
    ultimately show ?thesis
      unfolding affine_scheme_def using comm_ring_axioms by auto
  qed
  moreover have "is_open X" by simp
  ultimately show ?thesis
    by unfold_locales (fastforce intro: affine_scheme.axioms(1))
qed

lemma (in comm_ring) spec_is_affine_scheme:
  shows "affine_scheme R (+) (\<cdot>) \<zero> \<one> Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b
(\<lambda>U. add_sheaf_spec U) (\<lambda>U. mult_sheaf_spec U) (\<lambda>U. zero_sheaf_spec U) (\<lambda>U. one_sheaf_spec U)
(identity Spec) (\<lambda>U. identity (\<O> U))"
proof (intro affine_scheme.intro)
  show "comm_ring R (+) (\<cdot>) \<zero> \<one>" by (simp add: local.comm_ring_axioms)
next
  show "locally_ringed_space Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec
     zero_sheaf_spec one_sheaf_spec" using spec_is_locally_ringed_space by simp
next
  have [simp]: "\<And>x A. x \<in> A \<Longrightarrow> inv_into A (identity A) x = x"
    by (metis bij_betw_def bij_betw_restrict_eq inj_on_id2 inv_into_f_f restrict_apply')
  interpret zar: topological_space Spec is_zariski_open
    by blast
  interpret im_sheaf Spec is_zariski_open sheaf_spec
    sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec Spec
    is_zariski_open "identity Spec"
    by (metis homeomorphism_def im_sheaf_def sheaf_spec_is_sheaf zar.id_is_homeomorphism)
  have rh: "\<And>U V. \<lbrakk>is_zariski_open U; is_zariski_open V; V \<subseteq> U\<rbrakk>
             \<Longrightarrow> ring_homomorphism
                  (im_sheaf_morphisms U V)
                  (local.im_sheaf U) (add_sheaf_spec U)
                  (mult_sheaf_spec U) (zero_sheaf_spec U)
                  (one_sheaf_spec U) (local.im_sheaf V)
                  (add_sheaf_spec V) (mult_sheaf_spec V)
                  (zero_sheaf_spec V) (one_sheaf_spec V)"
    using im_sheaf_morphisms_def local.im_sheaf_def sheaf_spec_morphisms_are_ring_morphisms zar.open_preimage_identity by presburger
  interpret F: presheaf_of_rings Spec is_zariski_open
    "im_sheaf.im_sheaf Spec sheaf_spec (identity Spec)"
    "im_sheaf.im_sheaf_morphisms Spec sheaf_spec_morphisms (identity Spec)" \<O>b
    "\<lambda>V. add_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)" "\<lambda>V. mult_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)"
    "\<lambda>V. zero_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)"  "\<lambda>V. one_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)"
    unfolding presheaf_of_rings_def presheaf_of_rings_axioms_def
  proof (intro conjI strip)
    show "im_sheaf_morphisms U W x = (im_sheaf_morphisms V W \<circ> im_sheaf_morphisms U V) x"
      if "is_zariski_open U" "is_zariski_open V" "is_zariski_open W" "V \<subseteq> U"
        and "W \<subseteq> V" "x \<in> local.im_sheaf U" for U V W x
      using that assoc_comp by blast
  qed (auto simp: rh ring_of_empty)

  show "iso_locally_ringed_spaces Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b
     add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec Spec is_zariski_open sheaf_spec
     sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
     (identity Spec) (\<lambda>U. identity (\<O> U))"
  proof -
    have "iso_sheaves_of_rings
            Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
            (im_sheaf.im_sheaf Spec sheaf_spec (identity Spec))
            (im_sheaf.im_sheaf_morphisms Spec sheaf_spec_morphisms (identity Spec))
            \<O>b
            (\<lambda>V x y. add_sheaf_spec ((identity Spec)\<^sup>\<inverse> Spec V) x y)
            (\<lambda>V x y. mult_sheaf_spec ((identity Spec)\<^sup>\<inverse> Spec V) x y)
            (\<lambda>V. zero_sheaf_spec ((identity Spec)\<^sup>\<inverse> Spec V))
            (\<lambda>V. one_sheaf_spec ((identity Spec)\<^sup>\<inverse> Spec V))
            (\<lambda>U. identity (\<O> U))"
    proof intro_locales
      show "morphism_presheaves_of_rings_axioms is_zariski_open sheaf_spec sheaf_spec_morphisms add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec (im_sheaf.im_sheaf Spec sheaf_spec (identity Spec)) (im_sheaf.im_sheaf_morphisms Spec sheaf_spec_morphisms (identity Spec)) (\<lambda>V. add_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>V. mult_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>V. zero_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>V. one_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>U. identity (\<O> U))"
        using F.id_is_mor_pr_rngs
        by (simp add: local.im_sheaf_def morphism_presheaves_of_rings_def morphism_presheaves_of_rings_axioms_def im_sheaf_morphisms_def)
      then show "iso_presheaves_of_rings_axioms Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec (im_sheaf.im_sheaf Spec sheaf_spec (identity Spec)) (im_sheaf.im_sheaf_morphisms Spec sheaf_spec_morphisms (identity Spec)) \<O>b (\<lambda>V. add_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>V. mult_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>V. zero_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>V. one_sheaf_spec (identity Spec \<^sup>\<inverse> Spec V)) (\<lambda>U. identity (\<O> U))"
        unfolding iso_presheaves_of_rings_axioms_def
        apply (rule_tac x="(\<lambda>U. identity (\<O> U))" in exI)
        using F.presheaf_of_rings_axioms
        by (simp add: im_sheaf_morphisms_def local.im_sheaf_def morphism_presheaves_of_rings.intro morphism_presheaves_of_rings_axioms_def sheaf_spec_is_presheaf)
    qed
    moreover have "morphism_locally_ringed_spaces
                    Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
                    Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b add_sheaf_spec mult_sheaf_spec zero_sheaf_spec one_sheaf_spec
                    (identity Spec)
                    (\<lambda>U. identity (\<O> U))"
      by (simp add: locally_ringed_space.id_to_mor_locally_ringed_spaces spec_is_locally_ringed_space)
    ultimately show ?thesis
      by (metis locally_ringed_space.id_to_iso_locally_ringed_spaces spec_is_locally_ringed_space)
  qed
qed

lemma (in comm_ring) spec_is_scheme:
  shows "scheme Spec is_zariski_open sheaf_spec sheaf_spec_morphisms \<O>b
(\<lambda>U. add_sheaf_spec U) (\<lambda>U. mult_sheaf_spec U) (\<lambda>U. zero_sheaf_spec U) (\<lambda>U. one_sheaf_spec U)
  (UNIV::'a set)"
  by (metis spec_is_affine_scheme affine_scheme.affine_scheme_is_scheme)

lemma empty_scheme_is_affine_scheme:
  shows "affine_scheme {0::nat} (\<lambda>x y. 0) (\<lambda>x y. 0) 0 0
{} (\<lambda>U. U={}) (\<lambda>U. {0::nat}) (\<lambda>U V. identity{0}) 0 (\<lambda>U x y. 0) (\<lambda>U x y. 0) (\<lambda>U. 0) (\<lambda>U. 0)
(\<lambda>\<pp>\<in>Spec. undefined) (\<lambda>U. \<lambda>s \<in> cring0.sheaf_spec U. 0)"
proof -
  interpret im0: im_sheaf "{}" "\<lambda>U. U = {}" "\<lambda>U. {0}" "\<lambda>U V. identity {0}"
    "0" "\<lambda>U x y. 0" "\<lambda>U x y. 0" "\<lambda>U. 0" "\<lambda>U. 0" "{}" "\<lambda>U. U = {}" "\<lambda>\<pp>\<in>Spec. undefined"
  proof qed (use invertible_0 in auto)
  note im0.target.open_space [simp del] im0.ring_of_empty [simp del] im0.open_space [simp del]
  have cring0_open [simp]: "\<And>N. cring0.is_zariski_open N \<longleftrightarrow> N = {}"
    by (metis comm_ring.cring0_is_zariski_open cring0.comm_ring_axioms)
  have ring_im: "ring (im0.im_sheaf V) (im0.add_im_sheaf V) (im0.mult_im_sheaf V) (im0.zero_im_sheaf V) (im0.one_im_sheaf V)"
    for V :: "nat set set"
  proof intro_locales
    show "Group_Theory.monoid (im0.im_sheaf V) (im0.add_im_sheaf V) (im0.zero_im_sheaf V)"
      unfolding im0.add_im_sheaf_def im0.im_sheaf_def im0.zero_im_sheaf_def monoid_def
      by force
    then show "Group_Theory.group_axioms (im0.im_sheaf V) (im0.add_im_sheaf V) (im0.zero_im_sheaf V)"
      unfolding Group_Theory.group_axioms_def im0.im_sheaf_def im0.zero_im_sheaf_def im0.add_im_sheaf_def
      by (simp add: invertible_0)
    show "commutative_monoid_axioms (im0.im_sheaf V) (im0.add_im_sheaf V)"
      by (metis im0.add_im_sheaf_def commutative_monoid_axioms.intro)
  qed (auto simp: im0.im_sheaf_def im0.add_im_sheaf_def im0.mult_im_sheaf_def im0.one_im_sheaf_def monoid_def ring_axioms_def)
  have rh0: "ring_homomorphism (cring0.sheaf_spec_morphisms {} {}) {\<lambda>x. undefined}
             (cring0.add_sheaf_spec {}) (cring0.mult_sheaf_spec {}) (cring0.zero_sheaf_spec {}) (cring0.one_sheaf_spec {}) {\<lambda>x. undefined}
             (cring0.add_sheaf_spec {}) (cring0.mult_sheaf_spec {}) (cring0.zero_sheaf_spec {}) (cring0.one_sheaf_spec {})"
    by (metis cring0.cring0_sheaf_spec_empty cring0.is_zariski_open_empty cring0.sheaf_spec_morphisms_are_ring_morphisms im0.target.open_imp_subset)
  show ?thesis
  proof intro_locales
    show "locally_ringed_space_axioms (\<lambda>U. U={}) (\<lambda>U. {0::nat}) (\<lambda>U V. identity{0}) (\<lambda>U x y. 0) (\<lambda>U x y. 0) (\<lambda>U. 0) (\<lambda>U. 0)"
      by (metis (mono_tags, lifting) empty_iff locally_ringed_space_axioms_def)
    show "topological_space cring0.spectrum cring0.is_zariski_open"
      by blast
    show [simp]: "Set_Theory.map (\<lambda>\<pp>\<in>Spec. undefined) {} cring0.spectrum"
      by (metis cring0.cring0_spectrum_eq im0.map_axioms)
    show "continuous_map_axioms {} (\<lambda>U. U={}) cring0.is_zariski_open (\<lambda>\<pp>\<in>Spec. undefined)"
      unfolding continuous_map_axioms_def by fastforce
    show "presheaf_of_rings_axioms cring0.is_zariski_open cring0.sheaf_spec
            cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec"
      using cring0.\<O>_on_emptyset cring0.sheaf_morphisms_sheaf_spec
      by (metis cring0.sheaf_spec_is_presheaf presheaf_of_rings_def)
    show "sheaf_of_rings_axioms cring0.spectrum cring0.is_zariski_open cring0.sheaf_spec cring0.sheaf_spec_morphisms cring0.zero_sheaf_spec"
      using cring0.sheaf_spec_is_sheaf sheaf_of_rings_def by metis
    have im_sheaf_0[simp]: "im_sheaf.im_sheaf {} (\<lambda>U. {0}) (\<lambda>\<pp>\<in>Spec. undefined) U = {0}" for U :: "nat set set"
      using im0.im_sheaf_def by blast
    have rh: "ring_homomorphism (im0.im_sheaf_morphisms U V) (im0.im_sheaf U) (im0.add_im_sheaf U)
         (im0.mult_im_sheaf U) (im0.zero_im_sheaf U) (im0.one_im_sheaf U) (im0.im_sheaf V)
         (im0.add_im_sheaf V) (im0.mult_im_sheaf V) (im0.zero_im_sheaf V) (im0.one_im_sheaf V)"
      if "cring0.is_zariski_open U" "cring0.is_zariski_open V" "V \<subseteq> U" for U V
      using that by (metis cring0.cring0_is_zariski_open im0.is_ring_morphism)
    show "morphism_ringed_spaces_axioms {} (\<lambda>U. {0})
         (\<lambda>U V. identity {0}) 0 (\<lambda>U x y. 0) (\<lambda>U x y. 0)
         (\<lambda>U. 0) (\<lambda>U. 0) cring0.spectrum cring0.is_zariski_open cring0.sheaf_spec
         cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec
         cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec
         (\<lambda>\<pp>\<in>Spec. undefined) (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0)"
      unfolding morphism_ringed_spaces_axioms_def morphism_sheaves_of_rings_def
        morphism_presheaves_of_rings_def
    proof (intro conjI)
      show "presheaf_of_rings cring0.spectrum cring0.is_zariski_open cring0.sheaf_spec
         cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec
         cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec"
        using cring0.sheaf_spec_is_presheaf by force
      show "presheaf_of_rings cring0.spectrum cring0.is_zariski_open im0.im_sheaf im0.im_sheaf_morphisms
 0 im0.add_im_sheaf im0.mult_im_sheaf im0.zero_im_sheaf im0.one_im_sheaf"
        by (simp add: im0.presheaf_of_rings_axioms)
      show "morphism_presheaves_of_rings_axioms cring0.is_zariski_open cring0.sheaf_spec cring0.sheaf_spec_morphisms
               cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec
               im0.im_sheaf im0.im_sheaf_morphisms im0.add_im_sheaf im0.mult_im_sheaf im0.zero_im_sheaf im0.one_im_sheaf (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0)"
        unfolding morphism_presheaves_of_rings_axioms_def
      proof (intro conjI strip)
        fix U
        assume "cring0.is_zariski_open U"
        interpret rU: ring "cring0.sheaf_spec U" "cring0.add_sheaf_spec U" "cring0.mult_sheaf_spec U" "cring0.zero_sheaf_spec U" "cring0.one_sheaf_spec U"
          by (metis \<open>cring0.is_zariski_open U\<close> comm_ring.axioms(1) cring0.sheaf_spec_on_open_is_comm_ring)
        interpret rU': ring "im0.im_sheaf U" "im0.add_im_sheaf U" "im0.mult_im_sheaf U" "im0.zero_im_sheaf U" "im0.one_im_sheaf U"
          using ring_im by blast
        show "ring_homomorphism (\<lambda>s\<in>cring0.sheaf_spec U. 0) (cring0.sheaf_spec U) (cring0.add_sheaf_spec U) (cring0.mult_sheaf_spec U) (cring0.zero_sheaf_spec U) (cring0.one_sheaf_spec U)
                            (im0.im_sheaf U) (im0.add_im_sheaf U) (im0.mult_im_sheaf U) (im0.zero_im_sheaf U) (im0.one_im_sheaf U)"
        proof intro_locales
          show "Set_Theory.map (\<lambda>s\<in>cring0.sheaf_spec U. 0) (cring0.sheaf_spec U) (im0.im_sheaf U)"
            unfolding  Set_Theory.map_def by (metis ext_funcset_to_sing_iff im0.im_sheaf_def singletonI)
          show "monoid_homomorphism_axioms (\<lambda>s\<in>cring0.sheaf_spec U. 0) (cring0.sheaf_spec U) (cring0.add_sheaf_spec U) (cring0.zero_sheaf_spec U) (im0.add_im_sheaf U) (im0.zero_im_sheaf U)"
            unfolding monoid_homomorphism_axioms_def im0.zero_im_sheaf_def im0.add_im_sheaf_def
            by (metis rU.additive.unit_closed rU.additive.composition_closed restrict_apply)
          show "monoid_homomorphism_axioms (\<lambda>s\<in>cring0.sheaf_spec U. 0) (cring0.sheaf_spec U) (cring0.mult_sheaf_spec U) (cring0.one_sheaf_spec U) (im0.mult_im_sheaf U) (im0.one_im_sheaf U)"
            unfolding monoid_homomorphism_axioms_def im0.mult_im_sheaf_def im0.one_im_sheaf_def
            by (metis rU.multiplicative.composition_closed rU.multiplicative.unit_closed restrict_apply)
        qed
        show "(im0.im_sheaf_morphisms U V \<circ> (\<lambda>s\<in>cring0.sheaf_spec U. 0)) x = ((\<lambda>s\<in>cring0.sheaf_spec V. 0) \<circ> cring0.sheaf_spec_morphisms U V) x"
          if "cring0.is_zariski_open U" "cring0.is_zariski_open V" "V \<subseteq> U" "x \<in> cring0.sheaf_spec U"
          for U V x
          using that cring0.sheaf_morphisms_sheaf_spec
          unfolding im0.im_sheaf_morphisms_def o_def
          by (metis cring0.cring0_is_zariski_open insertI1 restrict_apply')
      qed
    qed
    interpret monoid0: Group_Theory.monoid "{\<lambda>x. undefined}"
      "cring0.add_sheaf_spec {}"
      "(\<lambda>\<pp>\<in>{}. quotient_ring.zero_rel ({0}\<setminus>\<pp>) {0} ring0.subtraction ring0.subtraction 0 0)"
      by (smt (verit, best) Group_Theory.monoid.intro cring0.add_sheaf_spec_extensional extensional_empty restrict_extensional singletonD)

    show "iso_locally_ringed_spaces_axioms {} (\<lambda>U. U = {})
     (\<lambda>U. {0}) (\<lambda>U V. identity {0}) 0 (\<lambda>U x y. 0)
     (\<lambda>U x y. 0) (\<lambda>U. 0) (\<lambda>U. 0) cring0.spectrum
     cring0.is_zariski_open cring0.sheaf_spec
     cring0.sheaf_spec_morphisms cring0.\<O>b
     cring0.add_sheaf_spec cring0.mult_sheaf_spec
     cring0.zero_sheaf_spec cring0.one_sheaf_spec
     (\<lambda>\<pp>\<in>Spec. undefined)
     (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0::nat)"
      unfolding iso_locally_ringed_spaces_axioms_def
    proof (intro conjI)
      show "homeomorphism {} (\<lambda>U. U = {}) cring0.spectrum cring0.is_zariski_open (\<lambda>\<pp>\<in>Spec. undefined)"
      proof intro_locales
        show "bijective (\<lambda>\<pp>\<in>Spec. undefined) {} cring0.spectrum"
          unfolding bijective_def bij_betw_def
          using cring0.cring0_spectrum_eq by blast
        show "Set_Theory.map (inverse_map (\<lambda>\<pp>\<in>Spec. undefined) {} cring0.spectrum) cring0.spectrum {}"
          unfolding Set_Theory.map_def inverse_map_def restrict_def
          by (smt (verit, best) PiE_I cring0.cring0_spectrum_eq empty_iff)
      qed (use im0.map_axioms continuous_map_axioms_def in \<open>force+\<close>)
      show "iso_sheaves_of_rings cring0.spectrum cring0.is_zariski_open cring0.sheaf_spec
                 cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec
                 im0.im_sheaf im0.im_sheaf_morphisms (0::nat) im0.add_im_sheaf im0.mult_im_sheaf im0.zero_im_sheaf im0.one_im_sheaf (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0::nat)"
      proof intro_locales
        show "topological_space cring0.spectrum cring0.is_zariski_open"
          by force
        show "presheaf_of_rings_axioms cring0.is_zariski_open cring0.sheaf_spec cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec"
          using \<open>presheaf_of_rings_axioms cring0.is_zariski_open cring0.sheaf_spec cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec\<close> by force
        show "presheaf_of_rings_axioms cring0.is_zariski_open im0.im_sheaf im0.im_sheaf_morphisms (0::nat) im0.add_im_sheaf im0.mult_im_sheaf im0.zero_im_sheaf im0.one_im_sheaf"
          using im0.presheaf_of_rings_axioms presheaf_of_rings_def by force
        show "morphism_presheaves_of_rings_axioms cring0.is_zariski_open cring0.sheaf_spec cring0.sheaf_spec_morphisms cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec im0.im_sheaf im0.im_sheaf_morphisms im0.add_im_sheaf im0.mult_im_sheaf im0.zero_im_sheaf im0.one_im_sheaf (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0::nat)"
        proof qed (auto simp: cring0.zero_sheaf_spec_def cring0.one_sheaf_spec_def cring0.add_sheaf_spec_def cring0.mult_sheaf_spec_def
            im0.zero_im_sheaf_def im0.one_im_sheaf_def im0.add_im_sheaf_def im0.mult_im_sheaf_def
            im0.im_sheaf_morphisms_def cring0.sheaf_morphisms_sheaf_spec monoid0.invertible_def)
      have morph_empty: "morphism_presheaves_of_rings {} (\<lambda>U. U = {})
             im0.im_sheaf im0.im_sheaf_morphisms 0 (\<lambda>V. ring0.subtraction) (\<lambda>V. ring0.subtraction)
             (\<lambda>V. 0) (\<lambda>V. 0) cring0.sheaf_spec cring0.sheaf_spec_morphisms cring0.\<O>b
             cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec
             (\<lambda>S. \<lambda>n\<in>{0}. \<lambda>x. undefined)"
      proof qed (auto simp: im0.im_sheaf_morphisms_def cring0.sheaf_spec_morphisms_def
            cring0.zero_sheaf_spec_def cring0.one_sheaf_spec_def cring0.add_sheaf_spec_def cring0.mult_sheaf_spec_def
            cring0.\<O>b_def monoid0.invertible_def)
      then show "iso_presheaves_of_rings_axioms cring0.spectrum cring0.is_zariski_open cring0.sheaf_spec
                   cring0.sheaf_spec_morphisms cring0.\<O>b cring0.add_sheaf_spec cring0.mult_sheaf_spec cring0.zero_sheaf_spec cring0.one_sheaf_spec
                   im0.im_sheaf im0.im_sheaf_morphisms (0::nat) im0.add_im_sheaf im0.mult_im_sheaf im0.zero_im_sheaf im0.one_im_sheaf (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0)"
        by unfold_locales (auto simp add: im0.zero_im_sheaf_def im0.one_im_sheaf_def im0.add_im_sheaf_def im0.mult_im_sheaf_def)
      qed
    qed
    show "morphism_locally_ringed_spaces_axioms {}
     (\<lambda>U. U = {}) (\<lambda>U. {0}) (\<lambda>U V. identity {0})
     (\<lambda>U x y. 0) (\<lambda>U x y. 0) (\<lambda>U. 0) (\<lambda>U. 0)
     cring0.is_zariski_open cring0.sheaf_spec
     cring0.sheaf_spec_morphisms cring0.add_sheaf_spec
     cring0.mult_sheaf_spec cring0.zero_sheaf_spec
     cring0.one_sheaf_spec (\<lambda>\<pp>\<in>Spec. undefined)
     (\<lambda>U. \<lambda>s\<in>cring0.sheaf_spec U. 0)"
      by (meson equals0D morphism_locally_ringed_spaces_axioms.intro)
  qed
qed

lemma empty_scheme_is_scheme:
  shows "scheme {} (\<lambda>U. U={}) (\<lambda>U. {0}) (\<lambda>U V. identity{0::nat}) 0 (\<lambda>U x y. 0) (\<lambda>U x y. 0)
          (\<lambda>U. 0) (\<lambda>U. 0) (UNIV::nat set)"
  by (metis affine_scheme.affine_scheme_is_scheme empty_scheme_is_affine_scheme)

end


(*
 * Copyright 2018, Data61
 * Commonwealth Scientific and Industrial Research Organisation (CSIRO)
 * ABN 41 687 119 230.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)

theory FastMap
imports
  LemmaBucket
begin

text \<open>
  Efficient rules and tactics for working with large lookup tables (maps).

  Features:
    \<^item> Define a binary lookup tree for any lookup table (requires linorder keys)
    \<^item> Conversion from lookup tree to lookup lists
    \<^item> Pre-computation of lookup results and domain/range sets

  See FastMap_Test for examples.
\<close>

(*
 * TODO:
 *
 *   • Storing the auxilliary list theorems with Local_Theory.notes
 *     takes quadratic time. Unfortunately, this seems to be a problem
 *     deep inside the Isabelle implementation. One might try to wrap
 *     the lists in new constants, but Local_Theory.define also takes
 *     quadratic time.
 *
 *   • Still a bit slower than the StaticFun package. Streamline the
 *     rulesets and proofs.
 *
 *   • We use a lot of manual convs for performance and to avoid
 *     relying on the dynamic simpset. However, we should clean up the
 *     convs and move as much as possible to (simp only:) invocations.
 *
 *     Note that running simp on deeply nested terms (e.g. lists)
 *     always takes quadratic time and we can't use it there. This is
 *     because rewritec unconditionally calls eta_conversion (urgh).
 *
 *   • The injectivity prover currently hardcodes inj_def into the
 *     simpset. This should be changed at some point, probably by
 *     asking the user to prove it beforehand.
 *
 *   • The key ordering prover is currently hardcoded to simp_tac;
 *     this should also be generalised. On the other hand, the user
 *     could work around this by manually supplying a simpset with
 *     precisely the needed theorems.
 *
 *   • Using the simplifier to evaluate tree lookups is still quite
 *     slow because it looks at the entire tree term (even though
 *     most of it is irrelevant for any given lookup). We should
 *     provide a tactic or simproc to do this.
 *
 *     We already generate lookup theorems for keys in the map, so
 *     this tactic should be optimised for missing keys.
 *
 *   • The linorder requirement can be cumbersome. It arises because
 *     we express the map_of conversion as a general theorem using
 *     lookup_tree_valid. An alternative approach is to extend what
 *     StaticFun does, and cleverly extract the set of all relevant
 *     bindings from the tree on a case-by-case basis.
 *
 *     We would still need to evaluate the key ordering function on
 *     the input keys, but any arbitrary relation would be allowed.
 *     This one probably calls for a wizard.
 *)

locale FastMap begin

text \<open>
  Binary lookup tree. This is largely an implementation detail, so we
  choose the structure to make automation easier (e.g. separate fields
  for the key and value).

  We could reuse HOL.Tree instead, but the proofs would need changing.
\<close>
datatype ('k, 'v) Tree =
    Leaf
  | Node 'k 'v "('k, 'v) Tree" "('k, 'v) Tree"

primrec lookup_tree :: "('k \<Rightarrow> 'ok :: linorder) \<Rightarrow> ('k, 'v) Tree \<Rightarrow> 'k \<Rightarrow> 'v option"
  where
    "lookup_tree key Leaf x = None"
  | "lookup_tree key (Node k v l r) x =
       (if key x = key k then Some v
        else if key x < key k then lookup_tree key l x
        else lookup_tree key r x)"

text \<open>
  Predicate for well-formed lookup trees.
  This states that the keys are distinct and appear in ascending order.
  It also returns the lowest and highest keys in the tree (or None for empty trees).
\<close>
primrec lookup_tree_valid ::
        "('k \<Rightarrow> 'ok :: linorder) \<Rightarrow> ('k, 'v) Tree \<Rightarrow> bool \<times> ('k \<times> 'k) option"
  where
    "lookup_tree_valid key Leaf = (True, None)"
  | "lookup_tree_valid key (Node k v lt rt) =
       (let (lt_valid, lt_range) = lookup_tree_valid key lt;
            (rt_valid, rt_range) = lookup_tree_valid key rt;
            lt_low = (case lt_range of None \<Rightarrow> k | Some (low, high) \<Rightarrow> low);
            rt_high = (case rt_range of None \<Rightarrow> k | Some (low, high) \<Rightarrow> high)
        in (lt_valid \<and> rt_valid \<and>
            (case lt_range of None \<Rightarrow> True | Some (low, high) \<Rightarrow> key high < key k) \<and>
            (case rt_range of None \<Rightarrow> True | Some (low, high) \<Rightarrow> key k < key low),
            Some (lt_low, rt_high)))"

lemma lookup_tree_valid_simps':
  "lookup_tree_valid key Leaf = (True, None)"
  "lookup_tree_valid key (Node k v Leaf Leaf) = (True, Some (k, k))"
  "\<lbrakk> lookup_tree_valid key (Node lk lv llt lrt) = (True, Some (llow, lhigh));
     key lhigh < key k
   \<rbrakk> \<Longrightarrow> lookup_tree_valid key (Node k v (Node lk lv llt lrt) Leaf) =
           (True, Some (llow, k))"
  "\<lbrakk> lookup_tree_valid key (Node rk rv rlt rrt) = (True, Some (rlow, rhigh));
     key k < key rlow
   \<rbrakk> \<Longrightarrow> lookup_tree_valid key (Node k v Leaf (Node rk rv rlt rrt)) =
           (True, Some (k, rhigh))"
  "\<lbrakk> lookup_tree_valid key (Node lk lv llt lrt) = (True, Some (llow, lhigh));
     lookup_tree_valid key (Node rk rv rlt rrt) = (True, Some (rlow, rhigh));
     key lhigh < key k;
     key k < key rlow
   \<rbrakk> \<Longrightarrow> lookup_tree_valid key (Node k v (Node lk lv llt lrt) (Node rk rv rlt rrt)) =
           (True, Some (llow, rhigh))"
  by auto

lemma lookup_tree_valid_empty:
  "lookup_tree_valid key tree = (True, None) \<Longrightarrow> tree = Leaf"
  apply (induct tree)
   apply simp
  apply (fastforce split: prod.splits option.splits if_splits)
  done

lemma lookup_tree_valid_range:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow> key low \<le> key high"
  apply (induct tree arbitrary: low high)
   apply simp
  apply (fastforce split: prod.splits option.splits if_splits)
  done

lemma lookup_tree_valid_in_range:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow>
   lookup_tree key tree k = Some v \<Longrightarrow>
   key k \<in> {key low .. key high}"
  apply (induct tree arbitrary: k v low high)
   apply simp
  apply (fastforce split: prod.splits option.splits if_split_asm
                   dest: lookup_tree_valid_empty lookup_tree_valid_range)
  done

lemma lookup_tree_valid_in_range_None:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow>
   key k \<notin> {key low .. key high} \<Longrightarrow>
   lookup_tree key tree k = None"
  using lookup_tree_valid_in_range by fastforce

text \<open>
  Flatten a lookup tree into an assoc-list.
  As long as the tree is well-formed, both forms are equivalent.
\<close>
primrec lookup_tree_to_list :: "('k, 'v) Tree \<Rightarrow> ('k \<times> 'v) list"
  where
    "lookup_tree_to_list Leaf = []"
  | "lookup_tree_to_list (Node k v lt rt) =
        lookup_tree_to_list lt @ [(k, v)] @ lookup_tree_to_list rt"

lemma lookup_tree_to_list_range:
  "lookup_tree_valid key tree = (True, Some (low, high)) \<Longrightarrow>
   (k, v) \<in> set (lookup_tree_to_list tree) \<Longrightarrow>
   key k \<in> {key low .. key high}"
  apply (induct tree arbitrary: k v low high)
   apply simp
  apply (fastforce split: prod.splits option.splits if_split_asm
                   dest: lookup_tree_valid_empty lookup_tree_valid_range)
  done

lemma lookup_tree_dom_distinct_sorted_:
  "fst (lookup_tree_valid key tree) \<Longrightarrow>
   distinct (lookup_tree_to_list tree) \<and> sorted (map (key o fst) (lookup_tree_to_list tree))"
  apply (induct tree)
   apply simp
  apply (fastforce simp: sorted_append
                   split: prod.splits option.splits if_splits
                   dest: lookup_tree_valid_empty lookup_tree_valid_range
                         lookup_tree_valid_in_range lookup_tree_to_list_range
                   elim: lookup_tree_valid_in_range_None)
  done

lemmas lookup_tree_dom_distinct = lookup_tree_dom_distinct_sorted_[THEN conjunct1]
lemmas lookup_tree_dom_sorted = lookup_tree_dom_distinct_sorted_[THEN conjunct2]

(* This goal is eta-expanded and flipped, which seems to help its proof *)
lemma lookup_tree_to_list_of_:
  "fst (lookup_tree_valid key tree) \<Longrightarrow>
   map_of (map (apfst key) (lookup_tree_to_list tree)) (key k) = lookup_tree key tree k"
  apply (induct tree arbitrary: k)
   apply simp
  (* this big blob just does case distinctions of both subtrees and
     all possible lookup results within each, then solves *)
  (* slow 10s *)
  apply (fastforce simp: apfst_def map_prod_def map_add_def
                   split: prod.splits option.splits if_splits
                   dest: lookup_tree_valid_empty lookup_tree_valid_range lookup_tree_valid_in_range
                   elim: lookup_tree_valid_in_range_None)
  done

(* Standard form of above *)
lemma lookup_tree_to_list_of:
  "fst (lookup_tree_valid key tree) \<Longrightarrow>
   lookup_tree key tree = map_of (map (apfst key) (lookup_tree_to_list tree)) o key"
  apply (rule ext)
  apply (simp add: lookup_tree_to_list_of_)
  done

lemma map_of_key:
  "inj key \<Longrightarrow> map_of (map (apfst key) binds) o key = map_of binds"
  apply (rule ext)
  apply (induct binds)
   apply simp
  apply (clarsimp simp: inj_def dom_def)
  done

lemma lookup_tree_to_list_of_distinct:
  "\<lbrakk> fst (lookup_tree_valid key tree);
     lookup_tree_to_list tree = binds;
     lookup_tree key tree = map_of (map (apfst key) binds) o key
   \<rbrakk> \<Longrightarrow> distinct (map (key o fst) binds)"
  apply (drule sym[where t = binds])
  apply clarsimp
  apply (thin_tac "binds = _")
  apply (induct tree)
   apply simp
  apply (fastforce simp: map_add_def lookup_tree_to_list_of
                   split: prod.splits option.splits if_splits
                   dest: lookup_tree_valid_empty lookup_tree_valid_range
                         lookup_tree_valid_in_range lookup_tree_to_list_range
                   elim: lookup_tree_valid_in_range_None)
  done

(* Top-level rule for converting to lookup list.
   We add a distinctness assertion for inferring the range of values. *)
lemma lookup_tree_to_list_of_gen:
  "\<lbrakk> inj key;
     fst (lookup_tree_valid key tree);
     lookup_tree_to_list tree = binds
   \<rbrakk> \<Longrightarrow> lookup_tree key tree = map_of binds \<and> distinct (map fst binds)"
  using lookup_tree_to_list_of
  apply (fastforce intro: lookup_tree_to_list_of_distinct
                   simp: map_of_key distinct_inj)
  done

text \<open>
  Domain and range of a @{const map_of}.
  Like @{thm dom_map_of_conv_image_fst} but leaving out the set bloat.
\<close>
lemma dom_map_of_conv_list:
  "dom (map_of xs) = set (map fst xs)"
  by (simp add: dom_map_of_conv_image_fst)

lemma ran_map_of_conv_list:
  "distinct (map fst xs) \<Longrightarrow> ran (map_of xs) = set (map snd xs)"
  by (erule distinct_map_via_ran)

text \<open>
  Read lookup rules from a @{const map_of}.
\<close>

lemma map_of_lookups:
  "m = map_of binds \<and> distinct (map fst binds) \<Longrightarrow>
   list_all (\<lambda>(k, v). m k = Some v) binds"
  apply (induct binds)
   apply simp
  apply (force simp: list_all_iff)
  done

(* Helper for converting from maps defined as @{const fun_upd} chains,
 * which are applied in reverse order *)
lemma map_of_rev:
  "distinct (map fst binds) \<Longrightarrow>
   map_of (rev binds) = map_of binds"
  apply (subgoal_tac "distinct (map fst (rev binds))")
   apply (rule ext)
   apply (induct binds)
    apply simp
   apply (force simp: map_add_def split: option.splits)
  apply (metis distinct_rev rev_map)
  done

lemma list_all_dest:
  "list_all P [(x, y)] \<equiv> P (x, y)"
  "list_all P ((x, y) # z # xs) \<equiv> (P (x, y) \<and> list_all P (z # xs))"
  by auto

(* Install lookup rules that don't depend on if_cong/if_weak_cong setup *)
lemma lookup_tree_simps':
  "lookup_tree key Leaf x = None"
  "key x = key k \<Longrightarrow> lookup_tree key (Node k v l r) x = Some v"
  "key x < key k \<Longrightarrow> lookup_tree key (Node k v l r) x = lookup_tree key l x"
  "key x > key k \<Longrightarrow> lookup_tree key (Node k v l r) x = lookup_tree key r x"
  by auto
end

declare FastMap.lookup_tree.simps[simp del]
declare FastMap.lookup_tree_simps'[simp]

ML \<open>
structure FastMap = struct

(* utils *)
fun mk_optionT typ = Type ("Option.option", [typ])
fun dest_optionT (Type ("Option.option", [typ])) = typ
  | dest_optionT t = raise TYPE ("dest_optionT", [t], [])

(* O(1) version of thm RS @{thm eq_reflection} *)
fun then_eq_reflection thm = let
  val (x, y) = Thm.dest_binop (Thm.dest_arg (Thm.cprop_of thm));
  val cT = Thm.ctyp_of_cterm x;
  val rule = @{thm eq_reflection} |> Thm.instantiate' [SOME cT] [SOME x, SOME y];
  in Thm.implies_elim rule thm end;

val lhs_conv = Conv.fun_conv o Conv.arg_conv
val rhs_conv = Conv.arg_conv
(* first order rewr_conv *)
fun fo_rewr_conv rule ct = let
  val (pure_eq, eqn) =
        ((true, Thm.instantiate (Thm.first_order_match (Thm.lhs_of rule, ct)) rule)
         handle TERM _ =>
           (false, Thm.instantiate (Thm.first_order_match
                      (fst (Thm.dest_binop (Thm.dest_arg (Thm.cprop_of rule))), ct)) rule))
        handle Pattern.MATCH => raise CTERM ("fo_rewr_conv", [Thm.cprop_of rule, ct]);
  in if pure_eq then eqn else then_eq_reflection eqn end;
fun fo_rewrs_conv rules = Conv.first_conv (map fo_rewr_conv rules);

(* Evaluate a term with rewrite rules. Unlike the simplifier, this
 * does only one top-down pass, but that's enough for tasks like
 * pushing List.map through a list. Also runs much faster. *)
fun fo_topdown_rewr_conv rules ctxt =
      Conv.top_conv (K (Conv.try_conv (fo_rewrs_conv rules))) ctxt

(* Allow recursive conv in cv2, deferred by function application *)
infix 1 then_conv'
fun (cv1 then_conv' cv2) ct =
  let
    val eq1 = cv1 ct;
    val eq2 = cv2 () (Thm.rhs_of eq1);
  in
    if Thm.is_reflexive eq1 then eq2
    else if Thm.is_reflexive eq2 then eq1
    else Thm.transitive eq1 eq2
  end;

(*
 * Helper that makes it easier to describe where to apply a conv.
 * This takes a skeleton term and applies the conversion wherever "HERE"
 * appears in the skeleton.
 *
 * FIXME: use HOL-Library.Rewrite instead
 *)
fun conv_at skel conv ctxt ct = let
  fun mismatch current_skel current_ct =
    raise TERM ("conv_at mismatch", [current_skel, Thm.term_of current_ct, skel, Thm.term_of ct])

  fun walk (Free ("HERE", _)) ctxt ct = conv ct
    | walk (skel as skel_f $ skel_x) ctxt ct =
        (case Thm.term_of ct of
            f $ x => Conv.combination_conv (walk skel_f ctxt) (walk skel_x ctxt) ct
          | _ => mismatch skel ct)
    | walk (skel as Abs (_, _, skel_body)) ctxt ct =
        (case Thm.term_of ct of
            Abs _ => Conv.abs_conv (fn (v, ctxt') => walk skel_body ctxt') ctxt ct
          | _ => mismatch skel ct)
    (* Also check that Consts match the skeleton pattern *)
    | walk (skel as Const (skel_name, _)) ctxt ct =
        if (case Thm.term_of ct of Const (name, _) => name = skel_name | _ => false)
        then Thm.reflexive ct
        else mismatch skel ct
    (* Default case *)
    | walk _ ctxt ct = Thm.reflexive ct
  in walk skel ctxt ct end

fun gconv_at_tac pat conv ctxt = Conv.gconv_rule (conv_at pat conv ctxt) 1 #> Seq.succeed

(* Tree builder code, copied from StaticFun *)

(* Actually build the tree -- theta (n lg(n)) *)
fun build_tree' _ mk_leaf [] = mk_leaf
  | build_tree' mk_node mk_leaf xs = let
    val len = length xs
    val (ys, zs) = chop (len div 2) xs
  in case zs of [] => error "build_tree': impossible"
    | ((a, b) :: zs) => mk_node a b (build_tree' mk_node mk_leaf ys)
        (build_tree' mk_node mk_leaf zs)
  end

fun build_tree xs = case xs of [] => error "build_tree : empty"
  | (idx, v) :: _ => let
    val idxT = fastype_of idx
    val vT = fastype_of v
    val treeT = Type (@{type_name FastMap.Tree}, [idxT, vT])
    val mk_leaf = Const (@{const_name FastMap.Leaf}, treeT)
    val node = Const (@{const_name FastMap.Node},
        idxT --> vT --> treeT --> treeT --> treeT)
    fun mk_node a b l r = node $ a $ b $ l $ r
  in
    build_tree' mk_node mk_leaf xs
  end

fun define_partial_map_tree map_name mappings ord_term ctxt = let
    val (idxT, vT) = apply2 fastype_of (hd mappings)
    val treeT = Type (@{type_name FastMap.Tree}, [idxT, vT])
    val lookup = Const (@{const_name FastMap.lookup_tree},
                        fastype_of ord_term --> treeT --> idxT
                            --> Type (@{type_name option}, [vT]))
    val map_term = lookup $ ord_term $ build_tree mappings
    val ((map_const, (_, map_def)), ctxt) =
          Local_Theory.define ((map_name, NoSyn), ((Thm.def_binding map_name, []), map_term)) ctxt
  in
    ((map_const, map_def), ctxt)
  end

(* Prove key ordering theorems. This lets us issue precise error messages
   when the user gives us keys whose ordering cannot be verified.
   We will also need these thms to prove the lookup_tree_valid property. *)
fun prove_key_ord_thms tree_name keyT mappings get_key simp_ctxt ctxt =
  let
    val solver = simp_tac (simp_ctxt ctxt [] []) 1;
  in
    fst (split_last mappings) ~~ tl mappings
    |> map_index (fn (i, ((k1, _), (k2, _))) => let
           val prop = Const (@{const_name less}, keyT --> keyT --> HOLogic.boolT) $
                            (get_key $ k1) $ (get_key $ k2)
                      |> HOLogic.mk_Trueprop;
           in case try (Goal.prove ctxt [] [] prop) (K solver) of
                  SOME x => x
                | _ => raise TERM (tree_name ^ ": failed to prove less-than ordering for keys #" ^
                                   string_of_int i ^ ", #" ^ string_of_int (i + 1),
                                   [prop])
           end)
  end;

(* Prove lookup_tree_valid *)
fun prove_tree_valid tree_name mappings kT keyT tree_term get_key simp_ctxt ctxt = let
    val key_ord_thms = prove_key_ord_thms tree_name keyT mappings get_key simp_ctxt ctxt;
    val treeT = fastype_of tree_term
    val valid_resultT = HOLogic.mk_prodT (HOLogic.boolT, mk_optionT (HOLogic.mk_prodT (kT, kT)))
    val tree_valid_prop =
          HOLogic.mk_Trueprop (
            Const (@{const_name fst}, valid_resultT --> HOLogic.boolT) $
            (Const (@{const_name FastMap.lookup_tree_valid},
                    (kT --> keyT) --> treeT --> valid_resultT) $
               get_key $ tree_term))
    val solver = simp_tac (put_simpset HOL_basic_ss ctxt
                           addsimps (@{thms prod.sel FastMap.lookup_tree_valid_simps'} @
                                     key_ord_thms)) 1
  in Goal.prove ctxt [] [] tree_valid_prop (K solver) end

fun solve_simp_tac name ctxt = SUBGOAL (fn (t, i) =>
      (simp_tac ctxt THEN_ALL_NEW SUBGOAL (fn (t', _) =>
          raise TERM (name ^ ": unsolved", [t, t']))) i)

fun convert_to_lookup_list kT valT mappings map_const map_def tree_valid_thm simp_ctxt ctxt = let
  val lookupT = fastype_of map_const
  (* map_eq = "<tree_const> = map_of <mappings>" *)
  val bindT = HOLogic.mk_prodT (kT, valT)
  val lookup_list = HOLogic.mk_list bindT (map HOLogic.mk_prod mappings)
  val map_of_Const = Const (@{const_name map_of}, HOLogic.listT bindT --> lookupT)
  val map_eq = HOLogic.mk_eq (map_const, map_of_Const $ lookup_list)
  (* distinct_pred = "distinct (map fst <mappings>)" *)
  val distinct_pred =
        Const (@{const_name distinct}, HOLogic.listT kT --> HOLogic.boolT) $
          (Const (@{const_name map}, (bindT --> kT) --> HOLogic.listT bindT --> HOLogic.listT kT) $
             Const (@{const_name fst}, bindT --> kT) $
             lookup_list)
  val convert_prop = HOLogic.mk_Trueprop (
        HOLogic.mk_conj (map_eq, distinct_pred)
        )
  fun TIMED desc tac = fn st =>
        Seq.make (K (Timing.timeap_msg ("tactic timing for " ^ desc)
                          (fn () => Seq.pull (tac st)) ()))

  val append_basecase = @{thm append.simps(1)}
  val append_rec = @{thm append.simps(2)}
  val lookup_tree_to_list_basecase = @{thm FastMap.lookup_tree_to_list.simps(1)}
  val lookup_tree_to_list_rec = @{thm FastMap.lookup_tree_to_list.simps(2)[simplified append.simps]}

  val lookup_tree_to_list_eval = let
    fun append_conv () =
            fo_rewr_conv append_basecase else_conv
            (fo_rewr_conv append_rec then_conv'
             (fn () => rhs_conv (append_conv ())))
    fun to_map_conv () =
            fo_rewr_conv lookup_tree_to_list_basecase else_conv
            (fo_rewr_conv lookup_tree_to_list_rec then_conv'
             (fn () => lhs_conv (to_map_conv ())) then_conv'
             (fn () => rhs_conv (rhs_conv (to_map_conv ()))) then_conv
             append_conv ())
  in to_map_conv () end

  val solver =
        TIMED "unfold" (gconv_at_tac @{term "Trueprop (HERE = map_of dummy1 \<and> dummy2)"}
                                     (K map_def) ctxt)
        THEN
        TIMED "main rule" (resolve_tac ctxt @{thms FastMap.lookup_tree_to_list_of_gen} 1)
        THEN
          TIMED "solve inj" (solve_simp_tac "solve inj"
                              (simp_ctxt ctxt @{thms simp_thms} @{thms inj_def}) 1)
          THEN
         TIMED "resolve valid" (resolve_tac ctxt [tree_valid_thm] 1)
         THEN
        TIMED "convert tree" (gconv_at_tac @{term "Trueprop (HERE = dummy1)"}
                                           lookup_tree_to_list_eval ctxt)
        THEN
        resolve_tac ctxt @{thms refl} 1
  val convert_thm = Goal.prove ctxt [] [] convert_prop (K solver)
  in convert_thm end

(* Obtain domain and range from lookup list *)
fun domain_range_common dom_ran_const xT xs map_const lookup_list_eqn intro_conv_tac ctxt = let
  val mapT = fastype_of map_const
  val prop = HOLogic.mk_Trueprop (
        HOLogic.mk_eq (
          Const (dom_ran_const, mapT --> HOLogic.mk_setT xT) $ map_const,
          Const (@{const_name set}, HOLogic.listT xT --> HOLogic.mk_setT xT) $
            (HOLogic.mk_list xT xs)
        ))
  val lookup_list_eqn' = then_eq_reflection lookup_list_eqn
  val map_fst_snd_conv = fo_topdown_rewr_conv @{thms list.map prod.sel} ctxt
  val solver =
        (gconv_at_tac @{term "Trueprop (dom_ran_dummy1 HERE = dummy2)"}
                      (K lookup_list_eqn') ctxt)
        THEN
        intro_conv_tac
        THEN
        gconv_at_tac @{term "Trueprop (HERE = dummy1)"} map_fst_snd_conv ctxt
        THEN
        resolve_tac ctxt @{thms refl} 1
  in Goal.prove ctxt [] [] prop (K solver) end;

fun tree_domain kT mappings map_const lookup_list_eqn ctxt =
  domain_range_common
    @{const_name dom} kT (map fst mappings) map_const lookup_list_eqn
    (* like (subst dom_map_of_conv_list) but faster *)
    (resolve_tac ctxt @{thms FastMap.dom_map_of_conv_list[THEN trans]} 1)
    ctxt;

fun tree_range valT mappings map_const lookup_list_eqn map_distinct_thm ctxt =
  domain_range_common
    @{const_name ran} valT (map snd mappings) map_const lookup_list_eqn
    (* like (subst ran_map_of_conv_list) but faster *)
    (resolve_tac ctxt @{thms FastMap.ran_map_of_conv_list[THEN trans]} 1 THEN
     resolve_tac ctxt [map_distinct_thm] 1)
    ctxt;

(* Choosing names for the const and its theorems. The constant will be named with
   map_name; Local_Theory.define may also add extra names (e.g. <map_name>_def) *)
type name_opts = {
    map_name: string,
    tree_valid_thm: string,
    to_lookup_list: string,
    keys_distinct_thm: string,
    lookup_thms: string,
    domain_thm: string,
    range_thm: string
};

fun name_opts_default (map_name: string): name_opts = {
    map_name = map_name,
    tree_valid_thm = map_name ^ "_tree_valid",
    to_lookup_list = map_name ^ "_to_lookup_list",
    keys_distinct_thm = map_name ^ "_keys_distinct",
    lookup_thms = map_name ^ "_lookups",
    domain_thm = map_name ^ "_domain",
    range_thm = map_name ^ "_range"
};

(* Top level interface *)
fun define_map
            (name_opts: name_opts)
            (mappings: (term * term) list)
            (get_key: term) (* function to get linorder key, must be injective *)
            (extra_simps: thm list)
            (minimal_simp: bool) (* true: start with minimal simpset; extra_simps must be adequate *)
            ctxt = let
    fun simp_ctxt ctxt basic_simps more_simps = if minimal_simp
      then put_simpset HOL_basic_ss ctxt addsimps (basic_simps @ extra_simps @ more_simps)
      else ctxt addsimps (extra_simps @ more_simps)

    val (kT, keyT) = dest_funT (fastype_of get_key)
    val valT = fastype_of (snd (hd mappings))

    val _ = tracing (#map_name name_opts ^ ": defining tree")
    val start = Timing.start ()
    val ((map_const, map_def), ctxt) =
            define_partial_map_tree
                (Binding.name (#map_name name_opts))
                mappings get_key ctxt
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    val _ = tracing (#map_name name_opts ^ ": proving tree is well-formed")
    val start = Timing.start ()
    val _ $ _ $ tree_term = Thm.term_of (Thm.rhs_of map_def)
    val tree_valid_thm =
          prove_tree_valid (#map_name name_opts) mappings kT keyT tree_term get_key simp_ctxt ctxt
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#tree_valid_thm name_opts), []), [([tree_valid_thm], [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    val _ = tracing (#map_name name_opts ^ ": converting tree to map")
    val start = Timing.start ()
    val convert_thm =
          convert_to_lookup_list kT valT mappings map_const map_def tree_valid_thm simp_ctxt ctxt
    val [lookup_list_eqn, map_distinct_thm] = HOLogic.conj_elims ctxt convert_thm
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))
    val _ = tracing (#map_name name_opts ^ ": storing map and distinctness theorems")
    val start = Timing.start ()
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#to_lookup_list name_opts), []), [([lookup_list_eqn], [])]),
         ((Binding.name (#keys_distinct_thm name_opts), []), [([map_distinct_thm], [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    val _ = tracing (#map_name name_opts ^ ": obtaining lookup rules")
    val start = Timing.start ()
    fun dest_list_all_conv () =
          fo_rewr_conv @{thm FastMap.list_all_dest(1)} else_conv
          (fo_rewr_conv @{thm FastMap.list_all_dest(2)} then_conv'
           (fn () => rhs_conv (dest_list_all_conv())))
    val combined_lookup_thm =
          (convert_thm RS @{thm FastMap.map_of_lookups})
          |> Conv.fconv_rule (conv_at @{term "Trueprop HERE"} (dest_list_all_conv ()) ctxt)
    val _ = tracing ("  splitting... " ^ Timing.message (Timing.result start))
    val lookup_thms =
          HOLogic.conj_elims ctxt combined_lookup_thm
          |> map (Conv.fconv_rule (conv_at @{term "Trueprop HERE"}
                                     (fo_rewr_conv @{thm prod.case[THEN eq_reflection]}) ctxt))

    val _ = if length lookup_thms = length mappings then () else
              raise THM ("wrong number of lookup thms: " ^ string_of_int (length lookup_thms) ^
                         " instead of " ^ string_of_int (length mappings), 0,
                         lookup_thms)
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#lookup_thms name_opts), []), [(lookup_thms, [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))

    (* domain and range *)
    val _ = tracing (#map_name name_opts ^ ": getting domain and range")
    val start = Timing.start ()
    val domain_thm = timeap_msg "  calculate domain"
            (tree_domain kT mappings map_const lookup_list_eqn) ctxt
    val range_thm = timeap_msg "  calculate range"
            (tree_range valT mappings map_const lookup_list_eqn map_distinct_thm) ctxt
    val (_, ctxt) = ctxt |> Local_Theory.notes
        [((Binding.name (#domain_thm name_opts), []), [([domain_thm], [])]),
         ((Binding.name (#range_thm name_opts), []), [([range_thm], [])])]
    val _ = tracing ("  done: " ^ Timing.message (Timing.result start))
  in ctxt end

end
\<close>

end


theory AuthHeap
imports DerivedConstructions Frac BaseLogicShallow View Own ProofSearchPredicates ProphMap
begin

subsubsection \<open>View based heap\<close>
type_synonym ('l,'v) heap = "('l,'v) map_view"

lemma heap_auth_agree:
  "\<lbrakk>(f::'l\<rightharpoonup>(dfrac\<times>'v::discrete ag)) l = Some (d,v); valid (comb a f)\<rbrakk> \<Longrightarrow> \<exists>d'. a l = Some (d',v)"
proof -
  assume assms: "f l = Some (d,v)" "valid (comb a f)"
  then have "\<forall>n. n_incl n f a" by (auto simp: valid_def)
  then obtain f' where f': "a = (f\<cdot>f')" by (auto simp: n_incl_incl incl_def)
  then show ?thesis proof (cases "f' l")
    case None
    then have "(f\<cdot>f') l = f l " by (auto simp: op_fun_def op_option_def assms(1))
    with f' have "a l = f l" by (auto simp: incl_def)
    with assms(1) show ?thesis by simp
  next
    case (Some x)
    with f' have al: "a l = (f l) \<cdot> Some x" by (auto simp: op_fun_def)
    with f' Some assms(2) have al_valid: "valid ((f l) \<cdot> Some x)"
      by (auto simp: valid_def op_fun_def) (metis valid_raw_fun.rep_eq)
    from f' assms(2) have "valid f'" apply (simp add: valid_def)
      by (metis camera_comm camera_valid_op)
    with Some obtain d' v' where x: "x = (d', v')" "valid v'"
      by (auto simp: valid_def valid_raw_fun.rep_eq valid_raw_option_def valid_raw_prod_def
        sprop_conj.rep_eq split: option.splits) (metis surj_pair)
    with al_valid assms(1) have "valid (v\<cdot>v')"
      by (auto simp: valid_def valid_raw_option_def op_option_def op_prod_def prod_n_valid_def
        split: option.splits)
    from d_ag_agree[OF this] al assms(1) x have "a l = Some (d\<cdot>d',v)"
      by (auto simp: op_ag_def Rep_ag_inverse op_option_def op_prod_def)
    then show ?thesis ..
  qed
qed

context
fixes get_heap :: "gname \<Rightarrow> 'a::ucamera \<Rightarrow> ('l,'v::ofe option) heap option"
  and put_heap
assumes heap_inG: "inG get_heap put_heap"
begin

text \<open>Unique name for singleton heap camera\<close>
definition "heap_name :: gname \<equiv> 0"

lemma heap_frag_valid: "\<V>(put_heap \<gamma> (\<circle>V [k\<mapsto>(dq,to_ag v)])) \<turnstile> \<upharpoonleft>(valid dq)"
  by (auto simp: upred_valid.rep_eq upred_entails.rep_eq upred_pure.rep_eq inG.put_n_valid[OF heap_inG]
    valid_def view_frag_def valid_raw_map_view.rep_eq map_view_rel_def)

lemma heap_op: "[l\<mapsto>(dq1, to_ag v1)]\<cdot>[l\<mapsto>(dq2, to_ag v2)] = [l\<mapsto>(dq1, to_ag v1)\<cdot>(dq2, to_ag v2)]"
  by (auto simp: op_fun_def op_option_def)

lemma heap_op_val_eq: "[l\<mapsto>(dq1, to_ag v)]\<cdot>[l\<mapsto>(dq2, to_ag v)] = [l\<mapsto>(dq1\<cdot>dq2, to_ag v)]"
  unfolding heap_op by (auto simp: op_prod_def op_ag_def to_ag_def Rep_ag_inverse)

lemma heap_valid: "\<V>(put_heap \<gamma> h) \<turnstile> \<V>(h::('l,'v option) heap)"
  by (simp add: upred_valid_def upred_entails.rep_eq Abs_upred_f_inverse inG.put_n_valid[OF heap_inG])

text \<open>Heap camera operations\<close>
abbreviation own_heap :: "('l,'v option) heap \<Rightarrow> 'a upred_f" ("Own\<^sub>h _") where
   "own_heap h \<equiv> own put_heap heap_name h"

definition own_heap_auth :: "frac \<Rightarrow> ('l,'v option) fmap \<Rightarrow> 'a upred_f" where
  "own_heap_auth q m \<equiv> Own\<^sub>h(map_view_auth (DfracOwn q) m)"

text \<open>Because our heap camera does not contain meta tokens, this proposition is just about owning a heap.\<close>
definition heap_interp :: "('l,'v option) fmap \<Rightarrow> 'a upred_f" where
  "heap_interp \<sigma> \<equiv> own_heap_auth 1 \<sigma>"

definition points_to :: "'l \<Rightarrow> dfrac \<Rightarrow> 'v \<Rightarrow> 'a upred_f" where
  "points_to l dq v = Own\<^sub>h(map_view_frag l dq (Some v))"
abbreviation points_to_disc :: "'l \<Rightarrow> 'v \<Rightarrow> 'a upred_f" where
  "points_to_disc \<equiv> \<lambda>l v. points_to l DfracDiscarded v"
abbreviation points_to_own :: "'l \<Rightarrow> frac \<Rightarrow> 'v \<Rightarrow> 'a upred_f" where
  "points_to_own \<equiv> \<lambda>l p v. points_to l (DfracOwn p) v"
abbreviation points_to_full :: "'l \<Rightarrow> 'v \<Rightarrow> 'a upred_f" where
  "points_to_full \<equiv> \<lambda>l v. points_to_own l 1 v"

lemma points_to_valid:
  "(points_to l dq v) -\<^emph> \<upharpoonleft>(valid dq)"
proof -
  have "(points_to l dq v) \<turnstile> \<V>(put_heap heap_name (\<circle>V [l\<mapsto>(dq,to_ag (Some v))]))"
    by (auto simp: points_to_def inG.own_valid'[OF heap_inG] map_view_frag_def)
  moreover have "\<V>(put_heap heap_name (\<circle>V [l\<mapsto>(dq,to_ag (Some v))])) \<turnstile>
    \<V>((\<circle>V [l\<mapsto>(dq,to_ag (Some v))])::('l,'v option) heap)"
    using heap_valid by blast
  ultimately have "(points_to l dq v) \<turnstile> \<upharpoonleft>(valid dq)"
    using heap_frag_valid upred_entails_trans by blast
  from upred_wand_holdsI [OF this] show ?thesis .
  qed
end

context
fixes get_heap :: "gname \<Rightarrow> 'a::ucamera \<Rightarrow> ('l,'v::discrete option) heap option"
  and put_heap
assumes heap_inG: "inG get_heap put_heap"
begin

abbreviation "points_to' \<equiv> points_to put_heap"
abbreviation "points_to_disc' \<equiv> points_to_disc put_heap"
abbreviation "points_to_own' \<equiv> points_to_own put_heap"
abbreviation "points_to_full' \<equiv> points_to_full put_heap"

notation points_to' ("_ \<mapsto>{_} _" 60)
notation points_to_disc' (infix "\<mapsto>\<box>" 60)
notation points_to_own' ("_\<mapsto>{#_}_" 60)
notation points_to_full' (infix "\<mapsto>\<^sub>u" 60)

lemma points_to_agree: "upred_holds ((((l::'l) \<mapsto>{dq1} (v1::'v))::'a upred_f) -\<^emph> ((l \<mapsto>{dq2} v2) -\<^emph> \<upharpoonleft>(v1 = v2)))"
proof -
  have "upred_holds ((l \<mapsto>{dq1} v1) -\<^emph> ((l \<mapsto>{dq2} v2)) -\<^emph>
    \<V>(put_heap heap_name (\<circle>V [l\<mapsto>(dq1, to_ag (Some v1))]) \<cdot>
    put_heap heap_name (\<circle>V [l\<mapsto>(dq2, to_ag (Some v2))])))"
    apply (simp add: points_to_def[OF heap_inG]) by (metis heap_inG inG.own_def map_view_frag_def upred_own_valid2)
  then have "upred_holds ((l \<mapsto>{dq1} v1) -\<^emph> ((l \<mapsto>{dq2} v2)) -\<^emph>
    \<V>(put_heap heap_name (\<circle>V ([l\<mapsto>(dq1, to_ag (Some v1))\<cdot>(dq2, to_ag (Some v2))]))))"
    by (auto simp: inG.put_op[OF heap_inG, symmetric] view_frag_def op_map_view_def
      op_option_def)
  then have v:"upred_holds ((l \<mapsto>{dq1} v1) -\<^emph> ((l \<mapsto>{dq2} v2)) -\<^emph>
    \<V>(\<circle>V ([l\<mapsto>(dq1, to_ag (Some v1))\<cdot>(dq2, to_ag (Some v2))])))"
    using upred_entails_wand_holdsR2[OF heap_valid, OF heap_inG] by blast
  have "valid (\<circle>V [l \<mapsto> (dq1, to_ag (Some v1)) \<cdot> (dq2, to_ag (Some v2))]) \<Longrightarrow>
    valid (to_ag (Some v1) \<cdot> to_ag (Some v2))"
    apply (auto simp: valid_def view_frag_def valid_raw_map_view.rep_eq map_view_rel_def op_prod_def
      split: option.splits)
    by (metis n_valid_ne ofe_sym to_ag_n_valid)
  from d_ag_agree[OF this] have "valid (\<circle>V [l \<mapsto> (dq1, to_ag (Some v1)) \<cdot> (dq2, to_ag (Some v2))]) \<Longrightarrow> v1=v2"
    by (auto simp: to_ag_def Abs_ag_inject)
  from upred_entails_wand_holdsR2[OF
    pure_entailsI[of "valid (\<circle>V [l \<mapsto> (dq1, to_ag (Some v1)) \<cdot> (dq2, to_ag (Some v2))])" "v1=v2", OF this, simplified]
    upred_entails_wand_holdsR2[OF upred_entail_eqL[OF discrete_valid] v]]
  show ?thesis .
qed

lemma points_to_combine_same:"((l \<mapsto>{dq1} v)) \<^emph> (l \<mapsto>{dq2} v) \<turnstile> (l \<mapsto>{dq1 \<cdot> dq2} v)"
  apply (unfold points_to_def[OF heap_inG] map_view_frag_def view_frag_def)
  apply (unfold heap_op_val_eq[OF heap_inG,symmetric])
  apply (rule upred_entails_trans[OF upred_entail_eqR[OF inG.own_op[OF heap_inG]]])
  by (auto simp: op_map_view_def op_option_def)

lemma points_to_combine: "upred_holds ((l\<mapsto>{dq1} v1) -\<^emph> ((l \<mapsto>{dq2} v2) -\<^emph> ((l\<mapsto>{dq1\<cdot>dq2} v1) \<^emph> \<upharpoonleft>(v1=v2))))"
  apply (rule upred_wand_holds2I)
  apply (rule upred_sep_pure)
  apply (rule entails_pure_extend[OF upred_wandE[OF upred_wand_holdsE[OF points_to_agree]]])
  using points_to_combine_same points_to_def[OF heap_inG] apply fastforce
  by (simp add: points_to_agree upred_wand_holds2E)

lemma points_to_frac_ne:
  assumes "\<not> (valid (dq1\<cdot>dq2))"
  shows "upred_holds ((l1 \<mapsto>{dq1} v1) -\<^emph> ((l2 \<mapsto>{dq2} v2) -\<^emph> \<upharpoonleft>(l1\<noteq>l2)))"
proof -
  have valid_drop :
    "valid (put_heap heap_name (\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot>
    put_heap heap_name (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))])) =
      valid ((\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot> (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))]))"
    by (simp add: valid_def inG.put_n_valid[OF heap_inG] inG.put_op[OF heap_inG, symmetric])
  have "\<V>((put_heap heap_name (\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot>
      put_heap heap_name (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))])))
    \<turnstile> \<upharpoonleft>(valid (put_heap heap_name (\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot>
      put_heap heap_name (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))])))"
    apply (simp add: upred_pure.rep_eq upred_entails.rep_eq upred_valid.rep_eq
      valid_def inG.put_n_valid[OF heap_inG] inG.put_op[OF heap_inG, symmetric])
    using dcamera_valid_iff by auto
  then have base: "upred_holds ((l1 \<mapsto>{dq1} v1) -\<^emph> ((l2 \<mapsto>{dq2} v2)) -\<^emph>
    \<upharpoonleft>(valid (put_heap heap_name (\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot>
    put_heap heap_name (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))]))))"
    using upred_wand_holds2I[OF upred_entails_trans[OF upred_wand_holds2E[OF upred_own_valid2]]]
      points_to_def[OF heap_inG] by (metis heap_inG inG.own_def map_view_frag_def)
  from assms have "valid ((\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot> (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))]))
    \<Longrightarrow> l1\<noteq>l2"
    apply (simp add: valid_def)
    apply (rule notI)
    apply (simp add: view_frag_def op_map_view_def heap_op op_prod_def op_option_def)
    apply (auto simp: valid_raw_map_view.rep_eq map_view_rel_def split: option.splits)
    by (metis assms)
  then have "\<upharpoonleft>(valid ((\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot> (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))]))) \<turnstile>
    \<upharpoonleft>(l1\<noteq>l2)" using pure_entailsI by blast
  with valid_drop have
    "\<upharpoonleft>(valid (put_heap heap_name (\<circle>V [l1\<mapsto>(dq1,to_ag (Some v1))]) \<cdot>
    put_heap heap_name (\<circle>V [l2\<mapsto>(dq2,to_ag (Some v2))])))
    \<turnstile> \<upharpoonleft>(l1\<noteq>l2)" by simp
    from upred_entails_wand_holdsR2[OF this base] show ?thesis .
qed

lemma points_to_ne: "upred_holds ((l1\<mapsto>\<^sub>uv1) -\<^emph> ((l2 \<mapsto>{dq2} v2)) -\<^emph> \<upharpoonleft>(l1\<noteq>l2))"
by (rule points_to_frac_ne[OF dfrac_not_valid_own])

lemma timeless_points_to [timeless_rule, log_prog_rule]: "timeless (l\<mapsto>{p}v)"
  unfolding points_to_def[OF heap_inG]
  apply (auto simp: inG.own_def[OF heap_inG] upred_own.rep_eq dcamera_val_def discrete_val_def
    inG.put_ne[OF heap_inG] ofe_refl valid_def inG.put_n_valid[OF heap_inG] ofe_limit
    intro!: own_timeless')
  apply (smt (verit, best) d_equiv heap_inG inG.put_ne inG.put_ne2)
  apply (smt (verit, best) d_equiv heap_inG inG.put_ne inG.put_ne2)
  using dcamera_valid_iff by blast

lemma points_to_lookup: "heap_interp put_heap h \<^emph> (l\<mapsto>\<^sub>uv) \<turnstile> \<upharpoonleft>(fmlookup h l = Some (Some v))"
proof -
  have "heap_interp put_heap h \<^emph> (l\<mapsto>\<^sub>uv) \<turnstile> own_heap put_heap (map_view_auth (DfracOwn 1) h \<cdot> map_view_frag l (DfracOwn 1) (Some v))"
    unfolding heap_interp_def[OF heap_inG] points_to_def[OF heap_inG] own_heap_auth_def[OF heap_inG]
    apply (rule upred_entails_trans[OF upred_entail_eqR[OF inG.own_op[OF heap_inG]]])
    by (auto simp: op_prod_def \<epsilon>_left_id)
  then have "heap_interp put_heap h \<^emph> (l\<mapsto>\<^sub>uv) \<turnstile> \<V> (map_view_auth (DfracOwn 1) h \<cdot> map_view_frag l (DfracOwn 1) (Some v))"
    using inG.own_valid[OF heap_inG] heap_valid[OF heap_inG] upred_entails_trans by blast
  then have 1: "heap_interp put_heap h \<^emph> (l\<mapsto>\<^sub>uv) \<turnstile> \<upharpoonleft>(valid (map_view_auth (DfracOwn 1) h \<cdot> map_view_frag l (DfracOwn 1) (Some v)))"
    using discrete_valid upred_entail_eqL upred_entails_trans by blast
  have "valid (map_view_auth (DfracOwn 1) h \<cdot> map_view_frag l (DfracOwn 1) (Some v)) \<Longrightarrow> fmlookup h l = Some (Some v)"
    unfolding valid_def view_both_valid map_view_auth_def map_view_frag_def map_view_rel_def
    apply auto by (metis d_equiv to_ag_n_equiv)
  then have "\<upharpoonleft>(valid (map_view_auth (DfracOwn 1) h \<cdot> map_view_frag l (DfracOwn 1) (Some v))) \<turnstile> \<upharpoonleft>(fmlookup h l = Some (Some v))"
    by fastforce
  with 1 show ?thesis by (rule upred_entails_trans)
qed
end

subsubsection \<open>Prophecy map camera\<close>
context
fixes get_prophm :: "gname \<Rightarrow> 'a::ucamera \<Rightarrow> ('p, 'vs::ofe) proph_mapGS option"
  and put_prophm
assumes prophm_inG: "inG get_prophm put_prophm"
begin
text \<open>Unique name for singleton \<^typ>\<open>('p, 'vs) proph_mapGS\<close> camera\<close>
definition "proph_map_name :: gname \<equiv> 4"

abbreviation proph_own :: "('p, 'vs) proph_mapGS \<Rightarrow> 'a upred_f" ("Own\<^sub>p _") where
  "proph_own pm \<equiv> own put_prophm proph_map_name pm"

abbreviation own_proph_auth :: "frac \<Rightarrow> ('p, 'vs list) fmap \<Rightarrow> 'a upred_f" where
  "own_proph_auth q m \<equiv> Own\<^sub>p(map_view_auth (DfracOwn q) m)"

definition proph_map_interp :: "('p \<times> 'vs) list \<Rightarrow> 'p fset \<Rightarrow> 'a upred_f" where
  "proph_map_interp pvs ps \<equiv> \<exists>\<^sub>u R. (\<upharpoonleft>(proph_resolves_in_list R pvs \<and> fmdom R |\<subseteq>| ps))
    \<^emph> (own_proph_auth 1 R)"

definition proph :: "'p \<Rightarrow> 'vs list \<Rightarrow> 'a upred_f" where
  "proph p vs = Own\<^sub>p(map_view_frag p (DfracOwn 1) vs)"
end
end