(*  Title:      statecharts/DataSpace/Update.thy

    Author:     Steffen Helke, Software Engineering Group
    Copyright   2010 Technische Universitaet Berlin
*)

header {* Update-Functions on Data Spaces *}
theory Update
imports Data
begin

subsection {* Total update-functions *}

definition
  Update :: "(('d data) => ('d data)) => bool" where
  "Update U = (\<forall> d. Data.DataSpace d = DataSpace (U d))"

lemma Update_EmptySet:
 "(% d. d) \<in> { L | L. Update L}";
by (unfold Update_def, auto)

definition
  "update = { L | (L::(('d data) => ('d data))). Update L}"

typedef 'd update = "update :: ('d data => 'd data) set"
  unfolding update_def
  apply (rule exI)
  apply (rule Update_EmptySet)
  done

definition
 UpdateApply :: "['d update, 'd data] => 'd data" ("(_ !!!/ _)" [10,11]10) where
 "UpdateApply U D == Rep_update U D"

definition
  DefaultUpdate :: "('d update)" where
 "DefaultUpdate ==  Abs_update (\<lambda> D. D)"

subsubsection {* Basic lemmas *}

lemma Update_select:
   "Update (Rep_update U)"
apply (cut_tac x=U in Rep_update)
apply (unfold update_def)
apply auto
done

lemma DataSpace_DataSpace_Update [simp]:
   "Data.DataSpace (Rep_update U DP) = Data.DataSpace DP"
apply (cut_tac U=U in Update_select)
apply (unfold Update_def)
apply auto
done

subsubsection {* @{text "DefaultUpdate"} *}

lemma Update_DefaultUpdate [simp]:
   "Update (\<lambda> D. D)";
by (unfold Update_def, auto)

lemma update_DefaultUpdate [simp]:
   "(\<lambda> D. D) \<in> update";
by (unfold update_def, auto)

lemma DataSpace_UpdateApply [simp]:
   "Data.DataSpace (U !!! D) = Data.DataSpace D";
by (unfold UpdateApply_def, auto)

subsection {* Partial update-functions *}

definition
  PUpdate :: "(('d data) => ('d pdata)) => bool" where
  "PUpdate U = (\<forall> d. Data.DataSpace d = PDataSpace (U d))"

lemma PUpdate_EmptySet:
 "(% d. Data2PData d) \<in> { L | L. PUpdate L}";
by (unfold PUpdate_def, auto)

definition "pupdate = { L | (L::(('d data) => ('d pdata))). PUpdate L}"

typedef 'd pupdate = "pupdate :: ('d data => 'd pdata) set"
  unfolding pupdate_def
  apply (rule exI)
  apply (rule PUpdate_EmptySet)
  done

definition
 PUpdateApply :: "['d pupdate, 'd data] => 'd pdata" ("(_ !!/ _)" [10,11]10) where
 "PUpdateApply U D = Rep_pupdate U D"

definition
  DefaultPUpdate :: "('d pupdate)" where
 "DefaultPUpdate = Abs_pupdate (\<lambda> D. DefaultPData (Data.DataSpace D))"

subsubsection {* Basic lemmas *}

lemma PUpdate_select:
   "PUpdate (Rep_pupdate U)";
apply (cut_tac x=U in Rep_pupdate)
apply (unfold pupdate_def)
apply auto
done

lemma DataSpace_PDataSpace_PUpdate [simp]:
   "PDataSpace (Rep_pupdate U DP) = Data.DataSpace DP";
apply (cut_tac U=U in PUpdate_select)
apply (unfold PUpdate_def)
apply auto
done

subsubsection {* @{text "Data2PData"} *}

lemma  PUpdate_Data2PData [simp]:
   "PUpdate Data2PData";
by (unfold PUpdate_def, auto)

lemma pupdate_Data2PData  [simp]:
   "Data2PData \<in> pupdate";
by (unfold pupdate_def, auto)

subsubsection {* @{text "PUpdate"} *}

lemma PUpdate_DefaultPUpdate [simp]:
   "PUpdate (\<lambda> D. DefaultPData (Data.DataSpace D))"
apply (unfold PUpdate_def)
apply auto
done

lemma pupdate_DefaultPUpdate [simp]:
   "(\<lambda> D. DefaultPData (Data.DataSpace D)) \<in> pupdate"
apply (unfold pupdate_def)
apply auto
done

lemma DefaultPUpdate_None [simp]:
    "(DefaultPUpdate !! D) = DefaultPData (DataSpace D)"
apply (unfold DefaultPUpdate_def PUpdateApply_def)
apply (subst Abs_pupdate_inverse)
apply auto
done

subsubsection {* @{text "SequentialRacing"} *}

definition
 UpdateOverride :: "['d pupdate, 'd update] =>
                     'd update" ("(_ [U+]/ _)" [10,11]10) where
 "UpdateOverride U P = Abs_update (\<lambda> DA . (U !! DA) [D+] (P !!! DA))"

(* -------------------------------------------------------------- *)
(* We use our own FoldSet operator simular to the definition      *)
(* of Isabelle 2002. Note, it is different to the definition      *)
(* in Isabelle 2009. Basically we express "f (g x)" by "h x"      *)
(* -------------------------------------------------------------- *)

inductive
  FoldSet :: "('b => 'a => 'a) => 'a => 'b set => 'a => bool"
  for h ::  "'b => 'a => 'a"
  and z :: 'a
where
  emptyI [intro]: "FoldSet h z {} z"
| insertI [intro]:
     "\<lbrakk> x \<notin> A; FoldSet h z A y \<rbrakk>
      \<Longrightarrow> FoldSet h z (insert x A) (h x y)"

definition
SequentialRacing :: "('d pupdate set) => ('d update set)" where
 "SequentialRacing U =
     {u. FoldSet UpdateOverride DefaultUpdate U u}"

lemma FoldSet_imp_finite:
  "FoldSet h z A x \<Longrightarrow> finite A"
by (induct set: FoldSet) auto

lemma finite_imp_FoldSet:
  "finite A \<Longrightarrow> \<exists> x. FoldSet h z A x"
by (induct set: finite) auto

lemma finite_SequentialRacing:
   "finite US \<Longrightarrow> (SOME u. u \<in> SequentialRacing US) \<in> SequentialRacing US"
apply (unfold SequentialRacing_def)
apply auto
apply (drule_tac h=UpdateOverride and z=DefaultUpdate in finite_imp_FoldSet)
apply auto
apply (rule someI)
apply auto
done

end


