(*  Title:   UPL.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology

*)
subsection \<open> UPL \<close>

theory UPL
  imports PL

begin

definition upl_der :: "['cont quasi_borel, 'cont assump, 'cont \<Rightarrow> 'typ, 'typ quasi_borel, ('cont \<Rightarrow> 'typ) \<Rightarrow> 'cont \<Rightarrow> bool] \<Rightarrow> bool" where
"upl_der \<Gamma> \<Psi> t T \<phi> \<equiv> (hpprog_typing \<Gamma> t T \<and> (\<exists>\<phi>'. \<phi> = (\<lambda>t k. \<phi>' k (t k))) \<and> (\<forall>k\<in>qbs_space \<Gamma>. hp_conjall \<Psi> k \<longrightarrow> \<phi> t k))"

syntax
 "_upl_der" :: "any \<Rightarrow> 'cont quasi_borel \<Rightarrow> 'cont assump \<Rightarrow> ('cont \<Rightarrow> 'typ) \<Rightarrow> 'typ quasi_borel \<Rightarrow> (('cont \<Rightarrow> 'typ) \<Rightarrow> 'cont \<Rightarrow> bool) \<Rightarrow> bool" ("_ | _ \<turnstile>\<^sub>U\<^sub>P\<^sub>L _ ;; _ | _" 21)

translations
 "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>" \<rightleftharpoons> "CONST upl_der \<Gamma> \<Psi> e T \<phi>"

(* Example *)
term "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_const 1 ;; \<nat>\<^sub>Q | \<lambda>r. hp_const 1 \<le>\<^sub>P\<^sub>L r +\<^sub>t r"

lemma upl_phi_equiv1:
  assumes "\<phi> = (\<lambda>r env. \<psi> env (r env))"
      and "e k = e' k"
    shows "\<phi> e k = \<phi> e' k"
  using assms by simp

lemma upl_phi_const:
  assumes "\<phi> = (\<lambda>r env. \<psi> env (r env))"
  shows "\<phi> (hp_const (e k)) k = \<phi> e k"
  by(simp add: assms hp_const_def)

text \<open> The completeness theorem w.r.t. derivability is proved by expanding definitions. \<close>
lemma pl_upl_complete:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; T"
      and "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
    shows "(\<Gamma> | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> t) \<longleftrightarrow> (\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L t ;; T | \<phi>)"
  using assms
  by(auto simp add: pl_der_def upl_der_def)

lemma pl_if_upl:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; T"
          "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L t ;; T | \<phi>"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> t"
  using pl_upl_complete[OF assms(1,2)] assms(3)
  by simp

lemma upl_if_pl:
  assumes "\<Gamma> \<turnstile>\<^sub>t t ;; T"
          "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> t"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L t ;; T | \<phi>"
  using pl_upl_complete[OF assms(1,2)] assms(3)
  by simp

lemma upl_const:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
          "\<Gamma> \<turnstile>\<^sub>t hp_const c ;; T"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> (hp_const c)"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_const c ;; T | \<phi>"
  using assms by(auto simp add: pl_der_def upl_der_def)

lemma upl_var1:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma>,,X | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> var1"
    shows "\<Gamma>,,X | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L var1 ;; X | \<phi>"
  using assms hpt_var1 by(auto simp add: pl_der_def upl_der_def)

lemma upl_var2:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma>,,Z,,Y | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> var2"
    shows "\<Gamma>,,Z,,Y | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L var2 ;; Z | \<phi>"
  using assms hpt_var2 by(auto simp add: pl_der_def upl_der_def)

lemma upl_var3:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma>,,Z,,Y,,X | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> var3"
    shows "\<Gamma>,,Z,,Y,,X | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L var3 ;; Z | \<phi>"
  using assms hpt_var3 by(auto simp add: pl_der_def upl_der_def)

lemma upl_var4:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma>,,Z,,Y,,X,,W | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> var4"
    shows "\<Gamma>,,Z,,Y,,X,,W | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L var4 ;; Z | \<phi>"
  using assms hpt_var4 by(auto simp add: pl_der_def upl_der_def)

lemma upl_var5:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma>,,Z,,Y,,X,,W,,V | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> var5"
    shows "\<Gamma>,,Z,,Y,,X,,W,,V | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L var5 ;; Z | \<phi>"
  using assms hpt_var5 by(auto simp add: pl_der_def upl_der_def)

