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

theory ExampleSystem
imports ArchAccess_AC
begin

context begin interpretation Arch . (*FIXME: arch_split*)

definition
  nat_to_bl :: "nat \<Rightarrow> nat \<Rightarrow> bool list option"
where
  "nat_to_bl bits n \<equiv>
    if n \<ge> 2^bits then
      None
    else
      Some $ bin_to_bl bits (of_nat n)"

lemma nat_to_bl_id [simp]: "nat_to_bl (size (x :: (('a::len) word))) (unat x) = Some (to_bl x)"
  apply (clarsimp simp: nat_to_bl_def to_bl_def)
  apply (auto simp: le_def word_size)
  done

(*---------------------------------------------------------*)

subsection \<open>Purpose\<close>

text \<open>

This file defines some example systems using the access control
definitions. The aim is a sanity check of the AC definitions, to
ensure they enable to reason about reasonable systems.

In particular, we want to make sure that

  . the function state_objs_to_policy does not connect everything to
  everything (Example 1)
  . we can talk about components sharing cnodes
  . we can talk about components sharing frames
  . we can have more than 1 untrusted component
  . we can have an EP between two untrusted components

\<close>

(*---------------------------------------------------------*)

subsection \<open>Generic functions / lemmas\<close>

text \<open>Defining the authority between labels.

In addition to the intuitive authority we want, we need to add all the
authority required to have a wellformed graph. So we define
complete_AgentAuthGraph to add these 'extra' authorities (at least all
the ones not depending on the current label). These are:

  . self-authority (each label needs all the authorities to itself).
  . if Control edge is present between 2 labels then we add all
    authorities between them.
  . Control authority is transitive: we add an Control edge
    between 2 labels if we can connect them via Control
    edges. Actually we add all authorities because of the second
    clause.

\<close>

definition
  complete_AuthGraph :: "'a auth_graph \<Rightarrow> 'a set \<Rightarrow> 'a auth_graph"
where
  "complete_AuthGraph g ls \<equiv>
     g \<union> {(l,a,l) | a l. l \<in> ls}"

text \<open>converting a nat to a bool list of size 10 - for the cnodes\<close>

definition
  the_nat_to_bl :: "nat \<Rightarrow> nat \<Rightarrow> bool list"
where
  "the_nat_to_bl sz n \<equiv> the (nat_to_bl sz n)"

definition
  the_nat_to_bl_10  :: "nat \<Rightarrow> bool list"
where
  "the_nat_to_bl_10 n \<equiv> the_nat_to_bl 10 n"

lemma tcb_cnode_index_nat_to_bl:
  "n<10 \<Longrightarrow> the_nat_to_bl_10 n \<noteq> tcb_cnode_index n"
  by (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def
                     tcb_cnode_index_def
                     nat_to_bl_def to_bl_def bin_to_bl_aux_def)

(*---------------------------------------------------------*)
subsection \<open>Example 1\<close>

text \<open>

This example aims at checking that we can extract a reasonable policy
from the state, i.e. that the function state_objs_to_policy does not connect
everything to everything.

This example is a system Sys1 made of 2 main components UT1 and T1,
connected through and endpoint EP1. EP1 is made of one single kernel
object: obj1_0x9, the endpoint. Both UT1 and T1 contains:

  . one TCB (obj1_0xC07 and obj1_0xC08 resp.)
  . one vspace made up of one top-level page table (obj1_BF7 and obj1_0xBF9 resp.)
  . each top-level pt contains a single page table (obj1_0xC00000 and obj1_0xC05000 resp.)
  . one cspace made up of one cnode (obj1_0x6 and obj1_0x7 resp.)
  . each cspace contains 4 caps:
         one to the tcb
         one to the cnode itself
         one to the vspace
         one to the ep

UT1 can send to the ep while T1 can receive from it.

Attempt to ASCII art:

          --------    ----                      ----     --------
          |       |   |  |                      |  |     |      |
          V       |   |  V     S             R  |  V     |      V
obj1_0xC07(tcb)-->obj1_0x6(cnode)--->obj1_0x9(ep)<---obj1_0x7(cnode)<--obj1_0xC08(tcb)
  |               |                                   |            |
  V               |                                   |            V
obj1_0xBF7(pt)<-----                                    -------> obj1_0xBF9(pt)
  |                                                                |
  V                                                                V
obj1_0xC00000(pt)                                                obj1_0xC05000(pt)

(the references are derived from the dump of the SAC system)

The aim is to be able to prove

  pas_refined Sys1PAS s1

where Sys1PAS is the label graph defining the AC policy for Sys1 and
s1 is the state of Sys1 described above.

This shows that the aag extracted from s1 (by state_objs_to_policy) is
included in the policy graph Sys1PAS.

\<close>

subsubsection \<open>Defining the State\<close>

text \<open>We need to define the asids of each pt to ensure that
the object is included in the right ASID-label\<close>

text \<open>UT1's ASID\<close>

definition
  asid1_0xBF7 :: asid
where
  "asid1_0xBF7 \<equiv> 1<<asid_low_bits"

text \<open>T1's ASID\<close>

definition
  asid1_0xBF9 :: asid
where
  "asid1_0xBF9 \<equiv> 2<<asid_low_bits"

lemma "asid_high_bits_of asid1_0xBF9 \<noteq> asid_high_bits_of asid1_0xBF7"
by (simp add: asid1_0xBF7_def asid_high_bits_of_def asid1_0xBF9_def asid_low_bits_def)

text \<open>UT1's CSpace\<close>
definition
  caps1_0x6 :: cnode_contents
where
  "caps1_0x6 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 0xC07,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 6 undefined undefined,
        (the_nat_to_bl_10 3)
            \<mapsto> ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7,0))),
        (the_nat_to_bl_10 318)
            \<mapsto> EndpointCap 9 0 {AllowSend} )"

definition
  obj1_0x6 :: kernel_object
where
  "obj1_0x6 \<equiv> CNode 10 caps1_0x6"

text \<open>T1's Cspace\<close>

definition
  caps1_0x7 :: cnode_contents
where
  "caps1_0x7 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 0xC08,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 7 undefined undefined,
        (the_nat_to_bl_10 3)
           \<mapsto> ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9,0))),
        (the_nat_to_bl_10 318)
           \<mapsto> EndpointCap 9 0 {AllowRecv}) "

definition
  obj1_0x7 :: kernel_object
where
  "obj1_0x7 \<equiv> CNode 10 caps1_0x7"

text \<open>endpoint between UT1 and T1\<close>

definition
  obj1_0x9 :: kernel_object
where
  "obj1_0x9 \<equiv> Endpoint IdleEP"

text \<open>UT1's VSpace\<close>

definition
  pt1_0xC00000 :: pt
where
  "pt1_0xC00000 \<equiv> (\<lambda>_. InvalidPTE)"

definition
  obj1_0xC00000 :: kernel_object
where
  "obj1_0xC00000 \<equiv> ArchObj (PageTable pt1_0xC00000)"

definition
  pt1_0xBF7 :: pt
where
  "pt1_0xBF7 \<equiv>
    (\<lambda>_. InvalidPTE)
     (0 := PageTablePTE
              (ucast (addrFromPPtr 0xC00000 >> pageBits))
              undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj1_0xBF7 :: kernel_object
where
  "obj1_0xBF7 \<equiv> ArchObj (PageTable pt1_0xBF7)"

text \<open>T1's VSpace\<close>

definition
  pt1_0xC05000 :: pt
where
  "pt1_0xC05000 \<equiv>
    (\<lambda>_. InvalidPTE)"

definition
  obj1_0xC05000 :: kernel_object
where
  "obj1_0xC05000 \<equiv> ArchObj (PageTable pt1_0xC05000)"

definition
  pt1_0xBF9 :: pt
where
  "pt1_0xBF9 \<equiv>
    (\<lambda>_. InvalidPTE)
     (0 := PageTablePTE
             (ucast (addrFromPPtr 0xC05000 >> pageBits))
             undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj1_0xBF9 :: kernel_object
where
  "obj1_0xBF9 \<equiv> ArchObj (PageTable pt1_0xBF9)"

text \<open>UT1's tcb\<close>

definition
  obj1_0xC07 :: kernel_object
where
  "obj1_0xC07 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 6 undefined undefined,
     tcb_vtable             = ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7, 0))),
     tcb_reply              = ReplyCap 0xC07 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = Running,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr> \<rparr>"

text \<open>T1's tcb\<close>

definition
  obj1_0xC08 :: kernel_object
