theory BaseLogicShallow
imports CoreStructures
begin

subsection \<open> Uniform Predicates \<close>
text \<open> A upred formalization as a semantic subtype of functions, shallow embedding \<close>
typedef (overloaded) 'm::ucamera upred_f = "{f::('m \<Rightarrow> nat \<Rightarrow> bool).
  \<forall>n m x y. f x n \<longrightarrow> n_incl m x y \<longrightarrow> m\<le>n \<longrightarrow> f y m}"
  proof
  define uTrue where "uTrue \<equiv> \<lambda>x::'m. \<lambda>n::nat. True"
  hence "\<forall>n m x y. uTrue x n \<longrightarrow> n_incl m x y \<longrightarrow> m\<le>n \<longrightarrow> uTrue y m" by fast
  thus "uTrue \<in> {f. \<forall>n m x y. f x n \<longrightarrow> n_incl m x y \<longrightarrow> m\<le>n \<longrightarrow> f y m}" by blast
qed

setup_lifting type_definition_upred_f
lemmas [simp] = Rep_upred_f_inverse Rep_upred_f_inject
lemmas [simp, intro!] = Rep_upred_f[unfolded mem_Collect_eq]

instantiation upred_f :: (ucamera) ofe begin
  lift_definition n_equiv_upred_f :: "nat \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool" is
    "\<lambda>n P Q. \<forall>a m. m\<le>n \<longrightarrow> n_valid a m \<longrightarrow> (P a m \<longleftrightarrow> Q a m)" .
  lift_definition ofe_eq_upred_f :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool" is
    "\<lambda>P Q. \<forall>a n. n_valid a n \<longrightarrow> (P a n \<longleftrightarrow> Q a n)" .
instance by (standard) (auto simp: n_equiv_upred_f.rep_eq ofe_eq_upred_f.rep_eq)
end

instantiation upred_f :: (ucamera) cofe begin
  lift_definition lim_upred_f :: "'a upred_f chain \<Rightarrow> 'a upred_f" is
    "\<lambda>(c::'a upred_f chain) (a::'a) n. \<forall>m\<le>n. n_valid a m \<longrightarrow> Rep_upred_f (Rep_chain c m) a m"
    by (smt (verit, ccfv_SIG) Rep_upred_f camera_n_incl_le camera_valid_op le_refl mem_Collect_eq
      n_incl_def n_valid_ne order_trans)
instance apply (standard; auto simp: lim_upred_f.rep_eq n_equiv_upred_f_def; transfer)
  apply (metis (mono_tags, lifting) cr_upred_f_def n_equiv_upred_f.rep_eq nle_le rel_funD2 upred_f.pcr_cr_eq)
  by (smt (z3) Rep_upred_f cr_upred_f_def le_cases3 mem_Collect_eq n_equiv_upred_f.rep_eq
    ne_sprop_weaken ofe_refl rel_funD2 total_n_inclI upred_f.pcr_cr_eq valid_raw_non_expansive)
end

text \<open>Axiomatized fixed-point\<close>
typedecl pre_iprop
instance pre_iprop :: ofe sorry
axiomatization pre :: "'a upred_f \<Rightarrow> pre_iprop" and iProp :: "pre_iprop \<Rightarrow> 'a upred_f"

locale T_iso =
fixes to_iso :: "'a::ofe \<Rightarrow> 'b::ofe" and from_iso :: "'b \<Rightarrow> 'a"
assumes isomorph1: "ofe_eq (to_iso (from_iso x)) x" and isomorph2: "ofe_eq (from_iso (to_iso y)) y"
  and to_ne: "non_expansive to_iso" and from_ne: "non_expansive from_iso"
begin
  lemma to_equiv: "n_equiv n (to_iso x) (to_iso y) \<longleftrightarrow> n_equiv n x y"
  proof
    assume assm: "n_equiv n (to_iso x) (to_iso y)"
    have iso_step: "n_equiv n x y \<longleftrightarrow> n_equiv n (from_iso (to_iso x)) (from_iso (to_iso y))"
      by (metis ofe_limit ofe_trans_eqL isomorph2)
    from non_expansiveE[OF from_ne, OF assm] have "n_equiv n (from_iso (to_iso x)) (from_iso (to_iso y))"
      by simp
    with iso_step show "n_equiv n x y" by simp
  next
    assume "n_equiv n x y"
    with non_expansiveE[OF to_ne] show "n_equiv n (to_iso x) (to_iso y)" by simp
  qed
  lemma from_equiv: "n_equiv n (from_iso x) (from_iso y) \<longleftrightarrow> n_equiv n x y"
    by (metis T_iso.intro T_iso.to_equiv from_ne isomorph1 isomorph2 to_ne)
end

interpretation ipropIso: T_iso pre iProp sorry

definition map_upred_ne :: "(('b::ucamera) -n> ('a::ucamera)) \<Rightarrow> (('a upred_f) -n> ('b upred_f))" where
  "map_upred_ne (f::'b-n>'a) = Abs_ne (\<lambda>(x::'a upred_f). Abs_upred_f (\<lambda>(c::'b) n. Rep_upred_f x (Rep_ne f c) n))"

lemma upred_f_ne: "\<lbrakk>n_equiv m (P::('a::ucamera) upred_f) Q; m\<le>n; n_valid x m; Rep_upred_f P x n\<rbrakk>
  \<Longrightarrow> Rep_upred_f Q x m"
  apply transfer using n_incl_refl by blast

subsubsection \<open>upred Functor\<close>
text \<open>A functor for \<^typ>\<open>'a upred_f\<close> based on sound camera morphisms.\<close>
context begin
text \<open>This is the map of the contravariant functor for uniform predicates.\<close>
lift_definition upred_map :: "('a::ucamera,'b::ucamera) cmra_morph \<Rightarrow> 'b upred_f \<Rightarrow> 'a upred_f" is
  "\<lambda>f P x. Rep_upred_f P (Rep_cmra_morph f x)"
  by (transfer; auto simp: n_incl_def camera_morphism_def non_expansive_def) metis

lemma upred_map_ne2: "non_expansive2 upred_map"
  by (rule non_expansive2I; transfer)
  (smt (verit, del_insts) Rep_cmra_morph Rep_upred_f camera_morphism.morphism_valid le_cases3
    mem_Collect_eq n_equiv_cmra_morph.rep_eq n_equiv_upred_f.rep_eq ofe_sym total_n_inclI)

lemma upred_map_ne: "non_expansive (upred_map f)"
  by (rule non_expansive2_ne[OF upred_map_ne2])

lemma upred_morph_ne: "non_expansive (\<lambda>f. upred_map f x)"
  by (rule non_expansiveI; transfer) (auto simp: ofe_sym total_n_inclI n_equiv_cmra_morph_def)

private lemma upred_morphism:
  "\<lbrakk>(\<And>n m x y. P x n \<Longrightarrow> n_incl m x y \<Longrightarrow> m \<le> n \<Longrightarrow> P y m); camera_morphism f\<rbrakk> \<Longrightarrow>
   (\<And>n m x y. (\<lambda>x. P (f x)) x n \<Longrightarrow> n_incl m x y \<Longrightarrow> m \<le> n \<Longrightarrow> (\<lambda>x. P (f x)) y m)"
proof -
  fix n m x y
  assume assms1: "(\<And>n m x y. P x n \<Longrightarrow> n_incl m x y \<Longrightarrow> m \<le> n \<Longrightarrow> P y m)" "camera_morphism f"
  assume assms2: "(\<lambda>x. P (f x)) x n" "n_incl m x y" "m \<le> n"
  then have P: "P (f x) n" by simp
  from assms2(2) n_incl_morph[OF assms1(2)] have "n_incl m (f x) (f y)" by simp
  from assms1(1)[OF P this assms2(3)] show "(\<lambda>x. P (f x)) y m" by simp
qed

lemma Abs_morphism_inverse: "\<lbrakk>\<forall>n m x y. P x n \<longrightarrow> n_incl m x y \<longrightarrow> m \<le> n \<longrightarrow> P y m; camera_morphism f\<rbrakk>
  \<Longrightarrow> Rep_upred_f (Abs_upred_f (\<lambda>x. P (f x))) = (\<lambda>x. P (f x))"
  by (smt (verit, best) mem_Collect_eq upred_morphism Abs_upred_f_inverse)

lemma upred_map_id: "upred_map id_morph P = P"
  by (auto simp: upred_map_def id_morph.rep_eq)

lemma upred_map_compose: "ofe_eq (upred_map (morph_comp g f) P) (upred_map f (upred_map g P))"
  by (simp add: morph_comp.rep_eq ofe_eq_upred_f.rep_eq upred_map.rep_eq)

lemma upred_map_ext: "(\<forall>x. ofe_eq (Rep_cmra_morph f x) (Rep_cmra_morph g x)) \<Longrightarrow>
  ofe_eq (upred_map f x) (upred_map g x)"
  using upred_morph_ne[unfolded non_expansive_def n_equiv_cmra_morph.rep_eq] by (metis ofe_limit)

lift_definition upred_map_ne :: "('a::ucamera,'b::ucamera) cmra_morph \<Rightarrow> 'b upred_f -n> 'a upred_f" is
  "\<lambda>f. upred_map f" by (rule upred_map_ne)

lemma upred_map_ne_ne: "non_expansive upred_map_ne"
  by (rule non_expansiveI)
  (smt (verit, best) n_equiv_ne.rep_eq non_expansive_def upred_map_ne.rep_eq upred_morph_ne)
end

text \<open> Basic predicates and predicate connectives: \<close>
(* Arcane Isabelle magic, presented to you by Manuel Eberl *)
context assumes "SORT_CONSTRAINT('a::ucamera)"
begin

text \<open> upred as a predicate on functions\<close>
definition upred_def :: "('a \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> bool" where
  [simp]: "upred_def P \<equiv> \<forall>n m x y. P x n \<longrightarrow> n_incl m x y \<longrightarrow> m\<le>n \<longrightarrow> P y m"
lemma upred_defI[intro?]:
  assumes "\<And>n m x y. \<lbrakk>P x n; n_incl m x y; m\<le>n\<rbrakk> \<Longrightarrow> P y m"
  shows "upred_def P"
  using assms by auto

lemma upred_def_rep: "upred_def (Rep_upred_f f)" using Rep_upred_f upred_def_def by blast

lemma upred_weaken: "\<lbrakk>n_equiv n x y; m\<le>n;upred_def f; f x n\<rbrakk> \<Longrightarrow> f y m"
  using Rep_upred_f total_n_inclI upred_def_def by fast

lemma upred_weaken_simple: "\<lbrakk>upred_def f; f x n; m\<le>n\<rbrakk> \<Longrightarrow> f x m"
  using ofe_refl upred_weaken by blast

lift_definition upred_holds :: "'a upred_f \<Rightarrow> bool" is
  "\<lambda>u. \<forall>a n. n_valid a n \<longrightarrow>  u a n" .

(* This shows that upred_f are pointwise down-closed, non-expansive and monotone. *)
theorem upred_equiv_upred_f:
  "upred_def f \<longleftrightarrow>
  ((\<forall>x n m. m \<le> n \<longrightarrow> f x n \<longrightarrow> f x m) \<and>
  (\<forall>n x y. n_equiv n x y\<longrightarrow>(\<forall>m\<le>n. f x m \<longleftrightarrow> f y m)) \<and>
  (\<forall>n x y. n_incl n x y \<longrightarrow> (\<forall>m\<le>n. f x m \<longrightarrow> f y m)))"
(is "?u f \<longleftrightarrow> (?sprop f \<and> ?ne f \<and> ?mon f)")
proof
assume assm: "?u f"
then show "?sprop f \<and> ?ne f \<and> ?mon f"
  by (smt (verit, best) camera_n_incl_le ofe_mono ofe_sym order_refl upred_def_def upred_weaken
    upred_weaken_simple)
next
assume assm: "?sprop f \<and> ?ne f \<and> ?mon f"
then show "?u f" by simp
qed

lemma upred_ne: "\<lbrakk>upred_def f; n_equiv n x y\<rbrakk> \<Longrightarrow> n_equiv n (f x n) (f y n)"
  unfolding upred_equiv_upred_f by auto

subsubsection \<open>Unifrom predicate semantics\<close>
text \<open> The semantic of uniform predicates is defined as a shallow embedding. \<close>

lift_definition upred_pure :: "bool \<Rightarrow> 'a upred_f" ("\<upharpoonleft>_") is "\<lambda>b::bool. \<lambda>_::'a. \<lambda>_::nat. b" .