(*  Author:     Gerwin Klein
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Correctness of the LBV\<close>

theory LBVCorrect
imports LBVSpec Typing_Framework
begin

locale lbvs = lbv +
  fixes s0  :: 'a ("s\<^sub>0")
  fixes c   :: "'a list"
  fixes ins :: "'b list"
  fixes phi :: "'a list" ("\<phi>")
  defines phi_def:
  "\<phi> \<equiv> map (\<lambda>pc. if c!pc = \<bottom> then wtl (take pc ins) c 0 s0 else c!pc)
       [0..<length ins]"

  assumes bounded: "bounded step (length ins)"
  assumes cert: "cert_ok c (length ins) \<top> \<bottom> A"
  assumes pres: "pres_type step (length ins) A"

lemma (in lbvs) phi_None [intro?]:
  "\<lbrakk> pc < length ins; c!pc = \<bottom> \<rbrakk> \<Longrightarrow> \<phi> ! pc = wtl (take pc ins) c 0 s0"
  by (simp add: phi_def)

lemma (in lbvs) phi_Some [intro?]:
  "\<lbrakk> pc < length ins; c!pc \<noteq> \<bottom> \<rbrakk> \<Longrightarrow> \<phi> ! pc = c ! pc"
  by (simp add: phi_def)

lemma (in lbvs) phi_len [simp]:
  "length \<phi> = length ins"
  by (simp add: phi_def)

lemma (in lbvs) wtl_suc_pc:
  assumes all: "wtl ins c 0 s\<^sub>0 \<noteq> \<top>"
  assumes pc:  "pc+1 < length ins"
  shows "wtl (take (pc+1) ins) c 0 s0 \<sqsubseteq>\<^sub>r \<phi>!(pc+1)"
proof -
  from all pc
  have "wtc c (pc+1) (wtl (take (pc+1) ins) c 0 s0) \<noteq> T" by (rule wtl_all)
  with pc show ?thesis by (simp add: phi_def wtc split: if_split_asm)
qed

lemma (in lbvs) wtl_stable:
  assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
  assumes s0:  "s0 \<in> A"
  assumes pc:  "pc < length ins"
  shows "stable r step \<phi> pc"
proof (unfold stable_def, clarify)
  fix pc' s' assume step: "(pc',s') \<in> set (step pc (\<phi> ! pc))"
                      (is "(pc',s') \<in> set (?step pc)")

  from bounded pc step have pc': "pc' < length ins" by (rule boundedD)

  from wtl have tkpc: "wtl (take pc ins) c 0 s0 \<noteq> \<top>" (is "?s1 \<noteq> _") by (rule wtl_take)
  from wtl have s2: "wtl (take (pc+1) ins) c 0 s0 \<noteq> \<top>" (is "?s2 \<noteq> _") by (rule wtl_take)

  from wtl pc have wt_s1: "wtc c pc ?s1 \<noteq> \<top>" by (rule wtl_all)

  have c_Some: "\<forall>pc t. pc < length ins \<longrightarrow> c!pc \<noteq> \<bottom> \<longrightarrow> \<phi>!pc = c!pc"
    by (simp add: phi_def)
  from pc have c_None: "c!pc = \<bottom> \<Longrightarrow> \<phi>!pc = ?s1" ..

  from wt_s1 pc c_None c_Some
  have inst: "wtc c pc ?s1  = wti c pc (\<phi>!pc)"
    by (simp add: wtc split: if_split_asm)

  from pres cert s0 wtl pc have "?s1 \<in> A" by (rule wtl_pres)
  with pc c_Some cert c_None
  have "\<phi>!pc \<in> A" by (cases "c!pc = \<bottom>") (auto dest: cert_okD1)
  with pc pres
  have step_in_A: "snd`set (?step pc) \<subseteq> A" by (auto dest: pres_typeD2)

  show "s' <=_r \<phi>!pc'"
  proof (cases "pc' = pc+1")
    case True
    with pc' cert
    have cert_in_A: "c!(pc+1) \<in> A" by (auto dest: cert_okD1)
    from True pc' have pc1: "pc+1 < length ins" by simp
    with tkpc have "?s2 = wtc c pc ?s1" by - (rule wtl_Suc)
    with inst
    have merge: "?s2 = merge c pc (?step pc) (c!(pc+1))" by (simp add: wti)
    also
    from s2 merge have "\<dots> \<noteq> \<top>" (is "?merge \<noteq> _") by simp
    with cert_in_A step_in_A
    have "?merge = (map snd [(p',t') \<leftarrow> ?step pc. p'=pc+1] ++_f (c!(pc+1)))"
      by (rule merge_not_top_s)
    finally
    have "s' <=_r ?s2" using step_in_A cert_in_A True step
      by (auto intro: pp_ub1')
    also
    from wtl pc1 have "?s2 <=_r \<phi>!(pc+1)" by (rule wtl_suc_pc)
    also note True [symmetric]
    finally show ?thesis by simp
  next
    case False
    from wt_s1 inst
    have "merge c pc (?step pc) (c!(pc+1)) \<noteq> \<top>" by (simp add: wti)
    with step_in_A
    have "\<forall>(pc', s')\<in>set (?step pc). pc'\<noteq>pc+1 \<longrightarrow> s' <=_r c!pc'"
      by - (rule merge_not_top)
    with step False
    have ok: "s' <=_r c!pc'" by blast
    moreover
    from ok
    have "c!pc' = \<bottom> \<Longrightarrow> s' = \<bottom>" by simp
    moreover
    from c_Some pc'
    have "c!pc' \<noteq> \<bottom> \<Longrightarrow> \<phi>!pc' = c!pc'" by auto
    ultimately
    show ?thesis by (cases "c!pc' = \<bottom>") auto
  qed
qed

lemma (in lbvs) phi_not_top:
  assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
  assumes pc:  "pc < length ins"
  shows "\<phi>!pc \<noteq> \<top>"
proof (cases "c!pc = \<bottom>")
  case False with pc
  have "\<phi>!pc = c!pc" ..
  also from cert pc have "\<dots> \<noteq> \<top>" by (rule cert_okD4)
  finally show ?thesis .
next
  case True with pc
  have "\<phi>!pc = wtl (take pc ins) c 0 s0" ..
  also from wtl have "\<dots> \<noteq> \<top>" by (rule wtl_take)
  finally show ?thesis .
qed

lemma (in lbvs) phi_in_A:
  assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
  assumes s0:  "s0 \<in> A"
  shows "\<phi> \<in> list (length ins) A"
proof -
  { fix x assume "x \<in> set \<phi>"
    then obtain xs ys where "\<phi> = xs @ x # ys"
      by (auto simp add: in_set_conv_decomp)
    then obtain pc where pc: "pc < length \<phi>" and x: "\<phi>!pc = x"
      by (simp add: that [of "length xs"] nth_append)

    from pres cert wtl s0 pc
    have "wtl (take pc ins) c 0 s0 \<in> A" by (auto intro!: wtl_pres)
    moreover
    from pc have "pc < length ins" by simp
    with cert have "c!pc \<in> A" ..
    ultimately
    have "\<phi>!pc \<in> A" using pc by (simp add: phi_def)
    hence "x \<in> A" using x by simp
  }
  hence "set \<phi> \<subseteq> A" ..
  thus ?thesis by (unfold list_def) simp
qed

lemma (in lbvs) phi0:
  assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
  assumes 0:   "0 < length ins"
  shows "s0 <=_r \<phi>!0"
proof (cases "c!0 = \<bottom>")
  case True
  with 0 have "\<phi>!0 = wtl (take 0 ins) c 0 s0" ..
  moreover have "wtl (take 0 ins) c 0 s0 = s0" by simp
  ultimately have "\<phi>!0 = s0" by simp
  thus ?thesis by simp
next
  case False
  with 0 have "phi!0 = c!0" ..
  moreover
  from wtl have "wtl (take 1 ins) c 0 s0 \<noteq> \<top>"  by (rule wtl_take)
  with 0 False
  have "s0 <=_r c!0" by (auto simp add: neq_Nil_conv wtc split: if_split_asm)
  ultimately
  show ?thesis by simp
qed

theorem (in lbvs) wtl_sound_strong:
  assumes wtl: "wtl ins c 0 s0 \<noteq> \<top>"
  assumes s0: "s0 \<in> A"
  assumes nz: "0 < length ins"
  shows "\<exists>ts \<in> list (length ins) A. wt_step r \<top> step ts \<and> s0 <=_r ts!0"
proof -
  from wtl s0 have "\<phi> \<in> list (length ins) A" by (rule phi_in_A)
  moreover
  have "wt_step r \<top> step \<phi>"
  proof (unfold wt_step_def, intro strip conjI)
    fix pc assume "pc < length \<phi>"
    then have pc: "pc < length ins" by simp
    with wtl show "\<phi>!pc \<noteq> \<top>" by (rule phi_not_top)
    from wtl s0 pc show "stable r step \<phi> pc" by (rule wtl_stable)
  qed
  moreover
  from wtl nz have "s0 <=_r \<phi>!0" by (rule phi0)
  ultimately
  show ?thesis by fast
qed

end


theory BPlusTree_ImpSplit
  imports
    BPlusTree_Imp
    BPlusTree_Split
    Imperative_Loops
begin

definition "split_relation xs \<equiv>
   \<lambda>(as,bs) i. i \<le> length xs \<and> as = take i xs \<and> bs = drop i xs"

lemma split_relation_alt:
  "split_relation as (ls,rs) i = (as = ls@rs \<and> i = length ls)"
  by (auto simp add: split_relation_def)

lemma split_relation_length: "split_relation xs (ls,rs) (length xs) = (ls = xs \<and> rs = [])"
  by (simp add: split_relation_def)

(* auxiliary lemmas on assns *)
(* simp? not sure if it always makes things more easy *)
lemma list_assn_prod_map: "list_assn (A \<times>\<^sub>a B) xs ys = list_assn B (map snd xs) (map snd ys) * list_assn A (map fst xs) (map fst ys)"
  apply(induct "(A \<times>\<^sub>a B)" xs ys rule: list_assn.induct)
     apply(auto simp add: ab_semigroup_mult_class.mult.left_commute ent_star_mono star_aci(2) star_assoc)
  done

(* concrete *)
lemma id_assn_list: "h \<Turnstile> list_assn id_assn (xs::'a list) ys \<Longrightarrow> xs = ys"
  apply(induction "id_assn::('a \<Rightarrow> 'a \<Rightarrow> assn)" xs ys rule: list_assn.induct)
     apply(auto simp add: less_Suc_eq_0_disj pure_def)
  done

lemma id_assn_list_alt: "list_assn id_assn (xs::'a list) ys = \<up>(xs = ys)"
  apply(induction "id_assn::('a \<Rightarrow> 'a \<Rightarrow> assn)" xs ys rule: list_assn.induct)
     apply(auto simp add: less_Suc_eq_0_disj pure_def)
  done

lemma snd_map_help:
  "x \<le> length tsi \<Longrightarrow>
       (\<forall>j<x. snd (tsi ! j) = ((map snd tsi)!j))"
  "x < length tsi \<Longrightarrow> snd (tsi!x) = ((map snd tsi)!x)"
  by auto

lemma split_ismeq: "((a::nat) \<le> b \<and> X) = ((a < b \<and> X) \<or> (a = b \<and> X))"
  by auto

lemma split_relation_map: "split_relation as (ls,rs) i \<Longrightarrow> split_relation (map f as) (map f ls, map f rs) i"
  apply(induction as arbitrary: ls rs i)
   apply(auto simp add: split_relation_def take_map drop_Cons')
  apply(metis list.simps(9) take_map)
  done

lemma split_relation_access: "\<lbrakk>split_relation as (ls,rs) i; rs = r#rrs\<rbrakk> \<Longrightarrow> as!i = r"
  by (simp add: split_relation_alt)

lemma index_to_elem_all: "(\<forall>j<length xs. P (xs!j)) = (\<forall>x \<in> set xs. P x)"
  by (simp add: all_set_conv_nth)

lemma index_to_elem: "n < length xs \<Longrightarrow> (\<forall>j<n. P (xs!j)) = (\<forall>x \<in> set (take n xs). P x)"
  by (simp add: all_set_conv_nth)
    (* ----------------- *)

definition split_half :: "'a::heap pfarray \<Rightarrow> nat Heap"
  where
    "split_half a \<equiv> do {
  l \<leftarrow> pfa_length a;
  return ((l + 1) div 2)
}"

lemma split_half_rule[sep_heap_rules]: "<
    is_pfa c tsi a>
    split_half a
  <\<lambda>i.
      is_pfa c tsi a
    * \<up>(i = (length tsi + 1) div 2 \<and>  split_relation tsi (BPlusTree_Split.split_half tsi) i)>"
  unfolding split_half_def split_relation_def
  apply(rule hoare_triple_preI)
  apply(sep_auto dest!: list_assn_len mod_starD)
  done

subsection "The imperative split locale"

locale split\<^sub>i_tree = abs_split_tree: BPlusTree_Split.split_tree split
  for split::
    "('a::{heap,default,linorder,order_top} bplustree \<times> 'a) list \<Rightarrow> 'a
       \<Rightarrow> ('a bplustree \<times> 'a) list \<times> ('a bplustree \<times> 'a) list" +
  fixes split\<^sub>i:: "('a btnode ref option \<times> 'a::{heap,default,linorder,order_top}) pfarray \<Rightarrow> 'a \<Rightarrow> nat Heap"
  assumes split\<^sub>i_rule [sep_heap_rules]:"sorted_less (separators ts) \<Longrightarrow>
  length tsi = length rs \<Longrightarrow>
  tsi'' = zip (zip (map fst tsi) (zip (butlast (r#rs)) (butlast (rs@[z])))) (map snd tsi) \<Longrightarrow>
 <is_pfa c tsi (a,n)
  * blist_assn k ts tsi'' >
    split\<^sub>i (a,n) p
  <\<lambda>i.
    is_pfa c tsi (a,n)
    * blist_assn k ts tsi''
    * \<up>(split_relation ts (split ts p) i)>\<^sub>t"

locale split\<^sub>i_list = abs_split_list: split_list split_list
  for split_list::
    "('a::{heap,default,linorder,order_top}) list \<Rightarrow> 'a
       \<Rightarrow> 'a list \<times> 'a list" +
  fixes split\<^sub>i_list:: "('a::{heap,default,linorder,order_top}) pfarray \<Rightarrow> 'a \<Rightarrow> nat Heap"
  assumes split\<^sub>i_list_rule [sep_heap_rules]: "sorted_less xs \<Longrightarrow>
   <is_pfa c xs (a,n)>
    split\<^sub>i_list (a,n) p
  <\<lambda>i.
    is_pfa c xs (a,n)
    * \<up>(split_relation xs (split_list xs p) i)>\<^sub>t"

locale split\<^sub>i_full = split\<^sub>i_tree: split\<^sub>i_tree split + split\<^sub>i_list: split\<^sub>i_list split_list
    for split::
      "('a bplustree \<times> 'a::{linorder,heap,default,order_top}) list \<Rightarrow> 'a
         \<Rightarrow> ('a bplustree \<times> 'a) list \<times> ('a bplustree \<times> 'a) list"
    and split_list::
      "'a::{default,linorder,order_top,heap} list \<Rightarrow> 'a
         \<Rightarrow> 'a list \<times> 'a list"

section "Imperative split operations"

text "So far, we have only given a functional specification of a possible split.
      We will now provide imperative split functions that refine the functional specification.
      However, rather than tracing the execution of the abstract specification,
      the imperative versions are implemented using while-loops."

subsection "Linear split"

text "The linear split is the most simple split function for binary trees.
      It serves a good example on how to use while-loops in Imperative/HOL
      and how to prove Hoare-Triples about its application using loop invariants."

definition lin_split :: "('a::heap \<times> 'b::{heap,linorder}) pfarray \<Rightarrow> 'b \<Rightarrow> nat Heap"
  where
    "lin_split \<equiv> \<lambda> (a,n) p. do {

  i \<leftarrow> heap_WHILET
    (\<lambda>i. if i<n then do {
      (_,s) \<leftarrow> Array.nth a i;
      return (s<p)
    } else return False)
    (\<lambda>i. return (i+1))
    0;

  return i
}"

lemma lin_split_rule: "
< is_pfa c xs (a,n)>
 lin_split (a,n) p
 <\<lambda>i. is_pfa c xs (a,n) * \<up>(i\<le>n \<and> (\<forall>j<i. snd (xs!j) < p) \<and> (i<n \<longrightarrow> snd (xs!i)\<ge>p))>\<^sub>t"
  unfolding lin_split_def

  supply R = heap_WHILET_rule''[where
      R = "measure (\<lambda>i. n - i)"
      and I = "\<lambda>i. is_pfa c xs (a,n) * \<up>(i\<le>n \<and> (\<forall>j<i. snd (xs!j) < p))"
      and b = "\<lambda>i. i<n \<and> snd (xs!i) < p"
      and Q="\<lambda>i. is_pfa c xs (a,n) * \<up>(i\<le>n \<and> (\<forall>j<i. snd (xs!j) < p) \<and> (i<n \<longrightarrow> snd (xs!i)\<ge>p))"
      ]
  thm R

  apply (sep_auto  decon: R simp: less_Suc_eq is_pfa_def) []
       apply (metis nth_take snd_eqD)
      apply (metis nth_take snd_eqD)
     apply (sep_auto simp: is_pfa_def less_Suc_eq)+
      apply (metis nth_take)
    apply(sep_auto simp: is_pfa_def)
  apply (metis le_simps(3) less_Suc_eq less_le_trans nth_take)
  apply(sep_auto simp: is_pfa_def)+
  done

subsection "Binary split"

text "To obtain an efficient B-Tree implementation, we prefer a binary split
function.
To explore the searching procedure
and the resulting proof, we first implement the split on singleton arrays."

definition bin'_split :: "'b::{heap,linorder} array_list \<Rightarrow> 'b \<Rightarrow> nat Heap"
  where
    "bin'_split \<equiv> \<lambda>(a,n) p. do {
  (low',high') \<leftarrow> heap_WHILET
    (\<lambda>(low,high). return (low < high))
    (\<lambda>(low,high). let mid = ((low  + high) div 2) in
     do {
      s \<leftarrow> Array.nth a mid;
      if p < s then
         return (low, mid)
      else if p > s then
         return (mid+1, high)
      else return (mid,mid)
     })
    (0::nat,n);
  return low'
}"

thm sorted_wrt_nth_less

(* alternative: replace (\<forall>j<l. xs!j < p) by (l > 0 \<longrightarrow> xs!(l-1) < p)*)
lemma bin'_split_rule: "
sorted_less xs \<Longrightarrow>
< is_pfa c xs (a,n)>
 bin'_split (a,n) p
 <\<lambda>l. is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. xs!j < p) \<and> (l<n \<longrightarrow> xs!l\<ge>p)) >\<^sub>t"
  unfolding bin'_split_def

  supply R = heap_WHILET_rule''[where
      R = "measure (\<lambda>(l,h). h-l)"
      and I = "\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l\<le>h \<and> h \<le> n \<and> (\<forall>j<l. xs!j < p) \<and> (h<n \<longrightarrow> xs!h\<ge>p))"
      and b = "\<lambda>(l,h). l<h"
      and Q="\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. xs!j < p) \<and> (l<n \<longrightarrow> xs!l\<ge>p))"
      ]
  thm R

  apply (sep_auto decon: R simp: less_Suc_eq is_pfa_def) []
  subgoal for l' aa l'a aaa ba j
  proof -
    assume 0: "n \<le> length l'a"
    assume a: "l'a ! ((aa + n) div 2) < p"
    moreover assume "aa < n"
    ultimately have b: "((aa+n)div 2) < n"
      by linarith
    then have "(take n l'a) ! ((aa + n) div 2) < p"
      using a by auto
    moreover assume "sorted_less (take n l'a)"
    ultimately have "\<And>j. j < (aa+n)div 2 \<Longrightarrow> (take n l'a) ! j < (take n l'a) ! ((aa + n) div 2)"
      using
        sorted_wrt_nth_less[where ?P="(<)" and xs="(take n l'a)" and ?j="((aa + n) div 2)"]
        a b "0" by auto
    moreover fix j assume "j < (aa+n) div 2"
    ultimately show "l'a ! j < p" using "0" b
      using \<open>take n l'a ! ((aa + n) div 2) < p\<close> dual_order.strict_trans by auto
  qed
  subgoal for l' aa b l'a aaa ba j
  proof -
    assume t0: "n \<le> length l'a"
    assume t1: "aa < b"
    assume a: "l'a ! ((aa + b) div 2) < p"
    moreover assume "b \<le> n"
    ultimately have b: "((aa+b)div 2) < n" using t1
      by linarith
    then have "(take n l'a) ! ((aa + b) div 2) < p"
      using a by auto
    moreover assume "sorted_less (take n l'a)"
    ultimately have "\<And>j. j < (aa+b)div 2 \<Longrightarrow> (take n l'a) ! j < (take n l'a) ! ((aa + b) div 2)"
      using
        sorted_wrt_nth_less[where ?P="(<)" and xs="(take n l'a)" and ?j="((aa + b) div 2)"]
        a b t0 by auto
    moreover fix j assume "j < (aa+b) div 2"
    ultimately show "l'a ! j < p" using t0 b
      using \<open>take n l'a ! ((aa + b) div 2) < p\<close> dual_order.strict_trans by auto
  qed
     apply sep_auto
      apply (metis le_less nth_take)
     apply (metis le_less nth_take)
    apply sep_auto
  subgoal for l' aa l'a aaa ba j
  proof -
    assume t0: "aa < n"
    assume t1: " n \<le> length l'a"
    assume t4: "sorted_less (take n l'a)"
    assume t5: "j < (aa + n) div 2"
    have "(aa+n) div 2 < n" using t0 by linarith
    then have "(take n l'a) ! j < (take n l'a) ! ((aa + n) div 2)"
      using t0 sorted_wrt_nth_less[where xs="take n l'a" and ?j="((aa + n) div 2)"]
        t1 t4 t5 by auto
    then show ?thesis
      using \<open>(aa + n) div 2 < n\<close> t5 by auto
  qed
  subgoal for l' aa b l'a aaa ba j
  proof -
    assume t0: "aa < b"
    assume t1: " n \<le> length l'a"
    assume t3: "b \<le> n"
    assume t4: "sorted_less (take n l'a)"
    assume t5: "j < (aa + b) div 2"
    have "(aa+b) div 2 < n" using t3 t0 by linarith
    then have "(take n l'a) ! j < (take n l'a) ! ((aa + b) div 2)"
      using t0 sorted_wrt_nth_less[where xs="take n l'a" and ?j="((aa + b) div 2)"]
        t1 t4 t5 by auto
    then show ?thesis
      using \<open>(aa + b) div 2 < n\<close> t5 by auto
  qed
    apply (metis nth_take order_mono_setup.refl)
   apply sep_auto
  apply (sep_auto simp add: is_pfa_def)
  done

text "We can fortunately directly use this function as the split-list interpretation."

text "Then, using the same loop invariant, a binary split for B-tree-like arrays
is derived in a straightforward manner."

definition bin_split :: "('a::heap \<times> 'b::{heap,linorder}) pfarray \<Rightarrow> 'b \<Rightarrow> nat Heap"
  where
    "bin_split \<equiv> \<lambda>(a,n) p. do {
  (low',high') \<leftarrow> heap_WHILET
    (\<lambda>(low,high). return (low < high))
    (\<lambda>(low,high). let mid = ((low  + high) div 2) in
     do {
      (_,s) \<leftarrow> Array.nth a mid;
      if p < s then
         return (low, mid)
      else if p > s then
         return (mid+1, high)
      else return (mid,mid)
     })
    (0::nat,n);
  return low'
}"

thm nth_take

lemma nth_take_eq: "take n ls = take n ls' \<Longrightarrow> i < n \<Longrightarrow> ls!i = ls'!i"
  by (metis nth_take)

lemma map_snd_sorted_less: "\<lbrakk>sorted_less (map snd xs); i < j; j < length xs\<rbrakk>
       \<Longrightarrow> snd (xs ! i) < snd (xs ! j)"
  by (metis (mono_tags, opaque_lifting) length_map less_trans nth_map sorted_wrt_iff_nth_less)

lemma map_snd_sorted_lesseq: "\<lbrakk>sorted_less (map snd xs); i \<le> j; j < length xs\<rbrakk>
       \<Longrightarrow> snd (xs ! i) \<le> snd (xs ! j)"
  by (metis eq_iff less_imp_le map_snd_sorted_less order.not_eq_order_implies_strict)

lemma bin_split_rule: "
sorted_less (map snd xs) \<Longrightarrow>
< is_pfa c xs (a,n)>
 bin_split (a,n) p
 <\<lambda>l. is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. snd(xs!j) < p) \<and> (l<n \<longrightarrow> snd(xs!l)\<ge>p)) >\<^sub>t"
  (* this works in principle, as demonstrated above *)
  unfolding bin_split_def

  supply R = heap_WHILET_rule''[where
      R = "measure (\<lambda>(l,h). h-l)"
      and I = "\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l\<le>h \<and> h \<le> n \<and> (\<forall>j<l. snd (xs!j) < p) \<and> (h<n \<longrightarrow> snd (xs!h)\<ge>p))"
      and b = "\<lambda>(l,h). l<h"
      and Q="\<lambda>(l,h). is_pfa c xs (a,n) * \<up>(l \<le> n \<and> (\<forall>j<l. snd (xs!j) < p) \<and> (l<n \<longrightarrow> snd (xs!l)\<ge>p))"
      ]
  thm R

  apply (sep_auto decon: R simp: less_Suc_eq is_pfa_def) []

      apply(auto dest!: sndI nth_take_eq[of n _ _ "(_ + _) div 2"])[]
     apply(auto dest!: sndI nth_take_eq[of n _ _ "(_ + _) div 2"])[]
    apply (sep_auto dest!: sndI )
  subgoal for ls i ls' _ _ j
    using map_snd_sorted_lesseq[of "take n ls'" j "(i + n) div 2"]
      less_mult_imp_div_less apply(auto)[]
    done
  subgoal for ls i j ls' _ _ j'
    using map_snd_sorted_lesseq[of "take n ls'" j' "(i + j) div 2"]
      less_mult_imp_div_less apply(auto)[]
    done
    apply sep_auto
  subgoal for ls i ls' _ _ j
    using map_snd_sorted_less[of "take n ls'" j "(i + n) div 2"]
      less_mult_imp_div_less
    apply(auto)[]
    done
  subgoal for ls i j ls' _ _ j'
    using map_snd_sorted_less[of "take n ls'" j' "(i + j) div 2"]
      less_mult_imp_div_less
    apply(auto)[]
    done
    apply (metis le_less nth_take_eq)
   apply sep_auto
  apply (sep_auto simp add: is_pfa_def)
  done

subsection "Refinement of an abstract split"

text \<open>Any function that yields the heap rule
we have obtained for bin\_split and lin\_split also
refines this abstract split.\<close>

locale split\<^sub>i_tree_smeq =
  fixes split_fun :: "('a::{heap,default,linorder,order_top} btnode ref option \<times> 'a) array \<times> nat \<Rightarrow> 'a \<Rightarrow> nat Heap"
  assumes split_rule: "sorted_less (separators xs) \<Longrightarrow>
 <is_pfa c xs (a, n)>
   split_fun (a, n) (p::'a)
  <\<lambda>r. is_pfa c xs (a, n) *
                 \<up> (r \<le> n \<and>
                   (\<forall>j<r. snd (xs ! j) < p) \<and>
                   (r < n \<longrightarrow> p \<le> snd (xs ! r)))>\<^sub>t"
begin

lemma linear_split_full: "\<forall>(_,s) \<in> set xs. s < p \<Longrightarrow> linear_split xs p = (xs,[])"
  by simp

lemma linear_split_split:
  assumes "n < length xs"
    and "(\<forall>(_,s) \<in> set (take n xs). s < p)"
    and " (case (xs!n) of (_,s) \<Rightarrow> \<not>(s < p))"
  shows "linear_split xs p = (take n xs, drop n xs)"
  using assms  apply (auto)
   apply (metis (mono_tags, lifting) id_take_nth_drop old.prod.case takeWhile_eq_all_conv takeWhile_tail)
  by (metis (no_types, lifting) Cons_nth_drop_Suc case_prod_conv dropWhile.simps(2) dropWhile_append2 id_take_nth_drop)

(* TODO refactor proof? *)
lemma split_rule_linear_split:
  shows
    "sorted_less (separators ts) \<Longrightarrow>
    min (length ks) (length tsi) = length tsi \<Longrightarrow>
    tsi' = zip ks (separators tsi) \<Longrightarrow>
    <
    is_pfa c tsi (a,n)
  * list_assn (A \<times>\<^sub>a id_assn) ts tsi'>
    split_fun (a,n) p
  <\<lambda>i.
    is_pfa c tsi (a,n)
    * list_assn (A \<times>\<^sub>a id_assn) ts tsi'
    * \<up>(split_relation ts (linear_split ts p) i)>\<^sub>t"
  apply(rule hoare_triple_preI)
  apply (sep_auto heap: split_rule dest!: mod_starD id_assn_list
      simp add: list_assn_prod_map split_ismeq map_snd_zip_take simp del: linear_split.simps)
    apply(auto simp add: is_pfa_def simp del: linear_split.simps)
proof -

  fix h l' assume heap_init:
    "h \<Turnstile> a \<mapsto>\<^sub>a l'"
    "map snd ts = (map snd (take n l'))"
    "n \<le> length l'"

  show full_thm: "\<forall>j<n. snd (l' ! j) < p \<Longrightarrow>
       split_relation ts (linear_split ts p) n"
  proof -
    assume sm_list: "\<forall>j<n. snd (l' ! j) < p"
    then have "\<forall>j < length (map snd (take n l')). ((map snd (take n l'))!j) < p"
      by simp
    then have "\<forall>j<length (map snd ts). ((map snd ts)!j) < p"
      using heap_init by simp
    then have "\<forall>(_,s) \<in> set ts. s < p"
      by (metis case_prod_unfold in_set_conv_nth length_map nth_map)
    then have "linear_split ts p = (ts, [])"
      using linear_split_full[of ts p] by simp
    then show "split_relation ts (linear_split ts p) n"
      using split_relation_length
      by (metis heap_init(2) heap_init(3) length_map length_take min.absorb2)

  qed
  then show "\<forall>j<n. snd (l' ! j) < p \<Longrightarrow>
       p \<le> snd (take n l' ! n) \<Longrightarrow>
       split_relation ts (linear_split ts p) n"
    by simp

  show part_thm: "\<And>x. x < n \<Longrightarrow>
       \<forall>j<x. snd (l' ! j) < p \<Longrightarrow>
       p \<le> snd (l' ! x) \<Longrightarrow> split_relation ts (linear_split ts p) x"
  proof -
    fix x assume x_sm_len: "x < n"
    moreover assume sm_list: "\<forall>j<x. snd (l' ! j) < p"
    ultimately have "\<forall>j<x. ((map snd l') ! j) < p"
      using heap_init
      by auto
    then have "\<forall>j<x. ((map snd ts)!j) < p"
      using heap_init  x_sm_len
      by auto
    moreover have x_sm_len_ts: "x < n"
      using heap_init x_sm_len by auto
    ultimately have "\<forall>(_,x) \<in> set (take x ts). x < p"
      by (auto simp add: in_set_conv_nth  min.absorb2)+
    moreover assume "p \<le> snd (l' ! x)"
    then have "case l'!x of (_,s) \<Rightarrow> \<not>(s < p)"
      by (simp add: case_prod_unfold)
    then have "case ts!x of (_,s) \<Rightarrow> \<not>(s < p)"
      using heap_init x_sm_len x_sm_len_ts
      by (metis (mono_tags, lifting) case_prod_unfold length_map length_take min.absorb2 nth_take snd_map_help(2))
    ultimately have "linear_split ts p = (take x ts, drop x ts)"
      using x_sm_len_ts linear_split_split[of x ts p] heap_init
      by (metis length_map length_take min.absorb2)
    then show "split_relation ts (linear_split ts p) x"
      using x_sm_len_ts
      by (metis append_take_drop_id heap_init(2) heap_init(3) length_map length_take less_imp_le_nat min.absorb2 split_relation_alt)
  qed
qed

sublocale split\<^sub>i_tree linear_split split_fun
  apply(unfold_locales)
  unfolding linear_split.simps
  subgoal by (auto split: list.splits)
  subgoal
    apply (auto split: list.splits)
    by (metis (no_types, lifting) case_prodD in_set_conv_decomp takeWhile_eq_all_conv takeWhile_idem)
  subgoal
    by (metis case_prod_conv hd_dropWhile le_less_linear list.sel(1) list.simps(3))
  subgoal for ts tsi rs tsi'' r z c a n k p
    supply R= split_rule_linear_split[of ts "zip (subtrees tsi) (zip (butlast (r # rs)) (butlast (rs @ [z])))" tsi
tsi''
      ]
    thm R
    apply(sep_auto heap: R simp del: last.simps butlast.simps)
    done
  done

end

locale split\<^sub>i_list_smeq =
  fixes split_list_fun :: "('a::{heap,default,linorder,order_top} array \<times> nat) \<Rightarrow> 'a \<Rightarrow> nat Heap"
  assumes split_list_rule: "sorted_less xs \<Longrightarrow>
 <is_pfa c xs (a, n)>
   split_list_fun (a, n) (p::'a)
  <\<lambda>r. is_pfa c xs (a, n) *
                 \<up> (r \<le> n \<and>
                   (\<forall>j<r. xs ! j < p) \<and>
                   (r < n \<longrightarrow> p \<le> xs ! r))>\<^sub>t"
begin

lemma split_list_rule_linear_split:
  shows
    "sorted_less ts \<Longrightarrow> <
    is_pfa c ts (a,n)>
    split_list_fun (a,n) p
  <\<lambda>i.
    is_pfa c ts (a,n)
    * \<up>(split_relation ts (linear_split_list ts p) i)>\<^sub>t"
  apply(rule hoare_triple_preI)
  apply (sep_auto heap: split_list_rule dest!: mod_starD
      simp add: list_assn_prod_map split_ismeq id_assn_list_alt simp del: linear_split_list.simps)
    apply(auto simp add: is_pfa_def split_relation_alt)
  subgoal by (smt (verit) eq_len_takeWhile_conv leD length_take length_takeWhile_le linorder_neqE_nat min_eq_arg(2) nth_length_takeWhile nth_take nth_take_eq)
  subgoal by (metis le_neq_implies_less length_take length_takeWhile_le min_eq_arg(2) nth_length_takeWhile nth_take)
  subgoal by (metis le_neq_implies_less length_take length_takeWhile_le min_eq_arg(2) nth_length_takeWhile nth_take)
  done

sublocale split\<^sub>i_list linear_split_list split_list_fun
  apply(unfold_locales)
  subgoal by (auto split: list.splits)
  subgoal
    apply (auto split: list.splits)
    by (metis (no_types, lifting) case_prodD in_set_conv_decomp takeWhile_eq_all_conv takeWhile_idem)
  subgoal
    apply (auto split: list.splits)
    by (metis case_prod_conv hd_dropWhile le_less_linear list.sel(1) list.simps(3))
  apply(sep_auto heap: split_list_rule_linear_split)
  done

end

locale split\<^sub>i_full_smeq = split\<^sub>i_tree_smeq split_fun + split\<^sub>i_list_smeq split_list_fun
  for split_fun:: "('a::{heap,default,linorder,order_top} btnode ref option \<times> 'a) array \<times> nat \<Rightarrow> 'a \<Rightarrow> nat Heap"
  and split_list_fun :: "('a::{heap,default,linorder,order_top} array \<times> nat) \<Rightarrow> 'a \<Rightarrow> nat Heap"
begin

sublocale split\<^sub>i_full split_fun split_list_fun linear_split linear_split_list
  by (unfold_locales)

end

text "The fact that these functions fulfill the locale specifications will only be shown
when we try to extract the executable code, because
the correct definitions have to be derived directly at the first instance of interpretation."

end


theory Impl_List_Playground_statefulpolicycompliance
imports "../TopoS_Impl"
    Impl_List_Playground_ChairNetwork
begin

thm ChairNetwork_def
thm ChairSecurityRequirements_def

definition "ChairNetwork_stateful_IFS =
  \<lparr> hostsL = nodesL ChairNetwork,
    flows_fixL = edgesL ChairNetwork,
    flows_stateL = filter_IFS_no_violations ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_IFS_no_violations ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_IFS"
lemma "set (flows_stateL ChairNetwork_stateful_IFS) \<subseteq>
       (set (flows_fixL ChairNetwork_stateful_IFS))" by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_IFS)) - set (flows_stateL ChairNetwork_stateful_IFS)"
(*only problems: printers!!!*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_IFS"

definition "ChairNetwork_stateful_ACS =
  \<lparr> hostsL = nodesL ChairNetwork,
   flows_fixL = edgesL ChairNetwork,
   flows_stateL = filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements \<rparr>"
value "edgesL ChairNetwork"
value "filter_compliant_stateful_ACS ChairNetwork ChairSecurityRequirements"
value "ChairNetwork_stateful_ACS"
lemma "set (flows_stateL ChairNetwork_stateful_ACS) \<subseteq> (set (flows_fixL ChairNetwork_stateful_ACS))"
  by eval (*must always hold*)
value "(set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)"

(*TODO: lemma \<dots> = X by eval*)

(*flows that are already allowed in both directions are not marked as stateful*)
value "((set (flows_fixL ChairNetwork_stateful_ACS)) - set (flows_stateL ChairNetwork_stateful_ACS)) - set (backlinks (flows_fixL ChairNetwork_stateful_ACS))"

(*the new backflows*)
value "set (edgesL (stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS)) - (set (edgesL ChairNetwork))"

(*the resulting ACS graph*)
value "stateful_list_policy_to_list_graph ChairNetwork_stateful_ACS"

value "generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"
value "generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements"
lemma "set (flows_fixL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) =
       set (flows_fixL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval
lemma "set (flows_stateL (generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements)) =
       set (flows_stateL (generate_valid_stateful_policy_IFSACS_2 ChairNetwork ChairSecurityRequirements))" by eval

definition "ChairNetwork_stateful = generate_valid_stateful_policy_IFSACS ChairNetwork ChairSecurityRequirements"

ML_val\<open>
visualize_edges @{context} @{term "flows_fixL ChairNetwork_stateful"}
  [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]",
   @{term "flows_stateL ChairNetwork_stateful"})] "";
\<close>

end


           (*-------------------------------------------*
            |                                           |
            |       LW-CSP-Prover on Isabelle2021       |
            |                                           |
           *-------------------------------------------*)

theory CSP_syntax
imports Main
begin

(*************************************************************

         1. Syntax of CSP
         2. Syntactic sugar
         3.
         4.

 *************************************************************)

(*-----------------------------------------------------------*
 |                                                           |
 |    Process Type Definitions                               |
 |                                                           |
 |             'a proc : type of process expressions         |
 |                       'n : process name                   |
 |                       'a : event                          |
 |                                                           |
 *-----------------------------------------------------------*)

(*********************************************************************
                       process expression
 *********************************************************************)

datatype
 ('p,'a) proc
    = STOP

    | Prefix   "'a" "('p,'a) proc"      ("(1_ /-> _)" [150,80] 80)

    | ExtCh    "('p,'a) proc" "('p,'a) proc"
                                               ("(1_ /[+] _)" [72,73] 72)
    | IntCh    "('p,'a) proc" "('p,'a) proc"
                                               ("(1_ /|~| _)" [64,65] 64)
    | NatExtCh "nat set" "nat => ('p,'a) proc"
                                               ("(1[nat] :_ .. /_)" [900,75] 75)
    | RepIntCh "'a set" "'a => ('p,'a) proc"
                                               ("(1!! :_ .. /_)" [900,68] 68)
    | If       "bool" "('p,'a) proc" "('p,'a) proc"
                                 ("(0IF _ /THEN _ /ELSE _)" [900,88,88] 88)
    | Para     "('p,'a) proc" "'a set" "('p,'a) proc"
                                               ("(1_ /|[_]| _)" [76,0,77] 76)
    | Hide     "('p,'a) proc" "'a set"   ("(1_ /~~ _)" [84,85] 84)

    | Ren      "('p,'a) proc" "('a * 'a) set"
                                               ("(1_ /[[_]])" [84,0] 84)
    | PName    "'p"                      ("$_" [900] 90)

(*--------------------------------------------------------------------*
 |                                                                    |
 | binding power:                                                     |
 |      PName > If > {Hide, Ren} > Prefix > Para >                    |
 |      NatExtCh > ExtCh >  RepIntCh > IntCh                          |
 |                                                                    |
 *--------------------------------------------------------------------*)

(*---------------------------------------*
 |           Syntactic Sugars            |
 *---------------------------------------*)

(*** nat external choice ***)

syntax
  "@Nat_ext_choice"  :: "pttrn => nat set => ('p,'a) proc
                => ('p,'a) proc"  ("(1[Nat] _:_ .. _)" [900,900,75] 75)
  "@Nat_Univ_ext_choice"  :: "pttrn => ('p,'a) proc
                => ('p,'a) proc"  ("(1[Nat] _ .. _)" [900,75] 75)
translations
  "[Nat] n:N .. P"  == "[nat] :N .. (%n. P)"
  "[Nat] n .. P"  == "[Nat] n:(CONST UNIV) .. P"

(*** replicated internal choice ***)

syntax
  "@Rep_int_choice"  :: "pttrn => 'a set => ('p,'a) proc
                => ('p,'a) proc"  ("(1!! _:_ .. _)" [900,900,68] 68)
  "@Rep_Univ_int_choice"  :: "pttrn => ('p,'a) proc
                => ('p,'a) proc"  ("(1!! _ .. _)" [900,68] 68)
translations
  "!! a:X .. P"  == "!! :X .. (%a. P)"
  "!! a .. P"  == "!! a:(CONST UNIV) .. P"

(*** sending ***)

abbreviation
  Send_prefix :: "('x => 'a) => 'x => ('p,'a) proc => ('p,'a) proc"
                                      ("(1_ ! _ /-> _)" [900,990,80] 80)
  where
  "a ! x -> P    == a x -> P"

(*** receiving on nat ***)

abbreviation
  Rec_prefix  :: "(nat => 'a) => nat set =>
                  (nat => ('p,'a) proc) => ('p,'a) proc"
  where
  "Rec_prefix a N Pf == [nat] : N .. (%n. a n -> Pf n)"

(* rec set *)

syntax
  "@Rec_nat_prefix"  :: "(nat => 'a) => pttrn => nat set => ('p,'a) proc
                => ('p,'a) proc"   ("(1_ ? _:_ /-> _)" [900,990,1000,75] 75)
  "@Rec_nat_Univ_prefix"  :: "(nat => 'a) => pttrn => ('p,'a) proc
                => ('p,'a) proc"   ("(1_ ? _ /-> _)" [900,990,75] 75)
translations
  "a ? n:N -> P" == "CONST Rec_prefix a N (%n. P)"
  "a ? n -> P"   == "a ? n:(CONST UNIV) -> P"

(*** interleaving ***)

abbreviation
   Interleave :: "('p,'a) proc => ('p,'a) proc
                    => ('p,'a) proc"  ("(1_ /||| _)" [76,77] 76)
where "P ||| Q == P |[{}]| Q"

(*** guard ***)

abbreviation
   Guard :: "bool => ('p,'a) proc
                  => ('p,'a) proc"  ("(1_ /&> _)" [150,80] 80)  (* ? *)
where "b &> P == IF b THEN P ELSE STOP"

(* renaming *)

abbreviation
  Ren_pair  :: "'a => 'a => ('a * 'a) set" ("_ <- _" [900,900] 900)
  where
  "a <- b == {(a,b)}"

(* test of syntactic sugars *)

lemma test_send_rec_syntax:
  "a ? n -> (b ! n -> STOP) = [Nat] n .. a n -> b n -> STOP"
  apply (simp)
  done
lemma test_renaming_syntax:
  "(a -> STOP)[[a <- b]] = (a -> STOP)[[{(a,b)}]]"
  apply (simp)
  done

(*  We assume that a process-name-function PNfun is given  *)
(*  for defining the meaning of each process-name.         *)

type_synonym ('p,'a) pnfun = "'p => ('p,'a) proc"
consts PNfun :: "('p,'a) pnfun"  (* Definition of process names *)

end


theory Extra4
  imports ExtraInv VCTheoryLemmas
begin

abbreviation s where "s s0 userAtTop_value userAtBottom_value  directionSwitch_value alarmButton_value stuck_value \<equiv>
 (toEnv
   (setPstate
     (setVarBool
       (setVarBool
         (setVarBool (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value)
           up' UP')
         moving' UP')
       direction' UP')
     ERROR Ctrl'goUp))"

theorem extra4: "VC4 extraInv env s0 userAtTop_value userAtBottom_value  directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC4_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  subgoal
    apply((drule conjE[of _ _ ?thesis])+)
                        defer
                        apply assumption+
    subgoal premises prems
      apply(rule conjI)
      using prems(1-7) prems(8) apply simp
      apply(rule conjI)
      using prems(1-7) prems(9) apply simp
      apply(rule conjI)
       apply(rule allI)
      subgoal for s1
        apply(cases "s1 = s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value")
         apply(rule impI)
         apply(rule exI[of _ s0])
         apply(rule exI[of _ "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"])
        using prems(1-7) substate_refl toEnvNum_id apply -[1]
         apply((rule conjI);simp)
        using prems(10) by simp
      apply(rule conjI)
      using prems(1-7) prems(11) apply simp
      apply(rule conjI)
      using prems(1-7) prems(12) apply simp
      apply(rule conjI)
      using prems(1-7) prems(13) apply simp
      apply(rule conjI)
      using prems(1-7) prems(14) apply simp
      apply(rule conjI)
      using prems(1-7) prems(15) apply simp
      apply(rule conjI)
      using prems(1-7) prems(16) apply simp
      apply(rule conjI)
      using prems(1-7) prems(17) apply simp
      apply(rule conjI)
      using prems(1-7) prems(18) apply simp
      apply(rule conjI)
      using prems(1-7) prems(19) apply simp
      apply(rule conjI)
      using prems(1-7) prems(20) apply simp
      apply(rule conjI)
      using prems(1-7) prems(21) apply simp
      apply(rule conjI)
      using prems(1-7) prems(21) prems(22) substate_refl apply simp
      apply(rule conjI)
      using prems(1-7) prems(23) apply simp
      using prems(1-7) prems(24) by simp
    done
  done

end


(*  Title:      HOL/Auth/ZhouGollmann.thy
    Author:     Giampaolo Bella and L C Paulson, Cambridge Univ Computer Lab
    Copyright   2003  University of Cambridge

The protocol of
  Jianying Zhou and Dieter Gollmann,
  A Fair Non-Repudiation Protocol,
  Security and Privacy 1996 (Oakland)
  55-61
*)

theory ZhouGollmann imports Public begin

abbreviation
  TTP :: agent where "TTP == Server"

abbreviation f_sub :: nat where "f_sub == 5"
abbreviation f_nro :: nat where "f_nro == 2"
abbreviation f_nrr :: nat where "f_nrr == 3"
abbreviation f_con :: nat where "f_con == 4"

definition broken :: "agent set" where
    \<comment>\<open>the compromised honest agents; TTP is included as it's not allowed to
        use the protocol\<close>
   "broken == bad - {Spy}"

declare broken_def [simp]

inductive_set zg :: "event list set"
  where

  Nil:  "[] \<in> zg"

| Fake: "[| evsf \<in> zg;  X \<in> synth (analz (spies evsf)) |]
         ==> Says Spy B X  # evsf \<in> zg"

| Reception:  "[| evsr \<in> zg; Says A B X \<in> set evsr |] ==> Gets B X # evsr \<in> zg"

  (*L is fresh for honest agents.
    We don't require K to be fresh because we don't bother to prove secrecy!
    We just assume that the protocol's objective is to deliver K fairly,
    rather than to keep M secret.*)
| ZG1: "[| evs1 \<in> zg;  Nonce L \<notin> used evs1; C = Crypt K (Number m);
           K \<in> symKeys;
           NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, C\<rbrace>|]
       ==> Says A B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> # evs1 \<in> zg"

  (*B must check that NRO is A's signature to learn the sender's name*)
| ZG2: "[| evs2 \<in> zg;
           Gets B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> \<in> set evs2;
           NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, C\<rbrace>;
           NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, C\<rbrace>|]
       ==> Says B A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> # evs2  \<in>  zg"

  (*A must check that NRR is B's signature to learn the sender's name;
    without spy, the matching label would be enough*)
| ZG3: "[| evs3 \<in> zg; C = Crypt K M; K \<in> symKeys;
           Says A B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> \<in> set evs3;
           Gets A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> \<in> set evs3;
           NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, C\<rbrace>;
           sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>|]
       ==> Says A TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace>
             # evs3 \<in> zg"

 (*TTP checks that sub_K is A's signature to learn who issued K, then
   gives credentials to A and B.  The Notes event models the availability of
   the credentials, but the act of fetching them is not modelled.  We also
   give con_K to the Spy. This makes the threat model more dangerous, while
   also allowing lemma @{text Crypt_used_imp_spies} to omit the condition
   @{term "K \<noteq> priK TTP"}. *)
| ZG4: "[| evs4 \<in> zg; K \<in> symKeys;
           Gets TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace>
             \<in> set evs4;
           sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
           con_K = Crypt (priK TTP) \<lbrace>Number f_con, Agent A, Agent B,
                                      Nonce L, Key K\<rbrace>|]
       ==> Says TTP Spy con_K
           #
           Notes TTP \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K, con_K\<rbrace>
           # evs4 \<in> zg"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]

declare symKey_neq_priEK [simp]
declare symKey_neq_priEK [THEN not_sym, simp]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "[|A \<noteq> B; TTP \<noteq> A; TTP \<noteq> B; K \<in> symKeys|] ==>
     \<exists>L. \<exists>evs \<in> zg.
           Notes TTP \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K,
               Crypt (priK TTP) \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K\<rbrace>\<rbrace>
               \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] zg.Nil
                    [THEN zg.ZG1, THEN zg.Reception [of _ A B],
                     THEN zg.ZG2, THEN zg.Reception [of _ B A],
                     THEN zg.ZG3, THEN zg.Reception [of _ A TTP],
                     THEN zg.ZG4])
apply (basic_possibility, auto)
done

subsection \<open>Basic Lemmas\<close>

lemma Gets_imp_Says:
     "[| Gets B X \<in> set evs; evs \<in> zg |] ==> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule zg.induct, auto)
done

lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> zg |]  ==> X \<in> spies evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

text\<open>Lets us replace proofs about @{term "used evs"} by simpler proofs
about @{term "parts (spies evs)"}.\<close>
lemma Crypt_used_imp_spies:
     "[| Crypt K X \<in> used evs; evs \<in> zg |]
      ==> Crypt K X \<in> parts (spies evs)"
apply (erule rev_mp)
apply (erule zg.induct)
apply (simp_all add: parts_insert_knows_A)
done

lemma Notes_TTP_imp_Gets:
     "[|Notes TTP \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K, con_K\<rbrace>
           \<in> set evs;
        sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
        evs \<in> zg|]
    ==> Gets TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule zg.induct, auto)