where
  "obj1_0xC08 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 7 undefined undefined,
     tcb_vtable             = ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9, 0))),
     tcb_reply              = ReplyCap 0xC08 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = BlockedOnReceive 9 \<lparr> receiver_can_grant = False \<rparr>,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr>\<rparr>"

definition
 "obj1_10 \<equiv> CNode 10 (Map.empty([] \<mapsto> cap.NullCap))"

(* the boolean in BlockedOnReceive is True if the object can receive but not send.
but Tom says it only matters if the sender can grant - which is not the case of the UT1 - I think *)

definition
  kh1 :: kheap
where
  "kh1 \<equiv> [0x6 \<mapsto> obj1_0x6,
           0x7 \<mapsto> obj1_0x7,
           0x9 \<mapsto> obj1_0x9,
           0xA \<mapsto> obj1_10,
           0xBF7 \<mapsto> obj1_0xBF7,
           0xBF9 \<mapsto> obj1_0xBF9,
           0xC07 \<mapsto> obj1_0xC07,
           0xC08 \<mapsto> obj1_0xC08,
           0xC00000 \<mapsto> obj1_0xC00000,
           0xC05000 \<mapsto> obj1_0xC05000]"

lemmas kh1_obj_def =
  obj1_0x6_def obj1_0x7_def obj1_0x9_def obj1_10_def obj1_0xBF7_def obj1_0xBF9_def
  obj1_0xC00000_def obj1_0xC05000_def obj1_0xC07_def obj1_0xC08_def

definition exst1 :: "det_ext" where
  "exst1 \<equiv> \<lparr>work_units_completed_internal = undefined,
             scheduler_action_internal = undefined,
             ekheap_internal = \<lambda>x. None,
             domain_list_internal = undefined,
             domain_index_internal = undefined,
             cur_domain_internal = undefined,
             domain_time_internal = undefined,
             ready_queues_internal = undefined,
             cdt_list_internal = undefined\<rparr>"

definition
  s1 :: "det_ext state"
where
  "s1 \<equiv>  \<lparr>
    kheap = kh1,
    cdt = Map.empty,
    is_original_cap = undefined,
    cur_thread = undefined,
    idle_thread = undefined,
    machine_state = undefined,
    interrupt_irq_node = (\<lambda>_. 10),
    interrupt_states = undefined,
    arch_state = \<lparr>
        riscv_asid_table = (\<lambda>_. None),
        riscv_global_pts = undefined,
        riscv_kernel_vspace = undefined
        \<rparr>,
     exst = exst1
    \<rparr>"

subsubsection \<open>Defining the policy graph\<close>

datatype Sys1Labels =
    UT1 | T1 | EP1 | IRQ1

definition
  Sys1AgentMap :: "Sys1Labels agent_map"
where
  "Sys1AgentMap \<equiv>
   (\<lambda>_. undefined)
     (0x6 := UT1,
      0x7 := T1,
      0x9 := EP1,
      0xA := IRQ1,
      0xBF7 := UT1,
      0xBF9 := T1,
      0xC00000 := UT1,
      0xC05000 := T1,
      0xC07 := UT1,
      0xC08 := T1 )"

lemma Sys1AgentMap_simps:
  "Sys1AgentMap 0x6 = UT1"
  "Sys1AgentMap 0x7 = T1"
  "Sys1AgentMap 0x9 = EP1"
  "Sys1AgentMap 0xA = IRQ1"
  "Sys1AgentMap 0xBF7 = UT1"
  "Sys1AgentMap 0xBF9 = T1"
  "Sys1AgentMap 0xC00000 = UT1"
  "Sys1AgentMap 0xC05000 = T1"
  "Sys1AgentMap 0xC07 = UT1"
  "Sys1AgentMap 0xC08 = T1"
  unfolding Sys1AgentMap_def by simp_all

definition
  Sys1AuthGraph_aux :: "Sys1Labels auth_graph"
where
    "Sys1AuthGraph_aux \<equiv>
  { (UT1, auth.SyncSend,    EP1),
    (UT1, auth.Reset,   EP1),
    (T1,  auth.Receive, EP1),
    (T1,  auth.Reset,   EP1) }"

definition
  Sys1AuthGraph:: "Sys1Labels auth_graph"
where
    "Sys1AuthGraph \<equiv> complete_AuthGraph Sys1AuthGraph_aux {T1, UT1}"

definition
  Sys1ASIDMap :: "Sys1Labels agent_asid_map"
where
  "Sys1ASIDMap \<equiv>
    (\<lambda>x. if (asid_high_bits_of x = asid_high_bits_of asid1_0xBF7)
          then UT1
         else if (asid_high_bits_of x = asid_high_bits_of asid1_0xBF9)
          then T1 else undefined)"

definition Sys1PAS :: "Sys1Labels PAS" where
  "Sys1PAS \<equiv> \<lparr> pasObjectAbs = Sys1AgentMap, pasASIDAbs = Sys1ASIDMap, pasIRQAbs = (\<lambda>_. IRQ1),
               pasPolicy = Sys1AuthGraph, pasSubject = UT1, pasMayActivate = True,
               pasMayEditReadyQueues = True, pasMaySendIrqs = True, pasDomainAbs = undefined \<rparr>"

subsubsection \<open>Proof of pas_refined for Sys1\<close>

lemma caps1_0x7_well_formed: "well_formed_cnode_n 10 caps1_0x7"
  apply (clarsimp simp: caps1_0x7_def well_formed_cnode_n_def)
  apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
  apply (clarsimp simp: empty_cnode_def dom_def)
  apply (rule set_eqI, clarsimp)
  apply (rule iffI)
   apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
  apply clarsimp
  done

lemma caps1_0x6_well_formed: "well_formed_cnode_n 10 caps1_0x6"
  apply (clarsimp simp: caps1_0x6_def well_formed_cnode_n_def)
  apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
  apply (clarsimp simp: empty_cnode_def dom_def)
  apply (rule set_eqI, clarsimp)
  apply (rule iffI)
   apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
  apply clarsimp
  done

(* clagged from KernelInit_R *)
lemma empty_cnode_apply[simp]:
  "(empty_cnode n xs = Some cap) = (length xs = n \<and> cap = NullCap)"
  by (auto simp add: empty_cnode_def)

