section\<open>Main definitions of the development\label{sec:main-definitions}\<close>

theory Definitions_Main
  imports
    Absolute_Versions
begin

text\<open>This theory gathers the main definitions of the
\<^session>\<open>Transitive_Models\<close> session and the present one.

It might be considered as the bare minimum reading requisite to
trust that our development indeed formalizes the theory of
forcing. This should be mathematically clear since this is the
only known method for obtaining proper extensions of ctms while
preserving the ordinals.

The main theorem of this session and all of its relevant definitions
appear in Section~\ref{sec:def-main-forcing}. The reader trusting
all the libraries on which our development is based, might jump
directly to Section~\ref{sec:relative-arith}, which treats relative
cardinal arithmetic as implemented in
\<^session>\<open>Transitive_Models\<close>. But in case one wants to dive deeper, the
following sections treat some basic concepts of the ZF logic
(Section~\ref{sec:def-main-ZF}) and in the
ZF-Constructible library (Section~\ref{sec:def-main-relative})
on which our definitions are built.
\<close>

declare [[show_question_marks=false]]

subsection\<open>ZF\label{sec:def-main-ZF}\<close>

text\<open>For the basic logic ZF we restrict ourselves to just a few
concepts.\<close>

thm bij_def[unfolded inj_def surj_def]
text\<open>@{thm [display] bij_def[unfolded inj_def surj_def]}\<close>
(*
bij(A, B) \<equiv>
  {f \<in> A \<rightarrow> B . \<forall>w\<in>A. \<forall>x\<in>A. f ` w = f ` x \<longrightarrow> w = x} \<inter>
  {f \<in> A \<rightarrow> B . \<forall>y\<in>B. \<exists>x\<in>A. f ` x = y}
*)

thm eqpoll_def
text\<open>@{thm [display] eqpoll_def}\<close>
(*
  A \<approx> B \<equiv> \<exists>f. f \<in> bij(A, B)
*)

thm Transset_def
text\<open>@{thm [display] Transset_def}\<close>
(*
  Transset(i) \<equiv> \<forall>x\<in>i. x \<subseteq> i
*)

thm Ord_def
text\<open>@{thm [display] Ord_def}\<close>
(*
  Ord(i) \<equiv> Transset(i) \<and> (\<forall>x\<in>i. Transset(x))
*)

thm lt_def le_iff
text\<open>@{thm [display] lt_def le_iff}\<close>
(*
  i < j \<equiv> i \<in> j \<and> Ord(j)
  i \<le> j \<longleftrightarrow> i < j \<or> i = j \<and> Ord(j)
*)

text\<open>With the concepts of empty set and successor in place,\<close>
lemma empty_def': "\<forall>x. x \<notin> 0" by simp
lemma succ_def': "succ(i) = i \<union> {i}" by blast

text\<open>we can define the set of natural numbers \<^term>\<open>\<omega>\<close>. In the
sources, it is  defined as a fixpoint, but here we just write
its characterization as the first limit ordinal.\<close>
thm Limit_nat[unfolded Limit_def] nat_le_Limit[unfolded Limit_def]
text\<open>@{thm [display] Limit_nat[unfolded Limit_def]
 nat_le_Limit[unfolded Limit_def]}\<close>
(*
  Ord(\<omega>) \<and> 0 < \<omega> \<and> (\<forall>y. y < \<omega> \<longrightarrow> succ(y) < \<omega>)
  Ord(i) \<and> 0 < i \<and> (\<forall>y. y < i \<longrightarrow> succ(y) < i) \<Longrightarrow> \<omega> \<le> i
*)

text\<open>Then, addition and predecessor on \<^term>\<open>\<omega>\<close> are inductively
characterized as follows:\<close>
thm add_0_right add_succ_right pred_0 pred_succ_eq
text\<open>@{thm [display] add_succ_right add_0_right pred_0 pred_succ_eq}\<close>
(*
  m \<in> \<omega> \<Longrightarrow> m +\<^sub>\<omega> 0 = m
  m +\<^sub>\<omega> succ(n) = succ(m +\<^sub>\<omega> n)

  pred(0) = 0
  pred(succ(y)) = y
*)

text\<open>Lists on a set \<^term>\<open>A\<close> can be characterized by being
recursively generated from the empty list \<^term>\<open>[]\<close> and the
operation \<^term>\<open>Cons\<close> that adds a new element to the left end;
the induction theorem for them shows that the characterization is
“complete”.\<close>

thm Nil Cons list.induct
text\<open>@{thm [display] Nil Cons list.induct }\<close>
(*
  [] \<in> list(A)
  a \<in> A \<Longrightarrow> l \<in> list(A) \<Longrightarrow> Cons(a, l) \<in> list(A)
  x \<in> list(A) \<Longrightarrow>
  P([]) \<Longrightarrow> (\<And>a l. a \<in> A \<Longrightarrow> l \<in> list(A) \<Longrightarrow> P(l) \<Longrightarrow> P(Cons(a, l))) \<Longrightarrow> P(x)
*)

text\<open>Length, concatenation, and \<^term>\<open>n\<close>th element of lists are
recursively characterized as follows.\<close>
thm length.simps app.simps nth_0 nth_Cons
text\<open>@{thm [display] length.simps app.simps nth_0 nth_Cons}\<close>
(*
  length([]) = 0
  length(Cons(a, l)) = succ(length(l))

  [] @ ys = ys
  Cons(a, l) @ ys = Cons(a, l @ ys)

  nth(0, Cons(a, l)) = a
  n \<in> \<omega> \<Longrightarrow> nth(succ(n), Cons(a, l)) = nth(n, l)
*)
text\<open>We have the usual Haskell-like notation for iterated applications
of \<^term>\<open>Cons\<close>:\<close>
lemma Cons_app: "[a,b,c] = Cons(a,Cons(b,Cons(c,[])))" ..

text\<open>Relative quantifiers restrict the range of the bound variable to a
class \<^term>\<open>M\<close> of type \<^typ>\<open>i\<Rightarrow>o\<close>; that is, a truth-valued function with
set arguments.\<close>
lemma "\<forall>x[M]. P(x) \<equiv> \<forall>x. M(x) \<longrightarrow> P(x)"
      "\<exists>x[M]. P(x) \<equiv> \<exists>x. M(x) \<and> P(x)"
  unfolding rall_def rex_def .

text\<open>Finally, a set can be viewed (“cast”) as a class using the
following function of type \<^typ>\<open>i\<Rightarrow>(i\<Rightarrow>o)\<close>.\<close>
thm setclass_iff
text\<open>@{thm [display] setclass_iff}\<close>
(*
  (##A)(x) \<longleftrightarrow> x \<in> A
*)

subsection\<open>Relative concepts\label{sec:def-main-relative}\<close>
text\<open>A list of relative concepts (mostly from the ZF-Constructible
    library) follows next.\<close>

thm big_union_def
text\<open>@{thm [display] big_union_def}\<close>
(*
  big_union(M, A, z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow> (\<exists>y[M]. y \<in> A \<and> x \<in> y)
*)

thm upair_def
text\<open>@{thm [display] upair_def}\<close>
(*
  upair(M, a, b, z) \<equiv> a \<in> z \<and> b \<in> z \<and> (\<forall>x[M]. x \<in> z \<longrightarrow> x = a \<or> x = b)
*)

thm pair_def
text\<open>@{thm [display] pair_def}\<close>
(*
  pair(M, a, b, z) \<equiv> \<exists>x[M]. upair(M, a, a, x) \<and>
                        (\<exists>y[M]. upair(M, a, b, y) \<and> upair(M, x, y, z))
*)

thm successor_def[unfolded is_cons_def union_def]
text\<open>@{thm [display] successor_def[unfolded is_cons_def union_def]}\<close>
(*
  successor(M, a, z) \<equiv> \<exists>x[M]. upair(M, a, a, x) \<and> (\<forall>xa[M]. xa \<in> z \<longleftrightarrow> xa \<in> x \<or> xa \<in> a)
*)

thm empty_def
text\<open>@{thm [display] empty_def}\<close>
(*
  empty(M, z) \<equiv> \<forall>x[M]. x \<notin> z
*)

thm transitive_set_def[unfolded subset_def]
text\<open>@{thm [display] transitive_set_def[unfolded subset_def]}\<close>
(*
  transitive_set(M, a) \<equiv> \<forall>x[M]. x \<in> a \<longrightarrow> (\<forall>xa[M]. xa \<in> x \<longrightarrow> xa \<in> a)
*)

thm ordinal_def
text\<open>@{thm [display] ordinal_def}\<close>
(*
  ordinal(M, a) \<equiv> transitive_set(M, a) \<and> (\<forall>x[M]. x \<in> a \<longrightarrow>
                                              transitive_set(M, x))
*)

thm image_def
text\<open>@{thm [display] image_def}\<close>
(*
  image(M, r, A, z) \<equiv> \<forall>y[M]. y \<in> z \<longleftrightarrow>
                (\<exists>w[M]. w \<in> r \<and> (\<exists>x[M]. x \<in> A \<and> pair(M, x, y, w)))
*)

thm fun_apply_def
text\<open>@{thm [display] fun_apply_def}\<close>
(*
  fun_apply(M, f, x, y) \<equiv> \<exists>xs[M]. \<exists>fxs[M]. upair(M, x, x, xs) \<and>
                       image(M, f, xs, fxs) \<and> big_union(M, fxs, y)
*)

thm is_function_def
text\<open>@{thm [display] is_function_def}\<close>
(*
  is_function(M, r) \<equiv> \<forall>x[M]. \<forall>y[M]. \<forall>y'[M]. \<forall>p[M]. \<forall>p'[M].
       pair(M, x, y, p) \<longrightarrow> pair(M, x, y', p') \<longrightarrow> p \<in> r \<longrightarrow> p' \<in> r \<longrightarrow> y = y'
*)

thm is_relation_def
text\<open>@{thm [display] is_relation_def}\<close>
(*
  is_relation(M, r) \<equiv> \<forall>z[M]. z \<in> r \<longrightarrow> (\<exists>x[M]. \<exists>y[M]. pair(M, x, y, z))
*)

thm is_domain_def
text\<open>@{thm [display] is_domain_def}\<close>
(*
  is_domain(M, r, z) \<equiv> \<forall>x[M]. x \<in> z \<longleftrightarrow>
                        (\<exists>w[M]. w \<in> r \<and> (\<exists>y[M]. pair(M, x, y, w)))
*)

thm typed_function_def
text\<open>@{thm [display] typed_function_def}\<close>
(*
  typed_function(M, A, B, r) \<equiv> is_function(M, r) \<and> is_relation(M, r) \<and>
                                is_domain(M, r, A) \<and>
            (\<forall>u[M]. u \<in> r \<longrightarrow> (\<forall>x[M]. \<forall>y[M]. pair(M, x, y, u) \<longrightarrow> y \<in> B))
*)

thm is_function_space_def[unfolded is_funspace_def]
  function_space_rel_def surjection_def
text\<open>@{thm [display] is_function_space_def[unfolded is_funspace_def]
  function_space_rel_def surjection_def}\<close>
(*
  is_function_space(M, A, B, fs) \<equiv>
  M(fs) \<and> (\<forall>f[M]. f \<in> fs \<longleftrightarrow> typed_function(M, A, B, f))

  A \<rightarrow>\<^bsup>M\<^esup> B \<equiv> THE d. is_function_space(M, A, B, d)

  surjection(M, A, B, f) \<equiv>
  typed_function(M, A, B, f) \<and>
  (\<forall>y[M]. y \<in> B \<longrightarrow> (\<exists>x[M]. x \<in> A \<and> is_apply(M, f, x, y)))
*)

text\<open>Relative version of the $\ZFC$ axioms\<close>
thm extensionality_def
text\<open>@{thm [display] extensionality_def}\<close>
(*
  extensionality(M) \<equiv> \<forall>x[M]. \<forall>y[M]. (\<forall>z[M]. z \<in> x \<longleftrightarrow> z \<in> y) \<longrightarrow> x = y
*)

thm foundation_ax_def
text\<open>@{thm [display] foundation_ax_def}\<close>
(*
  foundation_ax(M) \<equiv> \<forall>x[M]. (\<exists>y[M]. y \<in> x) \<longrightarrow> (\<exists>y[M]. y \<in> x \<and> \<not> (\<exists>z[M]. z \<in> x \<and> z \<in> y))
*)

thm upair_ax_def
text\<open>@{thm [display] upair_ax_def}\<close>
(*
  upair_ax(M) \<equiv> \<forall>x[M]. \<forall>y[M]. \<exists>z[M]. upair(M, x, y, z)
*)

thm Union_ax_def
text\<open>@{thm [display] Union_ax_def}\<close>
(*
  Union_ax(M) \<equiv> \<forall>x[M]. \<exists>z[M]. \<forall>xa[M]. xa \<in> z \<longleftrightarrow> (\<exists>y[M]. y \<in> x \<and> xa \<in> y)
*)

thm power_ax_def[unfolded powerset_def subset_def]
text\<open>@{thm [display] power_ax_def[unfolded powerset_def subset_def]}\<close>
(*
  power_ax(M) \<equiv> \<forall>x[M]. \<exists>z[M]. \<forall>xa[M]. xa \<in> z \<longleftrightarrow> (\<forall>xb[M]. xb \<in> xa \<longrightarrow> xb \<in> x)
*)

thm infinity_ax_def
text\<open>@{thm [display] infinity_ax_def}\<close>
(*
  infinity_ax(M) \<equiv> \<exists>I[M]. (\<exists>z[M]. empty(M, z) \<and> z \<in> I) \<and> (\<forall>y[M]. y \<in> I \<longrightarrow>
                        (\<exists>sy[M]. successor(M, y, sy) \<and> sy \<in> I))
*)

thm choice_ax_def
text\<open>@{thm [display] choice_ax_def}\<close>
(*
  choice_ax(M) \<equiv> \<forall>x[M]. \<exists>a[M]. \<exists>f[M]. ordinal(M, a) \<and> surjection(M, a, x, f)
*)

thm separation_def
text\<open>@{thm [display] separation_def}\<close>
(*
  separation(M, P) \<equiv> \<forall>z[M]. \<exists>y[M]. \<forall>x[M]. x \<in> y \<longleftrightarrow> x \<in> z \<and> P(x)
*)

thm univalent_def
text\<open>@{thm [display] univalent_def}\<close>
(*
  univalent(M, A, P) \<equiv> \<forall>x[M]. x \<in> A \<longrightarrow>
                          (\<forall>y[M]. \<forall>z[M]. P(x, y) \<and> P(x, z) \<longrightarrow> y = z)
*)

thm strong_replacement_def
text\<open>@{thm [display] strong_replacement_def}\<close>
(*
  strong_replacement(M, P) \<equiv> \<forall>A[M]. univalent(M, A, P) \<longrightarrow>
       (\<exists>Y[M]. \<forall>b[M]. b \<in> Y \<longleftrightarrow> (\<exists>x[M]. x \<in> A \<and> P(x, b)))
*)

text\<open>Internalized formulas\<close>

text\<open>“Codes” for formulas (as sets) are constructed from natural
numbers using \<^term>\<open>Member\<close>, \<^term>\<open>Equal\<close>, \<^term>\<open>Nand\<close>,
and \<^term>\<open>Forall\<close>.\<close>

thm Member Equal Nand Forall formula.induct
text\<open>@{thm [display] Member Equal Nand Forall formula.induct}\<close>
(*
  x \<in> \<omega> \<Longrightarrow> y \<in> \<omega> \<Longrightarrow> \<cdot>x \<in> y\<cdot> \<in> formula
  x \<in> \<omega> \<Longrightarrow> y \<in> \<omega> \<Longrightarrow> \<cdot>x = y\<cdot> \<in> formula
  p \<in> formula \<Longrightarrow> q \<in> formula \<Longrightarrow> \<cdot>\<not>(p \<and> q)\<cdot> \<in> formula
  p \<in> formula \<Longrightarrow> (\<forall>p) \<in> formula

  x \<in> formula \<Longrightarrow>
  (\<And>x y. x \<in> \<omega> \<Longrightarrow> y \<in> \<omega> \<Longrightarrow> P(\<cdot>x \<in> y\<cdot>)) \<Longrightarrow>
  (\<And>x y. x \<in> \<omega> \<Longrightarrow> y \<in> \<omega> \<Longrightarrow> P(\<cdot>x = y\<cdot>)) \<Longrightarrow>
  (\<And>p q. p \<in> formula \<Longrightarrow> P(p) \<Longrightarrow> q \<in> formula \<Longrightarrow> P(q) \<Longrightarrow> P(\<cdot>\<not>(p \<and> q)\<cdot>)) \<Longrightarrow>
  (\<And>p. p \<in> formula \<Longrightarrow> P(p) \<Longrightarrow> P((\<forall>p))) \<Longrightarrow> P(x)
*)

text\<open>Definitions for the other connectives and the internal existential
quantifier are also provided. For instance, negation:\<close>
thm Neg_def
text\<open>@{thm [display] Neg_def}\<close>
(*
  \<cdot>\<not>p\<cdot> \<equiv> \<cdot>\<not>(p \<and> p)\<cdot>
*)

thm arity.simps
text\<open>@{thm [display] arity.simps}\<close>
(*
  arity(\<cdot>x \<in> y\<cdot>) = succ(x) \<union> succ(y)
  arity(\<cdot>x = y\<cdot>) = succ(x) \<union> succ(y)
  arity(\<cdot>\<not>(p \<and> q)\<cdot>) = arity(p) \<union> arity(q)
  arity((\<forall>p)) = pred(arity(p))
*)

text\<open>We have the satisfaction relation between $\in$-models and
    first order formulas (given a “environment” list representing
    the assignment of free variables),\<close>
thm mem_iff_sats equal_iff_sats sats_Nand_iff sats_Forall_iff
text\<open>@{thm [display] mem_iff_sats equal_iff_sats sats_Nand_iff sats_Forall_iff}\<close>
(*
  nth(i, env) = x \<Longrightarrow> nth(j, env) = y \<Longrightarrow> env \<in> list(A) \<Longrightarrow> x \<in> y \<longleftrightarrow> A, env \<Turnstile> \<cdot>i \<in> j\<cdot>
  nth(i, env) = x \<Longrightarrow> nth(j, env) = y \<Longrightarrow> env \<in> list(A) \<Longrightarrow> x = y \<longleftrightarrow> A, env \<Turnstile> \<cdot>i = j\<cdot>
  env \<in> list(A) \<Longrightarrow> (A, env \<Turnstile> \<cdot>\<not>(p \<and> q)\<cdot>) \<longleftrightarrow> \<not> ((A, env \<Turnstile> p) \<and> (A, env \<Turnstile> q))
  env \<in> list(A) \<Longrightarrow> (A, env \<Turnstile> (\<cdot>\<forall>p\<cdot>)) \<longleftrightarrow> (\<forall>x\<in>A. A, Cons(x, env) \<Turnstile> p)*)

text\<open>as well as the satisfaction of an arbitrary set of sentences.\<close>
thm satT_def
text\<open>@{thm [display] satT_def}\<close>
(*
  A \<Turnstile> \<Phi>  \<equiv>  \<forall>\<phi>\<in>\<Phi>. A, [] \<Turnstile> \<phi>
*)

text\<open>The internalized (viz. as elements of the set \<^term>\<open>formula\<close>)
    version of the axioms follow next.\<close>

thm ZF_union_iff_sats ZF_power_iff_sats ZF_pairing_iff_sats
  ZF_foundation_iff_sats ZF_extensionality_iff_sats
  ZF_infinity_iff_sats sats_ZF_separation_fm_iff
  sats_ZF_replacement_fm_iff ZF_choice_iff_sats
text\<open>@{thm [display] ZF_union_iff_sats ZF_power_iff_sats
  ZF_pairing_iff_sats
  ZF_foundation_iff_sats ZF_extensionality_iff_sats
  ZF_infinity_iff_sats sats_ZF_separation_fm_iff
  sats_ZF_replacement_fm_iff ZF_choice_iff_sats}\<close>
(*
  Union_ax(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>Union Ax\<cdot>
  power_ax(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>Powerset Ax\<cdot>
  upair_ax(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>Pairing\<cdot>
  foundation_ax(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>Foundation\<cdot>
  extensionality(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>Extensionality\<cdot>
  infinity_ax(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>Infinity\<cdot>

  \<phi> \<in> formula \<Longrightarrow>
  (M, [] \<Turnstile> \<cdot>Separation(\<phi>)\<cdot>) \<longleftrightarrow>
  (\<forall>env\<in>list(M).
      arity(\<phi>) \<le> 1 +\<^sub>\<omega> length(env) \<longrightarrow> separation(##M, \<lambda>x. M, [x] @ env \<Turnstile> \<phi>))

  \<phi> \<in> formula \<Longrightarrow>
  (M, [] \<Turnstile> \<cdot>Replacement(\<phi>)\<cdot>) \<longleftrightarrow> (\<forall>env. replacement_assm(M, env, \<phi>))

  choice_ax(##A) \<longleftrightarrow> A, [] \<Turnstile> \<cdot>AC\<cdot>
*)

text\<open>Above, we use the following:\<close>

thm replacement_assm_def
text\<open>@{thm [display] replacement_assm_def}\<close>
(*
replacement_assm(M, env, \<phi>) \<equiv>
\<phi> \<in> formula \<longrightarrow>
env \<in> list(M) \<longrightarrow>
arity(\<phi>) \<le> 2 +\<^sub>\<omega> length(env) \<longrightarrow>
strong_replacement(##M, \<lambda>x y. M, [x, y] @ env \<Turnstile> \<phi>
*)

text\<open>Finally, the axiom sets are defined as follows.\<close>

thm ZF_fin_def ZF_schemes_def Zermelo_fms_def ZC_def ZF_def ZFC_def
text\<open>@{thm [display] ZF_fin_def ZF_schemes_def Zermelo_fms_def ZC_def ZF_def
  ZFC_def}\<close>
(*
  ZF_fin \<equiv> {\<cdot>Extensionality\<cdot>, \<cdot>Foundation\<cdot>, \<cdot>Pairing\<cdot>, \<cdot>Union Ax\<cdot>, \<cdot>Infinity\<cdot>, \<cdot>Powerset Ax\<cdot>}
  ZF_schemes \<equiv> {\<cdot>Separation(p)\<cdot> . p \<in> formula} \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> formula}
  \<cdot>Z\<cdot> \<equiv> ZF_fin \<union> {\<cdot>Separation(p)\<cdot> . p \<in> formula}
  ZC \<equiv> \<cdot>Z\<cdot> \<union> {\<cdot>AC\<cdot>}
  ZF \<equiv> ZF_schemes \<union> ZF_fin
  ZFC \<equiv> ZF \<union> {\<cdot>AC\<cdot>}
*)

subsection\<open>Relativization of infinitary arithmetic\label{sec:relative-arith}\<close>

text\<open>In order to state the defining property of the relative
    equipotence relation, we work under the assumptions of the
    locale \<^term>\<open>M_cardinals\<close>. They comprise a finite set
    of instances of Separation and Replacement to prove
    closure properties of the transitive class \<^term>\<open>M\<close>.\<close>

lemma (in M_cardinals) eqpoll_def':
  assumes "M(A)" "M(B)" shows "A \<approx>\<^bsup>M\<^esup> B \<longleftrightarrow> (\<exists>f[M]. f \<in> bij(A,B))"
  using assms unfolding eqpoll_rel_def by auto

text\<open>Below, $\mu$ denotes the minimum operator on the ordinals.\<close>
lemma cardinalities_defs:
  fixes M::"i\<Rightarrow>o"
  shows
    "|A|\<^bsup>M\<^esup> \<equiv> \<mu> i. M(i) \<and> i \<approx>\<^bsup>M\<^esup> A"
    "Card\<^bsup>M\<^esup>(\<alpha>) \<equiv> \<alpha> = |\<alpha>|\<^bsup>M\<^esup>"
    "\<kappa>\<^bsup>\<up>\<nu>,M\<^esup> \<equiv> |\<nu> \<rightarrow>\<^bsup>M\<^esup> \<kappa>|\<^bsup>M\<^esup>"
    "(\<kappa>\<^sup>+)\<^bsup>M\<^esup> \<equiv> \<mu> x. M(x) \<and> Card\<^bsup>M\<^esup>(x) \<and> \<kappa> < x"
  unfolding cardinal_rel_def cexp_rel_def
    csucc_rel_def Card_rel_def .

context M_aleph
begin

text\<open>Analogous to the previous Lemma @{thm [source] eqpoll_def'}, we are now under
    the assumptions of the locale \<^term>\<open>M_aleph\<close>. The axiom instances
    included are sufficient to state and prove the defining
    properties of the relativized \<^term>\<open>Aleph\<close> function
    (in particular, the required ability to perform transfinite recursions).\<close>

thm Aleph_rel_zero Aleph_rel_succ Aleph_rel_limit
text\<open>@{thm [display] Aleph_rel_zero Aleph_rel_succ Aleph_rel_limit}\<close>
(*
  \<aleph>\<^bsub>0\<^esub>\<^bsup>M\<^esup> = \<omega>
  Ord(\<alpha>) \<Longrightarrow> M(\<alpha>) \<Longrightarrow> \<aleph>\<^bsub>succ(\<alpha>)\<^esub>\<^bsup>M\<^esup> = (\<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup>\<^sup>+)\<^bsup>M\<^esup>
  Limit(\<alpha>) \<Longrightarrow> M(\<alpha>) \<Longrightarrow> \<aleph>\<^bsub>\<alpha>\<^esub>\<^bsup>M\<^esup> = (\<Union>j\<in>\<alpha>. \<aleph>\<^bsub>j\<^esub>\<^bsup>M\<^esup>)
*)

end \<comment> \<open>\<^locale>\<open>M_aleph\<close>\<close>

lemma ContHyp_rel_def':
  fixes N::"i\<Rightarrow>o"
  shows
    "CH\<^bsup>N\<^esup> \<equiv> \<aleph>\<^bsub>1\<^esub>\<^bsup>N\<^esup> = 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^bsup>N\<^esup>,N\<^esup>"
  unfolding ContHyp_rel_def .

text\<open>Under appropriate hypotheses (this time, from the locale \<^term>\<open>M_ZF_library\<close>),
   \<^term>\<open>CH\<^bsup>M\<^esup>\<close> is equivalent to its fully relational version \<^term>\<open>is_ContHyp\<close>.
    As a sanity check, we see that if the transitive class is indeed \<^term>\<open>\<V>\<close>,
    we recover the original $\CH$.\<close>

thm M_ZF_library.is_ContHyp_iff is_ContHyp_iff_CH[unfolded ContHyp_def]
text\<open>@{thm [display] M_ZF_library.is_ContHyp_iff
    is_ContHyp_iff_CH[unfolded ContHyp_def]}\<close>
(*
  M_ZF_library(M) \<Longrightarrow> is_ContHyp(M) \<longleftrightarrow> CH\<^bsup>M\<^esup>
  is_ContHyp(\<V>) \<longleftrightarrow> \<aleph>\<^bsub>1\<^esub> = 2\<^bsup>\<up>\<aleph>\<^bsub>0\<^esub>\<^esup>
*)

text\<open>In turn, the fully relational version evaluated on a nonempty
    transitive \<^term>\<open>A\<close> is equivalent to the satisfaction of the
    first-order formula \<^term>\<open>\<cdot>CH\<cdot>\<close>.\<close>
thm is_ContHyp_iff_sats
text\<open>@{thm [display] is_ContHyp_iff_sats}\<close>
(*
  env \<in> list(A) \<Longrightarrow> 0 \<in> A \<Longrightarrow> is_ContHyp(##A) \<longleftrightarrow> A, env \<Turnstile> \<cdot>CH\<cdot>
*)

subsection\<open>Forcing \label{sec:def-main-forcing}\<close>

text\<open>Our first milestone was to obtain a proper extension using forcing.
Its original proof didn't required the previous developments involving
the relativization of material on cardinal arithmetic. Now it is
derived from a stronger result, namely @{thm [source] extensions_of_ctms}
below.\<close>

thm extensions_of_ctms_ZF
text\<open>@{thm [display] extensions_of_ctms_ZF}\<close>
(*
  M \<approx> \<omega> \<Longrightarrow>
  Transset(M) \<Longrightarrow>
  M \<Turnstile> ZF \<Longrightarrow>
  \<exists>N. M \<subseteq> N \<and> N \<approx> \<omega> \<and> Transset(N) \<and> N \<Turnstile> ZF \<and> M \<noteq> N \<and>
    (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N) \<and> ((M, [] \<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N \<Turnstile> ZFC)
*)

text\<open>We can finally state our main results, namely, the existence of models
for $\ZFC + \CH$ and $\ZFC + \neg\CH$ under the assumption of a ctm of $\ZFC$.\<close>

thm ctm_ZFC_imp_ctm_not_CH
text\<open>@{thm [display] ctm_ZFC_imp_ctm_not_CH}\<close>
(*
  M \<approx> \<omega> \<Longrightarrow>
  Transset(M) \<Longrightarrow>
  M \<Turnstile> ZFC \<Longrightarrow>
  \<exists>N. M \<subseteq> N \<and>
    N \<approx> \<omega> \<and> Transset(N) \<and> N \<Turnstile> ZFC \<union> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>} \<and>
    (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)
*)

thm ctm_ZFC_imp_ctm_CH
text\<open>@{thm [display] ctm_ZFC_imp_ctm_CH}\<close>
(*
  M \<approx> \<omega> \<Longrightarrow>
  Transset(M) \<Longrightarrow>
  M \<Turnstile> ZFC \<Longrightarrow>
  \<exists>N. M \<subseteq> N \<and>
      N \<approx> \<omega> \<and>
      Transset(N) \<and> N \<Turnstile> ZFC \<union> {\<cdot>CH\<cdot>} \<and> (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)
*)

text\<open>These results can be strengthened by enumerating six finite sets of
replacement instances which are sufficient to develop forcing and for
the construction of the aforementioned models: \<^term>\<open>instances1_fms\<close>
through \<^term>\<open>instances3_fms\<close>, \<^term>\<open>instances_ground_fms\<close>, and
\<^term>\<open>instances_ground_notCH_fms\<close>,
which are then collected into the $31$-element set \<^term>\<open>overhead_notCH\<close>.
For example, we have:\<close>

thm instances1_fms_def
text\<open>@{thm [display] instances1_fms_def}\<close>
(*
instances1_fms \<equiv>
{ eclose_closed_fm, eclose_abs_fm,
  wfrec_rank_fm, transrec_VFrom_fm }
*)

thm overhead_def overhead_notCH_def
text\<open>@{thm [display] overhead_def overhead_notCH_def overhead_CH_def}\<close>
(*
  overhead \<equiv> instances1_fms \<union> instances_ground_fms

  overhead_notCH \<equiv> overhead \<union>
    instances2_fms \<union> instances3_fms \<union> instances_ground_notCH_fms
*)

text\<open>One further instance is needed to force $\CH$, with a total count
of $32$ instances:\<close>
thm overhead_CH_def
text\<open>@{thm [display] overhead_CH_def}\<close>
(*
  overhead_CH \<equiv> overhead_notCH \<union> {dc_abs_fm}
*)

thm extensions_of_ctms
text\<open>@{thm [display] extensions_of_ctms}\<close>
(*
M \<approx> \<omega> \<Longrightarrow>
Transset(M) \<Longrightarrow>
M \<Turnstile> \<cdot>Z\<cdot> \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead} \<Longrightarrow>
\<Phi> \<subseteq> formula \<Longrightarrow>
M \<Turnstile> {\<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>} \<Longrightarrow>
\<exists>N. M \<subseteq> N \<and>
    N \<approx> \<omega> \<and>
    Transset(N) \<and>
    M \<noteq> N \<and>
    (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N) \<and>
    ((M, [] \<Turnstile> \<cdot>AC\<cdot>) \<longrightarrow> N, [] \<Turnstile> \<cdot>AC\<cdot>) \<and> N \<Turnstile> \<cdot>Z\<cdot> \<union> {\<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> \<Phi>}
*)

thm ctm_of_not_CH
text\<open>@{thm [display] ctm_of_not_CH}\<close>
(*
M \<approx> \<omega> \<Longrightarrow>
Transset(M) \<Longrightarrow>
M \<Turnstile> ZC \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead_notCH} \<Longrightarrow>
\<Phi> \<subseteq> formula \<Longrightarrow>
M \<Turnstile> {\<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>} \<Longrightarrow>
\<exists>N. M \<subseteq> N \<and>
    N \<approx> \<omega> \<and>
    Transset(N) \<and>
    N \<Turnstile> ZC \<union> {\<cdot>\<not>\<cdot>CH\<cdot>\<cdot>} \<union> {\<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> \<Phi>} \<and>
    (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)
*)

thm ctm_of_CH
text\<open>@{thm [display] ctm_of_CH}\<close>
(*
M \<approx> \<omega> \<Longrightarrow>
Transset(M) \<Longrightarrow>
M \<Turnstile> ZC \<union> {\<cdot>Replacement(p)\<cdot> . p \<in> overhead_CH} \<Longrightarrow>
\<Phi> \<subseteq> formula \<Longrightarrow>
M \<Turnstile> {\<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> . \<phi> \<in> \<Phi>} \<Longrightarrow>
\<exists>N. M \<subseteq> N \<and>
    N \<approx> \<omega> \<and>
    Transset(N) \<and>
    N \<Turnstile> ZC \<union> {\<cdot>CH\<cdot>} \<union> {\<cdot>Replacement(\<phi>)\<cdot> . \<phi> \<in> \<Phi>} \<and>
    (\<forall>\<alpha>. Ord(\<alpha>) \<longrightarrow> \<alpha> \<in> M \<longleftrightarrow> \<alpha> \<in> N)
*)

text\<open>In the above three statements, the function \<^term>\<open>ground_repl_fm\<close>
takes an element \<^term>\<open>\<phi>\<close> of \<^term>\<open>formula\<close> and returns the
replacement instance in the ground model that produces the
\<^term>\<open>\<phi>\<close>-replacement instance in the generic extension. The next
result is stated in the context \<^locale>\<open>G_generic1\<close>, which assumes
the existence of a generic filter.\<close>

context G_generic1
begin

thm sats_ground_repl_fm_imp_sats_ZF_replacement_fm
text\<open>@{thm [display] sats_ground_repl_fm_imp_sats_ZF_replacement_fm}\<close>
(*
  \<phi> \<in> formula \<Longrightarrow>
  M, [] \<Turnstile> \<cdot>Replacement(ground_repl_fm(\<phi>))\<cdot> \<Longrightarrow> M[G], [] \<Turnstile> \<cdot>Replacement(\<phi>)\<cdot>
*)

end \<comment> \<open>\<^locale>\<open>G_generic1\<close>\<close>

end


(*  Title:      MultiASP.thy
    Author:     Ludovic Henrio and Florian Kammuller
                2014

    Note:       Multi-active object formalisation
*)

header {* Syntax and Semantics *}

theory MultiASP imports Main begin

subsection{*Preliminaries*}

definition
  remove_from_map :: "('a ~=> 'b) => 'a  => ('a ~=> 'b)"  (infixl "|``"  110) where
  "m|``x = m|`(dom m - {x})"

subsection {* Syntax *}
type_synonym ItfName = string
datatype VarName = This | Id string
type_synonym ClassName = string
type_synonym MethodName = string

type_synonym ActName = nat
type_synonym FutName = nat
type_synonym Location = nat

datatype Signature = Method Interface MethodName "(Interface * VarName) list"
  (* signature = Method returnType MethodName (list of parameters)*)
and Interface = Itf ItfName "Signature list"
  (*interface = Itf Itfname (list of method signatures)*)

datatype Value = null | ASPInt nat | ASPBool bool (* static values *)
                | ActRef ActName (* runtime values *)
                | ObjRef Location
type_synonym  Object = "VarName~=>Value"

datatype Storable = Obj Object | FutRef FutName | StoredVal Value

datatype Expression = Val Value
             | Var VarName
             | Plus Expression Expression ("_+\<^sub>A_" [120,120] 200)
             | And Expression Expression ("_&\<^sub>A_" [100,100] 300)

datatype Rhs = Expr Expression
             | Call Expression MethodName "Expression list" ("_.\<^sub>A_(_)" [440,0,50] 500) (*e.m(e list) *)
             | New ClassName "Expression list" ("new _(_)" [300,0] 500) (*new C(e list) *)
             | NewActive ClassName "Expression list" ("newActive _(_)" [300,0] 500) (*newActive C(e list) *)
             | Hole (* runtime term *)

datatype Statement = Skip
|  Assign VarName Rhs  (infix "=\<^sub>A"  400) (*x=z*)
| Return Expression ("return _" [300] 300)(*return E *)
| If Expression Statement Statement ("IF _ THEN _ ELSE _ " [300,0,0] 300)(*if E then s else s *)
| Seq Statement Statement (infix ";;"  100)

primrec RedContext:: "Statement\<Rightarrow> Statement \<times>Statement" (* returns basic instruction,context , i.e. the rest of the sequence*)
where
  "RedContext Skip = (Skip,Skip)" |
  "RedContext (x=\<^sub>Az) =  ((x=\<^sub>Az),Skip)" |
  "RedContext (return e) =  (return e,Skip)" |
  "RedContext (IF e THEN s ELSE s') =  (IF e THEN s ELSE s',Skip)" |
  "RedContext ( s ;; s') =  (fst (RedContext s),(snd (RedContext s);;s'))"

abbreviation BuildContext::"Statement\<Rightarrow>Statement\<Rightarrow> Statement \<times>Statement" ("_[[_]]" [300, 0] 300)
where "BuildContext R s \<equiv> (s,R)"

datatype Method = Signature  "(Interface * VarName) list" Statement
(*signature (local variables) body*)

datatype Class = ASPclass ClassName "(Interface * VarName) list" "Interface list"
                                   "(Interface * VarName) list" "Method list"
             (*ASPClass name (class parameters) (implemented interfaces) (state variables) (list of method bodies) *)

datatype Program = Prog "Interface set" "Class set" "(Interface * VarName) list" Statement

type_synonym EContext = "(VarName~=>Value) * Statement" (*execution contet = local variables and statement *)
type_synonym Request = "FutName * MethodName * (Value list)"
type_synonym Store = "Location~=>Storable"

(*datatype Process = Proc Request "Context list" *)

datatype ActiveObject = AO Location Store "Request~=>(EContext list)" "Request list"
    (* active object location , store, task list, request queue*)

datatype FutValue = Undefined | FutVal Value  Store

datatype Configuration = Cn "ActName~=>ActiveObject" "FutName~=>FutValue"

subsection {*finite configuration *}

definition finite_Store :: "Store \<Rightarrow> bool"
  where
    "finite_Store \<sigma> \<equiv> (finite (dom \<sigma>) \<and> (\<forall> loc obj. (\<sigma>(loc)=Some (Obj obj)\<longrightarrow> finite (dom obj))))"

definition finite_Processes :: "(Request~=>(EContext list)) \<Rightarrow> bool"
  where
    "finite_Processes (processMap) \<equiv> finite (dom (processMap)) \<and>
       (\<forall> contList\<in>(ran(processMap)). \<forall>cont\<in> set contList. finite (dom(fst(cont))))"

primrec finite_Configuration :: "Configuration => bool"
  where
 " finite_Configuration (Cn AOs Futures) =
      (finite (dom AOs) \<and> finite (dom Futures) \<and>
    (\<forall> futVal\<in>(ran Futures). \<forall> v \<sigma>. (futVal =FutVal v \<sigma> \<longrightarrow> finite_Store \<sigma>)) \<and> (*NB: Undefined futures are finite*)
    (\<forall> ao\<in>(ran AOs). \<forall> l \<sigma> P Q. ao = AO l \<sigma> P Q \<longrightarrow> finite_Store \<sigma> \<and> finite_Processes P))"
declare MultiASP.finite_Configuration.simps[simp del]

subsection {* serialization and location renaming *}

inductive serialize :: "Value \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool"
(*serialize v \<sigma> \<sigma>' is true if the serialization of value v is a subset of \<sigma>' (using store \<sigma>)*)
  where
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (Obj obj) \<and> (\<forall> v\<in> ran(obj). \<exists>\<sigma>''. (serialize v \<sigma> \<sigma>''\<and> \<sigma>'' \<subseteq>\<^sub>m \<sigma>'))
     \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (FutRef f)  \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
    " \<sigma>'(l) = \<sigma>(l) \<and> \<sigma>(l) = Some (StoredVal v)  \<Longrightarrow> (serialize (ObjRef l) \<sigma> \<sigma>')" |
     "(serialize (ActRef f) \<sigma> \<sigma>')" |
     "serialize (null) \<sigma> \<sigma>' " |
     "serialize (ASPInt n) \<sigma> \<sigma>'" |
     "serialize (ASPBool b) \<sigma> \<sigma>'"

primrec subst_Value :: " Value \<Rightarrow> (Location\<Rightarrow>Location) \<Rightarrow> Value"
where
  "subst_Value (ObjRef l) \<psi> = ObjRef (\<psi>(l))" |
  "subst_Value (ActRef a) \<psi> = ActRef a" |
  "subst_Value (null) \<psi> = null" |
  "subst_Value (ASPInt i) \<psi> = ASPInt i" |
  "subst_Value (ASPBool b) \<psi> = ASPBool b"

definition check_subst :: "Store \<Rightarrow> (Location\<Rightarrow>Location) \<Rightarrow> Store \<Rightarrow> bool"
where
  "check_subst  \<sigma> \<psi> \<sigma>' \<equiv>
    ( inj \<psi> \<and> dom \<sigma>' =  \<psi> ` (dom(\<sigma>))
    \<and> (\<forall> obj l . (\<sigma>(l) = Some (Obj obj)
      \<longrightarrow> (\<exists> obj'. (\<sigma>'(\<psi>(l)) = Some (Obj obj') \<and> (\<forall> x  v. obj(x) = Some v \<longrightarrow> obj'(x)=Some (subst_Value v \<psi>)))))
    \<and>   (\<forall> f l . (\<sigma>(l) = Some (FutRef f) \<longrightarrow> \<sigma>'(\<psi>(l)) =Some (FutRef f)))
    \<and>   (\<forall> v l . (\<sigma>(l) = Some (StoredVal v) \<longrightarrow>
      \<sigma>'(\<psi>(l)) = Some (StoredVal (subst_Value v \<psi>))))))"

definition serialize_and_rename :: "Value \<Rightarrow> Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool"
 where "serialize_and_rename v \<sigma> v' \<sigma>'  \<equiv> (\<exists>\<psi> \<sigma>''. serialize  v \<sigma> \<sigma>'' \<and>check_subst \<sigma>'' \<psi> \<sigma>'\<and>v'=subst_Value v \<psi>)"

definition serialize_and_rename_list :: "Value list \<Rightarrow> Store \<Rightarrow> Value list \<Rightarrow> Store \<Rightarrow> bool"
 where "serialize_and_rename_list vl \<sigma> vl' \<sigma>'  \<equiv>
              (length vl=length vl' \<and>
              (\<exists>\<psi> \<sigma>''. (\<forall> i<length vl. serialize  (vl!i) \<sigma> \<sigma>''\<and>vl'!i=subst_Value (vl!i) \<psi>) \<and>check_subst \<sigma>'' \<psi> \<sigma>'))"

(*locale Generic_Functions = *)

(* semantics parameterized by compatibility and binder function*)
axiomatization
  Compatible :: "(Request * Request) set"
and
  Bind:: "Object\<Rightarrow>MethodName\<Rightarrow>Value list\<Rightarrow> EContext "
and
  fields:: "ClassName \<Rightarrow>VarName list"
and
  params:: "ClassName \<Rightarrow>VarName list"
where
  symmetric_compatible: "sym Compatible"

lemma COMP[rule_format]: "\<forall>x y. (x,y)\<in>Compatible\<longrightarrow>(y,x)\<in>Compatible"
apply (fold sym_def)
apply (rule symmetric_compatible)
done

section{*SOS*}

(*datatype EvaluatedExpr = Undefined | EVal Value | EObj Object | EFutRef FutName*)

inductive_set EvalValue:: "(Value \<times> Store \<times> Value) set"
where
  "(null, \<sigma>,  null)\<in>EvalValue" |
  "(ASPInt i, \<sigma>,  (ASPInt i) )\<in>EvalValue" |
  "(ASPBool b, \<sigma>,  (ASPBool b) )\<in>EvalValue" |
  "(ActRef \<alpha>, \<sigma>,  (ActRef \<alpha>) )\<in>EvalValue" |
  "\<sigma>(l) = Some (FutRef f) \<Longrightarrow>(ObjRef l, \<sigma>, ObjRef l)\<in>EvalValue" |
  "\<sigma>(l) = Some (Obj obj) \<Longrightarrow>(ObjRef l, \<sigma>, ObjRef l)\<in>EvalValue" |
  "\<lbrakk>\<sigma>(l) = Some (StoredVal v);(v,\<sigma>,ee)\<in> EvalValue\<rbrakk> \<Longrightarrow>(ObjRef l, \<sigma>, ee)\<in>EvalValue"

lemma EvalValue_is_deterministic[rule_format,intro]: "(e,\<sigma>,v)\<in>EvalValue \<longrightarrow>(e,\<sigma>,v')\<in>EvalValue \<longrightarrow>v=v'"
apply (rule impI)
apply (erule EvalValue.induct)
apply auto
apply (erule EvalValue.cases,simp+)+
done

inductive_set EvalExpr:: "(Expression \<times> (VarName~=>Value)\<times>Store \<times> Value) set"
 where
   "(v,\<sigma>,ev)\<in>EvalValue \<Longrightarrow>(Val v,  locs, \<sigma>, ev)\<in>EvalExpr" |
   "\<lbrakk>locs(x)=Some v;(v,\<sigma>,ev)\<in>EvalValue\<rbrakk> \<Longrightarrow>(Var x,  locs, \<sigma>, ev)\<in>EvalExpr" |
   "\<lbrakk>locs(x)=None;locs(This)=Some (ObjRef or); (\<sigma>(or))=Some (Obj ob);
     ob(x) = Some v;(v,\<sigma>,ev)\<in>EvalValue\<rbrakk>
                      \<Longrightarrow>(Var x,  locs, \<sigma>, ev)\<in>EvalExpr" |
   "\<lbrakk>(e,locs,\<sigma>,ASPInt i)\<in>EvalExpr;(e',locs,\<sigma>, ASPInt i')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e +\<^sub>A e',  locs, \<sigma>, ASPInt (i+i'))\<in>EvalExpr" |
   "\<lbrakk>(e,locs,\<sigma>,ASPBool b)\<in>EvalExpr;(e',locs,\<sigma>,ASPBool b')\<in>EvalExpr\<rbrakk>
                      \<Longrightarrow>(e &\<^sub>A e',  locs, \<sigma>, ASPBool (b\<and>b'))\<in>EvalExpr"

lemma EvalExpr_is_deterministic[rule_format,intro]:
      " (e,locs,\<sigma>,v)\<in>EvalExpr \<longrightarrow> (\<forall> v'. (e,locs,\<sigma>,v')\<in>EvalExpr \<longrightarrow>v=v')"
apply (rule impI)
apply (erule EvalExpr.induct)
apply auto
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e+\<^sub>Ae'"  in EvalExpr.cases,auto)
apply (erule_tac ?a1.0="e&\<^sub>Ae'"  in EvalExpr.cases,auto)
done

thm EvalExpr_is_deterministic

inductive reduction :: "[Configuration, Configuration] => bool"  (infixl "\<leadsto>" 50)
  where
    Serve [simp, intro!]:
      "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks (Rq@R#Rq')) ; R=(f,m,vl);
        \<forall> Q\<in>dom(Tasks). (R,Q)\<in>Compatible;\<forall> Q\<in>set Rq. (R,Q)\<in>Compatible;
         (\<sigma> l_\<alpha>) = Some (Obj obj);
        Bind obj m vl = (locs,s); locs'=locs(This\<mapsto>ObjRef l_\<alpha>);
        Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (Tasks(R\<mapsto>[(locs',s)])) (Rq@Rq')))\<rbrakk>
          \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

    AssignLocal  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL); RedContext S = R[[(x=\<^sub>AExpr e)]];
       x\<in>dom locs ; (e, locs, \<sigma>,v)\<in>EvalExpr;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (Tasks(Q\<mapsto>((locs(x\<mapsto>v),R)#TL))) Rq))
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

    AssignField  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL); RedContext S = R[[(x=\<^sub>AExpr e)]];
       x\<notin>dom locs ;locs(This) = Some (ObjRef l);\<sigma>(l) = Some (Obj obj);x\<in>dom(obj);  (e, locs, \<sigma>,v)\<in>EvalExpr;
       \<sigma>'=\<sigma>(l\<mapsto>Obj (obj(x\<mapsto>v)));
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma>' (Tasks(Q\<mapsto>((locs,R)#TL))) Rq))
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

     New  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL);RedContext S = R[[x=\<^sub>Anew C(el)]];
       fields(C)=field_list; params(C)=param_list; l\<notin>dom \<sigma>;
       length param_list = length el;length param_list = length value_list;
       \<forall> i<length value_list . (el!i,locs,\<sigma>,value_list!i)\<in>EvalExpr ;
       \<sigma>'=\<sigma>(l\<mapsto> Obj (  (map_of (zip field_list (replicate (length field_list) null)))
                    ++ (map_of (zip param_list value_list)) )) ;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma>' (Tasks(Q\<mapsto>((locs,(x=\<^sub>AExpr (Val (ObjRef l));;R))#TL))) Rq))
      \<rbrakk>
      (* new term to evaluate is artificially complex because obj ref has to be encapsulated in a value and an expression*)
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

     NewActive  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL); RedContext S = R[[x=\<^sub>AnewActive C(el)]];
       fields(C)=field_list; params(C)=param_list; \<gamma>\<notin>dom Activities;
       length param_list = length el;length param_list = length value_list;
       \<forall> i<length value_list . ((el!i,locs,\<sigma>,value_list!i)\<in>EvalExpr \<and> serialize (value_list!i) \<sigma> \<sigma>\<^sub>0) ;
       l\<notin>dom \<sigma>\<^sub>0;
       \<sigma>'=\<sigma>\<^sub>0(l\<mapsto> Obj (  (map_of (zip field_list (replicate (length field_list) null)))
                    ++ (map_of (zip param_list value_list)) )) ;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (Tasks(Q\<mapsto>((locs,(x=\<^sub>AExpr (Val (ActRef \<gamma>)));;R)#TL))) Rq))
                             (\<gamma>\<mapsto> (AO l \<sigma>' empty []))
       (* new term to evaluate is artificially complex because obj ref has to be encapsulated in a value and an expression*)
     \<rbrakk>
        \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

   InvkActive  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       (Activities \<beta>) = Some (AO l\<^sub>\<beta> \<sigma>\<^sub>\<beta> Tasks\<^sub>\<beta> Rq\<^sub>\<beta>);
       Tasks Q = Some ((locs,S)#TL);RedContext S = R[[x=\<^sub>A(e.\<^sub>Am(el))]];
       (e,locs,\<sigma>,ActRef \<beta>)\<in>EvalExpr;
       f\<notin>dom Futures;      l\<notin>dom \<sigma>;
       length value_list = length el;
       \<forall> i<length value_list . ((el!i,locs,\<sigma>,value_list!i)\<in>EvalExpr) ;
       serialize_and_rename_list value_list \<sigma> value_list' \<sigma>\<^sub>P; dom \<sigma>\<^sub>P\<inter>dom \<sigma>\<^sub>\<beta>={};
       \<sigma>'=\<sigma>\<^sub>\<beta> ++ \<sigma>\<^sub>P;
       Activities'=Activities(\<alpha>\<mapsto> AO l_\<alpha> (\<sigma>(l\<mapsto>FutRef f)) (Tasks(Q\<mapsto>((locs,x=\<^sub>AExpr (Val (ObjRef l));;R)#TL))) Rq)
                             (\<beta>\<mapsto> AO l\<^sub>\<beta> \<sigma>' Tasks\<^sub>\<beta> (Rq\<^sub>\<beta>@[(f,m,value_list')]) )
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' (Futures(f\<mapsto>Undefined))" |

   InvkPassive  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL); RedContext S = R[[x=\<^sub>Ae.\<^sub>Am(el)]];
       (e,locs,\<sigma>,ObjRef l)\<in>EvalExpr;
         (\<sigma> l) = Some (Obj obj);
       length vl = length el; \<forall> i<length vl . ((el!i,locs,\<sigma>,vl!i)\<in>EvalExpr) ;
        Bind obj m vl = (locs,s); locs'=locs(This\<mapsto>ObjRef l);
       Activities'=Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma> (Tasks(Q\<mapsto>((locs',s)#(locs,x=\<^sub>AHole;;R)#TL))) Rq)
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

   ReturnLocal  [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs',S)#(locs,x=\<^sub>AHole;;R)#TL); RedContext S = R[[return e]];
       (e,locs,\<sigma>,v)\<in>EvalExpr;
       Activities'=Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma>
                              (Tasks(Q\<mapsto>((locs,x=\<^sub>AExpr (Val v);;R)#TL))) Rq)
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures" |

   ReturnRequest [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some [(locs',S)]; RedContext S = R[[return e]];
       Q=(f,m,vl);
       (e,locs,\<sigma>,v)\<in>EvalExpr;  serialize v \<sigma> \<sigma>\<^sub>f;
       Activities'=Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma> (Tasks|``Q) Rq)
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' (Futures(f\<mapsto>FutVal v \<sigma>\<^sub>f))" |

    UpdateFuture [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       (\<sigma> l) = Some (FutRef f);  (Futures f) = Some (FutVal v \<sigma>\<^sub>f);
       check_subst \<sigma>\<^sub>f \<psi> \<sigma>\<^sub>r; v'=subst_Value v \<psi>; (dom \<sigma>\<^sub>r)\<inter>(dom \<sigma>)= {};
       \<sigma>'=(\<sigma>++\<sigma>\<^sub>r)(l\<mapsto>StoredVal v'); Activities'=Activities(\<alpha>\<mapsto> AO l_\<alpha> \<sigma>' Tasks Rq)
      \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures"   |

    IfThenElseTrue [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL);RedContext S = R[[IF e THEN s\<^sub>t ELSE s\<^sub>e]];
       (e,locs,\<sigma>,ASPBool True)\<in>EvalExpr;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (Tasks(Q\<mapsto>((locs,s\<^sub>t;;R)#TL))) Rq))
   \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures"  |
    IfThenElseFalse [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL);RedContext S = R[[IF e THEN s\<^sub>t ELSE s\<^sub>e]];
       (e,locs,\<sigma>,ASPBoolFalse)\<in>EvalExpr;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (Tasks(Q\<mapsto>((locs,s\<^sub>e;;R)#TL))) Rq))
   \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures"  |

    Skip [simp, intro!]:
     "\<lbrakk>(Activities \<alpha>) = Some (AO l_\<alpha> \<sigma> Tasks Rq);
       Tasks Q = Some ((locs,S)#TL);RedContext S = R[[Skip]];R\<noteq>Skip;
       Activities'=Activities(\<alpha>\<mapsto> (AO l_\<alpha> \<sigma> (Tasks(Q\<mapsto>((locs,R)#TL))) Rq))
   \<rbrakk>
      \<Longrightarrow> Cn Activities Futures \<leadsto>Cn Activities' Futures"

(*     upd  [simp, intro!]: "l : dom f \<Longrightarrow>\<leadsto>
                         Upd (Obj f T) l a \<rightarrow>\<^sub>\<beta>  Obj (f (l \<mapsto> a)) T" |
    sel  [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Call s l u \<rightarrow>\<^sub>\<beta>  Call t l u" |
    selR [simp, intro!]: "u \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Call s l u \<rightarrow>\<^sub>\<beta>  Call s l t" |
    updL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Upd s l u \<rightarrow>\<^sub>\<beta> Upd t l u" |
    updR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Upd u l s \<rightarrow>\<^sub>\<beta> Upd u l t" |
    obj [simp, intro!]: "\<lbrakk> s \<rightarrow>\<^sub>\<beta> t; l: dom f \<rbrakk> \<Longrightarrow> Obj (f (l \<mapsto> s)) T \<rightarrow>\<^sub>\<beta> Obj (f (l \<mapsto> t)) T" |
  act [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t \<Longrightarrow> Active s \<rightarrow>\<^sub>\<beta> Active t"
abbreviation
  beta_reds :: "[dB, dB] => bool"  (infixl "->>" 50) where
  "s ->> t == beta^** s t"

notation (latex)
  beta_reds  (infixl "\<rightarrow>\<^sub>\<beta>\<^sup>*" 50)
*)

abbreviation InitialConfiguration:: "(VarName list) \<Rightarrow>Statement \<Rightarrow> Configuration"
where
  "InitialConfiguration vl s \<equiv> Cn (empty(0\<mapsto>(AO 0 (empty(0\<mapsto>Obj empty))
                  (empty((0,''m'',[])\<mapsto>[((map_of (zip vl (replicate (length vl) null))),s)])) []))) empty"

inductive Comp2 :: "(Request * Request) \<Rightarrow>bool"
 where
  symmetric_compatible: " Comp2 (x,y) \<Longrightarrow>Comp2 (y,x) "

end


(*  Title:      HOL/UNITY/Comp/TimerArray.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

A trivial example of reasoning about an array of processes
*)

theory TimerArray imports "../UNITY_Main" begin

type_synonym 'a state = "nat * 'a"   (*second component allows new variables*)

definition count :: "'a state => nat"
  where "count s = fst s"

definition decr  :: "('a state * 'a state) set"
  where "decr = (UN n uu. {((Suc n, uu), (n,uu))})"

definition Timer :: "'a state program"
  where "Timer = mk_total_program (UNIV, {decr}, UNIV)"

declare Timer_def [THEN def_prg_Init, simp]

declare count_def [simp] decr_def [simp]

(*Demonstrates induction, but not used in the following proof*)
lemma Timer_leadsTo_zero: "Timer \<in> UNIV leadsTo {s. count s = 0}"
apply (rule_tac f = count in lessThan_induct, simp)
apply (case_tac "m")
 apply (force intro!: subset_imp_leadsTo)
apply (unfold Timer_def, ensures_tac "decr")
done

lemma Timer_preserves_snd [iff]: "Timer \<in> preserves snd"
apply (rule preservesI)
apply (unfold Timer_def, safety)
done

declare PLam_stable [simp]

lemma TimerArray_leadsTo_zero:
     "finite I
      \<Longrightarrow> (plam i: I. Timer) \<in> UNIV leadsTo {(s,uu). \<forall>i\<in>I. s i = 0}"
apply (erule_tac A'1 = "\<lambda>i. lift_set i ({0} \<times> UNIV)"
       in finite_stable_completion [THEN leadsTo_weaken])
apply auto
(*Safety property, already reduced to the single Timer case*)
 prefer 2
 apply (simp add: Timer_def, safety)
(*Progress property for the array of Timers*)
apply (rule_tac f = "sub i o fst" in lessThan_induct)
apply (case_tac "m")
(*Annoying need to massage the conditions to have the form (... \<times> UNIV)*)
apply (auto intro: subset_imp_leadsTo
        simp add: insert_absorb
                  lift_set_Un_distrib [symmetric] lessThan_Suc [symmetric]
               Times_Un_distrib1 [symmetric] Times_Diff_distrib1 [symmetric])
apply (rename_tac "n")
apply (rule PLam_leadsTo_Basis)
apply (auto simp add: lessThan_Suc [symmetric])
apply (unfold Timer_def mk_total_program_def, safety)
apply (rule_tac act = decr in totalize_transientI, auto)
done

end


(*  Title:       ONode_Lifting.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

section "Lifting rules for (open) nodes"

theory ONode_Lifting
imports AWN OAWN_SOS OInvariants
begin

lemma node_net_state':
  assumes "s \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
    shows "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)"
  using assms proof induction
    fix s
    assume "s \<in> init (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
    then obtain \<sigma> \<zeta> where "s = (\<sigma>, NodeS i \<zeta> R\<^sub>i)"
      by (auto simp: onode_comps)
    thus "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)" by auto
  next
    fix s a \<sigma>'
    assume rt: "s \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and ih: "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)"
       and "U (fst s) \<sigma>'"
    then obtain \<sigma> \<zeta> R
      where "(\<sigma>, NodeS i \<zeta> R)  \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
        and "U \<sigma> \<sigma>'" and "snd s = NodeS i \<zeta> R" by auto
    from this(1-2)
      have "(\<sigma>', NodeS i \<zeta> R) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
        by - (erule(1) oreachable_other')
    with \<open>snd s = NodeS i \<zeta> R\<close> show "\<exists>\<sigma> \<zeta> R. (\<sigma>', snd s) = (\<sigma>, NodeS i \<zeta> R)" by simp
  next
    fix s a s'
    assume rt: "s \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and ih: "\<exists>\<sigma> \<zeta> R. s = (\<sigma>, NodeS i \<zeta> R)"
       and tr: "(s, a, s') \<in> trans (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "S (fst s) (fst s') a"
     from ih obtain \<sigma> \<zeta> R where "s = (\<sigma>, NodeS i \<zeta> R)" by auto
     with tr have "((\<sigma>, NodeS i \<zeta> R), a, s') \<in> onode_sos (trans T)"
       by (simp add: onode_comps)
     then obtain \<sigma>' \<zeta>' R' where "s' = (\<sigma>', NodeS i \<zeta>' R')"
       using onode_sos_dest_is_net_state' by metis
     with tr \<open>s = (\<sigma>, NodeS i \<zeta> R)\<close> show "\<exists>\<sigma> \<zeta> R. s' = (\<sigma>, NodeS i \<zeta> R)"
       by simp
  qed

lemma node_net_state:
  assumes "(\<sigma>, s) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) S U"
    shows "\<exists>\<zeta> R. s = NodeS i \<zeta> R"
  using assms
  by (metis Pair_inject node_net_state')

lemma node_net_state_trans [elim]:
  assumes sor: "(\<sigma>, s) \<in> oreachable (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o) S U"
      and str: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o)"
  obtains \<zeta> R \<zeta>' R'
    where "s = NodeS i \<zeta> R"
      and "s' = NodeS i \<zeta>' R'"
  proof -
    assume *: "\<And>\<zeta> R \<zeta>' R'. s = NodeS i \<zeta> R \<Longrightarrow> s' = NodeS i \<zeta>' R' \<Longrightarrow> thesis"
    from sor obtain \<zeta> R where "s = NodeS i \<zeta> R"
      by (metis node_net_state)
    moreover with str obtain \<zeta>' R' where "s' = NodeS i \<zeta>' R'"
      by (simp only: onode_comps)
         (metis onode_sos_dest_is_net_state'')
    ultimately show thesis by (rule *)
  qed

lemma nodemap_induct' [consumes, case_names init other local]:
  assumes "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      and init: "\<And>\<sigma> \<zeta>. (\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) \<Longrightarrow> P (\<sigma>, NodeS ii \<zeta> R\<^sub>i)"
      and other: "\<And>\<sigma> \<zeta> R \<sigma>' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    U \<sigma> \<sigma>'; P (\<sigma>, NodeS ii \<zeta> R) \<rbrakk> \<Longrightarrow> P (\<sigma>', NodeS ii \<zeta> R)"
      and local: "\<And>\<sigma> \<zeta> R \<sigma>' \<zeta>' R' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    ((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o);
                    S \<sigma> \<sigma>' a; P (\<sigma>, NodeS ii \<zeta> R) \<rbrakk> \<Longrightarrow> P (\<sigma>', NodeS ii \<zeta>' R')"
    shows "P (\<sigma>, NodeS ii \<zeta> R)"
  using assms(1) proof induction
    fix s
    assume "s \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
    hence "s \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by (rule oreachable_init)
    with \<open>s \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)\<close> obtain \<sigma> \<zeta> where "s = (\<sigma>, NodeS ii \<zeta> R\<^sub>i)"
      by (simp add: onode_comps) metis
    with \<open>s \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)\<close> and init show "P s" by simp
  next
    fix s a \<sigma>'
    assume sr: "s \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and "U (fst s) \<sigma>'"
       and "P s"
    from sr obtain \<sigma> \<zeta> R where "s = (\<sigma>, NodeS ii \<zeta> R)"
      using node_net_state' by metis
    with sr \<open>U (fst s) \<sigma>'\<close> \<open>P s\<close> show "P (\<sigma>', snd s)"
    by simp (metis other)
  next
    fix s a s'
    assume sr: "s \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and tr: "(s, a, s') \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "S (fst s) (fst s') a"
       and "P s"
    from this(1-3) have "s' \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by - (erule(2) oreachable_local)
    then obtain \<sigma>' \<zeta>' R' where [simp]: "s' = (\<sigma>', NodeS ii \<zeta>' R')"
      using node_net_state' by metis
    from sr and \<open>P s\<close> obtain \<sigma> \<zeta> R
      where [simp]: "s = (\<sigma>, NodeS ii \<zeta> R)"
        and A1: "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
        and A4: "P (\<sigma>, NodeS ii \<zeta> R)"
      using node_net_state' by metis
    with tr and \<open>S (fst s) (fst s') a\<close>
      have A2: "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
       and A3: "S \<sigma> \<sigma>' a" by simp_all
    from A1 A2 A3 A4 have "P (\<sigma>', NodeS ii \<zeta>' R')" by (rule local)
    thus "P s'" by simp
  qed

lemma nodemap_induct [consumes, case_names init step]:
  assumes "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      and init: "\<And>\<sigma> \<zeta>. (\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) \<Longrightarrow> P \<sigma> \<zeta> R\<^sub>i"
      and other: "\<And>\<sigma> \<zeta> R \<sigma>' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    U \<sigma> \<sigma>'; P \<sigma> \<zeta> R \<rbrakk> \<Longrightarrow> P \<sigma>' \<zeta> R"
      and local: "\<And>\<sigma> \<zeta> R \<sigma>' \<zeta>' R' a.
                  \<lbrakk> (\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U;
                    ((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o);
                    S \<sigma> \<sigma>' a; P \<sigma> \<zeta> R \<rbrakk> \<Longrightarrow> P \<sigma>' \<zeta>' R'"
    shows "P \<sigma> \<zeta> R"
  using assms(1) proof (induction "(\<sigma>, NodeS ii \<zeta> R)" arbitrary: \<sigma> \<zeta> R)
    fix \<sigma> \<zeta> R
    assume a1: "(\<sigma>, NodeS ii \<zeta> R) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
    hence "R = R\<^sub>i" by (simp add: init_onode_comp)
    with a1 have "(\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)" by simp
    with init and \<open>R = R\<^sub>i\<close> show "P \<sigma> \<zeta> R" by simp
  next
    fix st a \<sigma>' \<zeta>' R'
    assume "st \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and tr: "(st, a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "S (fst st) (fst (\<sigma>', NodeS ii \<zeta>' R')) a"
       and IH: "\<And>\<sigma> \<zeta> R. st = (\<sigma>, NodeS ii \<zeta> R) \<Longrightarrow> P \<sigma> \<zeta> R"
    from this(1) obtain \<sigma> \<zeta> R where "st = (\<sigma>, NodeS ii \<zeta> R)"
                                and "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by (metis node_net_state')
    note this(2)
    moreover from tr and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close>
      have "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)" by simp
    moreover from \<open>S (fst st) (fst (\<sigma>', NodeS ii \<zeta>' R')) a\<close> and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close>
      have "S \<sigma> \<sigma>' a" by simp
    moreover from IH and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close> have "P \<sigma> \<zeta> R" .
    ultimately show "P \<sigma>' \<zeta>' R'" by (rule local)
  next
    fix st \<sigma>' \<zeta> R
    assume "st \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
       and "U (fst st) \<sigma>'"
       and "snd st = NodeS ii \<zeta> R"
       and IH: "\<And>\<sigma> \<zeta> R. st = (\<sigma>, NodeS ii \<zeta> R) \<Longrightarrow> P \<sigma> \<zeta> R"
    from this(1,3) obtain \<sigma> where "st = (\<sigma>, NodeS ii \<zeta> R)"
                              and "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
      by (metis surjective_pairing)
    note this(2)
    moreover from \<open>U (fst st) \<sigma>'\<close> and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close> have "U \<sigma> \<sigma>'" by simp
    moreover from IH and \<open>st = (\<sigma>, NodeS ii \<zeta> R)\<close> have "P \<sigma> \<zeta> R" .
    ultimately show "P \<sigma>' \<zeta> R" by (rule other)
  qed

lemma node_addressD [dest, simp]:
  assumes "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) S U"
    shows "i = ii"
  using assms by (clarsimp dest!: node_net_state')

lemma node_proc_reachable [dest]:
  assumes "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                         (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      and sgivesu: "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
  proof -
    from assms(1) have "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                             (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      by - (frule node_addressD, simp)
    thus ?thesis
    proof (induction rule: nodemap_induct)
      fix \<sigma> \<zeta>
      assume "(\<sigma>, NodeS ii \<zeta> R\<^sub>i) \<in> init (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
      hence "(\<sigma>, \<zeta>) \<in> init T" by (auto simp: onode_comps)
      thus "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
        by (rule oreachable_init)
    next
      fix \<sigma> \<zeta> R \<sigma>' \<zeta>' R' a
      assume "other U {ii} \<sigma> \<sigma>'"
         and "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      thus "(\<sigma>', \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
        by - (rule oreachable_other')
    next
      fix \<sigma> \<zeta> R \<sigma>' \<zeta>' R' a
      assume rs: "(\<sigma>, NodeS ii \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                         (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
         and tr: "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> trans (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)"
         and ow: "otherwith S {ii} (oarrivemsg I) \<sigma> \<sigma>' a"
         and ih: "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"

      from ow have *: "\<sigma>' ii = \<sigma> ii \<Longrightarrow> other U {ii} \<sigma> \<sigma>'"
        by (clarsimp elim!: otherwithE) (rule otherI, simp_all, metis sgivesu)
      from tr have "((\<sigma>, NodeS ii \<zeta> R), a, (\<sigma>', NodeS ii \<zeta>' R')) \<in> onode_sos (trans T)"
        by (simp add: onode_comps)
      thus "(\<sigma>', \<zeta>') \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      proof cases
        case onode_bcast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_gcast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_ucast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_notucast
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_deliver
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_tau
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case onode_receive
        with ih and ow show ?thesis
          by (auto elim!: oreachable_local' otherwithE)
      next
        case (onode_arrive m)
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_connect1
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_connect2
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_connect_other
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_disconnect1
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_disconnect2
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      next
        case onode_disconnect_other
        hence "\<zeta>' = \<zeta>" and "\<sigma>' ii = \<sigma> ii" by auto
        from this(2) have "other U {ii} \<sigma> \<sigma>'" by (rule *)
        with ih and \<open>\<zeta>' = \<zeta>\<close> show ?thesis by auto
      qed
    qed
  qed

lemma node_proc_reachable_statelessassm [dest]:
  assumes "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                         (otherwith (\<lambda>_ _. True) {ii} (oarrivemsg I))
                                         (other (\<lambda>_ _. True) {ii})"
    shows "(\<sigma>, \<zeta>) \<in> oreachable T
                               (otherwith (\<lambda>_ _. True) {ii} (orecvmsg I)) (other (\<lambda>_ _. True) {ii})"
  using assms
  by (rule node_proc_reachable) simp_all

lemma node_lift:
  assumes "T \<Turnstile> (otherwith S {ii} (orecvmsg I), other U {ii} \<rightarrow>) global P"
      and "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile> (otherwith S {ii} (oarrivemsg I), other U {ii} \<rightarrow>) global P"
  proof (rule oinvariant_oreachableI)
    fix \<sigma> \<zeta>
    assume "(\<sigma>, \<zeta>) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o) (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
    moreover then obtain i s R where "\<zeta> = NodeS i s R"
      by (metis node_net_state)
    ultimately have "(\<sigma>, NodeS i s R) \<in> oreachable (\<langle>ii : T : R\<^sub>i\<rangle>\<^sub>o)
                                                   (otherwith S {ii} (oarrivemsg I)) (other U {ii})"
      by simp
    hence "(\<sigma>, s) \<in> oreachable T (otherwith S {ii} (orecvmsg I)) (other U {ii})"
      by - (erule node_proc_reachable, erule assms(2))
    with assms(1) show "global P (\<sigma>, \<zeta>)"
      by (metis fst_conv globalsimp oinvariantD)
  qed

lemma node_lift_step [intro]:
  assumes pinv: "T \<Turnstile>\<^sub>A (otherwith S {i} (orecvmsg I), other U {i} \<rightarrow>) globala (\<lambda>(\<sigma>, _, \<sigma>'). Q \<sigma> \<sigma>')"
      and other: "\<And>\<sigma> \<sigma>'. other U {i} \<sigma> \<sigma>' \<Longrightarrow> Q \<sigma> \<sigma>'"
      and sgivesu: "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith S {i} (oarrivemsg I), other U {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). Q \<sigma> \<sigma>')"
    (is "_ \<Turnstile>\<^sub>A (?S, ?U \<rightarrow>) _")
  proof (rule ostep_invariantI, simp)
    fix \<sigma> s a \<sigma>' s'
    assume rs: "(\<sigma>, s) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
       and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
       and ow: "?S \<sigma> \<sigma>' a"
    from ow have *: "\<sigma>' i = \<sigma> i \<Longrightarrow> other U {i} \<sigma> \<sigma>'"
      by (clarsimp elim!: otherwithE) (rule otherI, simp_all, metis sgivesu)
    from rs tr obtain \<zeta> R
      where [simp]: "s = NodeS i \<zeta> R"
        and "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
      by (metis node_net_state)
    from this(2) have or: "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {i} (orecvmsg I)) ?U"
      by (rule node_proc_reachable [OF _ assms(3)])
    from tr have "((\<sigma>, NodeS i \<zeta> R), a, (\<sigma>', s')) \<in> onode_sos (trans T)"
      by (simp add: onode_comps)
    thus "Q \<sigma> \<sigma>'"
    proof cases
      fix m \<zeta>'
      assume "a = R:*cast(m)"
         and tr': "((\<sigma>, \<zeta>), broadcast m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (broadcast m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix D m \<zeta>'
      assume "a = (R \<inter> D):*cast(m)"
         and tr': "((\<sigma>, \<zeta>), groupcast D m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (groupcast D m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d m \<zeta>'
      assume "a = {d}:*cast(m)"
         and tr': "((\<sigma>, \<zeta>), unicast d m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (unicast d m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d \<zeta>'
      assume "a = \<tau>"
         and tr': "((\<sigma>, \<zeta>), \<not>unicast d, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (\<not>unicast d)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix d \<zeta>'
      assume "a = i:deliver(d)"
         and tr': "((\<sigma>, \<zeta>), deliver d, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (deliver d)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix \<zeta>'
      assume "a = \<tau>"
         and tr': "((\<sigma>, \<zeta>), \<tau>, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' \<tau>"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix m \<zeta>'
      assume "a = {i}\<not>{}:arrive(m)"
         and tr': "((\<sigma>, \<zeta>), receive m, (\<sigma>', \<zeta>')) \<in> trans T"
      from this(1) and \<open>?S \<sigma> \<sigma>' a\<close> have "otherwith S {i} (orecvmsg I) \<sigma> \<sigma>' (receive m)"
        by (auto elim!: otherwithE)
      with or tr' show ?thesis by (rule ostep_invariantD [OF pinv, simplified])
    next
      fix m
      assume "a = {}\<not>{i}:arrive(m)"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = connect(i, i')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = connect(i', i)"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i' i''
      assume "a = connect(i', i'')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = disconnect(i, i')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i'
      assume "a = disconnect(i', i)"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    next
      fix i' i''
      assume "a = disconnect(i', i'')"
         and "\<sigma>' i = \<sigma> i"
      from this(2) have "other U {i} \<sigma> \<sigma>'" by (rule *)
      thus ?thesis by (rule other)
    qed
  qed

lemma node_lift_step_statelessassm [intro]:
  assumes "T \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
      and "\<And>\<xi>. Q \<xi> \<xi>"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
  proof -
    from assms(1)
      have "T \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (orecvmsg I), other (\<lambda>_ _. True) {i} \<rightarrow>)
                  globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
        by rule auto
    with assms(2) have "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (oarrivemsg I),
                                          other (\<lambda>_ _. True) {i} \<rightarrow>)
                                         globala (\<lambda>(\<sigma>, _, \<sigma>'). Q (\<sigma> i) (\<sigma>' i))"
      by - (rule node_lift_step, auto)
    thus ?thesis by rule auto
  qed

lemma node_lift_anycast [intro]:
  assumes pinv: "T \<Turnstile>\<^sub>A (otherwith S {i} (orecvmsg I), other U {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (Q \<sigma> \<sigma>') a)"
      and "\<And>\<xi> \<xi>'. S \<xi> \<xi>' \<Longrightarrow> U \<xi> \<xi>'"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith S {i} (oarrivemsg I), other U {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (Q \<sigma> \<sigma>') a)"
    (is "_ \<Turnstile>\<^sub>A (?S, ?U \<rightarrow>) _")
  proof (rule ostep_invariantI, simp)
    fix \<sigma> s a \<sigma>' s'
    assume rs: "(\<sigma>, s) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
       and tr: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o)"
       and "?S \<sigma> \<sigma>' a"
    from this(1-2) obtain \<zeta> R
      where [simp]: "s = NodeS i \<zeta> R"
        and "(\<sigma>, NodeS i \<zeta> R) \<in> oreachable (\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o) ?S ?U"
      by (metis node_net_state)
    from this(2) have "(\<sigma>, \<zeta>) \<in> oreachable T (otherwith S {i} (orecvmsg I)) ?U"
      by (rule node_proc_reachable [OF _ assms(2)])
    moreover from tr have "((\<sigma>, NodeS i \<zeta> R), a, (\<sigma>', s')) \<in> onode_sos (trans T)"
      by (simp add: onode_comps)
    ultimately show "castmsg (Q \<sigma> \<sigma>') a" using \<open>?S \<sigma> \<sigma>' a\<close>
      by - (erule onode_sos.cases, auto elim!: otherwithE dest!: ostep_invariantD [OF pinv])
  qed

lemma node_lift_anycast_statelessassm [intro]:
  assumes pinv: "T \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. orecvmsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                       globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (Q \<sigma> \<sigma>') a)"
    shows "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (\<lambda>\<sigma> _. oarrivemsg I \<sigma>, other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (Q \<sigma> \<sigma>') a)"
    (is "_ \<Turnstile>\<^sub>A (?S, _ \<rightarrow>) _")
  proof -
    from assms(1)
      have "T \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (orecvmsg I), other (\<lambda>_ _. True) {i} \<rightarrow>)
                  globala (\<lambda>(\<sigma>, a, \<sigma>'). anycast (Q \<sigma> \<sigma>') a)"
        by rule auto
    hence "\<langle>i : T : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (otherwith (\<lambda>_ _. True) {i} (oarrivemsg I), other (\<lambda>_ _. True) {i} \<rightarrow>)
                            globala (\<lambda>(\<sigma>, a, \<sigma>'). castmsg (Q \<sigma> \<sigma>') a)"
      by (rule node_lift_anycast) simp_all
    thus ?thesis
      by rule auto
  qed

lemma node_local_deliver:
  "\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (S, U \<rightarrow>) globala (\<lambda>(_, a, _). \<forall>j. j\<noteq>i \<longrightarrow> (\<forall>d. a \<noteq> j:deliver(d)))"
  proof (rule ostep_invariantI, simp)
    fix \<sigma> s a \<sigma>' s'
    assume 1: "(\<sigma>, s) \<in> oreachable (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o) S U"
       and 2: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o)"
       and "S \<sigma> \<sigma>' a"
    moreover from 1 2 obtain \<zeta> R \<zeta>' R' where "s = NodeS i \<zeta> R" and "s' = NodeS i \<zeta>' R'" ..
    ultimately show "\<forall>j. j\<noteq>i \<longrightarrow> (\<forall>d. a \<noteq> j:deliver(d))"
      by (cases a) (auto simp add: onode_comps)
  qed

lemma node_tau_deliver_unchanged:
  "\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o \<Turnstile>\<^sub>A (S, U \<rightarrow>) globala (\<lambda>(\<sigma>, a, \<sigma>'). a = \<tau> \<or> (\<exists>i d. a = i:deliver(d))
                                                     \<longrightarrow> (\<forall>j. j\<noteq>i \<longrightarrow> \<sigma>' j = \<sigma> j))"
  proof (rule ostep_invariantI, clarsimp simp only: globalasimp snd_conv fst_conv)
    fix \<sigma> s a \<sigma>' s' j
    assume 1: "(\<sigma>, s) \<in> oreachable (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o) S U"
       and 2: "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (\<langle>i : \<zeta>\<^sub>i : R\<^sub>i\<rangle>\<^sub>o)"
       and "S \<sigma> \<sigma>' a"
       and "a = \<tau> \<or> (\<exists>i d. a = i:deliver(d))"
       and "j \<noteq> i"
    moreover from 1 2 obtain \<zeta> R \<zeta>' R' where "s = NodeS i \<zeta> R" and "s' = NodeS i \<zeta>' R'" ..
    ultimately show "\<sigma>' j = \<sigma> j"
      by (cases a) (auto simp del: step_node_tau simp add: onode_comps)
  qed

end


(*  Title:      JinjaThreads/JVM/JVMExceptions.thy
    Author:     Gerwin Klein, Martin Strecker, Andreas Lochbihler
*)

header {* \isaheader{Exception handling in the JVM} *}

theory JVMExceptions
imports
  JVMInstructions
begin

abbreviation Any :: "cname option"
where "Any \<equiv> None"

definition matches_ex_entry :: "'m prog \<Rightarrow> cname \<Rightarrow> pc \<Rightarrow> ex_entry \<Rightarrow> bool"
where
 "matches_ex_entry P C pc xcp \<equiv>
                 let (s, e, C', h, d) = xcp in
                 s \<le> pc \<and> pc < e \<and> (case C' of None \<Rightarrow> True | \<lfloor>C''\<rfloor> \<Rightarrow> P \<turnstile> C \<preceq>\<^sup>* C'')"

primrec
  match_ex_table :: "'m prog \<Rightarrow> cname \<Rightarrow> pc \<Rightarrow> ex_table \<Rightarrow> (pc \<times> nat) option"
where
  "match_ex_table P C pc []     = None"
| "match_ex_table P C pc (e#es) = (if matches_ex_entry P C pc e
                                   then Some (snd(snd(snd e)))
                                   else match_ex_table P C pc es)"

abbreviation ex_table_of :: "'addr jvm_prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ex_table"
where "ex_table_of P C M == snd (snd (snd (the (snd (snd (snd(method P C M)))))))"

lemma match_ex_table_SomeD:
  "match_ex_table P C pc xt = Some (pc',d') \<Longrightarrow>
  \<exists>(f,t,D,h,d) \<in> set xt. matches_ex_entry P C pc (f,t,D,h,d) \<and> h = pc' \<and> d=d'"
  by (induct xt) (auto split: split_if_asm)

end


section \<open>Priority Search Trees on top of RBTs\<close>

theory PST_RBT
imports
  "HOL-Data_Structures.Cmp"
  "HOL-Data_Structures.Isin2"
  "HOL-Data_Structures.Lookup2"
  PST_General
begin

text \<open>
We obtain a priority search map based on red-black trees via the
general priority search tree augmentation.

This theory has been derived from the standard Isabelle implementation of red
black trees in @{session "HOL-Data_Structures"}.
\<close>

subsection \<open>Definitions\<close>

subsubsection \<open>The Code\<close>

datatype tcolor = Red | Black

type_synonym ('k,'p) rbth = "(('k\<times>'p) \<times> (tcolor \<times> ('k \<times> 'p))) tree"

abbreviation R where "R mkp l a r \<equiv> Node l (a, Red,mkp) r"
abbreviation B where "B mkp l a r \<equiv> Node l (a, Black,mkp) r"

abbreviation "mkR \<equiv> mkNode Red"
abbreviation "mkB \<equiv> mkNode Black"

fun baliL :: "('k,'p::linorder) rbth \<Rightarrow> 'k\<times>'p \<Rightarrow> ('k,'p) rbth \<Rightarrow> ('k,'p) rbth"
  where
  "baliL (R _ (R _ t1 a1 t2) a2 t3) a3 t4 = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)"
| "baliL (R _ t1 a1 (R _ t2 a2 t3)) a3 t4 = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)"
| "baliL t1 a t2 = mkB t1 a t2"

fun baliR :: "('k,'p::linorder) rbth \<Rightarrow> 'k\<times>'p \<Rightarrow> ('k,'p) rbth \<Rightarrow> ('k,'p) rbth"
  where
"baliR t1 a1 (R _ (R _ t2 a2 t3) a3 t4) = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)" |
"baliR t1 a1 (R _ t2 a2 (R _ t3 a3 t4)) = mkR (mkB t1 a1 t2) a2 (mkB t3 a3 t4)" |
"baliR t1 a t2 = mkB t1 a t2"

fun paint :: "tcolor \<Rightarrow> ('k,'p::linorder) rbth \<Rightarrow> ('k,'p::linorder) rbth" where
"paint c Leaf = Leaf" |
"paint c (Node l (a, (_,mkp)) r) = Node l (a, (c,mkp)) r"

fun baldL :: "('k,'p::linorder) rbth \<Rightarrow> 'k \<times> 'p \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"baldL (R _ t1 x t2) y t3 = mkR (mkB t1 x t2) y t3" |
"baldL bl x (B _ t1 y t2) = baliR bl x (mkR t1 y t2)" |
"baldL bl x (R _ (B _ t1 y t2) z t3)
  = mkR (mkB bl x t1) y (baliR t2 z (paint Red t3))" |
"baldL t1 x t2 = mkR t1 x t2"

fun baldR :: "('k,'p::linorder) rbth \<Rightarrow> 'k \<times> 'p \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"baldR t1 x (R _ t2 y t3) = mkR t1 x (mkB t2 y t3)" |
"baldR (B _ t1 x t2) y t3 = baliL (mkR t1 x t2) y t3" |
"baldR (R _ t1 x (B _ t2 y t3)) z t4
  = mkR (baliL (paint Red t1) x t2) y (mkB t3 z t4)" |
"baldR t1 x t2 = mkR t1 x t2"

fun combine :: "('k,'p::linorder) rbth \<Rightarrow> ('k,'p::linorder) rbth
    \<Rightarrow> ('k,'p::linorder) rbth"
where
"combine Leaf t = t" |
"combine t Leaf = t" |
"combine (R _ t1 a t2) (R _ t3 c t4) =
  (case combine t2 t3 of
     R _ u2 b u3 \<Rightarrow> (mkR (mkR t1 a u2) b (mkR u3 c t4)) |
     t23 \<Rightarrow> mkR t1 a (mkR t23 c t4))" |
"combine (B _ t1 a t2) (B _ t3 c t4) =
  (case combine t2 t3 of
     R _ t2' b t3' \<Rightarrow> mkR (mkB t1 a t2') b (mkB t3' c t4) |
     t23 \<Rightarrow> baldL t1 a (mkB t23 c t4))" |
"combine t1 (R _ t2 a t3) = mkR (combine t1 t2) a t3" |
"combine (R _ t1 a t2) t3 = mkR t1 a (combine t2 t3)"

fun color :: "('k,'p) rbth \<Rightarrow> tcolor" where
"color Leaf = Black" |
"color (Node _ (_, (c,_)) _) = c"

fun upd :: "'a::linorder \<Rightarrow> 'b::linorder \<Rightarrow> ('a,'b) rbth \<Rightarrow> ('a,'b) rbth" where
"upd x y Leaf = mkR Leaf (x,y) Leaf" |
"upd x y (B _ l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> baliL (upd x y l) (a,b) r |
  GT \<Rightarrow> baliR l (a,b) (upd x y r) |
  EQ \<Rightarrow> mkB l (x,y) r)" |
"upd x y (R _ l (a,b) r) = (case cmp x a of
  LT \<Rightarrow> mkR (upd x y l) (a,b) r |
  GT \<Rightarrow> mkR l (a,b) (upd x y r) |
  EQ \<Rightarrow> mkR l (x,y) r)"

definition update :: "'a::linorder \<Rightarrow> 'b::linorder \<Rightarrow> ('a,'b) rbth \<Rightarrow> ('a,'b) rbth"
where
"update x y t = paint Black (upd x y t)"

fun del :: "'a::linorder \<Rightarrow> ('a,'b::linorder)rbth \<Rightarrow> ('a,'b)rbth" where
"del x Leaf = Leaf" |
"del x (Node l ((a,b), (c,_)) r) = (case cmp x a of
     LT \<Rightarrow> if l \<noteq> Leaf \<and> color l = Black
           then baldL (del x l) (a,b) r else mkR (del x l) (a,b) r |
     GT \<Rightarrow> if r \<noteq> Leaf\<and> color r = Black
           then baldR l (a,b) (del x r) else mkR l (a,b) (del x r) |
  EQ \<Rightarrow> combine l r)"

definition delete :: "'a::linorder \<Rightarrow> ('a,'b::linorder) rbth \<Rightarrow> ('a,'b) rbth" where
"delete x t = paint Black (del x t)"

subsubsection \<open>Invariants\<close>

fun bheight :: "('k,'p) rbth \<Rightarrow> nat" where
"bheight Leaf = 0" |
"bheight (Node l (x, (c,_)) r) = (if c = Black then bheight l + 1 else bheight l)"

fun invc :: "('k,'p) rbth \<Rightarrow> bool" where
"invc Leaf = True" |
"invc (Node l (a, (c,_)) r) =
  (invc l \<and> invc r \<and> (c = Red \<longrightarrow> color l = Black \<and> color r = Black))"

fun invc2 :: "('k,'p) rbth \<Rightarrow> bool" \<comment> \<open>Weaker version\<close> where
"invc2 Leaf = True" |
"invc2 (Node l (a, _) r) = (invc l \<and> invc r)"

fun invh :: "('k,'p) rbth \<Rightarrow> bool" where
"invh Leaf = True" |
"invh (Node l (x, _) r) = (invh l \<and> invh r \<and> bheight l = bheight r)"

definition rbt :: "('k,'p::linorder) rbth \<Rightarrow> bool" where
"rbt t = (invc t \<and> invh t \<and> invpst t \<and> color t = Black)"

subsection \<open>Functional Correctness\<close>

lemma inorder_paint[simp]: "inorder(paint c t) = inorder t"
by(cases t) (auto)

lemma inorder_mkNode[simp]:
  "inorder (mkNode c l a r) = inorder l @ a # inorder r"
by (auto simp: mkNode_def)

lemma inorder_baliL[simp]:
  "inorder(baliL l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliL.cases) (auto)

lemma inorder_baliR[simp]:
  "inorder(baliR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baliR.cases) (auto)

lemma inorder_baldL[simp]:
  "inorder(baldL l a r) = inorder l @ a # inorder r"
by (cases "(l,a,r)" rule: baldL.cases) auto

lemma inorder_baldR[simp]:
  "inorder(baldR l a r) = inorder l @ a # inorder r"
by(cases "(l,a,r)" rule: baldR.cases) auto

lemma inorder_combine[simp]:
  "inorder(combine l r) = inorder l @ inorder r"
by (induction l r rule: combine.induct) (auto split: tree.split tcolor.split)

lemma inorder_upd:
  "sorted1(inorder t) \<Longrightarrow> inorder(upd x y t) = upd_list x y (inorder t)"
by(induction x y t rule: upd.induct)
  (auto simp: upd_list_simps)

lemma inorder_update:
  "sorted1(inorder t) \<Longrightarrow> inorder(update x y t) = upd_list x y (inorder t)"
by(simp add: update_def inorder_upd)

lemma inorder_del:
 "sorted1(inorder t) \<Longrightarrow>  inorder(del x t) = del_list x (inorder t)"
by(induction x t rule: del.induct)
  (auto simp: del_list_simps)

lemma inorder_delete:
  "sorted1(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
by(simp add: delete_def inorder_del)

subsection \<open>Invariant Preservation\<close>

lemma color_paint_Black: "color (paint Black t) = Black"
by (cases t) auto

theorem rbt_Leaf: "rbt Leaf"
by (simp add: rbt_def)

lemma invc2I: "invc t \<Longrightarrow> invc2 t"
by (cases t rule: invc.cases) simp+

lemma paint_invc2: "invc2 t \<Longrightarrow> invc2 (paint c t)"
by (cases t) auto

lemma invc_paint_Black: "invc2 t \<Longrightarrow> invc (paint Black t)"
by (cases t) auto

lemma invh_paint: "invh t \<Longrightarrow> invh (paint c t)"
by (cases t) auto

lemma invc_mkRB[simp]:
  "invc (mkR l a r) \<longleftrightarrow> invc l \<and> invc r \<and> color l = Black \<and> color r = Black"
  "invc (mkB l a r) \<longleftrightarrow> invc l \<and> invc r"
by (simp_all add: mkNode_def)

lemma color_mkNode[simp]: "color (mkNode c l a r) = c"
by (simp_all add: mkNode_def)

subsubsection \<open>Update\<close>

lemma invc_baliL:
  "\<lbrakk>invc2 l; invc r\<rbrakk> \<Longrightarrow> invc (baliL l a r)"
by (induct l a r rule: baliL.induct) auto

lemma invc_baliR:
  "\<lbrakk>invc l; invc2 r\<rbrakk> \<Longrightarrow> invc (baliR l a r)"
by (induct l a r rule: baliR.induct) auto

lemma bheight_mkRB[simp]:
  "bheight (mkR l a r) = bheight l"
  "bheight (mkB l a r) = Suc (bheight l)"
  by (simp_all add: mkNode_def)

lemma bheight_baliL:
  "bheight l = bheight r \<Longrightarrow> bheight (baliL l a r) = Suc (bheight l)"
by (induct l a r rule: baliL.induct) auto

lemma bheight_baliR:
  "bheight l = bheight r \<Longrightarrow> bheight (baliR l a r) = Suc (bheight l)"
by (induct l a r rule: baliR.induct) auto

lemma invh_mkNode[simp]:
  "invh (mkNode c l a r) \<longleftrightarrow> invh l \<and> invh r \<and> bheight l = bheight r"
by (simp add: mkNode_def)

lemma invh_baliL:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliL l a r)"
by (induct l a r rule: baliL.induct) auto

lemma invh_baliR:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk> \<Longrightarrow> invh (baliR l a r)"
by (induct l a r rule: baliR.induct) auto

lemma invc_upd: assumes "invc t"
  shows "color t = Black \<Longrightarrow> invc (upd x y t)" "invc2 (upd x y t)"
using assms
by (induct x y t rule: upd.induct)
   (auto simp: invc_baliL invc_baliR invc2I mkNode_def)

lemma invh_upd: assumes "invh t"
  shows "invh (upd x y t)" "bheight (upd x y t) = bheight t"
using assms
by(induct x y t rule: upd.induct)
  (auto simp: invh_baliL invh_baliR bheight_baliL bheight_baliR)

lemma invpst_paint[simp]: "invpst (paint c t) = invpst t"
by (cases "(c,t)" rule: paint.cases) auto

lemma invpst_baliR: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baliR l a r)"
by (cases "(l,a,r)" rule: baliR.cases) auto

lemma invpst_baliL: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baliL l a r)"
by (cases "(l,a,r)" rule: baliL.cases) auto

lemma invpst_upd: "invpst t \<Longrightarrow> invpst (upd x y t)"
by (induct x y t rule: upd.induct) (auto simp: invpst_baliR invpst_baliL)

theorem rbt_update: "rbt t \<Longrightarrow> rbt (update x y t)"
by (simp add: invc_upd(2) invh_upd(1) color_paint_Black invc_paint_Black
  invh_paint rbt_def update_def invpst_upd)

subsubsection \<open>Delete\<close>

lemma bheight_paint_Red:
  "color t = Black \<Longrightarrow> bheight (paint Red t) = bheight t - 1"
by (cases t) auto

lemma invh_baldL_invc:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  invc r \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight l + 1"
by (induct l a r rule: baldL.induct)
   (auto simp: invh_baliR invh_paint bheight_baliR bheight_paint_Red)

lemma invh_baldL_Black:
  "\<lbrakk> invh l;  invh r;  bheight l + 1 = bheight r;  color r = Black \<rbrakk>
   \<Longrightarrow> invh (baldL l a r) \<and> bheight (baldL l a r) = bheight r"
by (induct l a r rule: baldL.induct) (auto simp add: invh_baliR bheight_baliR)

lemma invc_baldL: "\<lbrakk>invc2 l; invc r; color r = Black\<rbrakk> \<Longrightarrow> invc (baldL l a r)"
by (induct l a r rule: baldL.induct) (auto simp: invc_baliR invc2I mkNode_def)

lemma invc2_baldL: "\<lbrakk> invc2 l; invc r \<rbrakk> \<Longrightarrow> invc2 (baldL l a r)"
by (induct l a r rule: baldL.induct)
   (auto simp: invc_baliR paint_invc2 invc2I mkNode_def)

lemma invh_baldR_invc:
  "\<lbrakk> invh l;  invh r;  bheight l = bheight r + 1;  invc l \<rbrakk>
  \<Longrightarrow> invh (baldR l a r) \<and> bheight (baldR l a r) = bheight l"
by(induct l a r rule: baldR.induct)
  (auto simp: invh_baliL bheight_baliL invh_paint bheight_paint_Red)

lemma invc_baldR: "\<lbrakk>invc a; invc2 b; color a = Black\<rbrakk> \<Longrightarrow> invc (baldR a x b)"
by (induct a x b rule: baldR.induct) (simp_all add: invc_baliL mkNode_def)

lemma invc2_baldR: "\<lbrakk> invc l; invc2 r \<rbrakk> \<Longrightarrow>invc2 (baldR l x r)"
by (induct l x r rule: baldR.induct)
   (auto simp: invc_baliL paint_invc2 invc2I mkNode_def)

lemma invh_combine:
  "\<lbrakk> invh l; invh r; bheight l = bheight r \<rbrakk>
  \<Longrightarrow> invh (combine l r) \<and> bheight (combine l r) = bheight l"
by (induct l r rule: combine.induct)
   (auto simp: invh_baldL_Black split: tree.splits tcolor.splits)

lemma invc_combine:
  assumes "invc l" "invc r"
  shows "color l = Black \<Longrightarrow> color r = Black \<Longrightarrow> invc (combine l r)"
         "invc2 (combine l r)"
using assms
by (induct l r rule: combine.induct)
   (auto simp: invc_baldL invc2I mkNode_def split: tree.splits tcolor.splits)

lemma neq_LeafD: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x c r. t = Node l (x,c) r"
by(cases t) auto

lemma del_invc_invh: "invh t \<Longrightarrow> invc t \<Longrightarrow> invh (del x t) \<and>
   (color t = Red \<and> bheight (del x t) = bheight t \<and> invc (del x t) \<or>
    color t = Black \<and> bheight (del x t) = bheight t - 1 \<and> invc2 (del x t))"
proof (induct x t rule: del.induct)
case (2 x _ y _ c)
  have "x = y \<or> x < y \<or> x > y" by auto
  thus ?case proof (elim disjE)
    assume "x = y"
    with 2 show ?thesis
    by (cases c) (simp_all add: invh_combine invc_combine)
  next
    assume "x < y"
    with 2 show ?thesis
      by(cases c)
        (auto
          simp: invh_baldL_invc invc_baldL invc2_baldL mkNode_def
          dest: neq_LeafD)
  next
    assume "y < x"
    with 2 show ?thesis
      by(cases c)
        (auto
          simp: invh_baldR_invc invc_baldR invc2_baldR mkNode_def
          dest: neq_LeafD)
  qed
qed auto

lemma invpst_baldR: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baldR l a r)"
by (cases "(l,a,r)" rule: baldR.cases) (auto simp: invpst_baliL)

lemma invpst_baldL: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (baldL l a r)"
by (cases "(l,a,r)" rule: baldL.cases) (auto simp: invpst_baliR)

lemma invpst_combine: "invpst l \<Longrightarrow> invpst r \<Longrightarrow> invpst (combine l r)"
by(induction l r rule: combine.induct)
  (auto split: tree.splits tcolor.splits simp: invpst_baldR invpst_baldL)

lemma invpst_del: "invpst t \<Longrightarrow> invpst (del x t)"
by(induct x t rule: del.induct)
  (auto simp: invpst_baldR invpst_baldL invpst_combine)

theorem rbt_delete: "rbt t \<Longrightarrow> rbt (delete k t)"
apply (clarsimp simp: delete_def rbt_def)
apply (frule (1) del_invc_invh[where x=k])
apply (auto simp: invc_paint_Black invh_paint color_paint_Black invpst_del)
done

lemma rbt_getmin_ismin:
  "rbt t \<Longrightarrow> t\<noteq>Leaf \<Longrightarrow> is_min2 (pst_getmin t) (set_tree t)"
unfolding rbt_def by (simp add: pst_getmin_ismin)

definition "rbt_is_empty t \<equiv> t = Leaf"

lemma rbt_is_empty: "rbt_is_empty t \<longleftrightarrow> inorder t = []"
by (cases t) (auto simp: rbt_is_empty_def)

definition empty where "empty = Leaf"

subsection \<open>Overall Correctness\<close>

interpretation PM: PrioMap_by_Ordered
where empty = empty and lookup = lookup and update = update and delete = delete
and inorder = inorder and inv = "rbt" and is_empty = rbt_is_empty
and getmin = pst_getmin
apply standard
apply (auto simp: lookup_map_of inorder_update inorder_delete rbt_update
                  rbt_delete rbt_Leaf rbt_is_empty empty_def
            dest: rbt_getmin_ismin)
done

end


theory Utilities_Ext
  imports
    Utilities
    Extended_Assertion
begin

context rbt_impl
begin

declare ll_matches_rbt.simps[simp]

lemma matches_rbt_correct [vcg_rules]:
  "
  llvm_htriple
  (rbt_assn_ext t {} ti)
  (ll_matches_rbt pat ti)
  (\<lambda>r. rbt_assn_ext t {} ti ** \<upharpoonleft>bool.assn (matches_rbt pat (rbt_of t)) r)
"
proof(induction pat arbitrary: t ti)
  case RP_Var
  then show ?case
    apply vcg
    apply (subst Hack_1) (*!FIX!*)
    apply vcg
    done
next
  case RP_Empty
  then show ?case
    apply vcg
    apply (subst Hack_1) (*!FIX!*)
    apply vcg_compat
    apply isep_extract_pure
    apply (simp add: bool_assn_pure_eq)
    apply auto[]
    apply (sepwith \<open>auto elim: rbt_of.elims\<close>)+
    done
next
  case (RP_Branch x1 pat1 pat2)
  note [vcg_rules] = RP_Branch

  show "?case"
    apply vcg
    subgoal
      apply (subst Hack_1) (*!FIX!*)
      apply (simp add: bool_assn_pure_eq)
      apply vcg
      done
    subgoal
      apply vcg
        apply (all \<open>subst Hack_1\<close>)
        apply vcg
      done
    done
qed

declare ll_matches_rbt.simps[simp del]

definition "ctx (P::bool) \<equiv> \<up>P"

lemma sep_context_pureI [fri_red_rules]:
  "B \<Longrightarrow> is_sep_red (\<up>B) \<box> \<box> (ctx B)"
  unfolding ctx_def
  apply (rule is_sep_redI)
  by (simp add: pure_true_conv)

lemma ctx_is_pure [simp]: "sep_is_pure_assn (ctx X)"
  unfolding ctx_def
  by simp

lemma ctx_pure_part [simp]: "pure_part (ctx X) = X"
  unfolding ctx_def
  by simp

end

end