done

text\<open>For reasoning about C, which is encrypted in message ZG2\<close>
lemma ZG2_msg_in_parts_spies:
     "[|Gets B \<lbrace>F, B', L, C, X\<rbrace> \<in> set evs; evs \<in> zg|]
      ==> C \<in> parts (spies evs)"
by (blast dest: Gets_imp_Says)

(*classical regularity lemma on priK*)
lemma Spy_see_priK [simp]:
     "evs \<in> zg ==> (Key (priK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
done

text\<open>So that blast can use it too\<close>
declare  Spy_see_priK [THEN [2] rev_iffD1, dest!]

lemma Spy_analz_priK [simp]:
     "evs \<in> zg ==> (Key (priK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

subsection\<open>About NRO: Validity for @{term B}\<close>

text\<open>Below we prove that if @{term NRO} exists then @{term A} definitely
sent it, provided @{term A} is not broken.\<close>

text\<open>Strong conclusion for a good agent\<close>
lemma NRO_validity_good:
     "[|NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, C\<rbrace>;
        NRO \<in> parts (spies evs);
        A \<notin> bad;  evs \<in> zg |]
     ==> Says A B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
done

lemma NRO_sender:
     "[|Says A' B \<lbrace>n, b, l, C, Crypt (priK A) X\<rbrace> \<in> set evs; evs \<in> zg|]
    ==> A' \<in> {A,Spy}"
