theory Outer_Friend_Issuer
  imports
    "Outer_Friend_Issuer_Value_Setup"
    "Bounded_Deducibility_Security.Compositional_Reasoning"
begin

subsubsection \<open>Declassification bound\<close>

(* We verify the following:
   Given an arbitrary but fixed user UID at node AID (who is not an observer) and a set of
   observers at each network node, the observers may learn about the *occurrence* of remote
   friendship actions of UID (because network traffic is assumed to be observable), but they
   learn nothing about the *content* of those actions (who was added or deleted as a friend)
   beyond public knowledge (friendship addition and deletion occur alternatingly),
   except if the action adds or deletes one of the observers themselves as friend.
*)

context OuterFriendIssuer
begin

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

text \<open>For each user \<open>uid\<close> at a node \<open>aid\<close>, the remote friendship updates with
the fixed user \<open>UID\<close> at node \<open>AID\<close> form an alternating sequence of friending and unfriending.

Note that actions involving remote users who are observers do not produce secret values;
instead, those actions are observable, and the property we verify does not protect their
confidentiality.\<close>

fun validValSeq :: "value list \<Rightarrow> (apiID \<times> userID) list \<Rightarrow> bool" where
  "validValSeq [] _ = True"
| "validValSeq (FrVal aid uid True # vl) auidl \<longleftrightarrow> (aid, uid) \<notin> set auidl \<and> uid \<notin> UIDs aid \<and> validValSeq vl (auidl ## (aid, uid))"
| "validValSeq (FrVal aid uid False # vl) auidl \<longleftrightarrow> (aid, uid) \<in>\<in> auidl \<and> uid \<notin> UIDs aid \<and> validValSeq vl (removeAll (aid, uid) auidl)"
| "validValSeq (OVal _ # vl) auidl = validValSeq vl auidl"

abbreviation validValSeqFrom :: "value list \<Rightarrow> state \<Rightarrow> bool" where
  "validValSeqFrom vl s \<equiv> validValSeq vl (removeUIDs (sentOuterFriendIDs s UID))"

text \<open>When the access window is closed, observers may learn about the occurrence of
remote friendship actions (by observing network traffic), but not their content;
the actions can be replaced by different actions involving different users (who are not observers)
without affecting the observations.\<close>

inductive BC :: "value list \<Rightarrow> value list \<Rightarrow> bool"
where
  BC_Nil[simp,intro]: "BC [] []"
| BC_FrVal[intro]:
    "BC vl vl1 \<Longrightarrow> uid' \<notin> UIDs aid \<Longrightarrow> BC (FrVal aid uid st # vl) (FrVal aid uid' st' # vl1)"

text \<open>When the access window is open, i.e.~the user \<open>UID\<close> is a local friend of an observer,
all information about the remote friends of \<open>UID\<close> is declassified;
when the access window closes again, the contents of future updates are kept confidential.\<close>