lemma s1_caps_of_state :
  "caps_of_state s1 p = Some cap \<Longrightarrow>
     cap = NullCap \<or>
     (p,cap) \<in>
       { ((6::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 0xC07),
         ((6::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 6 undefined undefined),
         ((6::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7, 0)))),
         ((6::obj_ref,(the_nat_to_bl_10 318)),EndpointCap  9 0 {AllowSend}),
         ((7::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 0xC08),
         ((7::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 7 undefined undefined),
         ((7::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9, 0)))),
         ((7::obj_ref,(the_nat_to_bl_10 318)),EndpointCap  9 0 {AllowRecv}) ,
         ((0xC07::obj_ref, (tcb_cnode_index 0)), CNodeCap 6 undefined undefined ),
         ((0xC07::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7, 0)))),
         ((0xC07::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC07 True {AllowGrant,AllowWrite}),
         ((0xC07::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((0xC07::obj_ref, (tcb_cnode_index 4)), NullCap),
         ((0xC08::obj_ref, (tcb_cnode_index 0)), CNodeCap 7 undefined undefined ),
         ((0xC08::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9, 0)))),
         ((0xC08::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC08 True {AllowGrant,AllowWrite}),
         ((0xC08::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((0xC08::obj_ref, (tcb_cnode_index 4)), NullCap)} "
  apply (insert caps1_0x7_well_formed)
  apply (insert caps1_0x6_well_formed)
  apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s1_def kh1_def kh1_obj_def)
  apply (case_tac p, clarsimp)
  apply (clarsimp split: if_splits)
     apply (clarsimp simp: cte_wp_at_cases tcb_cap_cases_def
                     split: if_split_asm)+
   apply (clarsimp simp: caps1_0x7_def split: if_splits)
  apply (clarsimp simp: caps1_0x6_def cte_wp_at_cases  split: if_splits)
  done

lemma Sys1_wellformed: "pas_wellformed Sys1PAS"
  apply (clarsimp simp: Sys1PAS_def
                     policy_wellformed_def
                     Sys1AuthGraph_def
                     Sys1AuthGraph_aux_def
                     complete_AuthGraph_def)
  apply blast
  done

lemma tcb_states_of_state_1:
  "tcb_states_of_state s1 = [0xC08 \<mapsto> thread_state.BlockedOnReceive 9 \<lparr> receiver_can_grant = False \<rparr>,  0xC07 \<mapsto> thread_state.Running ]"
  unfolding s1_def tcb_states_of_state_def
  apply (rule ext)
  apply (simp add: get_tcb_def)
  apply (simp add: kh1_def kh1_obj_def )
  done

lemma thread_bound_ntfns_1:
  "thread_bound_ntfns s1 = Map.empty"
  unfolding s1_def thread_bound_ntfns_def
  apply (rule ext)
  apply (simp add: get_tcb_def)
  apply (simp add: kh1_def kh1_obj_def )
  done

declare AllowSend_def[simp] AllowRecv_def[simp]

lemma domains_of_state_s1[simp]:
  "domains_of_state s1 = {}"
  apply (rule equalityI)
   apply (rule subsetI)
   apply clarsimp
   apply (erule domains_of_state_aux.induct)
   apply (simp add: s1_def exst1_def)
  apply simp
  done

lemma vs_refs_aux_empty_pt[simp]:
  "vs_refs_aux lvl (PageTable empty_pt) = {}"
  by (clarsimp simp: vs_refs_aux_def graph_of_def pte_ref2_def)

lemma is_aligned_0xC00000[simp]:
  "ptrFromPAddr (addr_from_ppn (UCAST(64 \<rightarrow> 52) (addrFromPPtr 0xC00000 >> pageBits))) = 0xC00000"
  by (subst ptrFromPAddr_addr_from_ppn; fastforce simp: bit_simps is_aligned_mask mask_def)

lemma is_aligned_0xC05000[simp]:
  "ptrFromPAddr (addr_from_ppn (UCAST(64 \<rightarrow> 52) (addrFromPPtr 0xC05000 >> pageBits))) = 0xC05000"
  by (subst ptrFromPAddr_addr_from_ppn; fastforce simp: bit_simps is_aligned_mask mask_def)

lemma "pas_refined Sys1PAS s1"
  apply (clarsimp simp: pas_refined_def)
  apply (intro conjI)
       subgoal by (simp add: Sys1_wellformed)
      subgoal by (simp add: irq_map_wellformed_aux_def s1_def Sys1AgentMap_simps Sys1PAS_def)
     subgoal by (simp add: tcb_domain_map_wellformed_aux_def)
    apply (clarsimp simp: auth_graph_map_def Sys1PAS_def state_objs_to_policy_def)+
    apply (erule state_bits_to_policy.cases, simp_all, clarsimp)
          apply (drule s1_caps_of_state, clarsimp)
          apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def)
          apply (elim disjE conjE; solves\<open>clarsimp simp: Sys1AgentMap_simps cap_auth_conferred_def cap_rights_to_auth_def\<close>)
         apply (drule s1_caps_of_state, clarsimp)
         apply (elim disjE; solves \<open>simp add: thread_bound_ntfns_def\<close>)
        apply (clarsimp simp: state_refs_of_def thread_st_auth_def tcb_states_of_state_1
               Sys1AuthGraph_def Sys1AgentMap_simps
               complete_AuthGraph_def
               Sys1AuthGraph_aux_def
               split: if_splits)
       apply (simp add:  thread_bound_ntfns_1)
      apply (simp add: s1_def) (* this is OK because cdt is empty..*)
     apply (simp add: s1_def) (* this is OK because cdt is empty..*)
    apply (fastforce simp: state_vrefs_def vs_refs_aux_def s1_def kh1_def kh1_obj_def
                           pt1_0xC00000_def pt1_0xC05000_def pt1_0xBF9_def pt1_0xBF7_def
                           Sys1AuthGraph_def Sys1AuthGraph_aux_def Sys1AgentMap_simps
                           complete_AuthGraph_def ptr_range_def pte_ref2_def opt_map_def
                    dest!: graph_ofD split: if_splits)
   apply (rule subsetI, clarsimp)
   apply (erule state_asids_to_policy_aux.cases)
     apply (drule s1_caps_of_state, clarsimp)
     apply (fastforce simp: Sys1AgentMap_simps Sys1PAS_def Sys1ASIDMap_def Sys1AuthGraph_def
                            Sys1AuthGraph_aux_def complete_AuthGraph_def cap_auth_conferred_def
                            asid1_0xBF9_def asid1_0xBF7_def asid_low_bits_def asid_high_bits_of_def)
    apply (fastforce simp: state_vrefs_def vs_refs_aux_def s1_def kh1_def kh1_obj_def
                           pt1_0xC00000_def pt1_0xC05000_def pt1_0xBF9_def pt1_0xBF7_def
                           Sys1AuthGraph_def Sys1AuthGraph_aux_def Sys1AgentMap_simps
                           complete_AuthGraph_def ptr_range_def pte_ref2_def opt_map_def
                    dest!: graph_ofD split: if_splits)
   apply (clarsimp simp: s1_def)
  apply (rule subsetI, clarsimp)
  apply (erule state_irqs_to_policy_aux.cases)
  apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def Sys1PAS_def Sys1ASIDMap_def)
  apply (drule s1_caps_of_state)
  apply (fastforce simp: Sys1AgentMap_simps Sys1PAS_def Sys1ASIDMap_def Sys1AuthGraph_def
                         Sys1AuthGraph_aux_def complete_AuthGraph_def cap_auth_conferred_def
                         asid1_0xBF9_def asid1_0xBF7_def asid_low_bits_def asid_high_bits_of_def)
  done

(*---------------------------------------------------------*)
subsection \<open>Example 2\<close>

text \<open>

This example systems Sys2 aims at checking that we can have 2
components, one untrusted UT2 and one truted T1, sharing a cnode obj2_5.

Both UT2 and T2 contains:

  . one TCB (obj2_0xC07 and obj2_0xC08 resp.)
  . one vspace made up of one top-level page table (obj2_0xBF7 and obj2_0xBF9 resp.)
  . each top-level pt contains a single page table (obj2_0xC00000 and obj2_0xC05000 resp.)
  . one cspace made up of one cnode (obj2_0x6 and obj2_0x7 resp.)
  . each cspace contains 4 caps:
         one to the tcb
         one to the cnode itself
         one to the vspace
         one to obj2_5

Attempt to ASCII art:

          --------    ----                          ----     --------
          |       |   |  |                          |  |     |      |
          V       |   |  V     S             R      |  V     |      V
obj2_0xC07(tcb)-->obj2_0x6(cnode)--->obj2_5(cnode)<---obj2_0x7(cnode)<--obj2_0xC08(tcb)
  |               |                                   |            |
  V               |                                   |            V
obj2_0xBF7(pt)<-----                                    -------> obj2_0xBF9(pt)
  |                                                                |
  V                                                                V
obj2_0xC00000(pt)                                                obj2_0xC05000(pt)

(the references are derived from the dump of the SAC system)

The aim is to be able to prove

  pas_refined Sys2PAS s2

where Sys2PAS is the label graph defining the AC policy for Sys2 and
s2 is the state of Sys2 described above.

This shows that the aag extracted from s2 (by state_objs_to_policy) is
included in the policy graph Sys2PAS.

\<close>

subsubsection \<open>Defining the State\<close>

text \<open>We need to define the asids of each pt to ensure that
the object is included in the right ASID-label\<close>

text \<open>UT2's ASID\<close>

definition
  asid2_0xBF7 :: asid
where
  "asid2_0xBF7 \<equiv> 1<<asid_low_bits"

text \<open>T2's ASID\<close>

definition
  asid2_0xBF9 :: asid
where
  "asid2_0xBF9 \<equiv> 2<<asid_low_bits"

lemma "asid_high_bits_of asid2_0xBF9 \<noteq> asid_high_bits_of asid2_0xBF7"
by (simp add: asid2_0xBF7_def asid_high_bits_of_def asid2_0xBF9_def asid_low_bits_def)

text \<open>the intermediaite CSpace\<close>

definition
  caps2_5 :: cnode_contents
where
  "caps2_5 \<equiv>
   (empty_cnode 10)"

definition
  obj2_5 :: kernel_object
where
  "obj2_5 \<equiv> CNode 10 caps2_5"

text \<open>UT2's CSpace\<close>

definition
  caps2_0x6 :: cnode_contents
where
  "caps2_0x6 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 0xC07,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 6 undefined undefined,
        (the_nat_to_bl_10 3)
            \<mapsto> ArchObjectCap (PageTableCap 0xBF7
                                             (Some (asid2_0xBF7, 0))),
        (the_nat_to_bl_10 4)
            \<mapsto> CNodeCap 5 undefined undefined )"