lift_definition upred_eq :: "'c::ofe \<Rightarrow> 'c \<Rightarrow> 'a upred_f" (infix "=\<^sub>u" 70) is
  "\<lambda>x (y::'c). \<lambda>_::'a. \<lambda>n. ofe_class.n_equiv n x y" by (rule ofe_mono)

lift_definition upred_conj :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f" (infixl "\<and>\<^sub>u" 60) is
  "\<lambda>P Q (a::'a) (n::nat). P a n \<and> Q a n" by (rule conj_forward)
lift_definition upred_disj :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f" (infixl "\<or>\<^sub>u" 55) is
  "\<lambda>P Q (a::'a) (n::nat). P a n \<or> Q a n" by (rule disj_forward)

lift_definition upred_impl :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f" (infixr "\<longrightarrow>\<^sub>u" 40) is
  "\<lambda>P Q (a::'a) n. (\<forall>m\<le>n. \<forall>b. incl a b \<longrightarrow> n_valid b m \<longrightarrow> P b m \<longrightarrow> Q b m)"
proof -
  fix x y n n' a b m c
  assume assms: "n_incl n' a (b::'a)" "n'\<le>n" "m\<le>n'" "incl b c" "n_valid c m" "x c m"
  assume x_upred: "(\<And>n m x' y. x x' n \<Longrightarrow> n_incl m x' y \<Longrightarrow> m \<le> n \<Longrightarrow> x y m)"
  assume y_upred: "(\<And>n m x (y'::'a). y x n \<Longrightarrow> n_incl m x y' \<Longrightarrow> m \<le> n \<Longrightarrow> y y' m)"
  assume I: "(\<And>m b. m \<le> n \<Longrightarrow> incl a b \<Longrightarrow> n_valid b m \<Longrightarrow> x b m \<Longrightarrow> y b m)"
  from \<open>n_incl n' a b\<close> obtain b' where b': "n_equiv n' b (op a b')" using n_incl_def by blast
  from \<open>incl b c\<close> obtain c' where c':"c = op b c'" using incl_def by blast
  with assms have "n_valid (op b c') m" by simp
  with b' have vabc: "n_valid (op (op a b') c') m"
    by (meson assms(3) valid_op_op_weaken ofe_mono)
  from c' \<open>x c m\<close> have xbc':"x (op b c') m"  by simp
  have bc_abc: "n_equiv m (op b c') (op (op a b') c')"
    using ofe_class.ofe_mono[OF assms(3) op_equiv[OF b', of c' c', simplified ofe_class.ofe_refl, simplified]] .
  from upred_weaken[OF this, of m, simplified] x_upred xbc'
  have xabc: "x (op (op a b') c') m" by metis
  from bc_abc c' have "n_equiv m (op (op a b') c') c" by (simp add:ofe_class.ofe_sym)
  from upred_weaken[OF this, of m, simplified, of y] have yabc: "y (op (op a b') c') m \<Longrightarrow> y c m"
    using y_upred by blast
  have "incl a (op (op a b') c')" using incl_op_extend incl_def by blast
  from yabc[OF I[OF order.trans[OF assms(3,2)] this vabc xabc]]
  show "y c m".
qed

lift_definition upred_forall :: "('c \<Rightarrow> 'a upred_f) \<Rightarrow> 'a upred_f" (binder "\<forall>\<^sub>u" 20) is
  "\<lambda>P (a::'a) (n::nat). \<forall>x::'c. P x a n" by (rule meta_allE)

lift_definition upred_exists :: "('c \<Rightarrow> 'a upred_f) \<Rightarrow> 'a upred_f" (binder "\<exists>\<^sub>u" 20) is
  "\<lambda>P (a::'a) (n::nat). \<exists>x::'c. P x a n" by (rule ex_forward)

lift_definition upred_sep :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f" (infixl "\<^emph>" 60) is
  "\<lambda>P Q (a::'a) n. \<exists>b1 b2. n_equiv n a (b1 \<cdot> b2) \<and> P b1 n \<and> Q b2 n"
proof (erule exE;erule exE)
  fix P Q n m a b c1 c2
  assume assms: "n_incl m a (b::'a)" "m\<le>n"
  assume I: "n_equiv n a (op c1 c2)\<and>P c1 n\<and>Q c2 n"
  assume Q: "(\<And>n m x y. Q x n \<Longrightarrow> n_incl m x y \<Longrightarrow> m \<le> n \<Longrightarrow> Q y m)"
  assume "(\<And>n m x y. P x n \<Longrightarrow> n_incl m x y \<Longrightarrow> m \<le> n \<Longrightarrow> P y m)"
  then have P: "upred_def P" by auto
  from I have I': "n_equiv n a (op c1 c2)" "P c1 n" "Q c2 n" by simp_all
  from assms obtain c where c:"n_equiv m b (op a c)" using n_incl_def by blast
  from op_equiv_subst[OF this I'(1) assms(2)] have "n_equiv m b (op (op c1 c2) c)" .
  then have bc: "n_equiv m b (op c1 (op c2 c))"
    by (metis camera_class.camera_assoc)
  from upred_weaken_simple[OF P I'(2) assms(2)] have c1: "P c1 m" .
  from Q[OF I'(3), of m, OF n_incl_op_extend assms(2), of c] have "Q (op c2 c) m" .
  with bc c1 show "\<exists>b1 b2. n_equiv m b (op b1 b2) \<and> P b1 m \<and> Q b2 m" by blast
qed

lift_definition upred_wand :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f" (infixr "-\<^emph>" 40) is
  "\<lambda>P Q (a::'a) n. \<forall>b m. m\<le>n \<longrightarrow> n_valid (a \<cdot> b) m \<longrightarrow> P b m \<longrightarrow> Q (a \<cdot> b) m"
proof -
  fix P Q n n' a b c m
  assume Q: "\<And>n m x y. Q (x::'a) n \<Longrightarrow> n_incl m x y \<Longrightarrow> m \<le> n \<Longrightarrow> Q y m"
  assume I: "(\<And>b m. m\<le>n \<Longrightarrow> n_valid (op a b) m \<Longrightarrow> P b m \<Longrightarrow> Q (op a b) m)"
  assume assms: "n_incl n' a (b::'a)" "n'\<le>n" "m\<le>n'" " n_valid (op b c) m" "P c m"
  from assms have "m\<le>n" by linarith
  from Q[OF I[OF this n_valid_incl_subst[OF assms(1,4,3)] assms(5)] n_incl_extend[OF assms(1,3)] order.refl]
  show "Q (op b c) m" .
qed

lift_definition upred_own :: "'a \<Rightarrow> 'a upred_f" ("Own(_)") is "\<lambda>(a::'a) b n. n_incl n a b"
  unfolding n_incl_def using camera_assoc op_equiv_subst by metis

lift_definition upred_valid :: "'b::camera \<Rightarrow> 'a upred_f" ("\<V>(_)") is "\<lambda>(a::'b) (_::'a). n_valid a"
  using Rep_sprop n_incl_def by blast

lift_definition upred_persis :: "'a upred_f \<Rightarrow> 'a upred_f" ("\<box>_") is "\<lambda>P (a::'a) n. (P (core a) n)::bool"
proof (unfold n_incl_def; erule exE)
  fix f n m
  fix a b c :: 'a
  assume I: "\<And>n m x y. f (x::'a) n \<Longrightarrow> \<exists>c. n_equiv m y (op x c) \<Longrightarrow> m \<le> n \<Longrightarrow> f y m"
  assume assms: "f (core a) n" "m\<le>n" "n_equiv m b (op a c)"
  then have "\<exists>d. n_equiv m b (op a d)" by auto
  then have "\<exists>d. n_equiv m (core b) (op (core a) d)"
    by (metis incl_def camera_core_mono core_ne[unfolded non_expansive_def])
  from I[OF assms(1) this assms(2)] show "f (core b) m" .
qed

lift_definition upred_plain :: "'a upred_f \<Rightarrow> 'a upred_f" ("\<^item>_") is "\<lambda>P (_::'a) (n::nat). (P (\<epsilon>::'a) n)::bool"
  by (metis \<epsilon>_left_id ofe_eq_limit n_incl_def)

lift_definition upred_later :: "'a upred_f \<Rightarrow> 'a upred_f" ("\<triangleright>_" 100) is "\<lambda>P (a::'a) n. n=0 \<or> P a (n-1)"
  by (smt (verit, ccfv_SIG) n_incl_def diff_0_eq_0 diff_diff_cancel diff_is_0_eq diff_right_commute diff_self_eq_0 ofe_mono)

lift_definition upred_bupd :: "'a upred_f \<Rightarrow> 'a upred_f" ("\<Rrightarrow>\<^sub>b_") is
  "\<lambda>P (a::'a) n. \<forall>m b. (m\<le>n \<and> n_valid (a \<cdot> b) m) \<longrightarrow> (\<exists>c. n_valid (c \<cdot> b) m \<and> P c m)"
  by (meson dual_order.trans n_incl_def n_valid_incl_subst)

lift_definition upred_entails :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool" (infix "\<turnstile>" 50) is
  "\<lambda>P Q. \<forall>(a::'a) n. n_valid a n \<longrightarrow> P a n \<longrightarrow> Q a n" .

definition upred_entail_eq :: "'a upred_f \<Rightarrow> 'a upred_f \<Rightarrow> bool" (infix "\<stileturn>\<turnstile>" 40) where
  "P \<stileturn>\<turnstile> Q \<equiv> (upred_entails P Q) \<and> (upred_entails Q P)"
end

(* Basic view shift operator *)
definition upred_bvs :: "('a::ucamera) upred_f \<Rightarrow> 'a upred_f \<Rightarrow> 'a upred_f" (infix "\<Rrightarrow>\<^sub>v" 70) where
  "upred_bvs P Q \<equiv> \<box>(P -\<^emph> (\<Rrightarrow>\<^sub>b Q))"
abbreviation wand_bupd (infix "==\<^emph>" 60) where "wand_bupd P Q \<equiv> P -\<^emph> \<Rrightarrow>\<^sub>b Q"

abbreviation "upred_emp \<equiv> \<upharpoonleft>True"

declare [[coercion upred_holds, coercion_enabled = true]]

subsubsection \<open>Upred \<^const>\<open>n_equiv\<close> rules\<close>
named_theorems upred_ne_rule
lemma upred_pure_ne [upred_ne_rule]: "(x\<longleftrightarrow>y) \<Longrightarrow> n_equiv n (\<upharpoonleft>x) (\<upharpoonleft>y)" by transfer simp
lemma upred_eq_ne [upred_ne_rule]: "\<lbrakk>n_equiv n x a; n_equiv n y b\<rbrakk> \<Longrightarrow> n_equiv n (x=\<^sub>ua) (y=\<^sub>ub)"
  by transfer (auto intro: ofe_mono)
lemma upred_conj_ne [upred_ne_rule]: "\<lbrakk>n_equiv n P Q; n_equiv n R S\<rbrakk> \<Longrightarrow> n_equiv n (P\<and>\<^sub>uR) (Q\<and>\<^sub>uS)"
  by transfer simp
lemma upred_disj_ne [upred_ne_rule]: "\<lbrakk>n_equiv n P Q; n_equiv n R S\<rbrakk> \<Longrightarrow> n_equiv n (P\<or>\<^sub>uR) (Q\<or>\<^sub>uS)"
  by transfer simp
lemma upred_impl_ne [upred_ne_rule]: "\<lbrakk>n_equiv n P Q; n_equiv n R S\<rbrakk> \<Longrightarrow> n_equiv n (P\<longrightarrow>\<^sub>uR) (Q\<longrightarrow>\<^sub>uS)"
  by transfer simp
lemma upred_forall_ne [upred_ne_rule]: "(\<And>x. n_equiv n (P x) (Q x)) \<Longrightarrow> n_equiv n (\<forall>\<^sub>u x. P x) (\<forall>\<^sub>u x. Q x)"
  by transfer' simp
lemma upred_exists_ne [upred_ne_rule]: "(\<And>x. n_equiv n (P x) (Q x)) \<Longrightarrow> n_equiv n (\<exists>\<^sub>u x. P x) (\<exists>\<^sub>u x. Q x)"
  by transfer' simp
lemma upred_sep_ne [upred_ne_rule]: "\<lbrakk>n_equiv n P Q; n_equiv n R S\<rbrakk> \<Longrightarrow> n_equiv n (P\<^emph>R) (Q\<^emph>S)"
  by transfer (metis camera_comm camera_valid_op n_valid_ne)
lemma upred_wand_ne [upred_ne_rule]: "\<lbrakk>n_equiv n P Q; n_equiv n R S\<rbrakk> \<Longrightarrow> n_equiv n (P-\<^emph>R) (Q-\<^emph>S)"
  by transfer (metis camera_comm camera_valid_op le_trans)
lemma upred_own_ne [upred_ne_rule]: "n_equiv n x y \<Longrightarrow> n_equiv n (Own x) (Own y)"
  by transfer (meson n_incl_def ofe_sym op_equiv_subst)
lemma upred_valid_ne [upred_ne_rule]: "n_equiv n x y \<Longrightarrow> n_equiv n (\<V> x) (\<V> y)"
  apply transfer using camera_props(8) n_equiv_sprop_def by blast
lemma upred_persis_ne [upred_ne_rule]: "n_equiv n P Q \<Longrightarrow> n_equiv n (\<box>P) (\<box>Q)"
  by transfer (metis camera_core_n_valid)
lemma upred_plain_ne [upred_ne_rule]: "n_equiv n P Q \<Longrightarrow> n_equiv n (\<^item>P) (\<^item>Q)"
  apply transfer using \<epsilon>_n_valid by blast
lemma upred_later_ne: "n_equiv n P Q \<Longrightarrow> n_equiv n (\<triangleright>P) (\<triangleright>Q)"
  apply transfer by (meson diff_le_self dual_order.trans ne_sprop_weaken ofe_eq_limit valid_raw_non_expansive)
lemma upred_later_contr: "contractive upred_later"
  unfolding contractive_def apply transfer
  by (smt (verit, best) One_nat_def Rep_sprop Suc_pred bot_nat_0.not_eq_extremum diff_le_mono diff_le_self less_Suc_eq_le mem_Collect_eq nle_le)
lemma upred_bupd_ne [upred_ne_rule]: "n_equiv n P Q \<Longrightarrow> n_equiv n (\<Rrightarrow>\<^sub>bP) (\<Rrightarrow>\<^sub>bQ)"
  by transfer (meson camera_valid_op order_trans)
end


theory Hotel_Example_Prolog
imports
  Hotel_Example
  "HOL-Library.Predicate_Compile_Alternative_Defs"
  "HOL-Library.Code_Prolog"
begin

declare Let_def[code_pred_inline]
(*
thm hotel_def
lemma [code_pred_inline]: "insert == (%y A x. y = x | A x)"
by (auto simp add: insert_iff[unfolded mem_def] fun_eq_iff intro!: eq_reflection)

lemma [code_pred_inline]: "(-) == (%A B x. A x \<and> \<not> B x)"
by (auto simp add: Diff_iff[unfolded mem_def] fun_eq_iff intro!: eq_reflection)
*)

definition issuedp :: "event list => key => bool"
where
  "issuedp evs k = (k \<in> issued evs)"

lemma [code_pred_def]:
  "issuedp [] Key0 = True"
  "issuedp (e # s) k = (issuedp s k \<or> (case e of Check_in g r (k1, k2) => k = k2 | _ => False))"
unfolding issuedp_def issued.simps initk_def
by (auto split: event.split)

definition cardsp
where
 "cardsp s g k = (k \<in> cards s g)"

lemma [code_pred_def]:
  "cardsp [] g k = False"
  "cardsp (e # s) g k =
    (let C = cardsp s g
     in case e of Check_in g' r c => if g' = g then k = c \<or> C k else C k | _ => C k)"
unfolding cardsp_def [abs_def] cards.simps by (auto simp add: Let_def split: event.split)

definition
  "isinp evs r g = (g \<in> isin evs r)"

lemma [code_pred_def]:
  "isinp [] r g = False"
  "isinp (e # s) r g =
  (let G = isinp s r
   in case e of Check_in g' r c => G g
    | Enter g' r' c => if r' = r then g = g' \<or> G g else G g
    | Exit g' r' => if r' = r then ((g \<noteq> g') \<and> G g) else G g)"
unfolding isinp_def [abs_def] isin.simps by (auto simp add: Let_def split: event.split)

declare hotel.simps(1)[code_pred_def]
lemma [code_pred_def]:
"hotel (e # s) =
  (hotel s & (case e of Check_in g r (k, k') => k = currk s r & \<not> issuedp s k'
  | Enter g r (k, k') => cardsp s g (k, k') & (roomk s r = k \<or> roomk s r = k')
  | Exit g r => isinp s r g))"
unfolding hotel.simps issuedp_def cardsp_def isinp_def
by (auto split: event.split)

declare List.member_rec[code_pred_def]

lemma [code_pred_def]: "no_Check_in s r = (\<not> (\<exists>g c. List.member s (Check_in g r c)))"
unfolding no_Check_in_def member_def by auto

lemma [code_pred_def]: "feels_safe s r =
(\<exists>s\<^sub>1 s\<^sub>2 s\<^sub>3 g c c'.
    s =
    s\<^sub>3 @
    [Enter g r c] @ s\<^sub>2 @ [Check_in g r c'] @ s\<^sub>1 &
    no_Check_in (s\<^sub>3 @ s\<^sub>2) r &
    (\<not> (\<exists> g'. isinp (s\<^sub>2 @ [Check_in g r c] @ s\<^sub>1) r g')))"
unfolding feels_safe_def isinp_def by auto

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = NONE,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = []})\<close>

values_prolog 40 "{s. hotel s}"

setup \<open>
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
\<close>

lemma "\<lbrakk> hotel s; isinp s r g \<rbrakk> \<Longrightarrow> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

section \<open>Manual setup to find the counterexample\<close>

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [],
   limited_predicates = [(["hotel"], 4)],
   replacing = [(("hotel", "limited_hotel"), "quickcheck")],
   manual_reorder = []})\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = no_counterexample]