apply (erule rev_mp)
apply (erule zg.induct, simp_all)
done

text\<open>Holds also for @{term "A = Spy"}!\<close>
theorem NRO_validity:
     "[|Gets B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> \<in> set evs;
        NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, C\<rbrace>;
        A \<notin> broken;  evs \<in> zg |]
     ==> Says A B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> \<in> set evs"
apply (drule Gets_imp_Says, assumption)
apply clarify
apply (frule NRO_sender, auto)
txt\<open>We are left with the case where the sender is @{term Spy} and not
  equal to @{term A}, because @{term "A \<notin> bad"}.
  Thus theorem \<open>NRO_validity_good\<close> applies.\<close>
apply (blast dest: NRO_validity_good [OF refl])
done

subsection\<open>About NRR: Validity for @{term A}\<close>

text\<open>Below we prove that if @{term NRR} exists then @{term B} definitely
sent it, provided @{term B} is not broken.\<close>

text\<open>Strong conclusion for a good agent\<close>
lemma NRR_validity_good:
     "[|NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, C\<rbrace>;
        NRR \<in> parts (spies evs);
        B \<notin> bad;  evs \<in> zg |]
     ==> Says B A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
done

lemma NRR_sender:
     "[|Says B' A \<lbrace>n, a, l, Crypt (priK B) X\<rbrace> \<in> set evs; evs \<in> zg|]
    ==> B' \<in> {B,Spy}"
