(*  Title:      HOL/Auth/n_german_lemma_inv__48_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__48_on_rules imports n_german_lemma_on_inv__48
begin
section{*All lemmas on causal relation between inv__48*}
lemma lemma_inv__48_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__48  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqEIVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqES  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqESVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReq N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvEVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvSVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__48) done
    }

    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__48) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory LaunchburyUnBH
imports LaunchburyStacked LaunchburyNoBH
begin

lemma delete_append[simp]: "delete x (al1@al2) = delete x al1 @ delete x al2"
  by (simp add: AList.delete_eq)

lemma forgetBH:
  assumes "\<Gamma> : \<Gamma>' \<Down> \<Delta> : \<Delta>'"
  assumes "distinctVars (\<Gamma>' @ \<Gamma>)"
  shows "\<Gamma>' @ \<Gamma> [\<Down>] \<Delta>' @ \<Delta>"
using assms
proof (induct rule: reds_distinct_ind)
case (Lambda \<Gamma> x y e \<Gamma>')
  show ?case
    unfolding append_Cons
    apply (rule LaunchburyNoBH.Lambda)
    done
next
case (Application n \<Gamma> \<Gamma>' \<Delta> \<Delta>' x e y \<Theta> \<Theta>' z e')
  show ?case
  unfolding append_Cons
  proof(rule LaunchburyNoBH.Application)
    show "atom n \<sharp> (\<Gamma>' @ \<Gamma>, delete x ((x, App (Var n) y) # \<Delta>' @ \<Delta>), x, e, y, \<Theta>' @ \<Theta>, z)"
      and "atom z \<sharp> (\<Gamma>' @ \<Gamma>, delete x ((x, App (Var n) y) # \<Delta>' @ \<Delta>), x, e, y, \<Theta>' @ \<Theta>)"
      using Application
      by (auto simp add: fresh_Pair fresh_Cons fresh_append eqvt_fresh_cong2[where f = delete, OF delete_eqvt])
    show "(n, e) # (x, App (Var n) y) # \<Gamma>' @ \<Gamma> [\<Down>] (n, Lam [z]. e') # (x, App (Var n) y) # \<Delta>' @ \<Delta>"
      by (rule Application(9)[unfolded append_Cons])

    have "x \<notin> heapVars (\<Delta>' @ \<Delta>)"
      using Application(6)
      by (simp add: distinctVars_Cons)
    hence [simp]:"delete x \<Delta>' = \<Delta>'"  "delete x \<Delta> = \<Delta>"
      by (auto intro: delete_no_there)

    show "(x, e'[z::=y]) # delete x ((x, App (Var n) y) # \<Delta>' @ \<Delta>) [\<Down>] \<Theta>' @ \<Theta>"
      using Application(11)
      by simp
  qed
next
case (Variable y e \<Gamma> x \<Gamma>' z \<Delta>' \<Delta>)
  have [simp]:"x \<noteq> y"
    using Variable(3)
    by (auto simp add: distinctVars_Cons)
  note this[symmetric,simp]

  have "y \<notin> heapVars \<Gamma>'"
    using Variable(3)
    by (auto simp add: distinctVars_Cons)
  hence [simp]: "delete y \<Gamma>' = \<Gamma>'"
    by (rule delete_no_there)

  have "x \<notin> heapVars \<Delta>'"
    using Variable(4)
    by (auto simp add: distinctVars_Cons)
  hence [simp]: "delete x \<Delta>' = \<Delta>'"
    by (rule delete_no_there)

  have "x \<notin> heapVars \<Delta>"
    using Variable(4)
    by (auto simp add: distinctVars_Cons)
  hence [simp]: "delete x \<Delta> = \<Delta>"
    by (rule delete_no_there)

  have "((x, Var y) # \<Gamma>') @ \<Gamma> [\<Down>] (x, z) # delete x (((x, Var y) # \<Delta>') @ (y, z) # \<Delta>)"
  unfolding append_Cons
  proof (rule LaunchburyNoBH.Variable)
    show "(y, e) \<in> set ((x, Var y) # \<Gamma>' @ \<Gamma>)"
      using Variable(1) by simp
    show "(y, e) # delete y ((x, Var y) # \<Gamma>' @ \<Gamma>) [\<Down>] (y, z) # (((x, Var y) # \<Delta>') @ \<Delta>)"
      using Variable(7) by simp

    show "set ((x, Var y) # \<Delta>' @ (y, z) # \<Delta>) = set ((y, z) # ((x, Var y) # \<Delta>') @ \<Delta>)"
      by auto
  qed
  thus ?case
    unfolding append_Cons
    by simp
next
case (Let as \<Gamma> x body \<Gamma>' \<Delta>' \<Delta>)
  show ?case
  unfolding append_Cons
  proof (rule LaunchburyNoBH.Let)
    show "set (bn as) \<sharp>* (\<Gamma>' @ \<Gamma>, x, Terms.Let as body)"
      using Let(1) by (simp add: fresh_star_Pair fresh_star_append)
    show "distinctVars (asToHeap as)" by fact
    show " (x, body) # \<Gamma>' @ asToHeap as  @ \<Gamma> [\<Down>] \<Delta>' @ \<Delta>"
      using Let(7) by simp
    show "set (\<Gamma>' @ asToHeap as @ \<Gamma>) = set (asToHeap as @ \<Gamma>' @ \<Gamma>)"
      by auto
qed

qed


theory Common_Primitive_Syntax
imports "../Datatype_Selectors"
        IpAddresses
        Simple_Firewall.Iface
        L4_Protocol_Flags Ports Tagged_Packet Conntrack_State
begin

section\<open>Primitive Matchers: Interfaces, IP Space, Layer 4 Ports Matcher\<close>

text\<open>Primitive Match Conditions which only support interfaces, IPv4 addresses,  layer 4 protocols, and layer 4 ports.
\<close>

context
  notes [[typedef_overloaded]]
begin
  datatype 'i common_primitive =
    is_Src: Src (src_sel: "'i::len ipt_iprange") |
    is_Dst: Dst (dst_sel: "'i::len ipt_iprange") |
    is_Iiface: IIface (iiface_sel: iface) |
    is_Oiface: OIface (oiface_sel: iface) |
    is_Prot: Prot (prot_sel: protocol) |
    is_Src_Ports: Src_Ports (src_ports_sel: ipt_l4_ports) |
    is_Dst_Ports: Dst_Ports (dst_ports_sel: ipt_l4_ports) |
    is_MultiportPorts: MultiportPorts (multiportports_sel: ipt_l4_ports) |
    is_L4_Flags: L4_Flags (l4_flags_sel: ipt_tcp_flags) |
    is_CT_State: CT_State (ct_state_sel: "ctstate set") |
    is_Extra: Extra (extra_sel: string)
end

lemma wf_disc_sel_common_primitive:
      "wf_disc_sel (is_Src_Ports, src_ports_sel) Src_Ports"
      "wf_disc_sel (is_Dst_Ports, dst_ports_sel) Dst_Ports"
      "wf_disc_sel (is_Src, src_sel) Src"
      "wf_disc_sel (is_Dst, dst_sel) Dst"
      "wf_disc_sel (is_Iiface, iiface_sel) IIface"
      "wf_disc_sel (is_Oiface, oiface_sel) OIface"
      "wf_disc_sel (is_Prot, prot_sel) Prot"
      "wf_disc_sel (is_L4_Flags, l4_flags_sel) L4_Flags"
      "wf_disc_sel (is_CT_State, ct_state_sel) CT_State"
      "wf_disc_sel (is_Extra, extra_sel) Extra"
      "wf_disc_sel (is_MultiportPorts, multiportports_sel) MultiportPorts"
  by(simp_all add: wf_disc_sel.simps)

  \<comment> \<open>Example for a packet again:\<close>
  value "\<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'',
          p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (173,194,112,111),
          p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {TCP_ACK},
          p_payload = ''GET / HTTP/1.0'',
          p_tag_ctstate = CT_Established\<rparr> :: 32 tagged_packet"

end


theory Friend
  imports
    "Friend_Value_Setup"
    "Bounded_Deducibility_Security.Compositional_Reasoning"
begin

subsection \<open>Declassification bound\<close>

context Friend
begin

fun T :: "(state,act,out) trans \<Rightarrow> bool"
where "T trn = False"

text \<open>The bound has the same ``while-or-last-before'' shape as the dynamic version of
the issuer bound for post confidentiality (Section~\ref{sec:dynamic-post-issuer}),
alternating between phases with open (\<open>BO\<close>) or closed (\<open>BC\<close>) access to the
confidential information.

The access window is initially open, because the two users are known not to exist when the system
is initialized, so there cannot be friendship between them.

The bound also incorporates the static knowledge that the friendship status alternates between
\<open>False\<close> and \<open>True\<close>.\<close>

fun alternatingFriends :: "value list \<Rightarrow> bool \<Rightarrow> bool" where
  "alternatingFriends [] _ = True"
| "alternatingFriends (FrVal st # vl) st' \<longleftrightarrow> st' = (\<not>st) \<and> alternatingFriends vl st"
| "alternatingFriends (OVal _ # vl) st = alternatingFriends vl st"

inductive BO :: "value list \<Rightarrow> value list \<Rightarrow> bool"
and BC :: "value list \<Rightarrow> value list \<Rightarrow> bool"
where
 BO_FrVal[simp,intro!]:
  "BO (map FrVal fs) (map FrVal fs)"
|BO_BC[intro]:
  "BC vl vl1 \<Longrightarrow>
   BO (map FrVal fs @ OVal False # vl) (map FrVal fs @ OVal False # vl1)"
(*  *)
|BC_FrVal[simp,intro!]:
  "BC (map FrVal fs) (map FrVal fs1)"
|BC_BO[intro]:
  "BO vl vl1 \<Longrightarrow> (fs = [] \<longleftrightarrow> fs1 = []) \<Longrightarrow> (fs \<noteq> [] \<Longrightarrow> last fs = last fs1) \<Longrightarrow>
   BC (map FrVal fs  @ OVal True # vl)
      (map FrVal fs1 @ OVal True # vl1)"

definition "B vl vl1 \<equiv> BO vl vl1 \<and> alternatingFriends vl1 False"

lemma BO_Nil_Nil: "BO vl vl1 \<Longrightarrow> vl = [] \<Longrightarrow> vl1 = []"
by (cases rule: BO.cases) auto

no_notation relcomp (infixr "O" 75)

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

subsection \<open>Unwinding proof\<close>

(* helper *) lemma toggle_friends12_True:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] [] [] []"
    and nf12: "\<not>friends12 s"
obtains al oul
where "sstep s al = (oul, createFriend s UID1 (pass s UID1) UID2)"
  and "al \<noteq> []" and "eqButUID s (createFriend s UID1 (pass s UID1) UID2)"
  and "friends12 (createFriend s UID1 (pass s UID1) UID2)"
  and "O (traceOf s al) = []" and "V (traceOf s al) = [FrVal True]"
proof cases
  assume "UID1 \<in>\<in> pendingFReqs s UID2 \<or> UID2 \<in>\<in> pendingFReqs s UID1"
  then show thesis proof
    assume pFR: "UID1 \<in>\<in> pendingFReqs s UID2"
    let ?a = "Cact (cFriend UID2 (pass s UID2) UID1)"
    let ?s' = "createFriend s UID1 (pass s UID1) UID2"
    let ?trn = "Trans s ?a outOK ?s'"
    have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2
      unfolding createFriend_sym[of "s" "UID1" "pass s UID1" "UID2" "pass s UID2"]
      by (auto simp add: c_defs)
    moreover then have "\<phi> ?trn" and "f ?trn = FrVal True" and "friends12 ?s'"
      by (auto simp: c_defs friends12_def)
    moreover have "\<not>\<gamma> ?trn" using UID1_UID2_UIDs by auto
    ultimately show thesis using nf12 rs
      by (intro that[of "[?a]" "[outOK]"]) (auto intro: Cact_cFriend_step_eqButUID)
  next
    assume pFR: "UID2 \<in>\<in> pendingFReqs s UID1"
    let ?a = "Cact (cFriend UID1 (pass s UID1) UID2)"
    let ?s' = "createFriend s UID1 (pass s UID1) UID2"
    let ?trn = "Trans s ?a outOK ?s'"
    have step: "step s ?a = (outOK, ?s')" using IDs pFR UID1_UID2 by (auto simp add: c_defs)
    moreover then have "\<phi> ?trn" and "f ?trn = FrVal True" and "friends12 ?s'"
      by (auto simp: c_defs friends12_def)
    moreover have "\<not>\<gamma> ?trn" using UID1_UID2_UIDs by auto
    ultimately show thesis using nf12 rs
      by (intro that[of "[?a]" "[outOK]"]) (auto intro: Cact_cFriend_step_eqButUID)
  qed
next
  assume pFR: "\<not>(UID1 \<in>\<in> pendingFReqs s UID2 \<or> UID2 \<in>\<in> pendingFReqs s UID1)"
  let ?a1 = "Cact (cFriendReq UID2 (pass s UID2) UID1 emptyRequestInfo)"
  let ?s1 = "createFriendReq s UID2 (pass s UID2) UID1 emptyRequestInfo"
  let ?trn1 = "Trans s ?a1 outOK ?s1"
  let ?a2 = "Cact (cFriend UID1 (pass ?s1 UID1) UID2)"
  let ?s2 = "createFriend ?s1 UID1 (pass ?s1 UID1) UID2"
  let ?trn2 = "Trans ?s1 ?a2 outOK ?s2"
  have eFR: "e_createFriendReq s UID2 (pass s UID2) UID1 emptyRequestInfo" using IDs pFR nf12
    using reach_friendIDs_symmetric[OF rs]
    by (auto simp add: c_defs friends12_def)
  then have step1: "step s ?a1 = (outOK, ?s1)" by auto
  moreover then have "\<not>\<phi> ?trn1" and "\<not>\<gamma> ?trn1" using UID1_UID2_UIDs by auto
  moreover have "eqButUID s ?s1" by (intro Cact_cFriendReq_step_eqButUID[OF step1]) auto
  moreover have rs1: "reach ?s1" using step1 by (intro reach_PairI[OF rs])
  moreover have step2: "step ?s1 ?a2 = (outOK, ?s2)" using IDs by (auto simp: c_defs)
  moreover then have "\<phi> ?trn2" and "f ?trn2 = FrVal True" and "friends12 ?s2"
    by (auto simp: c_defs friends12_def)
  moreover have "\<not>\<gamma> ?trn2" using UID1_UID2_UIDs by auto
  moreover have "eqButUID ?s1 ?s2" by (intro Cact_cFriend_step_eqButUID[OF step2 rs1]) auto
  moreover have "?s2 = createFriend s UID1 (pass s UID1) UID2"
    using eFR by (intro createFriendReq_createFriend_absorb)
  ultimately show thesis using nf12 rs
    by (intro that[of "[?a1, ?a2]" "[outOK, outOK]"]) (auto intro: eqButUID_trans)
qed

(* helper *) lemma toggle_friends12_False:
assumes rs: "reach s"
    and IDs: "IDsOK s [UID1, UID2] [] [] []"
    and f12: "friends12 s"
obtains al oul
where "sstep s al = (oul, deleteFriend s UID1 (pass s UID1) UID2)"
  and "al \<noteq> []" and "eqButUID s (deleteFriend s UID1 (pass s UID1) UID2)"
  and "\<not>friends12 (deleteFriend s UID1 (pass s UID1) UID2)"
  and "O (traceOf s al) = []" and "V (traceOf s al) = [FrVal False]"
proof -
  let ?a = "Dact (dFriend UID1 (pass s UID1) UID2)"
  let ?s' = "deleteFriend s UID1 (pass s UID1) UID2"
  let ?trn = "Trans s ?a outOK ?s'"
  have step: "step s ?a = (outOK, ?s')" using IDs f12 UID1_UID2
    by (auto simp add: d_defs friends12_def)
  moreover then have "\<phi> ?trn" and "f ?trn = FrVal False" and "\<not>friends12 ?s'"
    using reach_friendIDs_symmetric[OF rs] by (auto simp: d_defs friends12_def)
  moreover have "\<not>\<gamma> ?trn" using UID1_UID2_UIDs by auto
  ultimately show thesis using f12 rs
    by (intro that[of "[?a]" "[outOK]"]) (auto intro: Dact_dFriend_step_eqButUID)
qed

definition \<Delta>0 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>0 s vl s1 vl1 \<equiv>
 eqButUID s s1 \<and> friendIDs s = friendIDs s1 \<and> open s \<and>
 BO vl vl1 \<and> alternatingFriends vl1 (friends12 s1)"

definition \<Delta>1 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>1 s vl s1 vl1 \<equiv> (\<exists>fs fs1.
 eqButUID s s1 \<and> \<not>open s \<and>
 alternatingFriends vl1 (friends12 s1) \<and>
 vl = map FrVal fs \<and> vl1 = map FrVal fs1)"

definition \<Delta>2 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>2 s vl s1 vl1 \<equiv> (\<exists>fs fs1 vlr vlr1.
 eqButUID s s1 \<and> \<not>open s \<and> BO vlr vlr1 \<and>
 alternatingFriends vl1 (friends12 s1) \<and>
 (fs = [] \<longleftrightarrow> fs1 = []) \<and>
 (fs \<noteq> [] \<longrightarrow> last fs = last fs1) \<and>
 (fs = [] \<longrightarrow> friendIDs s = friendIDs s1) \<and>
 vl =  map FrVal fs  @ OVal True # vlr \<and>
 vl1 = map FrVal fs1 @ OVal True # vlr1)"

lemma \<Delta>2_I:
assumes "eqButUID s s1" "\<not>open s" "BO vlr vlr1" "alternatingFriends vl1 (friends12 s1)"
        "fs = [] \<longleftrightarrow> fs1 = []" "fs \<noteq> [] \<longrightarrow> last fs = last fs1"
        "fs = [] \<longrightarrow> friendIDs s = friendIDs s1"
        "vl =  map FrVal fs  @ OVal True # vlr"
        "vl1 = map FrVal fs1 @ OVal True # vlr1"
shows "\<Delta>2 s vl s1 vl1"
using assms unfolding \<Delta>2_def by blast

lemma istate_\<Delta>0:
assumes B: "B vl vl1"
shows "\<Delta>0 istate vl istate vl1"
using assms unfolding \<Delta>0_def istate_def B_def open_def openByA_def openByF_def friends12_def
by auto

lemma unwind_cont_\<Delta>0: "unwind_cont \<Delta>0 {\<Delta>0,\<Delta>1,\<Delta>2}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>0 s vl s1 vl1 \<or>
                           \<Delta>1 s vl s1 vl1 \<or>
                           \<Delta>2 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and \<Delta>0: "\<Delta>0 s vl s1 vl1"
  then have rs: "reach s" and ss1: "eqButUID s s1" and fIDs: "friendIDs s = friendIDs s1"
        and os: "open s" and BO: "BO vl vl1" and aF1: "alternatingFriends vl1 (friends12 s1)"
    using reachNT_reach unfolding \<Delta>0_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof-
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof cases
        assume \<phi>: "\<phi> ?trn"
        then have vl: "vl = f ?trn # vl'" using c by (auto simp: consume_def)
        from BO have ?match proof (cases "f ?trn")
          case (FrVal fv)
            with BO vl obtain vl1' where vl1': "vl1 = f ?trn # vl1'" and BO': "BO vl' vl1'"
            proof (cases rule: BO.cases)
              case (BO_BC vl'' vl1'' fs)
                moreover with vl FrVal obtain fs' where "fs = fv # fs'" by (cases fs) auto
                ultimately show ?thesis using FrVal BO_BC vl
                  by (intro that[of "map FrVal fs' @ OVal False # vl1''"]) auto
            qed auto
            from fIDs have f12: "friends12 s = friends12 s1" unfolding friends12_def by auto
            show ?match using \<phi> step rs FrVal proof (cases rule: \<phi>E)
              case (Friend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] [] [] []"
                  using ss1 unfolding eqButUID_def by auto
                let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = createFriend s UID1 p UID2"
                  using Friend step by (auto simp: createFriend_sym)
                have ss': "eqButUID s s'" using rs step Friend
                  by (auto intro: Cact_cFriend_step_eqButUID)
                moreover then have os': "open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al \<noteq> []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal True]"
                                         and f12s1': "friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Friend unfolding f12 by (auto elim: toggle_friends12_True)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Friend(6) f12 unfolding s'
                  by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto
                ultimately have "\<Delta>0 s' vl' ?s1' vl1'"
                  using ss1 BO' aF1 unfolding \<Delta>0_def vl1' Friend(3)
                  by (auto intro: eqButUID_trans eqButUID_sym)
                then show ?match using tr1 vl1' Friend UID1_UID2_UIDs
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            next
              case (Unfriend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] [] [] []"
                  using ss1 unfolding eqButUID_def by auto
                let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = deleteFriend s UID1 p UID2"
                  using Unfriend step by (auto simp: deleteFriend_sym)
                have ss': "eqButUID s s'" using rs step Unfriend
                  by (auto intro: Dact_dFriend_step_eqButUID)
                moreover then have os': "open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al \<noteq> []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal False]"
                                         and f12s1': "\<not>friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Unfriend unfolding f12 by (auto elim: toggle_friends12_False)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: d_defs)
                ultimately have "\<Delta>0 s' vl' ?s1' vl1'"
                  using ss1 BO' aF1 unfolding \<Delta>0_def vl1' Unfriend(3)
                  by (auto intro: eqButUID_trans eqButUID_sym)
                then show ?match using tr1 vl1' Unfriend UID1_UID2_UIDs
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            qed auto
        next
          case (OVal ov)
            with BO vl obtain vl1' where vl1': "vl1 = OVal False # vl1'"
                                      and vl': "vl = OVal False # vl'"
                                      and BC: "BC vl' vl1'"
            proof (cases rule: BO.cases)
              case (BO_BC vl'' vl1'' fs)
                moreover then have "fs = []" using vl unfolding OVal by (cases fs) auto
                ultimately show thesis using vl by (intro that[of vl1'']) auto
            qed auto
            then have "f ?trn = OVal False" using vl by auto
            with \<phi> step rs show ?match proof (cases rule: \<phi>E)
              case (CloseF uid p uid')
                let ?s1' = "deleteFriend s1 uid p uid'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = deleteFriend s uid p uid'" using CloseF step by auto
                have step1: "step s1 a = (outOK, ?s1')"
                  using CloseF step ss1 fIDs unfolding eqButUID_def by (auto simp: d_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "\<not>open s'" using CloseF os unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: d_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  using CloseF(2) UID1_UID2_UIDs unfolding friends12_def d_defs by auto
                from BC have "\<Delta>1 s' vl' ?s1' vl1' \<or> \<Delta>2 s' vl' ?s1' vl1'"
                proof (cases rule: BC.cases)
                  case (BC_FrVal fs fs1)
                    then show ?thesis using aF1 os' fIDs' f12s1 s's1' unfolding \<Delta>1_def vl1' by auto
                next
                  case (BC_BO vlr vlr1 fs fs1)
                    then have "\<Delta>2 s' vl' ?s1' vl1'" using s's1' os' aF1 f12s1 fIDs' unfolding vl1'
                      by (intro \<Delta>2_I[of _ _ _ _ _ fs fs1]) auto
                    then show ?thesis ..
                qed
                moreover have "open s1" "\<not>open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "\<phi> ?trn1" unfolding CloseF by auto
                ultimately show ?match using step1 vl1' CloseF UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def)
            next
              case (CloseA uid p uid' p')
                let ?s1' = "createUser s1 uid p uid' p'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = createUser s uid p uid' p'" using CloseA step by auto
                have step1: "step s1 a = (outOK, ?s1')"
                  using CloseA step ss1 unfolding eqButUID_def by (auto simp: c_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "\<not>open s'" using CloseA os unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: c_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  unfolding friends12_def by (auto simp: c_defs)
                from BC have "\<Delta>1 s' vl' ?s1' vl1' \<or> \<Delta>2 s' vl' ?s1' vl1'"
                proof (cases rule: BC.cases)
                  case (BC_FrVal fs fs1)
                    then show ?thesis using aF1 os' fIDs' f12s1 s's1' unfolding \<Delta>1_def vl1' by auto
                next
                  case (BC_BO vlr vlr1 fs fs1)
                    then have "\<Delta>2 s' vl' ?s1' vl1'" using s's1' os' aF1 f12s1 fIDs' unfolding vl1'
                      by (intro \<Delta>2_I[of _ _ _ _ _ fs fs1]) auto
                    then show ?thesis ..
                qed
                moreover have "open s1" "\<not>open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "\<phi> ?trn1" unfolding CloseA by auto
                ultimately show ?match using step1 vl1' CloseA UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vl1']) (auto simp: consume_def)
            qed auto
        qed
        then show "?match \<or> ?ignore" ..
      next
        assume n\<phi>: "\<not>\<phi> ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_\<phi>[OF step] step_friends12_\<phi>[OF step] by auto
        have vl': "vl' = vl" using n\<phi> c by (auto simp: consume_def)
        show ?thesis proof (cases "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and>
                                   a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
                                   a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and>
                                   a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            have fIDs': "friendIDs s' = friendIDs s1'"
              using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 True fIDs] .
            from True n\<phi> have n\<phi>': "\<not>\<phi> ?trn1" using eqButUID_step_\<phi>[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
              using step_friends12_\<phi>[OF step1] by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            then have "\<Delta>0 s' vl' s1' vl1" using os fIDs' aF1 BO
              unfolding \<Delta>0_def os' f12s1' vl' by auto
            then have ?match
              using step1 n\<phi>' fIDs eqButUID_step_\<gamma>_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match \<or> ?ignore" ..
        next
          case False
            with n\<phi> have "ou \<noteq> outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using \<Delta>0 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match \<or> ?ignore" ..
        qed
      qed
    qed
    then show ?thesis using BO BO_Nil_Nil by auto
  qed
qed

lemma unwind_cont_\<Delta>1: "unwind_cont \<Delta>1 {\<Delta>1, \<Delta>0}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>1 s vl s1 vl1 \<or> \<Delta>0 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and 1: "\<Delta>1 s vl s1 vl1"
  from rsT have rs: "reach s" by (intro reachNT_reach)
  from 1 obtain fs fs1
  where ss1: "eqButUID s s1" and os: "\<not>open s"
    and aF1: "alternatingFriends vl1 (friends12 s1)"
    and vl: "vl = map FrVal fs" and vl1: "vl1 = map FrVal fs1"
    unfolding \<Delta>1_def by auto
  from os have IDs: "IDsOK s [UID1, UID2] [] [] []" unfolding open_defs by auto
  then have IDs1: "IDsOK s1 [UID1, UID2] [] [] []" using ss1 unfolding eqButUID_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof cases
    assume fs1: "fs1 = []"
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof cases
        assume \<phi>: "\<phi> ?trn"
        with vl c obtain fv fs' where vl': "vl' = map FrVal fs'" and fv: "f ?trn = FrVal fv"
          by (cases fs) (auto simp: consume_def)
        from \<phi> step rs fv have ss': "eqButUID s s'"
          by (elim \<phi>E) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID)
        then have "\<not>open s'" using os by (auto simp: eqButUID_open_eq)
        moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans)
        ultimately have "\<Delta>1 s' vl' s1 vl1" using aF1 unfolding \<Delta>1_def vl' vl1 by auto
        moreover have "\<not>\<gamma> ?trn" using \<phi> step rs fv UID1_UID2_UIDs by (elim \<phi>E) auto
        ultimately have ?ignore by (intro ignoreI) auto
        then show "?match \<or> ?ignore" ..
      next
        assume n\<phi>: "\<not>\<phi> ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_\<phi>[OF step] step_friends12_\<phi>[OF step] by auto
        have vl': "vl' = vl" using n\<phi> c by (auto simp: consume_def)
        show ?thesis proof (cases "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and>
                                   a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
                                   a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and>
                                   a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            from True n\<phi> have n\<phi>': "\<not>\<phi> ?trn1" using eqButUID_step_\<phi>[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
              using step_friends12_\<phi>[OF step1] by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            then have "\<Delta>1 s' vl' s1' vl1" using os aF1 vl vl1
              unfolding \<Delta>1_def os' vl' f12s1' by auto
            then have ?match
              using step1 n\<phi>' os eqButUID_step_\<gamma>_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match \<or> ?ignore" ..
        next
          case False
            with n\<phi> have "ou \<noteq> outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using 1 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match \<or> ?ignore" ..
        qed
      qed
    qed
    then show ?thesis using fs1 unfolding vl1 by auto
  next
    assume "fs1 \<noteq> []"
    then obtain fs1' where fs1: "fs1 = (\<not>friends12 s1) # fs1'"
                       and aF1': "alternatingFriends (map FrVal fs1') (\<not>friends12 s1)"
      using aF1 unfolding vl1 by (cases fs1) auto
    obtain al oul s1' where "sstep s1 al = (oul, s1')" "al \<noteq> []" "eqButUID s1 s1'"
                            "friends12 s1' = (\<not>friends12 s1)"
                            "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal (\<not>friends12 s1)]"
      using rs1 IDs1
      by (cases "friends12 s1") (auto intro: toggle_friends12_True toggle_friends12_False)
    moreover then have "\<Delta>1 s vl s1' (map FrVal fs1')"
      using os aF1' vl ss1 unfolding \<Delta>1_def by (auto intro: eqButUID_sym eqButUID_trans)
    ultimately have ?iact using vl1 unfolding fs1
      by (intro iactionI_ms[of s1 al oul s1'])
         (auto simp: consumeList_def O_Nil_never list_ex_iff_length_V)
    then show ?thesis ..
  qed
qed

lemma unwind_cont_\<Delta>2: "unwind_cont \<Delta>2 {\<Delta>2,\<Delta>0}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<Delta>2 s vl s1 vl1 \<or> \<Delta>0 s vl s1 vl1"
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and 2: "\<Delta>2 s vl s1 vl1"
  from rsT have rs: "reach s" by (intro reachNT_reach)
  obtain fs fs1 vlr vlr1
  where ss1: "eqButUID s s1" and os: "\<not>open s" and BO: "BO vlr vlr1"
    and aF1: "alternatingFriends vl1 (friends12 s1)"
    and vl:  "vl =  map FrVal fs  @ OVal True # vlr"
    and vl1: "vl1 = map FrVal fs1 @ OVal True # vlr1"
    and fs_fs1: "fs = [] \<longleftrightarrow> fs1 = []"
    and last_fs: "fs \<noteq> [] \<longrightarrow> last fs = last fs1"
    and fs_fIDs: "fs = [] \<longrightarrow> friendIDs s = friendIDs s1"
    using 2 unfolding \<Delta>2_def by auto
  from os have IDs: "IDsOK s [UID1, UID2] [] [] []" unfolding open_defs by auto
  then have IDs1: "IDsOK s1 [UID1, UID2] [] [] []" using ss1 unfolding eqButUID_def by auto
  show "iaction ?\<Delta> s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction ?\<Delta> s vl s1 vl1)" (is "?iact \<or> (_ \<and> ?react)")
  proof cases
    assume "length fs1 > 1"
    then obtain fs1'
    where fs1: "fs1 = (\<not>friends12 s1) # fs1'" and fs1': "fs1' \<noteq> []"
      and last_fs': "last fs1 = last fs1'"
      and aF1': "alternatingFriends (map FrVal fs1' @ OVal True # vlr1) (\<not>friends12 s1)"
      using vl1 aF1 by (cases fs1) auto
    obtain al oul s1' where "sstep s1 al = (oul, s1')" "al \<noteq> []" "eqButUID s1 s1'"
                            "friends12 s1' = (\<not>friends12 s1)"
                            "O (traceOf s1 al) = []" "V (traceOf s1 al) = [FrVal (\<not>friends12 s1)]"
      using rs1 IDs1
      by (cases "friends12 s1") (auto intro: toggle_friends12_True toggle_friends12_False)
    moreover then have "\<Delta>2 s vl s1' (map FrVal fs1' @ OVal True # vlr1)"
      using os aF1' vl ss1 fs1' last_fs' fs_fs1 last_fs BO unfolding fs1
      by (intro \<Delta>2_I[of _ _ vlr vlr1 _ fs fs1'])
         (auto intro: eqButUID_sym eqButUID_trans)
    ultimately have ?iact using vl1 unfolding fs1
      by (intro iactionI_ms[of s1 al oul s1'])
         (auto simp: consumeList_def O_Nil_never list_ex_iff_length_V)
    then show ?thesis ..
  next
    assume len1_leq_1: "\<not> length fs1 > 1"
    have ?react proof
      fix a :: act and ou :: out and s' :: state and vl'
      let ?trn = "Trans s a ou s'"  let ?trn1 = "Trans s1 a ou s'"
      assume step: "step s a = (ou, s')" and T: "\<not> T ?trn" and c: "consume ?trn vl vl'"
      show "match ?\<Delta> s s1 vl1 a ou s' vl' \<or> ignore ?\<Delta> s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof cases
        assume \<phi>: "\<phi> ?trn"
        show ?thesis proof cases
          assume "length fs > 1"
          then obtain fv fs'
          where fs1: "fs = fv # fs'" and fs1': "fs' \<noteq> []"
            and last_fs': "last fs = last fs'"
            using vl by (cases fs) auto
          with \<phi> c have fv: "f ?trn = FrVal fv" and vl': "vl' = map FrVal fs' @ OVal True # vlr"
            unfolding vl consume_def by auto
          from \<phi> step rs fv have ss': "eqButUID s s'"
            by (elim \<phi>E) (auto intro: Cact_cFriend_step_eqButUID Dact_dFriend_step_eqButUID)
          then have "\<not>open s'" using os by (auto simp: eqButUID_open_eq)
          moreover have "eqButUID s' s1" using ss1 ss' by (auto intro: eqButUID_sym eqButUID_trans)
          ultimately have "\<Delta>2 s' vl' s1 vl1"
            using aF1 vl' fs1' fs_fs1 last_fs BO unfolding fs1 vl1
            by (intro \<Delta>2_I[of _ _ vlr vlr1 _ fs' fs1])
               (auto intro: eqButUID_sym eqButUID_trans)
          moreover have "\<not>\<gamma> ?trn" using \<phi> step rs fv UID1_UID2_UIDs by (elim \<phi>E) auto
          ultimately have ?ignore by (intro ignoreI) auto
          then show "?match \<or> ?ignore" ..
        next
          assume len_leq_1: "\<not> length fs > 1"
          show ?thesis proof cases
            assume fs: "fs = []"
            then have fs1: "fs1 = []" and fIDs: "friendIDs s = friendIDs s1"
              using fs_fs1 fs_fIDs by auto
            from fs \<phi> c have ov: "f ?trn = OVal True" and vl': "vl' = vlr"
              unfolding vl consume_def by auto
            with \<phi> step rs have ?match proof (cases rule: \<phi>E)
              case (OpenF uid p uid')
                let ?s1' = "createFriend s1 uid p uid'"
                let ?trn1 = "Trans s1 a outOK ?s1'"
                have s': "s' = createFriend s uid p uid'" using OpenF step by auto
                have "eqButUIDf (pendingFReqs s) (pendingFReqs s1)"
                  using ss1 unfolding eqButUID_def by auto
                then have "uid' \<in>\<in> pendingFReqs s uid \<longleftrightarrow> uid' \<in>\<in> pendingFReqs s1 uid"
                  using OpenF by (intro eqButUIDf_not_UID') auto
                then have step1: "step s1 a = (outOK, ?s1')"
                  using OpenF step ss1 fIDs unfolding eqButUID_def by (auto simp: c_defs)
                have s's1': "eqButUID s' ?s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                moreover have os': "open s'" using OpenF unfolding open_def by auto
                moreover have fIDs': "friendIDs s' = friendIDs ?s1'"
                  using fIDs unfolding s' by (auto simp: c_defs)
                moreover have f12s1: "friends12 s1 = friends12 ?s1'"
                  using OpenF(2) UID1_UID2_UIDs unfolding friends12_def c_defs by auto
                ultimately have "\<Delta>0 s' vl' ?s1' vlr1"
                  using BO aF1 unfolding \<Delta>0_def vl' vl1 fs1 by auto
                moreover have "\<not>open s1" "open ?s1'"
                  using ss1 os s's1' os' by (auto simp: eqButUID_open_eq)
                moreover then have "\<phi> ?trn1" unfolding OpenF by auto
                ultimately show ?match using step1 vl1 fs1 OpenF UID1_UID2 UID1_UID2_UIDs
                  by (intro matchI[of s1 a outOK ?s1' vl1 vlr1]) (auto simp: consume_def)
            qed auto
            then show ?thesis ..
          next
            assume "fs \<noteq> []"
            then obtain fv where fs: "fs = [fv]" using len_leq_1 by (cases fs) auto
            then have fs1: "fs1 = [fv]" using len1_leq_1 fs_fs1 last_fs by (cases fs1) auto
            with aF1 have f12s1: "friends12 s1 = (\<not>fv)" unfolding vl1 by auto
            have fv: "f ?trn = FrVal fv" and vl': "vl' = OVal True # vlr"
              using c \<phi> unfolding vl fs by (auto simp: consume_def)
            with \<phi> step rs have ?match proof (cases rule: \<phi>E)
              case (Friend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] [] [] []"
                  using ss1 unfolding eqButUID_def by auto
                have fv: "fv = True" using fv Friend by auto
                let ?s1' = "createFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = createFriend s UID1 p UID2"
                  using Friend step by (auto simp: createFriend_sym)
                have ss': "eqButUID s s'" using rs step Friend
                  by (auto intro: Cact_cFriend_step_eqButUID)
                moreover then have os': "\<not>open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al \<noteq> []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal True]"
                                         and f12s1': "friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Friend f12s1 unfolding fv by (auto elim: toggle_friends12_True)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Friend(6) f12s1 unfolding s' fv
                  by (intro eqButUID_createFriend12_friendIDs_eq[OF ss1 rs rs1]) auto
                ultimately have "\<Delta>2 s' vl' ?s1' (OVal True # vlr1)"
                  using BO ss1 aF1 unfolding vl' vl1 fs1 f12s1 fv
                  by (intro \<Delta>2_I[of _ _ _ _ _ "[]" "[]"])
                     (auto intro: eqButUID_trans eqButUID_sym)
                then show ?match using tr1 vl1 Friend UID1_UID2_UIDs unfolding fs1 fv
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            next
              case (Unfriend uid p uid')
                then have IDs1: "IDsOK s1 [UID1, UID2] [] [] []"
                  using ss1 unfolding eqButUID_def by auto
                have fv: "fv = False" using fv Unfriend by auto
                let ?s1' = "deleteFriend s1 UID1 (pass s1 UID1) UID2"
                have s': "s' = deleteFriend s UID1 p UID2"
                  using Unfriend step by (auto simp: deleteFriend_sym)
                have ss': "eqButUID s s'" using rs step Unfriend
                  by (auto intro: Dact_dFriend_step_eqButUID)
                moreover then have os': "\<not>open s'" using os eqButUID_open_eq by auto
                moreover obtain al oul where al: "sstep s1 al = (oul, ?s1')" "al \<noteq> []"
                                         and tr1: "O (traceOf s1 al) = []"
                                                  "V (traceOf s1 al) = [FrVal False]"
                                         and f12s1': "\<not>friends12 ?s1'"
                                         and s1s1': "eqButUID s1 ?s1'"
                  using rs1 IDs1 Unfriend f12s1 unfolding fv by (auto elim: toggle_friends12_False)
                moreover have "friendIDs s' = friendIDs ?s1'"
                  using Unfriend(6) f12s1 unfolding s' fv
                  by (intro eqButUID_deleteFriend12_friendIDs_eq[OF ss1 rs rs1])
                ultimately have "\<Delta>2 s' vl' ?s1' (OVal True # vlr1)"
                  using BO ss1 aF1 unfolding vl' vl1 fs1 f12s1 fv
                  by (intro \<Delta>2_I[of _ _ _ _ _ "[]" "[]"])
                     (auto intro: eqButUID_trans eqButUID_sym)
                then show ?match using tr1 vl1 Unfriend UID1_UID2_UIDs unfolding fs1 fv
                  by (intro matchI_ms[OF al]) (auto simp: consumeList_def)
            qed auto
            then show ?thesis ..
          qed
        qed
      next
        assume n\<phi>: "\<not>\<phi> ?trn"
        then have os': "open s = open s'" and f12s': "friends12 s = friends12 s'"
          using step_open_\<phi>[OF step] step_friends12_\<phi>[OF step] by auto
        have vl': "vl' = vl" using n\<phi> c by (auto simp: consume_def)
        show ?thesis proof (cases "a \<noteq> Cact (cFriend UID1 (pass s UID1) UID2) \<and>
                                   a \<noteq> Cact (cFriend UID2 (pass s UID2) UID1) \<and>
                                   a \<noteq> Dact (dFriend UID1 (pass s UID1) UID2) \<and>
                                   a \<noteq> Dact (dFriend UID2 (pass s UID2) UID1)")
          case True
            obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a") auto
            let ?trn1 = "Trans s1 a ou1 s1'"
            from True n\<phi> have n\<phi>': "\<not>\<phi> ?trn1" using eqButUID_step_\<phi>[OF ss1 rs rs1 step step1] by auto
            then have f12s1': "friends12 s1 = friends12 s1'"
              using step_friends12_\<phi>[OF step1] by auto
            have "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
            moreover have "friendIDs s = friendIDs s1 \<longrightarrow> friendIDs s' = friendIDs s1'"
              using eqButUID_step_friendIDs_eq[OF ss1 rs rs1 step step1 True] ..
            ultimately have "\<Delta>2 s' vl' s1' vl1"
              using os' os aF1 BO fs_fs1 last_fs fs_fIDs unfolding f12s1' vl' vl vl1
              by (intro \<Delta>2_I) auto
            then have ?match
              using step1 n\<phi>' os eqButUID_step_\<gamma>_out[OF ss1 step step1]
              by (intro matchI[of s1 a ou1 s1' vl1 vl1]) (auto simp: consume_def)
            then show "?match \<or> ?ignore" ..
        next
          case False
            with n\<phi> have "ou \<noteq> outOK" by auto
            then have "s' = s" using step False by auto
            then have ?ignore using 2 False UID1_UID2_UIDs unfolding vl' by (intro ignoreI) auto
            then show "?match \<or> ?ignore" ..
        qed
      qed
    qed
    then show ?thesis unfolding vl by auto
  qed
qed

definition Gr where
"Gr =
 {
 (\<Delta>0, {\<Delta>0,\<Delta>1,\<Delta>2}),
 (\<Delta>1, {\<Delta>1,\<Delta>0}),
 (\<Delta>2, {\<Delta>2,\<Delta>0})
 }"

theorem secure: secure
apply (rule unwind_decomp_secure_graph[of Gr \<Delta>0])
unfolding Gr_def
apply (simp, smt insert_subset order_refl)
using
istate_\<Delta>0 unwind_cont_\<Delta>0 unwind_cont_\<Delta>1 unwind_cont_\<Delta>2
unfolding Gr_def by (auto intro: unwind_cont_mono)

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

chapter "Restricted capabilities in the Separation Kernel Abstract Specification"

theory Separation
imports
  "ASepSpec.Syscall_SA"
  "AInvs.AInvs"
  "Lib.Bisim_UL"
  "Lib.LemmaBucket"
begin

text \<open>
  The seL4 kernel, when appropriately restricted, is a separation kernel. Any
  two processes in separate domains should behave the same as if they were
  processes running on two physically separated machines. They should not be
  aware of each other's existence and should not be able to communicate with
  each other except through well-defined channels. Importantly, it must be
  possible to show that there are no back channels through which one process
  can determine whether another process exists or what it is doing.

  In seL4 we achieve this by restricting the capabilities that a thread may
  possess. The restrictions are summarised in the predicate @{text
  separate_state} below (which indirectly depends on further predicates @{text
  separate_cnode_cap}, @{text separate_cap}, etc).

  a) A thread may only possess \emph{notification capabilities}
  (@{text NotificationCap}).

  b) Threads do not have caller capabilities. (A caller capability is a
  capability, placed in a special slot in the TCB, to allow replies. Since the
  @{text Reply} capability is disallowed so is the caller capability.)

  c) Pointers to other capability tables are disallowed meaning that the
  capability tree is flat. i.e. of depth 1

  Initialising the kernel so that these restrictions hold is not covered in
  the bisimulation proof, but can be achieved using the capDL initialiser.

  Note that this proof does not preclude threads from communicating via shared
  memory if the threads have been set up accordingly, which again can be done
  via the capDL initialiser.

  The proof does show that the kernel API after reaching a state that
  satisifies @{text separate_state} is that of a static separation kernel,
  that is, it only provides system calls for sending and receiving on
  notification objects and otherwise exhibits no dynamic behaviour.

  Systems with such a setup satisfy the preconditions of our separate
  non-intereference proof, which shows that information travels only along
  these authorised channels.
\<close>

definition
  separate_cap :: "cap \<Rightarrow> bool"
where
  "separate_cap cap \<equiv> case cap of
                             NotificationCap ptr badge rights \<Rightarrow> rights \<subseteq> {AllowRecv, AllowSend}
                           | NullCap                           \<Rightarrow> True
                           | _                                 \<Rightarrow> False"

lemma separate_capE:
  "\<lbrakk> separate_cap cap; cap = NullCap \<Longrightarrow> R; \<And>ptr badge rights. \<lbrakk> cap = NotificationCap ptr badge rights \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding separate_cap_def
  by (fastforce split: cap.splits)

definition
  "separate_cnode_cap cs cap \<equiv> case cap of
                                  CNodeCap p bits guard \<Rightarrow> (bits + length guard = word_bits) \<and>
                                                           (\<forall>off. case_option True separate_cap (cs (p, off)))
                                 | NullCap               \<Rightarrow> True
                                 | _                     \<Rightarrow> False"

definition
  "separate_tcb p cs \<equiv> case_option True (separate_cnode_cap cs) (cs (p, tcb_cnode_index 0))
                       \<and> cs (p, tcb_cnode_index 3) = Some NullCap" \<comment> \<open>ctable and caller cap\<close>

lemma separate_cnode_cap_rab:
  "\<lbrakk> separate_cnode_cap cs cap; length cref = word_bits \<rbrakk> \<Longrightarrow>
  resolve_address_bits (cap, cref) = (case cap of
                                         CNodeCap p bits guard \<Rightarrow> if guard \<le> cref then
                                                                     returnOk ((p, drop (length guard) cref), [])
                                                                 else
                                                                     (throwError (GuardMismatch (length cref) guard))
                                       | _ \<Rightarrow> throwError InvalidRoot)"
  unfolding separate_cnode_cap_def resolve_address_bits_def
  by (auto simp: word_bits_def resolve_address_bits'.simps split: cap.split_asm)

definition
  "separate_state s \<equiv> \<forall>p. tcb_at p s \<longrightarrow> separate_tcb p (caps_of_state s)"

lemma separate_cnode_capE:
  "\<lbrakk> separate_cnode_cap cs cap;
     cap = NullCap \<Longrightarrow> R;
    \<And>p bits guard. \<lbrakk> cap = CNodeCap p bits guard; bits + length guard = word_bits;
                     (\<forall>off cap'. cs (p, off) = Some cap' \<longrightarrow> separate_cap cap') \<rbrakk> \<Longrightarrow> R \<rbrakk>
   \<Longrightarrow> R"
  unfolding separate_cnode_cap_def
  by (auto split: cap.splits option.splits)

lemma valid_sep_cap_not_cnode:
  "\<lbrakk> s \<turnstile> cap; \<forall>off cap'. caps_of_state s (p, off) = Some cap' \<longrightarrow> separate_cap cap'; cap = CNodeCap p bits guard; bits \<le> length cref - length guard \<rbrakk>
  \<Longrightarrow> \<exists>cap'. caps_of_state s (p, take bits (drop (length guard) cref)) = Some cap' \<and> \<not> is_cnode_cap cap'"
  apply (clarsimp simp: valid_cap_simps not_less in_monad)
   apply (drule_tac offset = "take bits (drop (length guard) cref)" in cap_table_at_cte_at)
   apply simp
  apply (fastforce simp: cte_wp_at_caps_of_state separate_cap_def is_cap_simps)
  done

lemma bisim_gen_asm_r:
  assumes bs: "F \<Longrightarrow> bisim_underlying sr r P P' a b"
  shows   "bisim_underlying sr r P (P' and K F) a b"
  using bs
  by (fastforce intro!: bisim_underlyingI elim: bisim_underlyingE1  bisim_underlyingE2)

lemma bisim_separate_cap_cases:
  assumes nc: "cap = NullCap \<Longrightarrow> bisim R Pn Pn' m m'"
  and     ac: "\<And>ptr badge rights. \<lbrakk> cap = NotificationCap ptr badge rights \<rbrakk>
               \<Longrightarrow> bisim R (Pa ptr badge rights) (Pa' ptr badge rights) m m'"
  shows   "bisim R (\<lambda>s. (cap = NullCap \<longrightarrow> Pn s)
                    \<and> (\<forall>ptr badge rights. cap = NotificationCap ptr badge rights \<longrightarrow> Pa ptr badge rights s))
                   ((\<lambda>s. (cap = NullCap \<longrightarrow> Pn' s)
                    \<and> (\<forall>ptr badge rights. cap = NotificationCap ptr badge rights \<longrightarrow> Pa' ptr badge rights s))
                       and K (separate_cap cap)) m m'"
  using assms
  apply -
  apply (rule bisim_gen_asm_r)
  apply (erule separate_capE, simp_all)
  done

lemma caps_of_state_tcb:
  "\<lbrakk> get_tcb p s = Some tcb; option_map fst (tcb_cap_cases idx) = Some getF \<rbrakk> \<Longrightarrow> caps_of_state s (p, idx) = Some (getF tcb)"
  apply (drule get_tcb_SomeD)
  apply clarsimp
  apply (drule (1) cte_wp_at_tcbI [where t = "(p, idx)" and P = "(=) (getF tcb)", simplified])
  apply simp
  apply (clarsimp simp: cte_wp_at_caps_of_state)
  done

lemma caps_of_state_tcb_cap_cases:
  "\<lbrakk> get_tcb p s = Some tcb; idx \<in> dom tcb_cap_cases \<rbrakk> \<Longrightarrow> caps_of_state s (p, idx) = Some ((the (option_map fst (tcb_cap_cases idx))) tcb)"
  apply (clarsimp simp: dom_def)
  apply (erule caps_of_state_tcb)
  apply simp
  done

lemma separate_state_get_tcbD:
  "\<lbrakk>separate_state s; get_tcb p s = Some tcb \<rbrakk> \<Longrightarrow>
  separate_cnode_cap (caps_of_state s) (tcb_ctable tcb) \<and> tcb_caller tcb = NullCap"
  unfolding separate_state_def
  apply (drule spec [where x = p])
  apply (simp add: tcb_at_def separate_tcb_def caps_of_state_tcb_cap_cases dom_tcb_cap_cases)
  done

end