definition "BO vl vl1 \<equiv>
 (vl1 = vl) \<or>
 (\<exists>vl0 vl' vl1'. vl = vl0 @ OVal False # vl' \<and> vl1 = vl0 @ OVal False # vl1' \<and> BC vl' vl1')"

definition "B vl vl1 \<equiv> (BC vl vl1 \<or> BO vl vl1) \<and> validValSeqFrom vl1 istate"

lemma B_Nil_Nil: "B vl vl1 \<Longrightarrow> vl1 = [] \<longleftrightarrow> vl = []"
unfolding B_def BO_def by (auto elim: BC.cases)

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

subsubsection \<open>Unwinding proof\<close>

definition \<Delta>0 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>0 s vl s1 vl1 \<equiv>
 s1 = istate \<and> s = istate \<and> B vl vl1"

definition \<Delta>1 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>1 s vl s1 vl1 \<equiv>
 BO vl vl1 \<and>
 s1 = s \<and>
 validValSeqFrom vl1 s1"

definition \<Delta>2 :: "state \<Rightarrow> value list \<Rightarrow> state \<Rightarrow> value list \<Rightarrow> bool" where
"\<Delta>2 s vl s1 vl1 \<equiv>
 BC vl vl1 \<and>
 eqButUID s s1 \<and> \<not>open s1 \<and>
 validValSeqFrom vl1 s1"

lemma validValSeq_prefix: "validValSeq (vl @ vl') auidl \<Longrightarrow> validValSeq vl auidl"
by (induction vl arbitrary: auidl) (auto elim: validValSeq.elims)

lemma filter_removeAll: "filter P (removeAll x xs) = removeAll x (filter P xs)"
unfolding removeAll_filter_not_eq by (auto intro: filter_cong)

lemma step_validValSeqFrom:
assumes step: "step s a = (ou, s')"
and rs: "reach s"
and c: "consume (Trans s a ou s') vl vl'" (is "consume ?trn vl vl'")
and vVS: "validValSeqFrom vl s"
shows "validValSeqFrom vl' s'"
proof cases
  assume "\<phi> ?trn"
  moreover then obtain v where "vl = v # vl'" using c by (cases vl, auto simp: consume_def)
  moreover have "distinct (sentOuterFriendIDs s UID)" using rs by (intro reach_distinct_friends_reqs)
  ultimately show ?thesis using assms
    by (elim \<phi>E)
       (auto simp: com_defs c_defs d_defs consume_def distinct_remove1_removeAll filter_removeAll)
next
  assume n\<phi>: "\<not>\<phi> ?trn"
  then have vl': "vl' = vl" using c by (auto simp: consume_def)
  then show ?thesis using vVS step proof (cases a)
    case (Sact sa) then show ?thesis using assms vl' by (cases sa) (auto simp: s_defs) next
    case (Cact ca) then show ?thesis using assms vl' by (cases ca) (auto simp: c_defs) next
    case (Dact da) then show ?thesis using assms vl' by (cases da) (auto simp: d_defs) next
    case (Uact ua) then show ?thesis using assms vl' by (cases ua) (auto simp: u_defs) next
    case (COMact ca) then show ?thesis using assms vl' n\<phi> by (cases ca) (auto simp: com_defs filter_remove1)
  qed auto
qed

lemma istate_\<Delta>0:
assumes B: "B vl vl1"
shows "\<Delta>0 istate vl istate vl1"
using assms unfolding \<Delta>0_def
by auto

lemma unwind_cont_\<Delta>0: "unwind_cont \<Delta>0 {\<Delta>1,\<Delta>2}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<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 s: "s = istate" and s1: "s1 = istate" and B: "B vl vl1"
    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 (intro disjI1)
        obtain uid p where a: "a = Sact (sSys uid p) \<or> s' = s"
          using step unfolding s by (elim istate_sSys) auto
        have "\<not>open s'" using step a s by (auto simp: istate_def s_defs open_def)
        moreover then have "\<not>\<phi> ?trn" using step rs a by (auto elim!: \<phi>E simp: s istate_def com_defs)
        moreover have "sentOuterFriendIDs s' UID = sentOuterFriendIDs s UID"
          using s a step by (auto simp: s_defs)
        ultimately show "?match" using s s1 step B c unfolding \<Delta>1_def \<Delta>2_def B_def
          by (intro matchI[of s1 a ou s' vl1 vl1]) (auto simp: consume_def)
      qed
    qed
    with B_Nil_Nil[OF B] show ?thesis by auto
  qed
qed

lemma unwind_cont_\<Delta>1: "unwind_cont \<Delta>1 {\<Delta>1,\<Delta>2}"
proof(rule, simp)
  let ?\<Delta> = "\<lambda>s vl s1 vl1. \<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>1 s vl s1 vl1"
  then have rs: "reach s" and s: "s1 = s" and BO: "BO vl vl1"
        and vVS1: "validValSeqFrom vl1 s1"
    using reachNT_reach unfolding \<Delta>1_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"
        consider (Eq) "vl1 = vl"
          | (BC) vl0 vl'' vl1'' where "vl = vl0 @ OVal False # vl''"
                                and "vl1 = vl0 @ OVal False # vl1''"
                                and "BC vl'' vl1''"
          using BO
          by (auto simp: BO_def)
        then have "?match"
        proof cases
          case Eq
          then show ?thesis
            using step s c vVS1 step_validValSeqFrom[OF step rs c]
            by (intro matchI[of s1 a ou s' vl1 vl']) (auto simp: \<Delta>1_def BO_def)
        next
          case BC
          show "?match" proof (cases vl0)
            case Nil
              then have "consume ?trn vl1 vl1''" and "vl' = vl''" and f: "f ?trn = OVal False"
                using \<phi> c BC by (auto simp: consume_def)
              moreover then have "validValSeqFrom vl1'' s'"
                using s rs vVS1 by (intro step_validValSeqFrom[OF step]) auto
              moreover have "\<not>open s'" using \<phi> step rs f by (auto elim: \<phi>E)
              ultimately show ?thesis
                using step s BC by (intro matchI[of s1 a ou s' vl1 vl1'']) (auto simp: \<Delta>2_def)
          next
            case (Cons v vl0')
              then have "consume ?trn vl1 (vl0' @ OVal False # vl1'')" and "vl' = vl0' @ OVal False # vl''"
                using \<phi> c BC by (auto simp: consume_def)
              moreover then have "validValSeqFrom (vl0' @ OVal False # vl1'') s'"
                using s rs vVS1 by (intro step_validValSeqFrom[OF step]) auto
              ultimately show ?thesis
                using step s BC
                by (intro matchI[of s1 a ou s' vl1 "(vl0' @ OVal False # vl1'')"]) (auto simp: \<Delta>1_def BO_def)
          qed
        qed
        then show "?match \<or> ?ignore" ..
      next
        assume n\<phi>: "\<not>\<phi> ?trn"
        then have "consume ?trn vl1 vl1" and "vl' = vl" using c by (auto simp: consume_def)
        moreover then have "validValSeqFrom vl1 s'"
          using s rs vVS1 by (intro step_validValSeqFrom[OF step]) auto
        ultimately have "?match"
          using step s BO by (intro matchI[of s1 a ou s' vl1 vl1]) (auto simp: \<Delta>1_def)
        then show "?match \<or> ?ignore" ..
      qed
    qed
    with BO show ?thesis by (auto simp: BO_def)
  qed
qed

lemma unwind_cont_\<Delta>2: "unwind_cont \<Delta>2 {\<Delta>2}"
proof(rule, simp)
  fix s s1 :: state and vl vl1 :: "value list"
  assume rsT: "reachNT s" and rs1: "reach s1" and \<Delta>2: "\<Delta>2 s vl s1 vl1"
  then have rs: "reach s" and ss1: "eqButUID s s1" and BC: "BC vl vl1"
        and os: "\<not>open s1" and vVS1: "validValSeqFrom vl1 s1"
    using reachNT_reach unfolding \<Delta>2_def by auto
  show "iaction \<Delta>2 s vl s1 vl1 \<or>
        ((vl = [] \<longrightarrow> vl1 = []) \<and> reaction \<Delta>2 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>2 s s1 vl1 a ou s' vl' \<or> ignore \<Delta>2 s s1 vl1 a ou s' vl'" (is "?match \<or> ?ignore")
      proof cases
        assume \<phi>: "\<phi> ?trn"
        with BC c have "?match" proof (cases rule: BC.cases)
          case (BC_FrVal vl'' vl1'' uid' aid uid st st')
            then show ?thesis proof (cases st')
              case True
                let ?a1 = "COMact (comSendCreateOFriend UID (pass s1 UID) aid uid')"
                let ?ou1 = "O_sendCreateOFriend (aid, clientPass s aid, UID, uid')"
                let ?s1' = "snd (sendCreateOFriend s1 UID (pass s1 UID) aid uid')"
                let ?trn1 = "Trans s1 ?a1 ?ou1 ?s1'"
                have c1: "consume ?trn1 vl1 vl1''" and "vl' = vl''" and "f ?trn = FrVal aid uid st"
                  using \<phi> c BC_FrVal True by (auto simp: consume_def)
                moreover then have a: "(a = COMact (comSendCreateOFriend UID (pass s UID) aid uid)
                                        \<and> ou = O_sendCreateOFriend (aid, clientPass s aid, UID, uid))
                                     \<or> (a = COMact (comSendDeleteOFriend UID (pass s UID) aid uid)
                                        \<and> ou = O_sendDeleteOFriend (aid, clientPass s aid, UID, uid))"
                               and IDs: "IDsOK s [UID] [] [] [aid]"
                               and uid: "uid \<notin> UIDs aid"
                  using \<phi> step rs by (auto elim!: \<phi>E split: prod.splits simp: com_defs)
                moreover have step1: "step s1 ?a1 = (?ou1, ?s1')"
                  using IDs vVS1 BC_FrVal True ss1 by (auto simp: com_defs eqButUID_def)
                moreover then have "validValSeqFrom vl1'' ?s1'"
                  using vVS1 rs1 c1 by (intro step_validValSeqFrom[OF step1]) auto
                moreover have "\<not>open ?s1'" using os by (auto simp: open_def com_defs)
                moreover have "eqButUID s' ?s1'"
                  using ss1 step a uid BC_FrVal(4) eqButUID_eqButUIDf[OF ss1] eqButUID_eqButUIDs[OF ss1]
                  by (auto split: prod.splits simp: com_defs filter_remove1 intro!: eqButUID_cong eqButUIDf_cong)
                moreover have "\<gamma> ?trn = \<gamma> ?trn1" and "g ?trn = g ?trn1"
                  using BC_FrVal a uid by (auto simp: com_defs)
                ultimately show "?match"
                  using BC_FrVal by (intro matchI[of s1 ?a1 ?ou1 ?s1' vl1 vl1'']) (auto simp: \<Delta>2_def)
            next
              case False
                let ?a1 = "COMact (comSendDeleteOFriend UID (pass s1 UID) aid uid')"
                let ?ou1 = "O_sendDeleteOFriend (aid, clientPass s aid, UID, uid')"
                let ?s1' = "snd (sendDeleteOFriend s1 UID (pass s1 UID) aid uid')"
                let ?trn1 = "Trans s1 ?a1 ?ou1 ?s1'"
                have c1: "consume ?trn1 vl1 vl1''" and "vl' = vl''" and "f ?trn = FrVal aid uid st"
                  using \<phi> c BC_FrVal False by (auto simp: consume_def)
                moreover then have a: "(a = COMact (comSendCreateOFriend UID (pass s UID) aid uid)
                                        \<and> ou = O_sendCreateOFriend (aid, clientPass s aid, UID, uid))
                                     \<or> (a = COMact (comSendDeleteOFriend UID (pass s UID) aid uid)
                                        \<and> ou = O_sendDeleteOFriend (aid, clientPass s aid, UID, uid))"
                               and IDs: "IDsOK s [UID] [] [] [aid]"
                               and uid: "uid \<notin> UIDs aid"
                  using \<phi> step rs by (auto elim!: \<phi>E split: prod.splits simp: com_defs)
                moreover have step1: "step s1 ?a1 = (?ou1, ?s1')"
                  using IDs vVS1 BC_FrVal False ss1 by (auto simp: com_defs eqButUID_def)
                moreover then have "validValSeqFrom vl1'' ?s1'"
                  using vVS1 rs1 c1 by (intro step_validValSeqFrom[OF step1]) auto
                moreover have "\<not>open ?s1'" using os by (auto simp: open_def com_defs)
                moreover have "eqButUID s' ?s1'"
                  using ss1 step a uid BC_FrVal(4) eqButUID_eqButUIDf[OF ss1] eqButUID_eqButUIDs[OF ss1]
                  by (auto split: prod.splits simp: com_defs filter_remove1 intro!: eqButUID_cong eqButUIDf_cong)
                moreover have "\<gamma> ?trn = \<gamma> ?trn1" and "g ?trn = g ?trn1"
                  using BC_FrVal a uid by (auto simp: com_defs)
                ultimately show "?match"
                  using BC_FrVal by (intro matchI[of s1 ?a1 ?ou1 ?s1' vl1 vl1'']) (auto simp: \<Delta>2_def)
            qed
        qed (auto simp: consume_def)
        then show "?match \<or> ?ignore" ..
      next
        assume n\<phi>: "\<not>\<phi> ?trn"
        then have vl': "vl' = vl" using c by (auto simp: consume_def)
        obtain ou1 s1' where step1: "step s1 a = (ou1, s1')" by (cases "step s1 a")
        let ?trn1 = "Trans s1 a ou1 s1'"
        show "?match \<or> ?ignore"
        proof (cases "\<forall>aID uID'. uID' \<notin> UIDs aID \<longrightarrow>
                                 a \<noteq> COMact (comSendCreateOFriend UID (pass s UID) aID uID') \<and>
                                 a \<noteq> COMact (comSendDeleteOFriend UID (pass s UID) aID uID')")
          case True
            then have n\<phi>1: "\<not>\<phi> ?trn1"
              using n\<phi> ss1 rs rs1 step step1 by (auto simp: eqButUID_step_\<phi>)
            have "?match" using step1 unfolding vl' proof (intro matchI[of s1 a ou1 s1' vl1 vl1])
              show c1: "consume ?trn1 vl1 vl1" using n\<phi>1 by (auto simp: consume_def)
              show "\<Delta>2 s' vl s1' vl1" using BC unfolding \<Delta>2_def proof (intro conjI)
                show "eqButUID s' s1'" using eqButUID_step[OF ss1 step step1 rs rs1] .
                show "\<not>open s1'" proof
                  assume "open s1'"
                  with os have "open s1 \<noteq> open s1'" by auto
                  then show "False" using step1 n\<phi>1 by (elim open_step_cases[of s1 s1']) auto
                qed
                show "validValSeqFrom vl1 s1'"
                  using c1 rs1 vVS1 by (intro step_validValSeqFrom[OF step1]) auto
              qed auto
              show "\<gamma> ?trn = \<gamma> ?trn1" using ss1 rs rs1 step step1 True by (intro eqButUID_step_\<gamma>) auto
            next
              assume "\<gamma> ?trn"
              then have "ou = ou1" using os n\<phi> n\<phi>1 by (intro eqButUID_step_\<gamma>_out[OF ss1 step step1]) auto
              then show "g ?trn = g ?trn1" by (cases a) auto
            qed auto
            then show "?match \<or> ?ignore" ..
        next
          case False
            with n\<phi> have "?ignore"
              using UID_UIDs BC step ss1 os vVS1 unfolding vl'
              by (intro ignoreI) (auto simp: \<Delta>2_def split: prod.splits)
            then show "?match \<or> ?ignore" ..
        qed
      qed
    qed
    with BC show ?thesis by (cases rule: BC.cases) auto
  qed
qed

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

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

end

end


(*
 * Copyright 2017, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * Author: Zhe Hou.
 *)

theory Separata_Pointers
imports Main Separata_Advanced
begin

abbreviation (input)
pred_eq :: "'a \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> bool" (infixr "eq" 50) where
"a eq b \<equiv> \<lambda>s. a = b"

text {* In the heap model, 'b are the addresses, 'c are the values, 'a
are the heaps. *}

locale pointsto_algebra =
  fixes pointsto :: "'a \<Rightarrow> 'b \<Rightarrow> ('c::heap_sep_algebra) \<Rightarrow> bool" (infix "\<mapsto>" 40)

  assumes pointsto_inject: "\<lbrakk>(n \<mapsto> l) h1; (n \<mapsto> l) h2\<rbrakk> \<Longrightarrow> h1 = h2"
begin

lemma lssl_l5:
"Gamma \<and> h1 = h2 \<and> (n \<mapsto> l) h1 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (n \<mapsto> l) h1 \<and> (n \<mapsto> l) h2 \<longrightarrow> Delta"
using local.pointsto_inject by blast

lemma lssl_l5_inv:
"Gamma \<and> (n \<mapsto> l) h1 \<and> (n \<mapsto> l) h2 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> h1 = h2 \<and> (n \<mapsto> l) h1 \<longrightarrow> Delta"
by auto

lemma lssl_l5_der: "(n \<mapsto> l) h1 \<Longrightarrow> (n \<mapsto> l) h2 \<Longrightarrow> h1 = h2"
by (simp add: local.pointsto_inject)

text {* Operations about pointers. *}

definition substate:: "'c \<Rightarrow> 'c \<Rightarrow> bool" (infix "\<sqsubseteq>" 40) where
"h1 \<sqsubseteq> h2 \<equiv> \<exists>h3. (h1,h3\<triangleright>h2)"

definition state_as_fun:: "'c \<Rightarrow> 'a \<Rightarrow> 'b option" (infix "\<restriction>" 100) where
"h\<restriction>a \<equiv>
  let P = (\<lambda>v h a. \<exists>h'. h' \<sqsubseteq> h \<and> (a \<mapsto> v) h') in
  if  \<exists>v. P v h a then
    Some (SOME v. P v h a)
  else None"

definition set_val:: "'c \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c" where
"set_val h a v \<equiv> SOME h'. (\<forall>a'. (a'\<noteq>a \<longrightarrow> h'\<restriction>a' = h\<restriction>a') \<and> (h'\<restriction>a = Some v))"

definition all_elements:: "'a set" where
"all_elements \<equiv> {x. True}"

definition domain:: "'c \<Rightarrow> 'a set" where
"domain h \<equiv> {a. \<exists>v. h\<restriction>a = Some v}"

definition all_domains:: "'c set \<Rightarrow> 'a set" where
"all_domains hs \<equiv> {a. \<forall>h \<in> hs. \<exists>v. h\<restriction>a = Some v}"

definition heaps_of_domain:: "'a set \<Rightarrow> 'c set" where
"heaps_of_domain d \<equiv> {h. domain h = d}"

definition full_domain_heaps:: "'c set" where
"full_domain_heaps \<equiv> {h. domain h = all_elements}"

definition disjoint_domain::"'c \<Rightarrow> 'a set" where
"disjoint_domain h \<equiv> all_elements - (domain h)"

definition vals:: "'c \<Rightarrow> 'b set" where
"vals h \<equiv> {v. \<exists>a. h\<restriction>a = Some v}"

definition is_empty:: "'c \<Rightarrow> bool" where
"is_empty h \<equiv> domain h = {}"

definition get_state:: "'a \<Rightarrow> 'b \<Rightarrow> 'c" where
"get_state a v \<equiv> THE h. (a \<mapsto> v) h"

lemma dom_not_empty: "(a \<in> domain h) = (\<exists>v. (h\<restriction>a = Some v \<and> is_empty h = False))"
using domain_def local.is_empty_def by auto

lemma dom_not_none: "(a \<in> domain h) \<Longrightarrow> (h\<restriction>a \<noteq> None)"
by (simp add: dom_not_empty)

end

locale reynolds_algebra = pointsto_algebra +
  assumes pointsto_no_emp: "\<not>((n \<mapsto> l) 0)"
  assumes pointsto_no_larger_than_one: "\<lbrakk>(n \<mapsto> l) h; (h1,h2\<triangleright>h)\<rbrakk> \<Longrightarrow> (h1 = 0) \<or> (h2 = 0)"
  assumes pointsto_addr_disj: "\<lbrakk>(n1 \<mapsto> l1) h1; (n2 \<mapsto> l2) h2; (h1,h2\<triangleright>h)\<rbrakk> \<Longrightarrow> \<not> (n1 = n2)"
  assumes pointsto_unique: "\<lbrakk>(n1 \<mapsto> l1) h; (n2 \<mapsto> l2) h\<rbrakk> \<Longrightarrow> n1 = n2 \<and> l1 = l2"

  assumes pointsto_extend: "\<exists>n h1 h2. (h1,h\<triangleright>h2) \<and> (n \<mapsto> l) h1"
begin

text {* The following are properties of definitions on pointers. *}

lemma id_is_empty: "is_empty 0"
by (metis (no_types, lifting) Collect_empty_eq dom_not_none domain_def local.is_empty_def lspasl_iu_eq mem_Collect_eq pointsto_no_emp state_as_fun_def substate_def)

text {* The following are more inferences rules for pointers. *}

lemma lssl_l1: "Gamma \<and> (n \<mapsto> l) 0 \<longrightarrow> Delta"
by (simp add: local.pointsto_no_emp)

lemma lssl_l2:
"\<lbrakk>Gamma \<and> (0,h0\<triangleright>h0) \<and> (n \<mapsto> l) h0 \<and> h1 = 0 \<and> h2 = h0 \<longrightarrow> Delta;
  Gamma \<and> (h0,0\<triangleright>h0) \<and> (n \<mapsto> l) h0 \<and> h2 = 0 \<and> h1 = h0 \<longrightarrow> Delta\<rbrakk> \<Longrightarrow>
  Gamma \<and> (h1,h2\<triangleright>h0) \<and> (n \<mapsto> l) h0 \<longrightarrow> Delta"
by (metis heap_sep_algebra_class.lspasl_eq_der2 heap_sep_algebra_class.lspasl_eq_eq pointsto_no_larger_than_one)

lemma lssl_l2_inv:
"Gamma \<and> (h1,h2\<triangleright>h0) \<and> (n \<mapsto> l) h0 \<longrightarrow> Delta \<Longrightarrow>
(Gamma \<and> (0,h0\<triangleright>h0) \<and> (n \<mapsto> l) h0 \<and> h1 = 0 \<and> h0 = h2 \<longrightarrow> Delta) \<or>
(Gamma \<and> (h0,0\<triangleright>h0) \<and> (n \<mapsto> l) h0 \<and> h2 = 0 \<and> h0 = h1 \<longrightarrow> Delta)"
by blast

lemma lssl_l2_der:
"(h1,h2\<triangleright>h0) \<Longrightarrow> (n \<mapsto> l) h0 \<Longrightarrow> (h1 = 0 \<and> h0 = h2) \<or> (h2 = 0 \<and> h0 = h1)"
by (metis lssl_l2)

lemma lssl_l3: "Gamma \<and> (h1,h2\<triangleright>h0) \<and> (n\<mapsto>l1) h1 \<and> (n\<mapsto>l2) h2 \<longrightarrow> Delta"
using local.pointsto_addr_disj by blast

lemma lssl_l3_der:
"(h1,h2\<triangleright>h0) \<Longrightarrow> (n\<mapsto>l1) h1 \<Longrightarrow> (n\<mapsto>l2) h2 \<Longrightarrow> False"
using local.pointsto_addr_disj by blast

lemma lssl_l4:
"Gamma \<and> (n1\<mapsto>l1) h \<and> n1 = n2 \<and> l1 = l2 \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (n1\<mapsto>l1) h \<and> (n2\<mapsto>l2) h \<longrightarrow> Delta"
using local.pointsto_unique by blast

lemma lssl_l4_inv:
"Gamma \<and> (n1\<mapsto>l1) h \<and> (n2\<mapsto>l2) h \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<and> (n1\<mapsto>l1) h \<and> n1 = n2 \<and> l1 = l2 \<longrightarrow> Delta"
by auto

lemma lssl_l4_der:
"(n1\<mapsto>l1) h \<Longrightarrow> (n2\<mapsto>l2) h \<Longrightarrow> n1 = n2 \<and> l1 = l2"
by (simp add: local.pointsto_unique)

lemma lssl_l6:
"(\<exists>h1 h2 n. (Gamma \<and> (h1,h0\<triangleright>h2) \<and> (n\<mapsto>l) h1)) \<longrightarrow> Delta \<Longrightarrow>
 Gamma \<longrightarrow> Delta"
using local.pointsto_extend by blast

lemma lssl_l6_inv:
"Gamma \<longrightarrow> Delta \<Longrightarrow>
 (\<exists>h1 h2 n. (Gamma \<and> (h1,h0\<triangleright>h2) \<and> (n\<mapsto>l) h1)) \<longrightarrow> Delta"
by simp

lemma lssl_l6_der: "\<exists>h1 h2 n. (h1,h0\<triangleright>h2) \<and> (n\<mapsto>l) h1"
using local.pointsto_extend by blast

end

context reynolds_algebra
begin

text {* The following rule applications are for the |-> predicate. *}

method try_lssl_l1 = (
match premises in P[thin]:"(?n \<mapsto> ?l) (0)" \<Rightarrow>
  \<open>insert P, auto simp add: pointsto_no_emp\<close>
)

method try_lssl_l2 = (
match premises in P:"(n \<mapsto> l) (h)" for h n l \<Rightarrow>
  \<open>match premises in P'[thin]: "(?h1,?h2\<triangleright>h)" \<Rightarrow>
    \<open>match P' in "(0,h\<triangleright>h)" \<Rightarrow> \<open>fail\<close>
     \<bar>"(h,0\<triangleright>h)" \<Rightarrow> \<open>fail\<close>
     \<bar>_ \<Rightarrow> \<open>insert lssl_l2_der[OF P' P],auto\<close>\<close>\<close>,
simp_all?
)

method try_lssl_l3 = (
match premises in P:"(h1,h2\<triangleright>?h0)" and P':"(n \<mapsto> ?l1) (h1)"
  and P'':"(n \<mapsto> ?l2) (h2)" for h1 h2 n \<Rightarrow>
  \<open>insert lssl_l3_der[OF P P' P'']\<close>,
auto?
)

method try_lssl_l4 = (
match premises in P[thin]:"(n1\<mapsto>l1) (h)" for n1 l1 h \<Rightarrow>
  \<open>match premises in "(n1\<mapsto>l1) h" \<Rightarrow> \<open>fail\<close>
  \<bar>P':"(?n2\<mapsto>?l2) h" \<Rightarrow> \<open>insert lssl_l4_der[OF P P']\<close>\<close>,
simp?
)

method try_lssl_l5 = (
match premises in P[thin]: "(n\<mapsto>l) (h1)" for n l h1 \<Rightarrow>
  \<open>match premises in "(n\<mapsto>l) h1" \<Rightarrow> \<open>fail\<close>
  \<bar>P':"(n\<mapsto>l) ?h" \<Rightarrow> \<open>insert lssl_l5_der[OF P P']\<close>\<close>,
simp?
)

text {* We don't implement the application of HE because it's too expensive. *}

text {* The following is an alternative for reasoning about pointers. *}

method invert_pointer = (
(try_lssl_l1
|try_lssl_l3
|try_lssl_l4
|try_lssl_l5
|try_lspasl_empl
|try_lspasl_iu
|try_lspasl_d
|try_lspasl_eq
|try_lspasl_p
|try_lspasl_c
|try_lssl_l2
|(magic_mp_tac,(drule magic_mp),auto?,prep?)
|try_lspasl_starl
|try_lspasl_magicr
|try_lspasl_starr_guided
|try_lspasl_magicl_guided)+,
auto?)

method sepointer =
(prep
 |(invert_pointer
  |try_lsfasl_boxl
  |struct
  |noninvert
 )+
 |rare
)+

method starpointer =
(prep
 |(invert_pointer
  |(try_lspasl_starr_smart,(try_lspasl_starr,starr_solve_terns?)+) (* Tactics for solving *R formulae. *)
  |try_lsfasl_boxl
  |struct
  |noninvert
 )+
 |rare
)+

end

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim_Pres
  imports Weak_Bisimulation Weak_Sim_Pres Weak_Stat_Imp_Pres
begin

context env begin

lemma weakBisimInputPres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<And>Tvec. length xvec = length Tvec \<Longrightarrow> \<Psi> \<rhd> P[xvec::=Tvec] \<approx> Q[xvec::=Tvec]"

  shows "\<Psi> \<rhd> M\<lparr>\<lambda>*xvec N\<rparr>.P \<approx> M\<lparr>\<lambda>*xvec N\<rparr>.Q"
proof -
  let ?X = "{(\<Psi>, M\<lparr>\<lambda>*xvec N\<rparr>.P, M\<lparr>\<lambda>*xvec N\<rparr>.Q) | \<Psi> M xvec N P Q. \<forall>Tvec. length xvec = length Tvec \<longrightarrow> \<Psi> \<rhd> P[xvec::=Tvec] \<approx> Q[xvec::=Tvec]}"

  from assms have "(\<Psi>, M\<lparr>\<lambda>*xvec N\<rparr>.P, M\<lparr>\<lambda>*xvec N\<rparr>.Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case by(fastforce intro: weakStatImpInputPres dest: weakBisimE(3))
  next
    case(cSim \<Psi> P Q)
    thus ?case
      by auto (blast intro: weakInputPres dest: weakBisimE)
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimOutputPres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> M\<langle>N\<rangle>.P \<approx> M\<langle>N\<rangle>.Q"
proof -
  let ?X = "{(\<Psi>, M\<langle>N\<rangle>.P, M\<langle>N\<rangle>.Q) | \<Psi> M N P Q. \<Psi> \<rhd> P \<approx> Q}"

  from assms have "(\<Psi>, M\<langle>N\<rangle>.P, M\<langle>N\<rangle>.Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case by auto (blast intro: weakStatImpOutputPres dest: weakBisimE(3))
  next
    case(cSim \<Psi> P Q)
    thus ?case
      by(auto intro: weakOutputPres dest: weakBisimE)
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<approx> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | \<Psi> x P Q. \<Psi> \<rhd> P \<approx> Q \<and> x \<sharp> \<Psi>}"

  from assms have "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> xP xQ)
    {
      fix \<Psi> P Q x
      assume "\<Psi> \<rhd> P \<approx> Q"
      hence "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
      moreover have "eqvt weakBisim" by auto
      moreover assume "(x::name) \<sharp> \<Psi>"
      moreover have "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> weakBisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
        by auto
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<lessapprox><(?X \<union> weakBisim)> \<lparr>\<nu>x\<rparr>Q"
        by(rule weakStatImpResPres)
    }
    with \<open>(\<Psi>, xP, xQ) \<in> ?X\<close> show ?case by auto
  next
    case(cSim \<Psi> xP xQ)
    from \<open>(\<Psi>, xP, xQ) \<in> ?X\<close> obtain x P Q where "\<Psi> \<rhd> P \<approx> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<rhd> P \<leadsto><weakBisim> Q" by(rule weakBisimE)
    moreover have "eqvt ?X"
      by(force simp add: eqvt_def weakBisimClosed pt_fresh_bij[OF pt_name_inst, OF at_name_inst])
    hence "eqvt(?X \<union> weakBisim)" by auto
    moreover note \<open>x \<sharp> \<Psi>\<close>
    moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by auto
    moreover have "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> weakBisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
      by auto
    ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>x\<rparr>Q"
      by(rule weakResPres)
    with \<open>xP = \<lparr>\<nu>x\<rparr>P\<close> \<open>xQ = \<lparr>\<nu>x\<rparr>Q\<close> show ?case
      by simp
  next
    case(cExt \<Psi> xP xQ \<Psi>')
    from \<open>(\<Psi>, xP, xQ) \<in> ?X\<close> obtain x P Q where "\<Psi> \<rhd> P \<approx> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<Psi>" and "y \<sharp> \<Psi>'"
     by(generate_fresh "name", auto simp add: fresh_prod)
   from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<otimes> ([(x, y)] \<bullet> \<Psi>') \<rhd> P \<approx> Q"
     by(rule weakBisimE)
   hence "([(x, y)] \<bullet> (\<Psi> \<otimes> ([(x, y)] \<bullet> \<Psi>'))) \<rhd> ([(x, y)] \<bullet> P) \<approx> ([(x, y)] \<bullet> Q)"
     by(rule weakBisimClosed)
   with \<open>x \<sharp> \<Psi>\<close> \<open>y \<sharp> \<Psi>\<close> have "\<Psi> \<otimes> \<Psi>' \<rhd> ([(x, y)] \<bullet> P) \<approx> ([(x, y)] \<bullet> Q)"
     by(simp add: eqvts)
   with \<open>y \<sharp> \<Psi>\<close> \<open>y \<sharp> \<Psi>'\<close> have "(\<Psi> \<otimes> \<Psi>', \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P), \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> Q)) \<in> ?X"
     by auto
   moreover from \<open>y \<sharp> P\<close> \<open>y \<sharp> Q\<close> have "\<lparr>\<nu>x\<rparr>P = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P)" and "\<lparr>\<nu>x\<rparr>Q = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> Q)"
     by(simp add: alphaRes)+
   ultimately show ?case using \<open>xP = \<lparr>\<nu>x\<rparr>P\<close> \<open>xQ = \<lparr>\<nu>x\<rparr>Q\<close> by simp
 next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimResChainPres:
  fixes \<Psi>   :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   xvec :: "name list"

  assumes "\<Psi> \<rhd> P \<approx> Q"
  and     "xvec \<sharp>* \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>P \<approx> \<lparr>\<nu>*xvec\<rparr>Q"
using assms
by(induct xvec) (auto intro: weakBisimResPres)

lemma weakBisimParPresAux:
  fixes \<Psi>  :: 'b
  and   \<Psi>\<^sub>R :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   Q  :: "('a, 'b, 'c) psi"
  and   R  :: "('a, 'b, 'c) psi"
  and   A\<^sub>R :: "name list"

  assumes "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
  and     FrR: "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
  and     "A\<^sub>R \<sharp>* \<Psi>"
  and     "A\<^sub>R \<sharp>* P"
  and     "A\<^sub>R \<sharp>* Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?X = "{(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) | xvec \<Psi> P Q R. xvec \<sharp>* \<Psi> \<and> (\<forall>A\<^sub>R \<Psi>\<^sub>R. (extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q) \<longrightarrow>
                                                                                \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q)}"
  {
    fix xvec :: "name list"
    and \<Psi>    :: 'b
    and P    :: "('a, 'b, 'c) psi"
    and Q    :: "('a, 'b, 'c) psi"
    and R    :: "('a, 'b, 'c) psi"

    assume "xvec \<sharp>* \<Psi>"
    and    "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"

    hence "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X"
      by blast
  }
  note XI = this

  {
    fix xvec :: "name list"
    and \<Psi>    :: 'b
    and P    :: "('a, 'b, 'c) psi"
    and Q    :: "('a, 'b, 'c) psi"
    and R    :: "('a, 'b, 'c) psi"
    and C    :: "'d::fs_name"

    assume "xvec \<sharp>* \<Psi>"
    and    A: "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q; A\<^sub>R \<sharp>* C\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"

    from \<open>xvec \<sharp>* \<Psi>\<close> have "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X"
    proof(rule XI)
      fix A\<^sub>R \<Psi>\<^sub>R
      assume FrR: "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
      obtain p::"name prm" where "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>R) \<sharp>* P" and "(p \<bullet> A\<^sub>R) \<sharp>* Q" and "(p \<bullet> A\<^sub>R) \<sharp>* R" and "(p \<bullet> A\<^sub>R) \<sharp>* C"
                             and "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<^sub>R" and S: "(set p) \<subseteq> (set A\<^sub>R) \<times> (set(p \<bullet> A\<^sub>R))" and "distinctPerm p"
        by(rule_tac c="(\<Psi>, P, Q, R, \<Psi>\<^sub>R, C)" in name_list_avoiding) auto
      from FrR \<open>(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<^sub>R\<close> S have "extractFrame R = \<langle>(p \<bullet> A\<^sub>R), p \<bullet> \<Psi>\<^sub>R\<rangle>" by(simp add: frameChainAlpha')

      moreover assume "A\<^sub>R \<sharp>* \<Psi>"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> \<Psi>)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with \<open>A\<^sub>R \<sharp>* \<Psi>\<close> \<open>(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<close> S have "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" by simp
      moreover assume "A\<^sub>R \<sharp>* P"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> P)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with \<open>A\<^sub>R \<sharp>* P\<close> \<open>(p \<bullet> A\<^sub>R) \<sharp>* P\<close> S have "(p \<bullet> A\<^sub>R) \<sharp>* P" by simp
      moreover assume "A\<^sub>R \<sharp>* Q"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> Q)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with \<open>A\<^sub>R \<sharp>* Q\<close> \<open>(p \<bullet> A\<^sub>R) \<sharp>* Q\<close> S have "(p \<bullet> A\<^sub>R) \<sharp>* Q" by simp
      ultimately have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q" using \<open>(p \<bullet> A\<^sub>R) \<sharp>* C\<close> A by blast
      hence "(p \<bullet> (\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)" by(rule weakBisimClosed)
      with \<open>A\<^sub>R \<sharp>* \<Psi>\<close> \<open>(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<close> \<open>A\<^sub>R \<sharp>* P\<close> \<open>(p \<bullet> A\<^sub>R) \<sharp>* P\<close> \<open>A\<^sub>R \<sharp>* Q\<close> \<open>(p \<bullet> A\<^sub>R) \<sharp>* Q\<close> S \<open>distinctPerm p\<close>
      show "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q" by(simp add: eqvts)
    qed
  }
  note XI' = this

  have "eqvt ?X"
    apply(auto simp add: eqvt_def)
    apply(rule_tac x="p \<bullet> xvec" in exI)
    apply(rule_tac x="p \<bullet> P" in exI)
    apply(rule_tac x="p \<bullet> Q" in exI)
    apply(rule_tac x="p \<bullet> R" in exI)
    apply(simp add: eqvts)
    apply(simp add: fresh_star_bij)
    apply(clarify)
    apply(erule_tac x="(rev p) \<bullet> A\<^sub>R" in allE)
    apply(erule_tac x="(rev p) \<bullet> \<Psi>\<^sub>R" in allE)
    apply(drule mp)
    apply(rule conjI)
    apply(rule_tac pi=p in pt_bij4[OF pt_name_inst, OF at_name_inst])
    apply(simp add: eqvts)
    defer
    apply(drule_tac p=p in weakBisimClosed)
    apply(simp add: eqvts)
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    apply simp
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    apply simp
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    by simp

  moreover have Res: "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> weakBisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
  proof -
    fix \<Psi> P Q x
    assume "(\<Psi>, P, Q) \<in> ?X \<union> weakBisim" and "(x::name) \<sharp> \<Psi>"
    show "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
    proof(case_tac "(\<Psi>, P, Q) \<in> ?X")
      assume "(\<Psi>, P, Q) \<in> ?X"
      with \<open>x \<sharp> \<Psi>\<close> have "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X"
        apply auto
        by(rule_tac x="x#xvec" in exI) auto
      thus ?thesis by simp
    next
      assume "\<not>(\<Psi>, P, Q) \<in> ?X"
      with \<open>(\<Psi>, P, Q) \<in> ?X \<union> weakBisim\<close> have "\<Psi> \<rhd> P \<approx> Q"
        by blast
      hence "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<approx> \<lparr>\<nu>x\<rparr>Q" using \<open>x \<sharp> \<Psi>\<close>
        by(rule weakBisimResPres)
      thus ?thesis
        by simp
    qed
  qed

  {
    fix \<Psi>  :: 'b
      and P  :: "('a, 'b, 'c) psi"
      and Q  :: "('a, 'b, 'c) psi"
      and \<Psi>' :: 'b

    assume "\<Psi> \<rhd> P \<approx> Q"

    hence "\<Psi> \<rhd> Q \<approx> P" by(rule weakBisimE)
    then obtain P' P'' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'"
                         and QimpP': "insertAssertion(extractFrame Q) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion(extractFrame P') \<Psi>"
                         and P'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> P' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P''"
                         and "\<Psi> \<otimes> \<Psi>' \<rhd> Q \<approx> P''" using weakStatImp_def
      by(blast dest: weakBisimE)
    note PChain QimpP' P'Chain
    moreover from \<open>\<Psi> \<otimes> \<Psi>' \<rhd> Q \<approx> P''\<close> have "\<Psi> \<otimes> \<Psi>' \<rhd> P'' \<approx> Q" by(rule weakBisimE)
    ultimately have "\<exists>P' P''. \<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P' \<and> insertAssertion(extractFrame Q) \<Psi> \<hookrightarrow>\<^sub>F insertAssertion(extractFrame P') \<Psi> \<and>
                              \<Psi> \<otimes> \<Psi>' \<rhd> P' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'' \<and> \<Psi> \<otimes> \<Psi>' \<rhd> P'' \<approx> Q"
      by blast
  }
  moreover
  {
    fix \<Psi> P Q A\<^sub>R \<Psi>\<^sub>R R
    assume PSimQ: "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
       and FrR: "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
       and "A\<^sub>R \<sharp>* \<Psi>"
       and "A\<^sub>R \<sharp>* P"
       and "A\<^sub>R \<sharp>* Q"
    hence "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X"
    proof -
      have "P \<parallel> R = \<lparr>\<nu>*[]\<rparr>(P \<parallel> R)" by simp
      moreover have "Q \<parallel> R = \<lparr>\<nu>*[]\<rparr>(Q \<parallel> R)" by simp
      moreover have "([]::name list) \<sharp>* \<Psi>" by simp
      moreover
      {
        fix A\<^sub>R' \<Psi>\<^sub>R'

        assume FrR': "extractFrame R = \<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle>"
            and "A\<^sub>R' \<sharp>* \<Psi>"
            and "A\<^sub>R' \<sharp>* P"
            and "A\<^sub>R' \<sharp>* Q"
        obtain p where "(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* P"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* Q"
                   and S: "(set p) \<subseteq> (set A\<^sub>R') \<times> (set(p \<bullet> A\<^sub>R'))" and "distinctPerm p"
          by(rule_tac c="(A\<^sub>R, \<Psi>, \<Psi>\<^sub>R', P, Q)" in name_list_avoiding) auto

        from \<open>(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'\<close> S have "\<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle> = \<langle>p \<bullet> A\<^sub>R', p \<bullet> \<Psi>\<^sub>R'\<rangle>"
          by(simp add: frameChainAlpha)

        with FrR' have FrR'': "extractFrame R = \<langle>p \<bullet> A\<^sub>R', p \<bullet> \<Psi>\<^sub>R'\<rangle>" by simp
        with FrR \<open>(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R\<close>
        obtain q where "p \<bullet> \<Psi>\<^sub>R' = (q::name prm) \<bullet> \<Psi>\<^sub>R" and S': "set q \<subseteq> (set A\<^sub>R) \<times> set(p \<bullet> A\<^sub>R')" and "distinctPerm q"
          apply auto
          apply(drule_tac sym) apply simp
          by(drule_tac frameChainEq) auto
        from PSimQ have "(q \<bullet> (\<Psi> \<otimes> \<Psi>\<^sub>R)) \<rhd> (q \<bullet> P) \<approx> (q \<bullet> Q)"
          by(rule weakBisimClosed)
        with \<open>A\<^sub>R \<sharp>* \<Psi>\<close> \<open>A\<^sub>R \<sharp>* P\<close> \<open>A\<^sub>R \<sharp>* Q\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* P\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* Q\<close> S'
        have "\<Psi> \<otimes> (q \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q" by(simp add: eqvts)
        hence "(p \<bullet> (\<Psi> \<otimes> (q \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)" by(rule weakBisimClosed)
        with \<open>A\<^sub>R' \<sharp>* \<Psi>\<close> \<open>A\<^sub>R' \<sharp>* P\<close> \<open>A\<^sub>R' \<sharp>* Q\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* P\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* Q\<close> S \<open>distinctPerm p\<close> \<open>(p \<bullet> \<Psi>\<^sub>R') = q \<bullet> \<Psi>\<^sub>R\<close>
        have "\<Psi> \<otimes> \<Psi>\<^sub>R' \<rhd> P \<approx> Q"
          by(drule_tac sym) (simp add: eqvts)
      }
      ultimately show ?thesis
        by blast
    qed
    hence "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X \<union> weakBisim"
      by simp
  }
  note C1 = this

  have C2: "\<And>\<Psi> P Q xvec. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> weakBisim; (xvec::name list) \<sharp>* \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>*xvec\<rparr>P, \<lparr>\<nu>*xvec\<rparr>Q) \<in> ?X \<union> weakBisim"
  proof -
    fix \<Psi> P Q xvec
    assume "(\<Psi>, P, Q) \<in> ?X \<union> weakBisim"
    assume "(xvec::name list) \<sharp>* \<Psi>"
    thus "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>P, \<lparr>\<nu>*xvec\<rparr>Q) \<in> ?X \<union> weakBisim"
    proof(induct xvec)
      case Nil
      thus ?case using \<open>(\<Psi>, P, Q) \<in> ?X \<union> weakBisim\<close> by simp
    next
      case(Cons x xvec)
      thus ?case by(simp only: resChain.simps) (rule_tac Res, auto)
    qed
  qed

  {
    fix \<Psi> :: 'b
    and P :: "('a, 'b, 'c) psi"
    and Q :: "('a, 'b, 'c) psi"
    and R :: "('a, 'b, 'c) psi"
    and A\<^sub>R :: "name list"
    and \<Psi>\<^sub>R :: 'b

    assume "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
    and     FrR: "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
    and     "A\<^sub>R \<sharp>* \<Psi>"
    and     "A\<^sub>R \<sharp>* P"
    and     "A\<^sub>R \<sharp>* Q"

    have "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X"
    proof -
      {
        fix A\<^sub>R' :: "name list"
        and \<Psi>\<^sub>R' :: 'b

        assume FrR': "extractFrame R = \<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle>"
        and    "A\<^sub>R' \<sharp>* \<Psi>"
        and    "A\<^sub>R' \<sharp>* P"
        and    "A\<^sub>R' \<sharp>* Q"

        obtain p where "(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R" and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'" and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>R') \<sharp>* P" and "(p \<bullet> A\<^sub>R') \<sharp>* Q"
                   and Sp: "(set p) \<subseteq> (set A\<^sub>R') \<times> (set(p \<bullet> A\<^sub>R'))" and "distinctPerm p"
          by(rule_tac c="(A\<^sub>R, \<Psi>, \<Psi>\<^sub>R', P, Q)" in name_list_avoiding) auto

        from FrR' \<open>(p \<bullet> A\<^sub>R') \<sharp>*  \<Psi>\<^sub>R'\<close> Sp have "extractFrame R = \<langle>(p \<bullet> A\<^sub>R'), p \<bullet> \<Psi>\<^sub>R'\<rangle>"
          by(simp add: frameChainAlpha eqvts)
        with FrR \<open>(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R\<close> obtain q::"name prm"
          where Sq: "set q \<subseteq> set(p \<bullet> A\<^sub>R') \<times> set A\<^sub>R" and "distinctPerm q" and "\<Psi>\<^sub>R = q \<bullet> p \<bullet> \<Psi>\<^sub>R'"
          by(force elim: frameChainEq)

        from \<open>\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q\<close> \<open>\<Psi>\<^sub>R = q \<bullet> p \<bullet> \<Psi>\<^sub>R'\<close> have "\<Psi> \<otimes> (q \<bullet> p \<bullet> \<Psi>\<^sub>R') \<rhd> P \<approx> Q" by simp
        hence "(q \<bullet> (\<Psi> \<otimes> (q \<bullet> p \<bullet> \<Psi>\<^sub>R'))) \<rhd> (q \<bullet> P) \<approx> (q \<bullet> Q)" by(rule weakBisimClosed)
        with Sq \<open>A\<^sub>R \<sharp>* \<Psi>\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<close> \<open>A\<^sub>R \<sharp>* P\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* P\<close> \<open>A\<^sub>R \<sharp>* Q\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* Q\<close> \<open>distinctPerm q\<close>
        have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R') \<rhd> P \<approx> Q" by(simp add: eqvts)
        hence "(p \<bullet> (\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R'))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)" by(rule weakBisimClosed)
        with Sp \<open>A\<^sub>R' \<sharp>* \<Psi>\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<close> \<open>A\<^sub>R' \<sharp>* P\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* P\<close> \<open>A\<^sub>R' \<sharp>* Q\<close> \<open>(p \<bullet> A\<^sub>R') \<sharp>* Q\<close> \<open>distinctPerm p\<close>
        have "\<Psi> \<otimes> \<Psi>\<^sub>R' \<rhd> P \<approx> Q" by(simp add: eqvts)
      }
      thus ?thesis
        apply auto
        apply(rule_tac x="[]" in exI)
        by auto blast
    qed
  }
  note Goal = this
  with assms have "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> PR QR)
    {
      fix xvec :: "name list"
      fix P Q R
      assume A: "\<forall>A\<^sub>R \<Psi>\<^sub>R. extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q \<longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
      {
        fix A\<^sub>R \<Psi>\<^sub>R
        assume "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* P" and "A\<^sub>R \<sharp>* Q"
        with A have "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<lessapprox><weakBisim> Q" by(auto dest: weakBisimE)
      }
      moreover assume "xvec \<sharp>* \<Psi>"
      moreover have "eqvt weakBisim" by auto
      moreover note C1 C2 statEqWeakBisim
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) \<lessapprox><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
        by(rule weakStatImpParPres)
    }
    with \<open>(\<Psi>, PR, QR) \<in> ?X\<close> show ?case by auto
  next
    case(cSim \<Psi> PR QR)
    from \<open>(\<Psi>, PR, QR) \<in> ?X\<close>
    obtain xvec P Q R A\<^sub>R \<Psi>\<^sub>R where PFrR: "PR = \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R)" and QFrR: "QR = \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
                               and "xvec \<sharp>* \<Psi>"
      by auto
    with \<open>(\<Psi>, PR, QR) \<in> ?X\<close> have "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X" by simp
    hence "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)" using \<open>xvec \<sharp>* \<Psi>\<close>
    proof(induct xvec)
      case Nil
      from \<open>(\<Psi>, \<lparr>\<nu>*[]\<rparr>(P \<parallel> R), \<lparr>\<nu>*[]\<rparr>(Q \<parallel> R)) \<in> ?X\<close> have PRQR: "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X" by simp
      from PRQR have "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>;  A\<^sub>R \<sharp>* P;  A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> (\<Psi> \<otimes> \<Psi>\<^sub>R, P, Q) \<in> weakBisim"
        by auto
      moreover note weakBisimEqvt
      moreover from \<open>eqvt ?X\<close> have "eqvt(?X \<union> weakBisim)" by auto
      moreover note weakBisimE(2) weakBisimE(4) weakBisimE(3) weakBisimE(1)
      moreover note C1 C2
      ultimately have "\<Psi> \<rhd> P \<parallel> R \<leadsto><(?X \<union> weakBisim)> Q \<parallel> R" using statEqWeakBisim
        by(rule weakParPres)
      thus ?case by simp
    next
      case(Cons x xvec')
      from \<open>(x#xvec') \<sharp>* \<Psi>\<close> have "x \<sharp> \<Psi>" and "xvec' \<sharp>* \<Psi>" by simp+
      with \<open>(\<Psi>, \<lparr>\<nu>*(x#xvec')\<rparr>P \<parallel> R, \<lparr>\<nu>*(x#xvec')\<rparr>Q \<parallel> R) \<in> ?X\<close>
      have "(\<Psi>, \<lparr>\<nu>*(xvec')\<rparr>P \<parallel> R, \<lparr>\<nu>*(xvec')\<rparr>Q \<parallel> R) \<in> ?X"
        apply auto
        apply(subgoal_tac "\<exists>y yvec. xvec=y#yvec")
        apply(clarify)
        apply simp
        apply(simp add: psi.inject alpha)
        apply(clarify)
        apply(erule disjE)
        apply(erule disjE)
        apply(clarify)
        apply blast
        apply(clarify)
        apply(clarify)
        apply(simp add: eqvts)
        apply(rule_tac x="[(x, y)] \<bullet> yvec" in exI)
        apply(rule_tac x="[(x, y)] \<bullet> P" in exI)
        apply(rule_tac x="[(x, y)] \<bullet> Q" in exI)
        apply(rule_tac x="[(x, y)] \<bullet> R" in exI)
        apply(clarsimp)
        apply(rule conjI)
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(clarify)
        apply(erule_tac x="[(x, y)] \<bullet> A\<^sub>R" in allE)
        apply(erule_tac x="[(x, y)] \<bullet> \<Psi>\<^sub>R" in allE)
        apply(drule mp)
        apply(rule conjI)
        apply(rule_tac pi="[(x, y)]" in pt_bij4[OF pt_name_inst, OF at_name_inst])
        apply(simp add: eqvts)
        apply(rule conjI)
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(rule conjI)
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(drule_tac p="[(x, y)]" in weakBisimClosed)
        apply(simp add: eqvts)
        by(case_tac xvec) auto

      with \<open>\<lbrakk>(\<Psi>, \<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R)) \<in> ?X; xvec' \<sharp>* \<Psi>\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> \<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R)\<close> \<open>xvec' \<sharp>* \<Psi>\<close>
      have "\<Psi> \<rhd> \<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R)" by blast
      moreover note \<open>eqvt ?X\<close>
      moreover from \<open>eqvt ?X\<close> have "eqvt(?X \<union> weakBisim)" by auto
      moreover note \<open>x \<sharp> \<Psi>\<close>
      moreover have "?X \<union> weakBisim \<subseteq> ?X \<union> weakBisim" by simp
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R)) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R))" using Res
        by(rule_tac weakResPres)
      thus ?case
        by simp
    qed
    with PFrR QFrR show ?case
      by simp
  next
    case(cExt \<Psi> PR QR \<Psi>')

    from \<open>(\<Psi>, PR, QR) \<in> ?X\<close>
    obtain xvec P Q R A\<^sub>R \<Psi>\<^sub>R where PFrR: "PR = \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R)" and QFrR: "QR = \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
                               and "xvec \<sharp>* \<Psi>" and A: "\<forall>A\<^sub>R \<Psi>\<^sub>R. (extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q) \<longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
      by auto

    obtain p where "(p \<bullet> xvec) \<sharp>* \<Psi>"
               and "(p \<bullet> xvec) \<sharp>* P"
               and "(p \<bullet> xvec) \<sharp>* Q"
               and "(p \<bullet> xvec) \<sharp>* R"
               and "(p \<bullet> xvec) \<sharp>* \<Psi>'"
               and S: "(set p) \<subseteq> (set xvec) \<times> (set(p \<bullet> xvec))" and "distinctPerm p"
      by(rule_tac c="(\<Psi>, P, Q, R, \<Psi>')" in name_list_avoiding) auto

    from \<open>(p \<bullet> xvec) \<sharp>* P\<close> \<open>(p \<bullet> xvec) \<sharp>* R\<close> S have "\<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>(p \<bullet> (P \<parallel> R))"
      by(subst resChainAlpha) auto
    hence PRAlpha: "\<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> P) \<parallel> (p \<bullet> R))"
      by(simp add: eqvts)

    from \<open>(p \<bullet> xvec) \<sharp>* Q\<close> \<open>(p \<bullet> xvec) \<sharp>* R\<close> S have "\<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>(p \<bullet> (Q \<parallel> R))"
      by(subst resChainAlpha) auto
    hence QRAlpha: "\<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> Q) \<parallel> (p \<bullet> R))"
      by(simp add: eqvts)

    from \<open>(p \<bullet> xvec) \<sharp>* \<Psi>\<close> \<open>(p \<bullet> xvec) \<sharp>* \<Psi>'\<close> have "(\<Psi> \<otimes> \<Psi>', \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> P) \<parallel> (p \<bullet> R)), \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> Q) \<parallel> (p \<bullet> R))) \<in> ?X"
   proof(rule_tac C2="(\<Psi>, (p \<bullet> P), (p \<bullet> Q), R, \<Psi>', xvec, p \<bullet> xvec)" in XI', auto)
      fix A\<^sub>R \<Psi>\<^sub>R
      assume FrR: "extractFrame (p \<bullet> R) = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* \<Psi>'" and "A\<^sub>R \<sharp>* (p \<bullet> P)" and "A\<^sub>R \<sharp>* (p \<bullet> Q)"
      from FrR have "(p \<bullet> (extractFrame (p \<bullet> R))) = (p \<bullet> \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>)" by simp
      with \<open>distinctPerm p\<close> have "extractFrame R = \<langle>p \<bullet> A\<^sub>R, p \<bullet> \<Psi>\<^sub>R\<rangle>" by(simp add: eqvts)
      moreover from \<open>A\<^sub>R \<sharp>* \<Psi>\<close> have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> \<Psi>)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with \<open>xvec \<sharp>* \<Psi>\<close> \<open>(p \<bullet> xvec) \<sharp>* \<Psi>\<close> S have "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" by simp
      moreover from \<open>A\<^sub>R \<sharp>* (p \<bullet> P)\<close> have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> p \<bullet> P)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with \<open>distinctPerm p\<close> have "(p \<bullet> A\<^sub>R) \<sharp>* P" by simp
      moreover from \<open>A\<^sub>R \<sharp>* (p \<bullet> Q)\<close> have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> p \<bullet> Q)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with \<open>distinctPerm p\<close> have "(p \<bullet> A\<^sub>R) \<sharp>* Q" by simp
      ultimately have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q" using A by blast
      hence "(\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R)) \<otimes> (p \<bullet> \<Psi>') \<rhd> P \<approx> Q" by(rule weakBisimE)
      moreover have "(\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R)) \<otimes> (p \<bullet> \<Psi>') \<simeq> (\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R)"
        by(metis Associativity Commutativity Composition AssertionStatEqTrans AssertionStatEqSym)
      ultimately have "(\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q"
        by(rule statEqWeakBisim)
      hence "(p \<bullet> ((\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)"
        by(rule weakBisimClosed)
      with \<open>distinctPerm p\<close> \<open>xvec \<sharp>* \<Psi>\<close> \<open>(p \<bullet> xvec) \<sharp>* \<Psi>\<close> S show "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>R \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)"
        by(simp add: eqvts)
    qed
    with PFrR QFrR PRAlpha QRAlpha show ?case by simp
  next
    case(cSym \<Psi> PR QR)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimParPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<approx> Q \<parallel> R"
proof -
  obtain A\<^sub>R \<Psi>\<^sub>R where "extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* P" and "A\<^sub>R \<sharp>* Q"
    by(rule_tac C="(\<Psi>, P, Q)" in freshFrame) auto
  moreover from \<open>\<Psi> \<rhd> P \<approx> Q\<close> have "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q" by(rule weakBisimE)
  ultimately show ?thesis by(rule_tac weakBisimParPresAux)
qed

end

end


(*  Title:      HOL/Imperative_HOL/Array.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, Lukas Bulwahn & Florian Haftmann, TU Muenchen
*)

section {* Monadic arrays *}

theory Array
imports Heap_Monad
begin

subsection {* Primitives *}

definition present :: "heap \<Rightarrow> 'a\<Colon>heap array \<Rightarrow> bool" where
  "present h a \<longleftrightarrow> addr_of_array a < lim h"

definition get :: "heap \<Rightarrow> 'a\<Colon>heap array \<Rightarrow> 'a list" where
  "get h a = map from_nat (arrays h (TYPEREP('a)) (addr_of_array a))"

definition set :: "'a\<Colon>heap array \<Rightarrow> 'a list \<Rightarrow> heap \<Rightarrow> heap" where
  "set a x = arrays_update (\<lambda>h. h(TYPEREP('a) := ((h(TYPEREP('a))) (addr_of_array a:=map to_nat x))))"

definition alloc :: "'a list \<Rightarrow> heap \<Rightarrow> 'a\<Colon>heap array \<times> heap" where
  "alloc xs h = (let
     l = lim h;
     r = Array l;
     h'' = set r xs (h\<lparr>lim := l + 1\<rparr>)
   in (r, h''))"

definition length :: "heap \<Rightarrow> 'a\<Colon>heap array \<Rightarrow> nat" where
  "length h a = List.length (get h a)"

definition update :: "'a\<Colon>heap array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "update a i x h = set a ((get h a)[i:=x]) h"

definition noteq :: "'a\<Colon>heap array \<Rightarrow> 'b\<Colon>heap array \<Rightarrow> bool" (infix "=!!=" 70) where
  "r =!!= s \<longleftrightarrow> TYPEREP('a) \<noteq> TYPEREP('b) \<or> addr_of_array r \<noteq> addr_of_array s"

subsection {* Monad operations *}

definition new :: "nat \<Rightarrow> 'a\<Colon>heap \<Rightarrow> 'a array Heap" where
  [code del]: "new n x = Heap_Monad.heap (alloc (replicate n x))"

definition of_list :: "'a\<Colon>heap list \<Rightarrow> 'a array Heap" where
  [code del]: "of_list xs = Heap_Monad.heap (alloc xs)"

definition make :: "nat \<Rightarrow> (nat \<Rightarrow> 'a\<Colon>heap) \<Rightarrow> 'a array Heap" where
  [code del]: "make n f = Heap_Monad.heap (alloc (map f [0 ..< n]))"

definition len :: "'a\<Colon>heap array \<Rightarrow> nat Heap" where
  [code del]: "len a = Heap_Monad.tap (\<lambda>h. length h a)"

definition nth :: "'a\<Colon>heap array \<Rightarrow> nat \<Rightarrow> 'a Heap" where
  [code del]: "nth a i = Heap_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (get h a ! i, h))"

definition upd :: "nat \<Rightarrow> 'a \<Rightarrow> 'a\<Colon>heap array \<Rightarrow> 'a\<Colon>heap array Heap" where
  [code del]: "upd i x a = Heap_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (a, update a i x h))"

definition map_entry :: "nat \<Rightarrow> ('a\<Colon>heap \<Rightarrow> 'a) \<Rightarrow> 'a array \<Rightarrow> 'a array Heap" where
  [code del]: "map_entry i f a = Heap_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (a, update a i (f (get h a ! i)) h))"

definition swap :: "nat \<Rightarrow> 'a \<Rightarrow> 'a\<Colon>heap array \<Rightarrow> 'a Heap" where
  [code del]: "swap i x a = Heap_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (get h a ! i, update a i x h))"

definition freeze :: "'a\<Colon>heap array \<Rightarrow> 'a list Heap" where
  [code del]: "freeze a = Heap_Monad.tap (\<lambda>h. get h a)"

subsection {* Properties *}

text {* FIXME: Does there exist a "canonical" array axiomatisation in
the literature?  *}

text {* Primitives *}

lemma noteq_sym: "a =!!= b \<Longrightarrow> b =!!= a"
  and unequal [simp]: "a \<noteq> a' \<longleftrightarrow> a =!!= a'"
  unfolding noteq_def by auto

lemma noteq_irrefl: "r =!!= r \<Longrightarrow> False"
  unfolding noteq_def by auto

lemma present_alloc_noteq: "present h a \<Longrightarrow> a =!!= fst (alloc xs h)"
  by (simp add: present_def noteq_def alloc_def Let_def)

lemma get_set_eq [simp]: "get (set r x h) r = x"
  by (simp add: get_def set_def o_def)

lemma get_set_neq [simp]: "r =!!= s \<Longrightarrow> get (set s x h) r = get h r"
  by (simp add: noteq_def get_def set_def)

lemma set_same [simp]:
  "set r x (set r y h) = set r x h"
  by (simp add: set_def)

lemma set_set_swap:
  "r =!!= r' \<Longrightarrow> set r x (set r' x' h) = set r' x' (set r x h)"
  by (simp add: Let_def fun_eq_iff noteq_def set_def)

lemma get_update_eq [simp]:
  "get (update a i v h) a = (get h a) [i := v]"
  by (simp add: update_def)

lemma nth_update_neq [simp]:
  "a =!!= b \<Longrightarrow> get (update b j v h) a ! i = get h a ! i"
  by (simp add: update_def noteq_def)

lemma get_update_elem_neqIndex [simp]:
  "i \<noteq> j \<Longrightarrow> get (update a j v h) a ! i = get h a ! i"
  by simp

lemma length_update [simp]:
  "length (update b i v h) = length h"
  by (simp add: update_def length_def set_def get_def fun_eq_iff)

lemma update_swap_neq:
  "a =!!= a' \<Longrightarrow>
  update a i v (update a' i' v' h)
  = update a' i' v' (update a i v h)"
apply (unfold update_def)
apply simp
apply (subst set_set_swap, assumption)
apply (subst get_set_neq)
apply (erule noteq_sym)
apply simp
done

lemma update_swap_neqIndex:
  "\<lbrakk> i \<noteq> i' \<rbrakk> \<Longrightarrow> update a i v (update a i' v' h) = update a i' v' (update a i v h)"
  by (auto simp add: update_def set_set_swap list_update_swap)

lemma get_alloc:
  "get (snd (alloc xs h)) (fst (alloc ys h)) = xs"
  by (simp add: Let_def split_def alloc_def)

lemma length_alloc:
  "length (snd (alloc (xs :: 'a::heap list) h)) (fst (alloc (ys :: 'a list) h)) = List.length xs"
  by (simp add: Array.length_def get_alloc)

lemma set:
  "set (fst (alloc ls h))
     new_ls (snd (alloc ls h))
       = snd (alloc new_ls h)"
  by (simp add: Let_def split_def alloc_def)

lemma present_update [simp]:
  "present (update b i v h) = present h"
  by (simp add: update_def present_def set_def get_def fun_eq_iff)

lemma present_alloc [simp]:
  "present (snd (alloc xs h)) (fst (alloc xs h))"
  by (simp add: present_def alloc_def set_def Let_def)

lemma not_present_alloc [simp]:
  "\<not> present h (fst (alloc xs h))"
  by (simp add: present_def alloc_def Let_def)

text {* Monad operations *}

lemma execute_new [execute_simps]:
  "execute (new n x) h = Some (alloc (replicate n x) h)"
  by (simp add: new_def execute_simps)

lemma success_newI [success_intros]:
  "success (new n x) h"
  by (auto intro: success_intros simp add: new_def)

lemma effect_newI [effect_intros]:
  assumes "(a, h') = alloc (replicate n x) h"
  shows "effect (new n x) h h' a"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_newE [effect_elims]:
  assumes "effect (new n x) h h' r"
  obtains "r = fst (alloc (replicate n x) h)" "h' = snd (alloc (replicate n x) h)"
    "get h' r = replicate n x" "present h' r" "\<not> present h r"
  using assms by (rule effectE) (simp add: get_alloc execute_simps)

lemma execute_of_list [execute_simps]:
  "execute (of_list xs) h = Some (alloc xs h)"
  by (simp add: of_list_def execute_simps)

lemma success_of_listI [success_intros]:
  "success (of_list xs) h"
  by (auto intro: success_intros simp add: of_list_def)

lemma effect_of_listI [effect_intros]:
  assumes "(a, h') = alloc xs h"
  shows "effect (of_list xs) h h' a"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_of_listE [effect_elims]:
  assumes "effect (of_list xs) h h' r"
  obtains "r = fst (alloc xs h)" "h' = snd (alloc xs h)"
    "get h' r = xs" "present h' r" "\<not> present h r"
  using assms by (rule effectE) (simp add: get_alloc execute_simps)

lemma execute_make [execute_simps]:
  "execute (make n f) h = Some (alloc (map f [0 ..< n]) h)"
  by (simp add: make_def execute_simps)

lemma success_makeI [success_intros]:
  "success (make n f) h"
  by (auto intro: success_intros simp add: make_def)

lemma effect_makeI [effect_intros]:
  assumes "(a, h') = alloc (map f [0 ..< n]) h"
  shows "effect (make n f) h h' a"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_makeE [effect_elims]:
  assumes "effect (make n f) h h' r"
  obtains "r = fst (alloc (map f [0 ..< n]) h)" "h' = snd (alloc (map f [0 ..< n]) h)"
    "get h' r = map f [0 ..< n]" "present h' r" "\<not> present h r"
  using assms by (rule effectE) (simp add: get_alloc execute_simps)

lemma execute_len [execute_simps]:
  "execute (len a) h = Some (length h a, h)"
  by (simp add: len_def execute_simps)

lemma success_lenI [success_intros]:
  "success (len a) h"
  by (auto intro: success_intros simp add: len_def)

lemma effect_lengthI [effect_intros]:
  assumes "h' = h" "r = length h a"
  shows "effect (len a) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_lengthE [effect_elims]:
  assumes "effect (len a) h h' r"
  obtains "r = length h' a" "h' = h"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_nth [execute_simps]:
  "i < length h a \<Longrightarrow>
    execute (nth a i) h = Some (get h a ! i, h)"
  "i \<ge> length h a \<Longrightarrow> execute (nth a i) h = None"
  by (simp_all add: nth_def execute_simps)

lemma success_nthI [success_intros]:
  "i < length h a \<Longrightarrow> success (nth a i) h"
  by (auto intro: success_intros simp add: nth_def)

lemma effect_nthI [effect_intros]:
  assumes "i < length h a" "h' = h" "r = get h a ! i"
  shows "effect (nth a i) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_nthE [effect_elims]:
  assumes "effect (nth a i) h h' r"
  obtains "i < length h a" "r = get h a ! i" "h' = h"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_upd [execute_simps]:
  "i < length h a \<Longrightarrow>
    execute (upd i x a) h = Some (a, update a i x h)"
  "i \<ge> length h a \<Longrightarrow> execute (upd i x a) h = None"
  by (simp_all add: upd_def execute_simps)

lemma success_updI [success_intros]:
  "i < length h a \<Longrightarrow> success (upd i x a) h"
  by (auto intro: success_intros simp add: upd_def)

lemma effect_updI [effect_intros]:
  assumes "i < length h a" "h' = update a i v h"
  shows "effect (upd i v a) h h' a"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_updE [effect_elims]:
  assumes "effect (upd i v a) h h' r"
  obtains "r = a" "h' = update a i v h" "i < length h a"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_map_entry [execute_simps]:
  "i < length h a \<Longrightarrow>
   execute (map_entry i f a) h =
      Some (a, update a i (f (get h a ! i)) h)"
  "i \<ge> length h a \<Longrightarrow> execute (map_entry i f a) h = None"
  by (simp_all add: map_entry_def execute_simps)

lemma success_map_entryI [success_intros]:
  "i < length h a \<Longrightarrow> success (map_entry i f a) h"
  by (auto intro: success_intros simp add: map_entry_def)

lemma effect_map_entryI [effect_intros]:
  assumes "i < length h a" "h' = update a i (f (get h a ! i)) h" "r = a"
  shows "effect (map_entry i f a) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_map_entryE [effect_elims]:
  assumes "effect (map_entry i f a) h h' r"
  obtains "r = a" "h' = update a i (f (get h a ! i)) h" "i < length h a"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_swap [execute_simps]:
  "i < length h a \<Longrightarrow>
   execute (swap i x a) h =
      Some (get h a ! i, update a i x h)"
  "i \<ge> length h a \<Longrightarrow> execute (swap i x a) h = None"
  by (simp_all add: swap_def execute_simps)

lemma success_swapI [success_intros]:
  "i < length h a \<Longrightarrow> success (swap i x a) h"
  by (auto intro: success_intros simp add: swap_def)

lemma effect_swapI [effect_intros]:
  assumes "i < length h a" "h' = update a i x h" "r = get h a ! i"
  shows "effect (swap i x a) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_swapE [effect_elims]:
  assumes "effect (swap i x a) h h' r"
  obtains "r = get h a ! i" "h' = update a i x h" "i < length h a"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_freeze [execute_simps]:
  "execute (freeze a) h = Some (get h a, h)"
  by (simp add: freeze_def execute_simps)

lemma success_freezeI [success_intros]:
  "success (freeze a) h"
  by (auto intro: success_intros simp add: freeze_def)

lemma effect_freezeI [effect_intros]:
  assumes "h' = h" "r = get h a"
  shows "effect (freeze a) h h' r"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_freezeE [effect_elims]:
  assumes "effect (freeze a) h h' r"
  obtains "h' = h" "r = get h a"
  using assms by (rule effectE) (simp add: execute_simps)

lemma upd_return:
  "upd i x a \<guillemotright> return a = upd i x a"
  by (rule Heap_eqI) (simp add: bind_def guard_def upd_def execute_simps)

lemma array_make:
  "new n x = make n (\<lambda>_. x)"
  by (rule Heap_eqI) (simp add: map_replicate_trivial execute_simps)

lemma array_of_list_make [code]:
  "of_list xs = make (List.length xs) (\<lambda>n. xs ! n)"
  by (rule Heap_eqI) (simp add: map_nth execute_simps)

hide_const (open) present get set alloc length update noteq new of_list make len nth upd map_entry swap freeze

subsection {* Code generator setup *}

subsubsection {* Logical intermediate layer *}

definition new' where
  [code del]: "new' = Array.new o nat_of_integer"

definition make' where
  [code del]: "make' i f = Array.make (nat_of_integer i) (f o of_nat)"

lemma [code]:
  "Array.make n f = make' (of_nat n) (f o nat_of_integer)"
  by (simp add: make'_def o_def)

definition len' where
  [code del]: "len' a = Array.len a \<guillemotright>= (\<lambda>n. return (of_nat n))"

lemma [code]:
  "Array.len a = len' a \<guillemotright>= (\<lambda>i. return (nat_of_integer i))"
  by (simp add: len'_def)

definition nth' where
  [code del]: "nth' a = Array.nth a o nat_of_integer"

lemma [code]:
  "Array.nth a n = nth' a (of_nat n)"
  by (simp add: nth'_def)

definition upd' where
  [code del]: "upd' a i x = Array.upd (nat_of_integer i) x a \<guillemotright> return ()"

lemma [code]:
  "Array.upd i x a = upd' a (of_nat i) x \<guillemotright> return a"
  by (simp add: upd'_def upd_return)

lemma [code]:
  "Array.map_entry i f a = do {
     x \<leftarrow> Array.nth a i;
     Array.upd i (f x) a
   }"
  by (rule Heap_eqI) (simp add: bind_def guard_def map_entry_def execute_simps)

lemma [code]:
  "Array.swap i x a = do {
     y \<leftarrow> Array.nth a i;
     Array.upd i x a;
     return y
   }"
  by (rule Heap_eqI) (simp add: bind_def guard_def swap_def execute_simps)

lemma [code]:
  "Array.freeze a = do {
     n \<leftarrow> Array.len a;
     Heap_Monad.fold_map (\<lambda>i. Array.nth a i) [0..<n]
   }"
proof (rule Heap_eqI)
  fix h
  have *: "List.map
     (\<lambda>x. fst (the (if x < Array.length h a
                    then Some (Array.get h a ! x, h) else None)))
     [0..<Array.length h a] =
       List.map (List.nth (Array.get h a)) [0..<Array.length h a]"
    by simp
  have "execute (Heap_Monad.fold_map (Array.nth a) [0..<Array.length h a]) h =
    Some (Array.get h a, h)"
    apply (subst execute_fold_map_unchanged_heap)
    apply (simp_all add: nth_def guard_def *)
    apply (simp add: length_def map_nth)
    done
  then have "execute (do {
      n \<leftarrow> Array.len a;
      Heap_Monad.fold_map (Array.nth a) [0..<n]
    }) h = Some (Array.get h a, h)"
    by (auto intro: execute_bind_eq_SomeI simp add: execute_simps)
  then show "execute (Array.freeze a) h = execute (do {
      n \<leftarrow> Array.len a;
      Heap_Monad.fold_map (Array.nth a) [0..<n]
    }) h" by (simp add: execute_simps)