apply (erule rev_mp)
apply (erule zg.induct, simp_all)
done

text\<open>Holds also for @{term "B = Spy"}!\<close>
theorem NRR_validity:
     "[|Says B' A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> \<in> set evs;
        NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, C\<rbrace>;
        B \<notin> broken; evs \<in> zg|]
    ==> Says B A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> \<in> set evs"
apply clarify
apply (frule NRR_sender, auto)
txt\<open>We are left with the case where @{term "B' = Spy"} and  @{term "B' \<noteq> B"},
  i.e. @{term "B \<notin> bad"}, when we can apply \<open>NRR_validity_good\<close>.\<close>
 apply (blast dest: NRR_validity_good [OF refl])
done

subsection\<open>Proofs About @{term sub_K}\<close>

text\<open>Below we prove that if @{term sub_K} exists then @{term A} definitely
sent it, provided @{term A} is not broken.\<close>

text\<open>Strong conclusion for a good agent\<close>
lemma sub_K_validity_good:
     "[|sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
        sub_K \<in> parts (spies evs);
        A \<notin> bad;  evs \<in> zg |]
     ==> Says A TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace> \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply (blast dest!: Fake_parts_sing_imp_Un)
done

lemma sub_K_sender:
     "[|Says A' TTP \<lbrace>n, b, l, k, Crypt (priK A) X\<rbrace> \<in> set evs;  evs \<in> zg|]
    ==> A' \<in> {A,Spy}"
apply (erule rev_mp)
apply (erule zg.induct, simp_all)
done

text\<open>Holds also for @{term "A = Spy"}!\<close>
theorem sub_K_validity:
     "[|Gets TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace> \<in> set evs;
        sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
        A \<notin> broken;  evs \<in> zg |]
     ==> Says A TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace> \<in> set evs"
apply (drule Gets_imp_Says, assumption)
apply clarify
apply (frule sub_K_sender, auto)
txt\<open>We are left with the case where the sender is @{term Spy} and not
  equal to @{term A}, because @{term "A \<notin> bad"}.
  Thus theorem \<open>sub_K_validity_good\<close> applies.\<close>
apply (blast dest: sub_K_validity_good [OF refl])
done

subsection\<open>Proofs About @{term con_K}\<close>

text\<open>Below we prove that if @{term con_K} exists, then @{term TTP} has it,
and therefore @{term A} and @{term B}) can get it too.  Moreover, we know
that @{term A} sent @{term sub_K}\<close>

lemma con_K_validity:
     "[|con_K \<in> used evs;
        con_K = Crypt (priK TTP)
                  \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K\<rbrace>;
        evs \<in> zg |]
    ==> Notes TTP \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K, con_K\<rbrace>
          \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply (blast dest!: Fake_parts_sing_imp_Un)
txt\<open>ZG2\<close>
apply (blast dest: parts_cut)
done

text\<open>If @{term TTP} holds @{term con_K} then @{term A} sent
 @{term sub_K}.  We assume that @{term A} is not broken.  Importantly, nothing
  needs to be assumed about the form of @{term con_K}!\<close>
lemma Notes_TTP_imp_Says_A:
     "[|Notes TTP \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K, con_K\<rbrace>
           \<in> set evs;
        sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
        A \<notin> broken; evs \<in> zg|]
     ==> Says A TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace> \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt\<open>ZG4\<close>
apply clarify
apply (rule sub_K_validity, auto)
done

text\<open>If @{term con_K} exists, then @{term A} sent @{term sub_K}.  We again
   assume that @{term A} is not broken.\<close>
theorem B_sub_K_validity:
     "[|con_K \<in> used evs;
        con_K = Crypt (priK TTP) \<lbrace>Number f_con, Agent A, Agent B,
                                   Nonce L, Key K\<rbrace>;
        sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
        A \<notin> broken; evs \<in> zg|]
     ==> Says A TTP \<lbrace>Number f_sub, Agent B, Nonce L, Key K, sub_K\<rbrace> \<in> set evs"
by (blast dest: con_K_validity Notes_TTP_imp_Says_A)

subsection\<open>Proving fairness\<close>

text\<open>Cannot prove that, if @{term B} has NRO, then  @{term A} has her NRR.
It would appear that @{term B} has a small advantage, though it is
useless to win disputes: @{term B} needs to present @{term con_K} as well.\<close>

text\<open>Strange: unicity of the label protects @{term A}?\<close>
lemma A_unicity:
     "[|NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, Crypt K M\<rbrace>;
        NRO \<in> parts (spies evs);
        Says A B \<lbrace>Number f_nro, Agent B, Nonce L, Crypt K M', NRO'\<rbrace>
          \<in> set evs;
        A \<notin> bad; evs \<in> zg |]
     ==> M'=M"
apply clarify
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
txt\<open>ZG1: freshness\<close>
apply (blast dest: parts.Body)
done

text\<open>Fairness lemma: if @{term sub_K} exists, then @{term A} holds
NRR.  Relies on unicity of labels.\<close>
lemma sub_K_implies_NRR:
     "[| NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, Crypt K M\<rbrace>;
         NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, Crypt K M\<rbrace>;
         sub_K \<in> parts (spies evs);
         NRO \<in> parts (spies evs);
         sub_K = Crypt (priK A) \<lbrace>Number f_sub, Agent B, Nonce L, Key K\<rbrace>;
         A \<notin> bad;  evs \<in> zg |]
     ==> Gets A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> \<in> set evs"
apply clarify
apply hypsubst_thin
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply blast
txt\<open>ZG1: freshness\<close>
apply (blast dest: parts.Body)
txt\<open>ZG3\<close>
apply (blast dest: A_unicity [OF refl])
done

lemma Crypt_used_imp_L_used:
     "[| Crypt (priK TTP) \<lbrace>F, A, B, L, K\<rbrace> \<in> used evs; evs \<in> zg |]
      ==> L \<in> used evs"
