section \<open> Reactive Programs \<close>

theory utp_rea_prog
  imports utp_rea_cond "Shallow-Expressions.Shallow_Expressions" "Optics.Optics" "UTP2.utp" "UTP2.utp_pred"
begin

subsection \<open> Stateful reactive alphabet \<close>

text \<open> @{term R3} as presented in the UTP book and related publications is not sensitive to state,
  although reactive programs often need this property. Thus is is necessary to use a modification
  of @{term R3} from Butterfield et al.~\cite{BGW09} that explicitly states that intermediate
  waiting states do not propagate final state variables. In order to do this we need an additional
  observational variable that capture the program state that we call $st$. Upon this foundation,
  we can define operators for reactive programs~\cite{Foster17c}. \<close>

(* Changes from UTP1: renamed to reflect the 'rea' naming convention and line up with lemmata. *)
alphabet ('t, 's) srea_vars = "'t::trace rea_vars" +
  st :: 's

(* TODO(@MattWindsor91): do we need the type synonyms and translations? *)

type_synonym ('s,'t,'\<alpha>) rsp = "('t, 's, '\<alpha>) srea_vars_scheme" \<comment> \<open> Reactive state predicate \<close>
type_synonym ('s,'t,'\<alpha>,'\<beta>) rel_rsp  = "(('s,'t,'\<alpha>) rsp, ('s,'t,'\<beta>) rsp) urel" \<comment> \<open> Relation on the above \<close>
type_synonym ('s,'t,'\<alpha>) hrel_rsp  = "('s,'t,'\<alpha>,'\<alpha>) rel_rsp" \<comment> \<open> Homogeneous relation on the above \<close>
type_synonym ('s,'t) rdes = "('s,'t,unit) hrel_rsp" \<comment> \<open> Reactive design? \<close>

(* Needed to have a bidirectional mapping on the shorthands.
   TODO(@MattWindsor91): should these be called srea etc.? *)
translations
  (type) "('s,'t,'\<alpha>) rsp" <= (type) "('t, ('s, '\<alpha>) srea_vars_ext) rp"
  (type) "('s,'t,'\<alpha>) rsp" <= (type) "('t, ('s, '\<alpha>) srea_vars_scheme) rp"
  (type) "('s,'t,unit) rsp" <= (type) "('t, 's srea_vars) rp"
  (type) "('s,'t,'\<alpha>,'\<beta>) rel_rsp" <= (type) "(('s,'t,'\<alpha>) rsp, ('s1,'t1,'\<beta>) rsp) urel"
  (type) "('s,'t,'\<alpha>) hrel_rsp"  <= (type) "(('s, 't, '\<alpha>) rsp, ('s1,'t1,'\<alpha>1) rsp) urel" (* ? *)
  (type) "('s,'t) rdes" <= (type) "('s, 't, unit) hrel_rsp"

text \<open> Shorthand for the non-control alphabet of a stateful reactive process. \<close>

notation srea_vars.more\<^sub>L ("\<^bold>v\<^sub>S")

syntax
  "_svid_srea_alpha"  :: "svid" ("\<^bold>v\<^sub>S")

translations
  "_svid_srea_alpha" => "CONST srea_vars.more\<^sub>L"

text \<open> As a stateful reactive process adds 'st' to the alphabet of a reactive process, we can
  consider the continuation of its reactive alphabet as the sum of 'st' and the continuation of the
stateful reactive alphabet. \<close>
lemma rea_lens_equiv_st_rest: "\<^bold>v\<^sub>R \<approx>\<^sub>L st +\<^sub>L \<^bold>v\<^sub>S"
  by simp

text \<open> Pairing the reactive stateful alphabet with its control variables forms a bijective lens. \<close>
lemma srea_lens_bij: "bij_lens (ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L st +\<^sub>L \<^bold>v\<^sub>S)"
proof -
  have "ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L st +\<^sub>L \<^bold>v\<^sub>S \<approx>\<^sub>L ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L \<^bold>v\<^sub>R"
    by (auto intro!:lens_plus_cong, rule lens_equiv_sym, simp add: rea_lens_equiv_st_rest)
  also have "... \<approx>\<^sub>L 1\<^sub>L"
    using bij_lens_equiv_id[of "ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L \<^bold>v\<^sub>R"]
      by (simp add: rea_lens_bij)
  finally show ?thesis
    by (simp add: bij_lens_equiv_id)
qed

lemma st_qual_alpha (*[alpha]*): "x ;\<^sub>L fst\<^sub>L ;\<^sub>L st \<times>\<^sub>L st = ((st\<^sup><):x)\<^sub>v"
proof -
  have "x ;\<^sub>L fst\<^sub>L ;\<^sub>L st \<times>\<^sub>L st = x ;\<^sub>L fst\<^sub>L ;\<^sub>L (st ;\<^sub>L fst\<^sub>L +\<^sub>L st ;\<^sub>L snd\<^sub>L)"
    by (simp add: prod_as_plus)
  also have "\<dots> =  x ;\<^sub>L (fst\<^sub>L ;\<^sub>L (st ;\<^sub>L fst\<^sub>L +\<^sub>L st ;\<^sub>L snd\<^sub>L))" by (simp add: lens_comp_assoc)
  also have "\<dots> = x ;\<^sub>L (st ;\<^sub>L fst\<^sub>L)" by (simp add: comp_wb_lens fst_lens_plus)
  also have "\<dots> = ((st\<^sup><):x)\<^sub>v" by (simp add: ns_alpha_def)
  finally show ?thesis .
qed

lemma unrest_st'_neg_RC [unrest]:
  assumes "P is RR" "P is RC"
  shows "$st\<^sup>> \<sharp> P"
proof -
  have "P = (\<not>\<^sub>r (\<not>\<^sub>r P))"
    by (simp add: closure rpred assms)
  also have "... = (\<not>\<^sub>r (\<not>\<^sub>r P) ;; true\<^sub>r)"
    by (metis Healthy_if RC1_def RC_implies_RC1 assms(2) calculation)
  finally have "P = ..." .
  moreover have "$st\<^sup>> \<sharp> ..."
    by pred_auto
  ultimately show "$st\<^sup>> \<sharp> P"
    by simp
qed

lemma ex_st'_RR_closed [closure]:
  assumes "P is RR"
  shows "(\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>/st\<^sup>>\<rbrakk>) is RR"
proof -
  have 1: "$ok\<^sup>< \<sharp> P" "$ok\<^sup>> \<sharp> P" "$wait\<^sup>< \<sharp> P" "$wait\<^sup>> \<sharp> P"
    using assms RR_unrests by blast+
  have 2: "$ok\<^sup>< \<sharp> (\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>/st\<^sup>>\<rbrakk>)" "$ok\<^sup>> \<sharp> (\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>/st\<^sup>>\<rbrakk>)" "$wait\<^sup>< \<sharp> (\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>/st\<^sup>>\<rbrakk>)" "$wait\<^sup>> \<sharp> (\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>/st\<^sup>>\<rbrakk>)"
    by (simp_all add: unrest 1)
  have 3: "P = R2(P)"
    by (simp add: assms Healthy_if RR_implies_R2)
  have 4: "(\<Sqinter> s. P\<lbrakk>\<guillemotleft>s\<guillemotright>/st\<^sup>>\<rbrakk>) is R2"
    by (subst 3; pred_auto)
  from 2 4 show ?thesis
    using RR_R2_intro by blast
qed

lemma unrest_st'_R4 [unrest]:
  "$st\<^sup>> \<sharp> P \<Longrightarrow> $st\<^sup>> \<sharp> R4(P)"
  by pred_auto

lemma unrest_st'_R5 [unrest]:
  "$st\<^sup>> \<sharp> P \<Longrightarrow> $st\<^sup>> \<sharp> R5(P)"
  by pred_auto

subsection \<open> State Lifting \<close>

(* TODO: can we write this type better? *)
abbreviation lift_srea :: "('c \<times> 'f \<Rightarrow> 'g) \<Rightarrow> ('a::trace, 'b, 'c) srea_vars_scheme \<times> ('d::trace, 'e, 'f) srea_vars_scheme \<Rightarrow> 'g" ("\<lceil>_\<rceil>\<^sub>S") where
"\<lceil>P\<rceil>\<^sub>S \<equiv> P \<up> (\<^bold>v\<^sub>S\<^sup>2)"

term lift_state_rel

(* "('s, 't, '\<alpha>, '\<beta>) rel_rsp \<Rightarrow> ('\<alpha>, '\<beta>) urel" *)
abbreviation drop_state_rel :: "(('d::trace, 'e, 'a) srea_vars_scheme \<times> ('f::trace, 'g, 'b) srea_vars_scheme \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" ("\<lfloor>_\<rfloor>\<^sub>S")
where "\<lfloor>P\<rfloor>\<^sub>S \<equiv> P \<down> (\<^bold>v\<^sub>S\<^sup>2)"

abbreviation lift_state_pre ("\<lceil>_\<rceil>\<^sub>S\<^sub><")
  where "\<lceil>p\<rceil>\<^sub>S\<^sub>< \<equiv> \<lceil>p\<^sup><\<rceil>\<^sub>S"

abbreviation drop_state_pre ("\<lfloor>_\<rfloor>\<^sub>S\<^sub><")
where "\<lfloor>p\<rfloor>\<^sub>S\<^sub>< \<equiv> (\<lfloor>p\<rfloor>\<^sub>S)\<^sub><"

abbreviation lift_state_post ("\<lceil>_\<rceil>\<^sub>S\<^sub>>")
where "\<lceil>p\<rceil>\<^sub>S\<^sub>> \<equiv> \<lceil>p\<^sup>>\<rceil>\<^sub>S"

abbreviation drop_state_post ("\<lfloor>_\<rfloor>\<^sub>S\<^sub>>")
where "\<lfloor>p\<rfloor>\<^sub>S\<^sub>> \<equiv> (\<lfloor>p\<rfloor>\<^sub>S)\<^sub>>"

lemma st_unrest_state_pre [unrest]: "(unrest \<top>\<^sub>S s) \<Longrightarrow> $st\<^sup>< \<sharp> \<lceil>s\<rceil>\<^sub>S\<^sub><"
  by pred_auto

lemma st'_unrest_st_lift_pred [unrest]:
  "$st\<^sup>> \<sharp> \<lceil>a\<rceil>\<^sub>S\<^sub><"
  by pred_auto

lemma out_alpha_unrest_st_lift_pre [unrest]:
  "out\<alpha> \<sharp> \<lceil>a\<rceil>\<^sub>S\<^sub><"
  by pred_auto

lemma R1_st'_unrest [unrest]: "$st\<^sup>> \<sharp> P \<Longrightarrow> $st\<^sup>> \<sharp> R1(P)"
  by pred_auto

lemma R2c_st'_unrest [unrest]: "$st\<^sup>> \<sharp> P \<Longrightarrow> $st\<^sup>> \<sharp> R2c(P)"
  by pred_auto

lemma unrest_st_rea_rename [unrest]:
  "$st\<^sup>< \<sharp> P \<Longrightarrow> $st\<^sup>< \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  "$st\<^sup>> \<sharp> P \<Longrightarrow> $st\<^sup>> \<sharp> P\<lparr>f\<rparr>\<^sub>r"
  by (pred_auto, blast)+

lemma st_lift_R1_true_right: "(\<lceil>b\<rceil>\<^sub>S\<^sub>< ;; R1(true)) = \<lceil>b\<rceil>\<^sub>S\<^sub><"
  by pred_auto

lemma R2c_lift_state_pre: "R2c(\<lceil>b\<rceil>\<^sub>S\<^sub><) = \<lceil>b\<rceil>\<^sub>S\<^sub><"
  by pred_auto

subsection \<open> Reactive Program Operators \<close>

subsubsection \<open> State Substitution \<close>

text \<open> Lifting substitutions on the reactive state \<close>

(* TODO(@MattWindsor91): should this (and the others) be going to [rel], or somewhere else? *)

text \<open> The following two functions lift a predicate substitution to a relational one. \<close>

abbreviation usubst_rel_lift :: "'\<alpha> subst \<Rightarrow> ('\<alpha> \<times> '\<beta>) subst" ("\<lceil>_\<rceil>\<^sub>s") where
"\<lceil>\<sigma>\<rceil>\<^sub>s \<equiv> subst_aext \<sigma> fst\<^sub>L"

abbreviation usubst_rel_drop :: "('\<alpha> \<times> '\<alpha>) subst \<Rightarrow> '\<alpha> subst" ("\<lfloor>_\<rfloor>\<^sub>s") where
"\<lfloor>\<sigma>\<rfloor>\<^sub>s \<equiv> subst_ares \<sigma> fst\<^sub>L"

(* TODO(@MattWindsor91) *)
(* :: "'s subst \<Rightarrow> (('s,'t::trace,'\<alpha>) rsp \<times> ('s,'t,'\<beta>) rsp) subst" *)
definition subst_st_lift  ("\<lceil>_\<rceil>\<^sub>S\<^sub>\<sigma>") where
[pred]: "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> = \<lceil>\<sigma> \<up>\<^sub>s st\<rceil>\<^sub>s"

expr_constructor subst_st_lift
(*  \<lceil>subst_aext \<sigma> st\<rceil>\<^sub>S\<^sub><" *)

(*  :: "'s subst \<Rightarrow> ('s,'t::trace,'\<alpha>,'\<beta>) rel_rsp \<Rightarrow> ('s, 't, '\<alpha>, '\<beta>) rel_rsp" *)
abbreviation st_subst (infixr "\<dagger>\<^sub>S" 80) where
"\<sigma> \<dagger>\<^sub>S P \<equiv> \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> P"

translations
  "\<sigma> \<dagger>\<^sub>S P" <= "\<lceil>\<sigma> \<up> st\<rceil>\<^sub>S \<dagger> P"
  "\<sigma> \<dagger>\<^sub>S P" <= "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> P"

expr_constructor st_subst

lemma st_lift_lemma:
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> = (subst_aext \<sigma> (fst\<^sub>L ;\<^sub>L (st \<times>\<^sub>L st)))"
  by pred_auto

(*
lemma unrest_st_lift [unrest]:
  fixes x :: "'a \<Longrightarrow> ('s, 't::trace, '\<alpha>) rsp \<times> ('s, 't, '\<alpha>) rsp"
  assumes "x \<bowtie> (st)\<^sub>v"
  shows "x \<sharp>\<^sub>s \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma>" (is "?P")
  by (simp add: st_lift_lemma)
     (metis assms in_var_def in_var_prod_lens lens_comp_left_id st_vwb_lens unrest_subst_alpha_ext vwb_lens_wb)
*)

lemma id_st_subst [usubst]:
  "\<lceil>[\<leadsto>]\<rceil>\<^sub>S\<^sub>\<sigma> = [\<leadsto>]"
  by pred_auto

lemma st_subst_comp [usubst]:
  "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<circ>\<^sub>s \<lceil>\<rho>\<rceil>\<^sub>S\<^sub>\<sigma> = \<lceil>\<sigma> \<circ>\<^sub>s \<rho>\<rceil>\<^sub>S\<^sub>\<sigma>"
  by pred_auto

definition lift_cond_srea ("\<lceil>_\<rceil>\<^sub>S\<^sub>\<leftarrow>") where
[pred]: "\<lceil>b\<rceil>\<^sub>S\<^sub>\<leftarrow> = \<lceil>b\<rceil>\<^sub>S\<^sub><"

expr_constructor lift_cond_srea

lemma unrest_lift_cond_srea [unrest]:
  "x \<sharp> \<lceil>b\<rceil>\<^sub>S\<^sub>< \<Longrightarrow> x \<sharp> \<lceil>b\<rceil>\<^sub>S\<^sub>\<leftarrow>"
  by (simp add: lift_cond_srea_def)

lemma st_subst_RR_closed [closure]:
  assumes "P is RR"
  shows "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> P is RR"
proof -
  have "RR(\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> RR(P)) = \<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> RR(P)"
    by pred_auto
  thus ?thesis
    by (metis Healthy_def assms)
qed

declare [[show_types]]

(* TODO: why doesn't this proof work? *)
lemma subst_lift_cond_srea [usubst]: "\<sigma> \<dagger>\<^sub>S \<lceil>P\<rceil>\<^sub>S\<^sub>\<leftarrow> = \<lceil>\<sigma> \<dagger> P\<rceil>\<^sub>S\<^sub>\<leftarrow>"
  apply pred_auto
  oops

lemma st_subst_rea_not [usubst]: "\<sigma> \<dagger>\<^sub>S (\<not>\<^sub>r P) = (\<not>\<^sub>r \<sigma> \<dagger>\<^sub>S P)"
  by pred_auto

lemma st_subst_seq [usubst]: "\<sigma> \<dagger>\<^sub>S (P ;; Q) = \<sigma> \<dagger>\<^sub>S P ;; Q"
  by pred_auto

lemma st_subst_RC_closed [closure]:
  assumes "P is RC"
  shows "\<sigma> \<dagger>\<^sub>S P is RC"
  apply (rule RC_intro, simp add: closure assms)
  apply (simp add: st_subst_rea_not[THEN sym] st_subst_seq[THEN sym])
  apply (metis Healthy_if RC1_def RC_implies_RC1 assms)
  done

subsubsection \<open> Assignment \<close>

text \<open> An assignment in the stateful reactive \<close>

(* :: "(('s, 's) psubst) \<Rightarrow> ('s, 't::trace, '\<alpha>) hrel_rsp"  *)
definition rea_assigns ("\<langle>_\<rangle>\<^sub>r") where
[pred]: "\<langle>\<sigma>\<rangle>\<^sub>r = ((tr\<^sup>< = tr\<^sup>>)\<^sub>e \<and> \<lceil>\<langle>\<sigma>\<rangle>\<^sub>a\<rceil>\<^sub>S \<and> (\<^bold>v\<^sub>S\<^sup>< = \<^bold>v\<^sub>S\<^sup>>)\<^sub>e)"

(*
consts
  rea_assigns :: "('a, 'b) psubst \<Rightarrow> 'p" ("\<langle>_\<rangle>\<^sub>a")
*)

expr_constructor rea_assigns

(* New definition of _rea_assign following UTP.utp_rel_syntax *)
syntax
  "_rea_assign" :: "svid \<Rightarrow> logic \<Rightarrow> logic" (infix ":=\<^sub>r" 61)

translations
  "_rea_assign x e" == "CONST rea_assigns (CONST subst_upd (CONST subst_id) x (e)\<^sub>e)"
  "_rea_assign (_svid_tuple (_of_svid_list (x +\<^sub>L y))) e" <= "_rea_assign (x +\<^sub>L y) e"
(* Old UTP1 definition
syntax
  "_assign_rea" :: "svids \<Rightarrow> uexprs \<Rightarrow> logic"  ("'(_') :=\<^sub>r '(_')")
  "_assign_rea" :: "svids \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr ":=\<^sub>r" 62)

translations
  "_assign_rea xs vs" => "CONST rea_assigns (_mk_msubst (CONST Substitutions.subst_id) xs vs)"
  "_assign_rea x v" <= "CONST rea_assigns (CONST subst_upd (id\<^sub>s) x v)"
  "_assign_rea x v" <= "_assign_rea (_spvar x) v"
  "x,y :=\<^sub>r u,v" <= "CONST rea_assigns (CONST subst_upd (CONST subst_upd (Substitutions.subst_id) (CONST var x) u) (CONST var y) v)"
*)

lemma rea_assigns_RR_closed [closure]:
  "\<langle>\<sigma>\<rangle>\<^sub>r is RR"
  apply pred_auto using minus_zero_eq by auto

(* TODO(@MattWindsor91) *)
lemma st_subst_assigns_rea [usubst]:
  "\<sigma> \<dagger>\<^sub>S \<langle>\<rho>\<rangle>\<^sub>r = \<langle>\<rho> \<circ>\<^sub>s \<sigma>\<rangle>\<^sub>r"
  apply pred_auto
  oops

lemma st_subst_rea_skip [usubst]:
  "\<sigma> \<dagger>\<^sub>S II\<^sub>r = \<langle>\<sigma>\<rangle>\<^sub>r"
  oops

(* TODO(@MattWindsor91): needs RR *)
(*
lemma rea_assigns_comp [rpred]:
  assumes "P is RR"
  shows "\<langle>\<sigma>\<rangle>\<^sub>r ;; P = \<sigma> \<dagger>\<^sub>S P"
proof -
  have "\<langle>\<sigma>\<rangle>\<^sub>r ;; (RR P) = \<sigma> \<dagger>\<^sub>S (RR P)"
    apply pred_auto
    sledgehammer
  thus ?thesis
    by (metis Healthy_def assms)
qed
*)

(* TODO(@MattWindsor91) *)
lemma rea_assigns_rename [rpred]:
  "renamer f \<Longrightarrow> \<langle>\<sigma>\<rangle>\<^sub>r\<lparr>f\<rparr>\<^sub>r = \<langle>\<sigma>\<rangle>\<^sub>r"
  using minus_zero_eq by pred_auto

lemma st_subst_RR [closure]:
  assumes "P is RR"
  shows "(\<sigma> \<dagger>\<^sub>S P) is RR"
proof -
  have "(\<sigma> \<dagger>\<^sub>S RR(P)) is RR"
    by pred_auto
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

(*
lemma rea_assigns_st_subst [usubst]:
  "\<lceil>\<sigma> \<up>\<^sub>s st\<rceil>\<^sub>s \<dagger> \<langle>\<rho>\<rangle>\<^sub>r = \<langle>\<rho> \<circ>\<^sub>s \<sigma>\<rangle>\<^sub>r"
  by pred_auto
*)

subsubsection \<open> Conditional \<close>

text \<open> We guard the reactive conditional condition so that it can't be simplified by alphabet
  laws unless explicitly simplified. \<close>

(* TODO(@MattWindsor91) *)
(*  ::
  "('s,'t::trace,'\<alpha>,'\<beta>) rel_rsp \<Rightarrow>
  's pred \<Rightarrow>
  ('s,'t,'\<alpha>,'\<beta>) rel_rsp \<Rightarrow>
  ('s,'t,'\<alpha>,'\<beta>) rel_rsp" where *)

abbreviation cond_srea where
"cond_srea P b Q \<equiv> P \<triangleleft> \<lceil>b\<rceil>\<^sub>S\<^sub>\<leftarrow> \<triangleright> Q"

syntax
  "_cond_srea" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(3_ \<triangleleft> _ \<triangleright>\<^sub>R/ _)" [52,0,53] 52)

translations
  "_cond_srea P b Q" == "CONST cond_srea P b Q"

expr_constructor cond_srea

lemma st_cond_assigns [rpred]:
  "\<langle>\<sigma>\<rangle>\<^sub>r \<triangleleft> b \<triangleright>\<^sub>R \<langle>\<rho>\<rangle>\<^sub>r = \<langle>\<sigma> \<triangleleft> b \<triangleright> \<rho>\<rangle>\<^sub>r"
  apply pred_auto
  oops

lemma cond_srea_RR_closed [closure]:
  assumes "P is RR" "Q is RR"
  shows "P \<triangleleft> b \<triangleright>\<^sub>R Q is RR"
proof -
  have "RR(RR(P) \<triangleleft> b \<triangleright>\<^sub>R RR(Q)) = RR(P) \<triangleleft> b \<triangleright>\<^sub>R RR(Q)"
    by pred_auto
  thus ?thesis
    by (metis Healthy_def' assms(1) assms(2))
qed

(*
lemma cond_srea_RC1_closed:
  assumes "P is RC1" "Q is RC1"
  shows "P \<triangleleft> b \<triangleright>\<^sub>R Q is RC1"
proof -
  have "RC1(RC1(P) \<triangleleft> b \<triangleright>\<^sub>R RC1(Q)) = RC1(P) \<triangleleft> b \<triangleright>\<^sub>R RC1(Q)"
    using dual_order.trans by pred_auto
  thus ?thesis
    by (metis Healthy_def' assms)
qed

lemma cond_srea_RC_closed [closure]:
  assumes "P is RC" "Q is RC"
  shows "P \<triangleleft> b \<triangleright>\<^sub>R Q is RC"
  by (rule RC_intro', simp_all add: closure cond_srea_RC1_closed RC_implies_RC1 assms)
*)

lemma R4_cond [rpred]: "R4(P \<triangleleft> b \<triangleright>\<^sub>R Q) = ((R4(P)) \<triangleleft> b \<triangleright>\<^sub>R (R4(Q)))"
  by pred_auto

lemma R5_cond [rpred]: "R5(P \<triangleleft> b \<triangleright>\<^sub>R Q) = (R5(P) \<triangleleft> b \<triangleright>\<^sub>R R5(Q))"
  by pred_auto

lemma rea_rename_cond [rpred]: "(P \<triangleleft> b \<triangleright>\<^sub>R Q)\<lparr>f\<rparr>\<^sub>r = P\<lparr>f\<rparr>\<^sub>r \<triangleleft> b \<triangleright>\<^sub>R Q\<lparr>f\<rparr>\<^sub>r"
  by (pred_auto; metis)

subsubsection \<open> Assumptions \<close>

(* :: "'s pred \<Rightarrow> ('s, 't::trace, '\<alpha>) hrel_rsp" *)
definition rea_assume ("[_]\<^sup>\<top>\<^sub>r") where
[pred]: "[b]\<^sup>\<top>\<^sub>r = (II\<^sub>r \<triangleleft> b \<triangleright>\<^sub>R false)"

expr_constructor rea_assume

lemma rea_assume_RR [closure]: "[b]\<^sup>\<top>\<^sub>r is RR"
  by (simp add: rea_assume_def closure)

lemma rea_assume_false [rpred]: "[false]\<^sup>\<top>\<^sub>r = false"
  by pred_auto

lemma rea_assume_true [rpred]: "[true]\<^sup>\<top>\<^sub>r = II\<^sub>r"
  by pred_auto

lemma rea_assume_comp [rpred]: "[b]\<^sup>\<top>\<^sub>r ;; [c]\<^sup>\<top>\<^sub>r = [b \<and> c]\<^sup>\<top>\<^sub>r"
  by pred_auto

subsubsection \<open> State Abstraction \<close>

text \<open> We introduce state abstraction by creating some lens functors that allow us to lift
  a lens on the state-space to one on the whole stateful reactive alphabet. \<close>

definition lmap\<^sub>R :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('t::trace, 'a) rp \<Longrightarrow> ('t, 'b) rp" where
[lens_defs]: "lmap\<^sub>R = lmap[rea_vars]"

text \<open> This construction lens is useful for conversion between a record and its product representation;
  it would be helpful if this could be automatically generated. \<close>

(* TODO(@MattWindsor91): doesn't type correctly *)
definition rsp_make_lens :: "('\<sigma>, '\<tau>::trace, '\<alpha>) rsp \<Longrightarrow> bool \<times> bool \<times> '\<tau> \<times> '\<sigma> \<times> '\<alpha>" where
[lens_defs]: "rsp_make_lens = \<lparr> lens_get = \<lambda> (ok, wait, tr, st, more). \<lparr> ok\<^sub>v = ok, wait\<^sub>v = wait, tr\<^sub>v = tr, st\<^sub>v = st, \<dots> = more \<rparr>
                              , lens_put = (\<lambda> s v. (ok\<^sub>v v, wait\<^sub>v v, tr\<^sub>v v, st\<^sub>v v, more v)) \<rparr>"

lemma rsp_make_lens_alt: "rsp_make_lens = inv\<^sub>L (ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L st +\<^sub>L srea_vars.more\<^sub>L)"
  by (auto simp add: lens_defs)

lemma make_lens_bij [simp]: "bij_lens rsp_make_lens"
  by (unfold_locales, simp_all add: lens_defs prod.case_eq_if)

text \<open> The following is an intuitive definition of the @{term st} functorial lens, which
  frames all the state space excluding @{term st}, to which another lens @{term l} is
  applied. We do this by splitting the state space into a product, including the application
  of @{term l} to @{term st}, and then invert the product creation lens to reconstruct
  the reactive state space. \<close>

definition map_st_lens ::
  "('\<sigma> \<Longrightarrow> '\<psi>) \<Rightarrow>
   (('\<sigma>, '\<tau>::trace, '\<alpha>) rsp \<Longrightarrow> ('\<psi>, '\<tau>::trace, '\<alpha>) rsp)" ("map'_st\<^sub>L") where
"map_st_lens l = inv\<^sub>L (ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L st +\<^sub>L \<^bold>v\<^sub>S) ;\<^sub>L
                 (ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L (l ;\<^sub>L st) +\<^sub>L \<^bold>v\<^sub>S)"

text \<open> The above definition is intuitive, but unhelpful in proof automaton. Consequently,
  we the following optimised definition below. \<close>

lemma map_st_lens_alt_def [lens_defs]:
  "map_st_lens l = \<lparr> lens_get = \<lambda> s. \<lparr> ok\<^sub>v = ok\<^sub>v s, wait\<^sub>v = wait\<^sub>v s, tr\<^sub>v = tr\<^sub>v s, st\<^sub>v = get\<^bsub>l\<^esub> (st\<^sub>v s), \<dots> = more s \<rparr>
                  , lens_put = \<lambda> s v. \<lparr> ok\<^sub>v = ok\<^sub>v v, wait\<^sub>v = wait\<^sub>v v, tr\<^sub>v = tr\<^sub>v v, st\<^sub>v = put\<^bsub>l\<^esub> (st\<^sub>v s) (st\<^sub>v v), \<dots> = more v \<rparr> \<rparr>"
  by (auto simp add: map_st_lens_def lens_defs fun_eq_iff)

(* TODO(@MattWindsor91): missing def *)
(*
lemma map_st_vwb [simp]: "vwb_lens X \<Longrightarrow> vwb_lens (map_st\<^sub>L X)"
  apply (simp add: map_st_lens_def rsp_make_lens_alt[THEN sym])
*)

lemma map_st_lens_indep_st [simp]:
  "a \<bowtie> x \<Longrightarrow> map_st\<^sub>L a \<bowtie> x ;\<^sub>L st"
  by (rule lens_indep.intro, simp_all add: lens_defs lens_indep_comm lens_indep.lens_put_irr2)

lemma map_st_lens_indep_st' [simp]:
  "x \<bowtie> a \<Longrightarrow> map_st\<^sub>L a \<bowtie> x ;\<^sub>L st"
  by (rule lens_indep.intro, simp_all add: lens_defs lens_indep_comm lens_indep.lens_put_irr2)

syntax
  "_map_st_lens" :: "logic \<Rightarrow> salpha" ("map'_st\<^sub>L[_]")

translations
  "_map_st_lens a" => "CONST map_st_lens a"

abbreviation "abs_st\<^sub>L \<equiv> (map_st\<^sub>L 0\<^sub>L) \<times>\<^sub>L (map_st\<^sub>L 0\<^sub>L)"

(* TODO(@MattWindsor91): abbreviation being dropped *)
abbreviation abs_st ("\<langle>_\<rangle>\<^sub>S") where
"abs_st P \<equiv> P \<down> abs_st\<^sub>L"

(* TODO(@MattWindsor91) *)
(*
lemma rea_impl_aext_st [alpha]:
  "(P \<Rightarrow>\<^sub>r Q) \<oplus>\<^sub>r map_st\<^sub>L[a] = (P \<oplus>\<^sub>r map_st\<^sub>L[a] \<Rightarrow>\<^sub>r Q \<oplus>\<^sub>r map_st\<^sub>L[a])"
  by (rel_auto)
*)

(*  [alpha] *)
lemma rea_true_ext_st:
  "true\<^sub>r \<up> abs_st\<^sub>L = true\<^sub>r"
  by pred_auto

subsubsection \<open> Reactive Frames and Extensions \<close>

(* TODO(@MattWindsor91) *)
(*
definition rea_frame :: "('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> ('\<beta>, 't::trace, 'r) hrel_rsp \<Rightarrow> ('\<beta>, 't, 'r) hrel_rsp" where
[rel]: "rea_frame x P = frame (ok +\<^sub>L wait +\<^sub>L tr +\<^sub>L (x ;\<^sub>L st) +\<^sub>L \<^bold>v\<^sub>S) P"

definition rea_frame_ext :: "('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> ('\<alpha>, 't::trace, 'r) hrel_rsp \<Rightarrow> ('\<beta>, 't, 'r) hrel_rsp" where
[rel]: "rea_frame_ext a P = rea_frame a (P \<oplus>\<^sub>r map_st\<^sub>L[a])"

syntax
  "_rea_frame"     :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sub>r" [99,0] 100)
  "_rea_frame_ext" :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]\<^sub>r\<^sup>+" [99,0] 100)

translations
  "_rea_frame x P" => "CONST rea_frame x P"
  "_rea_frame (_salphaset (_salphamk x)) P" <= "CONST rea_frame x P"
  "_rea_frame_ext x P" => "CONST rea_frame_ext x P"
  "_rea_frame_ext (_salphaset (_salphamk x)) P" <= "CONST rea_frame_ext x P"

lemma rea_frame_R1_closed [closure]:
  assumes "P is R1"
  shows "x:[P]\<^sub>r is R1"
proof -
  have "R1(x:[R1 P]\<^sub>r) = x:[R1 P]\<^sub>r"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_if Healthy_intro assms)
qed

lemma rea_frame_R2_closed [closure]:
  assumes "P is R2"
  shows "x:[P]\<^sub>r is R2"
proof -
  have "R2(x:[R2 P]\<^sub>r) = x:[R2 P]\<^sub>r"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_if Healthy_intro assms)
qed

lemma rea_frame_RR_closed [closure]:
  assumes "P is RR"
  shows "x:[P]\<^sub>r is RR"
proof -
  have "RR(x:[RR P]\<^sub>r) = x:[RR P]\<^sub>r"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_if Healthy_intro assms)
qed

lemma rea_aext_R1 [closure]:
  assumes "P is R1"
  shows "rel_aext P (map_st\<^sub>L x) is R1"
proof -
  have "rel_aext (R1 P) (map_st\<^sub>L x) is R1"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_aext_R2 [closure]:
  assumes "P is R2"
  shows "rel_aext P (map_st\<^sub>L x) is R2"
proof -
  have "rel_aext (R2 P) (map_st\<^sub>L x) is R2"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_aext_RR [closure]:
  assumes "P is RR"
  shows "rel_aext P (map_st\<^sub>L x) is RR"
proof -
  have "rel_aext (RR P) (map_st\<^sub>L x) is RR"
    by (rel_auto)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma true_rea_map_st [alpha]: "(R1 true \<oplus>\<^sub>r map_st\<^sub>L[a]) = R1 true"
  by (rel_auto)

lemma rea_frame_ext_R1_closed [closure]:
  "P is R1 \<Longrightarrow> x:[P]\<^sub>r\<^sup>+ is R1"
  by (simp add: rea_frame_ext_def closure)

lemma rea_frame_ext_R2_closed [closure]:
  "P is R2 \<Longrightarrow> x:[P]\<^sub>r\<^sup>+ is R2"
  by (simp add: rea_frame_ext_def closure)

lemma rea_frame_ext_RR_closed [closure]:
  "P is RR \<Longrightarrow> x:[P]\<^sub>r\<^sup>+ is RR"
  by (simp add: rea_frame_ext_def closure)

lemma rel_aext_st_Instant_closed [closure]:
  "P is Instant \<Longrightarrow> rel_aext P (map_st\<^sub>L x) is Instant"
  by (rel_auto)

lemma rea_frame_ext_false [frame]:
  "x:[false]\<^sub>r\<^sup>+ = false"
  by (rel_auto)

lemma rea_frame_ext_skip [frame]:
  "vwb_lens x \<Longrightarrow> x:[II\<^sub>r]\<^sub>r\<^sup>+ = II\<^sub>r"
  by (rel_auto)

lemma rea_frame_ext_assigns [frame]:
  "vwb_lens x \<Longrightarrow> x:[\<langle>\<sigma>\<rangle>\<^sub>r]\<^sub>r\<^sup>+ = \<langle>\<sigma> \<up> x\<rangle>\<^sub>r"
  by (rel_auto)

lemma rea_frame_ext_cond [frame]:
  "x:[P \<triangleleft> b \<triangleright>\<^sub>R Q]\<^sub>r\<^sup>+ = x:[P]\<^sub>r\<^sup>+ \<triangleleft> (b \<oplus>\<^sub>p x) \<triangleright>\<^sub>R x:[Q]\<^sub>r\<^sup>+"
  by (rel_auto)

lemma rea_frame_ext_seq [frame]:
  "vwb_lens x \<Longrightarrow> x:[P ;; Q]\<^sub>r\<^sup>+ = x:[P]\<^sub>r\<^sup>+ ;; x:[Q]\<^sub>r\<^sup>+"
  apply (simp add: rea_frame_ext_def rea_frame_def alpha frame)
  apply (subst frame_seq)
     apply (simp_all add: plus_vwb_lens closure)
   apply (rel_auto)+
  done

lemma rea_frame_ext_subst_indep [usubst]:
  assumes "x \<bowtie> y" "\<Sigma> \<sharp> v" "P is RR"
  shows "\<sigma>(y \<mapsto>\<^sub>s v) \<dagger>\<^sub>S x:[P]\<^sub>r\<^sup>+ = (\<sigma> \<dagger>\<^sub>S x:[P]\<^sub>r\<^sup>+) ;; y :=\<^sub>r v"
proof -
  from assms(1-2) have "\<sigma>(y \<mapsto>\<^sub>s v) \<dagger>\<^sub>S x:[RR P]\<^sub>r\<^sup>+ = (\<sigma> \<dagger>\<^sub>S x:[RR P]\<^sub>r\<^sup>+) ;; y :=\<^sub>r v"
    by (rel_auto, (metis (no_types, lifting) lens_indep.lens_put_comm lens_indep_get)+)
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

lemma rea_frame_ext_subst_within [usubst]:
  assumes "vwb_lens x" "vwb_lens y" "\<Sigma> \<sharp> v" "P is RR"
  shows "\<sigma>(x:y \<mapsto>\<^sub>s v) \<dagger>\<^sub>S x:[P]\<^sub>r\<^sup>+ = (\<sigma> \<dagger>\<^sub>S x:[y :=\<^sub>r (v \<restriction>\<^sub>e x) ;; P]\<^sub>r\<^sup>+)"
proof -
  from assms(1,3) have "\<sigma>(x:y \<mapsto>\<^sub>s v) \<dagger>\<^sub>S x:[RR P]\<^sub>r\<^sup>+ = (\<sigma> \<dagger>\<^sub>S x:[y :=\<^sub>r (v \<restriction>\<^sub>e x) ;; RR(P)]\<^sub>r\<^sup>+)"
    by (rel_auto, metis+)
  thus ?thesis
    by (simp add: assms Healthy_if)
qed

lemma rea_frame_ext_UINF_ind [frame]:
  "a:[\<Sqinter> x \<bullet> P x]\<^sub>r\<^sup>+ = (\<Sqinter> x \<bullet> a:[P x]\<^sub>r\<^sup>+)"
  by (rel_auto)

lemma rea_frame_ext_UINF_mem [frame]:
  "a:[\<Sqinter> x\<in>A \<bullet> P x]\<^sub>r\<^sup>+ = (\<Sqinter> x\<in>A \<bullet> a:[P x]\<^sub>r\<^sup>+)"
  by (rel_auto)
*)

subsection \<open> Stateful Reactive specifications \<close>

(* TODO(@MattWindsor91) *)
(* :: "'s hrel \<Rightarrow> ('s, 't::trace, '\<alpha>, '\<beta>) rel_rsp" *)
definition rea_st_rel ("[_]\<^sub>S") where
[pred]: "rea_st_rel b = (\<lceil>(b)\<^sub>e\<rceil>\<^sub>S \<and> (tr\<^sup>> = tr\<^sup><)\<^sub>e)"

(*  :: "'s hrel \<Rightarrow> ('s, 't::trace, '\<alpha>, '\<beta>) rel_rsp" *)
definition rea_st_rel'("[_]\<^sub>S''") where
[pred]: "rea_st_rel' b = R1(\<lceil>b\<rceil>\<^sub>S)"

(*  :: "'s pred \<Rightarrow> ('s, 't::trace, '\<alpha>, '\<beta>) rel_rsp" *)
definition rea_st_cond ("[_]\<^sub>S\<^sub><") where
[pred]: "rea_st_cond b = R1(\<lceil>b\<rceil>\<^sub>S\<^sub><)"

(*  :: "'s upred \<Rightarrow> ('s, 't::trace, '\<alpha>, '\<beta>) rel_rsp" *)
definition rea_st_post ("[_]\<^sub>S\<^sub>>") where
[pred]: "rea_st_post b = R1(\<lceil>b\<rceil>\<^sub>S\<^sub>>)"

(*
lemma lift_state_pre_unrest [unrest]: "x \<bowtie> (st\<^sup><)\<^sub>v \<Longrightarrow> $x \<sharp> \<lceil>P\<rceil>\<^sub>S\<^sub><"
  apply (pred_auto, simp add: lens_indep_def)
  oops

lemma rea_st_rel_unrest [unrest]:
  "\<lbrakk> x \<bowtie> (tr\<^sup><)\<^sub>v; x \<bowtie> (tr\<^sup>>)\<^sub>v; x \<bowtie> (st\<^sup><)\<^sub>v; x \<bowtie> (st\<^sup>>)\<^sub>v \<rbrakk> \<Longrightarrow> $x \<sharp> [P]\<^sub>S\<^sub><"
  by (simp add: rea_st_cond_def R1_def unrest lens_indep_sym)

lemma rea_st_cond_unrest [unrest]:
  "\<lbrakk> x \<bowtie> (tr\<^sup><)\<^sub>v; x \<bowtie> (tr\<^sup>>)\<^sub>v; x \<bowtie> (st\<^sup><)\<^sub>v \<rbrakk> \<Longrightarrow> $x \<sharp> [P]\<^sub>S\<^sub><"
  by (simp add: add: rea_st_cond_def R1_def unrest lens_indep_sym)
*)

lemma subst_st_cond [usubst]: "\<lceil>\<sigma>\<rceil>\<^sub>S\<^sub>\<sigma> \<dagger> [P]\<^sub>S\<^sub>< = [\<sigma> \<dagger> P]\<^sub>S\<^sub><"
  apply pred_auto
  oops

lemma rea_st_cond_R1 [closure]: "[b]\<^sub>S\<^sub>< is R1"
  by pred_auto

lemma rea_st_cond_R2c [closure]: "[b]\<^sub>S\<^sub>< is R2c"
  by pred_auto

lemma rea_st_rel_RR [closure]: "[P]\<^sub>S is RR"
  using minus_zero_eq by pred_auto

lemma rea_st_rel'_RR [closure]: "[P]\<^sub>S' is RR"
  by pred_auto

lemma rea_st_post_RR [closure]: "[b]\<^sub>S\<^sub>> is RR"
  by pred_auto

(*
lemma st_subst_rel [usubst]:
  "\<sigma> \<dagger>\<^sub>S [P]\<^sub>S = [\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> P]\<^sub>S"
  by pred_auto
*)

(*
lemma st_rel_cond [rpred]:
  "[P \<triangleleft> b \<triangleright>\<^sub>r Q]\<^sub>S = [P]\<^sub>S \<triangleleft> b \<triangleright>\<^sub>R [Q]\<^sub>S"
  by (rel_auto)
*)

lemma st_rel_false [rpred]: "[false]\<^sub>S = false"
  by pred_auto

(* TODO: This is currently false, meaning something
   is wrong in a definition *)
(*
lemma st_rel_skip [rpred]:
  "[II]\<^sub>S = (II\<^sub>r :: ('s, 't::trace) rdes)"
  by pred_auto
*)

lemma st_rel_seq [rpred]:
  "[P ;; Q]\<^sub>S = [P]\<^sub>S ;; [Q]\<^sub>S"
  by pred_auto

lemma st_rel_conj [rpred]:
  "([P]\<^sub>S \<and> [Q]\<^sub>S) = [P \<and> Q]\<^sub>S"
   by pred_auto

lemma st_cond_disj [rpred]:
  "([P]\<^sub>S\<^sub>< \<or> [Q]\<^sub>S\<^sub><) = [P \<or> Q]\<^sub>S\<^sub><"
  by pred_auto

lemma rea_st_cond_RR [closure]: "[b]\<^sub>S\<^sub>< is RR"
  by (rule RR_intro, simp_all add: unrest closure; pred_auto)

lemma rea_st_cond_RC [closure]: "[b]\<^sub>S\<^sub>< is RC"
  by (rule RC_intro, simp add: closure, pred_auto)

lemma rea_st_cond_true [rpred]: "[true]\<^sub>S\<^sub>< = true\<^sub>r"
  by pred_auto

lemma rea_st_cond_false [rpred]: "[false]\<^sub>S\<^sub>< = false"
  by pred_auto

lemma st_cond_not [rpred]: "(\<not>\<^sub>r [P]\<^sub>S\<^sub><) = [\<not> P]\<^sub>S\<^sub><"
  by pred_auto

lemma st_cond_conj [rpred]: "([P]\<^sub>S\<^sub>< \<and> [Q]\<^sub>S\<^sub><) = [P \<and> Q]\<^sub>S\<^sub><"
  by pred_auto

lemma st_rel_assigns [rpred]:
  "[\<langle>\<sigma>\<rangle>\<^sub>a]\<^sub>S = (\<langle>\<sigma>\<rangle>\<^sub>r :: ('\<alpha>, 't::trace) rdes)"
  by pred_auto

lemma cond_st_distr: "(P \<triangleleft> b \<triangleright>\<^sub>R Q) ;; R = (P ;; R \<triangleleft> b \<triangleright>\<^sub>R Q ;; R)"
  by (pred_auto; blast)

lemma cond_st_miracle [rpred]: "P is R1 \<Longrightarrow> P \<triangleleft> b \<triangleright>\<^sub>R false = ([b]\<^sub>S\<^sub>< \<and> P)"
  by (pred_auto; blast)

lemma cond_st_true [rpred]: "P \<triangleleft> true \<triangleright>\<^sub>R Q = P"
  by pred_auto

lemma cond_st_false [rpred]: "P \<triangleleft> false \<triangleright>\<^sub>R Q = Q"
  by pred_auto

lemma st_cond_true_or [rpred]: "P is R1 \<Longrightarrow> (R1 true \<triangleleft> b \<triangleright>\<^sub>R P) = ([b]\<^sub>S\<^sub>< \<or> P)"
by (pred_auto; blast)

lemma st_cond_left_impl_RC_closed [closure]:
  "P is RC \<Longrightarrow> ([b]\<^sub>S\<^sub>< \<longrightarrow>\<^sub>r P) is RC"
  by (simp add: rea_impl_def rpred closure)

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

theory Example
imports System_S
begin

definition "id0 \<equiv> 0"
definition  "id1 \<equiv> 1"
definition  "id2 \<equiv> 2"

definition "e0 \<equiv> Entity {\<lparr> target = id1, rights = {Store}\<rparr>}"
definition "e1 \<equiv> Entity {\<lparr> target = id2, rights = {Grant}\<rparr>}"
definition "e2 \<equiv> Entity {}"

lemmas id_defs = id0_def id1_def id2_def
lemmas entity_defs = e0_def e1_def e2_def

definition example_state :: "state" where
"example_state \<equiv> [0 \<mapsto> e0, 1 \<mapsto> e1, 2 \<mapsto> e2] "

lemma de0:
  "direct_caps_of example_state id0 =
   {\<lparr> target = id1, rights = {Store}\<rparr>}"
  by (simp add: direct_caps_of_def example_state_def
                id_defs entity_defs
         split: option.splits)

lemma de1:
  "direct_caps_of example_state id1 =
   {\<lparr> target = id2, rights = {Grant}\<rparr>}"
  by (simp add: direct_caps_of_def example_state_def
                id_defs entity_defs
         split: option.splits)

lemma de2: "direct_caps_of example_state id2 = {}"
  by (simp add: direct_caps_of_def example_state_def
                id_defs entity_defs
         split: option.splits)

lemma scd:
  "store_connected_direct example_state = {(id0,id1)}"
  by (auto simp: store_connected_direct_def direct_caps_of_def
                 example_state_def id_defs entity_defs
          split: if_split_asm option.splits
           cong: conj_cong)

lemma sc:
  "store_connected example_state = {(id0,id1)} \<union> Id"
  apply simp
  apply (rule equalityI)
  apply (insert scd)
   apply (simp add: store_connected_def)
   apply clarsimp
   apply (erule converse_rtranclE)
    apply simp
   apply clarsimp
   apply (erule rtranclE)
    apply simp
   apply clarsimp
  apply (fastforce simp: store_connected_def)
  done

lemma sc': "store_connected example_state = Id \<union> {(0,1)}"
  by (clarsimp simp: sc id_defs)

lemma ce0:
  "caps_of example_state id0 =
   {\<lparr>target = id1, rights = {Store}\<rparr>,
    \<lparr>target = id2, rights = {Grant}\<rparr>}"
  by (fastforce simp: caps_of_def sc Collect_disj_eq de0 de1)

lemma ce1:
  "caps_of example_state id1 =
   {\<lparr> target = id2, rights = {Grant}\<rparr>}"
  apply (clarsimp simp: caps_of_def sc Collect_disj_eq de0 de1)
  apply (simp add: id0_def id1_def)
  done

lemma ce2: "caps_of example_state id2 = {}"
  apply (simp add: caps_of_def sc)
  apply (rule allI)
  apply (rule conjI)
   apply (simp add: id0_def id2_def)
  apply (simp add: de2)
  done

end


(*  Title:      Uint16.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Unsigned words of 16 bits\<close>

theory Uint16 imports
  Code_Target_Word_Base
begin

text \<open>
  Restriction for ML code generation:
  This theory assumes that the ML system provides a Word16
  implementation (mlton does, but PolyML 5.5 does not).
  Therefore, the code setup lives in the target \<open>SML_word\<close>
  rather than \<open>SML\<close>.  This ensures that code generation still
  works as long as \<open>uint16\<close> is not involved.
  For the target \<open>SML\<close> itself, no special code generation
  for this type is set up. Nevertheless, it should work by emulation via @{typ "16 word"}
  if the theory \<open>Code_Target_Bits_Int\<close> is imported.

  Restriction for OCaml code generation:
  OCaml does not provide an int16 type, so no special code generation
  for this type is set up.
\<close>

declare prod.Quotient[transfer_rule]

section \<open>Type definition and primitive operations\<close>

typedef uint16 = "UNIV :: 16 word set" ..

setup_lifting type_definition_uint16

text \<open>Use an abstract type for code generation to disable pattern matching on @{term Abs_uint16}.\<close>
declare Rep_uint16_inverse[code abstype]

declare Quotient_uint16[transfer_rule]

instantiation uint16 :: "{neg_numeral, modulo, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint16 :: uint16 is "0" .
lift_definition one_uint16 :: uint16 is "1" .
lift_definition plus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(+)" .
lift_definition minus_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(-)" .
lift_definition uminus_uint16 :: "uint16 \<Rightarrow> uint16" is uminus .
lift_definition times_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(*)" .
lift_definition divide_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(div)" .
lift_definition modulo_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is "(mod)" .
instance by standard (transfer, simp add: algebra_simps)+
end

instantiation uint16 :: linorder begin
lift_definition less_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "(\<le>)" .
instance by standard (transfer, simp add: less_le_not_le linear)+
end

lemmas [code] = less_uint16.rep_eq less_eq_uint16.rep_eq

instantiation uint16 :: bit_operations begin
lift_definition bitNOT_uint16 :: "uint16 \<Rightarrow> uint16" is bitNOT .
lift_definition bitAND_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitAND .
lift_definition bitOR_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitOR .
lift_definition bitXOR_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16" is bitXOR .
lift_definition test_bit_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint16" is set_bit .
lift_definition lsb_uint16 :: "uint16 \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" is shiftl .
lift_definition shiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" is shiftr .
lift_definition msb_uint16 :: "uint16 \<Rightarrow> bool" is msb .
instance ..
end

instantiation uint16 :: bit_comprehension begin
lift_definition set_bits_uint16 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16" is "set_bits" .
instance ..
end

lemmas [code] = test_bit_uint16.rep_eq lsb_uint16.rep_eq msb_uint16.rep_eq

instantiation uint16 :: equal begin
lift_definition equal_uint16 :: "uint16 \<Rightarrow> uint16 \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint16.rep_eq

instantiation uint16 :: size begin
lift_definition size_uint16 :: "uint16 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint16.rep_eq

lift_definition sshiftr_uint16 :: "uint16 \<Rightarrow> nat \<Rightarrow> uint16" (infixl ">>>" 55) is sshiftr .

lift_definition uint16_of_int :: "int \<Rightarrow> uint16" is "word_of_int" .

definition uint16_of_nat :: "nat \<Rightarrow> uint16"
where "uint16_of_nat = uint16_of_int \<circ> int"

lift_definition int_of_uint16 :: "uint16 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint16 :: "uint16 \<Rightarrow> nat" is "unat" .

definition integer_of_uint16 :: "uint16 \<Rightarrow> integer"
where "integer_of_uint16 = integer_of_int o int_of_uint16"

text \<open>Use pretty numerals from integer for pretty printing\<close>

context includes integer.lifting begin

lift_definition Uint16 :: "integer \<Rightarrow> uint16" is "word_of_int" .

lemma Rep_uint16_numeral [simp]: "Rep_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def Abs_uint16_inverse numeral.simps plus_uint16_def)

lemma Rep_uint16_neg_numeral [simp]: "Rep_uint16 (- numeral n) = - numeral n"
by(simp only: uminus_uint16_def)(simp add: Abs_uint16_inverse)

lemma numeral_uint16_transfer [transfer_rule]:
  "(rel_fun (=) cr_uint16) numeral numeral"
by(auto simp add: cr_uint16_def)

lemma numeral_uint16 [code_unfold]: "numeral n = Uint16 (numeral n)"
by transfer simp

lemma neg_numeral_uint16 [code_unfold]: "- numeral n = Uint16 (- numeral n)"
by transfer(simp add: cr_uint16_def)

end

lemma Abs_uint16_numeral [code_post]: "Abs_uint16 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint16_def numeral.simps plus_uint16_def Abs_uint16_inverse)

lemma Abs_uint16_0 [code_post]: "Abs_uint16 0 = 0"
by(simp add: zero_uint16_def)

lemma Abs_uint16_1 [code_post]: "Abs_uint16 1 = 1"
by(simp add: one_uint16_def)

section \<open>Code setup\<close>

code_printing code_module Uint16 \<rightharpoonup> (SML_word)
\<open>(* Test that words can handle numbers between 0 and 15 *)
val _ = if 4 <= Word.wordSize then () else raise (Fail ("wordSize less than 4"));

structure Uint16 : sig
  val set_bit : Word16.word -> IntInf.int -> bool -> Word16.word
  val shiftl : Word16.word -> IntInf.int -> Word16.word
  val shiftr : Word16.word -> IntInf.int -> Word16.word
  val shiftr_signed : Word16.word -> IntInf.int -> Word16.word
  val test_bit : Word16.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word16.orb (x, mask)
     else Word16.andb (x, Word16.notb mask)
  end

fun shiftl x n =
  Word16.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word16.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word16.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word16.andb (x, Word16.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word16.fromInt 0

end; (* struct Uint16 *)\<close>
code_reserved SML_word Uint16

code_printing code_module Uint16 \<rightharpoonup> (Haskell)
 \<open>module Uint16(Int16, Word16) where

  import Data.Int(Int16)
  import Data.Word(Word16)\<close>
code_reserved Haskell Uint16

text \<open>Scala provides unsigned 16-bit numbers as Char.\<close>

code_printing code_module Uint16 \<rightharpoonup> (Scala)
\<open>object Uint16 {

def set_bit(x: scala.Char, n: BigInt, b: Boolean) : scala.Char =
  if (b)
    (x | (1.toChar << n.intValue)).toChar
  else
    (x & (1.toChar << n.intValue).unary_~).toChar

def shiftl(x: scala.Char, n: BigInt) : scala.Char = (x << n.intValue).toChar

def shiftr(x: scala.Char, n: BigInt) : scala.Char = (x >>> n.intValue).toChar

def shiftr_signed(x: scala.Char, n: BigInt) : scala.Char = (x.toShort >> n.intValue).toChar

def test_bit(x: scala.Char, n: BigInt) : Boolean = (x & (1.toChar << n.intValue)) != 0

} /* object Uint16 */\<close>
code_reserved Scala Uint16

text \<open>
  Avoid @{term Abs_uint16} in generated code, use @{term Rep_uint16'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint16}.

  The new destructor @{term Rep_uint16'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint16} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint16}
  ([code abstract] equations for @{typ uint16} may use @{term Rep_uint16} because
  these instances will be folded away.)

  To convert @{typ "16 word"} values into @{typ uint16}, use @{term "Abs_uint16'"}.
\<close>

definition Rep_uint16' where [simp]: "Rep_uint16' = Rep_uint16"

lemma Rep_uint16'_transfer [transfer_rule]:
  "rel_fun cr_uint16 (=) (\<lambda>x. x) Rep_uint16'"
unfolding Rep_uint16'_def by(rule uint16.rep_transfer)

lift_definition Abs_uint16' :: "16 word \<Rightarrow> uint16" is "\<lambda>x :: 16 word. x" .

lemma Abs_uint16'_code [code]:
  "Abs_uint16' x = Uint16 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint16 \<Rightarrow> _"]]

lemma term_of_uint16_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''" shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint16.uint16.Abs_uint16'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]], TR (STR ''Uint16.uint16'') []]))
       (term_of_class.term_of (Rep_uint16' x))"
by(simp add: term_of_anything)

lemma Uin16_code [code abstract]: "Rep_uint16 (Uint16 i) = word_of_int (int_of_integer_symbolic i)"
unfolding Uint16_def int_of_integer_symbolic_def by(simp add: Abs_uint16_inverse)

code_printing
  type_constructor uint16 \<rightharpoonup>
  (SML_word) "Word16.word" and
  (Haskell) "Uint16.Word16" and
  (Scala) "scala.Char"
| constant Uint16 \<rightharpoonup>
  (SML_word) "Word16.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint16.Word16)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Word16)" and
  (Scala) "_.charValue"
| constant "0 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 0)" and
  (Haskell) "(0 :: Uint16.Word16)" and
  (Scala) "0"
| constant "1 :: uint16" \<rightharpoonup>
  (SML_word) "(Word16.fromInt 1)" and
  (Haskell) "(1 :: Uint16.Word16)" and
  (Scala) "1"
| constant "plus :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (Scala) "(_ +/ _).toChar"
| constant "uminus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.~" and
  (Haskell) "negate" and
  (Scala) "(- _).toChar"
| constant "minus :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (Scala) "(_ -/ _).toChar"
| constant "times :: uint16 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (Scala) "(_ */ _).toChar"
| constant "HOL.equal :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "!((_ : Word16.word) = _)" and
  (Haskell) infix 4 "==" and
  (Scala) infixl 5 "=="
| class_instance uint16 :: equal \<rightharpoonup> (Haskell) -
| constant "less_eq :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (Scala) infixl 4 "<="
| constant "less :: uint16 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML_word) "Word16.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (Scala) infixl 4 "<"
| constant "bitNOT :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.notb" and
  (Haskell) "Data'_Bits.complement" and
  (Scala) "_.unary'_~.toChar"
| constant "bitAND :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (Scala) "(_ & _).toChar"
| constant "bitOR :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (Scala) "(_ | _).toChar"
| constant "bitXOR :: uint16 \<Rightarrow> _" \<rightharpoonup>
  (SML_word) "Word16.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (Scala) "(_ ^ _).toChar"

definition uint16_div :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_div x y = (if y = 0 then undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x div y)"

definition uint16_mod :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
where "uint16_mod x y = (if y = 0 then undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16) else x mod y)"

context includes undefined_transfer begin

lemma div_uint16_code [code]: "x div y = (if y = 0 then 0 else uint16_div x y)"
unfolding uint16_div_def by transfer (simp add: word_div_def)

lemma mod_uint16_code [code]: "x mod y = (if y = 0 then x else uint16_mod x y)"
unfolding uint16_mod_def by transfer (simp add: word_mod_def)

lemma uint16_div_code [code abstract]:
  "Rep_uint16 (uint16_div x y) =
  (if y = 0 then Rep_uint16 (undefined ((div) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x div Rep_uint16 y)"
unfolding uint16_div_def by transfer simp

lemma uint16_mod_code [code abstract]:
  "Rep_uint16 (uint16_mod x y) =
  (if y = 0 then Rep_uint16 (undefined ((mod) :: uint16 \<Rightarrow> _) x (0 :: uint16)) else Rep_uint16 x mod Rep_uint16 y)"
unfolding uint16_mod_def by transfer simp

end

code_printing constant uint16_div \<rightharpoonup>
  (SML_word) "Word16.div ((_), (_))" and
  (Haskell) "Prelude.div" and
  (Scala) "(_ '/ _).toChar"
| constant uint16_mod \<rightharpoonup>
  (SML_word) "Word16.mod ((_), (_))" and
  (Haskell) "Prelude.mod" and
  (Scala) "(_ % _).toChar"

definition uint16_test_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint16_test_bit x n =
  (if n < 0 \<or> 15 < n then undefined (test_bit :: uint16 \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint16_code [code]:
  "test_bit x n \<longleftrightarrow> n < 16 \<and> uint16_test_bit x (integer_of_nat n)"
unfolding uint16_test_bit_def including undefined_transfer integer.lifting
by transfer(auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint16_test_bit_code [code]:
  "uint16_test_bit w n =
  (if n < 0 \<or> 15 < n then undefined (test_bit :: uint16 \<Rightarrow> _) w n else Rep_uint16 w !! nat_of_integer n)"
unfolding uint16_test_bit_def by(simp add: test_bit_uint16.rep_eq)

code_printing constant uint16_test_bit \<rightharpoonup>
  (SML_word) "Uint16.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (Scala) "Uint16.test'_bit"

definition uint16_set_bit :: "uint16 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint16"
where [code del]:
  "uint16_set_bit x n b =
  (if n < 0 \<or> 15 < n then undefined (set_bit :: uint16 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint16_code [code]:
  "set_bit x n b = (if n < 16 then uint16_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint16_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint16_set_bit_code [code abstract]:
  "Rep_uint16 (uint16_set_bit w n b) =
  (if n < 0 \<or> 15 < n then Rep_uint16 (undefined (set_bit :: uint16 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint16 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint16_set_bit_def by transfer simp

code_printing constant uint16_set_bit \<rightharpoonup>
  (SML_word) "Uint16.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (Scala) "Uint16.set'_bit"

lift_definition uint16_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint16 \<Rightarrow> nat \<Rightarrow> uint16" is set_bits_aux .

lemma uint16_set_bits_code [code]:
  "uint16_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint16_set_bits f ((w << 1) OR (if f n' then 1 else 0)) n')"
by(transfer fixing: n)(cases n, simp_all)

lemma set_bits_uint16 [code]:
  "(BITS n. f n) = uint16_set_bits f 0 16"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint16 shows "lsb x = x !! 0"
by transfer(simp add: word_lsb_def word_test_bit_def)

definition uint16_shiftl :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftl x n = (if n < 0 \<or> 16 \<le> n then undefined (shiftl :: uint16 \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint16_code [code]: "x << n = (if n < 16 then uint16_shiftl x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint16_shiftl_def
by transfer(simp add: not_less shiftl_zero_size word_size)

lemma uint16_shiftl_code [code abstract]:
  "Rep_uint16 (uint16_shiftl w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (shiftl :: uint16 \<Rightarrow> _) w n)
   else Rep_uint16 w << nat_of_integer n)"
including undefined_transfer unfolding uint16_shiftl_def by transfer simp

code_printing constant uint16_shiftl \<rightharpoonup>
  (SML_word) "Uint16.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (Scala) "Uint16.shiftl"

definition uint16_shiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_shiftr x n = (if n < 0 \<or> 16 \<le> n then undefined (shiftr :: uint16 \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint16_code [code]: "x >> n = (if n < 16 then uint16_shiftr x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint16_shiftr_def
by transfer(simp add: not_less shiftr_zero_size word_size)

lemma uint16_shiftr_code [code abstract]:
  "Rep_uint16 (uint16_shiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined (shiftr :: uint16 \<Rightarrow> _) w n)
   else Rep_uint16 w >> nat_of_integer n)"
including undefined_transfer unfolding uint16_shiftr_def by transfer simp

code_printing constant uint16_shiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (Scala) "Uint16.shiftr"

definition uint16_sshiftr :: "uint16 \<Rightarrow> integer \<Rightarrow> uint16"
where [code del]:
  "uint16_sshiftr x n =
  (if n < 0 \<or> 16 \<le> n then undefined sshiftr_uint16 x n else sshiftr_uint16 x (nat_of_integer n))"

lemma sshiftr_beyond: fixes x :: "'a :: len word" shows
  "size x \<le> n \<Longrightarrow> x >>> n = (if x !! (size x - 1) then -1 else 0)"
by(rule word_eqI)(simp add: nth_sshiftr word_size)

lemma sshiftr_uint16_code [code]:
  "x >>> n =
  (if n < 16 then uint16_sshiftr x (integer_of_nat n) else if x !! 15 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint16_sshiftr_def
by transfer (simp add: not_less sshiftr_beyond word_size)

lemma uint16_sshiftr_code [code abstract]:
  "Rep_uint16 (uint16_sshiftr w n) =
  (if n < 0 \<or> 16 \<le> n then Rep_uint16 (undefined sshiftr_uint16 w n)
   else Rep_uint16 w >>> nat_of_integer n)"
including undefined_transfer unfolding uint16_sshiftr_def by transfer simp

code_printing constant uint16_sshiftr \<rightharpoonup>
  (SML_word) "Uint16.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint16.Int16) _)) :: Uint16.Word16)" and
  (Scala) "Uint16.shiftr'_signed"

lemma uint16_msb_test_bit: "msb x \<longleftrightarrow> (x :: uint16) !! 15"
by transfer(simp add: msb_nth)

lemma msb_uint16_code [code]: "msb x \<longleftrightarrow> uint16_test_bit x 15"
by(simp add: uint16_test_bit_def uint16_msb_test_bit)

lemma uint16_of_int_code [code]: "uint16_of_int i = Uint16 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint16_code [code]:
  "int_of_uint16 x = int_of_integer (integer_of_uint16 x)"
by(simp add: integer_of_uint16_def)

lemma nat_of_uint16_code [code]:
  "nat_of_uint16 x = nat_of_integer (integer_of_uint16 x)"
unfolding integer_of_uint16_def including integer.lifting by transfer (simp add: unat_def)

lemma integer_of_uint16_code [code]:
  "integer_of_uint16 n = integer_of_int (uint (Rep_uint16' n))"
unfolding integer_of_uint16_def by transfer auto

code_printing
  constant "integer_of_uint16" \<rightharpoonup>
  (SML_word) "Word16.toInt _ : IntInf.int" and
  (Haskell) "Prelude.toInteger" and
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

definition uint16_of_natural :: "natural \<Rightarrow> uint16"
where "uint16_of_natural x \<equiv> Uint16 (integer_of_natural x)"

instantiation uint16 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint16 \<equiv> qc_random_cnv uint16_of_natural"
definition "exhaustive_uint16 \<equiv> qc_exhaustive_cnv uint16_of_natural"
definition "full_exhaustive_uint16 \<equiv> qc_full_exhaustive_cnv uint16_of_natural"
instance ..
end

instantiation uint16 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint16 i in (x, 0xFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint16.uint16'') []" .

definition "narrowing_uint16 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint16 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint16 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint16 (infixl ">>>" 55)

end


section\<open>LTL for EFSMs\<close>
text\<open>This theory builds off the \texttt{Linear\_Temporal\_Logic\_on\_Streams} theory from the HOL
library and defines functions to ease the expression of LTL properties over EFSMs. Since the LTL
operators effectively act over traces of models we must find a way to express models as streams.\<close>

theory EFSM_LTL
imports "Extended_Finite_State_Machines-devel.EFSM" "HOL-Library.Linear_Temporal_Logic_on_Streams"
begin

text_raw\<open>\snip{statedef}{1}{2}{%\<close>
record state =
  statename :: "nat option"
  datastate :: registers
  action :: action
  "output" :: outputs
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{whitebox}{1}{2}{%\<close>
type_synonym whitebox_trace = "state stream"
text_raw\<open>}%endsnip\<close>

type_synonym property = "whitebox_trace \<Rightarrow> bool"

abbreviation label :: "state \<Rightarrow> String.literal" where
  "label s \<equiv> fst (action s)"

abbreviation inputs :: "state \<Rightarrow> value list" where
  "inputs s \<equiv> snd (action s)"

text_raw\<open>\snip{ltlStep}{1}{2}{%\<close>
fun ltl_step :: "transition_matrix \<Rightarrow> cfstate option \<Rightarrow> registers \<Rightarrow> action \<Rightarrow> (nat option \<times> outputs \<times> registers)" where
  "ltl_step _ None r _ = (None, [], r)" |
  "ltl_step e (Some s) r (l, i) = (let possibilities = possible_steps e s r l i in
                   if possibilities = {||} then (None, [], r)
                   else
                     let (s', t) = Eps (\<lambda>x. x |\<in>| possibilities) in
                     (Some s', (evaluate_outputs t i r), (evaluate_updates t i r))
                  )"
text_raw\<open>}%endsnip\<close>

lemma ltl_step_singleton:
"\<exists>t. possible_steps e n r (fst v) (snd v) = {|(aa, t)|} \<and> evaluate_outputs t (snd v) r  = b \<and> evaluate_updates t (snd v) r = c\<Longrightarrow>
ltl_step e (Some n) r v = (Some aa, b, c)"
  apply (cases v)
  by auto

lemma ltl_step_none: "possible_steps e s r a b = {||} \<Longrightarrow> ltl_step e (Some s) r (a, b) = (None, [], r)"
  by simp

lemma ltl_step_none_2: "possible_steps e s r (fst ie) (snd ie) = {||} \<Longrightarrow> ltl_step e (Some s) r ie = (None, [], r)"
  by (metis ltl_step_none prod.exhaust_sel)

lemma ltl_step_alt: "ltl_step e (Some s) r t = (
  let possibilities = possible_steps e s r (fst t) (snd t) in
  if possibilities = {||} then
    (None, [], r)
  else
  let (s', t') = Eps (\<lambda>x. x |\<in>| possibilities) in
  (Some s', (apply_outputs (Outputs t') (join_ir (snd t) r)), (apply_updates (Updates t') (join_ir (snd t) r) r))
)"
  by (case_tac t, simp add: Let_def)

lemma ltl_step_some:
  assumes "possible_steps e s r l i = {|(s', t)|}"
      and "evaluate_outputs t i r = p"
      and "evaluate_updates t i r = r'"
    shows "ltl_step e (Some s) r (l, i) = (Some s', p, r')"
  by (simp add: assms)

lemma ltl_step_cases:
  assumes invalid: "P (None, [], r)"
      and valid: "\<forall>(s', t) |\<in>| (possible_steps e s r l i). P (Some s', (evaluate_outputs t i r), (evaluate_updates t i r))"
    shows "P (ltl_step e (Some s) r (l, i))"
  apply simp
  apply (case_tac "possible_steps e s r l i")
   apply (simp add: invalid)
  apply simp
  subgoal for x S'
    apply (case_tac "SOME xa. xa = x \<or> xa |\<in>| S'")
    apply simp
    apply (insert assms(2))
    apply (simp add: fBall_def Ball_def fmember_def)
    by (metis (mono_tags, lifting) fst_conv prod.case_eq_if snd_conv someI_ex)
  done

text\<open>The \texttt{make\_full\_observation} function behaves similarly to \texttt{observe\_execution}
from the \texttt{EFSM} theory. The main difference in behaviour is what is recorded. While the
observe execution function simply observes an execution of the EFSM to produce the corresponding
output for each action, the intention here is to record every detail of execution, including the
values of internal variables.

Thinking of each action as a step forward in time, there are five components which characterise
a given point in the execution of an EFSM. At each point, the model has a current control state and
data state. Each action has a label and some input parameters, and its execution may produce
some observableoutput. It is therefore sufficient to provide a stream of 5-tuples containing the
current control state, data state, the label and inputs of the action, and computed output. The
make full observation function can then be defined as in Figure 9.1, with an additional
function watch defined on top of this which starts the make full observation off in the
initial control state with the empty data state.

Careful inspection of the definition reveals another way that \texttt{make\_full\_observation}
differs from \texttt{observe\_execution}. Rather than taking a cfstate, it takes a cfstate option.
The reason for this is that we need to make our EFSM models complete. That is, we need them to be
able to respond to every action from every state like a DFA. If a model does not recognise a given
action in a given state, we cannot simply stop processing because we are working with necessarily
infinite traces. Since these traces are generated by observing action sequences, the make full
observation function must keep processing whether there is a viable transition or not.

To support this, the make full observation adds an implicit ``sink state'' to every EFSM it
processes by lifting control flow state indices from \texttt{nat} to \texttt{nat option} such that
state $n$ is seen as state \texttt{Some} $n$. The control flow state \texttt{None} represents a sink
state. If a model is unable to recognise a particular action from its current state, it moves into
the \texttt{None} state. From here, the behaviour is constant for the rest of the time --- the
control flow state remains None; the data state does not change, and no output is produced.\<close>

text_raw\<open>\snip{makeFullObservation}{1}{2}{%\<close>
primcorec make_full_observation :: "transition_matrix \<Rightarrow> cfstate option \<Rightarrow> registers \<Rightarrow> outputs \<Rightarrow> action stream \<Rightarrow> whitebox_trace" where
  "make_full_observation e s d p i = (
    let (s', o', d') = ltl_step e s d (shd i) in
    \<lparr>statename = s, datastate = d, action=(shd i), output = p\<rparr>##(make_full_observation e s' d' o' (stl i))
  )"
text_raw\<open>}%endsnip\<close>

text_raw\<open>\snip{watch}{1}{2}{%\<close>
abbreviation watch :: "transition_matrix \<Rightarrow> action stream \<Rightarrow> whitebox_trace" where
  "watch e i \<equiv> (make_full_observation e (Some 0) <> [] i)"
text_raw\<open>}%endsnip\<close>

subsection\<open>Expressing Properties\<close>
text\<open>In order to simplify the expression and understanding of properties, this theory defines a
number of named functions which can be used to express certain properties of EFSMs.\<close>

subsubsection\<open>State Equality\<close>
text\<open>The \textsc{state\_eq} takes a cfstate option representing a control flow state index and
returns true if this is the control flow state at the head of the full observation.\<close>

abbreviation state_eq :: "cfstate option \<Rightarrow> whitebox_trace \<Rightarrow> bool" where
  "state_eq v s \<equiv> statename (shd s) = v"

lemma state_eq_holds: "state_eq s = holds (\<lambda>x. statename x = s)"
  apply (rule ext)
  by (simp add: holds_def)

lemma state_eq_None_not_Some: "state_eq None s \<Longrightarrow> \<not> state_eq (Some n) s"
  by simp

subsubsection\<open>Label Equality\<close>
text\<open>The \textsc{label\_eq} function takes a string and returns true if this is equal to the label
at the head of the full observation.\<close>

abbreviation "label_eq v s \<equiv> fst (action (shd s)) = (String.implode v)"

lemma watch_label: "label_eq l (watch e t) = (fst (shd t) = String.implode l)"
  by (simp add: )

subsubsection\<open>Input Equality\<close>
text\<open>The \textsc{input\_eq} function takes a value list and returns true if this is equal to the
input at the head of the full observation.\<close>

abbreviation "input_eq v s \<equiv> inputs (shd s) = v"

subsubsection\<open>Action Equality\<close>
text\<open>The \textsc{action\_eq} function takes a (label, value list) pair and returns true if this is
equal to the action at the head of the full observation. This effectively combines
\texttt{label\_eq} and \texttt{input\_eq} into one function.\<close>

abbreviation "action_eq e \<equiv> label_eq (fst e) aand input_eq (snd e)"

subsubsection\<open>Output Equality\<close>
text\<open>The \textsc{output\_eq} function takes a takes a value option list and returns true if this is
equal to the output at the head of the full observation.\<close>

abbreviation "output_eq v s \<equiv> output (shd s) = v"

text_raw\<open>\snip{ltlVName}{1}{2}{%\<close>
datatype ltl_vname = Ip nat | Op nat | Rg nat
text_raw\<open>}%endsnip\<close>

subsubsection\<open>Checking Arbitrary Expressions\<close>
text\<open>The \textsc{check\_exp} function takes a guard expression and returns true if the guard
expression evaluates to true in the given state.\<close>

type_synonym ltl_gexp = "ltl_vname gexp"

definition join_iro :: "value list \<Rightarrow> registers \<Rightarrow> outputs \<Rightarrow> ltl_vname datastate" where
  "join_iro i r p = (\<lambda>x. case x of
    Rg n \<Rightarrow> r $ n |
    Ip n \<Rightarrow> Some (i ! n) |
    Op n \<Rightarrow> p ! n
  )"

lemma join_iro_R [simp]: "join_iro i r p (Rg n) = r $ n"
  by (simp add: join_iro_def)

abbreviation "check_exp g s \<equiv> (gval g (join_iro (snd (action (shd s))) (datastate (shd s)) (output (shd s))) = trilean.true)"

lemma alw_ev: "alw f = not (ev (\<lambda>s. \<not>f s))"
  by simp

lemma alw_state_eq_smap:
  "alw (state_eq s) ss = alw (\<lambda>ss. shd ss = s) (smap statename ss)"
  apply standard
   apply (simp add: alw_iff_sdrop )
  by (simp add: alw_mono alw_smap )

subsection\<open>Sink State\<close>
text\<open>Once the sink state is entered, it cannot be left and there are no outputs or updates
henceforth.\<close>

lemma shd_state_is_none: "(state_eq None) (make_full_observation e None r p t)"
  by (simp add: )

lemma unfold_observe_none: "make_full_observation e None d p t = (\<lparr>statename = None, datastate = d, action=(shd t), output = p\<rparr>##(make_full_observation e None d [] (stl t)))"
  by (simp add: stream.expand)

lemma once_none_always_none_aux:
  assumes "\<exists> p r i. j = (make_full_observation e None r p) i"
  shows "alw (state_eq None) j"
  using assms apply coinduct
  apply simp
  by fastforce

lemma once_none_always_none: "alw (state_eq None) (make_full_observation e None r p t)"
  using once_none_always_none_aux by blast

lemma once_none_nxt_always_none: "alw (nxt (state_eq None)) (make_full_observation e None r p t)"
  using once_none_always_none
  by (simp add: alw_iff_sdrop del: sdrop.simps)

lemma snth_sconst: "(\<forall>i. s !! i = h) = (s = sconst h)"
  by (auto simp add: sconst_alt sset_range)

lemma alw_sconst: "(alw (\<lambda>xs. shd xs = h) t) = (t = sconst h)"
  by (simp add: snth_sconst[symmetric] alw_iff_sdrop)

lemma smap_statename_None: "smap statename (make_full_observation e None r p i) = sconst None"
  by (meson EFSM_LTL.alw_sconst alw_state_eq_smap once_none_always_none)

lemma alw_not_some: "alw (\<lambda>xs. statename (shd xs) \<noteq> Some s) (make_full_observation e None r p t)"
  by (metis (mono_tags, lifting) alw_mono once_none_always_none option.distinct(1) )

lemma state_none: "((state_eq None) impl nxt (state_eq None)) (make_full_observation e s r p t)"
  by (simp add: )

lemma state_none_2:
  "(state_eq None) (make_full_observation e s r p t) \<Longrightarrow>
   (state_eq None) (make_full_observation e s r p (stl t))"
  by (simp add: )

lemma no_output_none_aux:
  assumes "\<exists> p r i. j = (make_full_observation e None r []) i"
  shows "alw (output_eq []) j"
  using assms apply coinduct
  apply simp
  by fastforce

lemma no_output_none: "nxt (alw (output_eq [])) (make_full_observation e None r p t)"
  using no_output_none_aux by auto

lemma nxt_alw: "nxt (alw P) s \<Longrightarrow> alw (nxt P) s"
  by (simp add: alw_iff_sdrop)

lemma no_output_none_nxt: "alw (nxt (output_eq [])) (make_full_observation e None r p t)"
  using nxt_alw no_output_none by blast

lemma no_output_none_if_empty: "alw (output_eq []) (make_full_observation e None r [] t)"
  by (metis (mono_tags, lifting) alw_nxt make_full_observation.simps(1) no_output_none state.select_convs(4))

lemma no_updates_none_aux:
  assumes "\<exists> p i. j = (make_full_observation e None r p) i"
  shows "alw (\<lambda>x. datastate (shd x) = r) j"
  using assms apply coinduct
  by fastforce

lemma no_updates_none: "alw (\<lambda>x. datastate (shd x) = r) (make_full_observation e None r p t)"
  using no_updates_none_aux by blast

lemma action_components: "(label_eq l aand input_eq i) s = (action (shd s) = (String.implode l, i))"
  by (metis fst_conv prod.collapse snd_conv)

end


(*  Title:      JinjaThreads/MM/JMM_Type.thy
    Author:     Andreas Lochbihler
*)

header {* \isaheader{JMM heap implementation 1} *}

theory JMM_Type
imports
  "../Common/ExternalCallWF"
  "../Common/ConformThreaded"
  JMM_Heap
begin

section {* Definitions *}

text {*
  The JMM heap only stores type information.
*}

type_synonym 'addr JMM_heap = "'addr \<rightharpoonup> htype"

translations (type) "'addr JMM_heap" <= (type) "'addr \<Rightarrow> htype option"

abbreviation jmm_empty :: "'addr JMM_heap" where "jmm_empty == Map.empty"

definition jmm_allocate :: "'addr JMM_heap \<Rightarrow> htype \<Rightarrow> ('addr JMM_heap \<times> 'addr) set"
where "jmm_allocate h hT = (\<lambda>a. (h(a \<mapsto> hT), a)) ` {a. h a = None}"

definition jmm_typeof_addr :: "'addr JMM_heap \<Rightarrow> 'addr \<rightharpoonup> htype"
where "jmm_typeof_addr h = h"

definition jmm_heap_read :: "'addr JMM_heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> bool"
where "jmm_heap_read h a ad v = True"

inductive jmm_heap_write :: "'addr JMM_heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool"
where "jmm_heap_write h a ad v h"

definition jmm_hconf :: "'m prog \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool" ("_ \<turnstile>jmm _ \<surd>" [51,51] 50)
where "P \<turnstile>jmm h \<surd> \<longleftrightarrow> ty_of_htype ` ran h \<subseteq> {T. is_type P T}"

definition jmm_allocated :: "'addr JMM_heap \<Rightarrow> 'addr set"
where "jmm_allocated h = dom (jmm_typeof_addr h)"

definition jmm_spurious_wakeups :: bool
where "jmm_spurious_wakeups = True"

lemmas jmm_heap_ops_defs =
  jmm_allocate_def jmm_typeof_addr_def
  jmm_heap_read_def jmm_heap_write_def
  jmm_allocated_def jmm_spurious_wakeups_def

type_synonym 'addr thread_id = "'addr"

abbreviation (input) addr2thread_id :: "'addr \<Rightarrow> 'addr thread_id"
where "addr2thread_id \<equiv> \<lambda>x. x"

abbreviation (input) thread_id2addr :: "'addr thread_id \<Rightarrow> 'addr"
where "thread_id2addr \<equiv> \<lambda>x. x"

interpretation jmm!: heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write
.

notation jmm.hext  ("_ \<unlhd>jmm _" [51,51] 50)
notation jmm.conf ("_,_ \<turnstile>jmm _ :\<le> _"  [51,51,51,51] 50)
notation jmm.addr_loc_type ("_,_ \<turnstile>jmm _@_ : _" [50, 50, 50, 50, 50] 51)
notation jmm.confs ("_,_ \<turnstile>jmm _ [:\<le>] _"  [51,51,51,51] 50)
notation jmm.tconf ("_,_ \<turnstile>jmm _ \<surd>t" [51,51,51] 50)

text {* Now a variation of the JMM with a different read operation that permits to read only type-conformant values *}

interpretation jmm'!: heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write
  for P .

notation jmm'.hext ("_ \<unlhd>jmm' _" [51,51] 50)
notation jmm'.conf ("_,_ \<turnstile>jmm' _ :\<le> _"  [51,51,51,51] 50)
notation jmm'.addr_loc_type ("_,_ \<turnstile>jmm' _@_ : _" [50, 50, 50, 50, 50] 51)
notation jmm'.confs ("_,_ \<turnstile>jmm' _ [:\<le>] _"  [51,51,51,51] 50)
notation jmm'.tconf ("_,_ \<turnstile>jmm' _ \<surd>t" [51,51,51] 50)

section {* Heap locale interpretations *}

subsection {* Locale @{text heap} *}

lemma jmm_heap: "heap addr2thread_id thread_id2addr jmm_allocate jmm_typeof_addr jmm_heap_write P"
proof
  fix h' a h hT
  assume "(h', a) \<in> jmm_allocate h hT"
  thus "jmm_typeof_addr h' a = \<lfloor>hT\<rfloor>"
    by(auto simp add: jmm_heap_ops_defs)
next
  fix h' :: "('addr :: addr) JMM_heap" and h hT a
  assume "(h', a) \<in> jmm_allocate h hT"
  thus "h \<unlhd>jmm h'"
    by(fastforce simp add: jmm_heap_ops_defs intro: jmm.hextI)
next
  fix h a al v and h' :: "('addr :: addr) JMM_heap"
  assume "jmm_heap_write h a al v h'"
  thus "h \<unlhd>jmm h'" by cases auto
qed simp

interpretation jmm!: heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write
  P
  for P
by(rule jmm_heap)

declare jmm.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemmas jmm'_heap = jmm_heap

interpretation jmm'!: heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write
  P
  for P
by(rule jmm'_heap)

declare jmm'.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

subsection {* Locale @{text "heap_conf"} *}

interpretation jmm!: heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write "jmm_hconf P"
  P
  for P .

abbreviation (input) jmm'_hconf :: "'m prog \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool" ("_ \<turnstile>jmm' _ \<surd>" [51,51] 50)
where "jmm'_hconf == jmm_hconf"

interpretation jmm'!: heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P .

abbreviation jmm_heap_read_typeable :: "('addr :: addr) itself \<Rightarrow> 'm prog \<Rightarrow> bool"
where "jmm_heap_read_typeable tytok P \<equiv> jmm.heap_read_typeable (jmm_hconf P :: 'addr JMM_heap \<Rightarrow> bool) P"

abbreviation jmm'_heap_read_typeable :: "('addr :: addr) itself \<Rightarrow> 'm prog \<Rightarrow> bool"
where "jmm'_heap_read_typeable tytok P \<equiv> jmm'.heap_read_typeable TYPE('m) P (jmm_hconf P :: 'addr JMM_heap \<Rightarrow> bool) P"

lemma jmm_heap_read_typeable: "jmm_heap_read_typeable tytok P"
by(rule jmm.heap_read_typeableI)(simp add: jmm_heap_read_def)

lemma jmm'_heap_read_typeable: "jmm'_heap_read_typeable tytok P"
by(rule jmm'.heap_read_typeableI)(auto simp add: jmm.heap_read_typed_def jmm_heap_read_def dest: jmm'.addr_loc_type_fun)

lemma jmm_heap_conf:
  "heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_write (jmm_hconf P) P"
proof
  show "P \<turnstile>jmm jmm_empty \<surd>"
    by(simp add: jmm_hconf_def)
next
  fix h a hT
  assume "jmm_typeof_addr h a = \<lfloor>hT\<rfloor>" "P \<turnstile>jmm h \<surd>"
  thus "is_htype P hT" by(auto simp add: jmm_hconf_def jmm_heap_ops_defs intro: ranI)
next
  fix h' h hT a
  assume "(h', a) \<in> jmm_allocate h hT" "P \<turnstile>jmm h \<surd>" "is_htype P hT"
  thus "P \<turnstile>jmm h' \<surd>"
    by(fastforce simp add: jmm_hconf_def jmm_heap_ops_defs ran_def split: split_if_asm)
next
  fix h a al v h' T
  assume "jmm_heap_write h a al v h'" "P \<turnstile>jmm h \<surd>"
    and "jmm.addr_loc_type P h a al T" and "P,h \<turnstile>jmm v :\<le> T"
  thus "P \<turnstile>jmm h' \<surd>" by(cases) simp
qed

interpretation jmm!: heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write "jmm_hconf P"
  P
  for P
by(rule jmm_heap_conf)

lemmas jmm'_heap_conf = jmm_heap_conf

interpretation jmm'!: heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
by(rule jmm'_heap_conf)

subsection {* Locale @{text heap_progress} *}

lemma jmm_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write (jmm_hconf P) P"
proof
  fix h a al T
  assume "P \<turnstile>jmm h \<surd>"
    and al: "jmm.addr_loc_type P h a al T"
  show "\<exists>v. jmm_heap_read h a al v \<and> P,h \<turnstile>jmm v :\<le> T"
    using jmm.defval_conf[of P h T] unfolding jmm_heap_ops_defs by blast
next
  fix h a al T v
  assume "jmm.addr_loc_type P h a al T"
  show "\<exists>h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm!: heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write "jmm_hconf P"
  P
  for P
by(rule jmm_heap_progress)

lemma jmm'_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr (jmm.heap_read_typed P) jmm_heap_write (jmm'_hconf P) P"
proof
  fix h a al T
  assume "P \<turnstile>jmm' h \<surd>"
    and al: "jmm'.addr_loc_type P h a al T"
  thus "\<exists>v. jmm.heap_read_typed P h a al v \<and> P,h \<turnstile>jmm' v :\<le> T"
    unfolding jmm.heap_read_typed_def jmm_heap_read_def
    by(auto dest: jmm'.addr_loc_type_fun intro: jmm'.defval_conf)
next
  fix h a al T v
  assume "jmm'.addr_loc_type P h a al T"
    and "P,h \<turnstile>jmm' v :\<le> T"
  thus "\<exists>h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm'!: heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
by(rule jmm'_heap_progress)

subsection {* Locale @{text heap_conf_read} *}

lemma jmm'_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr (jmm.heap_read_typed P) jmm_heap_write (jmm'_hconf P) P"
by(rule jmm.heap_conf_read_heap_read_typed)

interpretation jmm'!: heap_conf_read
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
by(rule jmm'_heap_conf_read)

interpretation jmm'!: heap_typesafe
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write "jmm'_hconf P"
  P
  for P
..

subsection {* Locale @{text allocated_heap} *}

lemma jmm_allocated_heap:
  "allocated_heap addr2thread_id thread_id2addr jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_write jmm_allocated P"
proof
  show "jmm_allocated jmm_empty = {}" by(auto simp add: jmm_heap_ops_defs)
next
  fix h' a h hT
  assume "(h', a) \<in> jmm_allocate h hT"
  thus "jmm_allocated h' = insert a (jmm_allocated h) \<and> a \<notin> jmm_allocated h"
    by(auto simp add: jmm_heap_ops_defs split: split_if_asm)
next
  fix h a al v h'
  assume "jmm_heap_write h a al v h'"
  thus "jmm_allocated h' = jmm_allocated h" by cases simp
qed

interpretation jmm!: allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr jmm_heap_read jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm_allocated_heap)

lemmas jmm'_allocated_heap = jmm_allocated_heap

interpretation jmm'!: allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate jmm_typeof_addr "jmm.heap_read_typed P" jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm'_allocated_heap)

subsection {* Syntax translations *}

notation jmm'.external_WT' ("_,_ \<turnstile>jmm' (_\<bullet>_'(_')) : _" [50,0,0,0,50] 60)

abbreviation jmm'_red_external ::
  "'m prog \<Rightarrow> 'addr thread_id \<Rightarrow> 'addr JMM_heap \<Rightarrow> 'addr \<Rightarrow> mname \<Rightarrow> 'addr val list
  \<Rightarrow> ('addr :: addr, 'addr thread_id, 'addr JMM_heap) external_thread_action
  \<Rightarrow> 'addr extCallRet \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool"
where "jmm'_red_external P \<equiv> jmm'.red_external (TYPE('m)) P P"

abbreviation jmm'_red_external_syntax ::
  "'m prog \<Rightarrow> 'addr thread_id \<Rightarrow> 'addr \<Rightarrow> mname \<Rightarrow> 'addr val list \<Rightarrow> 'addr JMM_heap
  \<Rightarrow> ('addr :: addr, 'addr thread_id, 'addr JMM_heap) external_thread_action
  \<Rightarrow> 'addr extCallRet \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm' (\<langle>(_\<bullet>_'(_')),/_\<rangle>) -_\<rightarrow>ext (\<langle>(_),/(_)\<rangle>)" [50, 0, 0, 0, 0, 0, 0, 0, 0] 51)
where
  "P,t \<turnstile>jmm' \<langle>a\<bullet>M(vs), h\<rangle> -ta\<rightarrow>ext \<langle>va, h'\<rangle> \<equiv> jmm'_red_external P t h a M vs ta va h'"

abbreviation jmm'_red_external_aggr ::
  "'m prog \<Rightarrow> 'addr thread_id \<Rightarrow> 'addr \<Rightarrow> mname \<Rightarrow> 'addr val list \<Rightarrow> 'addr JMM_heap
    \<Rightarrow> (('addr :: addr, 'addr thread_id, 'addr JMM_heap) external_thread_action \<times> 'addr extCallRet \<times> 'addr JMM_heap) set"
where "jmm'_red_external_aggr P \<equiv> jmm'.red_external_aggr TYPE('m) P P"

abbreviation jmm'_heap_copy_loc ::
  "'m prog \<Rightarrow> 'addr \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr JMM_heap
  \<Rightarrow> ('addr :: addr, 'addr thread_id) obs_event list \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool"
where "jmm'_heap_copy_loc \<equiv> jmm'.heap_copy_loc TYPE('m)"

abbreviation jmm'_heap_copies ::
  "'m prog \<Rightarrow> 'addr \<Rightarrow> 'addr \<Rightarrow> addr_loc list \<Rightarrow> 'addr JMM_heap
  \<Rightarrow> ('addr :: addr, 'addr thread_id) obs_event list \<Rightarrow> 'addr JMM_heap \<Rightarrow> bool"
where "jmm'_heap_copies \<equiv> jmm'.heap_copies TYPE('m)"

abbreviation jmm'_heap_clone ::
  "'m prog \<Rightarrow> 'addr JMM_heap \<Rightarrow> 'addr \<Rightarrow> 'addr JMM_heap
  \<Rightarrow> (('addr :: addr, 'addr thread_id) obs_event list \<times> 'addr) option \<Rightarrow> bool"
where "jmm'_heap_clone P \<equiv> jmm'.heap_clone TYPE('m) P P"

end


theory ResMapValid
  imports GenSubEnv NormEnv ResMapDisj
begin

definition super_drop_use_env where
  "super_drop_use_env r_s = (\<lambda> x. if r_s x = OwnPerm then NoPerm else r_s x)"

lemma self_sdrop_leq_use_env: "leq_use_env (super_drop_use_env r_s) r_s"
  apply (simp add: super_drop_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

lemma sdrop_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow> leq_use_env (super_drop_use_env r_x) r_s"
  apply (rule_tac r_sb="r_x" in trans_leq_use_env)
   apply (simp)
  apply (rule_tac self_sdrop_leq_use_env)
  done

lemma diff_sdrop_leq_use_env: "leq_use_env (diff_use_env r_s r_s) (super_drop_use_env r_s)"
  apply (simp add: leq_use_env_def)
  apply (simp add: super_drop_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: minus_use_env_def)
  apply (simp add: neg_use_env_def)
  apply (auto)
  apply (case_tac "r_s x")
    apply (auto)
  done

  (* basically, we want a static way of describing a recursive structure that will be maintained inductively and wont have any unpleasant
      properties (cyclic dependencies, etc). *)

  (*
definition valid_use_env where
  "valid_use_env s rs_map r_s r_x = (sub_use_env s r_c \<and> leq_use_env r_s r_c \<and> (\<forall> x. r_s x \<noteq> NoPerm \<longrightarrow>
    leq_use_env (lookup_res rs_map x) r_s \<and> disj_use_env (lookup_res rs_map x) r_x
  ))"*)

definition valid_use_entry where
  "valid_use_entry r_c r_s r_x = (leq_use_env r_x r_c \<and> strong_disj_use_env r_x r_s)"

definition valid_use_env where
  "valid_use_env s rs_map r_c r_s = (sub_use_env s r_c \<and> leq_use_env r_s r_c \<and>
    (\<forall> x. r_c x \<noteq> NoPerm \<longrightarrow> valid_use_entry r_c r_s (lookup_res rs_map x)))"

    (* - valid res map lemmas *)
    (*
lemma add_valid_res_map_rev: "\<lbrakk> valid_res_map s (add_mem rs_map x v); fresh_var s x \<rbrakk> \<Longrightarrow> valid_res_map s rs_map"
  apply (simp add: valid_res_map_def)
  apply (auto)
    apply (simp add: disj_res_map_def)
    apply (auto)
    apply (erule_tac x="xa" in allE)
    apply (erule_tac x="y" in allE)
    apply (auto)
    apply (case_tac "x = xa")
     apply (auto)
     apply (case_tac "x = y")
      apply (auto)
     apply (simp add: add_mem_def)
    apply (simp add: lookup_res_def)
    apply (simp add: add_mem_def)
    apply (case_tac "x = xa")
     apply (auto)
     apply (case_tac "x = y")
    apply (auto)

  apply (induct rs_map arbitrary: x v)
   apply (simp add: valid_res_map_def)
   apply (auto)
    apply (simp add: disj_res_map_def)
    apply (simp add: lookup_res_def)
    apply (auto)
    apply (rule_tac empty_strong_disj_use_env1)
   apply (simp add: sub_res_map_def)
  apply (simp add: add_mem_def)
  apply (simp add: valid_res_map_def)
  apply (auto)
   apply (cut_tac rs_map="rs_map" and x="x1" and r_s="x2" in disj_add_res_map)

  done*)
    (*
lemma add_valid_res_map: "\<lbrakk> valid_res_map s rs_map \<rbrakk> \<Longrightarrow> valid_res_map (add_mem s x v) rs_map"
  apply (simp add: valid_res_map_def)
  apply (auto)
   apply (simp add: sub_res_map_def)
   apply (simp add: add_mem_def)
  apply (erule_tac x="xa" in allE)
  apply (rule_tac add_sub_use_env)
  apply (auto)
  done

lemma add_set_valid_res_map: "\<lbrakk> valid_res_map s rs_map; sep_res_map r_s rs_map; sub_use_env s r_s \<rbrakk> \<Longrightarrow> valid_res_map (add_mem s x v) (set_res_map rs_map x r_s)"
  apply (simp add: valid_res_map_def)
  apply (auto)
     apply (simp add: set_res_map_def)
     apply (simp add: disj_res_map_def)
     apply (auto)
     apply (simp add: sep_res_map_def)
    apply (simp add: sep_res_map_def)
    apply (rule_tac comm_strong_disj_use_env)
    apply (simp)
   apply (simp add: sub_res_map_def)
   apply (simp add: add_mem_def)
   apply (auto)
   apply (simp add: set_res_map_def)
  apply (simp add: sub_res_map_def)
  apply (simp add: set_res_map_def)
  apply (auto)
   apply (rule_tac add_sub_use_env)
   apply (simp)
  apply (rule_tac add_sub_use_env)
  apply (simp)
  done    *)
(*
lemma add_rem_valid_res_map: "\<lbrakk> valid_res_map (add_mem s x v) rs_map \<rbrakk> \<Longrightarrow> valid_res_map s (rem_res_map rs_map x)"
  apply (simp add: valid_res_map_def)
  apply (auto)
    apply (rule_tac disj_rem_res_map)
    apply (simp)
   apply (rule_tac add_rem_sub_res_map)
   apply (simp)
  apply (simp add: rem_res_map_def)
  apply (simp add: set_res_map_def)
  apply (auto)
   apply (rule_tac empty_sub_use_env)
  *)
(*
lemma valid_lookup_res_map: "\<lbrakk> valid_res_map s rs_map; lookup_mem rs_map x = Some (r_s, rs_map') \<rbrakk> \<Longrightarrow> scope_use_env rs_map' r_s"
  apply (induct rs_map)
   apply (auto)
  apply (simp add: valid_res_map_def)    *)

    (* valid use env lemmas *)

lemma contain_valid_use_env: "\<lbrakk> contain_env s' s; valid_use_env s rs_map r_c r_s \<rbrakk> \<Longrightarrow> valid_use_env s' rs_map r_c r_s"
  apply (simp add: valid_use_env_def)
  apply (simp add: sub_use_env_def)
  apply (simp add: contain_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "s x")
   apply (auto)
  done

    (* ######### NRES map validity *)

definition valid_nres_map where
  "valid_nres_map s s_map = (full_nres_map s s_map \<and> disj_nres_map s_map \<and> sub_nres_map s s_map)"

definition valid_exp_use_env where
  "valid_exp_use_env s s_map r_s = (sub_use_env s r_s \<and> sep_nres_map r_s s_map)"

end


theory LLVM_Memory_RS
imports
  "../basic/LLVM_Basic_Main"
  Sep_Value_RS
  Sep_Array_Block_RS
begin

  interpretation ab: array_block2 "STATIC_ERROR ''''" MEM_ERROR "vload MEM_ERROR::_ \<Rightarrow> (llvm_primval val,_,_,_,_) M" "vstore MEM_ERROR" "checked_gep MEM_ERROR" val_\<alpha> vpto_assn "\<lambda>v. v\<in>range val_\<alpha>"
    apply unfold_locales
    apply (rule vload_rule)
    apply (rule vstore_rule)
    apply (rule vpto_assn_notZ)
    apply auto []
    apply (simp; rule vpto_assn_this)
    apply auto []
    done

  datatype llvm_amemory = LLVM_AMEMORY (the_amemory: "(nat \<Rightarrow> (nat \<Rightarrow> llvm_primval aval) \<times> int tsa_opt)")

  instantiation llvm_amemory :: unique_zero_sep_algebra begin
    definition "sep_disj_llvm_amemory a b \<equiv> the_amemory a ## the_amemory b"
    definition "plus_llvm_amemory a b \<equiv> LLVM_AMEMORY (the_amemory a + the_amemory b)"
    definition "zero_llvm_amemory \<equiv> LLVM_AMEMORY 0"

    instance
      apply standard
      unfolding sep_disj_llvm_amemory_def plus_llvm_amemory_def zero_llvm_amemory_def
      apply (auto simp: sep_algebra_simps llvm_amemory.expand)
      done

  end

  type_synonym llvm_assn = "llvm_amemory \<Rightarrow> bool"

  definition "llvm_\<alpha> \<equiv> LLVM_AMEMORY o ab.ba.\<alpha> o llvm_memory.the_memory"
  definition "llvm_pto x p \<equiv> (ab.ba.pto (llvm_val.the_val x) (llvm_ptr.the_ptr p)) o llvm_amemory.the_amemory"
  (*definition "llvm_is_base_ptr p \<equiv> ab.is_base_ptr (llvm_ptr.the_ptr p)"*)

  definition "llvm_malloc_tag n p \<equiv> ab.ba.tag n (llvm_ptr.the_ptr p) o llvm_amemory.the_amemory"

  instantiation llvm_ptr :: addr_algebra begin
    definition "abase_llvm_ptr = abase o llvm_ptr.the_ptr"
    definition "acompat_llvm_ptr a b \<equiv> acompat (llvm_ptr.the_ptr a) (llvm_ptr.the_ptr b)"
    definition "adiff_llvm_ptr a b \<equiv> adiff (llvm_ptr.the_ptr a) (llvm_ptr.the_ptr b)"
    definition "aidx_llvm_ptr a i \<equiv> LLVM_PTR ((llvm_ptr.the_ptr a) +\<^sub>a i)"

    instance
      apply standard
      unfolding abase_llvm_ptr_def acompat_llvm_ptr_def adiff_llvm_ptr_def aidx_llvm_ptr_def
      apply (intro part_equivpI sympI transpI)
      apply (metis ab.block_ptr_imp_abase ab.is_block_ptr_simps(2) acompat_refl llvm_ptr.sel)
      apply (auto intro: acompat_trans simp: acompat_dom)
      done
  end

  (*
  definition "llvm_idx_ptr p i \<equiv> LLVM_PTR (ab.idx_ptr (llvm_ptr.the_ptr p) i)"
  definition "llvm_is_arr_ptr p \<equiv> ab.is_arr_ptr (llvm_ptr.the_ptr p)"

  lemma llvm_idx_ptr_add[simp]: "llvm_idx_ptr (llvm_idx_ptr p i) j = llvm_idx_ptr p (i+j)"
    by (cases p) (auto simp: llvm_idx_ptr_def)

  lemma llvm_is_arr_ptr_idx[simp]: "llvm_is_arr_ptr (llvm_idx_ptr p i) \<longleftrightarrow> llvm_is_arr_ptr p"
    by (cases p) (auto simp: llvm_idx_ptr_def llvm_is_arr_ptr_def)
  *)

  lemma xfer_htriple:
    assumes "notime.htriple ab.ba.\<alpha> P c Q"
    assumes "P' = P o llvm_amemory.the_amemory"
    assumes "c' = llvm_zoom_base \<alpha> c"
    assumes "\<And>r. Q' (\<alpha> r) = Q r o llvm_amemory.the_amemory"
    shows "notime.htriple llvm_\<alpha> P' c' Q'"
    using assms unfolding notime.htriple_alt llvm_zoom_base_def llvm_\<alpha>_def wpn_def
    apply (clarsimp simp: run_simps)
  proof goal_cases
    case A: (1 p s f)

    find_theorems llvm_memory.the_memory\<^sub>L

    from \<open>p##f\<close> \<open>LLVM_AMEMORY (ab.ba.\<alpha> (get' llvm_memory.the_memory\<^sub>L s)) = p + f\<close>
    have "llvm_amemory.the_amemory p ## llvm_amemory.the_amemory f"
      and "ab.ba.\<alpha> (get' llvm_memory.the_memory\<^sub>L s) = llvm_amemory.the_amemory p + llvm_amemory.the_amemory f"
      by (auto simp: sep_disj_llvm_amemory_def plus_llvm_amemory_def)

    from A(1)[rule_format] show ?case
      apply (rule mwp_cons)
      apply (intro conjI; fact)
      apply (clarsimp_all simp: run_simps)
      by (metis (full_types) assms(4) comp_apply llvm_amemory.sel plus_llvm_amemory_def sep_disj_llvm_amemory_def)

  qed

  lemma llvm_load_rule[vcg_rules]: "notime.htriple llvm_\<alpha> (llvm_pto x p) (llvm_load p) (\<lambda>r. \<up>(r=x) ** llvm_pto x p)"
    apply (rule xfer_htriple[OF ab.ba.load_rule])
    unfolding llvm_pto_def llvm_load_def
    apply simp
    apply simp
    apply (rule ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
    done

  lemma llvm_store_unchecked_rule[vcg_rules]: "notime.htriple llvm_\<alpha> (llvm_pto xx p) (llvm_store_unchecked x p) (\<lambda>_. llvm_pto x p)"
    apply (rule xfer_htriple[OF ab.ba.store_rule])
    unfolding llvm_pto_def llvm_store_unchecked_def
    apply simp
    apply simp
    apply (rule ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps)
    done

  lemma llvm_store_rule[vcg_rules]: "llvm_vstruct x = llvm_vstruct xx
    \<Longrightarrow> notime.htriple llvm_\<alpha> (llvm_pto xx p) (llvm_store x p) (\<lambda>_. llvm_pto x p)"
    unfolding llvm_store_def
    by vcg

  lemma the_amemoryZ[simp]: "the_amemory 0 = 0" by (auto simp: zero_llvm_amemory_def)

  lemma the_amemoryZ_iff[simp]: "the_amemory x = 0 \<longleftrightarrow> x=0"
    by (auto simp: zero_llvm_amemory_def llvm_amemory.expand)

  lemma xfer_sep_conj1: "((\<lambda>x. a (the_amemory x)) ** (\<lambda>x. b (the_amemory x))) = (a**b) o the_amemory"
    apply (rule ext)
    apply (auto 3 3 simp: sep_conj_def sep_disj_llvm_amemory_def plus_llvm_amemory_def)
    by (metis (full_types) llvm_amemory.exhaust_sel llvm_amemory.sel)

  lemma xfer_sep_conj2: "((a o the_amemory) ** (b o the_amemory)) = (a**b) o the_amemory"
    using xfer_sep_conj1 unfolding comp_def .

  lemmas xfer_sep_conj = xfer_sep_conj1 xfer_sep_conj2

  lemma xfer_sep_list_conj1: "(\<And>*map (\<lambda>x. f x o the_amemory) l) = (\<And>*map f l) o the_amemory"
    apply (induction l)
    apply auto
    by (auto simp: sep_algebra_simps xfer_sep_conj)

  lemma xfer_sep_list_conj2: "(\<And>*map (\<lambda>x s. f x (the_amemory s)) l) = (\<And>*map f l) o the_amemory"
    using xfer_sep_list_conj1 unfolding comp_def .

  lemmas xfer_sep_list_conj = xfer_sep_list_conj1 xfer_sep_list_conj2

  lemma xfer_sep_set_img1: "(\<Union>*x\<in>I. f x o the_amemory) = (\<Union>*x\<in>I. f x) o the_amemory"
  proof (cases "finite I")
    case True then show ?thesis
      by (induction) (auto del: ext intro!: ext simp: sep_algebra_simps xfer_sep_conj)
  qed auto

  lemma xfer_sep_set_img2: "(\<Union>*x\<in>I. (\<lambda>s. f x (the_amemory s))) = (\<Union>*x\<in>I. f x) o the_amemory"
    using xfer_sep_set_img1 unfolding comp_def .

  lemmas xfer_sep_set_img = xfer_sep_set_img1 xfer_sep_set_img2

  lemma llvm_allocn_rule[vcg_rules]:
    "notime.htriple llvm_\<alpha>
      \<box>
      (llvm_allocn v n)
      (\<lambda>r. (\<Union>*i\<in>{0..<int n}. llvm_pto v (r +\<^sub>a i))
        ** llvm_malloc_tag (int n) r ** \<up>(abase r))"
    apply (rule xfer_htriple[OF ab.ba_allocn_rule])
    unfolding llvm_pto_def llvm_allocn_def llvm_malloc_tag_def abase_llvm_ptr_def aidx_llvm_ptr_def
    apply (rule ext) apply (auto simp: sep_algebra_simps) []
    apply simp
    apply (rule ext)
    apply (auto simp: sep_algebra_simps pred_lift_extract_simps xfer_sep_set_img xfer_sep_conj)
    done

  lemma llvm_free_rule[vcg_rules]:
    "notime.htriple llvm_\<alpha>
      ((\<Union>*i\<in>{0..<n}. EXS v. llvm_pto v (p +\<^sub>a i))
        ** llvm_malloc_tag n p)
      (llvm_free p)
      (\<lambda>_. \<box>)"
    apply (rule xfer_htriple[OF ab.ba_freen_rule[where p="llvm_ptr.the_ptr p" and n=n], where \<alpha>=id])
    apply (cases p; simp add: )

    unfolding llvm_pto_def llvm_free_def llvm_malloc_tag_def aidx_llvm_ptr_def
    apply (auto simp: sep_algebra_simps)
    apply (subst xfer_sep_set_img xfer_sep_conj)+
    apply (cases p; simp)
    by (metis llvm_val.sel)

  lemma llvm_checked_idx_ptr_rule[vcg_rules]:
    "abase p \<Longrightarrow>
      notime.htriple llvm_\<alpha>
        (llvm_pto v (p +\<^sub>a i))
        (llvm_checked_idx_ptr p i)
        (\<lambda>r. \<up>(r= p +\<^sub>a i) ** llvm_pto v (p +\<^sub>a i))
    "

    supply R=xfer_htriple[OF ab.checked_idx_ptr_rule[where p="llvm_ptr.the_ptr p" and i=i and xx="llvm_val.the_val v"], where \<alpha>=LLVM_PTR]
    apply (rule R)
    unfolding llvm_checked_idx_ptr_def llvm_pto_def abase_llvm_ptr_def aidx_llvm_ptr_def
    apply (auto simp: xfer_sep_conj sep_algebra_simps pred_lift_extract_simps)
    done

end