qed

hide_const (open) new' make' len' nth' upd'

text {* SML *}

code_printing type_constructor array \<rightharpoonup> (SML) "_/ array"
code_printing constant Array \<rightharpoonup> (SML) "raise/ (Fail/ \"bare Array\")"
code_printing constant Array.new' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.array/ ((_),/ (_)))"
code_printing constant Array.of_list \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.fromList/ _)"
code_printing constant Array.make' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.tabulate/ ((_),/ (_)))"
code_printing constant Array.len' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.length/ _)"
code_printing constant Array.nth' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.sub/ ((_),/ (_)))"
code_printing constant Array.upd' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.update/ ((_),/ (_),/ (_)))"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (SML) infixl 6 "="

code_reserved SML Array

text {* OCaml *}

code_printing type_constructor array \<rightharpoonup> (OCaml) "_/ array"
code_printing constant Array \<rightharpoonup> (OCaml) "failwith/ \"bare Array\""
code_printing constant Array.new' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.make/ (Big'_int.int'_of'_big'_int/ _)/ _)"
code_printing constant Array.of_list \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.of'_list/ _)"
code_printing constant Array.make' \<rightharpoonup> (OCaml)
  "(fun/ ()/ ->/ Array.init/ (Big'_int.int'_of'_big'_int/ _)/ (fun k'_ ->/ _/ (Big'_int.big'_int'_of'_int/ k'_)))"