apply (erule rev_mp)
apply (erule zg.induct, auto)
txt\<open>Fake\<close>
apply (blast dest!: Fake_parts_sing_imp_Un)
txt\<open>ZG2: freshness\<close>
apply (blast dest: parts.Body)
done

text\<open>Fairness for @{term A}: if @{term con_K} and @{term NRO} exist,
then @{term A} holds NRR.  @{term A} must be uncompromised, but there is no
assumption about @{term B}.\<close>
theorem A_fairness_NRO:
     "[|con_K \<in> used evs;
        NRO \<in> parts (spies evs);
        con_K = Crypt (priK TTP)
                      \<lbrace>Number f_con, Agent A, Agent B, Nonce L, Key K\<rbrace>;
        NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, Crypt K M\<rbrace>;
        NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, Crypt K M\<rbrace>;
        A \<notin> bad;  evs \<in> zg |]
    ==> Gets A \<lbrace>Number f_nrr, Agent A, Nonce L, NRR\<rbrace> \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
   txt\<open>Fake\<close>
   apply (simp add: parts_insert_knows_A)
   apply (blast dest: Fake_parts_sing_imp_Un)
  txt\<open>ZG1\<close>
  apply (blast dest: Crypt_used_imp_L_used)
 txt\<open>ZG2\<close>
 apply (blast dest: parts_cut)
txt\<open>ZG4\<close>
apply (blast intro: sub_K_implies_NRR [OF refl]
             dest: Gets_imp_knows_Spy [THEN parts.Inj])
done

text\<open>Fairness for @{term B}: NRR exists at all, then @{term B} holds NRO.
@{term B} must be uncompromised, but there is no assumption about @{term
A}.\<close>
theorem B_fairness_NRR:
     "[|NRR \<in> used evs;
        NRR = Crypt (priK B) \<lbrace>Number f_nrr, Agent A, Nonce L, C\<rbrace>;
        NRO = Crypt (priK A) \<lbrace>Number f_nro, Agent B, Nonce L, C\<rbrace>;
        B \<notin> bad; evs \<in> zg |]
    ==> Gets B \<lbrace>Number f_nro, Agent B, Nonce L, C, NRO\<rbrace> \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply (blast dest!: Fake_parts_sing_imp_Un)
txt\<open>ZG2\<close>
apply (blast dest: parts_cut)
done

text\<open>If @{term con_K} exists at all, then @{term B} can get it, by \<open>con_K_validity\<close>.  Cannot conclude that also NRO is available to @{term B},
because if @{term A} were unfair, @{term A} could build message 3 without
building message 1, which contains NRO.\<close>

end


theory Wasm_Assertions_Shallow imports "Wasm_Big_Step" begin

typedef lvar = "UNIV :: (nat) set" ..

(* global, local, logical variables*)
datatype var = Gl nat | Lc nat | Lv lvar

datatype 'a lvar_v = V_p v | V_n nat | V_b byte | V_a 'a

abbreviation "case_ret r r_new \<equiv> case_option r_new (\<lambda>x. Some x) r"

lemma case_ret_None[simp]:"case_ret r None = r"
  by (cases r) auto

(* variable store *)
(* global, local, logical variables*)
type_synonym 'a var_st = "global list \<times> v list \<times> (lvar, 'a lvar_v) map"

definition var_st_get_local :: "'a var_st \<Rightarrow> nat \<Rightarrow> v option" where
  "var_st_get_local st n \<equiv> let st_l = (fst (snd st)) in
                            (if (n < length st_l)
                            then Some (st_l!n)
                            else None)"

definition var_st_set_local :: "'a var_st \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> 'a var_st" where
  "var_st_set_local st n v \<equiv> let (gs, vs, lvs) = st in
                             (if (n < length vs)
                             then (gs, vs[n := v], lvs)
                             else st)"

definition var_st_get_global :: "'a var_st \<Rightarrow> nat \<Rightarrow> global option" where
  "var_st_get_global st n \<equiv> let st_g = (fst st) in
                            (if (n < length st_g)
                            then Some (st_g!n)
                            else None)"

definition var_st_set_global :: "'a var_st \<Rightarrow> nat \<Rightarrow> global \<Rightarrow> 'a var_st" where
  "var_st_set_global st n g \<equiv> let (gs, vs, lvs) = st in
                              (if (n < length gs)
                              then (gs[n := g], vs, lvs)
                              else st)"

definition var_st_set_global_v :: "'a var_st \<Rightarrow> nat \<Rightarrow> v \<Rightarrow> 'a var_st" where
  "var_st_set_global_v st n v \<equiv> let (gs, vs, lvs) = st in
                                (if (n < length gs)
                                then (gs[n := ((gs!n)\<lparr>g_val := v\<rparr>)], vs, lvs)
                                else st)"

definition var_st_get_lvar :: "'a var_st \<Rightarrow> lvar \<Rightarrow> 'a lvar_v option" where
  "var_st_get_lvar st lv \<equiv> let st_lv = (snd (snd st)) in st_lv lv"

definition var_st_set_lvar :: "'a var_st \<Rightarrow> lvar \<Rightarrow> 'a lvar_v \<Rightarrow> 'a var_st" where
  "var_st_set_lvar st l lv \<equiv> let (gs, vs, lvs) = st in
                              (gs, vs, (lvs(l \<mapsto> lv)))"

(* abstract heap with max length *)
type_synonym heap = "((nat, byte) map) \<times> (nat option)"

definition map_disj :: "('a,'b) map \<Rightarrow> ('a,'b) map \<Rightarrow> bool" where
  "map_disj m1 m2 \<equiv> Set.disjnt (dom m1) (dom m2)"

definition option_disj :: "'a option \<Rightarrow> 'a option \<Rightarrow> bool" where
  "option_disj o1 o2 \<equiv> Option.is_none o1 \<or> Option.is_none o2"

definition heap_disj :: "heap \<Rightarrow> heap \<Rightarrow> bool" where
  "heap_disj h1 h2 \<equiv> map_disj (fst h1) (fst h2) \<and> option_disj (snd h1) (snd h2)"

definition heap_merge :: "heap \<Rightarrow> heap \<Rightarrow> heap" where
  "heap_merge h1 h2 \<equiv> let (m1,s1) = h1 in
                       let (m2,s2) = h2 in
                       (m1 ++ m2, case_option s2 (\<lambda>s. Some s) s1)"

lemma heap_disj_sym: "heap_disj h1 h2 = heap_disj h2 h1"
  unfolding heap_disj_def map_disj_def option_disj_def
  using disjnt_sym
  by blast

lemma heap_merge_disj_sym:
  assumes "heap_disj h1 h2"
  shows "heap_merge h1 h2 = heap_merge h2 h1"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def heap_disj_def map_disj_def disjnt_def
  by (auto simp add: map_add_comm split: option.splits prod.splits)

lemma heap_merge_assoc:
  shows "heap_merge h1 (heap_merge h2 h3) = heap_merge (heap_merge h1 h2) h3"
  unfolding heap_merge_def
  by (auto split: option.splits prod.splits)

lemma heap_disj_merge_sub:
  assumes "heap_disj h1 (heap_merge h2 h3)"
  shows "heap_disj h1 h2"
        "heap_disj h1 h3"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def map_disj_def disjnt_def
  by (auto split: option.splits prod.splits)

lemma heap_disj_merge_assoc:
  assumes "heap_disj h_H h_Hf"
          "heap_disj (heap_merge h_H h_Hf) hf"
  shows "heap_disj h_H (heap_merge h_Hf hf)"
  using assms
  unfolding heap_disj_def heap_merge_def map_disj_def disjnt_def
  by (auto split: option.splits prod.splits)

lemma heap_merge_dom:
  assumes "x \<in> dom (fst (heap_merge h1 h2))"
  shows "x \<in> dom (fst h1) \<or> x \<in> dom (fst h2)"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def heap_disj_def map_disj_def disjnt_def
  by (auto simp add: map_add_comm split: option.splits prod.splits)

lemma heap_dom_merge:
  assumes "x \<in> dom (fst h1) \<or> x \<in> dom (fst h2)"
  shows "x \<in> dom (fst (heap_merge h1 h2))"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def heap_disj_def map_disj_def disjnt_def
  by (auto simp add: map_add_comm split: option.splits prod.splits)

lemma heap_dom_merge_eq:
  assumes "dom (fst h1) = dom(fst h2)"
  shows "dom (fst (heap_merge h1 hf)) = dom (fst (heap_merge h2 hf))"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def heap_disj_def map_disj_def disjnt_def
  apply (simp add: map_add_comm split: option.splits prod.splits)
  apply force
  done

lemma heap_disj_merge_maps1:
  assumes "heap_disj h1 h2"
          "(fst h1) x = Some y"
  shows "fst (heap_merge h1 h2) x = Some y"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def heap_disj_def map_disj_def disjnt_def
  apply (simp add: map_add_dom_app_simps map_add_comm split: option.splits prod.splits)
  apply (metis fst_conv map_add_comm map_add_find_right)
  done

lemma heap_disj_merge_maps2:
  assumes "heap_disj h1 h2"
          "(fst h2) x = Some y"
  shows "fst (heap_merge h1 h2) x = Some y"
  using assms
  unfolding heap_disj_def heap_merge_def option_disj_def heap_disj_def map_disj_def disjnt_def
  apply (simp add: map_add_dom_app_simps map_add_comm split: option.splits prod.splits)
  apply (metis fst_conv map_add_find_right)
  done

(* local variable reification *)
definition reifies_loc :: "[v list, 'a var_st] \<Rightarrow> bool" where
  "reifies_loc locs st \<equiv> (fst (snd st)) = locs"

(* global variable reification (with respect to a partial instance) *)
definition reifies_glob :: "[global list, nat list, 'a var_st] \<Rightarrow> bool" where
  "reifies_glob gs igs st \<equiv>
     let st_g = (fst st) in
     length st_g = (length igs) \<and> (\<forall>gn < length st_g. igs!gn < (length gs) \<and> st_g!gn = (gs!(igs!gn)))"

(* function reification (with respect to a partial instance) *)
definition reifies_func :: "[cl list, nat list, cl list] \<Rightarrow> bool" where
  "reifies_func cls icls fs \<equiv> list_all2 (\<lambda>icl f. icl < (length cls) \<and> cls!icl = f) icls fs"

(* heap reification relations *)
definition reifies_heap_contents :: "[mem, ((nat, byte) map)] \<Rightarrow> bool" where
  "reifies_heap_contents m byte_m \<equiv>
     \<forall>ind \<in> (dom byte_m). ind < mem_length m \<and> byte_m(ind) = Some (byte_at m ind)"

definition reifies_heap_length :: "[mem, nat option] \<Rightarrow> bool" where
  "reifies_heap_length m l_opt \<equiv> pred_option (\<lambda>l. mem_length m = (l * Ki64)) l_opt"

definition reifies_heap :: "[mem list, nat list, heap] \<Rightarrow> bool" where
  "reifies_heap ms im_opt h \<equiv> let im = hd im_opt in
                               im < length ms
                             \<and> reifies_heap_contents (ms!im) (fst h)
                             \<and> reifies_heap_length (ms!im) (snd h)"

(* store reification relation *)
definition reifies_s :: "[s, inst, heap, 'a var_st, cl list] \<Rightarrow> bool" where
  "reifies_s s i h st fs \<equiv> reifies_glob (globs s) (inst.globs i) st
                         \<and> reifies_func (funcs s) (inst.funcs i) fs
                         \<and> reifies_heap (mems s) (inst.mems i) h"

definition var_st_agree :: "'a var_st \<Rightarrow> var \<Rightarrow> 'a var_st \<Rightarrow> bool" where
  "var_st_agree st1 var st2 \<equiv> case var of
                                 Lc n \<Rightarrow> (var_st_get_local st1 n) = (var_st_get_local st2 n)
                               | Gl n \<Rightarrow> (var_st_get_global st1 n) = (var_st_get_global st2 n)
                               | Lv lvar \<Rightarrow> (var_st_get_lvar st1 lvar) = (var_st_get_lvar st2 lvar)"

(* shallow embedding of assertions *)
type_synonym 'a stack_ass = "(v \<Rightarrow> 'a var_st \<Rightarrow> bool) list"
type_synonym 'a heap_ass = "heap \<Rightarrow> 'a var_st \<Rightarrow> bool"

datatype 'a ass = Ass "'a stack_ass" "'a heap_ass" (infix "\<^sub>s|\<^sub>h" 60) | Ex_ass lvar "'a ass"

type_synonym 'a triple = "'a ass \<times> e list \<times> 'a ass"

(* function list, assms, label ass, return ass *)
type_synonym 'a triple_context = "cl list \<times> 'a ass list \<times> 'a ass option"

definition add_label_ass :: "'a triple_context \<Rightarrow> 'a ass \<Rightarrow> 'a triple_context" where
  "add_label_ass \<Gamma> l \<equiv> let (fs, labs, ret) = \<Gamma> in (fs, l#labs, ret)"

definition stack_ass_sat :: "'a stack_ass \<Rightarrow> v list \<Rightarrow> 'a var_st \<Rightarrow> bool" where
  "stack_ass_sat St ves v_st = list_all2 (\<lambda>Si v. Si v v_st) St ves"