definition
  obj2_0x6 :: kernel_object
where
  "obj2_0x6 \<equiv> CNode 10 caps2_0x6"

text \<open>T2's Cspace\<close>

definition
  caps2_0x7 :: cnode_contents
where
  "caps2_0x7 \<equiv>
   (empty_cnode 10)
      ( (the_nat_to_bl_10 1)
            \<mapsto> ThreadCap 0xC08,
        (the_nat_to_bl_10 2)
            \<mapsto> CNodeCap 7 undefined undefined,
        (the_nat_to_bl_10 3)
           \<mapsto> ArchObjectCap (PageTableCap 0xBF9
                                            (Some (asid2_0xBF9, 0))),
        (the_nat_to_bl_10 4)
            \<mapsto> CNodeCap 5 undefined undefined) "

definition
  obj2_0x7 :: kernel_object
where
  "obj2_0x7 \<equiv> CNode 10 caps2_0x7"

text \<open>endpoint between UT2 and T2\<close>

definition
  obj2_0x9 :: kernel_object
where
  "obj2_0x9 \<equiv> Endpoint IdleEP"

text \<open>UT2's VSpace\<close>

definition
  pt2_0xC00000 :: pt
where
  "pt2_0xC00000 \<equiv> (\<lambda>_. InvalidPTE)"

definition
  obj2_0xC00000 :: kernel_object
where
  "obj2_0xC00000 \<equiv> ArchObj (PageTable pt2_0xC00000)"

definition
  pt2_0xBF7 :: pt
where
  "pt2_0xBF7 \<equiv>
    (\<lambda>_. InvalidPTE)
     (0 := PageTablePTE
              (ucast (addrFromPPtr 0xC00000 >> pageBits))
              undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj2_0xBF7 :: kernel_object
where
  "obj2_0xBF7 \<equiv> ArchObj (PageTable pt2_0xBF7)"

text \<open>T1's VSpace\<close>

definition
  pt2_0xC05000 :: pt
where
  "pt2_0xC05000 \<equiv>
    (\<lambda>_. InvalidPTE)"

definition
  obj2_0xC05000 :: kernel_object
where
  "obj2_0xC05000 \<equiv> ArchObj (PageTable pt2_0xC05000)"

definition
  pt2_0xBF9 :: pt
where
  "pt2_0xBF9 \<equiv>
    (\<lambda>_. InvalidPTE)
     (0 := PageTablePTE
             (ucast (addrFromPPtr 0xC05000 >> pageBits))
             undefined )"

(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check
if it's right *)

definition
  obj2_0xBF9 :: kernel_object
where
  "obj2_0xBF9 \<equiv> ArchObj (PageTable pt2_0xBF9)"

text \<open>UT1's tcb\<close>

definition
  obj2_0xC07 :: kernel_object
where
  "obj2_0xC07 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 6 undefined undefined ,
     tcb_vtable             = ArchObjectCap (PageTableCap 0xBF7 (Some (asid2_0xBF7, 0))),
     tcb_reply              = ReplyCap 0xC07 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = Running,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr>\<rparr>"

text \<open>T1's tcb\<close>

definition
  obj2_0xC08 :: kernel_object
where
  "obj2_0xC08 \<equiv>
   TCB \<lparr>
     tcb_ctable             = CNodeCap 7 undefined undefined ,
     tcb_vtable             = ArchObjectCap (PageTableCap 0xBF9 (Some (asid2_0xBF9,0))),
     tcb_reply              = ReplyCap 0xC08 True {AllowGrant,AllowWrite}, \<comment> \<open>master reply cap to itself\<close>
     tcb_caller             = NullCap,
     tcb_ipcframe           = NullCap,
     tcb_state              = BlockedOnReceive 9 \<lparr> receiver_can_grant = False \<rparr>,
     tcb_fault_handler      = undefined,
     tcb_ipc_buffer         = undefined,
     tcb_fault              = undefined,
     tcb_bound_notification = None,
     tcb_mcpriority         = undefined,
     tcb_arch               = \<lparr>tcb_context = undefined\<rparr>\<rparr>"

(* the boolean in BlockedOnReceive is True if the object can receive but not send.
but Tom says it only matters if the sender can grant - which is not the case of the UT1 - I think *)

definition
  kh2 :: kheap
where
  "kh2 \<equiv> [0x6 \<mapsto> obj2_0x6,
           0x7 \<mapsto> obj2_0x7,
           0x9 \<mapsto> obj2_0x9,
           0xBF7 \<mapsto> obj2_0xBF7,
           0xBF9 \<mapsto> obj2_0xBF9,
           0xC00000 \<mapsto> obj2_0xC00000,
           0xC05000 \<mapsto> obj2_0xC05000,
           0xC07 \<mapsto> obj2_0xC07,
           0xC08 \<mapsto> obj2_0xC08 ]"

lemmas kh2_obj_def =
  obj2_0x6_def obj2_0x7_def obj2_0x9_def obj2_0xBF7_def obj2_0xBF9_def
  obj2_0xC00000_def obj2_0xC05000_def obj2_0xC07_def obj2_0xC08_def

definition
  s2 :: "det_ext state"
where
  "s2 \<equiv>  \<lparr>
    kheap = kh2,
    cdt = Map.empty,
    is_original_cap = undefined,
    cur_thread = undefined,
    idle_thread = undefined,
    machine_state = undefined,
    interrupt_irq_node = (\<lambda>_. 9001),
    interrupt_states = undefined,
    arch_state = \<lparr>
        riscv_asid_table = (\<lambda>_. None),
        riscv_global_pts = undefined,
        riscv_kernel_vspace = undefined
        \<rparr>,
    exst = exst1
    \<rparr>"

subsubsection \<open>Defining the policy graph\<close>

datatype Sys2Labels =
    UT2 | T2 | IRQ2

definition
  Sys2AgentMap :: "Sys2Labels agent_map"
where
  "Sys2AgentMap \<equiv>
   (\<lambda>_. undefined)
     (0x5 := UT2,
      0x6 := UT2,
      0x7 := T2,
      0x9 := T2,
      0xBF7 := UT2,
      0xBF9 := T2,
      0xC00000 := UT2,
      0xC05000 := T2,
      0xC07 := UT2,
      0xC08 := T2,
      9001 := IRQ2 )"

definition
  Sys2AuthGraph_aux :: "Sys2Labels auth_graph"
where
    "Sys2AuthGraph_aux \<equiv>
       { (T2, Control, UT2) }"

definition
  Sys2AuthGraph:: "Sys2Labels auth_graph"
where
    "Sys2AuthGraph \<equiv> complete_AuthGraph Sys2AuthGraph_aux {T2, UT2}"

definition
  Sys2ASIDMap :: "Sys2Labels agent_asid_map"
where
  "Sys2ASIDMap \<equiv>
    (\<lambda>_. undefined)
     (asid2_0xBF7 := UT2,
      asid2_0xBF9 := T2 )"

definition Sys2PAS :: "Sys2Labels PAS" where
  "Sys2PAS \<equiv> \<lparr> pasObjectAbs = Sys2AgentMap, pasASIDAbs = Sys2ASIDMap,
              pasIRQAbs = (\<lambda>_. IRQ2),
              pasPolicy = Sys2AuthGraph, pasSubject = UT2, pasMayActivate = True, pasMayEditReadyQueues = True, pasMaySendIrqs = True, pasDomainAbs = undefined \<rparr>"

subsubsection \<open>Proof of pas_refined for Sys2\<close>

lemma caps2_0x7_well_formed: "well_formed_cnode_n 10 caps2_0x7"
  apply (clarsimp simp: caps2_0x7_def well_formed_cnode_n_def)
  apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
  apply (clarsimp simp: empty_cnode_def dom_def)
  apply (rule set_eqI, clarsimp)
  apply (rule iffI)
   apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
  apply clarsimp
  done

lemma caps2_0x6_well_formed: "well_formed_cnode_n 10 caps2_0x6"
  apply (clarsimp simp: caps2_0x6_def well_formed_cnode_n_def)
  apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def)
  apply (clarsimp simp: empty_cnode_def dom_def)
  apply (rule set_eqI, clarsimp)
  apply (rule iffI)
   apply (elim disjE, insert len_bin_to_bl, simp_all)[1]
  apply clarsimp
  done