code_printing constant Array.len' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Big'_int.big'_int'_of'_int/ (Array.length/ _))"
code_printing constant Array.nth' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.get/ _/ (Big'_int.int'_of'_big'_int/ _))"
code_printing constant Array.upd' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.set/ _/ (Big'_int.int'_of'_big'_int/ _)/ _)"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (OCaml) infixl 4 "="

code_reserved OCaml Array

text {* Haskell *}

code_printing type_constructor array \<rightharpoonup> (Haskell) "Heap.STArray/ Heap.RealWorld/ _"
code_printing constant Array \<rightharpoonup> (Haskell) "error/ \"bare Array\""
code_printing constant Array.new' \<rightharpoonup> (Haskell) "Heap.newArray"
code_printing constant Array.of_list \<rightharpoonup> (Haskell) "Heap.newListArray"
code_printing constant Array.make' \<rightharpoonup> (Haskell) "Heap.newFunArray"
code_printing constant Array.len' \<rightharpoonup> (Haskell) "Heap.lengthArray"
code_printing constant Array.nth' \<rightharpoonup> (Haskell) "Heap.readArray"
code_printing constant Array.upd' \<rightharpoonup> (Haskell) "Heap.writeArray"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
code_printing class_instance array :: HOL.equal \<rightharpoonup> (Haskell) -

text {* Scala *}

code_printing type_constructor array \<rightharpoonup> (Scala) "!collection.mutable.ArraySeq[_]"
code_printing constant Array \<rightharpoonup> (Scala) "!sys.error(\"bare Array\")"
code_printing constant Array.new' \<rightharpoonup> (Scala) "('_: Unit)/ => / Array.alloc((_))((_))"
code_printing constant Array.make' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.make((_))((_))"
code_printing constant Array.len' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.len((_))"
code_printing constant Array.nth' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.nth((_), (_))"
code_printing constant Array.upd' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.upd((_), (_), (_))"
code_printing constant Array.freeze \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.freeze((_))"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (Scala) infixl 5 "=="

end


(*  Title:      HOL/HOLCF/IOA/NTP/Packet.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

theory Packet
imports Multiset
begin

type_synonym
  'msg packet = "bool * 'msg"

definition
  hdr :: "'msg packet => bool" where
  "hdr == fst"

definition
  msg :: "'msg packet => 'msg" where
  "msg == snd"

text \<open>Instantiation of a tautology?\<close>
lemma eq_packet_imp_eq_hdr: "!x. x = packet --> hdr(x) = hdr(packet)"
  by simp

declare hdr_def [simp] msg_def [simp]

end