fun ass_sat :: "'a ass \<Rightarrow> v list \<Rightarrow> heap \<Rightarrow> 'a var_st \<Rightarrow> bool" where
  "ass_sat (St \<^sub>s|\<^sub>h H) ves h v_st = (stack_ass_sat St ves v_st \<and> H h v_st)"
| "ass_sat (Ex_ass lv P) ves h st = (\<exists>v. ass_sat P ves h (var_st_set_lvar st lv v))"

fun ass_stack_len :: "'a ass \<Rightarrow> nat" where
  "ass_stack_len (St \<^sub>s|\<^sub>h H) = length St"
| "ass_stack_len (Ex_ass lv P) = ass_stack_len P"

(* label reification relation *)
definition reifies_lab :: "nat list \<Rightarrow> 'a triple_context \<Rightarrow> bool" where
  "reifies_lab lns \<Gamma> \<equiv> lns = map ass_stack_len (fst (snd \<Gamma>))"

(* return reification relation *)
definition reifies_ret :: "nat option \<Rightarrow> 'a triple_context \<Rightarrow> bool" where
  "reifies_ret rn \<Gamma> \<equiv> rn = Option.map_option ass_stack_len (snd (snd \<Gamma>))"

locale encapsulated_module =
  fixes i :: inst
  assumes encapsulated_inst_globs:"\<And> j k. \<lbrakk>j \<noteq> k; (j < length (inst.globs i)); (k < length (inst.globs i))\<rbrakk>
                                    \<Longrightarrow> (inst.globs i)!j \<noteq> (inst.globs i)!k"
begin

definition ass_wf where
  "ass_wf lvar_st ret \<Gamma> labs locs s hf st h vcs P \<equiv>
     ass_sat P vcs h st
      \<and> heap_disj h hf
      \<and> reifies_s s i (heap_merge h hf) st (fst \<Gamma>)
      \<and> reifies_loc locs st
      \<and> reifies_lab labs \<Gamma>
      \<and> reifies_ret ret \<Gamma>
      \<and> snd (snd st) = lvar_st"