lemma s2_caps_of_state :
  "caps_of_state s2 p = Some cap \<Longrightarrow>
     cap = NullCap \<or>
     (p,cap) \<in>
       { ((6::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 0xC07),
         ((6::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 6 undefined undefined),
         ((6::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageTableCap 0xBF7 (Some (asid2_0xBF7, 0)))),
         ((6::obj_ref,(the_nat_to_bl_10 4)),  CNodeCap 5 undefined undefined),
         ((7::obj_ref,(the_nat_to_bl_10 1)),  ThreadCap 0xC08),
         ((7::obj_ref,(the_nat_to_bl_10 2)),  CNodeCap 7 undefined undefined),
         ((7::obj_ref,(the_nat_to_bl_10 3)),  ArchObjectCap (PageTableCap 0xBF9 (Some (asid2_0xBF9, 0)))),
         ((7::obj_ref,(the_nat_to_bl_10 4)),  CNodeCap 5 undefined undefined),
         ((0xC07::obj_ref, (tcb_cnode_index 0)), CNodeCap 6 undefined undefined ),
         ((0xC07::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF7 (Some (asid2_0xBF7, 0)))),
         ((0xC07::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC07 True {AllowGrant,AllowWrite}),
         ((0xC07::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((0xC07::obj_ref, (tcb_cnode_index 4)), NullCap),
         ((0xC08::obj_ref, (tcb_cnode_index 0)), CNodeCap 7 undefined undefined ),
         ((0xC08::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF9 (Some (asid2_0xBF9, 0)))),
         ((0xC08::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC08 True {AllowGrant,AllowWrite}),
         ((0xC08::obj_ref, (tcb_cnode_index 3)), NullCap),
         ((0xC08::obj_ref, (tcb_cnode_index 4)), NullCap)} "
  apply (insert caps2_0x7_well_formed)
  apply (insert caps2_0x6_well_formed)
  apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s2_def kh2_def kh2_obj_def)
  apply (case_tac p, clarsimp)
  apply (clarsimp simp: cte_wp_at_cases split: if_splits)
     apply (clarsimp simp: tcb_cap_cases_def split: if_splits)+
   apply (clarsimp simp: caps2_0x7_def split: if_splits)
  apply (clarsimp simp: caps2_0x6_def cte_wp_at_cases  split: if_splits)
  done

lemma Sys2_wellformed: "pas_wellformed Sys2PAS"
  apply (clarsimp simp: Sys2PAS_def policy_wellformed_def)
  apply (intro conjI)
  apply (simp_all add: Sys2AuthGraph_def complete_AuthGraph_def
                       Sys2AuthGraph_aux_def)
  done

lemma Sys2AgentMap_simps:
  "Sys2AgentMap 5 = UT2"
  "Sys2AgentMap 6 = UT2"
  "Sys2AgentMap 7 = T2"
  "Sys2AgentMap 9 = T2"
  "Sys2AgentMap 0xBF7 = UT2"
  "Sys2AgentMap 0xBF9 = T2"
  "Sys2AgentMap 0xC00000 = UT2"
  "Sys2AgentMap 0xC05000 = T2"
  "Sys2AgentMap 0xC07 = UT2"
  "Sys2AgentMap 0xC08 = T2"
  "Sys2AgentMap 9001 = IRQ2"
  by (simp_all add: Sys2AgentMap_def)

lemma domains_of_state_s2[simp]:
  "domains_of_state s2 = {}"
  apply (rule equalityI)
   apply (rule subsetI)
   apply clarsimp
   apply (erule domains_of_state_aux.induct)
   apply (simp add: s2_def exst1_def)
  apply simp
  done

lemma thread_bound_ntfns_2[simp]:
  "thread_bound_ntfns s2 = Map.empty"
  unfolding s2_def thread_bound_ntfns_def
  apply (rule ext)
  apply (simp add: get_tcb_def)
  apply (simp add: kh2_def kh2_obj_def)
  done

lemma "pas_refined Sys2PAS s2"
  apply (clarsimp simp: pas_refined_def)
  apply (intro conjI)
      apply (simp add: Sys2_wellformed)
     apply (simp add: Sys2PAS_def s2_def Sys2AgentMap_def
                      irq_map_wellformed_aux_def)
    apply (clarsimp simp: auth_graph_map_def
                          Sys2PAS_def
                          state_objs_to_policy_def
                          state_bits_to_policy_def tcb_domain_map_wellformed_aux_def)+
    apply (erule state_bits_to_policyp.cases, simp_all)
         apply (drule s2_caps_of_state, clarsimp)
         apply (elim disjE, simp_all add: cap_auth_conferred_def
                                          Sys2AgentMap_simps
                                          Sys2AuthGraph_def Sys2AuthGraph_aux_def
                                          complete_AuthGraph_def
                              split: if_split_asm)[1]
        apply (drule s2_caps_of_state, clarsimp)
        apply (elim disjE, simp_all)[1]
       apply (clarsimp simp: state_refs_of_def s2_def kh2_def kh2_obj_def
                       split: if_splits)
       apply (clarsimp split:if_splits option.splits
                       simp: thread_st_auth_def tcb_states_of_state_def
                             Sys2AgentMap_simps Sys2AuthGraph_def
                             complete_AuthGraph_def Sys2AuthGraph_aux_def
                      dest!: get_tcb_SomeD)
      apply (simp add: s2_def) (* this is OK because cdt is empty..*)
     apply (simp add: s2_def) (* this is OK because cdt is empty..*)
    apply (fastforce simp: state_vrefs_def vs_refs_aux_def s2_def kh2_def kh2_obj_def pt2_0xBF9_def
                           pt2_0xBF7_def pt2_0xC05000_def pt2_0xC00000_def Sys2AgentMap_simps
                           Sys2AuthGraph_def Sys2AuthGraph_aux_def complete_AuthGraph_def
                           pte_ref2_def graph_of_def opt_map_def ptr_range_def
                    split: if_splits)
   apply clarsimp
   apply (erule state_asids_to_policy_aux.cases)
    apply clarsimp
    apply (fastforce simp: Sys2PAS_def Sys2AuthGraph_def Sys2AuthGraph_aux_def
                           complete_AuthGraph_def Sys2AgentMap_simps asid_low_bits_def
                           Sys2ASIDMap_def asid2_0xBF7_def asid2_0xBF9_def
                    dest!: s2_caps_of_state)
   apply (clarsimp simp: state_vrefs_def vs_refs_aux_def s2_def kh2_def kh2_obj_def
                  split: if_splits)
   apply (clarsimp simp: s2_def)
  apply (clarsimp)
  apply (erule state_irqs_to_policy_aux.cases)
  apply (fastforce simp: Sys2PAS_def Sys2AuthGraph_def Sys2AuthGraph_aux_def
                         complete_AuthGraph_def Sys2AgentMap_simps
                         Sys2ASIDMap_def asid2_0xBF7_def asid2_0xBF9_def
                  dest!: s2_caps_of_state)
  done

end

end


theory CoCallFix
imports CoCallAnalysisSig CoCallAnalysisBinds ArityAnalysisSig "Launchbury.Env-Nominal"  ArityAnalysisFix
begin

locale CoCallArityAnalysis =
  fixes cccExp :: "exp \<Rightarrow> (Arity \<rightarrow> AEnv \<times> CoCalls)"
begin

definition Aexp :: "exp \<Rightarrow> (Arity \<rightarrow> AEnv)"
  where "Aexp e = (\<Lambda> a. fst (cccExp e \<cdot> a))"

sublocale ArityAnalysis Aexp.

abbreviation Aexp_syn' ("\<A>\<^bsub>_\<^esub>") where "\<A>\<^bsub>a\<^esub> \<equiv> (\<lambda>e. Aexp e\<cdot>a)"
abbreviation Aexp_bot_syn' ("\<A>\<^sup>\<bottom>\<^bsub>_\<^esub>") where "\<A>\<^sup>\<bottom>\<^bsub>a\<^esub> \<equiv> (\<lambda>e. fup\<cdot>(Aexp e)\<cdot>a)"

lemma Aexp_eq:
  "\<A>\<^bsub>a\<^esub> e = fst (cccExp e \<cdot> a)"
  unfolding Aexp_def by (rule beta_cfun) (intro cont2cont)

lemma fup_Aexp_eq:
  "fup\<cdot>(Aexp e)\<cdot>a = fst (fup\<cdot>(cccExp e)\<cdot>a)"
  by (cases a)(simp_all add: Aexp_eq)

definition CCexp :: "exp \<Rightarrow> (Arity \<rightarrow> CoCalls)" where "CCexp \<Gamma> = (\<Lambda> a. snd (cccExp \<Gamma>\<cdot>a))"
lemma CCexp_eq:
  "CCexp e\<cdot>a = snd (cccExp e \<cdot> a)"
  unfolding CCexp_def by (rule beta_cfun) (intro cont2cont)

lemma fup_CCexp_eq:
  "fup\<cdot>(CCexp e)\<cdot>a = snd (fup\<cdot>(cccExp e)\<cdot>a)"
  by (cases a)(simp_all add: CCexp_eq)

sublocale CoCallAnalysis CCexp.

definition CCfix :: "heap \<Rightarrow> (AEnv \<times> CoCalls) \<rightarrow> CoCalls"
  where "CCfix \<Gamma> = (\<Lambda> aeG. (\<mu> G'. ccBindsExtra \<Gamma>\<cdot>(fst aeG , G') \<squnion> snd aeG))"

lemma CCfix_eq:
  "CCfix \<Gamma>\<cdot>(ae,G) = (\<mu> G'. ccBindsExtra \<Gamma>\<cdot>(ae, G') \<squnion> G)"
  unfolding CCfix_def
  by simp

lemma CCfix_unroll: "CCfix \<Gamma>\<cdot>(ae,G) = ccBindsExtra \<Gamma>\<cdot>(ae, CCfix \<Gamma>\<cdot>(ae,G)) \<squnion> G"
  unfolding  CCfix_eq
  apply (subst fix_eq)
  apply simp
  done

lemma fup_ccExp_restr_subst':
  assumes "\<And> a. cc_restr S (CCexp e[x::=y]\<cdot>a) = cc_restr S (CCexp e\<cdot>a)"
  shows "cc_restr S (fup\<cdot>(CCexp e[x::=y])\<cdot>a) = cc_restr S (fup\<cdot>(CCexp e)\<cdot>a)"
  using assms
  by (cases a) (auto simp del: cc_restr_cc_restr simp add: cc_restr_cc_restr[symmetric])

lemma ccBindsExtra_restr_subst':
  assumes "\<And> x' e a. (x',e) \<in> set \<Gamma> \<Longrightarrow> cc_restr S (CCexp e[x::=y]\<cdot>a) = cc_restr S (CCexp e\<cdot>a)"
  assumes "x \<notin> S"
  assumes "y \<notin> S"
  assumes "domA \<Gamma> \<subseteq> S"
  shows  "cc_restr S (ccBindsExtra  \<Gamma>[x::h=y]\<cdot>(ae, G))
       = cc_restr S (ccBindsExtra  \<Gamma>\<cdot>(ae f|` S , cc_restr S G))"
  apply (simp add: ccBindsExtra_simp ccBinds_eq ccBind_eq Int_absorb2[OF assms(4)] fv_subst_int[OF assms(3,2)])
  apply (intro arg_cong2[where f = "(\<squnion>)"] refl  arg_cong[OF mapCollect_cong])
  apply (subgoal_tac "k \<in> S")
  apply (auto intro: fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]] simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] ccSquare_def)[1]
  apply (metis assms(4) contra_subsetD domI dom_map_of_conv_domA)
  apply (subgoal_tac "k \<in> S")
  apply (auto intro: fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]]
              simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] ccSquare_def cc_restr_twist[where S = S] simp del: cc_restr_cc_restr)[1]
  apply (subst fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]], assumption)
  apply (simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] )
  apply (subst fup_ccExp_restr_subst'[OF assms(1)[OF map_of_SomeD]], assumption)
  apply (simp add: fv_subst_int[OF assms(3,2)]   fv_subst_int2[OF assms(3,2)] )
  apply (metis assms(4) contra_subsetD domI dom_map_of_conv_domA)
  done

lemma ccBindsExtra_restr:
  assumes "domA \<Gamma> \<subseteq> S"
  shows "cc_restr S (ccBindsExtra \<Gamma>\<cdot>(ae, G)) = cc_restr S (ccBindsExtra \<Gamma>\<cdot>(ae f|` S, cc_restr S G))"
  using assms
  apply (simp add: ccBindsExtra_simp ccBinds_eq ccBind_eq Int_absorb2)
  apply (intro arg_cong2[where f = "(\<squnion>)"] refl arg_cong[OF mapCollect_cong])
  apply (subgoal_tac "k \<in> S")
  apply simp
  apply (metis contra_subsetD domI dom_map_of_conv_domA)
  apply (subgoal_tac "k \<in> S")
  apply simp
  apply (metis contra_subsetD domI dom_map_of_conv_domA)
  done

lemma CCfix_restr:
  assumes "domA \<Gamma> \<subseteq> S"
  shows "cc_restr S (CCfix \<Gamma>\<cdot>(ae, G)) = cc_restr S (CCfix \<Gamma>\<cdot>(ae f|` S, cc_restr S G))"
  unfolding CCfix_def
  apply simp
  apply (rule parallel_fix_ind[where P = "\<lambda> x y . cc_restr S x = cc_restr S y"])
  apply simp
  apply rule
  apply simp
  apply (subst (1 2) ccBindsExtra_restr[OF assms])
  apply (auto)
  done

lemma ccField_CCfix:
  shows "ccField (CCfix \<Gamma>\<cdot>(ae, G)) \<subseteq> fv \<Gamma> \<union> ccField G"
  unfolding CCfix_def
  apply simp
  apply (rule fix_ind[where P = "\<lambda> x . ccField x \<subseteq> fv \<Gamma> \<union> ccField G"])
  apply (auto dest!: subsetD[OF ccField_ccBindsExtra])
  done

lemma CCfix_restr_subst':
  assumes "\<And> x' e a. (x',e) \<in> set \<Gamma> \<Longrightarrow> cc_restr S (CCexp e[x::=y]\<cdot>a) = cc_restr S (CCexp e\<cdot>a)"
  assumes "x \<notin> S"
  assumes "y \<notin> S"
  assumes "domA \<Gamma> \<subseteq> S"
  shows "cc_restr S (CCfix \<Gamma>[x::h=y]\<cdot>(ae, G)) = cc_restr S (CCfix \<Gamma>\<cdot>(ae f|` S, cc_restr S G))"
  unfolding CCfix_def
  apply simp
  apply (rule parallel_fix_ind[where P = "\<lambda> x y . cc_restr S x = cc_restr S y"])
  apply simp
  apply rule
  apply simp
  apply (subst  ccBindsExtra_restr_subst'[OF assms], assumption)
  apply (subst ccBindsExtra_restr[OF assms(4)]) back
  apply (auto)
  done

end

lemma Aexp_eqvt[eqvt]:  "\<pi> \<bullet> (CoCallArityAnalysis.Aexp cccExp e) = CoCallArityAnalysis.Aexp (\<pi> \<bullet> cccExp) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI) unfolding CoCallArityAnalysis.Aexp_eq by perm_simp rule

lemma CCexp_eqvt[eqvt]:  "\<pi> \<bullet> (CoCallArityAnalysis.CCexp cccExp e) = CoCallArityAnalysis.CCexp (\<pi> \<bullet> cccExp) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI) unfolding CoCallArityAnalysis.CCexp_eq by perm_simp rule

lemma CCfix_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.CCfix cccExp \<Gamma>) = CoCallArityAnalysis.CCfix (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  unfolding CoCallArityAnalysis.CCfix_def by perm_simp (simp_all add: Abs_cfun_eqvt)

lemma ccFix_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallArityAnalysis.CCfix cccexp1 heap1 = CoCallArityAnalysis.CCfix cccexp2 heap2"
   unfolding CoCallArityAnalysis.CCfix_def
   apply (rule arg_cong) back
   apply (rule ccBindsExtra_cong)
   apply (auto simp add: CoCallArityAnalysis.CCexp_def)
   done

context CoCallArityAnalysis
begin
definition cccFix ::  "heap \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> (AEnv \<times> CoCalls))"
  where "cccFix \<Gamma> = (\<Lambda> i. (Afix \<Gamma>\<cdot>(fst i \<squnion> (\<lambda>_.up\<cdot>0) f|` thunks \<Gamma>), CCfix \<Gamma>\<cdot>(Afix \<Gamma>\<cdot>(fst i  \<squnion> (\<lambda>_.up\<cdot>0) f|` (thunks \<Gamma>)), snd i)))"

lemma cccFix_eq:
  "cccFix \<Gamma>\<cdot>i = (Afix \<Gamma>\<cdot>(fst i \<squnion> (\<lambda>_.up\<cdot>0) f|` thunks \<Gamma>), CCfix \<Gamma>\<cdot>(Afix \<Gamma>\<cdot>(fst i  \<squnion> (\<lambda>_.up\<cdot>0) f|` (thunks \<Gamma>)), snd i))"
  unfolding cccFix_def
  by (rule beta_cfun)(intro cont2cont)
end

lemma cccFix_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.cccFix cccExp \<Gamma>) = CoCallArityAnalysis.cccFix  (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  apply (rule cfun_eqvtI) unfolding CoCallArityAnalysis.cccFix_eq by perm_simp rule

lemma cccFix_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallArityAnalysis.cccFix cccexp1 heap1 = CoCallArityAnalysis.cccFix cccexp2 heap2"
   unfolding CoCallArityAnalysis.cccFix_def
   apply (rule cfun_eqI)
   apply auto
   apply (rule arg_cong[OF Afix_cong], auto simp add: CoCallArityAnalysis.Aexp_def)[1]
   apply (rule arg_cong2[OF ccFix_cong Afix_cong ])
   apply (auto simp add: CoCallArityAnalysis.Aexp_def)
   done

subsubsection \<open>The non-recursive case\<close>

definition ABind_nonrec :: "var \<Rightarrow> exp \<Rightarrow> AEnv \<times> CoCalls \<rightarrow> Arity\<^sub>\<bottom>"
where
  "ABind_nonrec x e = (\<Lambda> i. (if isVal e \<or> x--x\<notin>(snd i) then fst i x else up\<cdot>0))"

lemma ABind_nonrec_eq:
  "ABind_nonrec x e\<cdot>(ae,G) = (if isVal e \<or> x--x\<notin>G then ae x else up\<cdot>0)"
  unfolding ABind_nonrec_def
  apply (subst beta_cfun)
  apply (rule cont_if_else_above)
  apply auto
  by (metis in_join join_self_below(4))

lemma ABind_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (ABind_nonrec x e) = ABind_nonrec (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  apply (case_tac xa, simp)
  unfolding ABind_nonrec_eq
  by perm_simp rule

lemma ABind_nonrec_above_arg:
  "ae x \<sqsubseteq> ABind_nonrec x e \<cdot> (ae, G)"
unfolding ABind_nonrec_eq by auto

definition Aheap_nonrec where
  "Aheap_nonrec x e = (\<Lambda> i. esing x\<cdot>(ABind_nonrec x e\<cdot>i))"

lemma Aheap_nonrec_simp:
  "Aheap_nonrec x e\<cdot>i = esing x\<cdot>(ABind_nonrec x e\<cdot>i)"
  unfolding Aheap_nonrec_def by simp

lemma Aheap_nonrec_lookup[simp]:
  "(Aheap_nonrec x e\<cdot>i) x = ABind_nonrec x e\<cdot>i"
  unfolding Aheap_nonrec_simp by simp

lemma Aheap_nonrec_eqvt'[eqvt]:
  "\<pi> \<bullet> (Aheap_nonrec x e) = Aheap_nonrec (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding Aheap_nonrec_simp
  by (perm_simp, rule)

context CoCallArityAnalysis
begin

  definition Afix_nonrec
   where "Afix_nonrec x e = (\<Lambda> i. fup\<cdot>(Aexp e)\<cdot>(ABind_nonrec x e \<cdot> i) \<squnion> fst i)"

  lemma Afix_nonrec_eq[simp]:
    "Afix_nonrec x e \<cdot> i = fup\<cdot>(Aexp e)\<cdot>(ABind_nonrec x e \<cdot> i) \<squnion> fst i"
    unfolding Afix_nonrec_def
    by (rule beta_cfun) simp

  definition CCfix_nonrec
   where "CCfix_nonrec x e = (\<Lambda> i. ccBind x e \<cdot> (Aheap_nonrec x e\<cdot>i, snd i)  \<squnion> ccProd (fv e) (ccNeighbors x (snd i) - (if isVal e then {} else {x})) \<squnion> snd i)"

  lemma CCfix_nonrec_eq[simp]:
    "CCfix_nonrec x e \<cdot> i = ccBind x e\<cdot>(Aheap_nonrec x e\<cdot>i, snd i)  \<squnion> ccProd (fv e) (ccNeighbors x (snd i) - (if isVal e then {} else {x})) \<squnion> snd i"
    unfolding CCfix_nonrec_def
    by (rule beta_cfun) (intro cont2cont)

  definition cccFix_nonrec ::  "var \<Rightarrow> exp \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> (AEnv \<times> CoCalls))"
    where "cccFix_nonrec x e = (\<Lambda> i. (Afix_nonrec x e \<cdot>i , CCfix_nonrec x e \<cdot>i))"

  lemma cccFix_nonrec_eq[simp]:
    "cccFix_nonrec x e\<cdot>i = (Afix_nonrec x e \<cdot>i , CCfix_nonrec x e \<cdot>i)"
    unfolding cccFix_nonrec_def
    by (rule beta_cfun) (intro cont2cont)

end

lemma AFix_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.Afix_nonrec cccExp x e) = CoCallArityAnalysis.Afix_nonrec (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding CoCallArityAnalysis.Afix_nonrec_eq
  by perm_simp rule

lemma CCFix_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.CCfix_nonrec cccExp x e) = CoCallArityAnalysis.CCfix_nonrec (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding CoCallArityAnalysis.CCfix_nonrec_eq
  by perm_simp rule

lemma cccFix_nonrec_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.cccFix_nonrec cccExp x e) = CoCallArityAnalysis.cccFix_nonrec (\<pi> \<bullet> cccExp) (\<pi> \<bullet> x) (\<pi> \<bullet> e)"
  apply (rule cfun_eqvtI)
  unfolding CoCallArityAnalysis.cccFix_nonrec_eq
  by perm_simp rule

subsubsection \<open>Combining the cases\<close>

context CoCallArityAnalysis
begin
  definition cccFix_choose ::  "heap \<Rightarrow> ((AEnv \<times> CoCalls) \<rightarrow> (AEnv \<times> CoCalls))"
    where "cccFix_choose \<Gamma> = (if nonrec \<Gamma> then case_prod cccFix_nonrec (hd \<Gamma>) else cccFix \<Gamma>)"

  lemma cccFix_choose_simp1[simp]:
    "\<not> nonrec \<Gamma> \<Longrightarrow> cccFix_choose \<Gamma> = cccFix \<Gamma>"
  unfolding cccFix_choose_def by simp

  lemma cccFix_choose_simp2[simp]:
    "x \<notin> fv e \<Longrightarrow> cccFix_choose [(x,e)] = cccFix_nonrec x e"
  unfolding cccFix_choose_def nonrec_def by auto

end

lemma cccFix_choose_eqvt[eqvt]: "\<pi> \<bullet> (CoCallArityAnalysis.cccFix_choose cccExp \<Gamma>) = CoCallArityAnalysis.cccFix_choose (\<pi> \<bullet> cccExp) (\<pi> \<bullet> \<Gamma>)"
  unfolding CoCallArityAnalysis.cccFix_choose_def
  apply (cases nonrec \<pi>  rule: eqvt_cases[where x = \<Gamma>])
  apply (perm_simp, rule)
  apply simp
  apply (erule nonrecE)
  apply (simp )

  apply simp
  done

lemma cccFix_nonrec_cong[fundef_cong]:
  "cccexp1 e = cccexp2 e  \<Longrightarrow> CoCallArityAnalysis.cccFix_nonrec cccexp1 x e = CoCallArityAnalysis.cccFix_nonrec cccexp2 x e"
   apply (rule cfun_eqI)
   unfolding CoCallArityAnalysis.cccFix_nonrec_eq
   unfolding CoCallArityAnalysis.Afix_nonrec_eq
   unfolding CoCallArityAnalysis.CCfix_nonrec_eq
   unfolding CoCallArityAnalysis.fup_Aexp_eq
   apply (simp only: )
   apply (rule arg_cong[OF ccBind_cong])
   apply simp
   unfolding CoCallArityAnalysis.CCexp_def
   apply simp
   done

lemma cccFix_choose_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> cccexp1 e = cccexp2 e); heap1 = heap2 \<rbrakk>
      \<Longrightarrow> CoCallArityAnalysis.cccFix_choose cccexp1 heap1 = CoCallArityAnalysis.cccFix_choose cccexp2 heap2"
   unfolding CoCallArityAnalysis.cccFix_choose_def
   apply (rule cfun_eqI)
   apply (auto elim!: nonrecE)
   apply (rule arg_cong[OF cccFix_nonrec_cong], auto)
   apply (rule arg_cong[OF cccFix_cong], auto)[1]
   done

end


theory Friend
imports "../Observation_Setup" Friend_Value_Setup
begin

subsection \<open>Declassification bound\<close>

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

text \<open>The bound follows the same ``while-or-last-before'' scheme as the bound for post
confidentiality (Section~\ref{sec:post-bound}), alternating between open (\<open>BO\<close>) and
closed (\<open>BC\<close>) phases.

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)

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

subsection \<open>Unwinding proof\<close>

(* Key lemma: *)
lemma eqButUID_step_\<gamma>_out:
assumes ss1: "eqButUID s s1"
and step: "step s a = (ou,s')" and step1: "step s1 a = (ou1,s1')"
and \<gamma>: "\<gamma> (Trans s a ou s')"
and os: "open s \<longrightarrow> friendIDs s = friendIDs s1"
shows "ou = ou1"
proof -
  from \<gamma> obtain uid where uid: "userOfA a = Some uid \<and> uid \<in> UIDs \<and> uid \<noteq> UID1 \<and> uid \<noteq> UID2
                              \<or> userOfA a = None"
    using UID1_UID2_UIDs  by (cases "userOfA a") auto
  { fix uid
    assume "uid \<in>\<in> friendIDs s UID1 \<or> uid \<in>\<in> friendIDs s UID2" and "uid \<in> UIDs"
    with os have "friendIDs s = friendIDs s1" unfolding open_def openByF_def by auto
  } note fIDs = this
  { fix uid uid'
    assume uid: "uid \<noteq> UID1" "uid \<noteq> UID2"
    have "friendIDs s uid = friendIDs s1 uid" (is ?f_eq)
     and "pendingFReqs s uid = pendingFReqs s1 uid" (is ?pFR_eq)
     and "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'" (is ?f_iff)
     and "uid \<in>\<in> pendingFReqs s uid' \<longleftrightarrow> uid \<in>\<in> pendingFReqs s1 uid'" (is ?pFR_iff)
     and "friendReq s uid uid' = friendReq s1 uid uid'" (is ?FR_eq)
     and "friendReq s uid' uid = friendReq s1 uid' uid" (is ?FR_eq')
    proof -
      show ?f_eq ?pFR_eq using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUIDf_not_UID)
      show ?f_iff ?pFR_iff using uid ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUIDf_not_UID')
      from uid have "\<not> (uid,uid') \<in> {(UID1,UID2), (UID2,UID1)}" by auto
      then show ?FR_eq ?FR_eq' using ss1 UID1_UID2_UIDs unfolding eqButUID_def
        by (auto intro!: eqButUID12_not_UID)
    qed
  } note simps = this eqButUID_def r_defs s_defs c_defs l_defs u_defs d_defs
  note facts = ss1 step step1 uid
  show ?thesis
  proof (cases a)
    case (Ract ra) then show ?thesis using facts by (cases ra) (auto simp add: simps)
  next
    case (Sact sa) then show ?thesis using facts by (cases sa) (auto simp add: simps)
  next
    case (Cact ca) then show ?thesis using facts by (cases ca) (auto simp add: simps)
  next
    case (Lact la)
      then show ?thesis using facts proof (cases la)
        case (lFriends uid p uid')
          with \<gamma> have uid: "uid \<in> UIDs" using Lact by auto
          then have uid_uid': "uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
            using ss1 UID1_UID2_UIDs unfolding eqButUID_def by (intro eqButUIDf_not_UID') auto
          show ?thesis
          proof (cases "(uid' = UID1 \<or> uid' = UID2) \<and> uid \<in>\<in> friendIDs s uid'")
            case True
              with uid have "friendIDs s = friendIDs s1" by (intro fIDs) auto
              then show ?thesis using lFriends facts Lact by (auto simp: simps)
          next
            case False
              then show ?thesis using lFriends facts Lact simps(1) uid_uid' by (auto simp: simps)
          qed
      next
        case (lPosts uid p)
          then have o: "\<And>PID. owner s PID = owner s1 PID"
                and n: "\<And>PID. post s PID = post s1 PID"
                and PIDs: "postIDs s = postIDs s1"
                and viss: "vis s = vis s1"
                and fu: "\<And>uid'. uid \<in>\<in> friendIDs s uid' \<longleftrightarrow> uid \<in>\<in> friendIDs s1 uid'"
                and e: "e_listPosts s uid p \<longleftrightarrow> e_listPosts s1 uid p"
            using ss1 uid Lact unfolding eqButUID_def l_defs by (auto simp add: simps(3))
          have "listPosts s uid p = listPosts s1 uid p"
            unfolding listPosts_def o n PIDs fu viss ..
          with e show ?thesis using Lact lPosts step step1 by auto
      qed (auto simp add: simps)
  next
    case (Uact ua) then show ?thesis using facts by (cases ua) (auto simp add: simps)
  next
    case (Dact da) then show ?thesis using facts by (cases da) (auto simp add: simps)
  qed
qed

(* 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 emptyReq)"
  let ?s1 = "createFriendReq s UID2 (pass s UID2) UID1 emptyReq"
  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 emptyReq" 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)
                moreover have "\<not>\<gamma> ?trn" using Friend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1' Friend
                  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)
                moreover have "\<not>\<gamma> ?trn" using Unfriend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1' Unfriend
                  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)
                moreover have "\<not>\<gamma> ?trn" using Friend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1 Friend 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)
                moreover have "\<not>\<gamma> ?trn" using Unfriend UID1_UID2_UIDs by auto
                ultimately show ?match using tr1 vl1 Unfriend 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


(*  Title:      HOL/Hoare/HeapSyntaxAbort.thy
    Author:     Tobias Nipkow
    Copyright   2002 TUM
*)

theory HeapSyntaxAbort imports Hoare_Logic_Abort Heap begin

subsection "Field access and update"

text{* Heap update @{text"p^.h := e"} is now guarded against @{term p}
being Null. However, @{term p} may still be illegal,
e.g. uninitialized or dangling. To guard against that, one needs a
more detailed model of the heap where allocated and free addresses are
distinguished, e.g. by making the heap a map, or by carrying the set
of free addresses around. This is needed anyway as soon as we want to
reason about storage allocation/deallocation. *}

syntax
  "_refupdate" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ref \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
   ("_/'((_ \<rightarrow> _)')" [1000,0] 900)
  "_fassign"  :: "'a ref => id => 'v => 's com"
   ("(2_^._ :=/ _)" [70,1000,65] 61)
  "_faccess"  :: "'a ref => ('a ref \<Rightarrow> 'v) => 'v"
   ("_^._" [65,1000] 65)
translations
  "_refupdate f r v" == "f(CONST addr r := v)"
  "p^.f := e" => "(p \<noteq> CONST Null) \<rightarrow> (f := _refupdate f p e)"
  "p^.f" => "f(CONST addr p)"

declare fun_upd_apply[simp del] fun_upd_same[simp] fun_upd_other[simp]

text "An example due to Suzuki:"

lemma "VARS v n
  {w = Ref w0 & x = Ref x0 & y = Ref y0 & z = Ref z0 &
   distinct[w0,x0,y0,z0]}
  w^.v := (1::int); w^.n := x;
  x^.v := 2; x^.n := y;
  y^.v := 3; y^.n := z;
  z^.v := 4; x^.n := z
  {w^.n^.n^.v = 4}"
by vcg_simp

end


(*
# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#   http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.
*)

theory TrustLevel
  imports Main
begin

locale TrustLevel=
  fixes trusted::'trustlevel
    and untrusted::'trustlevel
    and is_trusted::"'trustlevel\<Rightarrow>bool"
  assumes TRUSTLEVELHLR1:"is_trusted trusted"
  assumes TRUSTLEVELHLR2:"\<not>is_trusted untrusted"
  assumes TRUSTLEVELHLR3:"(x::'trustlevel)=trusted\<or>x=untrusted"
begin

lemma TRUSTLEVELHLR4:"trusted\<noteq>untrusted"
proof
  assume 0:"trusted=untrusted"
  from TRUSTLEVELHLR1 have "is_trusted untrusted" by (auto simp: 0)
  from this show "False" by (auto simp: TRUSTLEVELHLR2)
qed

end

print_locale! TrustLevel

end