(*  Title:      JinjaThreads/J/WellType.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

section \<open>Well-typedness of Jinja expressions\<close>

theory WellType
imports
  Expr
  State
  "../Common/ExternalCallWF"
  "../Common/WellForm"
  "../Common/SemiType"
begin

declare Listn.lesub_list_impl_same_size[simp del]
declare listE_length [simp del]

type_synonym
  env  = "vname \<rightharpoonup> ty"

inductive
  WT :: "(ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool) \<Rightarrow> 'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> ty \<Rightarrow> bool" ("_,_,_ \<turnstile> _ :: _"   [51,51,51,51]50)
  and WTs :: "(ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool) \<Rightarrow> 'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> ty list \<Rightarrow> bool"
    ("_,_,_ \<turnstile> _ [::] _"   [51,51,51,51]50)
  for is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  and P :: "'addr J_prog"
where

  WTNew:
  "is_class P C  \<Longrightarrow>
  is_lub,P,E \<turnstile> new C :: Class C"

| WTNewArray:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Integer; is_type P (T\<lfloor>\<rceil>) \<rbrakk> \<Longrightarrow>
  is_lub,P,E \<turnstile> newA T\<lfloor>e\<rceil> :: T\<lfloor>\<rceil>"

| WTCast:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: T; P \<turnstile> U \<le> T \<or> P \<turnstile> T \<le> U; is_type P U \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> Cast U e :: U"

| WTInstanceOf:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: T; P \<turnstile> U \<le> T \<or> P \<turnstile> T \<le> U; is_type P U; is_refT U \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e instanceof U :: Boolean"

| WTVal:
  "typeof v = Some T \<Longrightarrow>
  is_lub,P,E \<turnstile> Val v :: T"

| WTVar:
  "E V = Some T \<Longrightarrow>
  is_lub,P,E \<turnstile> Var V :: T"

| WTBinOp:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 :: T1; is_lub,P,E \<turnstile> e2 :: T2; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e1\<guillemotleft>bop\<guillemotright>e2 :: T"

| WTLAss:
  "\<lbrakk> E V = Some T;  is_lub,P,E \<turnstile> e :: T';  P \<turnstile> T' \<le> T;  V \<noteq> this \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> V:=e :: Void"

| WTAAcc:
  "\<lbrakk> is_lub,P,E \<turnstile> a :: T\<lfloor>\<rceil>; is_lub,P,E \<turnstile> i :: Integer \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> a\<lfloor>i\<rceil> :: T"

| WTAAss:
  "\<lbrakk> is_lub,P,E \<turnstile> a :: T\<lfloor>\<rceil>; is_lub,P,E \<turnstile> i :: Integer; is_lub,P,E \<turnstile> e :: T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> a\<lfloor>i\<rceil> := e :: Void"

| WTALength:
  "is_lub,P,E \<turnstile> a :: T\<lfloor>\<rceil> \<Longrightarrow> is_lub,P,E \<turnstile> a\<bullet>length :: Integer"

| WTFAcc:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<bullet>F{D} :: T"

| WTFAss:
  "\<lbrakk> is_lub,P,E \<turnstile> e\<^sub>1 :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D; is_lub,P,E \<turnstile> e\<^sub>2 :: T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :: Void"

| WTCAS:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D; volatile fm;
     is_lub,P,E \<turnstile> e2 :: T'; P \<turnstile> T' \<le> T; is_lub,P,E \<turnstile> e3 :: T''; P \<turnstile> T'' \<le> T \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> e1\<bullet>compareAndSwap(D\<bullet>F, e2, e3) :: Boolean"

| WTCall:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees M:Ts \<rightarrow> T = meth in D;
     is_lub,P,E \<turnstile> es [::] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<bullet>M(es) :: T"

| WTBlock:
  "\<lbrakk> is_type P T;  is_lub,P,E(V \<mapsto> T) \<turnstile> e :: T'; case vo of None \<Rightarrow> True | \<lfloor>v\<rfloor> \<Rightarrow> \<exists>T'. typeof v = \<lfloor>T'\<rfloor> \<and> P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> {V:T=vo; e} :: T'"

| WTSynchronized:
  "\<lbrakk> is_lub,P,E \<turnstile> o' :: T; is_refT T; T \<noteq> NT; is_lub,P,E \<turnstile> e :: T' \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> sync(o') e :: T'"

\<comment> \<open>Note that insync is not statically typable.\<close>

| WTSeq:
  "\<lbrakk> is_lub,P,E \<turnstile> e\<^sub>1::T\<^sub>1;  is_lub,P,E \<turnstile> e\<^sub>2::T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"

| WTCond:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Boolean;  is_lub,P,E \<turnstile> e\<^sub>1::T\<^sub>1;  is_lub,P,E \<turnstile> e\<^sub>2::T\<^sub>2; \<turnstile> lub(T\<^sub>1, T\<^sub>2) = T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T"

| WTWhile:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Boolean;  is_lub,P,E \<turnstile> c::T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> while (e) c :: Void"

| WTThrow:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Class C; P \<turnstile> C \<preceq>\<^sup>* Throwable \<rbrakk> \<Longrightarrow>
  is_lub,P,E \<turnstile> throw e :: Void"

| WTTry:
  "\<lbrakk> is_lub,P,E \<turnstile> e\<^sub>1 :: T;  is_lub,P,E(V \<mapsto> Class C) \<turnstile> e\<^sub>2 :: T; P \<turnstile> C \<preceq>\<^sup>* Throwable \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :: T"

| WTNil: "is_lub,P,E \<turnstile> [] [::] []"

| WTCons: "\<lbrakk> is_lub,P,E \<turnstile> e :: T; is_lub,P,E \<turnstile> es [::] Ts \<rbrakk> \<Longrightarrow> is_lub,P,E \<turnstile> e#es [::] T#Ts"

abbreviation WT' :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> ty \<Rightarrow> bool" ("_,_ \<turnstile> _ :: _" [51,51,51] 50)
where "WT' P \<equiv> WT (TypeRel.is_lub P) P"

abbreviation WTs' :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> ty list \<Rightarrow> bool" ("_,_ \<turnstile> _ [::] _" [51,51,51] 50)
where "WTs' P \<equiv> WTs (TypeRel.is_lub P) P"

declare WT_WTs.intros[intro!]

inductive_simps WTs_iffs [iff]:
  "is_lub',P,E \<turnstile> [] [::] Ts"
  "is_lub',P,E \<turnstile> e#es [::] T#Ts"
  "is_lub',P,E \<turnstile> e#es [::] Ts"

lemma WTs_conv_list_all2:
  fixes is_lub
  shows "is_lub,P,E \<turnstile> es [::] Ts = list_all2 (WT is_lub P E) es Ts"
by(induct es arbitrary: Ts)(auto simp add: list_all2_Cons1 elim: WTs.cases)

lemma WTs_append [iff]: "\<And>is_lub Ts. (is_lub,P,E \<turnstile> es\<^sub>1 @ es\<^sub>2 [::] Ts) =
  (\<exists>Ts\<^sub>1 Ts\<^sub>2. Ts = Ts\<^sub>1 @ Ts\<^sub>2 \<and> is_lub,P,E \<turnstile> es\<^sub>1 [::] Ts\<^sub>1 \<and> is_lub,P,E \<turnstile> es\<^sub>2[::]Ts\<^sub>2)"
by(auto simp add: WTs_conv_list_all2 list_all2_append1 dest: list_all2_lengthD[symmetric])

inductive_simps WT_iffs [iff]:
  "is_lub',P,E \<turnstile> Val v :: T"
  "is_lub',P,E \<turnstile> Var V :: T"
  "is_lub',P,E \<turnstile> e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"
  "is_lub',P,E \<turnstile> {V:T=vo; e} :: T'"

inductive_cases WT_elim_cases[elim!]:
  "is_lub',P,E \<turnstile> V :=e :: T"
  "is_lub',P,E \<turnstile> sync(o') e :: T"
  "is_lub',P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T"
  "is_lub',P,E \<turnstile> while (e) c :: T"
  "is_lub',P,E \<turnstile> throw e :: T"
  "is_lub',P,E \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :: T"
  "is_lub',P,E \<turnstile> Cast D e :: T"
  "is_lub',P,E \<turnstile> e instanceof U :: T"
  "is_lub',P,E \<turnstile> a\<bullet>F{D} :: T"
  "is_lub',P,E \<turnstile> a\<bullet>F{D} := v :: T"
  "is_lub',P,E \<turnstile> e\<bullet>compareAndSwap(D\<bullet>F, e', e'') :: T"
  "is_lub',P,E \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
  "is_lub',P,E \<turnstile> new C :: T"
  "is_lub',P,E \<turnstile> newA T\<lfloor>e\<rceil> :: T'"
  "is_lub',P,E \<turnstile> a\<lfloor>i\<rceil> := e :: T"
  "is_lub',P,E \<turnstile> a\<lfloor>i\<rceil> :: T"
  "is_lub',P,E \<turnstile> a\<bullet>length :: T"
  "is_lub',P,E \<turnstile> e\<bullet>M(ps) :: T"
  "is_lub',P,E \<turnstile> sync(o') e :: T"
  "is_lub',P,E \<turnstile> insync(a) e :: T"

lemma fixes is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_unique: "\<And>T1 T2 T3 T4. \<lbrakk> \<turnstile> lub(T1, T2) = T3; \<turnstile> lub(T1, T2) = T4 \<rbrakk> \<Longrightarrow> T3 = T4"
  shows WT_unique: "\<lbrakk> is_lub,P,E \<turnstile> e :: T; is_lub,P,E \<turnstile> e :: T' \<rbrakk> \<Longrightarrow> T = T'"
  and WTs_unique: "\<lbrakk> is_lub,P,E \<turnstile> es [::] Ts; is_lub,P,E \<turnstile> es [::] Ts' \<rbrakk> \<Longrightarrow> Ts = Ts'"
apply(induct arbitrary: T' and Ts' rule: WT_WTs.inducts)
apply blast
apply blast
apply blast
apply blast
apply fastforce
apply fastforce
apply(fastforce dest: WT_binop_fun)
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply(fastforce dest: sees_field_fun)
apply(fastforce dest: sees_field_fun)
apply blast
apply(fastforce dest: sees_method_fun)
apply fastforce
apply fastforce
apply fastforce
apply(blast dest: is_lub_unique)
apply fastforce
apply fastforce
apply blast
apply fastforce
apply fastforce
done

lemma fixes is_lub
  shows wt_env_mono: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> is_lub,P,E' \<turnstile> e :: T)"
  and wts_env_mono: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> is_lub,P,E' \<turnstile> es [::] Ts)"
apply(induct rule: WT_WTs.inducts)
apply(simp add: WTNew)
apply(simp add: WTNewArray)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTInstanceOf)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOp)
apply(force simp:map_le_def)
apply(simp add: WTAAcc)
apply(simp add: WTAAss, fastforce)
apply(simp add: WTALength, fastforce)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply blast
apply(fastforce)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSynchronized)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(fastforce)+
done