definition res_wf where
  "res_wf lvar_st' \<Gamma> res locs' s' hf vcsf Q \<equiv>
    let (fs,lasss,rass) = \<Gamma> in
    (case res of
       RTrap \<Rightarrow> False
     | RValue rvs \<Rightarrow> \<exists>h' h'' vcs' st'.
                             ass_sat Q vcs' h'' st'
                             \<and> rvs = vcsf@vcs'
                             \<and> heap_disj h'' hf
                             \<and> h' = heap_merge h'' hf
                             \<and> reifies_s s' i h' st' fs
                             \<and> reifies_loc locs' st'
                             \<and> snd (snd st') = lvar_st'
     | RBreak n rvs \<Rightarrow> \<exists>h' h'' vcs' st'.
                             n < length lasss
                             \<and> ass_sat (lasss!n) vcs' h'' st'
                             \<and> rvs = vcs'
                             \<and> heap_disj h'' hf
                             \<and> h' = heap_merge h'' hf
                             \<and> reifies_s s' i h' st' fs
                             \<and> reifies_loc locs' st'
                             \<and> snd (snd st') = lvar_st'
     | RReturn rvs \<Rightarrow> \<exists>h' h'' vcs' st' the_rass.
                             rass = Some the_rass
                             \<and> ass_sat the_rass vcs' h'' st'
                             \<and> rvs = vcs'
                             \<and> heap_disj h'' hf
                             \<and> h' = heap_merge h'' hf
                             \<and> reifies_s s' i h' st' fs
                             \<and> reifies_loc locs' st'
                             \<and> snd (snd st') = lvar_st')"

(* TODO: frame? ? ? ?*)
definition valid_triple :: "'a triple_context \<Rightarrow> 'a ass \<Rightarrow> e list \<Rightarrow> 'a ass \<Rightarrow> bool" ("_ \<Turnstile> {_}_{_}" 60) where
  "(\<Gamma> \<Turnstile> {P}es{Q}) \<equiv> \<forall>vcs h st s locs labs labsf ret retf lvar_st hf vcsf s' locs' res.
                                      ((ass_wf lvar_st ret \<Gamma> labs locs s hf st h vcs P \<and>
                                      ((s,locs,($$*vcsf)@($$*vcs)@es) \<Down>{(labs@labsf,case_ret ret retf,i)} (s',locs', res))) \<longrightarrow>
                                      res_wf lvar_st \<Gamma> res locs' s' hf vcsf Q)"

definition valid_triples :: "'a triple_context \<Rightarrow> 'a triple set \<Rightarrow> bool" ("_ \<TTurnstile> _" 60) where
  "\<Gamma> \<TTurnstile> specs \<equiv> \<forall>(P,es,Q) \<in> specs. (\<Gamma> \<Turnstile> {P}es{Q})"

(* TODO: frame? ? ? ?*)
definition valid_triple_n :: "'a triple_context \<Rightarrow> nat \<Rightarrow> 'a ass \<Rightarrow> e list \<Rightarrow> 'a ass \<Rightarrow> bool" ("_ \<Turnstile>'_ _ {_}_{_}" 60) where
  "(\<Gamma> \<Turnstile>_k {P}es{Q}) \<equiv> \<forall>vcs h st s locs labs labsf ret retf lvar_st hf vcsf s' locs' res.
                                      ((ass_wf lvar_st ret \<Gamma> labs locs s hf st h vcs P \<and>
                                      ((s,locs,($$*vcsf)@($$*vcs)@es) \<Down>k{(labs@labsf,case_ret ret retf,i)} (s',locs', res))) \<longrightarrow>
                                      res_wf lvar_st \<Gamma> res locs' s' hf vcsf Q)"

definition valid_triples_n :: "'a triple_context \<Rightarrow> nat \<Rightarrow> 'a triple set \<Rightarrow> bool" ("_ \<TTurnstile>'_ _ _" 60) where
  "(\<Gamma> \<TTurnstile>_n specs) \<equiv> \<forall>(P,es,Q) \<in> specs. (\<Gamma> \<Turnstile>_n {P}es{Q})"

definition valid_triples_assms :: "'a triple_context \<Rightarrow> 'a triple set \<Rightarrow> 'a triple set \<Rightarrow> bool" ("_\<bullet>_ \<TTurnstile> _" 60) where
  "(\<Gamma>\<bullet>assms \<TTurnstile> specs) \<equiv> ((fst \<Gamma>,[],None) \<TTurnstile> assms) \<longrightarrow> (\<Gamma> \<TTurnstile> specs)"

definition valid_triples_assms_n :: "'a triple_context \<Rightarrow> 'a triple set \<Rightarrow> nat \<Rightarrow> 'a triple set \<Rightarrow> bool" ("_\<bullet>_ \<TTurnstile>'_ _ _" 60) where
  "(\<Gamma>\<bullet>assms \<TTurnstile>_n specs) \<equiv> ((fst \<Gamma>,[],None) \<TTurnstile>_n assms) \<longrightarrow> (\<Gamma> \<TTurnstile>_n specs)"

lemmas valid_triple_defs = valid_triple_def valid_triples_def valid_triples_assms_def
                           valid_triple_n_def valid_triples_n_def valid_triples_assms_n_def

definition ass_conseq :: "'a ass \<Rightarrow> 'a ass \<Rightarrow> v list \<Rightarrow> heap \<Rightarrow> 'a var_st \<Rightarrow> bool" where
  "ass_conseq P P' vcs h st \<equiv> (ass_stack_len P \<le> ass_stack_len P' \<and> (ass_sat P vcs h st \<longrightarrow> ass_sat P' vcs h st))"

lemma extend_context_res_wf:
  assumes "res_wf lvar_st' (fs,[],None) res locs' s' hf vcsf Q"
  shows "res_wf lvar_st' (fs,ls,rs) res locs' s' hf vcsf Q"
  using assms
  unfolding res_wf_def
  by (auto split: res_b.splits)

lemma extend_context_res_wf_value_trap:
  assumes "res_wf lvar_st' (fs,ls,rs) res locs' s' hf vcsf Q"
          "\<exists>rvs. res = RValue rvs \<or> res = RTrap"
  shows "res_wf lvar_st' (fs,ls',rs') res locs' s' hf vcsf Q"
  using assms
  unfolding res_wf_def
  by (auto split: res_b.splits)

lemma ex_lab:"\<exists>l. lab = ass_stack_len l"
  using ass_stack_len.simps(1)
  by (metis Ex_list_of_length)

lemma ex_labs:"\<exists>ls. labs = map ass_stack_len ls"
  using ex_lab
  by (simp add: ex_lab ex_map_conv)

lemma ex_ret:"\<exists>rs. ret = map_option ass_stack_len rs"
  using ex_lab
  by (metis not_Some_eq option.simps(8) option.simps(9))

lemma res_wf_valid_triple_n_intro:
  assumes "\<Gamma> \<Turnstile>_k {P}es{Q}"
          "ass_wf lvar_st ret \<Gamma> labs locs s hf st h vcs P"
          "((s,locs,($$*vcsf)@($$*vcs)@es) \<Down>k{(labs@labsf,case_ret ret retf,i)} (s',locs', res))"
  shows "res_wf lvar_st \<Gamma> res locs' s' hf vcsf Q"
  using assms
  unfolding valid_triple_n_def
  by blast

lemma res_wf_valid_triple_n_intro_tight:
  assumes "\<Gamma> \<Turnstile>_k {P}es{Q}"
          "ass_wf lvar_st ret \<Gamma> labs locs s hf st h vcs P"
          "((s,locs,($$*vcsf)@($$*vcs)@es) \<Down>k{(labs,ret,i)} (s',locs', res))"
  shows "res_wf lvar_st \<Gamma> res locs' s' hf vcsf Q"
  using res_wf_valid_triple_n_intro[OF assms(1,2), of vcsf "[]" None] assms(3)
  by fastforce

lemma res_wf_valid_triple_n_not_rvalue:
  assumes "res_wf lvar_st \<Gamma> res locs s hf vcsf Q"
          "\<nexists>vs. res = RValue vs"
  shows "res_wf lvar_st \<Gamma> res locs s hf vcsf Q'"
  using assms
  unfolding res_wf_def
  by (cases res) auto

lemma extend_context_call:
  assumes "(fs,ls,rs) \<Turnstile>_n {P} [$Call j] {Q}"
  shows "(fs,ls',rs') \<Turnstile>_n {P} [$Call j] {Q}"
proof -
  {
    fix vcs h st s locs labs labsf ret retf lvar_st hf vcsf s' locs' res
    assume local_assms:"ass_wf lvar_st ret (fs, ls', rs') labs locs s hf st h vcs P"
                       "(s, locs, ($$* vcsf) @ ($$* vcs) @ [$Call j]) \<Down>n{(labs@labsf, case_ret ret retf, i)} (s', locs', res)"
    obtain ret' labs' where "ass_wf lvar_st ret' (fs, ls, rs) labs' locs s hf st h vcs P"
      using local_assms(1)
      unfolding ass_wf_def reifies_s_def reifies_lab_def reifies_ret_def
      by fastforce
    moreover
    have "(s, locs, ($$* vcsf) @ ($$* vcs) @ [$Call j]) \<Down>n{(labs'@labsf, case_ret ret' retf, i)} (s', locs', res)"
      by (metis append_assoc calln_context local_assms(2) map_append)
    ultimately
    have "res_wf lvar_st (fs, ls, rs) res locs' s' hf vcsf Q"
      using assms local_assms(2)
      unfolding valid_triple_n_def
      by fastforce
    hence "res_wf lvar_st (fs, ls', rs') res locs' s' hf vcsf Q"
      using extend_context_res_wf_value_trap call_value_trap local_assms(2)
      by (metis (no_types, lifting) append_assoc map_append)
  }
  thus ?thesis
    unfolding valid_triple_n_def
    by blast
qed

lemma reifies_func_ind:
  assumes "reifies_func (funcs s) (inst.funcs i) fs"
          "j < length fs"
  shows "sfunc s i j = fs!j"
  using assms
  unfolding reifies_func_def
  by (simp add: list_all2_conv_all_nth sfunc_def sfunc_ind_def)

lemma valid_triples_n_emp: "\<Gamma> \<TTurnstile>_n {}"
  unfolding valid_triples_n_def
  by blast

lemma res_wf_conseq:
  assumes "res_wf l_st (fs,ls,rs) res locs' s' hf vcsf P"
          "\<forall>vs h v_st. (list_all2 (\<lambda>L L'. ass_conseq L L' vs h v_st) ls ls')"
          "\<forall>vs h v_st. (rel_option (\<lambda>R R'. ass_conseq R R' vs h v_st) rs rs')"
          "\<forall>vs h v_st. (ass_sat P vs h v_st \<longrightarrow> ass_sat P' vs h v_st)"
  shows "res_wf l_st (fs,ls',rs') res locs' s' hf vcsf P'"
proof (cases res)
  case (RValue x1)
  thus ?thesis
    using assms
    unfolding res_wf_def
    apply simp
    apply metis
    done
next
  case (RBreak x21 x22)
  thus ?thesis
    using assms
    unfolding res_wf_def
    apply (simp add: ass_conseq_def)
    apply (metis (no_types, lifting) list_all2_conv_all_nth)
    done
next
  case (RReturn x3)
  thus ?thesis
    using assms(1,3)
    unfolding res_wf_def
    apply (cases rs; cases rs')
    apply (simp_all add: ass_conseq_def)
    apply blast
    done
next
  case RTrap
  thus ?thesis
    using assms
    unfolding res_wf_def
    by simp
qed

lemma stack_ass_sat_len:
  assumes "ass_sat P vcs h st"
  shows "length vcs = ass_stack_len P"
  using assms
proof (induction rule: ass_sat.induct)
  case (1 St H ves h v_st)
  thus ?case
    apply (simp add: stack_ass_sat_def)
    apply (metis list_all2_lengthD)
    done
qed auto

lemma stack_ass_sat_len1:
  assumes "ass_sat P vcs h st"
          "ass_sat P vcs' h st"
  shows "length vcs = length vcs'"
  using stack_ass_sat_len[OF assms(1)] stack_ass_sat_len[OF assms(2)]
  by simp

lemma ass_sat_len_eq_lab:
  assumes "(list_all2 (\<lambda>L L'. ass_conseq L L' vcs h st) ls ls')"
  shows "(list_all2 (\<lambda>L L'. ((\<not>ass_sat L vcs h st \<and> (ass_stack_len L \<le> ass_stack_len L')) \<or> (ass_stack_len L = ass_stack_len L'))) ls ls')"
  using assms
  unfolding ass_conseq_def list_all2_conv_all_nth
  by (metis stack_ass_sat_len)

lemma ass_sat_len_eq_ret:
  assumes "(rel_option (\<lambda>R R'. ass_conseq R R' vcs h st) rs rs')"
  shows "(rel_option (\<lambda>R R'. ((\<not>ass_sat R vcs h st \<and> (ass_stack_len R \<le> ass_stack_len R')) \<or> (ass_stack_len R = ass_stack_len R'))) rs rs')"
  using assms
  unfolding ass_conseq_def
  apply (cases rs; cases rs')
  apply simp_all
  apply (metis stack_ass_sat_len)
  done

lemma ass_wf_conseq1:
  assumes "ass_wf lvar_st ret (fs,ls,rs) labs locs s hf st h vcs P"
          "(ass_sat P vcs h st \<longrightarrow> ass_sat P' vcs h st)"
  shows "ass_wf lvar_st ret (fs,ls,rs) labs locs s hf st h vcs P'"
  using assms
  unfolding ass_wf_def
  by (auto simp add: reifies_lab_def reifies_ret_def)

lemma rel_option_to_eq_map_option:
  assumes
    "rel_option f x y" and
    "\<And>a b. f a b \<Longrightarrow> g a = g b"
  shows "map_option g x = map_option g y"
  using assms
  by (induction x y rule: option.rel_induct; simp)

lemma list_all2_to_eq_map:
  assumes
    "list_all2 f xs ys" and
    "\<And>a b. f a b \<Longrightarrow> g a = g b"
  shows "map g xs = map g ys"
  using assms
  by (induction xs ys rule: list.rel_induct; simp)

lemma ass_wf_conseq2:
  assumes "ass_wf lvar_st ret (fs,ls,rs) labs locs s hf st h vcs P"
          "(list_all2 (\<lambda>L L'. (ass_stack_len L = ass_stack_len L') \<and> ass_conseq L L' vcs h st) ls ls')"
          "(rel_option (\<lambda>R R'. (ass_stack_len R = ass_stack_len R') \<and> ass_conseq R R' vcs h st) rs rs')"
        shows "ass_wf lvar_st ret (fs,ls',rs') labs locs s hf st h vcs P"
proof -
  show ?thesis
    using assms
    unfolding ass_wf_def ass_conseq_def
    unfolding reifies_lab_def reifies_ret_def
    by (auto intro: list_all2_to_eq_map rel_option_to_eq_map_option)
qed

lemma valid_triple_assms_n_label_false:
  assumes "res_wf lvar_st (fs,ls,rs) res locs' s' hf vcsf Q"
          "j \<ge> length ls \<or> (\<forall>vcs h st. \<not>ass_sat (ls!j) vcs h st)"
  shows "res \<noteq> RBreak j rvs"
  using assms
  unfolding res_wf_def
  by (auto split: res_b.splits)

lemma valid_triple_assms_n_return_false:
  assumes "res_wf lvar_st (fs,ls,rs) res locs' s' hf vcsf Q"
          "rs = None \<or> (\<forall>vcs h st. \<not>ass_sat (the rs) vcs h st)"
  shows "res \<noteq> RReturn rvs"
  using assms
  unfolding res_wf_def
  by (auto split: res_b.splits)

lemma valid_triple_n_conseq:
  assumes "(fs,ls,rs) \<Turnstile>_n {P'} es {Q'}"
          "\<forall>vs h v_st. (list_all2 (\<lambda>L L'. ass_conseq L L' vs h v_st) ls ls') \<and>
                       (rel_option (\<lambda>R R'. ass_conseq R R' vs h v_st) rs rs') \<and>
                       (ass_sat P vs h v_st \<longrightarrow> ass_sat P' vs h v_st) \<and>
                       (ass_sat Q' vs h v_st \<longrightarrow> ass_sat Q vs h v_st)"
  shows "(fs,ls',rs') \<Turnstile>_n {P} es {Q}"
proof -
  {
    fix vcs h st s locs labs' labsf' ret' retf' lvar_st hf vcsf s' locs' res
    assume local_assms:"ass_wf lvar_st ret' (fs,ls',rs') labs' locs s hf st h vcs P"
                       "(s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs'@labsf', case_ret ret' retf', i)} (s', locs', res)"
    have "ass_wf lvar_st ret' (fs,ls',rs') labs' locs s hf st h vcs P'"
      using ass_wf_conseq1[OF local_assms(1)] assms(2)
      by blast
    then obtain labs ret where labs_def:"ass_wf lvar_st ret (fs,ls,rs) labs locs s hf st h vcs P'"
                                        "length labs = length labs'"
                                        "length ls = length ls'"
                                        "length (labs'@labsf') = length (labs@labsf')"
      unfolding ass_wf_def reifies_lab_def reifies_ret_def
      by simp (meson assms(2) list_all2_conv_all_nth)
    have "res_wf lvar_st (fs,ls',rs') res locs' s' hf vcsf Q"
    proof (cases res)
      case (RValue x1)
      hence "(s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs@labsf', case_ret ret retf', i)} (s', locs', res)"
        using reduce_to_n_not_break_n_return[OF local_assms(2)] labs_def(2)
        by simp
      hence "res_wf lvar_st (fs,ls,rs) res locs' s' hf vcsf Q'"
        using assms(1) labs_def
        unfolding valid_triple_n_def
        by fastforce
      thus ?thesis
        using assms(2) RValue
        unfolding res_wf_def
        by fastforce
    next
      case (RBreak ib vbs)
      have 0:"ib < length (labs'@labsf')"
        using local_assms(2) RBreak reduce_to_n_break_n
        by fastforce
      have b0:"(s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs'@labsf', case_ret ret' retf', i)} (s', locs', RBreak ib vbs)"
        using local_assms(2) RBreak
        by simp
      show ?thesis
      proof (cases "labs!ib \<noteq> labs'!ib")
        case True
        have "\<And>vs h v_st. list_all2 (\<lambda>L L'. \<not> ass_sat L vs h v_st \<and> ass_stack_len L \<le> ass_stack_len L' \<or> ass_stack_len L = ass_stack_len L') ls ls'"
          using ass_sat_len_eq_lab assms(2)
          by blast
        hence 1:"\<And>vcs h st. ib < length labs' \<Longrightarrow> \<not> ass_sat (ls!ib) vcs h st"
                "ib < length labs' \<Longrightarrow> labs!ib \<le> labs'!ib"
                "ib < length labs' \<Longrightarrow> labs!ib = ass_stack_len (ls!ib)"
                "ib < length labs' \<Longrightarrow> labs'!ib = ass_stack_len (ls'!ib)"
          using True 0 labs_def local_assms(1)
          unfolding list_all2_conv_all_nth ass_wf_def reifies_lab_def
          by fastforce+
        obtain vbs' where 2:"((s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs@labsf', case_ret ret retf', i)} (s', locs', RBreak ib vbs'))"
          using reduce_to_n_break_n2[OF reduce_to_n_not_return[OF b0] labs_def(4)] 0 1(2)
          by simp (metis True append_Nil2 labs_def(2) nth_append)
        thus ?thesis
          using res_wf_valid_triple_n_intro[OF assms(1) labs_def(1) 2] 1(1) RBreak
          unfolding res_wf_def
          by (simp split: res_b.splits) (metis True append_Nil2 labs_def(2) nth_append)
      next
        case False
        hence "(s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs@labsf', case_ret ret retf', i)} (s', locs', res)"
          using reduce_to_n_not_break_n_return[OF local_assms(2), of "labs@labsf'"] RBreak
                labs_def(2)
          by simp (metis nth_append)
        hence "res_wf lvar_st (fs,ls,rs) res locs' s' hf vcsf Q'"
          using assms(1) labs_def
          unfolding valid_triple_n_def
          by fastforce
        thus ?thesis
          using assms(2) RBreak
          unfolding res_wf_def ass_conseq_def
          by simp (metis (mono_tags, lifting) list_all2_conv_all_nth)
      qed
    next
      case (RReturn vrs)
      show ?thesis
      proof (cases "(pred_option (\<lambda>r_r. (case_ret ret retf') \<noteq> Some r_r) (case_ret ret' retf'))")
        case True
        obtain r_r r_r' rs'_r rs_r where r_r'_def:"ret = Some r_r"
                                                  "ret' = Some r_r'"
                                                  "rs' = Some rs'_r"
                                                  "rs = Some rs_r"

          using reduce_to_n_return1 local_assms(1,2) RReturn assms(2) labs_def True
          unfolding ass_wf_def reifies_ret_def
          by (fastforce split: option.splits)
        have "ass_stack_len rs_r \<noteq> ass_stack_len rs'_r"
          using local_assms(1) labs_def r_r'_def True
          unfolding ass_wf_def reifies_ret_def
          by simp
        moreover
        have "\<And>vs h v_st. rel_option (\<lambda>R R'. (\<not>ass_sat R vs h v_st \<and> (ass_stack_len R \<le> ass_stack_len R')) \<or> ass_stack_len R = ass_stack_len R') rs rs'"
          using ass_sat_len_eq_ret assms(2)
          by blast
        ultimately
        have 1:"\<And>vcs h st. \<not> ass_sat rs_r vcs h st \<and> ass_stack_len rs_r \<le> ass_stack_len rs'_r"
          using r_r'_def
          by simp
        hence "r_r \<le> r_r'"
          using r_r'_def local_assms(1)
          unfolding ass_wf_def reifies_ret_def
          by (metis (mono_tags, lifting) ass_wf_def eq_snd_iff labs_def(1) option.inject option.map(2) reifies_ret_def)
        then obtain vrs' where "((s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs@labsf', case_ret ret retf', i)} (s', locs', RReturn vrs'))"
          using local_assms(2) RReturn reduce_to_n_return2 reduce_to_n_not_break_n r_r'_def(1,2)
          by (metis labs_def(4) option.simps(5) res_b.distinct(7))
        thus ?thesis
          using assms(1) labs_def 1 r_r'_def RReturn
          unfolding valid_triple_n_def res_wf_def
          apply (cases "hf")
          apply (cases "st")
          apply (cases "h")
          apply (simp split: res_b.splits option.splits)
          apply metis
          done
      next
        case False
        hence "(s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs@labsf', case_ret ret retf', i)} (s', locs', res)"
          using reduce_to_n_not_break_n_return[OF local_assms(2), of "labs@labsf'" "case_ret ret retf'"] RReturn labs_def(2)
          by auto
        hence "res_wf lvar_st (fs,ls,rs) res locs' s' hf vcsf Q'"
          using assms(1) labs_def
          unfolding valid_triple_n_def
          by fastforce
        thus ?thesis
          using assms(2) RReturn
          unfolding res_wf_def ass_conseq_def
          by simp (metis (no_types, lifting) option.rel_cases option.sel)
      qed
    next
      case RTrap
      hence "(s, locs, ($$*vcsf)@($$*vcs)@es) \<Down>n{(labs@labsf', case_ret ret retf', i)} (s', locs', res)"
        using reduce_to_n_not_break_n_return[OF local_assms(2)] labs_def(2)
        by auto
      hence "res_wf lvar_st (fs,ls,rs) res locs' s' hf vcsf Q'"
        using assms(1) labs_def
        unfolding valid_triple_n_def
        by fastforce
      thus ?thesis
        using assms(2) RTrap
        unfolding res_wf_def
        by fastforce
    qed
  }
  thus ?thesis
    unfolding valid_triple_n_def
    by blast
qed

lemma valid_triple_assms_n_conseq:
  assumes "((fs,ls,rs)\<bullet>assms \<TTurnstile>_n {(P',es,Q')})"
          "\<forall>vs h v_st. (list_all2 (\<lambda>L L'. ass_conseq L L' vs h v_st) ls ls') \<and>
                       (rel_option (\<lambda>R R'. ass_conseq R R' vs h v_st) rs rs') \<and>
                       (ass_sat P vs h v_st \<longrightarrow> ass_sat P' vs h v_st) \<and>
                       (ass_sat Q' vs h v_st \<longrightarrow> ass_sat Q vs h v_st)"
  shows "((fs,ls',rs')\<bullet>assms \<TTurnstile>_n {(P,es,Q)})"
  using valid_triple_n_conseq[OF _ assms(2)] assms(1)
  unfolding valid_triples_assms_n_def valid_triples_n_def
  by simp
end

end