oops

setup \<open>Code_Prolog.map_code_options (K
  {ensure_groundness = true,
   limit_globally = NONE,
   limited_types = [],
   limited_predicates = [(["hotel"], 5)],
   replacing = [(("hotel", "limited_hotel"), "quickcheck")],
   manual_reorder = []})\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

section \<open>Using a global limit for limiting the execution\<close>

text \<open>A global depth limit of 10 does not suffice to find the counterexample.\<close>

setup \<open>
  Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = SOME 10,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = []})
\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = no_counterexample]
oops

text \<open>But a global depth limit of 11 does.\<close>

setup \<open>
  Code_Prolog.map_code_options (K
  {ensure_groundness = true,
  limit_globally = SOME 11,
  limited_types = [],
  limited_predicates = [],
  replacing = [],
  manual_reorder = []})
\<close>

lemma
  "hotel s ==> feels_safe s r ==> isinp s r g ==> owns s r = Some g"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

end


theory "BAN_modified_CCITT_X509_3_cert_auto"
imports
  "ESPLogic"
begin

(* section:  BAN modified version of CCITT X.509 (3)  *)

(* text:
  Modelled after SPORE.

  Notable differences:
    1. We use explicit global constants instead of implicit typing to discern
       the different messages.

    2. We prove non-injective synchronization, which is stronger than the
       authentication on Ya and Yb required in the SPORE description.

    3. We equate all timestamps to a single global constant; i.e., we assume
       no checking of timestamps is done.

 *)

role A
where "A =
  [ Send ''1'' <| sAV ''A'',
                  PSign <| sC ''1_1'', sC ''Time'', sN ''Na'', sAV ''B'', sN ''Xa'',
                           PEnc <| sC ''1_2'', sN ''Ya'' |> ( sPK ''B'' )
                        |>
                        ( sPK ''A'' )
               |>
  , Recv ''2'' <| sAV ''B'',
                  PSign <| sC ''2_1'', sC ''Time'', sMV ''Nb'', sAV ''A'', sN ''Na'',
                           sMV ''Xb'', PEnc <| sC ''2_2'', sMV ''Yb'' |> ( sPK ''A'' )
                        |>
                        ( sPK ''B'' )
               |>
  , Send ''3'' <| sAV ''A'',
                  PSign <| sC ''3'', sAV ''B'', sMV ''Nb'' |> ( sPK ''A'' )
               |>
  ]"

role B
where "B =
  [ Recv ''1'' <| sMV ''A'',
                  PSign <| sC ''1_1'', sC ''Time'', sMV ''Na'', sAV ''B'', sMV ''Xa'',
                           PEnc <| sC ''1_2'', sMV ''Ya'' |> ( sPK ''B'' )
                        |>
                        ( PAsymPK ( sMV ''A'' ) )
               |>
  , Send ''2'' <| sAV ''B'',
                  PSign <| sC ''2_1'', sC ''Time'', sN ''Nb'', sMV ''A'', sMV ''Na'',
                           sN ''Xb'', PEnc <| sC ''2_2'', sN ''Yb'' |> ( PAsymPK ( sMV ''A'' ) )
                        |>
                        ( sPK ''B'' )
               |>
  , Recv ''3'' <| sMV ''A'',
                  PSign <| sC ''3'', sAV ''B'', sN ''Nb'' |> ( PAsymPK ( sMV ''A'' ) )
               |>
  ]"

protocol X509
where "X509 = { A, B }"

locale restricted_X509_state = X509_state

type_invariant X509_msc_typing for X509
where "X509_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((B, ''Na''), (KnownT B_1))
  , ((A, ''Nb''), (KnownT A_2))
  , ((B, ''Xa''), (KnownT B_1))
  , ((A, ''Xb''), (KnownT A_2))
  , ((B, ''Ya''), (SumT (KnownT B_1) (NonceT A ''Ya'')))
  , ((A, ''Yb''), (SumT (KnownT A_2) (NonceT B ''Yb'')))
  ]"