lemma fixes is_lub
  shows WT_fv: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> fv e \<subseteq> dom E"
  and WT_fvs: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> fvs es \<subseteq> dom E"
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done

lemma fixes is_lub
  shows WT_expr_locks: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> expr_locks e = (\<lambda>ad. 0)"
  and WTs_expr_lockss: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> expr_lockss es = (\<lambda>ad. 0)"
by(induct rule: WT_WTs.inducts)(auto)

lemma
  fixes is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_is_type: "\<And>T1 T2 T3. \<lbrakk> \<turnstile> lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T3"
  and wf: "wf_prog wf_md P"
  shows WT_is_type: "\<lbrakk> is_lub,P,E \<turnstile> e :: T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> is_type P T"
  and WTs_is_type: "\<lbrakk> is_lub,P,E \<turnstile> es [::] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> set Ts \<subseteq> types P"
apply(induct rule: WT_WTs.inducts)
apply simp
apply simp
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (fastforce intro:nth_mem simp add: ran_def)
apply(simp add: WT_binop_is_type)
apply(simp)
apply(simp del: is_type_array add: is_type_ArrayD)
apply(simp)
apply(simp)
apply(simp add:sees_field_is_type[OF _ wf])
apply(simp)
apply simp
apply(fastforce dest: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply(fastforce simp add: ran_def split: if_split_asm)
apply(simp add: is_class_Object[OF wf])
apply(simp)
apply(simp)
apply(fastforce intro: is_lub_is_type)
apply(simp)
apply(simp)
apply simp
apply simp
apply simp
done

lemma
  fixes is_lub1 :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile>1 lub'((_,/ _)') = _" [51,51,51] 50)
  and is_lub2 :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile>2 lub'((_,/ _)') = _" [51,51,51] 50)
  assumes wf: "wf_prog wf_md P"
  and is_lub1_into_is_lub2: "\<And>T1 T2 T3. \<lbrakk> \<turnstile>1 lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> \<turnstile>2 lub(T1, T2) = T3"
  and is_lub2_is_type: "\<And>T1 T2 T3. \<lbrakk> \<turnstile>2 lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T3"
  shows WT_change_is_lub: "\<lbrakk> is_lub1,P,E \<turnstile> e :: T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> is_lub2,P,E \<turnstile> e :: T"
  and WTs_change_is_lub: "\<lbrakk> is_lub1,P,E \<turnstile> es [::] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> is_lub2,P,E \<turnstile> es [::] Ts"
