theory Model_locale
  imports Ord_locale
  keywords "model_interpretation" "model_closed" :: thy_goal
  begin

locale Model = Ord Mem Emp Set Union Subset Pow Succ Inf Repl
    for Mem :: "'d \<Rightarrow> 'd \<Rightarrow> bool" (infixl \<open>\<in>\<close> 50)
    and Emp :: "'d" (\<open>\<emptyset>\<close>) and Set :: "'d \<Rightarrow> bool"
    and Union :: "'d \<Rightarrow> 'd" (\<open>\<Union>_\<close> [90] 90)
    and Subset:: "['d,'d] \<Rightarrow> bool" (infixl \<open>\<subseteq>\<close> 50)
    and Pow ::  "'d \<Rightarrow> 'd" (\<open>\<P>\<close> 90)
    and Succ :: "'d \<Rightarrow> 'd"
    and Inf :: "'d"  \<comment> \<open>witness of Infinity\<close>
    and Repl :: "[['d,'d] \<Rightarrow> bool] \<Rightarrow> 'd \<Rightarrow>'d" (\<open>\<R>\<close> 90)  +
  fixes
    set :: "'d" and ord :: "'d" and
    Ops :: "'d \<Rightarrow> 'd \<Rightarrow> 'd \<Rightarrow> 'd" and
    Ignored :: "'d"
  assumes (*Consider abstracting the tag from the locale,
            because later we will want to keep the proofs,
            but not the tag*)
          (*Can we make a weak set theory?*)
    ops_setseq_ax : "\<forall>\<beta> x. setseq (\<lambda>\<alpha>. Ops \<alpha> \<beta> x)" and
    ig_set : "Set (Ignored)" and

    tags : "set < \<omega> \<and> ord < \<omega>" and
    ops_set_0_ax : "Ops set 0 x = \<emptyset>" and
    ops_set_succ_ax : "\<forall>\<beta>. Ord \<beta> \<longrightarrow> Ops set (succ \<beta>) = Pow" and
    ops_set_lim_ax : "\<forall>\<mu>. Limit \<mu> \<longrightarrow> Ops set \<mu> f = \<emptyset>" and
    ops_ord_ax : "\<forall>\<beta>. Ord \<beta> \<longrightarrow> Ops ord \<beta> x = sng \<beta>"

context Model begin

subsection \<open>Tagging operations - currently implemented with Kuratowski pairs\<close>

abbreviation Tag :: "'d \<Rightarrow> 'd \<Rightarrow> 'd" (infixl \<open>\<triangleright>\<close> 70) where
  "n \<triangleright> x \<equiv> kpair n x"

abbreviation TagOf :: "'d \<Rightarrow> 'd" where
  "TagOf x \<equiv> \<tau> x"

abbreviation ObjOf :: "'d \<Rightarrow> 'd" where
  "ObjOf x \<equiv> \<pi> x"

subsection \<open>Tag all members of a set\<close>

definition TagSetMems :: "'d \<Rightarrow> 'd \<Rightarrow> 'd" where
  "TagSetMems \<beta> x \<equiv> RepFun (\<lambda>a. \<beta> \<triangleright> a) x"

lemma tmap_set : "Set x \<Longrightarrow> Set (TagSetMems \<beta> x)"
  unfolding TagSetMems_def by (rule repfun_set)

lemma tmap_iff : assumes "Set x" shows
  "b \<in> x \<longleftrightarrow> \<beta> \<triangleright> b \<in> TagSetMems \<beta> x"
  unfolding TagSetMems_def
  by (simp add: repfun_iff[OF assms],
      blast elim: pair_inject)

lemma tmapI : "b \<in> x \<Longrightarrow> \<beta> \<triangleright> b \<in> TagSetMems \<beta> x"
  using setI tmap_iff by auto

lemma tmapD : assumes "Set x"
  shows "b \<in> TagSetMems \<beta> x \<Longrightarrow> bex x (\<lambda>b'. b = (\<beta> \<triangleright> b'))"
  unfolding TagSetMems_def by (auto elim: repfunE[OF assms])

lemma tmapE : assumes "Set x"
  shows " \<lbrakk> b \<in> TagSetMems \<beta> x ;
    \<And>b'.\<lbrakk> b' \<in> x ; b = (\<beta> \<triangleright> b') \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P "
  unfolding TagSetMems_def  by (rule repfunE[OF assms])

subsection \<open>Disjoint Union of a sequence of sets\<close>

definition disj :: "['d \<Rightarrow> 'd] \<Rightarrow> 'd" (\<open>\<Uplus>\<close>) where
 "\<Uplus> X \<equiv> \<Union> RepFun (\<lambda>b. TagSetMems b (X b)) (predSet \<omega>)"

lemma disj_set : "Set (\<Uplus> X)" unfolding disj_def
  by (rule union_set[OF repfun_set[OF predset_set[OF \<omega>_ord]]])

lemma disj_iff : assumes "setseq X"
  shows "b \<in> \<Uplus> X \<longleftrightarrow> (rex (\<lambda>\<beta>. \<beta> < \<omega>) (\<lambda>\<beta>. bex (X \<beta>) (\<lambda>b'. b = (\<beta> \<triangleright> b'))))"
  unfolding disj_def
proof (simp add: repfun_union[OF predset_set[OF \<omega>_ord]], rule)
  assume "bex (predSet \<omega>) (\<lambda>\<beta>. b \<in> TagSetMems \<beta> (X \<beta>))"
  then obtain \<beta> where "\<beta> < \<omega>" "b \<in> TagSetMems \<beta> (X \<beta>)" using predset_iff[OF \<omega>_ord] by auto
  thus "rex (\<lambda>\<beta>. \<beta> < \<omega>) (\<lambda>\<beta>. bex (X \<beta>) (\<lambda>b'. b = (\<beta> \<triangleright> b')))" unfolding rex_def
    using assms \<open>\<beta> < \<omega>\<close> by (blast elim: tmapE)
next
  assume "rex (\<lambda>\<beta>. \<beta> < \<omega>) (\<lambda>\<beta>. bex (X \<beta>) (\<lambda>b'. b = (\<beta> \<triangleright> b')))"
  then obtain \<beta> and b' where "\<beta> < \<omega>" "b = (\<beta> \<triangleright> b')" "b' \<in> X \<beta>" by auto
  hence "\<beta> \<in> predSet \<omega>" and "b \<in> TagSetMems \<beta> (X \<beta>)"
    using predset_iff[OF \<omega>_ord] tmap_iff assms \<open>\<beta> < \<omega>\<close> by auto
  thus "bex (predSet \<omega>) (\<lambda>\<beta>. b \<in> TagSetMems \<beta> (X \<beta>))" by auto
qed

(*Weaker version*)
lemma disj_iff' : assumes "setseq X"
  shows "\<beta> \<triangleright> b' \<in> \<Uplus> X \<longleftrightarrow> \<beta> < \<omega> \<and> b' \<in> X \<beta>"
  by (simp add: disj_iff[OF assms],
      auto elim: pair_inject)

lemma disjI : "\<lbrakk> \<beta> < \<omega> ; b' \<in> X \<beta> \<rbrakk> \<Longrightarrow> \<beta> \<triangleright> b' \<in> \<Uplus> X"
  unfolding disj_def using
    repfun_union[OF predset_set[OF \<omega>_ord]]
    predset_iff[OF \<omega>_ord]
  by (blast intro: tmapI)

lemma disjE : assumes "setseq X"
  shows "\<lbrakk> b \<in> \<Uplus> X ; \<And>\<beta> b'. \<lbrakk> b = (\<beta> \<triangleright> b') ; \<beta> < \<omega> ; b' \<in> X \<beta>\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using disj_iff[OF assms] by auto

subsection \<open>Subset of a tagged set with tag \<beta>\<close>

definition Part :: "'d \<Rightarrow> 'd \<Rightarrow> 'd" where
 "Part \<beta> x \<equiv> Collect (\<lambda>b. (\<exists>b'. b = (\<beta> \<triangleright> b'))) x"

lemma part_set : assumes "Set x"
  shows "Set (Part \<beta> x)" unfolding Part_def by (rule collect_set[OF assms])

lemma part_iff : assumes "Set x"
  shows "b \<in> Part \<beta> x \<longleftrightarrow> b \<in> x \<and> (\<exists>b'. b = (\<beta> \<triangleright> b'))"
  unfolding Part_def using collect_iff[OF assms] by auto

lemma partI : "\<lbrakk> b = (\<beta> \<triangleright> b'); b \<in> x \<rbrakk> \<Longrightarrow> b \<in> Part \<beta> x "
  using part_iff setI by auto

lemma partI' : "\<alpha> \<triangleright> b \<in> x \<Longrightarrow> \<alpha> \<triangleright> b \<in> Part \<alpha> x"
  using partI by auto

lemma partD1 : assumes "Set x" shows "b \<in> Part \<beta> x \<Longrightarrow> \<tau> b = \<beta>"
  using part_iff[OF \<open>Set x\<close>] fst_eq by auto

lemma partD2 : assumes "Set x" shows "b \<in> Part \<beta> x \<Longrightarrow> b \<in> x"
  using part_iff[OF \<open>Set x\<close>] by auto

lemma partE : assumes "Set x"
  shows "\<lbrakk> b \<in> Part \<beta> x ; \<And>b'. \<lbrakk> b \<in> x ; b = (\<beta> \<triangleright> b') \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using part_iff[OF assms] by auto

lemma partD_pair : assumes "Set x"
  shows "\<alpha> \<triangleright> b \<in> Part \<beta> x \<Longrightarrow> \<alpha> = \<beta>"
  using part_iff[OF assms] pair_inject by auto

lemma part_subset :
  shows "x \<subseteq> y \<Longrightarrow> Part \<alpha> x \<subseteq> Part \<alpha> y"
proof -
  assume "x \<subseteq> y" hence "Set x" "Set y" using subset_set by simp_all
  hence "Set (Part \<alpha> x)" "Set (Part \<alpha> y)" using part_set by simp_all
  thus "Part \<alpha> x \<subseteq> Part \<alpha> y"
  proof
    fix a assume "a \<in> Part \<alpha> x" thus "a \<in> Part \<alpha> y"
      using \<open>x \<subseteq> y\<close> by (auto intro: partI elim: partE[OF \<open>Set x\<close>])
  qed
qed