sublocale X509_state < X509_msc_typing_state
proof -
  have "(t,r,s) : approx X509_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF X509_msc_typing.monoTyp, completeness_cases_rule])
    case (A_2_Nb t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_Nb
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_2_Xb t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_Xb
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_2_Yb t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_Yb
    thus ?case
    proof(sources! "
        Enc {| LC ''2_2'', s(MV ''Yb'' tid0) |} ( PK ( s(AV ''A'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (B_1_A t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_Na t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_Na
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_Xa t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_Xa
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_Ya t r s tid0)
    then interpret state: X509_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_Ya
    thus ?case
    proof(sources! "
        Enc {| LC ''1_2'', s(MV ''Ya'' tid0) |} ( PK ( s(AV ''B'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "X509_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context X509_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Security Properties  *)

lemma (in restricted_X509_state) A_Ya_secrecy:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "LN ''Ya'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''Ya'' tid0 ")
  case A_1_Ya note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case A_1_Ya_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_X509_state) B_Yb_secrecy:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "LN ''Yb'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''Yb'' tid0 ")
  case B_2_Yb note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case B_2_Yb_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_X509_state) B_Ya_secrecy:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, B_1 ) : steps t"
    "s(MV ''Ya'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1_1'', LC ''Time'', s(MV ''Na'' tid0), s(AV ''B'' tid0),
                          s(MV ''Xa'' tid0),
                          Enc {| LC ''1_2'', s(MV ''Ya'' tid0) |} ( PK ( s(AV ''B'' tid0) ) )
                       |}
                       ( SK ( s(MV ''A'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_1_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: A_Ya_secrecy intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_X509_state) A_Yb_secrecy:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "( tid0, A_2 ) : steps t"
    "s(MV ''Yb'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2_1'', LC ''Time'', s(MV ''Nb'' tid0), s(AV ''A'' tid0),
                          LN ''Na'' tid0, s(MV ''Xb'' tid0),
                          Enc {| LC ''2_2'', s(MV ''Yb'' tid0) |} ( PK ( s(AV ''A'' tid0) ) )
                       |}
                       ( SK ( s(AV ''B'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (B_2_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: B_Yb_secrecy intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_X509_state) A_noninjective_synch:
  assumes facts:
    "roleMap r tid1 = Some A"
    "RLKR(s(AV ''A'' tid1)) ~: reveals t"
    "RLKR(s(AV ''B'' tid1)) ~: reveals t"
    "( tid1, A_3 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some B &
        s(AV ''A'' tid1) = s(MV ''A'' tid2) &
        s(AV ''B'' tid1) = s(AV ''B'' tid2) &
        LN ''Na'' tid1 = s(MV ''Na'' tid2) &
        s(MV ''Nb'' tid1) = LN ''Nb'' tid2 &
        LN ''Ya'' tid1 = s(MV ''Ya'' tid2) &
        s(MV ''Yb'' tid1) = LN ''Yb'' tid2 &
        predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
        predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
        predOrd t (St( tid1, A_1 )) (St( tid1, A_2 )) &
        predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
        predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2_1'', LC ''Time'', s(MV ''Nb'' tid1), s(AV ''A'' tid1),
                          LN ''Na'' tid1, s(MV ''Xb'' tid1),
                          Enc {| LC ''2_2'', s(MV ''Yb'' tid1) |} ( PK ( s(AV ''A'' tid1) ) )
                       |}
                       ( SK ( s(AV ''B'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (B_2_enc_1 tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''1_1'', LC ''Time'', LN ''Na'' tid1, s(AV ''B'' tid1),
                            s(MV ''Xa'' tid2),
                            Enc {| LC ''1_2'', s(MV ''Ya'' tid2) |} ( PK ( s(AV ''B'' tid1) ) )
                         |}
                         ( SK ( s(AV ''A'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (A_1_enc_1 tid3) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_X509_state) B_noninjective_synch:
  assumes facts:
    "roleMap r tid2 = Some B"
    "RLKR(s(AV ''B'' tid2)) ~: reveals t"
    "RLKR(s(MV ''A'' tid2)) ~: reveals t"
    "( tid2, B_3 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some A &
        s(AV ''A'' tid1) = s(MV ''A'' tid2) &
        s(AV ''B'' tid1) = s(AV ''B'' tid2) &
        LN ''Na'' tid1 = s(MV ''Na'' tid2) &
        s(MV ''Nb'' tid1) = LN ''Nb'' tid2 &
        LN ''Ya'' tid1 = s(MV ''Ya'' tid2) &
        s(MV ''Yb'' tid1) = LN ''Yb'' tid2 &
        predOrd t (St( tid1, A_1 )) (St( tid2, B_1 )) &
        predOrd t (St( tid2, B_2 )) (St( tid1, A_2 )) &
        predOrd t (St( tid1, A_3 )) (St( tid2, B_3 )) &
        predOrd t (St( tid1, A_1 )) (St( tid1, A_2 )) &
        predOrd t (St( tid1, A_2 )) (St( tid1, A_3 )) &
        predOrd t (St( tid2, B_1 )) (St( tid2, B_2 )) &
        predOrd t (St( tid2, B_2 )) (St( tid2, B_3 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1_1'', LC ''Time'', s(MV ''Na'' tid2), s(AV ''B'' tid2),
                          s(MV ''Xa'' tid2),
                          Enc {| LC ''1_2'', s(MV ''Ya'' tid2) |} ( PK ( s(AV ''B'' tid2) ) )
                       |}
                       ( SK ( s(MV ''A'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_1_enc_1 tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''3'', s(AV ''B'' tid2), LN ''Nb'' tid2 |}
                         ( SK ( s(AV ''A'' tid3) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (auto dest!: ltk_secrecy)
    next
      case (A_3_enc tid4) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''2_1'', LC ''Time'', LN ''Nb'' tid2, s(AV ''A'' tid3),
                              LN ''Na'' tid4, s(MV ''Xb'' tid4),
                              Enc {| LC ''2_2'', s(MV ''Yb'' tid4) |} ( PK ( s(AV ''A'' tid3) ) )
                           |}
                           ( SK ( s(AV ''B'' tid2) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (auto dest!: ltk_secrecy)
      next
        case (B_2_enc_1 tid5) note_unified facts = this facts
        thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


theory Compiler2
imports Compiler
begin

text {*
The preservation of the source code semantics is already shown in the
parent theory @{theory Compiler}. This here shows the second direction.
*}

section {* Compiler Correctness, Reverse Direction *}

subsection {* Definitions *}

text {* Execution in @{term n} steps for simpler induction *}
primrec
  exec_n :: "instr list \<Rightarrow> config \<Rightarrow> nat \<Rightarrow> config \<Rightarrow> bool"
  ("_/ \<turnstile> (_ \<rightarrow>^_/ _)" [65,0,1000,55] 55)
where
  "P \<turnstile> c \<rightarrow>^0 c' = (c'=c)" |
  "P \<turnstile> c \<rightarrow>^(Suc n) c'' = (\<exists>c'. (P \<turnstile> c \<rightarrow> c') \<and> P \<turnstile> c' \<rightarrow>^n c'')"

text {* The possible successor PCs of an instruction at position @{term n} *}
text_raw{*\snip{isuccsdef}{0}{1}{% *}
definition isuccs :: "instr \<Rightarrow> int \<Rightarrow> int set" where
"isuccs i n = (case i of
  JMP j \<Rightarrow> {n + 1 + j} |
  JMPLESS j \<Rightarrow> {n + 1 + j, n + 1} |
  JMPGE j \<Rightarrow> {n + 1 + j, n + 1} |
  _ \<Rightarrow> {n +1})"
text_raw{*}%endsnip*}

text {* The possible successors PCs of an instruction list *}
definition succs :: "instr list \<Rightarrow> int \<Rightarrow> int set" where
"succs P n = {s. \<exists>i::int. 0 \<le> i \<and> i < size P \<and> s \<in> isuccs (P!!i) (n+i)}"

text {* Possible exit PCs of a program *}
definition exits :: "instr list \<Rightarrow> int set" where
"exits P = succs P 0 - {0..< size P}"

subsection {* Basic properties of @{term exec_n} *}

lemma exec_n_exec:
  "P \<turnstile> c \<rightarrow>^n c' \<Longrightarrow> P \<turnstile> c \<rightarrow>* c'"
  by (induct n arbitrary: c) (auto intro: star.step)

lemma exec_0 [intro!]: "P \<turnstile> c \<rightarrow>^0 c" by simp

lemma exec_Suc:
  "\<lbrakk> P \<turnstile> c \<rightarrow> c'; P \<turnstile> c' \<rightarrow>^n c'' \<rbrakk> \<Longrightarrow> P \<turnstile> c \<rightarrow>^(Suc n) c''"
  by (fastforce simp del: split_paired_Ex)

lemma exec_exec_n:
  "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> \<exists>n. P \<turnstile> c \<rightarrow>^n c'"
  by (induct rule: star.induct) (auto intro: exec_Suc)

lemma exec_eq_exec_n:
  "(P \<turnstile> c \<rightarrow>* c') = (\<exists>n. P \<turnstile> c \<rightarrow>^n c')"
  by (blast intro: exec_exec_n exec_n_exec)

lemma exec_n_Nil [simp]:
  "[] \<turnstile> c \<rightarrow>^k c' = (c' = c \<and> k = 0)"
  by (induct k) (auto simp: exec1_def)

lemma exec1_exec_n [intro!]:
  "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P \<turnstile> c \<rightarrow>^1 c'"
  by (cases c') simp

subsection {* Concrete symbolic execution steps *}

lemma exec_n_step:
  "n \<noteq> n' \<Longrightarrow>
  P \<turnstile> (n,stk,s) \<rightarrow>^k (n',stk',s') =
  (\<exists>c. P \<turnstile> (n,stk,s) \<rightarrow> c \<and> P \<turnstile> c \<rightarrow>^(k - 1) (n',stk',s') \<and> 0 < k)"
  by (cases k) auto

lemma exec1_end:
  "size P <= fst c \<Longrightarrow> \<not> P \<turnstile> c \<rightarrow> c'"
  by (auto simp: exec1_def)

lemma exec_n_end:
  "size P <= (n::int) \<Longrightarrow>
  P \<turnstile> (n,s,stk) \<rightarrow>^k (n',s',stk') = (n' = n \<and> stk'=stk \<and> s'=s \<and> k =0)"
  by (cases k) (auto simp: exec1_end)

lemmas exec_n_simps = exec_n_step exec_n_end

subsection {* Basic properties of @{term succs} *}

lemma succs_simps [simp]:
  "succs [ADD] n = {n + 1}"
  "succs [LOADI v] n = {n + 1}"
  "succs [LOAD x] n = {n + 1}"
  "succs [STORE x] n = {n + 1}"
  "succs [JMP i] n = {n + 1 + i}"
  "succs [JMPGE i] n = {n + 1 + i, n + 1}"
  "succs [JMPLESS i] n = {n + 1 + i, n + 1}"
  by (auto simp: succs_def isuccs_def)

lemma succs_empty [iff]: "succs [] n = {}"
  by (simp add: succs_def)

lemma succs_Cons:
  "succs (x#xs) n = isuccs x n \<union> succs xs (1+n)" (is "_ = ?x \<union> ?xs")
proof
  let ?isuccs = "\<lambda>p P n i::int. 0 \<le> i \<and> i < size P \<and> p \<in> isuccs (P!!i) (n+i)"
  { fix p assume "p \<in> succs (x#xs) n"
    then obtain i::int where isuccs: "?isuccs p (x#xs) n i"
      unfolding succs_def by auto
    have "p \<in> ?x \<union> ?xs"
    proof cases
      assume "i = 0" with isuccs show ?thesis by simp
    next
      assume "i \<noteq> 0"
      with isuccs
      have "?isuccs p xs (1+n) (i - 1)" by auto
      hence "p \<in> ?xs" unfolding succs_def by blast
      thus ?thesis ..
    qed
  }
  thus "succs (x#xs) n \<subseteq> ?x \<union> ?xs" ..

  { fix p assume "p \<in> ?x \<or> p \<in> ?xs"
    hence "p \<in> succs (x#xs) n"
    proof
      assume "p \<in> ?x" thus ?thesis by (fastforce simp: succs_def)
    next
      assume "p \<in> ?xs"
      then obtain i where "?isuccs p xs (1+n) i"
        unfolding succs_def by auto
      hence "?isuccs p (x#xs) n (1+i)"
        by (simp add: algebra_simps)
      thus ?thesis unfolding succs_def by blast
    qed
  }
  thus "?x \<union> ?xs \<subseteq> succs (x#xs) n" by blast
qed

lemma succs_iexec1:
  assumes "c' = iexec (P!!i) (i,s,stk)" "0 \<le> i" "i < size P"
  shows "fst c' \<in> succs P 0"
  using assms by (auto simp: succs_def isuccs_def split: instr.split)

lemma succs_shift:
  "(p - n \<in> succs P 0) = (p \<in> succs P n)"
  by (fastforce simp: succs_def isuccs_def split: instr.split)

lemma inj_op_plus [simp]:
  "inj (op + (i::int))"
  by (metis add_minus_cancel inj_on_inverseI)

lemma succs_set_shift [simp]:
  "op + i ` succs xs 0 = succs xs i"
  by (force simp: succs_shift [where n=i, symmetric] intro: set_eqI)

lemma succs_append [simp]:
  "succs (xs @ ys) n = succs xs n \<union> succs ys (n + size xs)"
  by (induct xs arbitrary: n) (auto simp: succs_Cons algebra_simps)

lemma exits_append [simp]:
  "exits (xs @ ys) = exits xs \<union> (op + (size xs)) ` exits ys -
                     {0..<size xs + size ys}"
  by (auto simp: exits_def image_set_diff)

lemma exits_single:
  "exits [x] = isuccs x 0 - {0}"
  by (auto simp: exits_def succs_def)

lemma exits_Cons:
  "exits (x # xs) = (isuccs x 0 - {0}) \<union> (op + 1) ` exits xs -
                     {0..<1 + size xs}"
  using exits_append [of "[x]" xs]
  by (simp add: exits_single)

lemma exits_empty [iff]: "exits [] = {}" by (simp add: exits_def)

lemma exits_simps [simp]:
  "exits [ADD] = {1}"
  "exits [LOADI v] = {1}"
  "exits [LOAD x] = {1}"
  "exits [STORE x] = {1}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMP i] = {1 + i}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMPGE i] = {1 + i, 1}"
  "i \<noteq> -1 \<Longrightarrow> exits [JMPLESS i] = {1 + i, 1}"
  by (auto simp: exits_def)

lemma acomp_succs [simp]:
  "succs (acomp a) n = {n + 1 .. n + size (acomp a)}"
  by (induct a arbitrary: n) auto

lemma acomp_size:
  "(1::int) \<le> size (acomp a)"
  by (induct a) auto

lemma acomp_exits [simp]:
  "exits (acomp a) = {size (acomp a)}"
  by (auto simp: exits_def acomp_size)

lemma bcomp_succs:
  "0 \<le> i \<Longrightarrow>
  succs (bcomp b f i) n \<subseteq> {n .. n + size (bcomp b f i)}
                           \<union> {n + i + size (bcomp b f i)}"
proof (induction b arbitrary: f i n)
  case (And b1 b2)
  from And.prems
  show ?case
    by (cases f)
       (auto dest: And.IH(1) [THEN subsetD, rotated]
                   And.IH(2) [THEN subsetD, rotated])
qed auto

lemmas bcomp_succsD [dest!] = bcomp_succs [THEN subsetD, rotated]

lemma bcomp_exits:
  fixes i :: int
  shows
  "0 \<le> i \<Longrightarrow>
  exits (bcomp b f i) \<subseteq> {size (bcomp b f i), i + size (bcomp b f i)}"
  by (auto simp: exits_def)

lemma bcomp_exitsD [dest!]:
  "p \<in> exits (bcomp b f i) \<Longrightarrow> 0 \<le> i \<Longrightarrow>
  p = size (bcomp b f i) \<or> p = i + size (bcomp b f i)"
  using bcomp_exits by auto

lemma ccomp_succs:
  "succs (ccomp c) n \<subseteq> {n..n + size (ccomp c)}"
proof (induction c arbitrary: n)
  case SKIP thus ?case by simp
next
  case Assign thus ?case by simp
next
  case (Seq c1 c2)
  from Seq.prems
  show ?case
    by (fastforce dest: Seq.IH [THEN subsetD])
next
  case (If b c1 c2)
  from If.prems
  show ?case
    by (auto dest!: If.IH [THEN subsetD] simp: isuccs_def succs_Cons)
next
  case (While b c)
  from While.prems
  show ?case by (auto dest!: While.IH [THEN subsetD])
qed

lemma ccomp_exits:
  "exits (ccomp c) \<subseteq> {size (ccomp c)}"
  using ccomp_succs [of c 0] by (auto simp: exits_def)

lemma ccomp_exitsD [dest!]:
  "p \<in> exits (ccomp c) \<Longrightarrow> p = size (ccomp c)"
  using ccomp_exits by auto

subsection {* Splitting up machine executions *}

lemma exec1_split:
  fixes i j :: int
  shows
  "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (j,s') \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size c \<Longrightarrow>
  c \<turnstile> (i,s) \<rightarrow> (j - size P, s')"
  by (auto split: instr.splits simp: exec1_def)

lemma exec_n_split:
  fixes i j :: int
  assumes "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow>^n (j, s')"
          "0 \<le> i" "i < size c"
          "j \<notin> {size P ..< size P + size c}"
  shows "\<exists>s'' (i'::int) k m.
                   c \<turnstile> (i, s) \<rightarrow>^k (i', s'') \<and>
                   i' \<in> exits c \<and>
                   P @ c @ P' \<turnstile> (size P + i', s'') \<rightarrow>^m (j, s') \<and>
                   n = k + m"
using assms proof (induction n arbitrary: i j s)
  case 0
  thus ?case by simp
next
  case (Suc n)
  have i: "0 \<le> i" "i < size c" by fact+
  from Suc.prems
  have j: "\<not> (size P \<le> j \<and> j < size P + size c)" by simp
  from Suc.prems
  obtain i0 s0 where
    step: "P @ c @ P' \<turnstile> (size P + i, s) \<rightarrow> (i0,s0)" and
    rest: "P @ c @ P' \<turnstile> (i0,s0) \<rightarrow>^n (j, s')"
    by clarsimp

  from step i
  have c: "c \<turnstile> (i,s) \<rightarrow> (i0 - size P, s0)" by (rule exec1_split)

  have "i0 = size P + (i0 - size P) " by simp
  then obtain j0::int where j0: "i0 = size P + j0"  ..

  note split_paired_Ex [simp del]

  { assume "j0 \<in> {0 ..< size c}"
    with j0 j rest c
    have ?case
      by (fastforce dest!: Suc.IH intro!: exec_Suc)
  } moreover {
    assume "j0 \<notin> {0 ..< size c}"
    moreover
    from c j0 have "j0 \<in> succs c 0"
      by (auto dest: succs_iexec1 simp: exec1_def simp del: iexec.simps)
    ultimately
    have "j0 \<in> exits c" by (simp add: exits_def)
    with c j0 rest
    have ?case by fastforce
  }
  ultimately
  show ?case by cases
qed

lemma exec_n_drop_right:
  fixes j :: int
  assumes "c @ P' \<turnstile> (0, s) \<rightarrow>^n (j, s')" "j \<notin> {0..<size c}"
  shows "\<exists>s'' i' k m.
          (if c = [] then s'' = s \<and> i' = 0 \<and> k = 0
           else c \<turnstile> (0, s) \<rightarrow>^k (i', s'') \<and>
           i' \<in> exits c) \<and>
           c @ P' \<turnstile> (i', s'') \<rightarrow>^m (j, s') \<and>
           n = k + m"
  using assms
  by (cases "c = []")
     (auto dest: exec_n_split [where P="[]", simplified])

text {*
  Dropping the left context of a potentially incomplete execution of @{term c}.
*}

lemma exec1_drop_left:
  fixes i n :: int
  assumes "P1 @ P2 \<turnstile> (i, s, stk) \<rightarrow> (n, s', stk')" and "size P1 \<le> i"
  shows "P2 \<turnstile> (i - size P1, s, stk) \<rightarrow> (n - size P1, s', stk')"
proof -
  have "i = size P1 + (i - size P1)" by simp
  then obtain i' :: int where "i = size P1 + i'" ..
  moreover
  have "n = size P1 + (n - size P1)" by simp
  then obtain n' :: int where "n = size P1 + n'" ..
  ultimately
  show ?thesis using assms
    by (clarsimp simp: exec1_def simp del: iexec.simps)
qed

lemma exec_n_drop_left:
  fixes i n :: int
  assumes "P @ P' \<turnstile> (i, s, stk) \<rightarrow>^k (n, s', stk')"
          "size P \<le> i" "exits P' \<subseteq> {0..}"
  shows "P' \<turnstile> (i - size P, s, stk) \<rightarrow>^k (n - size P, s', stk')"
using assms proof (induction k arbitrary: i s stk)
  case 0 thus ?case by simp
next
  case (Suc k)
  from Suc.prems
  obtain i' s'' stk'' where
    step: "P @ P' \<turnstile> (i, s, stk) \<rightarrow> (i', s'', stk'')" and
    rest: "P @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^k (n, s', stk')"
    by auto
  from step `size P \<le> i`
  have *: "P' \<turnstile> (i - size P, s, stk) \<rightarrow> (i' - size P, s'', stk'')"
    by (rule exec1_drop_left)
  then have "i' - size P \<in> succs P' 0"
    by (fastforce dest!: succs_iexec1 simp: exec1_def simp del: iexec.simps)
  with `exits P' \<subseteq> {0..}`
  have "size P \<le> i'" by (auto simp: exits_def)
  from rest this `exits P' \<subseteq> {0..}`
  have "P' \<turnstile> (i' - size P, s'', stk'') \<rightarrow>^k (n - size P, s', stk')"
    by (rule Suc.IH)
  with * show ?case by auto
qed

lemmas exec_n_drop_Cons =
  exec_n_drop_left [where P="[instr]", simplified] for instr

definition
  "closed P \<longleftrightarrow> exits P \<subseteq> {size P}"

lemma ccomp_closed [simp, intro!]: "closed (ccomp c)"
  using ccomp_exits by (auto simp: closed_def)

lemma acomp_closed [simp, intro!]: "closed (acomp c)"
  by (simp add: closed_def)

lemma exec_n_split_full:
  fixes j :: int
  assumes exec: "P @ P' \<turnstile> (0,s,stk) \<rightarrow>^k (j, s', stk')"
  assumes P: "size P \<le> j"
  assumes closed: "closed P"
  assumes exits: "exits P' \<subseteq> {0..}"
  shows "\<exists>k1 k2 s'' stk''. P \<turnstile> (0,s,stk) \<rightarrow>^k1 (size P, s'', stk'') \<and>
                           P' \<turnstile> (0,s'',stk'') \<rightarrow>^k2 (j - size P, s', stk')"
proof (cases "P")
  case Nil with exec
  show ?thesis by fastforce
next
  case Cons
  hence "0 < size P" by simp
  with exec P closed
  obtain k1 k2 s'' stk'' where
    1: "P \<turnstile> (0,s,stk) \<rightarrow>^k1 (size P, s'', stk'')" and
    2: "P @ P' \<turnstile> (size P,s'',stk'') \<rightarrow>^k2 (j, s', stk')"
    by (auto dest!: exec_n_split [where P="[]" and i=0, simplified]
             simp: closed_def)
  moreover
  have "j = size P + (j - size P)" by simp
  then obtain j0 :: int where "j = size P + j0" ..
  ultimately
  show ?thesis using exits
    by (fastforce dest: exec_n_drop_left)
qed

subsection {* Correctness theorem *}

lemma acomp_neq_Nil [simp]:
  "acomp a \<noteq> []"
  by (induct a) auto

lemma acomp_exec_n [dest!]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>^n (size (acomp a),s',stk') \<Longrightarrow>
  s' = s \<and> stk' = aval a s#stk"
proof (induction a arbitrary: n s' stk stk')
  case (Plus a1 a2)
  let ?sz = "size (acomp a1) + (size (acomp a2) + 1)"
  from Plus.prems
  have "acomp a1 @ acomp a2 @ [ADD] \<turnstile> (0,s,stk) \<rightarrow>^n (?sz, s', stk')"
    by (simp add: algebra_simps)

  then obtain n1 s1 stk1 n2 s2 stk2 n3 where
    "acomp a1 \<turnstile> (0,s,stk) \<rightarrow>^n1 (size (acomp a1), s1, stk1)"
    "acomp a2 \<turnstile> (0,s1,stk1) \<rightarrow>^n2 (size (acomp a2), s2, stk2)"
       "[ADD] \<turnstile> (0,s2,stk2) \<rightarrow>^n3 (1, s', stk')"
    by (auto dest!: exec_n_split_full)

  thus ?case by (fastforce dest: Plus.IH simp: exec_n_simps exec1_def)
qed (auto simp: exec_n_simps exec1_def)

lemma bcomp_split:
  fixes i j :: int
  assumes "bcomp b f i @ P' \<turnstile> (0, s, stk) \<rightarrow>^n (j, s', stk')"
          "j \<notin> {0..<size (bcomp b f i)}" "0 \<le> i"
  shows "\<exists>s'' stk'' (i'::int) k m.
           bcomp b f i \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'') \<and>
           (i' = size (bcomp b f i) \<or> i' = i + size (bcomp b f i)) \<and>
           bcomp b f i @ P' \<turnstile> (i', s'', stk'') \<rightarrow>^m (j, s', stk') \<and>
           n = k + m"
  using assms by (cases "bcomp b f i = []") (fastforce dest!: exec_n_drop_right)+

lemma bcomp_exec_n [dest]:
  fixes i j :: int
  assumes "bcomp b f j \<turnstile> (0, s, stk) \<rightarrow>^n (i, s', stk')"
          "size (bcomp b f j) \<le> i" "0 \<le> j"
  shows "i = size(bcomp b f j) + (if f = bval b s then j else 0) \<and>
         s' = s \<and> stk' = stk"
using assms proof (induction b arbitrary: f j i n s' stk')
  case Bc thus ?case
    by (simp split: if_split_asm add: exec_n_simps exec1_def)
next
  case (Not b)
  from Not.prems show ?case
    by (fastforce dest!: Not.IH)
next
  case (And b1 b2)

  let ?b2 = "bcomp b2 f j"
  let ?m  = "if f then size ?b2 else size ?b2 + j"
  let ?b1 = "bcomp b1 False ?m"

  have j: "size (bcomp (And b1 b2) f j) \<le> i" "0 \<le> j" by fact+

  from And.prems
  obtain s'' stk'' and i'::int and k m where
    b1: "?b1 \<turnstile> (0, s, stk) \<rightarrow>^k (i', s'', stk'')"
        "i' = size ?b1 \<or> i' = ?m + size ?b1" and
    b2: "?b2 \<turnstile> (i' - size ?b1, s'', stk'') \<rightarrow>^m (i - size ?b1, s', stk')"
    by (auto dest!: bcomp_split dest: exec_n_drop_left)
  from b1 j
  have "i' = size ?b1 + (if \<not>bval b1 s then ?m else 0) \<and> s'' = s \<and> stk'' = stk"
    by (auto dest!: And.IH)
  with b2 j
  show ?case
    by (fastforce dest!: And.IH simp: exec_n_end split: if_split_asm)
next
  case Less
  thus ?case by (auto dest!: exec_n_split_full simp: exec_n_simps exec1_def) (* takes time *)
qed

lemma ccomp_empty [elim!]:
  "ccomp c = [] \<Longrightarrow> (c,s) \<Rightarrow> s"
  by (induct c) auto

declare assign_simp [simp]

lemma ccomp_exec_n:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>^n (size(ccomp c),t,stk')
  \<Longrightarrow> (c,s) \<Rightarrow> t \<and> stk'=stk"
proof (induction c arbitrary: s t stk stk' n)
  case SKIP
  thus ?case by auto
next
  case (Assign x a)
  thus ?case
    by simp (fastforce dest!: exec_n_split_full simp: exec_n_simps exec1_def)
next
  case (Seq c1 c2)
  thus ?case by (fastforce dest!: exec_n_split_full)
next
  case (If b c1 c2)
  note If.IH [dest!]

  let ?if = "IF b THEN c1 ELSE c2"
  let ?cs = "ccomp ?if"
  let ?bcomp = "bcomp b False (size (ccomp c1) + 1)"

  from `?cs \<turnstile> (0,s,stk) \<rightarrow>^n (size ?cs,t,stk')`
  obtain i' :: int and k m s'' stk'' where
    cs: "?cs \<turnstile> (i',s'',stk'') \<rightarrow>^m (size ?cs,t,stk')" and
        "?bcomp \<turnstile> (0,s,stk) \<rightarrow>^k (i', s'', stk'')"
        "i' = size ?bcomp \<or> i' = size ?bcomp + size (ccomp c1) + 1"
    by (auto dest!: bcomp_split)

  hence i':
    "s''=s" "stk'' = stk"
    "i' = (if bval b s then size ?bcomp else size ?bcomp+size(ccomp c1)+1)"
    by auto

  with cs have cs':
    "ccomp c1@JMP (size (ccomp c2))#ccomp c2 \<turnstile>
       (if bval b s then 0 else size (ccomp c1)+1, s, stk) \<rightarrow>^m
       (1 + size (ccomp c1) + size (ccomp c2), t, stk')"
    by (fastforce dest: exec_n_drop_left simp: exits_Cons isuccs_def algebra_simps)

  show ?case
  proof (cases "bval b s")
    case True with cs'
    show ?thesis
      by simp
         (fastforce dest: exec_n_drop_right
                   split: if_split_asm
                   simp: exec_n_simps exec1_def)
  next
    case False with cs'
    show ?thesis
      by (auto dest!: exec_n_drop_Cons exec_n_drop_left
               simp: exits_Cons isuccs_def)
  qed
next
  case (While b c)

  from While.prems
  show ?case
  proof (induction n arbitrary: s rule: nat_less_induct)
    case (1 n)

    { assume "\<not> bval b s"
      with "1.prems"
      have ?case
        by simp
           (fastforce dest!: bcomp_exec_n bcomp_split simp: exec_n_simps)
    } moreover {
      assume b: "bval b s"
      let ?c0 = "WHILE b DO c"
      let ?cs = "ccomp ?c0"
      let ?bs = "bcomp b False (size (ccomp c) + 1)"
      let ?jmp = "[JMP (-((size ?bs + size (ccomp c) + 1)))]"

      from "1.prems" b
      obtain k where
        cs: "?cs \<turnstile> (size ?bs, s, stk) \<rightarrow>^k (size ?cs, t, stk')" and
        k:  "k \<le> n"
        by (fastforce dest!: bcomp_split)

      have ?case
      proof cases
        assume "ccomp c = []"
        with cs k
        obtain m where
          "?cs \<turnstile> (0,s,stk) \<rightarrow>^m (size (ccomp ?c0), t, stk')"
          "m < n"
          by (auto simp: exec_n_step [where k=k] exec1_def)
        with "1.IH"
        show ?case by blast
      next
        assume "ccomp c \<noteq> []"
        with cs
        obtain m m' s'' stk'' where
          c: "ccomp c \<turnstile> (0, s, stk) \<rightarrow>^m' (size (ccomp c), s'', stk'')" and
          rest: "?cs \<turnstile> (size ?bs + size (ccomp c), s'', stk'') \<rightarrow>^m
                       (size ?cs, t, stk')" and
          m: "k = m + m'"
          by (auto dest: exec_n_split [where i=0, simplified])
        from c
        have "(c,s) \<Rightarrow> s''" and stk: "stk'' = stk"
          by (auto dest!: While.IH)
        moreover
        from rest m k stk
        obtain k' where
          "?cs \<turnstile> (0, s'', stk) \<rightarrow>^k' (size ?cs, t, stk')"
          "k' < n"
          by (auto simp: exec_n_step [where k=m] exec1_def)
        with "1.IH"
        have "(?c0, s'') \<Rightarrow> t \<and> stk' = stk" by blast
        ultimately
        show ?case using b by blast
      qed
    }
    ultimately show ?case by cases
  qed
qed

theorem ccomp_exec:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk') \<Longrightarrow> (c,s) \<Rightarrow> t"
  by (auto dest: exec_exec_n ccomp_exec_n)

corollary ccomp_sound:
  "ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)  \<longleftrightarrow>  (c,s) \<Rightarrow> t"
  by (blast intro!: ccomp_exec ccomp_bigstep)

end


(* Author: Tobias Nipkow *)

subsection "Annotated Commands"

theory ACom
imports Com
begin

datatype 'a acom =
  SKIP 'a                           ("SKIP {_}" 61) |
  Assign vname aexp 'a              ("(_ ::= _/ {_})" [1000, 61, 0] 61) |
  Seq "('a acom)" "('a acom)"       ("_;;//_"  [60, 61] 60) |
  If bexp 'a "('a acom)" 'a "('a acom)" 'a
    ("(IF _/ THEN ({_}/ _)/ ELSE ({_}/ _)//{_})"  [0, 0, 0, 61, 0, 0] 61) |
  While 'a bexp 'a "('a acom)" 'a
    ("({_}//WHILE _//DO ({_}//_)//{_})"  [0, 0, 0, 61, 0] 61)

notation com.SKIP ("SKIP")

text_raw\<open>\snip{stripdef}{1}{1}{%\<close>
fun strip :: "'a acom \<Rightarrow> com" where
"strip (SKIP {P}) = SKIP" |
"strip (x ::= e {P}) = x ::= e" |
"strip (C\<^sub>1;;C\<^sub>2) = strip C\<^sub>1;; strip C\<^sub>2" |
"strip (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {P}) =
  IF b THEN strip C\<^sub>1 ELSE strip C\<^sub>2" |
"strip ({I} WHILE b DO {P} C {Q}) = WHILE b DO strip C"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{asizedef}{1}{1}{%\<close>
fun asize :: "com \<Rightarrow> nat" where
"asize SKIP = 1" |
"asize (x ::= e) = 1" |
"asize (C\<^sub>1;;C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2" |
"asize (IF b THEN C\<^sub>1 ELSE C\<^sub>2) = asize C\<^sub>1 + asize C\<^sub>2 + 3" |
"asize (WHILE b DO C) = asize C + 3"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{annotatedef}{1}{1}{%\<close>
definition shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a" where
"shift f n = (\<lambda>p. f(p+n))"

fun annotate :: "(nat \<Rightarrow> 'a) \<Rightarrow> com \<Rightarrow> 'a acom" where
"annotate f SKIP = SKIP {f 0}" |
"annotate f (x ::= e) = x ::= e {f 0}" |
"annotate f (c\<^sub>1;;c\<^sub>2) = annotate f c\<^sub>1;; annotate (shift f (asize c\<^sub>1)) c\<^sub>2" |
"annotate f (IF b THEN c\<^sub>1 ELSE c\<^sub>2) =
  IF b THEN {f 0} annotate (shift f 1) c\<^sub>1
  ELSE {f(asize c\<^sub>1 + 1)} annotate (shift f (asize c\<^sub>1 + 2)) c\<^sub>2
  {f(asize c\<^sub>1 + asize c\<^sub>2 + 2)}" |
"annotate f (WHILE b DO c) =
  {f 0} WHILE b DO {f 1} annotate (shift f 2) c {f(asize c + 2)}"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{annosdef}{1}{1}{%\<close>
fun annos :: "'a acom \<Rightarrow> 'a list" where
"annos (SKIP {P}) = [P]" |
"annos (x ::= e {P}) = [P]" |
"annos (C\<^sub>1;;C\<^sub>2) = annos C\<^sub>1 @ annos C\<^sub>2" |
"annos (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  P\<^sub>1 # annos C\<^sub>1 @  P\<^sub>2 # annos C\<^sub>2 @ [Q]" |
"annos ({I} WHILE b DO {P} C {Q}) = I # P # annos C @ [Q]"
text_raw\<open>}%endsnip\<close>

definition anno :: "'a acom \<Rightarrow> nat \<Rightarrow> 'a" where
"anno C p = annos C ! p"

definition post :: "'a acom \<Rightarrow>'a" where
"post C = last(annos C)"

text_raw\<open>\snip{mapacomdef}{1}{2}{%\<close>
fun map_acom :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a acom \<Rightarrow> 'b acom" where
"map_acom f (SKIP {P}) = SKIP {f P}" |
"map_acom f (x ::= e {P}) = x ::= e {f P}" |
"map_acom f (C\<^sub>1;;C\<^sub>2) = map_acom f C\<^sub>1;; map_acom f C\<^sub>2" |
"map_acom f (IF b THEN {P\<^sub>1} C\<^sub>1 ELSE {P\<^sub>2} C\<^sub>2 {Q}) =
  IF b THEN {f P\<^sub>1} map_acom f C\<^sub>1 ELSE {f P\<^sub>2} map_acom f C\<^sub>2
  {f Q}" |
"map_acom f ({I} WHILE b DO {P} C {Q}) =
  {f I} WHILE b DO {f P} map_acom f C {f Q}"
text_raw\<open>}%endsnip\<close>

lemma annos_ne: "annos C \<noteq> []"
by(induction C) auto

lemma strip_annotate[simp]: "strip(annotate f c) = c"
by(induction c arbitrary: f) auto

lemma length_annos_annotate[simp]: "length (annos (annotate f c)) = asize c"
by(induction c arbitrary: f) auto

lemma size_annos: "size(annos C) = asize(strip C)"
by(induction C)(auto)

lemma size_annos_same: "strip C1 = strip C2 \<Longrightarrow> size(annos C1) = size(annos C2)"
apply(induct C2 arbitrary: C1)
apply(case_tac C1, simp_all)+
done

lemmas size_annos_same2 = eqTrueI[OF size_annos_same]

lemma anno_annotate[simp]: "p < asize c \<Longrightarrow> anno (annotate f c) p = f p"
apply(induction c arbitrary: f p)
apply (auto simp: anno_def nth_append nth_Cons numeral_eq_Suc shift_def
            split: nat.split)
  apply (metis add_Suc_right add_diff_inverse add.commute)
 apply(rule_tac f=f in arg_cong)
 apply arith
apply (metis less_Suc_eq)
done

lemma eq_acom_iff_strip_annos:
  "C1 = C2 \<longleftrightarrow> strip C1 = strip C2 \<and> annos C1 = annos C2"
apply(induction C1 arbitrary: C2)
apply(case_tac C2, auto simp: size_annos_same2)+
done

lemma eq_acom_iff_strip_anno:
  "C1=C2 \<longleftrightarrow> strip C1 = strip C2 \<and> (\<forall>p<size(annos C1). anno C1 p = anno C2 p)"
by(auto simp add: eq_acom_iff_strip_annos anno_def
     list_eq_iff_nth_eq size_annos_same2)

lemma post_map_acom[simp]: "post(map_acom f C) = f(post C)"
by (induction C) (auto simp: post_def last_append annos_ne)

lemma strip_map_acom[simp]: "strip (map_acom f C) = strip C"
by (induction C) auto

lemma anno_map_acom: "p < size(annos C) \<Longrightarrow> anno (map_acom f C) p = f(anno C p)"
apply(induction C arbitrary: p)
apply(auto simp: anno_def nth_append nth_Cons' size_annos)
done

lemma strip_eq_SKIP:
  "strip C = SKIP \<longleftrightarrow> (\<exists>P. C = SKIP {P})"
by (cases C) simp_all

lemma strip_eq_Assign:
  "strip C = x::=e \<longleftrightarrow> (\<exists>P. C = x::=e {P})"
by (cases C) simp_all

lemma strip_eq_Seq:
  "strip C = c1;;c2 \<longleftrightarrow> (\<exists>C1 C2. C = C1;;C2 & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_If:
  "strip C = IF b THEN c1 ELSE c2 \<longleftrightarrow>
  (\<exists>P1 P2 C1 C2 Q. C = IF b THEN {P1} C1 ELSE {P2} C2 {Q} & strip C1 = c1 & strip C2 = c2)"
by (cases C) simp_all

lemma strip_eq_While:
  "strip C = WHILE b DO c1 \<longleftrightarrow>
  (\<exists>I P C1 Q. C = {I} WHILE b DO {P} C1 {Q} & strip C1 = c1)"
by (cases C) simp_all

lemma set_annos_anno[simp]: "set (annos (annotate (\<lambda>p. a) c)) = {a}"
by(induction c) simp_all

lemma post_in_annos: "post C \<in> set(annos C)"
by(auto simp: post_def annos_ne)

lemma post_anno_asize: "post C = anno C (size(annos C) - 1)"
by(simp add: post_def last_conv_nth[OF annos_ne] anno_def)

end


section {* Alphabetised Predicates *}

theory utp_pred
imports
  utp_expr
  utp_subst
  utp_tactics
begin

text {* In this theory we begin to create an Isabelle version of the alphabetised predicate calculus
  that is described in Chapter 1 of the UTP book~\cite{Hoare&98}. *}

subsection {* Predicate type and syntax *}

text {* An alphabetised predicate is a simply a boolean valued expression. *}

type_synonym '\<alpha> upred = "(bool, '\<alpha>) uexpr"

translations
  (type) "'\<alpha> upred" <= (type) "(bool, '\<alpha>) uexpr"

text {* We want to remain as close as possible to the mathematical UTP syntax, but also
        want to be conservative with HOL. For this reason we chose not to steal syntax
        from HOL, but where possible use polymorphism to allow selection of the appropriate
        operator (UTP vs. HOL). Thus we will first remove the standard syntax for conjunction,
        disjunction, and negation, and replace these with adhoc overloaded definitions. We
        similarly use polymorphic constants for the other predicate calculus operators. *}

purge_notation
  conj (infixr "\<and>" 35) and
  disj (infixr "\<or>" 30) and
  Not ("\<not> _" [40] 40)

consts
  utrue  :: "'a" ("true")
  ufalse :: "'a" ("false")
  uconj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<and>" 35)
  udisj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<or>" 30)
  uimpl  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Rightarrow>" 25)
  uiff   :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Leftrightarrow>" 25)
  unot   :: "'a \<Rightarrow> 'a" ("\<not> _" [40] 40)
  uex    :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> 'p \<Rightarrow> 'p"
  uall   :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> 'p \<Rightarrow> 'p"
  ushEx  :: "['a \<Rightarrow> 'p] \<Rightarrow> 'p"
  ushAll :: "['a \<Rightarrow> 'p] \<Rightarrow> 'p"

adhoc_overloading
  uconj conj and
  udisj disj and
  unot Not

text {* We set up two versions of each of the quantifiers: @{const uex} / @{const uall} and
        @{const ushEx} / @{const ushAll}. The former pair allows quantification of UTP variables,
        whilst the latter allows quantification of HOL variables in concert with the literal
        expression constructor @{term "\<guillemotleft>x\<guillemotright>"}. Both varieties will be needed at various points.
        Syntactically they are distinguished by a boldface quantifier
        for the HOL versions (achieved by the "bold" escape in Isabelle). *}

nonterminal idt_list

syntax
  "_idt_el"  :: "idt \<Rightarrow> idt_list" ("_")
  "_idt_list" :: "idt \<Rightarrow> idt_list \<Rightarrow> idt_list" ("(_,/ _)" [0, 1])
  "_uex"     :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<exists> _ \<bullet> _" [0, 10] 10)
  "_uall"    :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<forall> _ \<bullet> _" [0, 10] 10)
  "_ushEx"   :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<bullet> _" [0, 10] 10)
  "_ushAll"  :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<bullet> _" [0, 10] 10)
  "_ushBEx"  :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_ushBAll" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_ushGAll" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_ushGtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ > _ \<bullet> _" [0, 0, 10] 10)
  "_ushLtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ < _ \<bullet> _" [0, 0, 10] 10)
  "_uvar_res" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>v" 90)

translations
  "_uex x P"                   == "CONST uex x P"
  "_uex (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_uex (x +\<^sub>L y) P"
  "_uall x P"                  == "CONST uall x P"
  "_uall (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_uall (x +\<^sub>L y) P"
  "_ushEx x P"                 == "CONST ushEx (\<lambda> x. P)"
  "\<^bold>\<exists> x \<in> A \<bullet> P"                => "\<^bold>\<exists> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<and> P"
  "_ushAll x P"                == "CONST ushAll (\<lambda> x. P)"
  "\<^bold>\<forall> x \<in> A \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<Rightarrow> P"
  "\<^bold>\<forall> x | P \<bullet> Q"                => "\<^bold>\<forall> x \<bullet> P \<Rightarrow> Q"
  "\<^bold>\<forall> x > y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> >\<^sub>u y \<Rightarrow> P"
  "\<^bold>\<forall> x < y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> <\<^sub>u y \<Rightarrow> P"

subsection {* Predicate operators *}

text {* We chose to maximally reuse definitions and laws built into HOL. For this reason,
        when introducing the core operators we proceed by lifting operators from the
        polymorphic algebraic hierarchy of HOL. Thus the initial definitions take
        place in the context of type class instantiations. We first introduce our own
        class called \emph{refine} that will add the refinement operator syntax to
        the HOL partial order class. *}

class refine = order

abbreviation refineBy :: "'a::refine \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<sqsubseteq>" 50) where
"P \<sqsubseteq> Q \<equiv> less_eq Q P"

text {* Since, on the whole, lattices in UTP are the opposite way up to the standard definitions
        in HOL, we syntactically invert the lattice operators. This is the one exception where
        we do steal HOL syntax, but I think it makes sense for UTP. Indeed we make this
        inversion for all of the lattice operators. *}

purge_notation Lattices.inf (infixl "\<sqinter>" 70)
notation Lattices.inf (infixl "\<squnion>" 70)
purge_notation Lattices.sup (infixl "\<squnion>" 65)
notation Lattices.sup (infixl "\<sqinter>" 65)

purge_notation Inf ("\<Sqinter>_" [900] 900)
notation Inf ("\<Squnion>_" [900] 900)
purge_notation Sup ("\<Squnion>_" [900] 900)
notation Sup ("\<Sqinter>_" [900] 900)

purge_notation Orderings.bot ("\<bottom>")
notation Orderings.bot ("\<top>")
purge_notation Orderings.top ("\<top>")
notation Orderings.top ("\<bottom>")

purge_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)

text {* We trivially instantiate our refinement class *}

instance uexpr :: (order, type) refine ..

-- {* Configure transfer law for refinement for the fast relational tactics. *}

theorem upred_ref_iff [uexpr_transfer_laws]:
"(P \<sqsubseteq> Q) = (\<forall>b. \<lbrakk>Q\<rbrakk>\<^sub>e b \<longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>e b)"
apply (transfer)
apply (clarsimp)
done

text {* Next we introduce the lattice operators, which is again done by lifting. *}

instantiation uexpr :: (lattice, type) lattice
begin
  lift_definition sup_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. Lattices.sup (P A) (Q A)" .
  lift_definition inf_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. Lattices.inf (P A) (Q A)" .
instance
  by (intro_classes) (transfer, auto)+
end

instantiation uexpr :: (bounded_lattice, type) bounded_lattice
begin
  lift_definition bot_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. Orderings.bot" .
  lift_definition top_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. Orderings.top" .
instance
  by (intro_classes) (transfer, auto)+
end

lemma top_uexpr_rep_eq [simp]:
  "\<lbrakk>Orderings.bot\<rbrakk>\<^sub>e b = False"
  by (transfer, auto)

lemma bot_uexpr_rep_eq [simp]:
  "\<lbrakk>Orderings.top\<rbrakk>\<^sub>e b = True"
  by (transfer, auto)

instance uexpr :: (distrib_lattice, type) distrib_lattice
  by (intro_classes) (transfer, rule ext, auto simp add: sup_inf_distrib1)

text {* Finally we show that predicates form a Boolean algebra (under the lattice operators),
  a complete lattice, a completely distribute lattice, and a complete boolean algebra. This
  equip us with a very complete theory for basic logical propositions. *}

instance uexpr :: (boolean_algebra, type) boolean_algebra
apply (intro_classes, unfold uexpr_defs; transfer, rule ext)
apply (simp_all add: sup_inf_distrib1 diff_eq)
done

instantiation uexpr :: (complete_lattice, type) complete_lattice
begin
  lift_definition Inf_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. INF P:PS. P(A)" .
  lift_definition Sup_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. SUP P:PS. P(A)" .
instance
  by (intro_classes)
     (transfer, auto intro: INF_lower SUP_upper simp add: INF_greatest SUP_least)+
end

instance uexpr :: (complete_distrib_lattice, type) complete_distrib_lattice
  apply (intro_classes)
  apply (transfer, rule ext, auto)
  using sup_INF apply fastforce
  apply (transfer, rule ext, auto)
  using inf_SUP apply fastforce
done

instance uexpr :: (complete_boolean_algebra, type) complete_boolean_algebra ..

text {* From the complete lattice, we can also define and give syntax for the fixed-point operators.
  Like the lattice operators, these are reversed in UTP. *}

syntax
  "_mu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<mu> _ \<bullet> _" [0, 10] 10)
  "_nu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<nu> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<nu> X \<bullet> P" == "CONST lfp (\<lambda> X. P)"
  "\<mu> X \<bullet> P" == "CONST gfp (\<lambda> X. P)"

text {* With the lattice operators defined, we can proceed to give definitions for the
        standard predicate operators in terms of them. *}

definition "true_upred  = (Orderings.top :: '\<alpha> upred)"
definition "false_upred = (Orderings.bot :: '\<alpha> upred)"
definition "conj_upred  = (Lattices.inf :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "disj_upred  = (Lattices.sup :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "not_upred   = (uminus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "diff_upred  = (minus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"

abbreviation Conj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<And>_" [900] 900) where
"\<And> A \<equiv> \<Squnion> A"

abbreviation Disj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<Or>_" [900] 900) where
"\<Or> A \<equiv> \<Sqinter> A"

notation
  conj_upred (infixr "\<and>\<^sub>p" 35) and
  disj_upred (infixr "\<or>\<^sub>p" 30)

text {* Perhaps slightly confusingly, the UTP infimum is the HOL supremum and vice-versa. This is
  because, again, in UTP the lattice is inverted due to the definition of refinement and a desire
  to have miracle at the top, and abort at the bottom. *}

lift_definition UINF :: "('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, '\<alpha>) uexpr) \<Rightarrow> ('b, '\<alpha>) uexpr"
is "\<lambda> P F b. Sup {\<lbrakk>F x\<rbrakk>\<^sub>eb | x. \<lbrakk>P x\<rbrakk>\<^sub>eb}" .

lift_definition USUP :: "('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, '\<alpha>) uexpr) \<Rightarrow> ('b, '\<alpha>) uexpr"
is "\<lambda> P F b. Inf {\<lbrakk>F x\<rbrakk>\<^sub>eb | x. \<lbrakk>P x\<rbrakk>\<^sub>eb}" .

declare UINF_def [upred_defs]
declare USUP_def [upred_defs]

syntax
  "_USup"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<And> _ \<bullet> _" [0, 10] 10)
  "_USup"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<Squnion> _ \<bullet> _" [0, 10] 10)
  "_USup_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<And> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_USup_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Squnion> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_USUP"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<And> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_USUP"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Squnion> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_UInf"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<Or> _ \<bullet> _" [0, 10] 10)
  "_UInf"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<Sqinter> _ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Or> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Sqinter> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_UINF"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Or> _ | _ \<bullet> _" [0, 10] 10)
  "_UINF"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Sqinter> _ | _ \<bullet> _" [0, 10] 10)

translations
  "\<Sqinter> x | P \<bullet> F" => "CONST UINF (\<lambda> x. P) (\<lambda> x. F)"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x | true \<bullet> F"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x | true \<bullet> F"
  "\<Sqinter> x \<in> A \<bullet> F" => "\<Sqinter> x | \<guillemotleft>x\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Sqinter> x \<in> A \<bullet> F" <= "\<Sqinter> x | \<guillemotleft>y\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Sqinter> x | P \<bullet> F" <= "CONST UINF (\<lambda> y. P) (\<lambda> x. F)"
  "\<Sqinter> x | P \<bullet> F(x)" <= "CONST UINF (\<lambda> x. P) F"
  "\<Squnion> x | P \<bullet> F" => "CONST USUP (\<lambda> x. P) (\<lambda> x. F)"
  "\<Squnion> x \<bullet> F"     == "\<Squnion> x | true \<bullet> F"
  "\<Squnion> x \<in> A \<bullet> F" => "\<Squnion> x | \<guillemotleft>x\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Squnion> x \<in> A \<bullet> F" <= "\<Squnion> x | \<guillemotleft>y\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Squnion> x | P \<bullet> F" <= "CONST USUP (\<lambda> y. P) (\<lambda> x. F)"
  "\<Squnion> x | P \<bullet> F(x)" <= "CONST USUP (\<lambda> x. P) F"

text {* We also define the other predicate operators *}

lift_definition impl::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longrightarrow> Q A" .

lift_definition iff_upred ::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longleftrightarrow> Q A" .

lift_definition ex :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<exists> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition shEx ::"['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" is
"\<lambda> P A. \<exists> x. (P x) A" .

lift_definition all :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<forall> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition shAll ::"['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" is
"\<lambda> P A. \<forall> x. (P x) A" .

text {* We define the following operator which is dual of existential quantification. It hides the
  valuation of variables other than $x$ through existential quantification. *}

lift_definition var_res :: "'\<alpha> upred \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred" is
"\<lambda> P x b. \<exists> b'. P (b' \<oplus>\<^sub>L b on x)" .

translations
  "_uvar_res P a" \<rightleftharpoons> "CONST var_res P a"

text {* We have to add a u subscript to the closure operator as I don't want to override the syntax
        for HOL lists (we'll be using them later). *}

lift_definition closure::"'\<alpha> upred \<Rightarrow> '\<alpha> upred" ("[_]\<^sub>u") is
"\<lambda> P A. \<forall>A'. P A'" .

lift_definition taut :: "'\<alpha> upred \<Rightarrow> bool" ("`_`")
is "\<lambda> P. \<forall> A. P A" .

-- {* Configuration for UTP tactics (see @{theory utp_tactics}). *}

update_uexpr_rep_eq_thms -- {* Reread @{text rep_eq} theorems. *}

declare utp_pred.taut.rep_eq [upred_defs]

adhoc_overloading
  utrue "true_upred" and
  ufalse "false_upred" and
  unot "not_upred" and
  uconj "conj_upred" and
  udisj "disj_upred" and
  uimpl impl and
  uiff iff_upred and
  uex ex and
  uall all and
  ushEx shEx and
  ushAll shAll

syntax
  "_uneq"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<noteq>\<^sub>u" 50)
  "_unmem"      :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<notin>\<^sub>u" 50)

translations
  "x \<noteq>\<^sub>u y" == "CONST unot (x =\<^sub>u y)"
  "x \<notin>\<^sub>u A" == "CONST unot (CONST bop (op \<in>) x A)"

declare true_upred_def [upred_defs]
declare false_upred_def [upred_defs]
declare conj_upred_def [upred_defs]
declare disj_upred_def [upred_defs]
declare not_upred_def [upred_defs]
declare diff_upred_def [upred_defs]
declare subst_upd_uvar_def [upred_defs]
declare par_subst_def [upred_defs]
declare unrest_usubst_def [upred_defs]
declare uexpr_defs [upred_defs]

lemma true_alt_def: "true = \<guillemotleft>True\<guillemotright>"
  by (pred_auto)

declare true_alt_def[THEN sym,lit_simps]
declare false_alt_def[THEN sym,lit_simps]

text {* We set up syntax for the conditional. This is effectively an infix version of
  if-then-else where the condition is in the middle. *}

abbreviation cond ::
  "('a,'\<alpha>) uexpr \<Rightarrow> '\<alpha> upred \<Rightarrow> ('a,'\<alpha>) uexpr \<Rightarrow> ('a,'\<alpha>) uexpr"
  ("(3_ \<triangleleft> _ \<triangleright>/ _)" [52,0,53] 52)
where "P \<triangleleft> b \<triangleright> Q \<equiv> trop If b P Q"

subsection {* Unrestriction Laws *}

lemma unrest_allE:
  "\<lbrakk> &\<Sigma> \<sharp> P; P = true \<Longrightarrow> Q; P = false \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (pred_auto)

lemma unrest_true [unrest]: "x \<sharp> true"
  by (pred_auto)

lemma unrest_false [unrest]: "x \<sharp> false"
  by (pred_auto)

lemma unrest_conj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<and> Q"
  by (pred_auto)

lemma unrest_disj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<or> Q"
  by (pred_auto)

lemma unrest_UINF [unrest]:
  "\<lbrakk> (\<And> i. x \<sharp> P(i)); (\<And> i. x \<sharp> Q(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Sqinter> i | P(i) \<bullet> Q(i))"
  by (pred_auto)

lemma unrest_USUP [unrest]:
  "\<lbrakk> (\<And> i. x \<sharp> P(i)); (\<And> i. x \<sharp> Q(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Squnion> i | P(i) \<bullet> Q(i))"
  by (pred_auto)

lemma unrest_UINF_mem [unrest]:
  "\<lbrakk>(\<And> i. i \<in> A \<Longrightarrow> x \<sharp> P(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Sqinter> i\<in>A \<bullet> P(i))"
  by (pred_simp, metis)

lemma unrest_USUP_mem [unrest]:
  "\<lbrakk>(\<And> i. i \<in> A \<Longrightarrow> x \<sharp> P(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Squnion> i\<in>A \<bullet> P(i))"
  by (pred_simp, metis)

lemma unrest_impl [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Rightarrow> Q"
  by (pred_auto)

lemma unrest_iff [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Leftrightarrow> Q"
  by (pred_auto)

lemma unrest_not [unrest]: "x \<sharp> (P :: '\<alpha> upred) \<Longrightarrow> x \<sharp> (\<not> P)"
  by (pred_auto)

text {* The sublens proviso can be thought of as membership below. *}

lemma unrest_ex_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<exists> y \<bullet> P)"
  by (pred_auto)

declare sublens_refl [simp]
declare lens_plus_ub [simp]
declare lens_plus_right_sublens [simp]
declare comp_wb_lens [simp]
declare comp_mwb_lens [simp]
declare plus_mwb_lens [simp]

lemma unrest_ex_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<exists> x \<bullet> P)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma unrest_all_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma unrest_all_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<forall> x \<bullet> P)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

lemma unrest_var_res_diff [unrest]:
  assumes "x \<bowtie> y"
  shows "y \<sharp> (P \<restriction>\<^sub>v x)"
  using assms by (pred_auto)

lemma unrest_var_res_in [unrest]:
  assumes "mwb_lens x" "y \<subseteq>\<^sub>L x" "y \<sharp> P"
  shows "y \<sharp> (P \<restriction>\<^sub>v x)"
  using assms
  apply (pred_auto)
  apply fastforce
  apply (metis (no_types, lifting) mwb_lens_weak weak_lens.put_get)
done

lemma unrest_shEx [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<exists> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_shAll [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<forall> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_closure [unrest]:
  "x \<sharp> [P]\<^sub>u"
  by (pred_auto)

subsection {* Used-by laws *}

lemma usedBy_not [unrest]:
  "\<lbrakk> x \<natural> P \<rbrakk> \<Longrightarrow> x \<natural> (\<not> P)"
  by (pred_simp)

lemma usedBy_conj [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<and> Q)"
  by (pred_simp)

lemma usedBy_disj [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<or> Q)"
  by (pred_simp)

lemma usedBy_impl [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<Rightarrow> Q)"
  by (pred_simp)

lemma usedBy_iff [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<Leftrightarrow> Q)"
  by (pred_simp)

subsection {* Substitution Laws *}

text {* Substitution is monotone *}

lemma subst_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<sigma> \<dagger> P) \<sqsubseteq> (\<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_true [usubst]: "\<sigma> \<dagger> true = true"
  by (pred_auto)

lemma subst_not [usubst]: "\<sigma> \<dagger> (\<not> P) = (\<not> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_impl [usubst]: "\<sigma> \<dagger> (P \<Rightarrow> Q) = (\<sigma> \<dagger> P \<Rightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_iff [usubst]: "\<sigma> \<dagger> (P \<Leftrightarrow> Q) = (\<sigma> \<dagger> P \<Leftrightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_disj [usubst]: "\<sigma> \<dagger> (P \<or> Q) = (\<sigma> \<dagger> P \<or> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_conj [usubst]: "\<sigma> \<dagger> (P \<and> Q) = (\<sigma> \<dagger> P \<and> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_sup [usubst]: "\<sigma> \<dagger> (P \<sqinter> Q) = (\<sigma> \<dagger> P \<sqinter> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_inf [usubst]: "\<sigma> \<dagger> (P \<squnion> Q) = (\<sigma> \<dagger> P \<squnion> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_UINF [usubst]: "\<sigma> \<dagger> (\<Sqinter> i | P(i) \<bullet> Q(i)) = (\<Sqinter> i | (\<sigma> \<dagger> P(i)) \<bullet> (\<sigma> \<dagger> Q(i)))"
  by (pred_auto)

lemma subst_USUP [usubst]: "\<sigma> \<dagger> (\<Squnion> i | P(i) \<bullet> Q(i)) = (\<Squnion> i | (\<sigma> \<dagger> P(i)) \<bullet> (\<sigma> \<dagger> Q(i)))"
  by (pred_auto)

lemma subst_closure [usubst]: "\<sigma> \<dagger> [P]\<^sub>u = [P]\<^sub>u"
  by (pred_auto)

lemma subst_shEx [usubst]: "\<sigma> \<dagger> (\<^bold>\<exists> x \<bullet> P(x)) = (\<^bold>\<exists> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

lemma subst_shAll [usubst]: "\<sigma> \<dagger> (\<^bold>\<forall> x \<bullet> P(x)) = (\<^bold>\<forall> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

text {* TODO: Generalise the quantifier substitution laws to n-ary substitutions *}

lemma subst_ex_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<exists> x \<bullet> P) = \<sigma> \<dagger> (\<exists> x \<bullet> P)"
  by (pred_auto)

lemma subst_ex_same' [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<exists> &x \<bullet> P) = \<sigma> \<dagger> (\<exists> &x \<bullet> P)"
  by (pred_auto)

lemma subst_ex_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<exists> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<exists> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
done

lemma subst_ex_unrest [usubst]:
  "x \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (\<exists> x \<bullet> P) = (\<exists> x \<bullet> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_all_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<forall> x \<bullet> P) = \<sigma> \<dagger> (\<forall> x \<bullet> P)"
  by (simp add: id_subst subst_unrest unrest_all_in)

lemma subst_all_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<forall> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<forall> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

end


theory Execution
  imports Trace
begin

section \<open>Execution\<close>

text \<open>
Given a reordering relation and evaluation behaviour of a language,
convert a trace into manipulations over memory.
\<close>

locale execution =
  fixes eval :: "'a \<Rightarrow> 's rel"
  assumes eval_det: "(m,m') \<in> eval \<alpha> \<Longrightarrow> (m,m'') \<in> eval \<alpha> \<Longrightarrow> m' = m''"

context execution
begin

inductive trace_mem
  where
    "trace_mem m [] m" |
    "(m'', m) \<in> eval \<alpha> \<Longrightarrow> trace_mem m t m' \<Longrightarrow> trace_mem m'' (\<alpha>#t) m'"

definition ev :: "'a Stmt \<Rightarrow> 's \<Rightarrow> 'a Trace \<Rightarrow> 'a Stmt  \<Rightarrow> 's \<Rightarrow> bool"
  ("\<langle>_,_\<rangle> \<rightarrow>_\<^sup>* \<langle>_,_\<rangle>" [50,40,40] 70)
  where "\<langle>c,m\<rangle> \<rightarrow>t\<^sup>* \<langle>c',m'\<rangle> \<equiv> trace_mem m t m' \<and> c \<mapsto>t\<^sup>* c'"

lemma trace_mem_det:
  assumes "trace_mem m t m'" "trace_mem m t m''"
  shows "m' = m''"
  using assms
proof (induct arbitrary: m'')
  case (1 m)
  then show ?case by (auto elim: trace_mem.cases)
next
  case (2 m''' m \<alpha> t m')
  hence a: "(m''', m) \<in> eval \<alpha>" "trace_mem m t m'" "\<forall>m''. trace_mem m t m'' \<longrightarrow> m' = m''"
    by blast+
  show ?case using 2(4)
  proof (cases rule: trace_mem.cases)
    case (2 m'''')
    show ?thesis using eval_det[OF 2(1) a(1)] a(3) 2(2) by blast
  qed
qed

lemma ev_det:
  assumes "\<langle>c,m\<rangle> \<rightarrow>t\<^sup>* \<langle>c',m'\<rangle>"
  assumes "\<langle>c,m\<rangle> \<rightarrow>t\<^sup>* \<langle>c'',m''\<rangle>"
  shows "m'' = m'"
  using assms trace_mem_det unfolding ev_def
  by auto

end

end