proof(induct rule: WT_WTs.inducts)
  case (WTBlock U E V e' T vo)
  from \<open>is_type P U\<close> \<open>ran E \<subseteq> types P\<close>
  have "ran (E(V \<mapsto> U)) \<subseteq> types P" by(auto simp add: ran_def)
  hence "is_lub2,P,E(V \<mapsto> U) \<turnstile> e' :: T" by(rule WTBlock)
  with \<open>is_type P U\<close> show ?case
    using \<open>case vo of None \<Rightarrow> True | \<lfloor>v\<rfloor> \<Rightarrow> \<exists>T'. typeof v = \<lfloor>T'\<rfloor> \<and> P \<turnstile> T' \<le> U\<close> by auto
next
  case (WTCond E e e1 T1 e2 T2 T)
  from \<open>ran E \<subseteq> types P\<close> have "is_lub2,P,E \<turnstile> e :: Boolean" "is_lub2,P,E \<turnstile> e1 :: T1" "is_lub2,P,E \<turnstile> e2 :: T2"
    by(rule WTCond)+
  moreover from is_lub2_is_type wf \<open>is_lub2,P,E \<turnstile> e1 :: T1\<close> \<open>ran E \<subseteq> types P\<close>
  have "is_type P T1" by(rule WT_is_type)
  from is_lub2_is_type wf \<open>is_lub2,P,E \<turnstile> e2 :: T2\<close> \<open>ran E \<subseteq> types P\<close>
  have "is_type P T2" by(rule WT_is_type)
  with \<open>\<turnstile>1 lub(T1, T2) = T\<close> \<open>is_type P T1\<close>
  have "\<turnstile>2 lub(T1, T2) = T" by(rule is_lub1_into_is_lub2)
  ultimately show ?case ..
next
  case (WTTry E e1 T V C e2)
  from \<open>ran E \<subseteq> types P\<close> have "is_lub2,P,E \<turnstile> e1 :: T" by(rule WTTry)
  moreover from \<open>P \<turnstile> C \<preceq>\<^sup>* Throwable\<close> have "is_class P C"
    by(rule is_class_sub_Throwable[OF wf])
  with \<open>ran E \<subseteq> types P\<close> have "ran (E(V \<mapsto> Class C)) \<subseteq> types P"
    by(auto simp add: ran_def)
  hence "is_lub2,P,E(V \<mapsto> Class C) \<turnstile> e2 :: T" by(rule WTTry)
  ultimately show ?case using \<open>P \<turnstile> C \<preceq>\<^sup>* Throwable\<close> ..
qed auto

subsection \<open>Code generator setup\<close>

lemma WTBlock_code:
  "\<And>is_lub. \<lbrakk> is_type P T; is_lub,P,E(V \<mapsto> T) \<turnstile> e :: T';
     case vo of None \<Rightarrow> True | \<lfloor>v\<rfloor> \<Rightarrow> case typeof v of None \<Rightarrow> False | Some T' \<Rightarrow> P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> {V:T=vo; e} :: T'"
by(auto)

lemmas [code_pred_intro] =
  WTNew WTNewArray WTCast WTInstanceOf WTVal WTVar WTBinOp WTLAss WTAAcc WTAAss WTALength WTFAcc WTFAss WTCAS WTCall
declare
  WTBlock_code [code_pred_intro WTBlock']
lemmas [code_pred_intro] =
  WTSynchronized WTSeq WTCond WTWhile WTThrow WTTry
  WTNil WTCons

code_pred
  (modes:
    (i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
    (i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  [detect_switches, skip_proof]
  WT
proof -
  case WT
  from WT.prems show thesis
  proof cases
    case (WTBlock T V e vo)
    thus thesis using WT.WTBlock'[OF refl refl refl, of V T vo e] by(auto)
  qed(assumption|erule WT.that[OF refl refl refl]|rule refl)+
next
  case WTs
  from WTs.prems WTs.that show thesis by cases blast+
qed

inductive is_lub_sup :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool"
for P T1 T2 T3
where
  "sup P T1 T2 = OK T3 \<Longrightarrow> is_lub_sup P T1 T2 T3"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  is_lub_sup
.

definition WT_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> ty \<Rightarrow> bool" ("_,_ \<turnstile> _ ::'' _" [51,51,51] 50)
where "WT_code P \<equiv> WT (is_lub_sup P) P"

definition WTs_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> ty list \<Rightarrow> bool" ("_,_ \<turnstile> _ [::''] _" [51,51,51] 50)
where "WTs_code P \<equiv> WTs (is_lub_sup P) P"

lemma assumes wf: "wf_prog wf_md P"
  shows WT_code_into_WT:
  "\<lbrakk> P,E \<turnstile> e ::' T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> e :: T"

  and WTs_code_into_WTs:
  "\<lbrakk> P,E \<turnstile> es [::'] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> es [::] Ts"
proof -
  assume ran: "ran E \<subseteq> types P"
  { assume wt: "P,E \<turnstile> e ::' T"
    show "P,E \<turnstile> e :: T"
      by(rule WT_change_is_lub[OF wf _ _ wt[unfolded WT_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
  { assume wts: "P,E \<turnstile> es [::'] Ts"
    show "P,E \<turnstile> es [::] Ts"
      by(rule WTs_change_is_lub[OF wf _ _ wts[unfolded WTs_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
qed

lemma assumes wf: "wf_prog wf_md P"
  shows WT_into_WT_code:
  "\<lbrakk> P,E \<turnstile> e :: T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> e ::' T"

  and WT_into_WTs_code_OK:
  "\<lbrakk> P,E \<turnstile> es [::] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> es [::'] Ts"
proof -
  assume ran: "ran E \<subseteq> types P"
  { assume wt: "P,E \<turnstile> e :: T"
    show "P,E \<turnstile> e ::' T" unfolding WT_code_def
      by(rule WT_change_is_lub[OF wf _ _ wt ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
  { assume wts: "P,E \<turnstile> es [::] Ts"
    show "P,E \<turnstile> es [::'] Ts" unfolding WTs_code_def
      by(rule WTs_change_is_lub[OF wf _ _ wts ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
qed

theorem WT_eq_WT_code:
  assumes "wf_prog wf_md P"
  and "ran E \<subseteq> types P"
  shows "P,E \<turnstile> e :: T \<longleftrightarrow> P,E \<turnstile> e ::' T"
using assms by(blast intro: WT_code_into_WT WT_into_WT_code)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  WT_code
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  WTs_code
.

end


theory sas_analysis
imports "sas" "DFP.DFP_law_DFtick"
begin

declare inj_def [simp add]
declare Let_def [simp add]

declare Rec_prefix_def [simp add]
declare Send_prefix_def [simp add]

lemma rawPosition_Int_adjust_eq_empty [simp]: "{| rawPosition i |}\<^sub>c \<inter> {| adjust i |}\<^sub>c = {}"
  by (auto)

lemma rawPosition_Int_servoCmd_eq_empty [simp]: "{| rawPosition i |}\<^sub>c \<inter> {| servoCmd i |}\<^sub>c = {}"
  by (auto)

lemma adjust_DONT_Renames_rawPosition [simp]: "a \<in> {| rawPosition i |}\<^sub>c \<Longrightarrow>
       {x::Events \<in> {| rawPosition i |}\<^sub>c.
                      (x, a) \<in> ehsvOutput i<==adjust i} = { a }"
  apply (simp add: Renaming2_channel_def Renaming2_channel_fun_def fun_to_rel_def Image_def)
  by (auto)

lemma adjust_DONT_Renames_servoCmd [simp]: "a \<in> {| servoCmd i |}\<^sub>c \<Longrightarrow>
       {x::Events \<in> {| servoCmd i |}\<^sub>c.
                      (x, a) \<in> ehsvOutput i<==adjust i} = { a }"
  apply (simp add: Renaming2_channel_def Renaming2_channel_fun_def fun_to_rel_def Image_def)
  by (auto)

lemma unwind_EHSV : "$EHSV i [[ ehsvOutput i <== adjust i ]] =F
            ? p:{| rawPosition(i) |}\<^sub>c -> ? e:{| servoCmd(i) |}\<^sub>c -> ? f:{ adjust(i) ((inv (rawPosition i) p) - disp (dOmega (inv (servoCmd i) e))) } -> $EHSV i [[ ehsvOutput i <== adjust i ]]"
  apply (cspF_unwind_left, simp_all, cspF_ren_left)
  by (rule cspF_decompo, simp, cspF_step_left, cspF_step_left, cspF_ren_left)+

lemma unwind_Raw : "$Raw i p0 =F ? p:{ rawPosition(i) p0 } -> (? p:{ rawPosition(i) p0 } -> $Raw i p0
                                                               [+] (? adj:{| adjust(i) |}\<^sub>c \<rightarrow> $Raw i (saturate (p0 + (inv (adjust i) adj))) ))
                                 [+] (? adj:{| adjust(i) |}\<^sub>c \<rightarrow> $Raw i (saturate (p0 + (inv (adjust i) adj))) )"
  apply (cspF_unwind_left, cspF_hsf_left)
  apply (rule cspF_decompo, simp)
  apply (rule cspF_decompo, simp)
  by (cspF_unwind_left)

lemma feedbackPos_DONT_Renames_rawPosition [simp]: "a \<in> {| rawPosition i |}\<^sub>c \<Longrightarrow>
       {x::Events \<in> {| rawPosition i |}\<^sub>c.
                      (x, a) \<in> lvdtOutput i<==feedbackPos i} = { a }"
  apply (simp add: Renaming2_channel_def Renaming2_channel_fun_def fun_to_rel_def Image_def)
  by (auto)

lemma rawPosition_Renaming_coreMoved_simp [simp]: "a \<in> {| rawPosition i |}\<^sub>c \<Longrightarrow>
       {x::Events \<in> {| coreMoved i |}\<^sub>c.
                      (x, a) \<in> coreMoved i<==rawPosition i} = { coreMoved i (inv (rawPosition i) a) }"
  apply (simp add: Renaming2_channel_def Renaming2_channel_fun_def fun_to_rel_def Image_def)
  by (auto)

lemma unwind_LVDT : "$LVDT i [[coreMoved i<==rawPosition i]] [[lvdtOutput i<==feedbackPos i]] =F
            ? p:{| rawPosition(i) |}\<^sub>c \<rightarrow> ? f:{ feedbackPos i (inv (rawPosition i) p) } \<rightarrow> $LVDT i [[ coreMoved i <== rawPosition i ]] [[ lvdtOutput i <== feedbackPos i ]]"
  apply (cspF_unwind_left, cspF_step_left, cspF_step_left)
  apply (rule cspF_decompo, simp, erule rangeE)
  by (cspF_step_left)+

lemma unwind_PCU : "PCU i p0 =F (
              ? p:{| rawPosition(i) |}\<^sub>c -> ? e:{| servoCmd(i) |}\<^sub>c -> ? f:{ adjust(i) ((inv (rawPosition i) p) - disp (dOmega (inv (servoCmd i) e))) } -> $EHSV i [[ ehsvOutput i <== adjust i ]]
              |[ {| rawPosition i, adjust i |}\<^sub>c ]|
              ( ? p:{ rawPosition(i) p0 } -> (? p:{ rawPosition(i) p0 } -> $Raw i p0
                                        [+] (? adj:{| adjust(i) |}\<^sub>c \<rightarrow> $Raw i (saturate (p0 + (inv (adjust i) adj))) ))
                [+] (? adj:{| adjust(i) |}\<^sub>c \<rightarrow> $Raw i (saturate (p0 + (inv (adjust i) adj))) ))
            )
            |[ {| rawPosition i |}\<^sub>c ]|
            ( ? p:{| rawPosition(i) |}\<^sub>c \<rightarrow> (? f:{ feedbackPos(i) (modulate (senseVoltage (inv (rawPosition i) p))) } -> ($LVDT i [[ coreMoved i <== rawPosition i ]] [[ lvdtOutput i <== feedbackPos i ]])) )"

  apply (simp add: PCU_def)
  apply (rule cspF_decompo, simp)
  apply (rule cspF_decompo, simp)
  apply (rule unwind_EHSV)
  apply (rule unwind_Raw)
  apply (rule unwind_LVDT)
  done

lemma unwind_ACE : "$ACE i =F (? p:{| controlCmd(i) |}\<^sub>c -> ? f:{| feedbackPos(i) |}\<^sub>c ->
                              ? x:{ servoCmd(i) (saturate((inv (controlCmd i) p) - (inv (feedbackPos i) f))) } -> $ACE i)"
  by (cspF_auto)

lemma unwind_ACE_PCU :
    "ACE_PCU i p0 =F
            (? p:{| controlCmd(i) |}\<^sub>c -> ? f:{| feedbackPos(i) |}\<^sub>c ->
                              ? x:{ servoCmd(i) (saturate((inv (controlCmd i) p) - (inv (feedbackPos i) f))) } -> $ACE i)
            |[ {| servoCmd i, feedbackPos i |}\<^sub>c ]|
            ((? p:{| rawPosition(i) |}\<^sub>c -> ? e:{| servoCmd(i) |}\<^sub>c -> ? f:{ adjust(i) ((inv (rawPosition i) p) - disp (dOmega (inv (servoCmd i) e))) } -> $EHSV i [[ ehsvOutput i <== adjust i ]]
              |[ {| rawPosition i, adjust i |}\<^sub>c ]|
              ( ? p:{ rawPosition(i) p0 } -> (? p:{ rawPosition(i) p0 } -> $Raw i p0
                                        [+] (? adj:{| adjust(i) |}\<^sub>c \<rightarrow> $Raw i (saturate (p0 + (inv (adjust i) adj))) ))
                [+] (? adj:{| adjust(i) |}\<^sub>c \<rightarrow> $Raw i (saturate (p0 + (inv (adjust i) adj))) ))
             )
             |[ {| rawPosition i |}\<^sub>c ]|
             ( ? p:{| rawPosition(i) |}\<^sub>c \<rightarrow> (? f:{ feedbackPos(i) (modulate (senseVoltage (inv (rawPosition i) p))) } -> ($LVDT i [[ coreMoved i <== rawPosition i ]] [[ lvdtOutput i <== feedbackPos i ]])) ))"

  apply (simp add: ACE_PCU_def)
  apply (rule cspF_rw_left, rule cspF_decompo, simp, rule unwind_ACE)
  apply (rule unwind_PCU)
  by (cspF_hsf)

definition PCUadj
where "PCUadj i aa adj ==
       ? x:{adjust i adj}
        -> ( ($EHSV i [[ehsvOutput i<==adjust i]]
             |[{| rawPosition i, adjust i |}\<^sub>c]|
             $Raw i (saturate (aa + inv (adjust i) x))
             |[{| rawPosition i |}\<^sub>c]|
             $LVDT i [[coreMoved i<==rawPosition i]] [[lvdtOutput i<==feedbackPos i]]))"

definition ACE_PCUadj
where "ACE_PCUadj i aa adj == $ACE i |[{| servoCmd i, feedbackPos i |}\<^sub>c]| PCUadj i aa adj"

lemma unwind_ACE_PCUadj :
    "$ACE i |[{| servoCmd i, feedbackPos i |}\<^sub>c]| PCUadj i aa adj =F
       (? p:{| controlCmd(i) |}\<^sub>c -> ? f:{| feedbackPos(i) |}\<^sub>c ->
                              ? x:{ servoCmd(i) (saturate((inv (controlCmd i) p) - (inv (feedbackPos i) f))) } -> $ACE i)
       |[{| servoCmd i, feedbackPos i |}\<^sub>c]|
       ? x:{adjust i adj} -> (($EHSV i [[ehsvOutput i<==adjust i]]
                             |[{| rawPosition i, adjust i |}\<^sub>c]|
                             $Raw i (saturate (aa + inv (adjust i) x))
                             |[{| rawPosition i |}\<^sub>c]|
                             $LVDT i [[coreMoved i<==rawPosition i]] [[lvdtOutput i<==feedbackPos i]]))"

  apply (rule cspF_decompo, simp)
  apply (rule unwind_ACE)
  apply (simp add: PCUadj_def)
  done

declare inj_def [simp del]
declare Let_def [simp del]

declare Rec_prefix_def [simp del]
declare Send_prefix_def [simp del]

end


theory Proc1
imports "../SPARK"
begin

spark_open "loop_invariant/proc1"

spark_vc procedure_proc1_5
  by (simp add: ring_distribs pull_mods)

spark_vc procedure_proc1_8
  by (simp add: ring_distribs pull_mods)

spark_end

lemma pow_2_32_simp: "4294967296 = (2::int)^32"
  by simp

end


theory Review_RAut_NCPC_PAut
imports "../Observation_Setup" Review_Value_Setup "Bounded_Deducibility_Security.Compositional_Reasoning"
begin

subsection \<open>Confidentiality from users who are not the review's author, a PC member, or an author of the paper\<close>

text \<open>We verify the following property:

\ \\
A group of users UIDs learn nothing
about the various updates to the N'th review of a paper PID
(save for the inexistence of any updates) unless/until
\begin{itemize}
\item a user in UIDs is the review's author, or
\item a user in UIDs becomes a PC member in the paper's conference
having no conflict with that paper and the
conference moves to the discussion phase, or
\item a user in UIDs become a PC member in the paper's conference
or an author of the paper and the conference moves to the notification phase
\end{itemize}
\<close>

type_synonym "value" = rcontent

fun f :: "(state,act,out) trans \<Rightarrow> value" where
"f (Trans _ (Uact (uReview cid uid p pid n rc)) _ _) = rc"
|
"f (Trans _ (UUact (uuReview cid uid p pid n rc)) _ _) = rc"

fun T :: "(state,act,out) trans \<Rightarrow> bool" where
"T (Trans _ _ ou s') =
 (\<exists> uid \<in> UIDs.
    isREVNth s' uid PID N
    \<or>
    (\<exists> cid. PID \<in>\<in> paperIDs s' cid \<and> isPC s' cid uid \<and> pref s' uid PID \<noteq> Conflict \<and> phase s' cid \<ge> disPH)
    \<or>
    (\<exists> cid. PID \<in>\<in> paperIDs s' cid \<and> isPC s' cid uid \<and> phase s' cid \<ge> notifPH)
    \<or>
    isAUT s' uid PID \<and> (\<exists> cid. PID \<in>\<in> paperIDs s' cid \<and> phase s' cid \<ge> notifPH)
 )"

declare T.simps [simp del]

definition B :: "value list \<Rightarrow> value list \<Rightarrow> bool" where
"B vl vl1 \<equiv> vl \<noteq> []"

interpretation BD_Security_IO where
istate = istate and step = step and
\<phi> = \<phi> and f = f and \<gamma> = \<gamma> and g = g and T = T and B = B
done

lemma reachNT_non_isPC_isChair:
assumes "reachNT s" and "uid \<in> UIDs"
shows
"\<not> isRevNth s cid uid PID N \<and>
 (PID \<in>\<in> paperIDs s cid \<and> isPC s cid uid \<longrightarrow>
    (pref s uid PID = Conflict \<or> phase s cid < disPH) \<and> phase s cid < notifPH) \<and>
 (PID \<in>\<in> paperIDs s cid \<and> isChair s cid uid \<longrightarrow>
    (pref s uid PID = Conflict \<or> phase s cid < disPH) \<and> phase s cid < notifPH) \<and>
 (isAut s cid uid PID \<longrightarrow> phase s cid < notifPH)"
using assms apply induct
apply (auto simp: istate_def)[]
apply(intro conjI)
  subgoal for trn apply(cases trn, simp add: T.simps reachNT_reach isAUT_def isREVNth_def)[] .
  subgoal for trn apply(cases trn, simp add: T.simps reachNT_reach isAUT_def isREVNth_def)[]
    apply (metis not_less) .
  subgoal for trn apply(cases trn, simp add: T.simps reachNT_reach isAUT_def isREVNth_def)[]
    apply (metis isChair_isPC not_less reachNT_reach reach_PairI) .
  subgoal for trn apply(cases trn, simp add: T.simps reachNT_reach isAUT_def isREVNth_def)[]
    apply (metis isAut_paperIDs not_less reachNT_reach reach_PairI) .
done

lemma T_\<phi>_\<gamma>:
assumes 1: "reachNT s" and 2: "step s a = (ou,s')" "\<phi> (Trans s a ou s')"
shows "\<not> \<gamma> (Trans s a ou s')"
using reachNT_non_isPC_isChair[OF 1] 2 unfolding T.simps \<phi>_def2
apply (auto simp: u_defs uu_defs isRev_imp_isRevNth_getReviewIndex)
by (metis isRev_imp_isRevNth_getReviewIndex)+

(* major *) lemma eqExcPID_N_step_out:
assumes s's1': "eqExcPID_N s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and sT: "reachNT s" and s1: "reach s1"
and PID: "PID \<in>\<in> paperIDs s cid"
and UIDs: "userOfA a \<in> UIDs"
shows "ou = ou1"
proof-
  note s = reachNT_reach[OF sT]
  note Inv = reachNT_non_isPC_isChair[OF sT UIDs]
  note eqs = eqExcPID_N_imp[OF s's1']
  note eqs' = eqExcPID_N_imp1[OF s's1']
  note eqss = eqExcPID_N_imp2[OF s's1'] eqExcPID_N_imp3'[OF s s's1']

  note simps[simp] = c_defs u_defs uu_defs r_defs l_defs Paper_dest_conv eqExcPID_N_def eeqExcPID_N_def eqExcD
  note * = step step1 eqs eqs' eqss s s1 UIDs PID paperIDs_equals[OF s] Inv

  show ?thesis
  proof (cases a)
    case (Cact x1)
    with * show ?thesis by (cases x1; auto)
  next
    case (Uact x2)
    with * show ?thesis by (cases x2; auto)
  next
    case (UUact x3)
    with * show ?thesis by (cases x3; auto)
  next
    case (Ract x4)
    with * show ?thesis
    proof (cases x4)
      case (rMyReview x81 x82 x83 x84)
      with Ract * show ?thesis
        by clarsimp (metis getRevRole_Some_Rev_isRevNth)
    next
      case (rReviews x91 x92 x93 x94)
      with Ract * show ?thesis
        by clarsimp (metis not_less)
    next
      case (rFinalReviews x121 x122 x123 x124)
      with Ract * show ?thesis
        by clarsimp (metis not_less)
    qed auto
  next
    case (Lact x5)
    with * show ?thesis by (cases x5; auto; presburger)
  qed
qed

definition \<Delta>1 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>1 s vl s1 vl1 \<equiv>
 (\<forall> cid. PID \<in>\<in> paperIDs s cid \<longrightarrow> phase s cid < revPH) \<and> s = s1 \<and> B vl vl1"

definition \<Delta>2 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>2 s vl s1 vl1 \<equiv>
 \<exists> cid.
   PID \<in>\<in> paperIDs s cid \<and> phase s cid = revPH \<and>
   \<not> (\<exists> uid. isREVNth s uid PID N) \<and>
   s = s1 \<and> B vl vl1"

(* Note: In the similar property from discussion confidentiality we have only 3 non-exit phases
instead of 4, not having a phase like \<Delta>2: this is because there the agent affecting the documents (chairs),
must have been assigned in a previous phase; here reviewers are assigned in the same phase
in which they can edit.   *)

definition \<Delta>3 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>3 s vl s1 vl1 \<equiv>
 \<exists> cid uid. PID \<in>\<in> paperIDs s cid \<and> phase s cid = revPH \<and> isREVNth s uid PID N \<and> eqExcPID_N s s1"

definition \<Delta>4 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>4 s vl s1 vl1 \<equiv>
 \<exists> cid. PID \<in>\<in> paperIDs s cid \<and> phase s cid > revPH \<and> eqExcPID_N s s1 \<and> vl1 = []"

definition \<Delta>e :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>e s vl s1 vl1 \<equiv>
 vl \<noteq> [] \<and>
 (\<exists> cid. PID \<in>\<in> paperIDs s cid \<and> phase s cid > revPH \<and> \<not> (\<exists> uid. isREVNth s uid PID N))"

lemma istate_\<Delta>1:
assumes B: "B vl vl1"
shows "\<Delta>1 istate vl istate vl1"
using B unfolding \<Delta>1_def B_def istate_def by auto

lemma unwind_cont_\<Delta>1: "unwind_cont \<Delta>1 {\<Delta>1,\<Delta>2,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>1 s vl s1 vl1 \<or> \<Delta>2 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>1 s vl s1 vl1"
  hence rs: "reach s" and ss1: "s1 = s" and vl: "vl \<noteq> []"
  and PID_ph: "\<And> cid. PID \<in>\<in> paperIDs s cid \<Longrightarrow> phase s cid < revPH"
  using reachNT_reach unfolding \<Delta>1_def B_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have \<phi>: "\<not> \<phi> ?trn"
        apply(cases a)
        subgoal by simp
        subgoal for x2 apply(cases x2) using step PID_ph by (fastforce simp: u_defs)+
        subgoal for x3 apply(cases x3) using step PID_ph by (fastforce simp: uu_defs)+
        by simp_all
      hence vl': "vl' = vl" using c unfolding consume_def by auto
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof-
        have ?match proof
          show "validTrans ?trn1" unfolding ss1 using step by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def ss1 using \<phi> by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
        next
          show "?\<Delta> s' vl' s' vl1"
          proof(cases "\<exists> cid. PID \<in>\<in> paperIDs s cid")
            case False note PID = False
            have PID_ph': "\<And> cid. PID \<in>\<in> paperIDs s' cid \<Longrightarrow> phase s' cid < revPH" using PID step rs
            apply(cases a)
              subgoal for _ x1 apply(cases x1) apply(fastforce simp: c_defs)+ .
              subgoal for _ x2 apply(cases x2) apply(fastforce simp: u_defs)+ .
              subgoal for _ x3 apply(cases x3) apply(fastforce simp: uu_defs)+ .
              by auto
            hence "\<Delta>1 s' vl' s' vl1" unfolding \<Delta>1_def B_def vl' using PID_ph' vl by auto
            thus ?thesis by auto
          next
            case True
            then obtain CID where PID: "PID \<in>\<in> paperIDs s CID" by auto
            hence ph: "phase s CID < revPH" using PID_ph by auto
            have PID': "PID \<in>\<in> paperIDs s' CID" by (metis PID paperIDs_mono step)
            show ?thesis
            proof(cases "phase s' CID < revPH")
              case True note ph' = True
              hence "\<Delta>1 s' vl' s' vl1" unfolding \<Delta>1_def B_def vl' using vl ph' PID' apply auto
              by (metis reach_PairI paperIDs_equals rs step)
              thus ?thesis by auto
            next
              case False note ph' = False
              have "\<not> (\<exists> uid. isRevNth s CID uid PID N)" using rs ph isRevNth_geq_revPH by fastforce
              hence ph_isRev': "phase s' CID = revPH \<and> \<not> (\<exists> uid. isRevNth s' CID uid PID N)"
              using ph' ph PID step rs
              apply(cases a)
                subgoal for x1 apply(cases x1) apply(fastforce simp: c_defs)+ .
                subgoal for x2 apply(cases x2) apply(fastforce simp: u_defs)+ .
                subgoal for x3 apply(cases x3) apply(fastforce simp: uu_defs)+ .
              by auto
              hence "\<not> (\<exists> uid. isREVNth s' uid PID N)"
              by (metis PID' isREVNth_imp_isRevNth reach_PairI rs1 ss1 step)
              hence "\<Delta>2 s' vl' s' vl1"
              unfolding \<Delta>2_def B_def isREVNth_def vl' using vl ph' PID' ph_isRev' by auto
              thus ?thesis by auto
            qed
          qed
        qed
        thus ?thesis by simp
      qed
    qed
    thus ?thesis using vl by auto
  qed
qed

lemma unwind_cont_\<Delta>2: "unwind_cont \<Delta>2 {\<Delta>2,\<Delta>3,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>2 s vl s1 vl1 \<or> \<Delta>3 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>2 s vl s1 vl1"
  then obtain CID where rs: "reach s" and ph: "phase s CID = revPH" (is "?ph = _")
  and PID: "PID \<in>\<in> paperIDs s CID" and ss1: "s1 = s"
  and vl: "vl \<noteq> []" and uid: "\<not> (\<exists> uid. isREVNth s uid PID N)"
  using reachNT_reach unfolding \<Delta>2_def B_def by auto
  hence uid: "\<not> (\<exists> uid. isRevNth s CID uid PID N)" by (metis isREVNth_def)
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      let ?ph' = "phase s' CID"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have \<phi>: "\<not> \<phi> ?trn"
        apply(cases a)
        subgoal by simp
        subgoal for x2 apply(cases x2)
          using step ph uid apply (auto simp: u_defs isRev_def3)
          by (metis PID paperIDs_equals rs)
        subgoal for x3 apply(cases x3)
          using step ph apply (auto simp: uu_defs)
          by (metis PID n_not_Suc_n paperIDs_equals rs)
        by simp_all
      hence vl': "vl' = vl" using c unfolding consume_def by auto
      have PID': "PID \<in>\<in> paperIDs s' CID" by (metis paperIDs_mono step PID)
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof-
        have ?match proof
          show "validTrans ?trn1" unfolding ss1 using step by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def ss1 using \<phi> by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1" unfolding ss1 by simp
        next
          show "?\<Delta> s' vl' s' vl1"
          proof(cases "?ph' = revPH")
            case True note ph' = True
            show ?thesis
            proof(cases "\<exists> uid. isRevNth s' CID uid PID N")
              case False
              hence "\<not> (\<exists> uid. isREVNth s' uid PID N)"
              by (metis reach_PairI PID' isREVNth_imp_isRevNth rs1 ss1 step)
              hence "\<Delta>2 s' vl' s' vl1" unfolding \<Delta>2_def B_def vl' using vl ph' PID' by auto
              thus ?thesis by auto
            next
              case True  hence "\<exists> uid. isREVNth s' uid PID N" by (metis isREVNth_def)
              hence "\<Delta>3 s' vl' s' vl1" unfolding \<Delta>3_def vl' using vl ph' PID' by auto
              thus ?thesis by auto
            qed
          next
            case False hence 1: "?ph' > revPH \<and> \<not> (\<exists> uid. isRevNth s' CID uid PID N)"
              using PID ph uid step rs
              apply(cases a)
              subgoal for x1 apply(cases x1) apply(fastforce simp: c_defs)+ .
              subgoal for x2 apply(cases x2) apply(fastforce simp: u_defs)+ .
              subgoal for x3 apply(cases x3) apply(fastforce simp: uu_defs)+ .
              by auto
            hence "\<not> (\<exists> uid. isREVNth s' uid PID N)"
            by (metis reach_PairI PID' isREVNth_imp_isRevNth rs1 ss1 step)
            hence "\<Delta>e s' vl' s' vl1" unfolding \<Delta>e_def vl' using vl PID' 1 by auto
            thus ?thesis by auto
          qed
        qed
        thus ?thesis by simp
      qed
    qed
    thus ?thesis using vl by simp
  qed
qed

lemma unwind_cont_\<Delta>3: "unwind_cont \<Delta>3 {\<Delta>3,\<Delta>4,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>3 s vl s1 vl1 \<or> \<Delta>4 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>3 s vl s1 vl1"
  then obtain CID uid where uuid: "isREVNth s uid PID N"
  and rs: "reach s" and ph: "phase s CID = revPH" (is "?ph = _") and ss1: "eqExcPID_N s s1"
  and PID: "PID \<in>\<in> paperIDs s CID" using reachNT_reach unfolding \<Delta>3_def by blast
  hence uid: "isRevNth s CID uid PID N" by (metis isREVNth_imp_isRevNth)
  hence uid_notin: "uid \<notin> UIDs" using reachNT_non_isPC_isChair[OF rsT] by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof(cases vl1)
    case (Cons v1 vl1') note vl1 = Cons
    have uid1: "isRevNth s CID uid PID N" using ss1 uid unfolding eqExcPID_N_def by auto
    define a1 where "a1 \<equiv> Uact (uReview CID uid (pass s uid) PID N v1)"
    obtain s1' ou1 where step1: "step s1 a1 = (ou1,s1')" by (metis prod.exhaust)
    let ?trn1 = "Trans s1 a1 ou1 s1'"
    have s1s1': "eqExcPID_N s1 s1'" using a1_def step1 uReview_uuReview_step_eqExcPID_N by blast
    have ss1': "eqExcPID_N s s1'" using eqExcPID_N_trans[OF ss1 s1s1'] .
    hence many_s1': "PID \<in>\<in> paperIDs s1' CID" "isRevNth s1' CID uid PID N"
    "phase s1' CID = revPH" "pass s1' uid = pass s uid"
    using uid PID ph unfolding eqExcPID_N_def by auto
    hence more_s1': "uid \<in>\<in> userIDs s1'" "CID \<in>\<in> confIDs s1'"
    by (metis paperIDs_confIDs reach_PairI roles_userIDs rs1 step1 many_s1'(1))+
    have f: "f ?trn1 = v1" unfolding a1_def by simp
    have rs1': "reach s1'" using rs1 step1 by (auto intro: reach_PairI)
    have ou1: "ou1 = outOK"
    using step1 uid1 ph unfolding a1_def apply ( simp add: u_defs uu_defs many_s1' more_s1' isRev_def2)
    by (metis isRevNth_getReviewIndex many_s1' rs1)
    have ?iact proof
      show "step s1 a1 = (ou1,s1')" by fact
    next
      show \<phi>: "\<phi> ?trn1" using ou1 unfolding a1_def by simp
      thus "consume ?trn1 vl1 vl1'" using f unfolding consume_def vl1 by simp
    next
      show "\<not> \<gamma> ?trn1" by (simp add: a1_def uid_notin)
    next
      have "\<Delta>3 s vl s1' vl1'" unfolding \<Delta>3_def using ph PID ss1' uuid by auto
      thus "?\<Delta> s vl s1' vl1'" by simp
    qed
    thus ?thesis by auto
  next
    case Nil note vl1 = Nil
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      let ?ph' = "phase s' CID"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID \<in>\<in> paperIDs s' CID" using PID rs by (metis paperIDs_mono step)
      have uid': "isRevNth s' CID uid PID N"
      using uid step rs ph PID isRevNth_persistent by auto
      have uuid': "isREVNth s' uid PID N" by (metis isREVNth_def uid')
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof(cases "\<phi> ?trn")
        case False note \<phi> = False
        have vl: "vl' = vl" using c \<phi> unfolding consume_def by (cases vl) auto
        obtain ou1 and s1' where step1: "step s1 a = (ou1,s1')" by (metis prod.exhaust)
        let ?trn1 = "Trans s1 a ou1 s1'"
        have s's1': "eqExcPID_N s' s1'" using eqExcPID_N_step[OF ss1 step step1] .
        have \<phi>1: "\<not> \<phi> ?trn1" using \<phi> unfolding eqExcPID_N_step_\<phi>[OF ss1 step step1] .
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def using \<phi>1 by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1"
          using eqExcPID_N_step_out[OF ss1 step step1 rsT rs1 PID] by simp
        next
          show "?\<Delta> s' vl' s1' vl1"
          proof(cases "?ph' = revPH")
            case True
            hence "\<Delta>3 s' vl' s1' vl1" using PID' s's1' uuid' unfolding \<Delta>3_def by auto
            thus ?thesis by auto
          next
            case False hence "?ph' > revPH"
            using ph rs step by (metis le_less phase_increases2 prod.sel(2))
            hence "\<Delta>4 s' vl' s1' vl1" using s's1' PID' unfolding \<Delta>4_def vl1 by auto
            thus ?thesis by auto
          qed
        qed
        thus ?thesis by simp
      next
        case True note \<phi> = True
        have s's: "eqExcPID_N s' s" using eqExcPID_N_sym[OF \<phi>_step_eqExcPID_N[OF \<phi> step]] .
        have s's1: "eqExcPID_N s' s1" using eqExcPID_N_trans[OF s's ss1] .
        have ?ignore proof
          show "\<not> \<gamma> ?trn" using T_\<phi>_\<gamma> \<phi> rsT step by auto
        next
          show "?\<Delta> s' vl' s1 vl1"
          proof(cases "?ph' = revPH")
            case True
            hence "\<Delta>3 s' vl' s1 vl1" using s's1 PID' uuid' unfolding \<Delta>3_def by auto
            thus ?thesis by auto
          next
            case False hence "?ph' > revPH"
            using ph rs step using eqExcPID_N_def s's by auto
            hence "\<Delta>4 s' vl' s1 vl1" using s's1 PID' unfolding \<Delta>4_def vl1 by auto
            thus ?thesis by auto
          qed
        qed
        thus ?thesis by auto
      qed
    qed
    thus ?thesis using vl1 by auto
  qed
qed

lemma unwind_cont_\<Delta>4: "unwind_cont \<Delta>4 {\<Delta>4,\<Delta>e}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>4 s vl s1 vl1 \<or> \<Delta>e s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and "\<Delta>4 s vl s1 vl1"
  then obtain CID where rs: "reach s" and ph: "phase s CID > revPH" (is "?ph > _")
  and PID: "PID \<in>\<in> paperIDs s CID" and ss1: "eqExcPID_N s s1" and vl1: "vl1 = []"
  using reachNT_reach unfolding \<Delta>4_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof-
    have "?react"
    proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      let ?ph' = "phase s' CID"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      have PID': "PID \<in>\<in> paperIDs s' CID" using PID rs by (metis paperIDs_mono step)
      have ph': "phase s' CID > revPH" using ph rs by (meson less_le_trans local.step phase_increases)
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof(cases "\<phi> ?trn")
        case False note \<phi> = False
        have vl: "vl' = vl" using c \<phi> unfolding consume_def by (cases vl) auto
        obtain ou1 and s1' where step1: "step s1 a = (ou1,s1')" by (metis prod.exhaust)
        let ?trn1 = "Trans s1 a ou1 s1'"
        have s's1': "eqExcPID_N s' s1'" using eqExcPID_N_step[OF ss1 step step1] .
        have \<phi>1: "\<not> \<phi> ?trn1" using \<phi> unfolding eqExcPID_N_step_\<phi>[OF ss1 step step1] .
        have ?match proof
          show "validTrans ?trn1" using step1 by simp
        next
          show "consume ?trn1 vl1 vl1" unfolding consume_def using \<phi>1 by auto
        next
          show "\<gamma> ?trn = \<gamma> ?trn1" unfolding ss1 by simp
        next
          assume "\<gamma> ?trn" thus "g ?trn = g ?trn1"
          using eqExcPID_N_step_out[OF ss1 step step1 rsT rs1 PID] by simp
        next
          have "\<Delta>4 s' vl' s1' vl1" using ph' PID' s's1' unfolding \<Delta>4_def vl1 by auto
          thus "?\<Delta> s' vl' s1' vl1" by simp
        qed
        thus ?thesis by simp
      next
        case True note \<phi> = True
        have s's: "eqExcPID_N s' s" using eqExcPID_N_sym[OF \<phi>_step_eqExcPID_N[OF \<phi> step]] .
        have s's1: "eqExcPID_N s' s1" using eqExcPID_N_trans[OF s's ss1] .
        have ?ignore proof
          show "\<not> \<gamma> ?trn" using T_\<phi>_\<gamma> \<phi> rsT step by auto
        next
          have "\<Delta>4 s' vl' s1 vl1" using s's1 PID' ph' vl1 unfolding \<Delta>4_def by auto
          thus "?\<Delta> s' vl' s1 vl1" by auto
        qed
        thus ?thesis by simp
      qed
    qed
    thus ?thesis using vl1 by simp
  qed
qed

(* Exit arguments: *)
definition K1exit where
"K1exit cid s \<equiv> PID \<in>\<in> paperIDs s cid \<and> phase s cid > revPH \<and> \<not> (\<exists> uid. isRevNth s cid uid PID N)"

lemma invarNT_K1exit: "invarNT (K1exit cid)"
unfolding invarNT_def apply (safe dest!: reachNT_reach)
  subgoal for _ a apply(cases a)
    subgoal for x1 apply(cases x1) apply (fastforce simp add: c_defs K1exit_def geq_noPH_confIDs)+ .
    subgoal for x2 apply(cases x2) apply (fastforce simp add: u_defs K1exit_def paperIDs_equals)+ .
    subgoal for x3 apply(cases x3) apply (fastforce simp add: uu_defs K1exit_def)+ .
    by auto
  done

lemma noVal_K1exit: "noVal (K1exit cid) v"
apply(rule no\<phi>_noVal)
unfolding no\<phi>_def apply safe
  subgoal for _ a apply(cases a)
    subgoal by (fastforce simp add: c_defs K1exit_def)
    subgoal for x2 apply(cases x2) apply (auto simp add: u_defs K1exit_def)
      apply (metis less_not_refl paperIDs_equals reachNT_reach) .
    subgoal for x3 apply(cases x3) apply (auto simp add: uu_defs K1exit_def)
      apply (metis isRev_def3 paperIDs_equals reachNT_reach) .
    by auto
  done

lemma unwind_exit_\<Delta>e: "unwind_exit \<Delta>e"
proof
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and \<Delta>e: "\<Delta>e s vl s1 vl1"
  hence vl: "vl \<noteq> []" using reachNT_reach unfolding \<Delta>e_def by auto
  then obtain CID where "K1exit CID s" using \<Delta>e unfolding K1exit_def \<Delta>e_def isREVNth_def by auto
  thus "vl \<noteq> [] \<and> exit s (hd vl)" apply(simp add: vl)
  by (metis rsT exitI2 invarNT_K1exit noVal_K1exit)
qed

theorem secure: secure
apply(rule unwind_decomp4_secure[of \<Delta>1 \<Delta>2 \<Delta>e \<Delta>3 \<Delta>4])
using
istate_\<Delta>1
unwind_cont_\<Delta>1 unwind_cont_\<Delta>2 unwind_cont_\<Delta>3 unwind_cont_\<Delta>4
unwind_exit_\<Delta>e
by auto

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* License: BSD, terms see file ./LICENSE *)

theory ArrayAssertion

imports
  ArchArraysMemInstance
  "StructSupport"

begin

lemma array_tag_n_eq:
  "(array_tag_n n :: ('a :: c_type['b :: finite]) field_desc typ_desc) =
  TypDesc (TypAggregate
    (map (\<lambda>n. DTPair (adjust_ti (typ_info_t TYPE('a)) (\<lambda>x. index x n)
            (\<lambda>x f. Arrays.update f n x)) (replicate n CHR ''1'')) [0..<n]))
  (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @ nat_to_bin_string (card (UNIV :: 'b :: finite set)))"
  apply (induct n)
   apply (simp add: typ_info_array array_tag_def eval_nat_numeral array_tag_n.simps empty_typ_info_def)
   apply (simp add: typ_info_array array_tag_def eval_nat_numeral array_tag_n.simps empty_typ_info_def)
   apply (simp add: ti_typ_combine_def Let_def)
   done

lemma typ_info_array':
  "typ_info_t TYPE ('a :: c_type['b :: finite]) =
  TypDesc (TypAggregate
    (map (\<lambda>n. DTPair (adjust_ti (typ_info_t TYPE('a)) (\<lambda>x. index x n)
            (\<lambda>x f. Arrays.update f n x)) (replicate n CHR ''1'')) [0..<(card (UNIV :: 'b :: finite set))]))
  (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @ nat_to_bin_string (card (UNIV :: 'b :: finite set)))"
  by (simp add: typ_info_array array_tag_def array_tag_n_eq)

definition
  "uinfo_array_tag_n_m (v :: 'a itself) n m = TypDesc
    (TypAggregate (map (\<lambda>i. DTPair (typ_uinfo_t TYPE('a)) (replicate i CHR ''1'')) [0 ..< n]))
    (typ_name (typ_uinfo_t TYPE('a :: c_type)) @ ''_array_'' @ nat_to_bin_string m)"

lemma map_td_list_map:
  "map_td_list f = map (map_td_pair f)"
  by (rule ext, rename_tac x) (induct_tac x, simp_all)

lemma uinfo_array_tag_n_m_eq:
  "n \<le> CARD('b)
    \<Longrightarrow> export_uinfo (array_tag_n n :: (('a :: wf_type)['b :: finite]) field_desc typ_desc)
        = uinfo_array_tag_n_m TYPE ('a) n (CARD('b))"
  apply (clarsimp simp: uinfo_array_tag_n_m_def array_tag_n_eq map_td_list_map
                        o_def adjust_ti_def map_td_map typ_uinfo_t_def export_uinfo_def)
  apply (fastforce intro: map_td_extI simp: field_norm_blah)
  done

lemma typ_uinfo_array_tag_n_m_eq:
  "typ_uinfo_t TYPE (('a :: wf_type)['b :: finite])
        = uinfo_array_tag_n_m TYPE ('a) (CARD('b)) (CARD('b))"
  by (simp add: typ_uinfo_t_def typ_info_array array_tag_def uinfo_array_tag_n_m_eq)

text \<open>Alternative to h_t_valid for arrays. This allows reasoning
about arrays of variable width.\<close>
definition h_t_array_valid :: "heap_typ_desc \<Rightarrow> ('a :: c_type) ptr \<Rightarrow> nat \<Rightarrow> bool" where
  "h_t_array_valid htd ptr n = valid_footprint htd (ptr_val ptr) (uinfo_array_tag_n_m TYPE ('a) n n)"

text \<open>Assertion that pointer p is within an array that continues for at least n more elements.\<close>
definition
  "array_assertion (p :: ('a :: c_type) ptr) n htd
    = (\<exists>q i j. h_t_array_valid htd q j
        \<and> p = CTypesDefs.ptr_add q (int i) \<and> i < j \<and> i + n \<le> j)"

lemma array_assertion_shrink_right:
  "array_assertion p n htd \<Longrightarrow> n' \<le> n \<Longrightarrow> array_assertion p n' htd"
  by (fastforce simp: array_assertion_def)

lemma array_assertion_shrink_leftD:
  "array_assertion p n htd \<Longrightarrow> j < n \<Longrightarrow> array_assertion (CTypesDefs.ptr_add p (int j)) (n - j) htd"
  apply (clarsimp simp: array_assertion_def)
  apply (rule exI, rule_tac x="i + j" in exI, rule exI, erule conjI)
  apply (simp add: CTypesDefs.ptr_add_def field_simps)
  done

lemma array_assertion_shrink_leftI:
  "array_assertion (CTypesDefs.ptr_add p (- (int j))) (n + j) htd
    \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> array_assertion p n htd"
  apply (drule_tac j=j in array_assertion_shrink_leftD, simp)
  apply (simp add: CTypesDefs.ptr_add_def)
  done

lemma h_t_array_valid:
  "h_t_valid htd gd (p :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> h_t_array_valid htd (ptr_coerce p :: 'a ptr) (CARD('b))"
  by (clarsimp simp: h_t_valid_def h_t_array_valid_def typ_uinfo_array_tag_n_m_eq)

lemma array_ptr_valid_array_assertionD:
  "h_t_valid htd gd (p :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> array_assertion (ptr_coerce p :: 'a ptr) (CARD('b)) htd"
  apply (clarsimp simp: array_assertion_def dest!: h_t_array_valid)
  apply (fastforce intro: exI[where x=0])
  done

lemma array_ptr_valid_array_assertionI:
  "h_t_valid htd gd (q :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> q = ptr_coerce p
    \<Longrightarrow> n \<le> CARD('b)
    \<Longrightarrow> array_assertion (p :: 'a ptr) n htd"
  by (auto dest: array_ptr_valid_array_assertionD
           simp: array_assertion_shrink_right)

lemma h_t_array_valid_array_assertion:
  "h_t_array_valid htd ptr n \<Longrightarrow> 0 < n
   \<Longrightarrow> array_assertion ptr n htd"
  apply (simp add: array_assertion_def)
  apply (fastforce intro: exI[where x=0])
  done

text \<open>Derived from array_assertion, an appropriate assertion for performing
a pointer addition, or for dereferencing a pointer addition (the strong case).

In either case, there must be an array connecting the two ends of the pointer
transition, with the caveat that the last address can be just out of the array
if the pointer is not dereferenced, thus the strong/weak distinction.

If the pointer doesn't actually move, nothing is learned.
\<close>
definition ptr_add_assertion :: "('a :: c_type) ptr \<Rightarrow> int \<Rightarrow> bool \<Rightarrow> heap_typ_desc \<Rightarrow> bool" where
  "ptr_add_assertion ptr offs strong htd \<equiv>
    offs = 0 \<or>
    array_assertion (if offs < 0 then CTypesDefs.ptr_add ptr offs else ptr)
                    (if offs < 0 then nat (- offs) else if strong then Suc (nat offs) else nat offs)
                    htd"

lemma ptr_add_assertion_positive:
  "offs \<ge> 0 \<Longrightarrow> ptr_add_assertion ptr offs strong htd
    = (offs = 0 \<or> array_assertion ptr (case strong of True \<Rightarrow> Suc (nat offs)
        | False \<Rightarrow> nat offs) htd)"
  by (simp add: ptr_add_assertion_def)

lemma ptr_add_assertion_negative:
  "offs < 0 \<Longrightarrow> ptr_add_assertion ptr offs strong htd
    = array_assertion (CTypesDefs.ptr_add ptr offs) (nat (- offs)) htd"
  by (simp add: ptr_add_assertion_def)

lemma ptr_add_assertion_uint[simp]:
  "ptr_add_assertion ptr (uint offs) strong htd
    = (offs = 0 \<or> array_assertion ptr
        (case strong of True \<Rightarrow> Suc (unat offs) | False \<Rightarrow> unat offs) htd)"
  by (metis ptr_add_assertion_positive uint_nonnegative unat_def unsigned_eq_0_iff)

text \<open>Ignore char and void pointers. The C standard specifies that arithmetic on
char and void pointers doesn't create any special checks.\<close>

definition ptr_add_assertion' :: "('a :: c_type) ptr \<Rightarrow> int \<Rightarrow> bool \<Rightarrow> heap_typ_desc \<Rightarrow> bool" where
  "ptr_add_assertion' ptr offs strong htd =
     (typ_uinfo_t TYPE('a) = typ_uinfo_t TYPE(word8)
      \<or> typ_uinfo_t TYPE ('a) = typ_uinfo_t TYPE(unit)
      \<or> ptr_add_assertion ptr offs strong htd)"

(* Useful for clearing away these assumptions. *)
lemma td_diff_from_typ_name:
  "typ_name td \<noteq> typ_name td' \<Longrightarrow> td \<noteq> td'"
  by clarsimp

lemma typ_name_void:
  "typ_name (typ_uinfo_t TYPE(unit)) = ''unit''"
 by (simp add: typ_uinfo_t_def)

lemmas ptr_add_assertion' = ptr_add_assertion'_def td_diff_from_typ_name typ_name_void

text \<open>Mechanism for retyping a range of memory to a non-constant array size.\<close>

definition ptr_arr_retyps :: "nat \<Rightarrow> ('a :: c_type) ptr \<Rightarrow> heap_typ_desc \<Rightarrow> heap_typ_desc" where
  "ptr_arr_retyps n p \<equiv>
    htd_update_list (ptr_val p)
        (map (\<lambda>i. list_map (typ_slice_t (uinfo_array_tag_n_m TYPE('a) n n) i))
             [0..<n * size_of TYPE('a)])"

lemma ptr_arr_retyps_to_retyp:
  "n = CARD('b :: finite)
    \<Longrightarrow> ptr_arr_retyps n (p :: ('c :: wf_type) ptr) = ptr_retyp (ptr_coerce p :: ('c['b]) ptr)"
  by (auto simp: ptr_arr_retyps_def ptr_retyp_def typ_slices_def typ_uinfo_array_tag_n_m_eq)

lemma size_td_uinfo_array_tag_n_m[simp]:
  "size_td (uinfo_array_tag_n_m (t :: 'a :: c_type itself) n m)
   = size_of (TYPE('a)) * n"
  apply (induct n)
   apply (simp add: uinfo_array_tag_n_m_def)
  apply (simp add: uinfo_array_tag_n_m_def size_of_def)
  done

lemma typ_slice_list_array:
  "x < size_td td * n
    \<Longrightarrow> typ_slice_list (map (\<lambda>i. DTPair td (nm i)) [0..<n]) x
        = typ_slice_t td (x mod size_td td)"
proof (induct n arbitrary: x nm)
  case 0 thus ?case by simp
next
  note if_split[split del]
  case (Suc n)
  from Suc.prems show ?case
    apply (simp add: upt_conv_Cons map_Suc_upt[symmetric]
                del: upt.simps)
    apply (split if_split, intro conjI impI)
     apply auto[1]
    apply (simp add: o_def)
    apply (subst Suc.hyps)
     apply arith
    apply (metis mod_geq)
    done
qed

lemma h_t_array_valid_field:
  "h_t_array_valid htd (p :: 'a :: wf_type ptr) n
    \<Longrightarrow> k < n
    \<Longrightarrow> gd (p +\<^sub>p int k)
    \<Longrightarrow> h_t_valid htd gd (p +\<^sub>p int k)"
  supply if_split[split del]
  apply (clarsimp simp: h_t_array_valid_def h_t_valid_def valid_footprint_def
                        size_of_def[symmetric, where t="TYPE('a)"] Let_def)
  apply (drule_tac x="k * size_of TYPE('a) + y" in spec)
  apply (drule mp)
   apply (frule_tac k="size_of TYPE('a)" in mult_le_mono1[where j=n, OF Suc_leI])
   apply (simp add: mult.commute)
  apply (clarsimp simp: ptr_add_def add.assoc)
  apply (erule map_le_trans[rotated])
  apply (clarsimp simp: uinfo_array_tag_n_m_def)
  apply (subst typ_slice_list_array)
   apply (frule_tac k="size_of TYPE('a)" in mult_le_mono1[where j=n, OF Suc_leI])
   apply (simp add: mult.commute size_of_def)
  apply (simp add: size_of_def list_map_mono)
  done

end