lemma part_union : assumes "Set x" "Set y" shows "Part \<alpha> (x \<union> y) = Part \<alpha> x \<union> Part \<alpha> y"
proof (rule equality_iffI[OF part_set[OF un_set] un_set], simp add: un_iff, rule)
  fix a assume "a \<in> Part \<alpha> (x \<union> y)"
  thus "a \<in> Part \<alpha> x \<or> a \<in> Part \<alpha> y"
  proof (rule partE[OF un_set])
    fix a' assume "a \<in> x \<union> y" "a = (\<alpha> \<triangleright> a')"
    from \<open>a \<in> x \<union> y\<close> show "a \<in> Part \<alpha> x \<or> a \<in> Part \<alpha> y"
      by (auto elim: unE intro: partI[OF \<open>a = (\<alpha> \<triangleright> a')\<close>])
  qed
next
  fix a assume "a \<in> Part \<alpha> x \<or> a \<in> Part \<alpha> y"
  thus "a \<in> Part \<alpha> (x \<union> y)" proof
    assume "a \<in> Part \<alpha> x" thus "a \<in> Part \<alpha> (x \<union> y)"
      using part_subset[OF un_subset1[OF \<open>Set x\<close>]] by auto
  next
    assume "a \<in> Part \<alpha> y" thus "a \<in> Part \<alpha> (x \<union> y)"
      using part_subset[OF un_subset2[OF \<open>Set y\<close>]] by auto
  qed
qed

lemma part_disj_iff : assumes "setseq X"
  shows "b \<in> Part \<beta> (\<Uplus> X) \<longleftrightarrow> (\<beta> < \<omega> \<and> bex (X \<beta>) (\<lambda>b'. b = (\<beta> \<triangleright> b')))"
  by (simp add: part_iff[OF disj_set] disj_iff[OF \<open>setseq X\<close>],
      auto elim: pair_inject)

lemma part_disjI : "\<lbrakk> b = (\<beta> \<triangleright> b') ; b' \<in> X \<beta> ; \<beta> < \<omega> \<rbrakk> \<Longrightarrow> b \<in> Part \<beta> (\<Uplus> X)"
  by (auto intro: partI disjI)

lemma part_disjE : assumes "setseq X" shows
  "\<lbrakk> b \<in> Part \<beta> (\<Uplus> X) ; \<And>b'. \<lbrakk> b = (\<beta> \<triangleright> b') ; \<beta> < \<omega> ; b' \<in> X \<beta>  \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using part_disj_iff[OF assms] by auto

lemma set_tag : "set < \<omega>" by (simp add: tags)
lemma ord_tag : "ord < \<omega>" by (simp add: tags)

subsection \<open>Tier -- model building operator\<close>

definition Tier :: "'d \<Rightarrow> 'd" where
 "Tier \<equiv> OrdRec (\<lambda>\<mu> f. (\<Union> (f[predSet \<mu>])) \<union> \<Uplus> (\<lambda>\<alpha>. Ops \<alpha> \<mu> f - Ignored))
                (\<lambda>\<beta> x. x \<union> \<Uplus> (\<lambda>\<alpha>. Ops \<alpha> \<beta> (x - Ignored)))
                (\<Uplus> (\<lambda>\<alpha>. Ops \<alpha> 0 \<emptyset>))"

lemma no_set_ignored : "set \<triangleright> x' \<notin> Ignored" sorry
lemma no_ord_ignored : "ord \<triangleright> b' \<notin> Ignored" sorry

lemma ops_setseq : "setseq (\<lambda>\<alpha>. Ops \<alpha> \<beta> x)"
  by (simp add: ops_setseq_ax)

lemma ops_ig_setseq : "setseq (\<lambda>\<alpha>. Ops \<alpha> \<beta> x - Ignored)"
  using ops_setseq diff_set by blast

lemma ops_set : "\<alpha> < \<omega> \<Longrightarrow> Set (Ops \<alpha> \<beta> x)"
  using ops_setseq by auto

thm disj_iff'[OF ops_setseq]

subsection \<open>General lemmas about the structure of Tier\<close>

lemma tier_0 : "Tier 0 = \<Uplus> (\<lambda>a. Ops a 0 \<emptyset>)"
  unfolding Tier_def using ordrec_0 by simp

lemma tier0_iff : "x \<in> Tier 0 \<longleftrightarrow> rex (\<lambda>\<alpha>. \<alpha> < \<omega>) (\<lambda>\<alpha>. bex (Ops \<alpha> 0 \<emptyset>) (\<lambda>x'. x = (\<alpha> \<triangleright> x')))"
  unfolding tier_0 by (simp add: disj_iff[OF ops_setseq])

lemma tier0_iff' : "\<alpha> \<triangleright> x' \<in> Tier 0 \<longleftrightarrow> \<alpha> < \<omega> \<and> x' \<in> Ops \<alpha> 0 \<emptyset> "
  using tier0_iff by (auto elim: pair_inject)

lemma tier_succ : assumes "Ord \<beta>"
  shows "Tier (succ \<beta>) = Tier \<beta> \<union> \<Uplus> (\<lambda>a. Ops a (succ \<beta>) (Tier \<beta> - Ignored))"
  unfolding Tier_def using ordrec_succ assms by simp

lemma tier_succ_iff : assumes "Ord \<beta>"
  shows "x \<in> Tier (succ \<beta>) \<longleftrightarrow> x \<in> Tier \<beta> \<or> (rex (\<lambda>\<alpha>. \<alpha> < \<omega>) (\<lambda>\<alpha>. bex (Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored)) (\<lambda>x'. x = (\<alpha> \<triangleright> x'))))"
  unfolding tier_succ[OF assms] un_iff disj_iff[OF ops_setseq] by simp

lemma tier_succI1 : assumes "Ord \<beta>"
  shows "x \<in> Tier \<beta> \<Longrightarrow> x \<in> Tier (succ \<beta>)"
  unfolding tier_succ_iff[OF assms] by simp

lemma tier_succI2 : assumes "Ord \<beta>"
  shows "\<lbrakk> \<alpha> < \<omega>;  x = \<alpha> \<triangleright> x'; x' \<in> Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored) \<rbrakk> \<Longrightarrow> x \<in> Tier (succ \<beta>)"
  using tier_succ_iff[OF assms] by auto

lemma tier_succE : assumes "Ord \<beta>"
  shows "\<lbrakk> x \<in> Tier (succ \<beta>); x \<in> Tier \<beta> \<Longrightarrow> P;
   \<And>\<alpha> x'.\<lbrakk> \<alpha> < \<omega>; x = \<alpha> \<triangleright> x'; x' \<in> Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  using tier_succ_iff[OF assms] by blast

lemma tier_succ_iff' : assumes "Ord \<beta>"
  shows "\<alpha> \<triangleright> x' \<in> Tier (succ \<beta>) \<longleftrightarrow> (\<alpha> \<triangleright> x') \<in> Tier \<beta> \<or> (\<alpha> < \<omega> \<and> x' \<in> Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored))"
  using tier_succ_iff[OF assms] by (auto elim: pair_inject)

lemma tier_limit : assumes "Limit \<mu>"
  shows "Tier \<mu> = (\<Union> RepFun Tier (predSet \<mu>)) \<union>
                (\<Uplus> (\<lambda>\<alpha>. Ops \<alpha> \<mu> (Lambda (predSet \<mu>) (\<lambda>\<beta>. Tier \<beta>)) - Ignored))"
  unfolding Tier_def by (simp add: ordrec_lim assms image_domain)

lemma tier_lim_iff : assumes "Limit \<mu>"
  shows "x \<in> Tier \<mu> \<longleftrightarrow> (rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Tier \<beta>))
                     \<or> (rex (\<lambda>\<alpha>. \<alpha> < \<omega>) (\<lambda>\<alpha>. bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x')))"
  unfolding tier_limit[OF assms] repfun_union[OF predset_set[OF limit_ord[OF assms]]]
            un_iff disj_iff[OF ops_ig_setseq] predset_iff[OF limit_ord[OF assms]] rex_def bex_def by auto

(*lemma tier_limit_ops_subset : assumes "Limit \<mu>"
  shows "\<alpha> < \<omega> \<Longrightarrow> Ops \<alpha> \<mu> (Lambda (predSet \<mu>) (\<lambda>\<beta>. Tier \<beta>)) - Ignored \<subseteq> Tier \<mu>"
proof -
  let ?O = "(\<lambda>a. Ops a \<mu> (Lambda (predSet \<mu>) (\<lambda>\<beta>. Tier \<beta>)) - Ignored)"
  assume "\<alpha> < \<omega>" hence "?O \<alpha> \<subseteq> (\<Union> RepFun ?O (predSet \<omega>))"
    using repfun_union_subset[OF predsetI] subset_refl[OF diff_set[OF ops_set]] by auto
  thus "?O \<alpha> \<subseteq> Tier \<mu>"  unfolding tier_limit[OF assms]
    using subset_trans[OF _ un_subset2[OF union_set[OF repfun_set[OF predset_set[OF \<omega>_ord]]]]] by auto
qed*)

lemma tier_limI1 : assumes "Limit \<mu>"
  shows "\<beta> < \<mu> \<Longrightarrow> x \<in> Tier \<beta> \<Longrightarrow> x \<in> Tier \<mu>"
  unfolding tier_lim_iff[OF assms] by auto

lemma tier_limI2 : assumes "Limit \<mu>"
  shows "\<alpha> < \<omega> \<Longrightarrow> x \<in> Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) \<Longrightarrow> x \<notin> Ignored \<Longrightarrow> \<alpha> \<triangleright> x \<in> Tier \<mu>"
  unfolding tier_lim_iff[OF assms] by (auto intro: diffI)

lemma tier_limE : assumes "Limit \<mu>" shows "\<lbrakk> x \<in> Tier \<mu> ;
  \<And>\<beta>. \<lbrakk> \<beta> < \<mu> ; x \<in> Tier \<beta> \<rbrakk> \<Longrightarrow> P ;
  \<And>\<alpha> x'. \<lbrakk> \<alpha> < \<omega> ; x = \<alpha> \<triangleright> x' ; x' \<in> Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier); x' \<notin> Ignored \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  unfolding tier_lim_iff[OF assms] using diffE[OF ops_set] by blast

lemma tier_set : assumes "Ord \<beta>" shows "Set (Tier \<beta>)"
  by (rule ord_cases[OF assms],
      simp_all add: disj_set un_set union_set[OF repfun_set[OF predset_set]]
                    tier_0 tier_succ tier_limit)

corollary tier0_set : "Set (Tier 0)" by (rule tier_set[OF zero_ord])
corollary tiersucc_set : "Ord \<beta> \<Longrightarrow> Set (Tier (succ \<beta>))" by (rule tier_set[OF succ_ord])
corollary tierlimit_set : "Limit \<mu> \<Longrightarrow> Set (Tier \<mu>)" by (rule tier_set[OF limit_ord])

lemma tier_subset : assumes "Ord \<beta>" shows "Tier \<beta> \<subseteq> Tier (succ \<beta>)"
  using tier_succ[OF \<open>Ord \<beta>\<close>] un_subset1[OF tier_set[OF \<open>Ord \<beta>\<close>]] by auto

lemma tier_limit_union : assumes "Limit \<mu>"
  shows "\<Union> RepFun Tier (predSet \<mu>) \<subseteq> Tier \<mu>"
  unfolding tier_limit[OF assms]
  using un_subset1[OF union_set[OF repfun_set[OF predset_set[OF limit_ord[OF assms]]]]]
  by auto

lemma tier_limit_subset : assumes "Limit \<mu>"
  shows "\<beta> < \<mu> \<Longrightarrow> Tier \<beta> \<subseteq> Tier \<mu>"
  using repfun_union_subset[OF predsetI] subset_refl[OF tier_set[OF lt_ord1]]
        subset_trans[OF _ tier_limit_union[OF assms]]
  by auto

lemma tier_increasing' : assumes "Ord \<beta>" shows "\<alpha> < \<beta> \<Longrightarrow> Tier \<alpha> \<subseteq> Tier \<beta>"
proof (induct rule: trans_induct3[OF \<open>Ord \<beta>\<close>])
  case 1
  then show ?case using zero_def by auto
next
  case IH:(2 \<beta>)
  from \<open>\<alpha> \<le> \<beta>\<close> have "\<alpha> < \<beta> | \<alpha> = \<beta>" using le_iff by auto
  thus ?case proof (rule)
    assume "\<alpha> < \<beta>" hence "Tier \<alpha> \<subseteq> Tier \<beta>" using IH(2) by simp
    thus "Tier \<alpha> \<subseteq> Tier (succ \<beta>)" using subset_trans[OF _ tier_subset[OF \<open>Ord \<beta>\<close>]] by auto
  next
    assume "\<alpha> = \<beta>" thus "Tier \<alpha> \<subseteq> Tier (succ \<beta>)" using tier_subset[OF \<open>Ord \<beta>\<close>] by auto
  qed
next
  case IH:(3 \<mu>)
  from tier_limit_subset[OF IH(1) IH(3)] show ?case by simp
qed

lemma tier_increasing : assumes "\<alpha> < \<beta>" shows "Tier \<alpha> \<subseteq> Tier \<beta>"
  using tier_increasing'[OF lt_ord2[OF assms] assms] by auto

lemma greatest_tier : assumes "Ord \<alpha>" "Ord \<beta>"
  shows "\<lbrakk> x \<in> Tier \<alpha> ; y \<in> Tier \<beta> \<rbrakk> \<Longrightarrow> (\<exists>\<gamma>. x \<in> Tier \<gamma> \<and> y \<in> Tier \<gamma>)"
proof -
  assume xy: "x \<in> Tier \<alpha>" "y \<in> Tier \<beta>"
  show "(\<exists>\<gamma>. x \<in> Tier \<gamma> \<and> y \<in> Tier \<gamma>)"
  proof (rule Ord_linear_lt[OF assms], rule_tac [1] exI, rule_tac [2] exI, rule_tac [3] exI)
    assume "\<alpha> < \<beta>" thus "x \<in> Tier \<beta> \<and> y \<in> Tier \<beta>"
      using subsetD[OF tier_increasing] xy by auto
  next
    assume "\<alpha> = \<beta>" thus "x \<in> Tier \<beta> \<and> y \<in> Tier \<beta>" using xy by simp
  next
    assume "\<beta> < \<alpha>" thus "x \<in> Tier \<alpha> \<and> y \<in> Tier \<alpha>"
      using subsetD[OF tier_increasing] xy by auto
  qed
qed

subsection \<open>Parts of Tier\<close>

lemma part_tier0_iff : "x \<in> Part \<alpha> (Tier 0) \<longleftrightarrow> \<alpha> < \<omega> \<and> bex (Ops \<alpha> 0 \<emptyset>) (\<lambda>x'. x = (\<alpha> \<triangleright> x'))"
  by (simp add: part_iff[OF tier0_set] tier0_iff, auto elim: pair_inject)

lemma part_tier0I : "\<lbrakk> \<alpha> < \<omega> ; x' \<in> Ops \<alpha> 0 \<emptyset> ; x = \<alpha> \<triangleright> x' \<rbrakk> \<Longrightarrow> x \<in> Part \<alpha> (Tier 0)"
  using part_tier0_iff by auto

lemma part_tier0E : "\<lbrakk> x \<in> Part \<alpha> (Tier 0) ; \<And>x'. \<lbrakk> x' \<in> Ops \<alpha> 0 \<emptyset> ; x = \<alpha> \<triangleright> x' \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using part_tier0_iff by auto

(* A strong but ugly lemma for the successor case *)
lemma part_tiersucc_iff : assumes "Ord \<beta>" shows "x \<in> Part \<alpha> (Tier (succ \<beta>)) \<longleftrightarrow>
  (x \<in> Part \<alpha> (Tier \<beta>) \<or> (\<alpha> < \<omega> \<and> bex (Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored)) (\<lambda>x'. x = (\<alpha> \<triangleright> x'))))"
  by (simp add: tier_succ[OF assms]
                part_union[OF tier_set[OF assms] disj_set]
                un_iff part_disj_iff[OF ops_setseq])

lemma part_tiersuccI1 : assumes "Ord \<beta>"
  shows "\<lbrakk> \<alpha> < \<omega> ; x' \<in> Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored); x = \<alpha> \<triangleright> x'\<rbrakk>
        \<Longrightarrow> x \<in> Part \<alpha> (Tier (succ \<beta>))"
  using part_tiersucc_iff[OF assms] by auto

lemma part_tiersuccI2 : assumes "Ord \<beta>"
  shows "x \<in> Part \<alpha> (Tier \<beta>) \<Longrightarrow> x \<in> Part \<alpha> (Tier (succ \<beta>))"
  using part_tiersucc_iff[OF assms] by auto

lemma part_tiersuccE : assumes "Ord \<beta>" shows "\<lbrakk> x \<in> Part \<alpha> (Tier (succ \<beta>)) ;
        x \<in> Part \<alpha> (Tier \<beta>)  \<Longrightarrow> P ;
  \<And>x'.\<lbrakk> x' \<in> Ops \<alpha> (succ \<beta>) (Tier \<beta> - Ignored) ; x = \<alpha> \<triangleright> x' \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using part_tiersucc_iff[OF assms] by auto

lemma part_tierlim_iff : assumes "Limit \<mu>"
  shows "x \<in> Part \<alpha> (Tier \<mu>) \<longleftrightarrow> (rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>)))
             \<or> (\<alpha> < \<omega> \<and> bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x')) "
proof
  assume "x \<in> Part \<alpha> (Tier \<mu>)"
  then obtain x' where "x \<in> Tier \<mu>" "x = \<alpha> \<triangleright> x'" using partE[OF tierlimit_set[OF assms]] by auto
  show "(rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))) \<or>
         (\<alpha> < \<omega> \<and> bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x'))"
  proof (rule tier_limE[OF assms(1) \<open>x \<in> Tier \<mu>\<close>], rule disjI1)
    fix \<beta> assume "\<beta> < \<mu>" "x \<in> Tier \<beta>"
    thus "(rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>)))" using partI[OF \<open>x = \<alpha> \<triangleright> x'\<close>] by auto
  next
    fix \<alpha>' x'' assume "\<alpha>' < \<omega>" "x = \<alpha>' \<triangleright> x''" "x'' \<in> Ops \<alpha>' \<mu> (Lambda (predSet \<mu>) Tier)" "x'' \<notin> Ignored"
    moreover hence "\<alpha> = \<alpha>'" "x' = x''" using \<open>x = \<alpha> \<triangleright> x'\<close> by (auto elim: pair_inject)
    ultimately have "\<alpha> < \<omega> \<and> bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x')"
      using diffI by auto
    thus "(rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))) \<or>
          (\<alpha> < \<omega> \<and> bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x'))" by simp
  qed
next
  assume "(rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))) \<or>
        (\<alpha> < \<omega> \<and> bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x'))"
  thus "x \<in> Part \<alpha> (Tier \<mu>)" proof
    assume "rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))"
    then obtain \<beta> where "\<beta> < \<mu>" "x \<in> Part \<alpha> (Tier \<beta>)" by auto
    then obtain x' where "x \<in> Tier \<beta>" "x = \<alpha> \<triangleright> x'" using partE[OF tier_set[OF lt_ord1]] by blast
    thus "x \<in> Part \<alpha> (Tier \<mu>)" using tier_limI1[OF assms \<open>\<beta> < \<mu>\<close>] partI by auto
  next
    assume "\<alpha> < \<omega> \<and> bex (Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier) - Ignored) (\<lambda>x'. x = \<alpha> \<triangleright> x')"
    then obtain x' where "x = \<alpha> \<triangleright> x'" "\<alpha> < \<omega>" "x' \<in> Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier)" "x' \<notin> Ignored"
      using diff_iff[OF ops_set] by auto
    thus "x \<in> Part \<alpha> (Tier \<mu>)" using partI tier_limI2[OF assms] by auto
  qed
qed

lemma part_tierlimI : assumes "Limit \<mu>"
  shows "\<lbrakk> \<alpha> < \<omega> ; x' \<in> Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier); x' \<notin> Ignored; x = \<alpha> \<triangleright> x'\<rbrakk>
          \<Longrightarrow> x \<in> Part \<alpha> (Tier \<mu>) "
  using part_tierlim_iff[OF assms] diffI by auto

lemma part_tierlimE : assumes "Limit \<mu>"
  shows "\<lbrakk> x \<in> Part \<alpha> (Tier \<mu>) ;
    \<And>\<beta>. \<lbrakk> \<beta> < \<mu>; x \<in> Part \<alpha> (Tier \<beta>) \<rbrakk> \<Longrightarrow> P ;
    \<And>x'. \<lbrakk> x = \<alpha> \<triangleright> x'; x' \<in> Ops \<alpha> \<mu> (Lambda (predSet \<mu>) Tier); x' \<notin> Ignored \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using part_tierlim_iff[OF assms] diff_iff[OF ops_set] by auto

lemma tier_tagged : assumes "Ord \<beta>"
  shows "x \<in> Tier \<beta> \<Longrightarrow> (\<exists>\<alpha> x'. \<alpha> < \<omega> \<and> x = \<alpha> \<triangleright> x')"
proof (induct rule: trans_induct3[OF assms])
  case 1
  then show ?case using tier0_iff unfolding bex_def rex_def by auto
next
  case IH:(2 \<beta>)
  show ?case by (rule tier_succE[OF IH(1,3)], use IH(2) in auto)
next
  case IH:(3 \<mu>)
  show ?case by (rule tier_limE[OF IH(1,3)], use IH(2) in auto)
qed

lemma part_succ_subset : assumes "Ord \<beta>"
  shows "Part \<alpha> (Tier \<beta>) \<subseteq> Part \<alpha> (Tier (succ \<beta>))"
  by (rule part_subset[OF tier_subset[OF assms]])

subsection \<open>Structure of the 'set' part of Tier\<close>

thm ops_set_0_ax
lemma ops_set_succ : "Ord \<beta> \<Longrightarrow> Ops set (succ \<beta>) x = Pow x" using ops_set_succ_ax by simp
lemma ops_set_lim : "Limit \<mu> \<Longrightarrow> Ops set \<mu> f = \<emptyset>" using ops_set_lim_ax by simp

lemma set_limit_iff : assumes "Limit \<mu>"
  shows "x \<in> Part set (Tier \<mu>) \<longleftrightarrow> rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. x \<in> Part set (Tier \<beta>))"
  unfolding part_tierlim_iff[OF assms] using ops_set_lim[OF assms] emp diff_iff[OF emp_set] by auto

lemma set_limI : assumes "Limit \<mu>"
  shows "\<lbrakk> \<beta> < \<mu> ; x \<in> Part set (Tier \<beta>) \<rbrakk> \<Longrightarrow> x \<in> Part set (Tier \<mu>)"
  using set_limit_iff[OF assms] by auto

lemma set_limE : assumes "Limit \<mu>"
  shows "\<lbrakk> x \<in> Part set (Tier \<mu>) ; \<And>\<beta> x'. \<lbrakk> \<beta> < \<mu> ; x \<in> Tier \<beta> ; x = set \<triangleright> x' \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using set_limit_iff[OF assms] part_iff[OF tier_set] lt_ord1 limit_ord[OF assms] by auto

lemma set_0 : "Part set (Tier 0) = \<emptyset>"
  by (rule equals0I[OF part_set[OF tier0_set]], unfold part_tier0_iff ops_set_0_ax, auto)

lemma set_succ_iff : assumes "Ord \<beta>" shows
  "x \<in> Part set (Tier (succ \<beta>)) \<longleftrightarrow> (\<exists>x'. x' \<subseteq> (Tier \<beta> - Ignored) \<and> x = set \<triangleright> x')"
proof (induct rule: trans_induct3[OF assms])
  case 1
  then show ?case proof (rule)
    assume "x \<in> Part set (Tier (succ 0))"
    thus "\<exists>x'. x' \<subseteq> Tier 0 - Ignored \<and> x = set \<triangleright> x'"
    proof (rule part_tiersuccE[OF zero_ord])
      from set_0 show "x \<in> Part set (Tier 0) \<Longrightarrow> \<exists>x'. x' \<subseteq> Tier 0 - Ignored \<and> x = set \<triangleright> x'" by auto
    next
      fix x' assume "x' \<in> Ops set (succ 0) (Tier 0 - Ignored)" "x = set \<triangleright> x'"
      hence "x' \<in> Pow (Tier 0 - Ignored)" using ops_set_succ assms by simp
      hence "x' \<subseteq> Tier 0 - Ignored" using powD[OF diff_set[OF tier0_set]] by simp
      thus "\<exists>x'. x' \<subseteq> Tier 0 - Ignored \<and> x = set \<triangleright> x'" using \<open>x = set \<triangleright> x'\<close> by auto
    qed
  next
    assume "\<exists>x'. x' \<subseteq> Tier 0 - Ignored \<and> x = set \<triangleright> x'"
    thus "x \<in> Part set (Tier (succ 0))"
      using part_tiersuccI1[OF zero_ord set_tag]
            ops_set_succ powI by auto
  qed
next
  case IH:(2 \<beta>)
  show ?case proof (rule)
    assume "x \<in> Part set (Tier (succ (succ \<beta>)))"
    thus "\<exists>x'. x' \<subseteq> Tier (succ \<beta>) - Ignored \<and> x = set \<triangleright> x'"
    proof (rule part_tiersuccE[OF succ_ord[OF \<open>Ord \<beta>\<close>]])
      assume "x \<in> Part set (Tier (succ \<beta>))"
      then obtain x' where "x' \<subseteq> Tier \<beta> - Ignored" "x = set \<triangleright> x'" using IH(2) by auto
      moreover hence "x' \<subseteq> Tier (succ \<beta>) - Ignored" using diff_subset1[OF tier_subset[OF IH(1)]] by simp
      ultimately show "\<exists>x'. x' \<subseteq> Tier (succ \<beta>) - Ignored \<and> x = set \<triangleright> x'" by auto
    next
      fix x' assume "x' \<in> Ops set (succ (succ \<beta>)) (Tier (succ \<beta>) - Ignored)" "x = set \<triangleright> x'"
      thus "\<exists>x'. x' \<subseteq> Tier (succ \<beta>) - Ignored \<and> x = set \<triangleright> x'"
        using ops_set_succ[OF succ_ord[OF IH(1)]]
              powD[OF diff_set[OF tiersucc_set[OF IH(1)]]] by auto
    qed
  next
    assume "\<exists>x'. x' \<subseteq> Tier (succ \<beta>) - Ignored \<and> x = set \<triangleright> x'"
    then obtain x' where "x' \<subseteq> Tier (succ \<beta>) - Ignored" "x = set \<triangleright> x'" by auto
    thus "x \<in> Part set (Tier (succ (succ \<beta>)))"
      using part_tiersuccI1[OF succ_ord[OF \<open>Ord \<beta>\<close>] set_tag]
            ops_set_succ succ_ord[OF \<open>Ord \<beta>\<close>] powI by auto
  qed
next
  case IH:(3 \<mu>)
  show ?case proof
    assume "x \<in> Part set (Tier (succ \<mu>))"
    thus "\<exists>x'. x' \<subseteq> Tier \<mu> - Ignored \<and> x = set \<triangleright> x'"
    proof (rule part_tiersuccE[OF limit_ord[OF IH(1)]])
      assume "x \<in> Part set (Tier \<mu>)"
      then obtain \<beta> x' where "\<beta> < \<mu>" "x \<in> Tier \<beta>" "x = set \<triangleright> x'" using set_limE[OF IH(1)] by auto
      hence "x \<in> Part set (Tier (succ \<beta>))" using tier_subset[OF lt_ord1[OF \<open>\<beta> < \<mu>\<close>]] subsetD partI by auto
      hence "x' \<subseteq> Tier \<beta> - Ignored" using IH(2)[OF \<open>\<beta> < \<mu>\<close>] \<open>x = set \<triangleright> x'\<close> by (auto elim: pair_inject)
      hence "x' \<subseteq> Tier \<mu> - Ignored" using diff_subset1[OF tier_limit_subset[OF IH(1) \<open>\<beta> < \<mu>\<close>]] by simp
      thus "\<exists>x'. x' \<subseteq> Tier \<mu> - Ignored \<and> x = set \<triangleright> x'" using \<open>x = set \<triangleright> x'\<close> by auto
    next
      fix x' assume "x' \<in> Ops set (succ \<mu>) (Tier \<mu> - Ignored)" "x = set \<triangleright> x'"
      hence "x' \<in> Pow (Tier \<mu> - Ignored)" unfolding ops_set_succ[OF limit_ord[OF IH(1)]] by simp
      thus "\<exists>x'. x' \<subseteq> Tier \<mu> - Ignored \<and> x = set \<triangleright> x'" using \<open>x = set \<triangleright> x'\<close> powD[OF diff_set[OF tierlimit_set[OF IH(1)]]] by auto
    qed
  next
    assume "\<exists>x'. x' \<subseteq> Tier \<mu> - Ignored \<and> x = set \<triangleright> x'"
    then obtain x' where "x' \<subseteq> Tier \<mu> - Ignored" "x = set \<triangleright> x'" by blast
    hence "x' \<in> Pow (Tier \<mu> - Ignored)" using powI by simp
    hence "x' \<in> Ops set (succ \<mu>) (Tier \<mu> - Ignored)" unfolding ops_set_succ[OF limit_ord[OF IH(1)]] by simp
    thus "x \<in> Part set (Tier (succ \<mu>))" using part_tiersucc_iff[OF limit_ord[OF IH(1)]] \<open>x = set \<triangleright> x'\<close> set_tag by auto
  qed
qed

lemma set_succ_iff' : assumes "Ord \<beta>"
  shows "set \<triangleright> x' \<in> Tier (succ \<beta>) \<longleftrightarrow> x' \<subseteq> (Tier \<beta> - Ignored)"
proof
  let ?x = "set \<triangleright> x'"
  assume "?x \<in> Tier (succ \<beta>)" hence "?x \<in> Part set (Tier (succ \<beta>))" using partI by auto
  thus "x' \<subseteq> (Tier \<beta> - Ignored)" using set_succ_iff[OF assms] by (auto elim: pair_inject)
next
  assume "x' \<subseteq> (Tier \<beta> - Ignored)" thus "set \<triangleright> x' \<in> Tier (succ \<beta>)"
    using set_succ_iff[OF assms] partD2[OF tiersucc_set[OF assms]] by (blast elim: pair_inject)
qed

lemma set_succI : assumes "Ord \<beta>"
  shows "\<lbrakk> x = set \<triangleright> x' ; x' \<subseteq> Tier \<beta> - Ignored\<rbrakk> \<Longrightarrow> x \<in> Part set (Tier (succ \<beta>))"
  using set_succ_iff[OF assms] by auto

lemma set_succI' : assumes "Ord \<beta>"
  shows "x' \<subseteq> Tier \<beta> - Ignored \<Longrightarrow> set \<triangleright> x' \<in> Tier (succ \<beta>)"
  using set_succ_iff'[OF assms] by simp

lemma set_succE : assumes "Ord \<beta>"
  shows "\<lbrakk> x \<in> Part set (Tier (succ \<beta>)) ;
    \<And>x'. \<lbrakk> x = set \<triangleright> x'; x' \<subseteq> Tier \<beta> - Ignored \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using set_succ_iff[OF assms] by auto

lemma set_succE2 : assumes "Ord \<beta>"
  shows "\<lbrakk> x \<in> Part set (Tier (succ \<beta>)) ;
    \<And>x'. \<lbrakk> x = set \<triangleright> x'; x' \<subseteq> Tier \<beta> \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using set_succ_iff[OF assms] diff_subset2[OF tier_set[OF assms]] by auto

lemma set_succD_ig : assumes "Ord \<beta>"
  shows "set \<triangleright> x' \<in> Tier (succ \<beta>) \<Longrightarrow> x' \<subseteq> Tier \<beta> - Ignored"
  using set_succ_iff'[OF assms] by simp

lemma set_succD : assumes "Ord \<beta>"
  shows "set \<triangleright> x' \<in> Tier (succ \<beta>) \<Longrightarrow> x' \<subseteq> Tier \<beta>"
  using set_succ_iff'[OF assms] diff_subset2[OF tier_set[OF assms]] by simp

subsection \<open>Structure of the 'ord' part of Tier\<close>

thm ops_ord_ax
lemma ops_ord : "Ord \<beta> \<Longrightarrow> Ops ord \<beta> x = sng \<beta>" using ops_ord_ax by simp

lemma ord_0 : "Part ord (Tier 0) = sng (ord \<triangleright> 0)"
  by (rule equality_iffI[OF part_set[OF tier0_set] sng_set],
      use part_tier0_iff ord_tag ops_ord[OF zero_ord] sng_iff in auto)
lemma ord_succ_iff : assumes "Ord \<beta>"
  shows "b \<in> Part ord (Tier (succ \<beta>)) \<longleftrightarrow> b \<in> Part ord (Tier \<beta>) \<or> b = ord \<triangleright> (succ \<beta>)"
  using part_tiersucc_iff[OF assms, where ?\<alpha> = ord] sng_iff ord_tag unfolding ops_ord[OF succ_ord[OF \<open>Ord \<beta>\<close>]] by auto
lemma ord_lim_iff : assumes "Limit \<mu>"
  shows "b \<in> Part ord (Tier \<mu>) \<longleftrightarrow> (rex (\<lambda>\<beta>. \<beta> < \<mu>) (\<lambda>\<beta>. b \<in> Part ord (Tier \<beta>)) \<or> b = ord \<triangleright> \<mu>)"
  using part_tierlim_iff[OF assms, where ?\<alpha> = ord] ord_tag no_ord_ignored unfolding ops_ord[OF limit_ord[OF assms]] sorry

definition inModel :: "'d \<Rightarrow> bool" (\<open>M\<close>) where
  "inModel x \<equiv> rex Ord (\<lambda>\<beta>. x \<in> Tier \<beta>)"

lemma mI [intro] : "\<lbrakk> Ord \<beta> ; x \<in> Tier \<beta> \<rbrakk> \<Longrightarrow> M x"
  unfolding inModel_def by (rule rexI)

lemma mI' : "\<lbrakk> Ord \<beta>; x' \<subseteq> Tier \<beta> - Ignored \<rbrakk> \<Longrightarrow> M (set \<triangleright> x')"
  using set_succI' mI[OF succ_ord] by auto

lemma mE [elim]: "\<lbrakk> M x ; \<And>\<beta>. \<lbrakk> Ord \<beta> ; x \<in> Tier \<beta> \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  unfolding inModel_def by auto

lemma minduct3: assumes "M x" "x \<in> Tier 0 \<Longrightarrow> P"
    "(\<And>\<beta>. Ord \<beta> \<Longrightarrow> (x \<in> Tier \<beta> \<Longrightarrow> P) \<Longrightarrow> x \<in> Tier (succ \<beta>) \<Longrightarrow> P)"
    "(\<And>\<mu>. Limit \<mu> \<Longrightarrow> (\<And>\<beta>. \<beta> < \<mu> \<Longrightarrow> x \<in> Tier \<beta> \<Longrightarrow> P) \<Longrightarrow> x \<in> Tier \<mu> \<Longrightarrow> P)"
    shows "P"
proof -
  from assms(1) obtain \<beta> where "Ord \<beta>" "x \<in> Tier \<beta>" by auto
  thus ?thesis by (induct rule: trans_induct3, use assms(2,3,4) in auto)
qed

lemma m_tag : assumes "M x" shows "TagOf x = \<alpha> \<longleftrightarrow> (\<exists>x'. x = \<alpha> \<triangleright> x')"
proof (rule mE[OF assms])
  fix \<beta> assume"Ord \<beta>" "x \<in> Tier \<beta>"
  show "TagOf x = \<alpha> \<longleftrightarrow> (\<exists>x'. x = \<alpha> \<triangleright> x')"
  proof
    assume "TagOf x = \<alpha>" then obtain \<alpha>' x' where "x = \<alpha>' \<triangleright> x'"
      using tier_tagged[OF \<open>Ord \<beta>\<close> \<open>x \<in> Tier \<beta>\<close>] by auto
    thus "\<exists>x'. x = \<alpha> \<triangleright> x'" using \<open>TagOf x = \<alpha>\<close> fst_eq by auto
  next
    assume "\<exists>x'. x = \<alpha> \<triangleright> x'" thus "TagOf x = \<alpha>" using fst_eq by auto
  qed
qed

lemma m_part : assumes "M x" shows "TagOf x = \<alpha> \<longleftrightarrow> (rex Ord (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>)))"
proof
  assume "TagOf x = \<alpha>"
  then obtain \<beta> x' where "Ord \<beta>" "x \<in> Tier \<beta>" "x = \<alpha> \<triangleright> x'" using assms m_tag mE by blast
  thus "rex Ord (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))" using partI by blast
next
  assume "rex Ord (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))"
  then obtain \<beta> where "Ord \<beta>" "x \<in> Part \<alpha> (Tier \<beta>)" by auto
  thus "TagOf x = \<alpha>" using partD1[OF tier_set] by auto
qed

lemma m_part_succ : assumes "M x" shows "TagOf x = \<alpha> \<longleftrightarrow> (rex Ord (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier (succ \<beta>))))"
  unfolding m_part[OF assms]
proof (auto)
  assume "rex Ord (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier \<beta>))"
  then obtain \<beta> where "Ord \<beta>" "x \<in> Part \<alpha> (Tier \<beta>)" by auto
  hence "x \<in> Part \<alpha> (Tier (succ \<beta>))" using part_succ_subset by auto
  thus "rex Ord (\<lambda>\<beta>. x \<in> Part \<alpha> (Tier (succ \<beta>)))" using succ_ord[OF \<open>Ord \<beta>\<close>] by auto
qed

definition mall :: "('d \<Rightarrow> bool) \<Rightarrow> bool" (binder \<open>m\<forall>\<close> 10) where
  "mall P \<equiv> rall M P"

lemma mallI [intro]: "(\<And>x. M x \<Longrightarrow> P x) \<Longrightarrow> m\<forall>x. P x"
  unfolding mall_def by auto

lemma mspec : "\<lbrakk> m\<forall>x. P x ; M x \<rbrakk> \<Longrightarrow> P x"
  unfolding mall_def by auto

lemma mallE [elim] : "\<lbrakk> m\<forall>x. P x ; P x \<Longrightarrow> Q ; \<not> M x \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  unfolding mall_def by auto

definition mex (binder \<open>m\<exists>\<close> 10)
  where "mex P \<equiv> rex inModel P"

lemma mexI [intro]: "P x \<Longrightarrow> M x \<Longrightarrow> m\<exists>x. P x"
  unfolding mex_def by auto

lemma mexE [elim]: "\<lbrakk> m\<exists>x. P x ; \<And>x. \<lbrakk> M x ; P x \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  unfolding mex_def by auto

definition muniq (binder \<open>m\<exists>\<^sub>\<le>\<^sub>1\<close> 10)
  where "muniq P \<equiv> mall (\<lambda>y. mall (\<lambda>z. P y \<and> P z \<longrightarrow> y = z))"

definition mrall (binder \<open>mr\<forall>\<close> 10)
  where "mrall P Q \<equiv> mall (\<lambda>x. P x \<longrightarrow> Q x)"

definition mrex (binder \<open>mr\<exists>\<close> 10)
  where "mrex P Q \<equiv> mex (\<lambda>x. P x \<and> Q x)"

definition fun_mall
  where "fun_mall P \<equiv> (\<forall>F. (\<forall>x. M x \<longrightarrow> M (F x)) \<longrightarrow> P F)"

definition binfun_mall
  where "binfun_mall P \<equiv> (\<forall>F. (\<forall>x y. M x \<and> M y \<longrightarrow> M (F x y)) \<longrightarrow> P F)"

(*Model versions of GZF constants
  Higher-order parameters of model operators MUST be restricted to the model,
  otherwise it is painful to prove transfer rules.*)

definition "mSet x \<equiv> TagOf x = set"
lemma tag_mset [simp]: "mSet (set \<triangleright> x')" unfolding mSet_def fst_eq by simp

lemma mset_eq : assumes "M x" shows "mSet x \<longleftrightarrow> (\<exists>x'. x = set \<triangleright> x')"
  unfolding mSet_def by (rule m_tag[OF assms])

lemma mset_part_tier : assumes "M x"
  shows "mSet x \<longleftrightarrow> (rex Ord (\<lambda>\<beta>. x \<in> Part set (Tier \<beta>)))"
  unfolding mSet_def using m_part[OF assms] by auto

lemma mset_part_tier_succ : assumes "M x"
  shows "mSet x \<longleftrightarrow> (rex Ord (\<lambda>\<beta>. x \<in> Part set (Tier (succ \<beta>))))"
  unfolding mSet_def using m_part_succ[OF assms] by auto

lemma msetI : assumes "M x" "Ord \<beta>" shows "x \<in> Part set (Tier \<beta>) \<Longrightarrow> mSet x"
   unfolding mset_part_tier[OF assms(1)] by (insert assms(2), auto)

lemma msetI' : "x = set \<triangleright> x' \<Longrightarrow> mSet x" unfolding mSet_def by simp

lemma mset_partE1 : assumes "M x"
  shows "\<lbrakk> mSet x ; \<And>\<beta>. \<lbrakk> Ord \<beta>; x \<in> Part set (Tier \<beta>)\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using mset_part_tier[OF assms] by auto

lemma msetE1 : assumes "M x"
  shows "\<lbrakk> mSet x ; \<And>\<beta>. \<lbrakk> Ord \<beta>; x \<in> Tier \<beta> \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using mset_part_tier[OF assms] partD2[OF tier_set] by auto

lemma mset_part_succE1 : assumes "M x"
  shows "\<lbrakk> mSet x ; \<And>\<beta>. \<lbrakk> Ord \<beta>; x \<in> Part set (Tier (succ \<beta>))\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using mset_part_tier_succ[OF assms] by auto

lemma mset_succE1 : assumes "M x"
  shows "\<lbrakk> mSet x ; \<And>\<beta>. \<lbrakk> Ord \<beta>; x \<in> Tier (succ \<beta>)\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using mset_part_tier_succ[OF assms] partD2[OF tier_set] by auto

lemma msetE2_ig : assumes "M x" "x = set \<triangleright> x'"
  "\<And>\<beta>. \<lbrakk> Ord \<beta>; x \<in> Tier (succ \<beta>); x' \<subseteq> Tier \<beta> - Ignored \<rbrakk> \<Longrightarrow> P"
shows "P"
proof -
  from assms(1,2) have "mSet x" by simp
  then obtain \<beta> where "Ord \<beta>" "x \<in> Tier (succ \<beta>)" using mset_succE1[OF assms(1)] by auto
  moreover hence "x' \<subseteq> Tier \<beta> - Ignored" using set_succD_ig assms(2) by auto
  ultimately show "P" using assms(3) by simp
qed

lemma msetE2 : assumes "M x" "x = set \<triangleright> x'"
  "\<And>\<beta>. \<lbrakk> Ord \<beta>; x \<in> Tier (succ \<beta>); x' \<subseteq> Tier \<beta> \<rbrakk> \<Longrightarrow> P"
shows "P"
proof -
  from assms(1,2) have "mSet x" by simp
  then obtain \<beta> where "Ord \<beta>" "x \<in> Tier (succ \<beta>)" using mset_succE1[OF assms(1)] by auto
  moreover hence "x' \<subseteq> Tier \<beta>" using assms(2) set_succD by auto
  ultimately show "P" using assms(3) by simp
qed

lemma msetE3_ig: assumes "M x" shows "\<lbrakk> mSet x;
    \<And>\<beta> x'. \<lbrakk> Ord \<beta>; x \<in> Tier (succ \<beta>) ; x = set \<triangleright> x' ; x' \<subseteq> Tier \<beta> - Ignored \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
proof -
  assume "mSet x" and H:"(\<And>\<beta> x'. Ord \<beta> \<Longrightarrow> x \<in> Tier (succ \<beta>) \<Longrightarrow> x = set \<triangleright> x' \<Longrightarrow> x' \<subseteq> Tier \<beta> - Ignored \<Longrightarrow> P)"
  from \<open>mSet x\<close> obtain \<beta> where "Ord \<beta>" "x \<in> Part set (Tier (succ \<beta>))" using mset_part_tier_succ[OF assms] by auto
  then obtain x' where "x \<in> Tier (succ \<beta>)" "x = set \<triangleright> x'" "x' \<subseteq> Tier \<beta> - Ignored"
    using set_succ_iff partD2[OF tiersucc_set] by blast
  thus "P" using H[OF \<open>Ord \<beta>\<close>] by auto
qed

lemma msetE3: assumes "M x" shows "\<lbrakk> mSet x;
    \<And>\<beta> x'. \<lbrakk> Ord \<beta>; x \<in> Tier (succ \<beta>) ; x = set \<triangleright> x' ; x' \<subseteq> Tier \<beta> \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using  diff_subset2[OF tier_set] by (auto elim: msetE3_ig[OF assms])

lemma msetE4 : assumes "M x" shows "\<lbrakk> mSet x;
    \<And>x'. \<lbrakk> x = set \<triangleright> x'\<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  using msetE3[OF assms] by auto

lemma mset_obj_set' : assumes "M x" shows "x = set \<triangleright> x' \<Longrightarrow> Set x'"
  using subset_set1 by (auto elim: msetE2[OF assms] pair_inject)

lemma mset_obj_set : assumes "M x" shows "mSet x \<Longrightarrow> Set (ObjOf x)"
  by (rule msetE4[OF assms], use mset_obj_set'[OF assms] in auto)

definition "mMem x y \<equiv> mSet y \<and> (x \<in> (ObjOf y))"

lemma mMem_iff : assumes "mSet x" shows "mMem a x \<longleftrightarrow> a \<in> ObjOf x"
  unfolding mMem_def using assms by auto

lemma mMemI : assumes "mSet x" shows "a \<in> ObjOf x \<Longrightarrow> mMem a x"
  using mMem_iff[OF assms] by auto

lemma mMemI' : assumes "x = set \<triangleright> x'" shows "a \<in> x' \<Longrightarrow> mMem a x"
  unfolding mMem_def using snd_eq assms by auto

lemma mMemI'' : shows "a \<in> x' \<Longrightarrow> mMem a (set \<triangleright> x')"
  using mMemI' by auto

lemma mMem_mset : "mMem a x \<Longrightarrow> mSet x"
  unfolding mMem_def by simp

lemma mMemD : "mMem a x \<Longrightarrow> a \<in> ObjOf x"
  unfolding mMem_def by auto

lemma mMemD' : assumes "x = set \<triangleright> x'" shows "mMem a x \<Longrightarrow> a \<in> x'"
  unfolding mMem_def using snd_eq assms by auto

lemma mMemE : assumes "M x" "mMem a x" "\<And>x'. \<lbrakk> x = set \<triangleright> x'; a \<in> x' \<rbrakk> \<Longrightarrow> P" shows "P"
  unfolding mMem_def
proof -
  from \<open>mMem a x\<close> have "mSet x" "a \<in> ObjOf x" unfolding mMem_def by simp_all
  then obtain x' where "x = set \<triangleright> x'" using msetE4[OF \<open>M x\<close>] by auto
  moreover hence "a \<in> x'" using \<open>a \<in> ObjOf x\<close> snd_eq by auto
  ultimately show "P" using assms(3) by auto
qed

lemma mMem_m : assumes "M x" shows "mMem a x \<Longrightarrow> M a"
proof -
  assume "mMem a x" hence "mSet x" using mMem_mset by simp
  then obtain \<beta> x' where "Ord \<beta>" "x = set \<triangleright> x'" "x' \<subseteq> Tier \<beta>" by (blast elim: msetE3[OF assms])
  hence "a \<in> Tier \<beta>" using mMemD'[OF _ \<open>mMem a x\<close>] by auto
  hence "\<exists>\<beta>. Ord \<beta> \<and> a \<in> Tier \<beta>" using \<open>Ord \<beta>\<close> by auto
  thus "M a" by auto
qed

lemma mem_m : assumes "M x" "x = set \<triangleright> x'" shows "a \<in> x' \<Longrightarrow> M a"
  by (rule mMem_m[OF assms(1) mMemI'[OF assms(2)]])

lemma mMem_tier : assumes "Ord \<beta>" shows "\<lbrakk> x \<in> Tier (succ \<beta>); mMem a x \<rbrakk> \<Longrightarrow> a \<in> Tier \<beta>"
proof -
  assume "x \<in> Tier (succ \<beta>)" hence "M x" using assms by auto
  assume "mMem a x" then obtain x' where "x = set \<triangleright> x'" "a \<in> x'" using mMemE[OF \<open>M x\<close>] by auto
  thus "a \<in> Tier \<beta>" unfolding mMem_def mSet_def
    using set_succD[OF assms] \<open>x \<in> Tier (succ \<beta>)\<close> by auto
qed

definition forceM where "forceM x \<equiv> if M x then x else set \<triangleright> \<emptyset>"
definition "mEmp \<equiv> set \<triangleright> \<emptyset>"

lemma memp_mset : "mSet (mEmp)" unfolding mSet_def mEmp_def fst_eq by simp
lemma memp_m : "M (mEmp)" unfolding mEmp_def
  using mI'[OF zero_ord] empty_subsetI[OF diff_set[OF tier_set[OF zero_ord]]] by auto

lemma forceM_m [simp] : "M (forceM x)"
  using forceM_def memp_m unfolding mEmp_def by auto

lemma forceM_eq : "M x \<Longrightarrow> forceM x = x"
  unfolding forceM_def by auto

text \<open>(EMP) : Axiom of Empty Set\<close>
theorem "m\<forall>a. \<not> (mMem a mEmp)"
proof (rule, rule ccontr, simp)
  fix a assume "mMem a mEmp"
  hence "a \<in> \<emptyset>" unfolding mEmp_def using mMemD snd_eq by blast
  thus "False" using not_mem_empty by simp
qed

text \<open>(SET): Set Ownership Axiom\<close>
theorem "m\<forall>x. mSet x \<longleftrightarrow> (x = mEmp \<or> (m\<exists>y. mMem y x))"
proof (rule, rule)
  fix x assume "M x" "mSet x"
  then obtain \<beta> x' where "Ord \<beta>" "x \<in> Tier (succ \<beta>)" "x = set \<triangleright> x'" "x' \<subseteq> Tier \<beta>" by (rule msetE3)
  hence "x' = \<emptyset> \<or> (\<exists>y. y \<in> x')" using setE[OF subset_set1] by blast
  thus "x = mEmp \<or> (m\<exists>y. mMem y x)"
  proof (rule)
    assume "x' = \<emptyset>" hence "x = mEmp" unfolding mEmp_def \<open>x = set \<triangleright> x'\<close> by auto
    thus "x = mEmp \<or> (m\<exists>y. mMem y x)" by rule
  next
    assume "\<exists>y. y \<in> x'" then obtain y where "y \<in> x'" by auto
    hence "M y" "mMem y x" using mMemI'[OF \<open>x = set \<triangleright> x'\<close>] mI[OF \<open>Ord \<beta>\<close>] subsetD[OF \<open>x' \<subseteq> Tier \<beta>\<close>] by auto
    hence "m\<exists>y. mMem y x" by auto
    thus "x = mEmp \<or> (m\<exists>y. mMem y x)" by rule
  qed
next
  fix x assume "M x" "x = mEmp \<or> (m\<exists>y. mMem y x)"
  thus "mSet x" unfolding mEmp_def mMem_def by auto
qed

text \<open>(EXT): Axiom of Extensionality\<close>
theorem "m\<forall>x y. mSet x \<longrightarrow> mSet y \<longrightarrow> (m\<forall>a. mMem a x \<longleftrightarrow> mMem a y) \<longrightarrow> x = y"
proof (rule, rule, rule, rule, rule)
  fix x y assume "M x" "M y" "mSet x" "mSet y" and iff:"m\<forall>a. mMem a x \<longleftrightarrow> mMem a y"
  then obtain x' y' where [simp] : "x = set \<triangleright> x'" "y = set \<triangleright> y'" by (blast elim: msetE4)
  hence "Set x'" "Set y'" using mset_obj_set' \<open>M x\<close> \<open>M y\<close> by auto
  hence "x' = y'" proof (rule equality_iffI)
    fix a show "a \<in> x' \<longleftrightarrow> a \<in> y'" proof
      assume "a \<in> x'" hence "M a" "mMem a x"
        using mem_m[OF \<open>M x\<close>] mMemI' by simp_all
      hence "mMem a y" using iff by auto
      thus "a \<in> y'" using mMemD' by auto
    next
      assume "a \<in> y'" hence "M a" "mMem a y"
        using mem_m[OF \<open>M y\<close>] mMemI' by simp_all
      hence "mMem a x" using iff by auto
      thus "a \<in> x'" using mMemD' by auto
    qed
  qed
  thus "x = y" using kpair_iff by simp
qed

definition "mUnion x \<equiv> set \<triangleright> (\<Union> (RepFun ObjOf (Part set (ObjOf x))))"

text \<open>(UNI): Axiom of Union\<close>
theorem munion_iff : "m\<forall>x. mSet x \<longrightarrow> mSet (mUnion x)
          \<and> (m\<forall>a. mMem a (mUnion x) \<longleftrightarrow> (m\<exists>z. mMem z x \<and> mMem a z))"
proof (rule, rule, rule)
  fix x assume "M x" "mSet x"
  then obtain \<beta> x' where "Ord \<beta>" "x \<in> Tier (succ \<beta>)" "x' \<subseteq> Tier \<beta>" "x = set \<triangleright> x'" by (auto elim: msetE3)
  show "mSet (mUnion x)" unfolding mUnion_def by simp
  show "m\<forall>a. mMem a (mUnion x) \<longleftrightarrow> (m\<exists>z. mMem z x \<and> mMem a z)"
  proof (rule)
    fix a assume "M a" show "mMem a (mUnion x) = (m\<exists>z. mMem z x \<and> mMem a z)"
    proof
      assume "mMem a (mUnion x)"
      hence "a \<in> \<Union> RepFun ObjOf (Part set x')" unfolding mUnion_def using mMemD' \<open>x = set \<triangleright> x'\<close> by auto
      then obtain z where "a \<in> ObjOf z" "z \<in> Part set x'"
        using repfun_union[OF part_set[OF mset_obj_set'[OF \<open>M x\<close> \<open>x = set \<triangleright> x'\<close>]]] by auto
      hence "mSet z" "z \<in> x'" using mset_obj_set'[OF \<open>M x\<close> \<open>x = set \<triangleright> x'\<close>] partD1 partD2 unfolding mSet_def by auto
      hence "M z" "mMem a z" "mMem z x"
         using mem_m[OF \<open>M x\<close> \<open>x = set \<triangleright> x'\<close>] mMemI[OF _ \<open>a \<in> ObjOf z\<close>] mMemI'[OF \<open>x = set \<triangleright> x'\<close>] by auto
      thus "m\<exists>z. mMem z x \<and> mMem a z" by auto
    next
      assume "m\<exists>z. mMem z x \<and> mMem a z"
      then obtain z where "M z" "mMem z x" "mMem a z" by auto
      hence "z \<in> x'" "TagOf z = set" "a \<in> ObjOf z" using mMemD mMemD'[OF \<open>x = set \<triangleright> x'\<close>] mMem_mset mSet_def by auto
      hence "z \<in> Part set (ObjOf x)" using partI m_tag[OF \<open>M z\<close>] \<open>x = set \<triangleright> x'\<close> by auto
      hence "a \<in> \<Union> RepFun ObjOf (Part set (ObjOf x))" unfolding
        repfun_union[OF part_set[OF mset_obj_set[OF \<open>M x\<close> \<open>mSet x\<close>]]] using \<open>a \<in> ObjOf z\<close> by auto
      thus "mMem a (mUnion x)" unfolding mUnion_def using mMemI by auto
    qed
  qed
qed

definition mSubset where msub_def : "mSubset x y \<equiv> mSet x \<and> mSet y \<and> (\<forall>a. mMem a x \<longrightarrow> mMem a y)"
thm strip
lemmas stripm = impI allI rallI mallI

text \<open>(SUB): Definition of Subset\<close>
theorem msub_iff : "m\<forall>x y. mSubset x y \<longleftrightarrow> mSet x \<and> mSet y \<and> (m\<forall>a. mMem a x \<longrightarrow> mMem a y)"
  unfolding msub_def mall_def rall_def using mMem_m by auto

lemma msubI : assumes "mSet x" "mSet y"
  shows "(\<And>a. mMem a x \<Longrightarrow> mMem a y) \<Longrightarrow> mSubset x y"
  using assms msub_def by auto

lemma msubI' : assumes "x = set \<triangleright> x'" "y = set \<triangleright> y'"
  shows "x' \<subseteq> y' \<Longrightarrow> mSubset x y"
  using assms msub_def mMemI'[OF assms(2)] mMemD'[OF assms(1)] subsetD by auto

lemma msub_mset1 : "mSubset x y \<Longrightarrow> mSet x" unfolding msub_def by auto
lemma msub_mset2 : "mSubset x y \<Longrightarrow> mSet y" unfolding msub_def by auto

lemma msubE : assumes "M x" "M y"
  "mSubset x y" "\<And>x' y'. \<lbrakk> x = set \<triangleright> x'; y = set \<triangleright> y'; x' \<subseteq> y' \<rbrakk> \<Longrightarrow> P" shows "P"
proof -
  from assms(1,2,3) obtain x' y' where x':"x = set \<triangleright> x'" and y':"y = set \<triangleright> y'"
    unfolding msub_def by (blast elim: msetE4)
  moreover have "x' \<subseteq> y'" using assms(3) mMemD'[OF y'] mMemI'[OF x']
   unfolding msub_def by (auto intro: subsetI[OF mset_obj_set'[OF \<open>M x\<close> x'] mset_obj_set'[OF \<open>M y\<close> y']])
  ultimately show "P" using assms(4) by simp
qed

definition "mPow x \<equiv> set \<triangleright> (TagSetMems set (Pow (ObjOf x)))"

lemma mpow_mset : "mSet (mPow x)" unfolding mSet_def mPow_def by simp

text \<open>(POW): Axiom of Power Set\<close>
theorem "m\<forall>x. mSet x \<longrightarrow> (m\<forall>z. mMem z (mPow x) = mSubset z x)"
proof (rule, rule, rule)
  fix x z assume "M x" "M z" "mSet x"
  then obtain x' where x':"x = set \<triangleright> x'" using msetE4 by auto
  hence "Set x'" and mpow: "mPow x = set \<triangleright> TagSetMems set (Pow x')"
    using mset_obj_set'[OF \<open>M x\<close>] unfolding mPow_def by simp_all

  show "mMem z (mPow x) = mSubset z x" proof
    assume "mMem z (mPow x)"
    hence "z \<in> TagSetMems set (Pow x')" by (rule mMemD'[OF mpow])
    then obtain z' where "z' \<subseteq> x'" "z = set \<triangleright> z'" using powD[OF \<open>Set x'\<close>]
      by (blast elim: tmapE[OF pow_set[OF \<open>Set x'\<close>]])
    thus "mSubset z x" using msubI'[OF _ x'] by auto
  next
    assume "mSubset z x"
    then obtain z' x'' where z':"z = set \<triangleright> z'" "x = set \<triangleright> x''" and "z' \<subseteq> x''"
      using msubE[OF \<open>M z\<close> \<open>M x\<close>] x' by blast
    also hence "z' \<subseteq> x'" using x' by (auto elim: pair_inject)
    hence "z' \<in> Pow x'" using powI by simp
    hence "z \<in> TagSetMems set (Pow x')" using tmapI z' by auto
    thus "mMem z (mPow x)" unfolding mPow_def using mMemI'' x' by auto
  qed
qed

definition "mSucc x \<equiv> mUnion (set \<triangleright> (upair x (set \<triangleright> (sng x))))"

lemma sng_succ : assumes "Ord \<beta>" "x = set \<triangleright> x'"
  shows "x \<in> Tier \<beta> \<Longrightarrow> set \<triangleright> sng x \<in> Tier (succ \<beta>)"
  by  (rule set_succI'[OF assms(1)], rule subsetI[OF sng_set diff_set[OF tier_set[OF \<open>Ord \<beta>\<close>]]],
       unfold sng_iff, rule diffI, use no_set_ignored assms(2) in auto)

lemma upair_succ : assumes "Ord \<beta>" "x = set \<triangleright> x'" "y = set \<triangleright> y'"
  shows "x \<in> Tier \<beta> \<Longrightarrow> y \<in> Tier \<beta> \<Longrightarrow> set \<triangleright> upair x y \<in> Tier (succ \<beta>)"
  by (rule set_succI'[OF assms(1)], rule subsetI[OF upair_set diff_set[OF tier_set[OF \<open>Ord \<beta>\<close>]]],
      unfold upair_iff, rule diffI, use no_set_ignored assms(2,3) in auto)

text \<open>(SUC): Characterisation of Successor Operation\<close>
theorem msucc_iff : "m\<forall>x. mSet x \<longrightarrow> (m\<forall>a. mMem a (mSucc x) = (mMem a x \<or> a = x))"
proof (rule, rule, rule)
  fix x a assume "M x" "M a" "mSet x"
  then obtain \<beta> x' where "Ord \<beta>" and x:"x \<in> Tier \<beta>" and x': \<open>x = set \<triangleright> x'\<close> by (blast elim: msetE3)
  let ?sng = "set \<triangleright> sng x"
  let ?up = "set \<triangleright> upair x ?sng"
  have "?sng \<in> Tier (succ \<beta>)" and "x \<in> Tier (succ \<beta>)" by (rule sng_succ[OF \<open>Ord \<beta>\<close> x' x], rule tier_succI1[OF \<open>Ord \<beta>\<close> x])
  hence upM:"?up \<in> Tier (succ (succ \<beta>))" using upair_succ[OF succ_ord[OF \<open>Ord \<beta>\<close>] x'] by auto
  hence "M ?up" "mSet ?up" using mI[OF succ_ord[OF succ_ord[OF \<open>Ord \<beta>\<close>]]] by auto
  hence uni:"(m\<forall>a. mMem a (mUnion ?up) = (m\<exists>z. mMem z ?up \<and> mMem a z))" using munion_iff by blast
  show "mMem a (mSucc x) \<longleftrightarrow> mMem a x \<or> a = x"
  proof
    assume "mMem a (mSucc x)"
    hence "(m\<exists>z. mMem z ?up \<and> mMem a z)" unfolding mSucc_def using uni \<open>M a\<close> by auto
    then obtain z where "M z" "mMem z ?up" "mMem a z" by blast
    hence "z \<in> upair x ?sng" using mMemD' by auto
    thus "mMem a x \<or> a = x" using \<open>mMem a z\<close> mMemD'[OF _ \<open>mMem a z\<close>] sng_iff by (auto elim: upairE)
  next
    assume "mMem a x \<or> a = x"
    hence "mMem a x \<or> mMem a ?sng" using mMemI' sngI by auto
    then obtain z where "mMem z ?up" "mMem a z" using upairI1 upairI2 mMemI' by blast
    moreover hence "M z" using mI[OF succ_ord[OF \<open>Ord \<beta>\<close>] mMem_tier[OF succ_ord[OF \<open>Ord \<beta>\<close>] upM]] by auto
    ultimately have "m\<exists>z. mMem z ?up \<and> mMem a z" by auto
    thus "mMem a (mSucc x)" unfolding mSucc_def using uni \<open>M a\<close> by auto
  qed
qed

abbreviation "\<Theta> n \<equiv> OrdRec (\<lambda>\<mu> f. f[predSet \<omega>]) (\<lambda>_ x. mSucc x) mEmp n"

definition "mInf \<equiv> set \<triangleright> (\<Theta> \<omega>)"

text \<open>(INF): Axiom of Infinity\<close>
theorem minf: "mMem mEmp mInf \<and> (m\<forall>x. mMem x mInf \<longrightarrow> mMem (mSucc x) mInf)"
proof
  have theta:"\<Theta> \<omega> = RepFun \<Theta> (predSet \<omega>)" using ordrec_lim \<omega>_lim image_domain by auto
  show "mMem mEmp mInf" unfolding mInf_def theta
  proof (rule mMemI', simp)
    have "\<Theta> 0 = mEmp" using ordrec_0 by simp
    moreover have "\<Theta> 0 \<in> RepFun \<Theta> (predSet \<omega>)" using repfunI[OF predsetI[OF \<omega>_0]] by auto
    ultimately show "mEmp \<in> RepFun \<Theta> (predSet \<omega>)" by simp
  qed
  thm mMemD'
  show "m\<forall>x. mMem x mInf \<longrightarrow> mMem (mSucc x) mInf" unfolding mInf_def theta
  proof (rule, rule, rule mMemI', simp)
    fix x assume "M x" "mMem x (set \<triangleright> RepFun \<Theta> (predSet \<omega>))"
    hence "x \<in> RepFun \<Theta> (predSet \<omega>)" using mMemD' by auto
    then obtain \<beta>  where "x = \<Theta> \<beta>" "\<beta> < \<omega>"
       using repfunE[OF predset_set[OF \<omega>_ord]] predsetE[OF \<omega>_ord] by blast
     hence "mSucc x = \<Theta> (succ \<beta>)" using ordrec_succ by auto
     thus "mSucc x \<in> RepFun \<Theta> (predSet \<omega>)" using repfunI[OF predsetI[OF \<omega>_succ[OF \<open>\<beta> < \<omega>\<close>]]] by auto
  qed
qed

definition "mRepl P x \<equiv> set \<triangleright> (Replace (\<lambda>a b. M a \<and> M b \<and> P a b) (ObjOf x))"

text \<open>(REPL): Axiom of Replacement\<close>
lemma mrepl: "\<forall>P. m\<forall>x. mSet x \<longrightarrow> mSet (mRepl P x) \<and> ((m\<forall>a. mMem a x \<longrightarrow> (m\<exists>\<^sub>\<le>\<^sub>1b. P a b))
    \<longrightarrow> (m\<forall>b. mMem b (mRepl P x) = (m\<exists>a. mMem a x \<and> P a b)))"
proof (rule, rule, rule, rule)
  fix P x assume "M x" "mSet x"
  then obtain x' where x':"x = set \<triangleright> x'" using msetE4 by auto
  hence "ObjOf x = x'" "Set x'" using mset_obj_set[OF \<open>M x\<close> \<open>mSet x\<close>] by auto

  show "mSet (mRepl P x)" unfolding mRepl_def by simp
  show "(m\<forall>a. mMem a x \<longrightarrow> (m\<exists>\<^sub>\<le>\<^sub>1b. P a b)) \<longrightarrow> (m\<forall>b. mMem b (mRepl P x) = (m\<exists>a. mMem a x \<and> P a b))"
  proof (rule)
    let ?P' = "(\<lambda>a b. M a \<and> M b \<and> P a b)"
    assume "m\<forall>a. mMem a x \<longrightarrow> (m\<exists>\<^sub>\<le>\<^sub>1 b. P a b)"
    hence uniq: "\<And>a b c. M a \<Longrightarrow> mMem a x \<Longrightarrow> M b \<Longrightarrow> M c \<Longrightarrow> P a b \<Longrightarrow> P a c \<Longrightarrow> b =c" unfolding muniq_def by auto
    show "m\<forall>b. mMem b (mRepl P x) = (m\<exists>a. mMem a x \<and> P a b)"
    proof (rule, rule)
      fix b assume "M b" "mMem b (mRepl P x)"
      hence "b \<in> Replace ?P' x'" unfolding mRepl_def using mMemD' \<open>ObjOf x = x'\<close> by (auto)
      thus "m\<exists>a. mMem a x \<and> P a b"
      proof (rule replaceE[OF \<open>Set x'\<close>])
        fix a assume "a \<in> x'" "?P' a b"
        hence "M a" "mMem a x" "P a b" using mMemI'[OF x'] by auto
        thus "m\<exists>a. mMem a x \<and> P a b" by auto
      qed
    next
      fix b assume "M b" "m\<exists>a. mMem a x \<and> P a b"
      then obtain a where "M a" "mMem a x" "P a b" by auto
      show "mMem b (mRepl P x)" proof (rule mMemI', simp add: mRepl_def, rule replaceI)
        show "M a \<and> M b \<and> P a b" using \<open>M a\<close> \<open>M b\<close> \<open>P a b\<close> forceM_def by auto
        show "a \<in> ObjOf x" by (rule mMemD[OF \<open>mMem a x\<close>])
        fix c assume "M a \<and> M c \<and> P a c" thus "c=b"
          using uniq[OF \<open>M a\<close> \<open>mMem a x\<close>] \<open>M b\<close> \<open>P a b\<close> by auto
      qed
    qed
  qed
qed

(*Model versions of Ord constants*)
definition "mOrd_conv \<beta> \<equiv> ord \<triangleright> \<beta>"
definition "mOrd \<B> \<equiv> TagOf \<B> = ord"

lemma mOrdI : "b = ord \<triangleright> b' \<Longrightarrow> mOrd b"
  unfolding mOrd_def by simp

definition "mzero \<equiv> ord \<triangleright> 0"
definition "momega \<equiv> ord \<triangleright> \<omega>"

theorem "mOrd mzero" unfolding mzero_def using mOrdI by auto
theorem "mOrd momega" unfolding momega_def using mOrdI by auto

definition "mlt \<A> \<B> \<equiv> mOrd \<A> \<and> mOrd \<B> \<and> (ObjOf \<A>) < (ObjOf \<B>)"

theorem "m\<forall>\<alpha> \<beta>. mlt \<alpha> \<beta> \<longrightarrow> mOrd \<alpha> \<and> mOrd \<beta>"
  using mlt_def by auto

definition "msucc \<B> \<equiv> ord \<triangleright> (succ (ObjOf \<B>))"
theorem "m\<forall>\<beta>. mOrd (msucc \<beta>) = mOrd \<beta>" sorry

definition "mpredSet \<B> \<equiv> set \<triangleright> (TagSetMems ord (predSet (ObjOf \<B>)))"
definition "mOrdRec L F A \<B> \<equiv> OrdRec (\<lambda>a b. L (forceM a) (forceM b)) (\<lambda>a b. F (forceM a) (forceM b)) A (ObjOf \<B>)"

definition "mLimit \<B> \<equiv> Limit (ObjOf \<B>)"

ML_file \<open>translate_locale.ML\<close>

model_interpretation trans_gzf : mGZF
  sorry

model_interpretation trans_ord : mOrd
  sorry

ML \<open>Goal.prove\<close>

ML_file \<open>model_closed.ML\<close>

model_closed closed_gzf : mGZF
  sorry

model_closed closed_ord : mOrd
  sorry

end
end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_NStoogeSortPermutes
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

(*fun did not finish the proof*)
function third :: "int => int" where
  "third y =
   (if (y = 2) then 0 else
      (if (y = 1) then 0 else
         (if (y = 0) then 0 else 1 + (third (y - 3)))))"
  by pat_completeness auto

fun take :: "int => 'a list => 'a list" where
  "take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun drop :: "int => 'a list => 'a list" where
  "drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "int list => int list"
  and nstoogesort :: "int list => int list"
  and nstooge1sort1 :: "int list => int list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

theorem property0 :
  "isPermutation (nstoogesort xs) xs"
  oops

end


section \<open>Open Singly Linked Lists\<close>
theory Open_List
imports List_Seg Imp_List_Spec
begin

subsection \<open>Definitions\<close>
type_synonym 'a os_list = "'a node ref option"

abbreviation os_list :: "'a list \<Rightarrow> ('a::heap) os_list \<Rightarrow> assn" where
  "os_list l p \<equiv> lseg l p None"

subsection \<open>Precision\<close>
lemma os_prec:
  "precise os_list"
  by rule (simp add: lseg_prec2)

lemma os_imp_list_impl: "imp_list os_list"
  apply unfold_locales
  apply (rule os_prec)
  done
interpretation os: imp_list os_list by (rule os_imp_list_impl)

subsection \<open>Operations\<close>
subsubsection \<open>Allocate Empty List\<close>

definition os_empty :: "'a::heap os_list Heap" where
  "os_empty \<equiv> return None"

lemma os_empty_rule: "<emp> os_empty <os_list []>"
  unfolding os_empty_def
  apply sep_auto
  done

lemma os_empty_impl: "imp_list_empty os_list os_empty"
  apply unfold_locales
  apply (sep_auto heap add: os_empty_rule)
  done
interpretation os: imp_list_empty os_list os_empty by (rule os_empty_impl)

subsubsection \<open>Emptiness check\<close>
text \<open>A linked list is empty, iff it is the null pointer.\<close>

definition os_is_empty :: "'a::heap os_list \<Rightarrow> bool Heap" where
  "os_is_empty b \<equiv> return (b = None)"

lemma os_is_empty_rule:
  "<os_list xs b> os_is_empty b <\<lambda>r. os_list xs b * \<up>(r \<longleftrightarrow> xs = [])>"
  unfolding os_is_empty_def
  apply sep_auto
  done

lemma os_is_empty_impl: "imp_list_is_empty os_list os_is_empty"
  apply unfold_locales
  apply (sep_auto heap add: os_is_empty_rule)
  done
interpretation os: imp_list_is_empty os_list os_is_empty
  by (rule os_is_empty_impl)

subsubsection \<open>Prepend\<close>

text \<open>To push an element to the front of a list we allocate a new node which
  stores the element and the old list as successor. The new list is the new
  allocated reference.\<close>

definition os_prepend :: "'a \<Rightarrow> 'a::heap os_list \<Rightarrow> 'a os_list Heap" where
  "os_prepend a n = do { p \<leftarrow> ref (Node a n); return (Some p) }"

lemma os_prepend_rule:
  "<os_list xs n> os_prepend x n <os_list (x # xs)>"
  unfolding os_prepend_def
  apply sep_auto
  done

lemma os_prepend_impl: "imp_list_prepend os_list os_prepend"
  apply unfold_locales
  apply (sep_auto heap add: os_prepend_rule)
  done
interpretation os: imp_list_prepend os_list os_prepend
  by (rule os_prepend_impl)

subsubsection\<open>Pop\<close>
text \<open>To pop the first element out of the list we look up the value and the
  reference of the node and return the pair of those.\<close>

fun os_pop :: "'a::heap os_list \<Rightarrow> ('a \<times> 'a os_list) Heap" where
  "os_pop None   = raise STR ''Empty Os_list''" |
  "os_pop (Some p) = do {m \<leftarrow> !p; return (val m, next m)}"

declare os_pop.simps[simp del]

lemma os_pop_rule:
  "xs \<noteq> [] \<Longrightarrow> <os_list xs r>
  os_pop r
  <\<lambda>(x,r'). os_list (tl xs) r' * (the r) \<mapsto>\<^sub>r (Node x r') * \<up>(x = hd xs)>"

  apply (cases r, simp_all)
  apply (cases xs, simp_all)

  apply (sep_auto simp: os_pop.simps)
  done

lemma os_pop_impl: "imp_list_pop os_list os_pop"
  apply unfold_locales
  apply (sep_auto heap add: os_pop_rule)
  done
interpretation os: imp_list_pop os_list os_pop by (rule os_pop_impl)

subsubsection \<open>Reverse\<close>

text \<open>The following reversal function is equivalent to the one from
  Imperative HOL. And gives a more difficult example.\<close>

partial_function (heap) os_reverse_aux
  :: "'a::heap os_list \<Rightarrow> 'a os_list \<Rightarrow> 'a os_list Heap"
  where [code]:
  "os_reverse_aux q p = (case p of
    None \<Rightarrow> return q |
    Some r \<Rightarrow> do {
      v \<leftarrow> !r;
      r := Node (val v) q;
      os_reverse_aux p (next v) })"

lemma [simp, sep_dflt_simps]:
  "os_reverse_aux q None = return q"
  "os_reverse_aux q (Some r) = do {
      v \<leftarrow> !r;
      r := Node (val v) q;
      os_reverse_aux (Some r) (next v) }"
  apply (subst os_reverse_aux.simps)
  apply simp
  apply (subst os_reverse_aux.simps)
  apply simp
  done

definition "os_reverse p = os_reverse_aux None p"

lemma os_reverse_aux_rule:
  "<os_list xs p * os_list ys q>
    os_reverse_aux q p
  <os_list ((rev xs) @ ys) >"
proof (induct xs arbitrary: p q ys)
  case Nil thus ?case
    apply sep_auto
    done
next
  case (Cons x xs)
  show ?case
    apply (cases p, simp_all)
    apply (sep_auto heap add: cons_pre_rule[OF _ Cons.hyps])
    done
qed

lemma os_reverse_rule: "<os_list xs p> os_reverse p <os_list (rev xs)>"
  unfolding os_reverse_def
  apply (auto simp: os_reverse_aux_rule[where ys="[]", simplified, rule_format])
  done

lemma os_reverse_impl: "imp_list_reverse os_list os_reverse"
  apply unfold_locales
  apply (sep_auto heap add: os_reverse_rule)
  done
interpretation os: imp_list_reverse os_list os_reverse
  by (rule os_reverse_impl)

subsubsection \<open>Remove\<close>

text \<open>Remove all appearances of an element from a linked list.\<close>

partial_function (heap) os_rem
  :: "'a::heap \<Rightarrow> 'a node ref option \<Rightarrow> 'a node ref option Heap"
  where [code]:
  "os_rem x b = (case b of
     None \<Rightarrow> return None |
     Some p \<Rightarrow> do {
       n \<leftarrow> !p;
       q \<leftarrow> os_rem x (next n);
       (if (val n = x)
         then return q
         else do {
           p := Node (val n) q;
           return (Some p) }) })"

lemma [simp, sep_dflt_simps]:
  "os_rem x None = return None"
  "os_rem x (Some p) = do {
       n \<leftarrow> !p;
       q \<leftarrow> os_rem x (next n);
       (if (val n = x)
         then return q
         else do {
           p := Node (val n) q;
           return (Some p) }) }"
  apply (subst os_rem.simps, simp)+
  done

lemma os_rem_rule[sep_heap_rules]:
  "<os_list xs b> os_rem x b <\<lambda>r. os_list (removeAll x xs) r * true>"
proof (induct xs arbitrary: b x) (* Have to generalize over x, as
    sep_auto preprocessor introduces a new variable. Alternative:
    No preprocessing. (See alternative proof below) *)
  case Nil show ?case
    apply sep_auto
    done
next
  case (Cons y xs)
  show ?case by (sep_auto heap add: Cons.hyps)
qed

lemma os_rem_rule_alt_proof:
  "<os_list xs b> os_rem x b <\<lambda>r. os_list (removeAll x xs) r * true>"
proof (induct xs arbitrary: b)
  case Nil show ?case
    apply sep_auto
    done
next
  case (Cons y xs)
  show ?case
    by (sep_auto (nopre) heap add: Cons.hyps) (* Switching off preprocessor *)
qed

subsubsection \<open>Iterator\<close>

type_synonym 'a os_list_it = "'a os_list"
definition "os_is_it l p l2 it
  \<equiv> \<exists>\<^sub>Al1. \<up>(l=l1@l2) * lseg l1 p it * os_list l2 it"

definition os_it_init :: "'a os_list \<Rightarrow> ('a os_list_it) Heap"
  where "os_it_init l = return l"

fun os_it_next where
  "os_it_next (Some p) = do {
    n \<leftarrow> !p;
    return (val n,next n)
  }"

definition os_it_has_next :: "'a os_list_it \<Rightarrow> bool Heap" where
  "os_it_has_next it \<equiv> return (it\<noteq>None)"

lemma os_iterate_impl:
  "imp_list_iterate os_list os_is_it os_it_init os_it_has_next os_it_next"
  apply unfold_locales
  unfolding os_it_init_def os_is_it_def[abs_def]
  apply sep_auto

  apply (case_tac it, simp)
  apply (case_tac l', simp)
  apply sep_auto
  apply (rule ent_frame_fwd[OF lseg_append])
    apply frame_inference
    apply simp

  unfolding os_it_has_next_def
  apply (sep_auto elim!: neq_NilE)

  apply solve_entails
  apply (rule ent_frame_fwd[OF lseg_conc])
    apply frame_inference
    apply solve_entails
  done
interpretation os:
  imp_list_iterate os_list os_is_it os_it_init os_it_has_next os_it_next
  by (rule os_iterate_impl)

subsubsection \<open>List-Sum\<close>

partial_function (heap) os_sum' :: "int os_list_it \<Rightarrow> int \<Rightarrow> int Heap"
  where [code]:
  "os_sum' it s = do {
    b \<leftarrow> os_it_has_next it;
    if b then do {
      (x,it') \<leftarrow> os_it_next it;
      os_sum' it' (s+x)
    } else return s
  }"

lemma os_sum'_rule[sep_heap_rules]:
  "<os_is_it l p l' it>
    os_sum' it s
  <\<lambda>r. os_list l p * \<up>(r = s + sum_list l')>\<^sub>t"
proof (induct l' arbitrary: it s)
  case Nil thus ?case
    apply (subst os_sum'.simps)
    apply (sep_auto intro: os.quit_iteration)
    done
next
  case (Cons x l')
  show ?case
    apply (subst os_sum'.simps)
    apply (sep_auto heap: Cons.hyps)
    done
qed

definition "os_sum p \<equiv> do {
  it \<leftarrow> os_it_init p;
  os_sum' it 0}"

lemma os_sum_rule[sep_heap_rules]:
  "<os_list l p> os_sum p <\<lambda>r. os_list l p * \<up>(r=sum_list l)>\<^sub>t"
  unfolding os_sum_def
  by sep_auto

end


(*  Title:      ZF/Induct/Rmap.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* An operator to ``map'' a relation over a list *}

theory Rmap imports Main begin

consts
  rmap :: "i=>i"

inductive
  domains "rmap(r)" \<subseteq> "list(domain(r)) \<times> list(range(r))"
  intros
    NilI:  "<Nil,Nil> \<in> rmap(r)"

    ConsI: "[| <x,y>: r;  <xs,ys> \<in> rmap(r) |]
            ==> <Cons(x,xs), Cons(y,ys)> \<in> rmap(r)"

  type_intros domainI rangeI list.intros

lemma rmap_mono: "r \<subseteq> s ==> rmap(r) \<subseteq> rmap(s)"
  apply (unfold rmap.defs)
  apply (rule lfp_mono)
    apply (rule rmap.bnd_mono)+
  apply (assumption | rule Sigma_mono list_mono domain_mono range_mono basic_monos)+
  done

inductive_cases
      Nil_rmap_case [elim!]: "<Nil,zs> \<in> rmap(r)"
  and Cons_rmap_case [elim!]: "<Cons(x,xs),zs> \<in> rmap(r)"

declare rmap.intros [intro]

lemma rmap_rel_type: "r \<subseteq> A \<times> B ==> rmap(r) \<subseteq> list(A) \<times> list(B)"
  apply (rule rmap.dom_subset [THEN subset_trans])
  apply (assumption |
    rule domain_rel_subset range_rel_subset Sigma_mono list_mono)+
  done

lemma rmap_total: "A \<subseteq> domain(r) ==> list(A) \<subseteq> domain(rmap(r))"
  apply (rule subsetI)
  apply (erule list.induct)
   apply blast+
  done

lemma rmap_functional: "function(r) ==> function(rmap(r))"
  apply (unfold function_def)
  apply (rule impI [THEN allI, THEN allI])
  apply (erule rmap.induct)
   apply blast+
  done

text {*
  \medskip If @{text f} is a function then @{text "rmap(f)"} behaves
  as expected.
*}

lemma rmap_fun_type: "f \<in> A->B ==> rmap(f): list(A)->list(B)"
  by (simp add: Pi_iff rmap_rel_type rmap_functional rmap_total)

lemma rmap_Nil: "rmap(f)`Nil = Nil"
  by (unfold apply_def) blast

lemma rmap_Cons: "[| f \<in> A->B;  x \<in> A;  xs: list(A) |]
      ==> rmap(f) ` Cons(x,xs) = Cons(f`x, rmap(f)`xs)"
  by (blast intro: apply_equality apply_Pair rmap_fun_type rmap.intros)

end


(* Victor B. F. Gomes, University of Cambridge
   Martin Kleppmann, University of Cambridge
   Dominic P. Mulligan, University of Cambridge
   Alastair R. Beresford, University of Cambridge
*)

section\<open>Replicated Growable Array\<close>

text\<open>The RGA, introduced by \cite{Roh:2011dw}, is a replicated ordered list (sequence) datatype
     that supports \emph{insert} and \emph{delete} operations.\<close>

theory
  Ordered_List
imports
  Util
begin

type_synonym ('id, 'v) elt = "'id \<times> 'v \<times> bool"

subsection\<open>Insert and delete operations\<close>

text\<open>Insertion operations place the new element \emph{after} an existing list element with a given ID, or at the head of the list if no ID is given.
Deletion operations refer to the ID of the list element that is to be deleted.
However, it is not safe for a deletion operation to completely remove a list element, because then a concurrent insertion after the deleted element would not be able to locate the insertion position.
Instead, the list retains so-called \emph{tombstones}: a deletion operation merely sets a flag on a list element to mark it as deleted, but the element actually remains in the list.
A separate garbage collection process can be used to eventually purge tombstones \cite{Roh:2011dw}, but we do not consider tombstone removal here.\<close>

hide_const insert

fun insert_body :: "('id::{linorder}, 'v) elt list \<Rightarrow> ('id, 'v) elt \<Rightarrow> ('id, 'v) elt list" where
  "insert_body []     e = [e]" |
  "insert_body (x#xs) e =
     (if fst x < fst e then
        e#x#xs
      else x#insert_body xs e)"

fun insert :: "('id::{linorder}, 'v) elt list \<Rightarrow> ('id, 'v) elt \<Rightarrow> 'id option \<Rightarrow> ('id, 'v) elt list option" where
  "insert xs     e None     = Some (insert_body xs e)" |
  "insert []     e (Some i) = None" |
  "insert (x#xs) e (Some i) =
     (if fst x = i then
        Some (x#insert_body xs e)
      else
        insert xs e (Some i) \<bind> (\<lambda>t. Some (x#t)))"

fun delete :: "('id::{linorder}, 'v) elt list \<Rightarrow> 'id \<Rightarrow> ('id, 'v) elt list option" where
  "delete []                 i = None" |
  "delete ((i', v, flag)#xs) i =
     (if i' = i then
        Some ((i', v, True)#xs)
      else
        delete xs i \<bind> (\<lambda>t. Some ((i',v,flag)#t)))"

subsection\<open>Well-definedness of insert and delete\<close>

lemma insert_no_failure:
  assumes "i = None \<or> (\<exists>i'. i = Some i' \<and> i' \<in> fst ` set xs)"
  shows   "\<exists>xs'. insert xs e i = Some xs'"
using assms by(induction rule: insert.induct; force)

lemma insert_None_index_neq_None [dest]:
  assumes "insert xs e i = None"
  shows   "i \<noteq> None"
using assms by(cases i, auto)

lemma insert_Some_None_index_not_in [dest]:
  assumes "insert xs e (Some i) = None"
  shows   "i \<notin> fst ` set xs"
using assms by(induction xs, auto split: if_split_asm bind_splits)

lemma index_not_in_insert_Some_None [simp]:
  assumes "i \<notin> fst ` set xs"
  shows   "insert xs e (Some i) = None"
using assms by(induction xs, auto)

lemma delete_no_failure:
  assumes "i \<in> fst ` set xs"
  shows   "\<exists>xs'. delete xs i = Some xs'"
using assms by(induction xs; force)

lemma delete_None_index_not_in [dest]:
  assumes "delete xs i = None"
  shows  "i \<notin> fst ` set xs"
using assms by(induction xs, auto split: if_split_asm bind_splits simp add: fst_eq_Domain)

lemma index_not_in_delete_None [simp]:
  assumes "i \<notin> fst ` set xs"
  shows   "delete xs i = None"
using assms by(induction xs, auto)

subsection\<open>Preservation of element indices\<close>

lemma insert_body_preserve_indices [simp]:
  shows  "fst ` set (insert_body xs e) = fst ` set xs \<union> {fst e}"
by(induction xs, auto simp add: insert_commute)

lemma insert_preserve_indices:
  assumes "\<exists>ys. insert xs e i = Some ys"
  shows   "fst ` set (the (insert xs e i)) = fst ` set xs \<union> {fst e}"
using assms by(induction xs; cases i; auto simp add: insert_commute split: bind_splits)

corollary insert_preserve_indices':
  assumes "insert xs e i = Some ys"
  shows   "fst ` set (the (insert xs e i)) = fst ` set xs \<union> {fst e}"
using assms insert_preserve_indices by blast

lemma delete_preserve_indices:
  assumes "delete xs i = Some ys"
  shows   "fst ` set xs = fst ` set ys"
using assms by(induction xs arbitrary: ys, simp) (case_tac a; auto split: if_split_asm bind_splits)

subsection\<open>Commutativity of concurrent operations\<close>

lemma insert_body_commutes:
  assumes "fst e1 \<noteq> fst e2"
  shows   "insert_body (insert_body xs e1) e2 = insert_body (insert_body xs e2) e1"
using assms by(induction xs, auto)

lemma insert_insert_body:
  assumes "fst e1 \<noteq> fst e2"
      and "i2 \<noteq> Some (fst e1)"
  shows   "insert (insert_body xs e1) e2 i2 = insert xs e2 i2 \<bind> (\<lambda>ys. Some (insert_body ys e1))"
using assms by (induction xs; cases i2) (auto split: if_split_asm simp add: insert_body_commutes)

lemma insert_Nil_None:
  assumes "fst e1 \<noteq> fst e2"
      and "i \<noteq> fst e2"
      and "i2 \<noteq> Some (fst e1)"
  shows   "insert [] e2 i2 \<bind> (\<lambda>ys. insert ys e1 (Some i)) = None"
using assms by (cases "i2") clarsimp+

lemma insert_insert_body_commute:
  assumes "i \<noteq> fst e1"
      and "fst e1 \<noteq> fst e2"
  shows   "insert (insert_body xs e1) e2 (Some i) =
             insert xs e2 (Some i) \<bind> (\<lambda>y. Some (insert_body y e1))"
using assms by(induction xs, auto simp add: insert_body_commutes)

lemma insert_commutes:
  assumes "fst e1 \<noteq> fst e2"
          "i1 = None \<or> i1 \<noteq> Some (fst e2)"
          "i2 = None \<or> i2 \<noteq> Some (fst e1)"
  shows   "insert xs e1 i1 \<bind> (\<lambda>ys. insert ys e2 i2) =
           insert xs e2 i2 \<bind> (\<lambda>ys. insert ys e1 i1)"
using assms proof(induction rule: insert.induct)
  fix xs and e :: "('a, 'b) elt"
  assume "i2 = None \<or> i2 \<noteq> Some (fst e)" and "fst e \<noteq> fst e2"
  thus "insert xs e None \<bind> (\<lambda>ys. insert ys e2 i2) = insert xs e2 i2 \<bind> (\<lambda>ys. insert ys e None)"
    by(auto simp add: insert_body_commutes intro: insert_insert_body)
next
  fix i and e :: "('a, 'b) elt"
  assume "fst e \<noteq> fst e2" and "i2 = None \<or> i2 \<noteq> Some (fst e)" and "Some i = None \<or> Some i \<noteq> Some (fst e2)"
  thus "insert [] e (Some i) \<bind> (\<lambda>ys. insert ys e2 i2) = insert [] e2 i2 \<bind> (\<lambda>ys. insert ys e (Some i))"
    by (auto intro: insert_Nil_None[symmetric])
next
  fix xs i and x e :: "('a, 'b) elt"
  assume IH: "(fst x \<noteq> i \<Longrightarrow>
               fst e \<noteq> fst e2 \<Longrightarrow>
               Some i = None \<or> Some i \<noteq> Some (fst e2) \<Longrightarrow>
               i2 = None \<or> i2 \<noteq> Some (fst e) \<Longrightarrow>
               insert xs e (Some i) \<bind> (\<lambda>ys. insert ys e2 i2) = insert xs e2 i2 \<bind> (\<lambda>ys. insert ys e (Some i)))"
     and "fst e \<noteq> fst e2"
     and "Some i = None \<or> Some i \<noteq> Some (fst e2)"
     and "i2 = None \<or> i2 \<noteq> Some (fst e)"
  thus "insert (x # xs) e (Some i) \<bind> (\<lambda>ys. insert ys e2 i2) = insert (x # xs) e2 i2 \<bind> (\<lambda>ys. insert ys e (Some i))"
    apply -
    apply(erule disjE, clarsimp, simp, rule conjI)
     apply(case_tac i2; force simp add: insert_body_commutes insert_insert_body_commute)
    apply(case_tac i2; clarsimp cong: Option.bind_cong simp add: insert_insert_body split: bind_splits)
    apply force
    done
qed

lemma delete_commutes:
  shows "delete xs i1 \<bind> (\<lambda>ys. delete ys i2) = delete xs i2 \<bind> (\<lambda>ys. delete ys i1)"
by(induction xs, auto split: bind_splits if_split_asm)

lemma insert_body_delete_commute:
  assumes "i2 \<noteq> fst e"
  shows   "delete (insert_body xs e) i2 \<bind> (\<lambda>t. Some (x#t)) =
            delete xs i2 \<bind> (\<lambda>y. Some (x#insert_body y e))"
using assms by (induction xs arbitrary: x; cases e, auto split: bind_splits if_split_asm)

lemma insert_delete_commute:
  assumes "i2 \<noteq> fst e"
  shows   "insert xs e i1 \<bind> (\<lambda>ys. delete ys i2) = delete xs i2 \<bind> (\<lambda>ys. insert ys e i1)"
using assms by(induction xs; cases e; cases i1, auto split: bind_splits if_split_asm simp add: insert_body_delete_commute)

subsection\<open>Alternative definition of insert\<close>

fun insert' :: "('id::{linorder}, 'v) elt list \<Rightarrow> ('id, 'v) elt \<Rightarrow> 'id option \<rightharpoonup> ('id::{linorder}, 'v) elt list" where
  "insert' [] e     None     = Some [e]" |
  "insert' [] e     (Some i) = None" |
  "insert' (x#xs) e None     =
     (if fst x < fst e then
        Some (e#x#xs)
      else
        case insert' xs e None of
          None   \<Rightarrow> None
        | Some t \<Rightarrow> Some (x#t))" |
  "insert' (x#xs) e (Some i) =
     (if fst x = i then
        case insert' xs e None of
          None   \<Rightarrow> None
        | Some t \<Rightarrow> Some (x#t)
      else
        case insert' xs e (Some i) of
          None   \<Rightarrow> None
        | Some t \<Rightarrow> Some (x#t))"

lemma [elim!, dest]:
  assumes "insert' xs e None = None"
  shows   "False"
using assms by(induction xs, auto split: if_split_asm option.split_asm)

lemma insert_body_insert':
  shows "insert' xs e None = Some (insert_body xs e)"
by(induction xs, auto)

lemma insert_insert':
  shows "insert xs e i = insert' xs e i"
by(induction xs; cases e; cases i, auto split: option.split simp add: insert_body_insert')

lemma insert_body_stop_iteration:
  assumes "fst e > fst x"
  shows "insert_body (x#xs) e = e#x#xs"
using assms by simp

lemma insert_body_contains_new_elem:
  shows "\<exists>p s. xs = p @ s \<and> insert_body xs e = p @ e # s"
proof (induction xs)
  case Nil thus ?case by force
next
  case (Cons a xs)
  then obtain p s where "xs = p @ s \<and> insert_body xs e = p @ e # s" by force
  thus ?case
    apply clarsimp
    apply (rule conjI; clarsimp)
      apply force
    apply (rule_tac x="a # p" in exI, force)
    done
qed

lemma insert_between_elements:
  assumes "xs = pre@ref#suf"
      and "distinct (map fst xs)"
      and "\<And>i'. i' \<in> fst ` set xs \<Longrightarrow> i' < fst e"
    shows "insert xs e (Some (fst ref)) = Some (pre @ ref # e # suf)"
  using assms by(induction xs arbitrary: pre ref suf, force) (case_tac pre; case_tac suf; force)

lemma insert_position_element_technical:
  assumes "\<forall>x\<in>set as. a \<noteq> fst x"
    and "insert_body (cs @ ds) e = cs @ e # ds"
  shows "insert (as @ (a, aa, b) # cs @ ds) e (Some a) = Some (as @ (a, aa, b) # cs @ e # ds)"
using assms by (induction as arbitrary: cs ds; clarsimp)

lemma split_tuple_list_by_id:
  assumes "(a,b,c) \<in> set xs"
    and "distinct (map fst xs)"
  shows "\<exists>pre suf. xs = pre @ (a,b,c) # suf \<and> (\<forall>y \<in> set pre. fst y \<noteq> a)"
using assms proof(induction xs, clarsimp)
  case (Cons x xs)
  { assume "x \<noteq> (a, b, c)"
    hence "(a, b, c) \<in> set xs" "distinct (map fst xs)"
      using Cons.prems by force+
    then obtain pre suf where "xs = pre @ (a, b, c) # suf \<and> (\<forall>y\<in>set pre. fst y \<noteq> a)"
      using Cons.IH by force
    hence ?case
      apply(rule_tac x="x#pre" in exI)
      using Cons.prems(2) by auto
  } thus ?case
    by force
qed

lemma insert_preserves_order:
  assumes "i = None \<or> (\<exists>i'. i = Some i' \<and> i' \<in> fst ` set xs)"
      and "distinct (map fst xs)"
    shows "\<exists>pre suf. xs = pre@suf \<and> insert xs e i = Some (pre @ e # suf)"
  using assms proof -
  { assume "i = None"
    hence ?thesis
      by clarsimp (metis insert_body_contains_new_elem)
  } moreover {
    assume "\<exists>i'. i = Some i' \<and> i' \<in> fst ` set xs"
    then obtain j v b where "i = Some j" "(j, v, b) \<in> set xs" by force
    moreover then obtain as bs where "xs = as@(j,v,b)#bs" "\<forall>x \<in> set as. fst x \<noteq> j"
      using assms by (metis split_tuple_list_by_id)
    moreover then obtain cs ds where "insert_body bs e = cs@e#ds" "cs@ds = bs"
      by(metis insert_body_contains_new_elem)
    ultimately have ?thesis
      by(rule_tac x="as@(j,v,b)#cs" in exI; clarsimp)(metis insert_position_element_technical)
  } ultimately show ?thesis
    using assms by force
qed
end


section \<open>\<open>Extra_Vector_Spaces\<close> -- Additional facts about vector spaces\<close>

theory Extra_Vector_Spaces
  imports
    "HOL-Analysis.Inner_Product"
    "HOL-Analysis.Euclidean_Space"
    "HOL-Library.Indicator_Function"
    "HOL-Analysis.Topology_Euclidean_Space"
    "HOL-Analysis.Line_Segment"
    Extra_General
begin

subsection \<open>Euclidean spaces\<close>

typedef 'a euclidean_space = "UNIV :: ('a \<Rightarrow> real) set" ..
setup_lifting type_definition_euclidean_space

instantiation euclidean_space :: (type) real_vector begin
lift_definition plus_euclidean_space ::
  "'a euclidean_space \<Rightarrow> 'a euclidean_space \<Rightarrow> 'a euclidean_space"
  is "\<lambda>f g x. f x + g x" .
lift_definition zero_euclidean_space :: "'a euclidean_space" is "\<lambda>_. 0" .
lift_definition uminus_euclidean_space ::
  "'a euclidean_space \<Rightarrow> 'a euclidean_space"
  is "\<lambda>f x. - f x" .
lift_definition minus_euclidean_space ::
  "'a euclidean_space \<Rightarrow> 'a euclidean_space \<Rightarrow> 'a euclidean_space"
  is "\<lambda>f g x. f x - g x".
lift_definition scaleR_euclidean_space ::
  "real \<Rightarrow> 'a euclidean_space \<Rightarrow> 'a euclidean_space"
  is "\<lambda>c f x. c * f x" .
instance
  apply intro_classes
  by (transfer; auto intro: distrib_left distrib_right)+
end

instantiation euclidean_space :: (finite) real_inner begin
lift_definition inner_euclidean_space :: "'a euclidean_space \<Rightarrow> 'a euclidean_space \<Rightarrow> real"
  is "\<lambda>f g. \<Sum>x\<in>UNIV. f x * g x :: real" .
definition "norm_euclidean_space (x::'a euclidean_space) = sqrt (inner x x)"
definition "dist_euclidean_space (x::'a euclidean_space) y = norm (x-y)"
definition "sgn x = x /\<^sub>R norm x" for x::"'a euclidean_space"
definition "uniformity = (INF e\<in>{0<..}. principal {(x::'a euclidean_space, y). dist x y < e})"
definition "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x'::'a euclidean_space, y) in uniformity. x' = x \<longrightarrow> y \<in> U)"
instance
proof intro_classes
  fix x :: "'a euclidean_space"
    and y :: "'a euclidean_space"
    and z :: "'a euclidean_space"
  show "dist (x::'a euclidean_space) y = norm (x - y)"
    and "sgn (x::'a euclidean_space) = x /\<^sub>R norm x"
    and "uniformity = (INF e\<in>{0<..}. principal {(x, y). dist (x::'a euclidean_space) y < e})"
    and "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. (x'::'a euclidean_space) = x \<longrightarrow> y \<in> U)"
    and "norm x = sqrt (inner x x)" for U
    unfolding dist_euclidean_space_def norm_euclidean_space_def sgn_euclidean_space_def
      uniformity_euclidean_space_def open_euclidean_space_def
    by simp_all

  show "inner x y = inner y x"
    apply transfer
    by (simp add: mult.commute)
  show "inner (x + y) z = inner x z + inner y z"
  proof transfer
    fix x y z::"'a \<Rightarrow> real"
    have "(\<Sum>i\<in>UNIV. (x i + y i) * z i) = (\<Sum>i\<in>UNIV. x i * z i + y i * z i)"
      by (simp add: distrib_left mult.commute)
    thus "(\<Sum>i\<in>UNIV. (x i + y i) * z i) = (\<Sum>j\<in>UNIV. x j * z j) + (\<Sum>k\<in>UNIV. y k * z k)"
      by (subst sum.distrib[symmetric])
  qed

  show "inner (r *\<^sub>R x) y = r * (inner x y)" for r
  proof transfer
    fix r and x y::"'a\<Rightarrow>real"
    have "(\<Sum>i\<in>UNIV. r * x i * y i) = (\<Sum>i\<in>UNIV. r * (x i * y i))"
      by (simp add: mult.assoc)
    thus "(\<Sum>i\<in>UNIV. r * x i * y i) = r * (\<Sum>j\<in>UNIV. x j * y j)"
      by (subst sum_distrib_left)
  qed
  show "0 \<le> inner x x"
    apply transfer
    by (simp add: sum_nonneg)
  show "(inner x x = 0) = (x = 0)"
  proof (transfer, rule)
    fix f :: "'a \<Rightarrow> real"
    assume "(\<Sum>i\<in>UNIV. f i * f i) = 0"
    hence "f x * f x = 0" for x
      apply (rule_tac sum_nonneg_eq_0_iff[THEN iffD1, rule_format, where A=UNIV and x=x])
      by auto
    thus "f = (\<lambda>_. 0)"
      by auto
  qed auto
qed
end

instantiation euclidean_space :: (finite) euclidean_space begin
lift_definition euclidean_space_basis_vector :: "'a \<Rightarrow> 'a euclidean_space" is
  "\<lambda>x. indicator {x}" .
definition "Basis_euclidean_space == (euclidean_space_basis_vector ` UNIV)"
instance
proof intro_classes
  fix u :: "'a euclidean_space"
    and v :: "'a euclidean_space"
  show "(Basis::'a euclidean_space set) \<noteq> {}"
    unfolding Basis_euclidean_space_def by simp
  show "finite (Basis::'a euclidean_space set)"
    unfolding Basis_euclidean_space_def by simp
  show "inner u v = (if u = v then 1 else 0)"
    if "u \<in> Basis" and "v \<in> Basis"
    using that unfolding Basis_euclidean_space_def
    apply transfer apply auto
    by (auto simp: indicator_def)
  show "(\<forall>v\<in>Basis. inner u v = 0) = (u = 0)"
    unfolding Basis_euclidean_space_def
    apply transfer
    by auto
qed
end (* euclidean_space :: (finite) euclidean_space *)

lemma closure_bounded_linear_image_subset_eq:
  assumes f: "bounded_linear f"
  shows "closure (f ` closure S) = closure (f ` S)"
  by (meson closed_closure closure_bounded_linear_image_subset closure_minimal closure_mono closure_subset f image_mono subset_antisym)

lemma not_singleton_real_normed_is_perfect_space[simp]: \<open>class.perfect_space (open :: 'a::{not_singleton,real_normed_vector} set \<Rightarrow> bool)\<close>
  apply standard
  by (metis UNIV_not_singleton clopen closed_singleton empty_not_insert)

end