(*         \<Gamma>, x : X | \<Psi>,\<phi>' |-upl e : Y | \<phi>
  ----------------------------------------------------
   \<Gamma> | \<Psi> |-upl (\<lambda>x. e) : X \<Rightarrow> Y | \<forall>x. \<phi>' \<longrightarrow> \<phi>[r x/r] *)
lemma upl_abs:
  assumes "\<Psi> = (\<lambda>\<psi>. (\<lambda>(k,_). \<psi> k)) `\<Psi>'"
          "\<Phi>' = (\<lambda>x env. curry (hp_conjall \<Phi>) env x)"
          "\<phi> = (\<lambda>r k. \<phi>' (snd k) (\<lambda>l. r (l,snd k)) (fst k))"
      and "\<Gamma>,,X | \<Psi> \<union> \<Phi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>"
    shows "\<Gamma> | \<Psi>' \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_lambda e ;; exp_qbs X T | (\<lambda>r. \<forall>\<^sub>P\<^sub>Lx\<in>\<^sub>P\<^sub>LX. \<Phi>' x \<longrightarrow>\<^sub>P\<^sub>L \<phi>' x (hp_app r (hp_const x)))"
proof(auto simp add: hp_definitions upl_der_def)
  show "\<Gamma> \<turnstile>\<^sub>t curry e ;; exp_qbs X T"
    using assms(4) hpt_abs[of \<Gamma> X e T]
    by(simp add: hp_definitions upl_der_def)
next
  obtain \<psi> where h:"\<phi> = (\<lambda>t k. \<psi> k (t k))"
    using assms(4) by(auto simp add: upl_der_def)
  define \<psi>' where "\<psi>' \<equiv> (\<lambda>env f. \<forall>x\<in>qbs_space X. \<Phi>' x env \<longrightarrow> \<psi> (env,x) (f x))"
  have "\<And> x r env. \<phi>' x (\<lambda>k. r k x) env = \<psi> (env, x) (r env x)"
  proof -
    fix x r env
    have "\<phi>' x (\<lambda>k. r k x) env = \<phi> (case_prod r) (env,x)"
      by (simp add: assms(3))
    also have "... = (\<lambda>t k. \<psi> k (t k)) (case_prod r) (env,x)"
      by(simp add: h)
    finally show "\<phi>' x (\<lambda>k. r k x) env = \<psi> (env, x) (r env x)" by simp
  qed
  hence "(\<lambda>r env. \<forall>x\<in>qbs_space X. \<Phi>' x env \<longrightarrow> \<phi>' x (\<lambda>xa. r xa x) env) = (\<lambda>r env. \<psi>' env (r env))"
    by(simp add: \<psi>'_def comp_def qbs_eval_def)
  thus " \<exists>\<phi>''. (\<lambda>r env. \<forall>x\<in>qbs_space X. \<Phi>' x env \<longrightarrow> \<phi>' x (\<lambda>xa. r xa x) env) = (\<lambda>t k. \<phi>'' k (t k))"
    by auto
next
  fix k x
  assume h:"k \<in> qbs_space \<Gamma>"
           "hp_conjall \<Psi>' k"
           "x \<in> qbs_space X"
           "\<Phi>' x k"
  then have "hp_conjall ((\<lambda>\<psi> (k, _). \<psi> k) ` \<Psi>' \<union> \<Phi>) (k,x)"
    by (auto simp add:  assms(1,2) curry_def hp_and_def hp_conjall_union[of "(\<lambda>\<psi> (k, _). \<psi> k) ` \<Psi>'" \<Phi>] hp_conjall_def)

  thus "\<phi>' x (\<lambda>xa. e (xa, x)) k"
    using h assms by(simp add: upl_der_def hpprog_context_def)
qed

lemma upl_abs':
  assumes "\<Psi> = (\<lambda>\<psi>. (\<lambda>(k,_). \<psi> k)) `\<Psi>'"
          "\<Phi>' = hp_conjall_fix \<Phi>"
          "\<phi> = (\<lambda>r k. \<phi>' (hp_const (snd k)) (\<lambda>l. r (l,snd k)) (fst k))"
      and "\<Gamma>,,X | \<Psi> \<union> \<Phi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>"
    shows "\<Gamma> | \<Psi>' \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_lambda e ;; exp_qbs X T | (\<lambda>r. \<forall>\<^sub>P\<^sub>Lx\<in>\<^sub>P\<^sub>LX. \<Phi>' (hp_const x) \<longrightarrow>\<^sub>P\<^sub>L \<phi>' (hp_const x) (hp_app r (hp_const x)))"
proof(auto simp add: hp_definitions upl_der_def)
  show "\<Gamma> \<turnstile>\<^sub>t curry e ;; exp_qbs X T"
    using assms(4) hpt_abs[of \<Gamma> X e T]
    by(simp add: hp_definitions upl_der_def)
next
  obtain \<psi> where h:"\<phi> = (\<lambda>t k. \<psi> k (t k))"
    using assms(4) by(auto simp add: upl_der_def)
  define \<psi>' where "\<psi>' \<equiv> (\<lambda>env f. \<forall>x\<in>qbs_space X. \<Phi>' (hp_const x) env \<longrightarrow> \<psi> (env,x) (f x))"
  have "\<And> x r env. \<phi>' (hp_const x) (\<lambda>k. r k x) env = \<psi> (env, x) (r env x)"
  proof -
    fix x r env
    have "\<phi>' (hp_const x) (\<lambda>k. r k x) env = \<phi> (case_prod r) (env,x)"
      by (simp add: assms(3))
    also have "... = (\<lambda>t k. \<psi> k (t k)) (case_prod r) (env,x)"
      by(simp add: h)
    finally show "\<phi>' (hp_const x) (\<lambda>k. r k x) env = \<psi> (env, x) (r env x)" by simp
  qed
  hence "(\<lambda>r env. \<forall>x\<in>qbs_space X. \<Phi>' (hp_const x) env \<longrightarrow> \<phi>' (hp_const x) (\<lambda>xa. r xa x) env) = (\<lambda>r env. \<psi>' env (r env))"
    by(simp add: \<psi>'_def comp_def qbs_eval_def)
  thus " \<exists>\<phi>''. (\<lambda>r env. \<forall>x\<in>qbs_space X. \<Phi>' (\<lambda>_. x) env \<longrightarrow> \<phi>' (\<lambda>_. x) (\<lambda>xa. r xa x) env) = (\<lambda>t k. \<phi>'' k (t k))"
    by (auto simp add: hp_const_def)
next
  fix k x
  assume h:"k \<in> qbs_space \<Gamma>"
           "hp_conjall \<Psi>' k"
           "x \<in> qbs_space X"
           "\<Phi>' (\<lambda>_. x) k"
  then have "hp_conjall ((\<lambda>\<psi> (k, _). \<psi> k) ` \<Psi>' \<union> \<Phi>) (k,x)"
    by (auto simp add:  assms(1,2) curry_def hp_and_def hp_conjall_union[of "(\<lambda>\<psi> (k, _). \<psi> k) ` \<Psi>'" \<Phi>] hp_conjall_def hp_const_def hp_conjall_fix_def)
  thus "\<phi>' (\<lambda>_. x) (\<lambda>xa. e (xa, x)) k "
    using h assms by(simp add: upl_der_def comp_def qbs_eval_def hpprog_context_def hp_const_def)
qed

(*  \<Gamma> | \<Psi> |-upl e : T | \<phi>    \<Gamma> | \<Psi> |-pl \<phi> e \<longrightarrow> \<psi> e
   --------------------------------------------------
                \<Gamma> | \<Psi> |-upl e : T | \<psi>               *)
lemma upl_sub:
  assumes "\<psi> = (\<lambda>r env. \<psi>' env (r env))"
          "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<phi> e \<longrightarrow>\<^sub>P\<^sub>L \<psi> e"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<psi>"
  using assms by(auto simp add: pl_der_def upl_der_def hp_implies_def)

(*  \<Gamma> | \<Psi> \<turnstile>upl f : T1 \<Rightarrow> T2 | \<forall>x:T1. \<phi>1[x/r] \<longrightarrow> \<phi>[r x/x]    \<Gamma> | \<Psi> \<turnstile>upl e : T1 | \<phi>1
   ----------------------------------------------------------------------------------
                              \<Gamma> | \<Psi> \<turnstile>upl f x : T2 | \<phi>[e/x]                          *)
lemma upl_app:
  assumes "\<phi> = (\<lambda>t r env. \<phi>' (t env) env (r env))"
          "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L f ;; exp_qbs T1 T2 | (\<lambda>r. \<forall>\<^sub>P\<^sub>Lx\<in>\<^sub>P\<^sub>LT1. \<psi> (hp_const x) \<longrightarrow>\<^sub>P\<^sub>L \<phi> (hp_const x) (hp_app r (hp_const x)))"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T1 | \<psi>"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_app f e ;; T2 | \<phi> e"
proof(auto simp add: upl_der_def)
  show "\<Gamma> \<turnstile>\<^sub>t hp_app f e ;; T2"
    using hpt_app assms(2,3) by(auto simp add: upl_der_def)
next
  show "\<exists>\<phi>'. \<phi> e = (\<lambda>t k. \<phi>' k (t k))"
    using assms(1) by auto
next
  obtain \<psi>' where h1: "\<psi> = (\<lambda>r env. \<psi>' env (r env))"
    using assms(3) by(auto simp add: upl_der_def)
  fix k
  assume h:"k \<in> qbs_space \<Gamma>"
           "hp_conjall \<Psi> k"
  then have "e k \<in> qbs_space T1"
    using assms(3) qbs_morphismE(1)[of e \<Gamma> T1]
    by(auto simp add: upl_der_def hpprog_typing_def)
  moreover have "(\<psi> (hp_const (e k)) k)"
    using  assms(3) h upl_phi_const[OF h1,of e k]
    by(simp add: upl_der_def)
  ultimately have "\<phi> (hp_const (e k)) (hp_app f (hp_const (e k))) k"
    using h assms(2) by(simp add: upl_der_def hp_implies_def hp_all_def)
  moreover have "(\<phi> (hp_const (e k)) (hp_app f (hp_const (e k))) k) = (\<phi> e (hp_app f e) k)"
    by(simp add: hp_definitions assms(1))
  ultimately show "\<phi> e (hp_app f e) k"
    by simp
qed

(*  \<Gamma> | \<Psi> \<turnstile>upl e : T1 \<times> T2 | \<phi> [\<pi>1(r)/r]
   --------------------------------------
           \<Gamma> | \<Psi> \<turnstile>upl \<pi>1 e : T1 | \<phi>     *)
lemma upl_proj1:
  assumes "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T1 \<Otimes>\<^sub>Q (T2 :: 't2 quasi_borel) | \<lambda>r. \<phi> (hp_fst r)"
  shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_fst e ;; T1 | (\<phi> :: ('env \<Rightarrow> 't1) \<Rightarrow> 'env \<Rightarrow> bool)"
  using assms hpt_fst[of \<Gamma> e T1 T2]
proof(auto simp add: upl_der_def hp_fst_def)
  fix \<phi>' :: "'env \<Rightarrow> 't1 \<times> 't2 \<Rightarrow> bool"
  define fr :: "'t1 \<Rightarrow> 't1 \<times> 't2"
    where "fr \<equiv> (\<lambda>k1. (k1,undefined))"
  define \<psi> :: "'env \<Rightarrow> 't1 \<Rightarrow> bool"
    where "\<psi> \<equiv> (\<lambda>env t1. \<phi>' env (fr t1))"
  have hfr:"\<And>r'. fst \<circ> (fr \<circ> r') = r'"
    by(auto simp add: fr_def)
  assume h1:"(\<lambda>r. \<phi> (\<lambda>env. fst (r env))) = (\<lambda>t k. \<phi>' k (t k))"
  have "\<And>r' env. \<phi> r' env = \<phi>' env (fr (r' env))"
  proof -
    fix r' env
    have "\<phi> r' env = (\<lambda>r. \<phi> (\<lambda>env. fst (r env))) (fr \<circ> r') env"
      using hfr[of r'] by(auto simp add: comp_def)
    also have "... = (\<lambda>t k. \<phi>' k (t k)) (fr \<circ> r') env"
      by (metis h1)
    finally show "\<phi> r' env = \<phi>' env (fr (r' env))"
      by auto
  qed
  hence "\<phi> = (\<lambda>t k. \<psi> k (t k))"
    by(auto simp add: \<psi>_def)
  thus "\<exists>\<phi>''. \<phi> = (\<lambda>t k. \<phi>'' k (t k))"
    by auto
qed

(*  \<Gamma> | \<Psi> \<turnstile>upl e : T1 \<times> T2 | \<phi> [\<pi>2(r)/r]
   --------------------------------------
           \<Gamma> | \<Psi> \<turnstile>upl \<pi>2 e : T2 | \<phi>     *)
lemma upl_proj2:
  assumes "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; (T1 :: 't1 quasi_borel) \<Otimes>\<^sub>Q T2 | \<lambda>r. \<phi> (hp_snd r)"
  shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_snd e ;; T2 | (\<phi> :: ('env \<Rightarrow> 't2) \<Rightarrow> 'env \<Rightarrow> bool)"
  using assms hpt_snd[of \<Gamma> e T1 T2]
proof(auto simp add: upl_der_def hp_snd_def)
  fix \<phi>' :: "'env \<Rightarrow> 't1 \<times> 't2 \<Rightarrow> bool"
  define fr :: "'t2 \<Rightarrow> 't1 \<times> 't2"
    where "fr \<equiv> (\<lambda>k2. (undefined,k2))"
  define \<psi> :: "'env \<Rightarrow> 't2 \<Rightarrow> bool"
    where "\<psi> \<equiv> (\<lambda>env t1. \<phi>' env (fr t1))"
  have hfr:"\<And>r'. snd \<circ> (fr \<circ> r') = r'"
    by(auto simp add: fr_def)
  assume h1:"(\<lambda>r. \<phi> (\<lambda>env. snd (r env))) = (\<lambda>t k. \<phi>' k (t k))"
  have "\<And>r' env. \<phi> r' env = \<phi>' env (fr (r' env))"
  proof -
    fix r' env
    have "\<phi> r' env = (\<lambda>r. \<phi> (\<lambda>env. snd (r env))) (fr \<circ> r') env"
      using hfr[of r'] by(auto simp add: comp_def)
    also have "... = (\<lambda>t k. \<phi>' k (t k)) (fr \<circ> r') env"
      by (metis h1)
    finally show "\<phi> r' env = \<phi>' env (fr (r' env))"
      by auto
  qed
  hence "\<phi> = (\<lambda>t k. \<psi> k (t k))"
    by(auto simp add: \<psi>_def)
  thus "\<exists>\<phi>''. \<phi> = (\<lambda>t k. \<phi>'' k (t k))"
    by auto
qed

(* \<Gamma> | \<Psi> \<turnstile>upl e1 : T1 | \<phi>1     \<Gamma> | \<Psi> \<turnstile>upl e2 : T2 | \<phi>2    \<Gamma> | \<Psi> \<turnstile>pl \<forall>x:T1, \<forall>y:T2, \<phi>1[x/r] \<longrightarrow> \<phi>2[y/r] \<longrightarrow> \<phi>[(x,y)/r]
  -----------------------------------------------------------------------------------------------------------------------
                                    \<Gamma> | \<Psi> \<turnstile>upl (e1,e2) : T1 \<times> T2 | \<phi>                                                    *)
lemma upl_pair:
  assumes "\<phi> = (\<lambda>r env. \<phi>' env (r env))"
          "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e1 ;; T1 | \<phi>1"
          "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e2 ;; T2 | \<phi>2"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>P\<^sub>L \<forall>\<^sub>P\<^sub>Lx\<in>\<^sub>P\<^sub>LT1. \<forall>\<^sub>P\<^sub>Ly\<in>\<^sub>P\<^sub>LT2. \<phi>1 (hp_const x) \<longrightarrow>\<^sub>P\<^sub>L \<phi>2 (hp_const y) \<longrightarrow>\<^sub>P\<^sub>L \<phi> (hp_pair (hp_const x) (hp_const y))"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_pair e1 e2 ;; T1 \<Otimes>\<^sub>Q T2 | \<phi>"
  unfolding upl_der_def apply auto
  using assms(2,3) hpt_pair[of \<Gamma> e1 T1 e2 T2] apply(simp add: upl_der_def)
  using assms(1) apply auto[1]
proof -
  fix k
  assume h:"k \<in> qbs_space \<Gamma>"
           "hp_conjall \<Psi> k"
  then have "\<phi>1 (hp_const (e1 k)) k" "\<phi>2 (hp_const (e2 k)) k"
    using assms(2,3) by(auto simp add: hp_const_def upl_der_def)
  moreover have "e1 k \<in> qbs_space T1" "e2 k \<in> qbs_space T2"
    using qbs_morphismE(1)[of e1 \<Gamma> T1] qbs_morphismE(1)[of e2 \<Gamma> T2] assms(2,3) h
    by(auto simp add: upl_der_def hpprog_typing_def)
  ultimately have "\<phi> (hp_pair (hp_const (e1 k)) (hp_const (e2 k))) k"
    using assms(2-4) h by(simp add: upl_der_def hp_definitions pl_der_def)
  thus "\<phi> (hp_pair e1 e2) k"
    by(simp add: assms(1) hp_definitions)
qed

(* \<Gamma> | \<Psi>, \<phi>'[0/n] |-upl t0 : T | \<phi>[0/n]    \<Gamma>, n : \<nat>, t : T | \<Psi>, \<phi>'[Suc n/n], \<phi>' \<longrightarrow> \<phi>[t/r], t = f n |-upl e : T | \<phi>[Suc n/n]
  -------------------------------------------------------------------------------------------------------------------
                    \<Gamma> | \<Psi> |-upl rec t0 (\<lambda>n t. e) : \<nat> \<Rightarrow> T | \<forall>n. \<phi>' \<longrightarrow> \<phi>[r n/r]                                     *)
lemma upl_recnat':
  assumes "\<Phi>0 = (\<lambda>\<psi>. (\<lambda>k. \<psi> (k,0))) `\<Phi>"
          "\<Phi>Sn = (\<lambda>\<psi>. (\<lambda>((k,n),_). \<psi> (k,Suc n))) `\<Phi>"
          "\<Phi>' = hp_conjall_fix \<Phi>"
          "\<Psi>' = (\<lambda>\<psi>. (\<lambda>((k,_),_). \<psi> k)) `\<Psi>"
          "\<phi>' = (\<lambda>fn ft k. \<phi> (hp_const (fn k)) (hp_const (ft k)) (fst (fst k)))"
          "IH = {(\<lambda>((k,n),t). hp_conjall \<Phi> (k,n) \<longrightarrow> \<phi> (hp_const n) (hp_const t) k)}"
          "\<And>n. \<exists>\<psi>n. \<phi> (hp_const n) = (\<lambda>r env. \<psi>n env (r env))"
          "fn = (\<lambda>envnt. hp_rec_nat t0 (hp_lambda (hp_lambda e)) (fst (fst envnt)))"
          "\<Gamma> | \<Psi> \<union> \<Phi>0 \<turnstile>\<^sub>U\<^sub>P\<^sub>L t0 ;; T | \<phi> (hp_const 0)"
     and  "\<Gamma> ,, \<nat>\<^sub>Q ,, T | \<Psi>' \<union> \<Phi>Sn \<union> IH \<union> {var1 =\<^sub>P\<^sub>L hp_app fn var2}  \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>' (hp_suc var2)"
   shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_rec_nat t0 (hp_lambda (hp_lambda e)) ;; (exp_qbs \<nat>\<^sub>Q T) | (\<lambda>r. \<forall>\<^sub>P\<^sub>Ln\<in>\<^sub>P\<^sub>L\<nat>\<^sub>Q. \<Phi>' (hp_const n) \<longrightarrow>\<^sub>P\<^sub>L \<phi> (hp_const n) (hp_app r (hp_const n)))"
proof(auto simp add: upl_der_def)
  show "\<Gamma> \<turnstile>\<^sub>t hp_rec_nat t0 (hp_lambda (hp_lambda e)) ;; exp_qbs \<nat>\<^sub>Q T"
    using hpt_recnat'[of \<Gamma> t0 T e] assms(9,10)
    by(auto simp add: upl_der_def)
next
  have "\<forall>n. \<exists>\<psi>n. \<forall>r env. \<phi> (hp_const n) r env = \<psi>n env (r env)"
  proof
    fix n
    obtain \<psi>n where "\<phi> (hp_const n) = (\<lambda>r env. \<psi>n env (r env))"
      using assms(7)[of n] by auto
    thus "\<exists>\<psi>n. \<forall>r env. \<phi> (hp_const n) r env = \<psi>n env (r env)"
      by auto
  qed
  hence "\<exists>\<psi>. \<forall>n r env. \<phi> (hp_const n) r env = \<psi> n env (r env)"
    by(rule choice)
  then obtain \<psi> where hp:"\<forall>n r env. \<phi> (hp_const n) r env = \<psi> n env (r env)"
    by auto

  define \<psi>' where "\<psi>' \<equiv> (\<lambda>env t. \<forall>n\<in>qbs_space \<nat>\<^sub>Q. \<Phi>' (hp_const n) env \<longrightarrow> \<psi> n env (t n))"
  then have "(\<lambda>r. \<forall>\<^sub>P\<^sub>Ln\<in>\<^sub>P\<^sub>L\<nat>\<^sub>Q. \<Phi>' (hp_const n) \<longrightarrow>\<^sub>P\<^sub>L \<phi> (hp_const n) (hp_app r (hp_const n))) = (\<lambda>t k. \<psi>' k (t k))"
    using hp by(auto simp add: hp_definitions)
  thus "\<exists>\<psi>'. (\<lambda>r. \<forall>\<^sub>P\<^sub>Ln\<in>\<^sub>P\<^sub>L\<nat>\<^sub>Q. \<Phi>' (hp_const n) \<longrightarrow>\<^sub>P\<^sub>L \<phi> (hp_const n) (hp_app r (hp_const n))) = (\<lambda>t k. \<psi>' k (t k))"
    by auto
next
  fix k
  assume h:"k \<in> qbs_space \<Gamma>"
           "hp_conjall \<Psi> k"
  show "(\<forall>\<^sub>P\<^sub>Ln\<in>\<^sub>P\<^sub>L\<nat>\<^sub>Q. \<Phi>' (hp_const n) \<longrightarrow>\<^sub>P\<^sub>L \<phi> (hp_const n) (hp_app (hp_rec_nat t0 (hp_lambda (hp_lambda e))) (hp_const n))) k"
  proof(auto simp add: hp_all_def hp_implies_def)
    fix n
    assume "\<Phi>' (hp_const n) k"
    then show "\<phi> (hp_const n) (hp_app (hp_rec_nat t0 (hp_lambda (hp_lambda e))) (hp_const n)) k"
    proof(induction n)
      case 0
      then show ?case
        using assms(1,3,9) h by(force simp add: upl_der_def hp_definitions hp_conjall_fix_def hp_conjall_def)
    next
      case ih:(Suc n)
      let ?f = "hp_rec_nat t0 (hp_lambda (hp_lambda e))"
      let ?env = "((k,n),?f k n)"
      have ht:"?f k n \<in> qbs_space T"
        using hpt_recnat'[of \<Gamma> t0 T e] h(1) qbs_morphismE(1)[of ?f \<Gamma> "exp_qbs \<nat>\<^sub>Q T"] qbs_morphismE(1)[of "?f k" "\<nat>\<^sub>Q" T] assms(10,9)
        by(auto simp add: upl_der_def hpprog_typing_def)
      hence "?env \<in> qbs_space (\<Gamma> ,, \<nat>\<^sub>Q ,, T)"
        by(simp add: h(1) hpprog_context_def)
      moreover have "hp_conjall \<Psi>' ?env"
        using h by(simp add: assms(4) hp_conjall_def)
      moreover have "hp_conjall \<Phi>Sn ?env"
        using assms(2,3) ih(2) by(simp add: hp_conjall_fix_def hp_conjall_def hp_const_def)
      moreover have "hp_conjall IH ?env"
      proof -
        have "(hp_app (hp_rec_nat t0 (hp_lambda (hp_lambda e))) (\<lambda>a. n)) k = hp_const (hp_rec_nat t0 (hp_lambda (hp_lambda e)) k n) k"
          by(simp add: hp_definitions)
        hence "\<phi> (hp_const n) (hp_app (hp_rec_nat t0 (hp_lambda (hp_lambda e))) (\<lambda>a. n)) k = \<phi> (hp_const n) (hp_const (hp_rec_nat t0 (hp_lambda (hp_lambda e)) k n)) k"
          using upl_phi_equiv1[of "\<phi> (hp_const n)" _ "hp_app (hp_rec_nat t0 (hp_lambda (hp_lambda e))) (\<lambda>a. n)" k "hp_const (hp_rec_nat t0 (hp_lambda (hp_lambda e)) k n)"] assms(7)[of n]
          by auto
        thus ?thesis
          using ih(1) assms(3)
          by(simp add: assms(6) hp_conjall_def hp_conjall_fix_def hp_const_def)
      qed
      moreover have "(var1 =\<^sub>P\<^sub>L hp_app fn var2) ?env"
        by(simp add: assms(8) hp_definitions)
      ultimately have "\<phi>' (hp_suc var2) e ?env"
        using assms(10) by(simp add: upl_der_def hp_conjall_union hp_conjall_def,blast)
      moreover have "\<phi>' (hp_suc var2) e ?env = \<phi> (hp_const (Suc n)) (hp_app ?f (hp_const (Suc n))) k"
                     (is "?lhs = ?rhs")
      proof -
        obtain \<psi> where hpsi:"\<phi> (hp_const (Suc n)) = (\<lambda>r env. \<psi> env (r env))"
          using assms(7)[of "Suc n"] by auto
        have "?lhs = \<phi> (hp_const (hp_suc var2 ((k, n), hp_rec_nat t0 (hp_lambda (hp_lambda e)) k n))) (hp_const (e ((k, n), ?f k n))) k"
          by(simp add: assms(5))
        also have "... =  \<phi> (hp_const (Suc n)) (hp_const (e ((k, n), hp_rec_nat t0 (hp_lambda (hp_lambda e)) k n))) k"
          by(simp add: hp_definitions)
        also have "... = \<phi> (hp_const (Suc n)) (hp_app (hp_app (hp_lambda (hp_lambda e)) (hp_const n)) (hp_app ?f (hp_const n))) k"
          apply(rule upl_phi_equiv1[of "\<phi> (hp_const (Suc n))"],simp_all add: hp_definitions)
          using hpsi by(auto simp add: hp_const_def)
        also have "... = ?rhs"
          by(simp add: hp_definitions)
        finally show ?thesis .
      qed
      ultimately show "\<phi> (hp_const (Suc n)) (hp_app (hp_rec_nat t0 (hp_lambda (hp_lambda e))) (hp_const (Suc n))) k"
        by simp
    qed
  qed
qed

(* \<Gamma> | \<Psi> \<turnstile>upl e : T | \<phi>1   \<Gamma> | \<Psi> \<turnstile>upl e : T | \<phi>2
  ------------------------------------------------
               \<Gamma> | \<Psi> \<turnstile>upl e : T | \<phi>1 \<and> \<phi>2       *)
lemma upl_andI:
  assumes "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>1"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>2"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T
               | (\<lambda>r. \<phi>1 r \<and>\<^sub>P\<^sub>L \<phi>2 r)"
  using assms by(auto simp add: upl_der_def hp_and_def)

(* \<Gamma> | \<Psi>, \<phi>'[e/r] \<turnstile>upl e : T | \<phi>1
  --------------------------------
    \<Gamma> | \<Psi> \<turnstile>upl e : T | \<phi>' \<longrightarrow> \<phi>1 *)
lemma upl_impI:
  assumes "\<Gamma> | \<Psi> \<union> \<Phi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<phi>1"
    shows "\<Gamma> | \<Psi>  \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | (\<lambda>r. hp_conjall \<Phi> \<longrightarrow>\<^sub>P\<^sub>L \<phi>1 r)"
proof(auto simp add: upl_der_def hp_implies_def)
  show "\<Gamma> \<turnstile>\<^sub>t e ;; T"
    using assms by(simp add: upl_der_def)
next
  obtain \<phi>1' where 1:"\<phi>1 = (\<lambda>r env. \<phi>1' env (r env))"
    using assms by(auto simp add: upl_der_def)
  show "\<exists>\<phi>'. (\<lambda>r env. hp_conjall \<Phi> env \<longrightarrow> \<phi>1 r env) = (\<lambda>t k. \<phi>' k (t k))"
    by(rule exI[where x="\<lambda>env x. hp_conjall \<Phi> env \<longrightarrow> \<phi>1' env x"],simp add: 1)
next
  fix k
  assume "k \<in> qbs_space \<Gamma>"
         "hp_conjall \<Psi> k"
         "hp_conjall \<Phi> k"
  then show "\<phi>1 e k"
    using assms
    by(simp add: hp_conjall_def upl_der_def,blast)
qed

(* \<Gamma> | \<Psi> \<turnstile>upl e : T | \<phi>[return r/r]
  ----------------------------------
         \<Gamma> | \<Psi> \<turnstile>upl e : P[T] | \<phi>     *)
lemma upl_return:
  assumes "\<phi> = (\<lambda>t k. \<phi>' k (t k))"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; T | \<lambda>r. \<phi> (hp_return T r)"
  shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L hp_return T e ;; monadP_qbs T | \<phi>"
  using assms hpt_return[of \<Gamma> e T] by(auto simp add: upl_der_def hp_return_def)

(* \<Gamma> | \<Psi> \<turnstile>upl e : P[T1] | \<phi>1     \<Gamma> | \<Psi> \<turnstile>upl f : T1 \<Rightarrow> P[T2] | \<forall>s:P[T1]. \<phi>1[s/r] \<longrightarrow> \<phi>2[bind s r/r]
  --------------------------------------------------------------------------------------------------
                              \<Gamma> | \<Psi> \<turnstile>upl bind e f : P[T2] | \<phi>2                                    *)
lemma upl_bind:
  assumes "\<phi>2 = (\<lambda>r env. \<psi>' env (r env))"
          "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L e ;; monadP_qbs T1 | \<phi>1"
      and "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L f ;; exp_qbs T1 (monadP_qbs T2) | \<lambda>r. \<forall>\<^sub>P\<^sub>Ls\<in>\<^sub>P\<^sub>LmonadP_qbs T1. \<phi>1 (hp_const s) \<longrightarrow>\<^sub>P\<^sub>L \<phi>2 (hp_const s \<bind> r)"
    shows "\<Gamma> | \<Psi> \<turnstile>\<^sub>U\<^sub>P\<^sub>L  e \<bind> f ;; monadP_qbs T2 | \<phi>2"
proof(auto simp add: upl_der_def)
  show "\<Gamma> \<turnstile>\<^sub>t e \<bind> f ;; monadP_qbs T2"
    using assms(2,3) hpt_bind[of \<Gamma> e T1 f T2]
    by(simp add: upl_der_def)
next
  show "\<exists>\<phi>'. \<phi>2 = (\<lambda>t k. \<phi>' k (t k))"
    using assms(1) by auto
next
  fix k
  assume h:"k \<in> qbs_space \<Gamma>"
           "hp_conjall \<Psi> k "
  then have "e k \<in> qbs_space (monadP_qbs T1)"
    using assms(2) qbs_morphismE(1)[of e \<Gamma> "monadP_qbs T1"]
    by(auto simp add: upl_der_def hpprog_typing_def)
  moreover have "\<phi>1 (hp_const (e k)) k"
    using upl_phi_const[of \<phi>1 _ e k] assms(2) h
    by(auto simp add: upl_der_def)
  ultimately have "\<phi>2 (hp_const (e k) \<bind> f) k"
    using assms(3) h by(simp add: upl_der_def hp_implies_def hp_all_def)
  moreover have "(\<phi>2 (hp_const (e k) \<bind> f) k) = (\<phi>2 (e \<bind> f) k)"
    using assms(1) by(simp add: hp_const_def hp_bind_def)
  ultimately show "\<phi>2 (e \<bind> f) k"
    by simp
qed

end


(*  Title:      HOL/Imperative_HOL/Heap.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, TU Muenchen
*)

section \<open>A polymorphic heap based on cantor encodings\<close>

theory Heap
imports Main "HOL-Library.Countable"
begin

subsection \<open>Representable types\<close>

text \<open>The type class of representable types\<close>

class heap = typerep + countable

instance unit :: heap ..

instance bool :: heap ..

instance nat :: heap ..

instance prod :: (heap, heap) heap ..

instance sum :: (heap, heap) heap ..

instance list :: (heap) heap ..

instance option :: (heap) heap ..

instance int :: heap ..

instance String.literal :: heap ..

instance typerep :: heap ..

subsection \<open>A polymorphic heap with dynamic arrays and references\<close>

text \<open>
  References and arrays are developed in parallel,
  but keeping them separate makes some later proofs simpler.
\<close>

type_synonym addr = nat \<comment> \<open>untyped heap references\<close>
type_synonym heap_rep = nat \<comment> \<open>representable values\<close>

record heap =
  arrays :: "typerep \<Rightarrow> addr \<Rightarrow> heap_rep list"
  refs :: "typerep \<Rightarrow> addr \<Rightarrow> heap_rep"
  lim  :: addr

definition empty :: heap where
  "empty = \<lparr>arrays = (\<lambda>_ _. []), refs = (\<lambda>_ _. 0), lim = 0\<rparr>"

datatype 'a array = Array addr \<comment> \<open>note the phantom type 'a\<close>
datatype 'a ref = Ref addr \<comment> \<open>note the phantom type 'a\<close>

primrec addr_of_array :: "'a array \<Rightarrow> addr" where
  "addr_of_array (Array x) = x"

primrec addr_of_ref :: "'a ref \<Rightarrow> addr" where
  "addr_of_ref (Ref x) = x"

lemma addr_of_array_inj [simp]:
  "addr_of_array a = addr_of_array a' \<longleftrightarrow> a = a'"
  by (cases a, cases a') simp_all

lemma addr_of_ref_inj [simp]:
  "addr_of_ref r = addr_of_ref r' \<longleftrightarrow> r = r'"
  by (cases r, cases r') simp_all

instance array :: (type) countable
  by (rule countable_classI [of addr_of_array]) simp

instance ref :: (type) countable
  by (rule countable_classI [of addr_of_ref]) simp

text \<open>Syntactic convenience\<close>

setup \<open>
  Sign.add_const_constraint (@{const_name Array}, SOME @{typ "nat \<Rightarrow> 'a::heap array"})
  #> Sign.add_const_constraint (@{const_name Ref}, SOME @{typ "nat \<Rightarrow> 'a::heap ref"})
  #> Sign.add_const_constraint (@{const_name addr_of_array}, SOME @{typ "'a::heap array \<Rightarrow> nat"})
  #> Sign.add_const_constraint (@{const_name addr_of_ref}, SOME @{typ "'a::heap ref \<Rightarrow> nat"})
\<close>

hide_const (open) empty

end


theory OpSem
imports Main HOL.Rat (*SetADT*)
begin

type_synonym TS = rat (* Timestamp *)
type_synonym T = nat (* Thread ID *)
type_synonym L = nat (* Location *)
type_synonym V = nat

definition "null = (0 :: nat)"

(* bool: true = release/aquire or false = relaxed*)
datatype action =
    Read bool L V
  | Write bool L V
  | Update L V V

fun avar :: "action \<Rightarrow> L" where
    "avar (Read _ x v) = x"
  | "avar (Write _ x v) = x"
  | "avar (Update x e v) = x"

fun wr_val :: "action \<Rightarrow> V option" where
    "wr_val (Write _ _ v) =  Some v"
  | "wr_val (Update _ _ v) = Some v"
  | "wr_val _ = None"

fun rd_val :: "action \<Rightarrow> V option" where
    "rd_val (Read _ _ v) = Some v"
  | "rd_val (Update _ v _) = Some v"
  | "rd_val _ = None"

fun isRA :: "action \<Rightarrow> bool" where
    "isRA (Read b _ _) = b"
  | "isRA (Write b _ _) = b"
  | "isRA (Update _ _ _) = True"

fun isWr :: "action \<Rightarrow> bool" where
    "isWr (Read _ _ _) = False"
  | "isWr (Write _ _ _) = True"
  | "isWr (Update _ _ _) = False"

fun isRd :: "action \<Rightarrow> bool" where
    "isRd (Read _ _ _) = True"
  | "isRd (Write _ _ _) = False"
  | "isRd (Update _ _ _) = False"

fun isUp :: "action \<Rightarrow> bool" where
    "isUp (Read _ _ _) = False"
  | "isUp (Write _ _ _) = False"
  | "isUp (Update _ _ _) = True"

abbreviation "reads a \<equiv> a \<in> (dom rd_val)"
abbreviation "writes a \<equiv> a \<in> (dom wr_val)"

type_synonym View = "L \<Rightarrow> T"

type_synonym event = "TS \<times> T \<times> action"

definition time_stamp :: "event \<Rightarrow> TS" where "time_stamp e \<equiv> fst e"
definition tid :: "event \<Rightarrow> T" where "tid e \<equiv> fst (snd e)"
definition act :: "event \<Rightarrow> action" where "act e \<equiv> snd (snd e)"

definition var :: "L \<times> TS \<Rightarrow> L" where "var = fst"
definition tst :: "L \<times> TS \<Rightarrow> TS" where "tst = snd"

record write_record =
  val :: V
  is_releasing :: bool

record surrey_state =
  writes :: "(L \<times> TS) set"
  thrView :: "T \<Rightarrow> L \<Rightarrow> (L \<times> TS)"
  modView :: "(L \<times> TS) \<Rightarrow> L \<Rightarrow> (L \<times> TS)"
  mods :: "(L \<times> TS) \<Rightarrow> write_record"
  covered :: "(L \<times> TS) set"

definition "value \<sigma> w \<equiv>  val (mods \<sigma> w)"
definition "releasing \<sigma> w \<equiv>  is_releasing (mods \<sigma> w)"

definition "writes_on \<sigma> x = {w . var w = x \<and> w \<in> writes \<sigma>}"
definition "visible_writes \<sigma> t x \<equiv> {w \<in> writes_on \<sigma> x . tst(thrView \<sigma> t x) \<le> tst w}"

lemma writes_on_var [simp]: "w \<in> writes_on \<sigma> x \<Longrightarrow> var w = x"
  by (simp add: writes_on_def)

lemma visible_var [simp]: "w \<in> visible_writes \<sigma> t x \<Longrightarrow> var w = x"
  by (auto simp add: visible_writes_def)

lemma visible_writes_in_writes: "visible_writes \<sigma> t x \<subseteq> writes \<sigma>"
  using visible_writes_def writes_on_def by fastforce

definition "valid_fresh_ts \<sigma> w ts' \<equiv> tst w < ts' \<and> (\<forall> w' \<in> writes_on \<sigma> (var w). tst w < tst w' \<longrightarrow> ts' < tst w')"

definition "ts_oride m m' x \<equiv> if tst (m x) \<le> tst (m' x) then m' x else m x"

definition rev_app :: "'s \<Rightarrow> ('s \<Rightarrow> 't) \<Rightarrow> 't" (infixl ";;" 150)
  where
  "rev_app s f \<equiv> f s"

definition
  "update_thrView t nv \<sigma> \<equiv> \<sigma> \<lparr> thrView := (thrView \<sigma>)(t := nv)\<rparr>"

definition
  "update_modView w nv \<sigma> \<equiv> \<sigma> \<lparr> modView := (modView \<sigma>)(w := nv) \<rparr>"

definition
  "update_mods w nwr \<sigma> \<equiv> \<sigma> \<lparr> mods := (mods \<sigma>)(w := nwr)\<rparr> \<lparr>writes := writes \<sigma> \<union> {w}\<rparr>"

definition
  "add_cv w \<sigma> \<equiv> \<sigma> \<lparr> covered := covered \<sigma> \<union> {w}\<rparr>"

definition "syncing \<sigma> w b \<equiv> releasing \<sigma> w \<and> b"

lemma [simp]: "syncing \<sigma> w False = False"
  by (simp add: syncing_def)

lemma [simp]: "syncing \<sigma> w True = releasing \<sigma> w"
  by (simp add: syncing_def)

definition
  "read_trans t b w \<sigma>  \<equiv>
       let new_thr_idx = (thrView \<sigma> t)(var w := w) in
       let new_thr_idx' =
             if syncing \<sigma> w b then ts_oride new_thr_idx (modView \<sigma> w) else new_thr_idx in
          \<sigma> ;; update_thrView t new_thr_idx'"

lemma [simp]: "\<not> syncing \<sigma> w b \<Longrightarrow> thrView (read_trans t b w \<sigma>) t = (thrView \<sigma> t)(var w := w)"
  by (simp add: read_trans_def rev_app_def update_thrView_def)

lemma syncing_thrView_read_trans [simp]: "syncing \<sigma> w b \<Longrightarrow>
                     thrView (read_trans t b w \<sigma>) t = ts_oride ((thrView \<sigma> t)(var w := w)) (modView \<sigma> w)"
  by (simp add: read_trans_def rev_app_def update_thrView_def)

lemma [simp]: "t' \<noteq> t \<Longrightarrow> thrView (read_trans t b w \<sigma>) t' = (thrView \<sigma> t')"
  apply (simp add: read_trans_def rev_app_def update_thrView_def)
  by (metis fun_upd_other surrey_state.ext_inject surrey_state.surjective surrey_state.update_convs(2))

lemma [simp]: "var w \<noteq> x \<Longrightarrow> b = False \<Longrightarrow> thrView (read_trans t b w \<sigma>) t x = thrView \<sigma> t x"
  by (simp add: read_trans_def rev_app_def update_thrView_def Let_def ts_oride_def)

lemma [simp]: "modView (read_trans t b w \<sigma>) = modView \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "mods (read_trans t b w \<sigma>) = mods \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "covered (read_trans t b w \<sigma>) = covered \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "writes (read_trans t b w \<sigma>) = writes \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "writes_on (read_trans t b w \<sigma>) x = writes_on \<sigma> x"
  apply(unfold writes_on_def)
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "value (read_trans t False w \<sigma>) x  = value \<sigma> x"
  apply(unfold value_def)
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

definition
  "write_trans t b w v \<sigma> ts' \<equiv>
          \<sigma> ;; update_thrView t ((thrView \<sigma> t)(var w := (var w, ts')))
            ;; update_modView (var w, ts') ((thrView \<sigma> t)(var w := (var w, ts')))
            ;; update_mods (var w, ts') \<lparr> val = v, is_releasing = b\<rparr>"

lemma [simp]: "thrView (write_trans t b w v \<sigma> ts') t = (thrView \<sigma> t)(var w := (var w, ts'))"
  by (simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "t' \<noteq> t \<Longrightarrow> thrView (write_trans t b w v \<sigma> ts') t' = (thrView \<sigma> t')"
  by (simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' = (thrView \<sigma> t)(var w := (var w, ts'))"
  apply (simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse tst_def var_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' y = modView \<sigma> w' y"
  by (auto simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow> mods (write_trans t b w v \<sigma> ts') w' = \<lparr> val = v, is_releasing = b\<rparr>"
  apply (simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse tst_def var_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> mods (write_trans t b w v \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> mods (write_trans t b w v \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "covered (write_trans t b w v \<sigma> ts') = covered \<sigma>"
  by (simp add: write_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "writes (write_trans t b w v \<sigma> ts') = writes \<sigma> \<union> {(var w, ts')}"
  by(simp add: Let_def rev_app_def
                   write_trans_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "x = var w \<Longrightarrow> writes_on (write_trans t b w v \<sigma> ts') x = writes_on \<sigma> x \<union> {(var w, ts')}"
  apply(unfold writes_on_def)
  apply(simp add: read_trans_def Let_def rev_app_def update_thrView_def)
  using Collect_cong by auto

lemma [simp]: "y \<noteq> var w \<Longrightarrow> writes_on (write_trans t b w v \<sigma> ts') y = writes_on \<sigma> y"
  apply(unfold writes_on_def)
  by(auto simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "w \<in> writes_on \<sigma> y \<Longrightarrow>  w \<in> writes_on (write_trans t b w' v \<sigma> ts') y"
  apply(unfold writes_on_def)
  by simp

definition "update_trans t w v' \<sigma> ts' \<equiv>
       let new_thr_idx = (thrView \<sigma> t)(var w := (var w, ts')) in
         let new_thr_idx' =
             if releasing \<sigma> w
             then
                 ts_oride new_thr_idx (modView \<sigma> w)
             else
                 new_thr_idx
             in
                 \<sigma> ;; update_thrView t new_thr_idx'
                   ;; update_modView (var w, ts') new_thr_idx'
                   ;; update_mods (var w, ts') \<lparr> val = v', is_releasing = True\<rparr>
                   ;; add_cv w"

definition "update_trans_a t w v' \<sigma> ts' \<equiv>
       let new_thr_idx = (thrView \<sigma> t)(var w := (var w, ts')) in
         let new_thr_idx' =
             if releasing \<sigma> w
             then
                 ts_oride new_thr_idx (modView \<sigma> w)
             else
                 new_thr_idx
             in
                 \<sigma> ;; update_thrView t new_thr_idx'
                   ;; update_modView (var w, ts') new_thr_idx'
                   ;; update_mods (var w, ts') \<lparr> val = v', is_releasing = False\<rparr>
                   ;; add_cv w"

definition "update_trans_r t w v' \<sigma> ts' \<equiv>
       let new_thr_idx = (thrView \<sigma> t)(var w := (var w, ts')) in
                 \<sigma> ;; update_thrView t new_thr_idx
                   ;; update_modView (var w, ts') new_thr_idx
                   ;; update_mods (var w, ts') \<lparr> val = v', is_releasing = True\<rparr>
                   ;; add_cv w"

definition "CAS t w cv nv' \<sigma> ts' \<equiv>
      if value \<sigma> w = cv
      then
        (update_trans t w nv' \<sigma> ts', True)
      else
        (read_trans t False w \<sigma>, False)"

definition cas_step :: "T \<Rightarrow> L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> surrey_state \<Rightarrow> surrey_state \<Rightarrow> bool"
  where
    "cas_step t l cv nv \<sigma> \<sigma>'\<equiv>
       \<exists> w ts'. w \<in> visible_writes \<sigma> t l \<and>
               w \<notin> covered \<sigma> \<and>
               valid_fresh_ts \<sigma> w ts' \<and>
       \<sigma>' = fst(CAS t w cv nv \<sigma> ts')"

lemma [simp]: "\<not> releasing \<sigma> w \<Longrightarrow>
                     thrView (update_trans  t w v' \<sigma> ts') t = (thrView \<sigma> t)(var w := (var w, ts'))"
  by (simp add: Let_def rev_app_def update_modView_def update_mods_def update_thrView_def update_trans_def add_cv_def)

lemma [simp]: "\<not> releasing \<sigma> w \<Longrightarrow>
                     thrView (update_trans_a  t w v' \<sigma> ts') t = (thrView \<sigma> t)(var w := (var w, ts'))"
  by (simp add: Let_def rev_app_def update_modView_def update_mods_def update_thrView_def update_trans_a_def add_cv_def)

lemma [simp]: " releasing \<sigma> w \<Longrightarrow>
                  thrView (update_trans  t w v' \<sigma> ts') t = ts_oride ((thrView \<sigma> t)(var w := (var w, ts'))) (modView \<sigma> w)"
  by (auto simp add: Let_def update_trans_def add_cv_def rev_app_def update_modView_def update_mods_def update_thrView_def)

lemma [simp]: " releasing \<sigma> w \<Longrightarrow>
                  thrView (update_trans_a  t w v' \<sigma> ts') t = ts_oride ((thrView \<sigma> t)(var w := (var w, ts'))) (modView \<sigma> w)"
  by (auto simp add: Let_def update_trans_a_def add_cv_def rev_app_def update_modView_def update_mods_def update_thrView_def)

lemma [simp]: "thrView (update_trans_r  t w v' \<sigma> ts') t = (thrView \<sigma> t)(var w := (var w, ts'))"
  by (simp add: Let_def rev_app_def update_modView_def update_mods_def update_thrView_def update_trans_r_def add_cv_def)

lemma [simp]: "t' \<noteq> t \<Longrightarrow> thrView (update_trans  t w v' \<sigma> ts') t' = (thrView \<sigma> t')"
  by (simp add: Let_def update_trans_def add_cv_def rev_app_def update_modView_def update_mods_def update_thrView_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
             \<not> releasing \<sigma> w \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = (thrView \<sigma> t)(var w := (var w, ts'))"
  apply (simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse tst_def var_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
             releasing \<sigma> w \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = ts_oride ((thrView \<sigma> t)(var w := (var w, ts'))) (modView \<sigma> w)"
  apply (simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse tst_def var_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: Let_def fun_upd_idem_iff fun_upd_twist rev_app_def update_modView_def update_mods_def update_thrView_def update_trans_def add_cv_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> mods (update_trans t w v' \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> mods (update_trans t w v' \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
             mods (update_trans t w v' \<sigma> ts') w' = \<lparr> val = v', is_releasing = True\<rparr>"
  apply (simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse tst_def var_def)

lemma [simp]: "covered (update_trans t w v' \<sigma> ts')  = covered \<sigma> \<union> {w}"
  by (simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "writes (update_trans t w v' \<sigma> ts') = writes \<sigma> \<union> {(var w, ts')}"
 by (auto simp add: Let_def update_trans_def rev_app_def add_cv_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "x = var w \<Longrightarrow> writes_on (update_trans t w v' \<sigma> ts') x = writes_on \<sigma> x \<union> {(x, ts')}"
  apply(unfold writes_on_def)
  apply(simp add: read_trans_def Let_def rev_app_def update_thrView_def)
  using Collect_cong by auto

lemma [simp]: "y \<noteq> var w \<Longrightarrow> writes_on (update_trans t w v' \<sigma> ts') y = writes_on \<sigma> y"
  apply(unfold writes_on_def)
  by(auto simp add: read_trans_def Let_def rev_app_def update_thrView_def)

definition step :: "T \<Rightarrow> action \<Rightarrow> surrey_state \<Rightarrow> surrey_state \<Rightarrow> bool"
  where
    "step t a \<sigma> \<sigma>'\<equiv>
       \<exists> w. w \<in> visible_writes \<sigma> t (avar a) \<and>
       (case a of
         Read b x v \<Rightarrow>
           v = value \<sigma> w \<and>
           \<sigma>' = read_trans t b w \<sigma>
       | Write b x v \<Rightarrow> \<exists> ts'.
           w \<notin> covered \<sigma> \<and>
           valid_fresh_ts \<sigma> w ts' \<and>
           \<sigma>' = write_trans t b w v \<sigma> ts'
       | Update x v v' \<Rightarrow> \<exists> ts'.
           v = value \<sigma> w \<and>
           w \<notin> covered \<sigma> \<and>
           valid_fresh_ts \<sigma> w ts' \<and>
           \<sigma>' = update_trans t w v' \<sigma> ts')
           "

lemma step_cases:
       "step t a \<sigma> \<sigma>'
          \<Longrightarrow>
        \<lbrakk>\<And> w b x v. \<sigma>' = read_trans t b w \<sigma> \<and> a = Read b x v \<and> w \<in> visible_writes \<sigma> t (avar a) \<and>
          v = value \<sigma> w \<Longrightarrow> P \<sigma> (read_trans t b w \<sigma>)\<rbrakk>
         \<Longrightarrow>
       \<lbrakk>\<And> w b x v ts'. \<sigma>' = write_trans t b w v \<sigma> ts' \<and> a = Write b x v \<and> w \<in> visible_writes \<sigma> t (avar a) \<and>
           w \<notin> covered \<sigma> \<and>
           valid_fresh_ts \<sigma> w ts'
           \<Longrightarrow> P \<sigma> (write_trans t b w v \<sigma> ts') \<rbrakk>
         \<Longrightarrow>
       \<lbrakk>\<And> w x v v' ts'. \<sigma>' = update_trans t w v' \<sigma> ts' \<and> a = Update x v v' \<and>
           w \<in> visible_writes \<sigma> t (avar a) \<and>
           v = value \<sigma> w \<and>
           w \<notin> covered \<sigma> \<and>
           valid_fresh_ts \<sigma> w ts'
           \<Longrightarrow> P \<sigma> (update_trans t w v' \<sigma> ts')\<rbrakk>
  \<Longrightarrow> P \<sigma> \<sigma>'"
  apply(simp add: step_def) apply(case_tac a) by auto

definition "WrX x v \<equiv> Write False x v"
definition "WrR x v \<equiv> Write True x v"
definition "RdX x v \<equiv> Read False x v"
definition "RdA x v \<equiv> Read True x v"

abbreviation WrX_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ := _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [x := v]\<^sub>t \<sigma>' \<equiv> step t (WrX x v) \<sigma> \<sigma>'"

abbreviation WrR_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ :=\<^sup>R _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [x :=\<^sup>R v]\<^sub>t \<sigma>' \<equiv> step t (WrR x v) \<sigma> \<sigma>'"

abbreviation RdX_state_abbr:: " surrey_state \<Rightarrow> V \<Rightarrow> L \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ \<leftarrow> _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [r \<leftarrow> x]\<^sub>t \<sigma>' \<equiv> step t (RdX x r) \<sigma> \<sigma>'"

abbreviation RdA_state_abbr:: " surrey_state \<Rightarrow> V \<Rightarrow> L \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ \<leftarrow>\<^sup>A _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [r \<leftarrow>\<^sup>A x]\<^sub>t \<sigma>' \<equiv> step t (RdA x r) \<sigma> \<sigma>'"

abbreviation Up_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ RMW[_, _, _]\<^sub>_ _" [100,100,100,100,100,100])
  where "\<sigma> RMW[x, u, v]\<^sub>t \<sigma>' \<equiv> step t (Update x u v) \<sigma> \<sigma>'"

abbreviation Up_A_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ RMW\<^sup>A[_, _, _]\<^sub>_ _" [100,100,100,100,100,100])
  where "\<sigma> RMW\<^sup>A[x, u, v]\<^sub>t \<sigma>' \<equiv> step t (Update x u v) \<sigma> \<sigma>'"

abbreviation Up_R_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ RMW\<^sup>R[_, _, _]\<^sub>_ _" [100,100,100,100,100,100])
  where "\<sigma> RMW\<^sup>R[x, u, v]\<^sub>t \<sigma>' \<equiv> step t (Update x u v) \<sigma> \<sigma>'"

abbreviation Swap_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ SWAP[_, _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> SWAP[x, v]\<^sub>t \<sigma>' \<equiv> \<exists>u . step t (Update x u v) \<sigma> \<sigma>'"

definition "initial_state \<sigma> I \<equiv>
                 \<exists> F . writes \<sigma> = {(x, F x) | x. True} \<and>
                       (\<forall> t x. thrView \<sigma> t x = (x, F x)) \<and>
                       (\<forall> w x. modView \<sigma> w x = (x, F x)) \<and>
                       (\<forall> w. mods \<sigma> w = \<lparr> val = I (var w), is_releasing = False \<rparr>) \<and>
                       covered \<sigma> = {}"

definition
  "wfs \<sigma> \<equiv>
      (\<forall> t x. thrView \<sigma> t x \<in> writes_on \<sigma> x) \<and>
      (\<forall> w x. modView \<sigma> w x \<in> writes_on \<sigma> x) \<and>
      (\<forall> x. finite(writes_on \<sigma> x)) \<and>
      (\<forall> w. w \<in> writes \<sigma> \<longrightarrow> modView \<sigma> w (var w) = w) \<and>
      covered \<sigma> \<subseteq> writes \<sigma>"

definition "lastWr \<sigma> x \<equiv> (x, Max (tst`(writes_on \<sigma> x)))"

definition "p_obs \<sigma> t x u \<equiv> \<exists> w. w \<in> visible_writes \<sigma> t x \<and> u = value \<sigma> w"

definition "d_obs \<sigma> view x u \<equiv> view x = lastWr \<sigma> x \<and> value \<sigma> (lastWr \<sigma> x) = u"

definition "d_obs_t \<sigma> t x u \<equiv> d_obs \<sigma> (thrView \<sigma> t) x u"

definition "c_obs \<sigma> x u t y v \<equiv>
              \<forall> w \<in> visible_writes \<sigma> t x. value \<sigma> w = u \<longrightarrow>
                         d_obs \<sigma> (modView \<sigma> w) y v \<and>
                         releasing \<sigma> w"

abbreviation p_obs_abbr:: "nat  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[_ \<approx>\<^sub>_ _] _" [100, 100, 100, 100])
  where "[x \<approx>\<^sub>t u] \<sigma> \<equiv> p_obs \<sigma> t x u"

abbreviation d_obs_abbr:: "nat  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> surrey_state \<Rightarrow> bool" ("[_ =\<^sub>_ _] _" [100, 100, 100, 100])
  where "[x =\<^sub>t u] \<sigma> \<equiv> d_obs_t \<sigma> t x u"

abbreviation c_obs_abbr:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> surrey_state \<Rightarrow> bool" ("[_ = _]\<^sub>_\<lparr>_ = _ \<rparr> _" [100, 100, 100, 100, 100, 100])
  where "[x = u]\<^sub>t\<lparr>y = v\<rparr> \<sigma> \<equiv> c_obs \<sigma> x u t y v"

definition "covered_v \<sigma> x v \<equiv> \<forall> w .  w \<in> writes_on \<sigma> x \<and> w \<notin> covered \<sigma> \<longrightarrow> w = lastWr \<sigma> x \<and> value \<sigma> w = v"

abbreviation covered_v_abbr:: "L \<Rightarrow> V  \<Rightarrow> surrey_state \<Rightarrow> bool" ("cvd[_, _] _" [100, 100,100])
  where "cvd[x, u] \<sigma> \<equiv> covered_v \<sigma> x u"

definition "mo w w'\<equiv> var(w) = var(w') \<and> tst(w) < tst(w')"

definition "enc \<sigma> view x u \<equiv> \<exists> w . w \<in> writes_on \<sigma> x \<and> tst(w) \<le> tst(view x) \<and> value \<sigma> w = u"

definition "enc_t \<sigma> t x u \<equiv>  enc \<sigma> (thrView \<sigma> t) x u"

definition "p_vorder \<sigma> u x v \<equiv> \<exists> w w'.  w \<in> writes_on \<sigma> x  \<and>  w' \<in> writes_on \<sigma> x \<and>
                                        value \<sigma> w = u \<and> value \<sigma> w' = v \<and>
                                        mo w w' "

definition "d_vorder \<sigma> u x v \<equiv> (\<forall> w w'.  w \<in> writes_on \<sigma> x  \<and>  w' \<in> writes_on \<sigma> x \<and>
                                        value \<sigma> w = u \<and> value \<sigma> w' = v \<longrightarrow>
                                        mo w w') \<and> p_vorder \<sigma> u x v"

definition "init_val \<sigma> x v \<equiv>
  \<exists> w . w \<in> writes_on \<sigma> x \<and>
        (\<forall>w'\<in> writes_on \<sigma> x .  w \<noteq> w' \<longrightarrow>  mo w w') \<and>
        value \<sigma> w = v"

definition "amo \<sigma> x u \<equiv> \<not> p_vorder \<sigma> u x u"

definition "no_val \<sigma> x i u \<equiv> init_val \<sigma> x i \<and> \<not> p_vorder \<sigma> i x u"

definition "last_val \<sigma> x u i \<equiv>
                init_val \<sigma> x i \<and> p_vorder \<sigma> i x u
                \<and> (\<forall> w. w \<noteq> u \<longrightarrow> \<not> p_vorder \<sigma> u x w)"

abbreviation p_vorder_abbr:: "V  \<Rightarrow> L \<Rightarrow> V \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[_ \<leadsto>\<^sub>_ _] _" [100,100,100,100])
  where "[u \<leadsto>\<^sub>x v] \<sigma> \<equiv> p_vorder \<sigma> u x v"

abbreviation d_vorder_abbr:: "V  \<Rightarrow> L \<Rightarrow> V \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[_ \<hookrightarrow>\<^sub>_ _] _" [100,100,100,100])
  where "[u \<hookrightarrow>\<^sub>x v] \<sigma> \<equiv> d_vorder \<sigma> u x v"

abbreviation amo_abbr:: "L \<Rightarrow> V \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[\<one>\<^sub>_ _] _" [100,100,100])
  where "[\<one>\<^sub>x u] \<sigma> \<equiv> amo \<sigma> x u"

abbreviation no_abbr:: "L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> surrey_state \<Rightarrow> bool" ("[\<zero>\<^sub>_ _]\<^sub>_ _" [100,100,100,100])
  where "[\<zero>\<^sub>x u]\<^sub>i \<sigma> \<equiv> no_val \<sigma> x i u"

abbreviation enc_abbr:: "L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("[en _ _]\<^sub>_ _" [100,100,100,100])
  where "[en x u]\<^sub>t \<sigma> \<equiv> enc_t \<sigma> t x u"

abbreviation last_abbr:: "L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("[last _ _ _]\<^sub>_ _" [100, 100,100,100,100])
  where "[last x i u]\<^sub>t \<sigma> \<equiv> last_val \<sigma> x u i"

abbreviation init_abbr:: "L \<Rightarrow> V  \<Rightarrow> surrey_state \<Rightarrow> bool" ("[init _ _] _" [100, 100,100])
  where "[init x v] \<sigma> \<equiv> init_val \<sigma> x v"

lemma initially_write_unique: "initial_state \<sigma> I \<Longrightarrow> w \<in> writes_on \<sigma> x \<Longrightarrow> w' \<in> writes_on \<sigma> x \<Longrightarrow> w = w'"
  apply(unfold initial_state_def writes_on_def) by auto

lemma initial_wfs: assumes "initial_state \<sigma> I"  shows "wfs \<sigma>"
  apply(simp add: initial_state_def wfs_def)
  apply(rule conjI)
  using assms writes_on_def
   apply (smt CollectI fst_conv initial_state_def var_def)
  apply(rule conjI)
  using assms writes_on_def initial_state_def apply simp
  apply (smt CollectI fst_conv initial_state_def var_def writes_on_def)
  apply rule using initially_write_unique[OF assms(1)]
  apply (smt CollectI Collect_cong finite.emptyI finite.insertI insert_compr not_finite_existsD singletonD writes_on_def)
    apply(rule conjI)
  apply (smt CollectD Pair_inject assms initial_state_def)
  using assms initial_state_def by fastforce

lemma [simp]: "wfs \<sigma> \<Longrightarrow> writes_on \<sigma> x \<noteq> {}"
  apply(simp add: wfs_def)
  by (metis empty_iff)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> finite(writes_on \<sigma> x)"
  by(simp add: wfs_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> thrView \<sigma> t x \<in> writes_on \<sigma> x"
  by(simp add: wfs_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> modView \<sigma> w x \<in> writes_on \<sigma> x"
  using wfs_def by blast

lemma [simp]: "wfs \<sigma> \<Longrightarrow> modView (read_trans t b w \<sigma>) w x \<in> writes_on (read_trans t b w \<sigma>) x"
  by auto

lemma [simp]: "wfs \<sigma> \<Longrightarrow> writes_on \<sigma> x =  writes_on (read_trans t b w \<sigma>) x"
  by auto

lemma last_write_max: "wfs \<sigma> \<Longrightarrow> w \<in> writes_on \<sigma> x \<Longrightarrow> tst w \<le> tst (lastWr \<sigma> x)"
  by(simp add: lastWr_def)
end


(*
 * Copyright Florian Haftmann
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Ancient comprehensive Word Library\<close>

theory Word_Lib_Sumo
imports
  "HOL-Library.Word"
  Aligned
  Bit_Comprehension
  Bit_Comprehension_Int
  Bit_Shifts_Infix_Syntax
  Bits_Int
  Bitwise_Signed
  Bitwise
  Enumeration_Word
  Generic_set_bit
  Hex_Words
  Least_significant_bit
  More_Arithmetic
  More_Divides
  More_Sublist
  Even_More_List
  More_Misc
  Strict_part_mono
  Legacy_Aliases
  Most_significant_bit
  Next_and_Prev
  Norm_Words
  Reversed_Bit_Lists
  Rsplit
  Signed_Words
  Syntax_Bundles
  Typedef_Morphisms
  Type_Syntax
  Word_EqI
  Word_Lemmas
  Word_8
  Word_16
  Word_32
  Word_Syntax
  Signed_Division_Word
  Singleton_Bit_Shifts
  More_Word_Operations
  Many_More
begin

unbundle bit_operations_syntax
unbundle bit_projection_infix_syntax

declare word_induct2[induct type]
declare word_nat_cases[cases type]

declare signed_take_bit_Suc [simp]

(* these generate take_bit terms, which we often don't want for concrete lengths *)
lemmas of_int_and_nat = unsigned_of_nat unsigned_of_int signed_of_int signed_of_nat

bundle no_take_bit
begin
declare of_int_and_nat[simp del]
end

lemmas bshiftr1_def = bshiftr1_eq
lemmas is_down_def = is_down_eq
lemmas is_up_def = is_up_eq
lemmas mask_def = mask_eq
lemmas scast_def = scast_eq
lemmas shiftl1_def = shiftl1_eq
lemmas shiftr1_def = shiftr1_eq
lemmas sshiftr1_def = sshiftr1_eq
lemmas sshiftr_def = sshiftr_eq_funpow_sshiftr1
lemmas to_bl_def = to_bl_eq
lemmas ucast_def = ucast_eq
lemmas unat_def = unat_eq_nat_uint
lemmas word_cat_def = word_cat_eq
lemmas word_reverse_def = word_reverse_eq_of_bl_rev_to_bl
lemmas word_roti_def = word_roti_eq_word_rotr_word_rotl
lemmas word_rotl_def = word_rotl_eq
lemmas word_rotr_def = word_rotr_eq
lemmas word_sle_def = word_sle_eq
lemmas word_sless_def = word_sless_eq

lemmas uint_0 = uint_nonnegative
lemmas uint_lt = uint_bounded
lemmas uint_mod_same = uint_idem
lemmas of_nth_def = word_set_bits_def

lemmas of_nat_word_eq_iff = word_of_nat_eq_iff
lemmas of_nat_word_eq_0_iff = word_of_nat_eq_0_iff
lemmas of_int_word_eq_iff = word_of_int_eq_iff
lemmas of_int_word_eq_0_iff = word_of_int_eq_0_iff

lemmas word_next_def = word_next_unfold

lemmas word_prev_def = word_prev_unfold

lemmas is_aligned_def = is_aligned_iff_dvd_nat

lemmas word_and_max_simps =
  word8_and_max_simp
  word16_and_max_simp
  word32_and_max_simp

lemma distinct_lemma: "f x \<noteq> f y \<Longrightarrow> x \<noteq> y" by auto

lemmas and_bang = word_and_nth

lemmas sdiv_int_def = signed_divide_int_def
lemmas smod_int_def = signed_modulo_int_def

(* shortcut for some specific lengths *)
lemma word_fixed_sint_1[simp]:
  "sint (1::8 word) = 1"
  "sint (1::16 word) = 1"
  "sint (1::32 word) = 1"
  "sint (1::64 word) = 1"
  by (auto simp: sint_word_ariths)

declare of_nat_diff [simp]

(* Haskellish names/syntax *)
notation (input)
  bit ("testBit")

lemmas cast_simps = cast_simps ucast_down_bl

(* shadows the slightly weaker Word.nth_ucast *)
lemma nth_ucast:
  "(ucast (w::'a::len word)::'b::len word) !! n =
   (w !! n \<and> n < min LENGTH('a) LENGTH('b))"
  by (auto simp add: bit_simps not_le dest: bit_imp_le_length)

end