(*  Title:      HOL/SET_Protocol/Merchant_Registration.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section\<open>The SET Merchant Registration Protocol\<close>

theory Merchant_Registration
imports Public_SET
begin

text\<open>Copmpared with Cardholder Reigstration, \<open>KeyCryptKey\<close> is not
  needed: no session key encrypts another.  Instead we
  prove the "key compromise" theorems for sets KK that contain no private
  encryption keys (\<^term>\<open>priEK C\<close>).\<close>

inductive_set
  set_mr :: "event list set"
where

  Nil:    \<comment> \<open>Initial trace is empty\<close>
           "[] \<in> set_mr"

| Fake:    \<comment> \<open>The spy MAY say anything he CAN say.\<close>
           "[| evsf \<in> set_mr; X \<in> synth (analz (knows Spy evsf)) |]
            ==> Says Spy B X  # evsf \<in> set_mr"

| Reception: \<comment> \<open>If A sends a message X to B, then B might receive it\<close>
             "[| evsr \<in> set_mr; Says A B X \<in> set evsr |]
              ==> Gets B X  # evsr \<in> set_mr"

| SET_MR1: \<comment> \<open>RegFormReq: M requires a registration form to a CA\<close>
           "[| evs1 \<in> set_mr; M = Merchant k; Nonce NM1 \<notin> used evs1 |]
            ==> Says M (CA i) \<lbrace>Agent M, Nonce NM1\<rbrace> # evs1 \<in> set_mr"

| SET_MR2: \<comment> \<open>RegFormRes: CA replies with the registration form and the
               certificates for her keys\<close>
  "[| evs2 \<in> set_mr; Nonce NCA \<notin> used evs2;
      Gets (CA i) \<lbrace>Agent M, Nonce NM1\<rbrace> \<in> set evs2 |]
   ==> Says (CA i) M \<lbrace>sign (priSK (CA i)) \<lbrace>Agent M, Nonce NM1, Nonce NCA\<rbrace>,
                       cert (CA i) (pubEK (CA i)) onlyEnc (priSK RCA),
                       cert (CA i) (pubSK (CA i)) onlySig (priSK RCA) \<rbrace>
         # evs2 \<in> set_mr"

| SET_MR3:
         \<comment> \<open>CertReq: M submits the key pair to be certified.  The Notes
             event allows KM1 to be lost if M is compromised. Piero remarks
             that the agent mentioned inside the signature is not verified to
             correspond to M.  As in CR, each Merchant has fixed key pairs.  M
             is only optionally required to send NCA back, so M doesn't do so
             in the model\<close>
  "[| evs3 \<in> set_mr; M = Merchant k; Nonce NM2 \<notin> used evs3;
      Key KM1 \<notin> used evs3;  KM1 \<in> symKeys;
      Gets M \<lbrace>sign (invKey SKi) \<lbrace>Agent X, Nonce NM1, Nonce NCA\<rbrace>,
               cert (CA i) EKi onlyEnc (priSK RCA),
               cert (CA i) SKi onlySig (priSK RCA) \<rbrace>
        \<in> set evs3;
      Says M (CA i) \<lbrace>Agent M, Nonce NM1\<rbrace> \<in> set evs3 |]
   ==> Says M (CA i)
            \<lbrace>Crypt KM1 (sign (priSK M) \<lbrace>Agent M, Nonce NM2,
                                          Key (pubSK M), Key (pubEK M)\<rbrace>),
              Crypt EKi (Key KM1)\<rbrace>
         # Notes M \<lbrace>Key KM1, Agent (CA i)\<rbrace>
         # evs3 \<in> set_mr"

| SET_MR4:
         \<comment> \<open>CertRes: CA issues the certificates for merSK and merEK,
             while checking never to have certified the m even
             separately. NOTE: In Cardholder Registration the
             corresponding rule (6) doesn't use the "sign" primitive. "The
             CertRes shall be signed but not encrypted if the EE is a Merchant
             or Payment Gateway."-- Programmer's Guide, page 191.\<close>
    "[| evs4 \<in> set_mr; M = Merchant k;
        merSK \<notin> symKeys;  merEK \<notin> symKeys;
        Notes (CA i) (Key merSK) \<notin> set evs4;
        Notes (CA i) (Key merEK) \<notin> set evs4;
        Gets (CA i) \<lbrace>Crypt KM1 (sign (invKey merSK)
                                 \<lbrace>Agent M, Nonce NM2, Key merSK, Key merEK\<rbrace>),
                      Crypt (pubEK (CA i)) (Key KM1) \<rbrace>
          \<in> set evs4 |]
    ==> Says (CA i) M \<lbrace>sign (priSK(CA i)) \<lbrace>Agent M, Nonce NM2, Agent(CA i)\<rbrace>,
                        cert  M      merSK    onlySig (priSK (CA i)),
                        cert  M      merEK    onlyEnc (priSK (CA i)),
                        cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)\<rbrace>
          # Notes (CA i) (Key merSK)
          # Notes (CA i) (Key merEK)
          # evs4 \<in> set_mr"

text\<open>Note possibility proofs are missing.\<close>

declare Says_imp_knows_Spy [THEN parts.Inj, dest]
declare parts.Body [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]

text\<open>General facts about message reception\<close>
lemma Gets_imp_Says:
     "[| Gets B X \<in> set evs; evs \<in> set_mr |] ==> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule set_mr.induct, auto)
done

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

declare Gets_imp_knows_Spy [THEN parts.Inj, dest]

subsubsection\<open>Proofs on keys\<close>

text\<open>Spy never sees an agent's private keys! (unless it's bad at start)\<close>
lemma Spy_see_private_Key [simp]:
     "evs \<in> set_mr
      ==> (Key(invKey (publicKey b A)) \<in> parts(knows Spy evs)) = (A \<in> bad)"
apply (erule set_mr.induct)
apply (auto dest!: Gets_imp_knows_Spy [THEN parts.Inj])
done

lemma Spy_analz_private_Key [simp]:
     "evs \<in> set_mr ==>
     (Key(invKey (publicKey b A)) \<in> analz(knows Spy evs)) = (A \<in> bad)"
by auto

declare Spy_see_private_Key [THEN [2] rev_iffD1, dest!]
declare Spy_analz_private_Key [THEN [2] rev_iffD1, dest!]

(*This is to state that the signed keys received in step 4
  are into parts - rather than installing sign_def each time.
  Needed in Spy_see_priSK_RCA, Spy_see_priEK and in Spy_see_priSK
Goal "[|Gets C \<lbrace>Crypt KM1
                (sign K \<lbrace>Agent M, Nonce NM2, Key merSK, Key merEK\<rbrace>), X\<rbrace>
          \<in> set evs;  evs \<in> set_mr |]
    ==> Key merSK \<in> parts (knows Spy evs) \<and>
        Key merEK \<in> parts (knows Spy evs)"
by (fast_tac (claset() addss (simpset())) 1);
qed "signed_keys_in_parts";
???*)

text\<open>Proofs on certificates -
  they hold, as in CR, because RCA's keys are secure\<close>

lemma Crypt_valid_pubEK:
     "[| Crypt (priSK RCA) \<lbrace>Agent (CA i), Key EKi, onlyEnc\<rbrace>
           \<in> parts (knows Spy evs);
         evs \<in> set_mr |] ==> EKi = pubEK (CA i)"
apply (erule rev_mp)
apply (erule set_mr.induct, auto)
done

lemma certificate_valid_pubEK:
    "[| cert (CA i) EKi onlyEnc (priSK RCA) \<in> parts (knows Spy evs);
        evs \<in> set_mr |]
     ==> EKi = pubEK (CA i)"
apply (unfold cert_def signCert_def)
apply (blast dest!: Crypt_valid_pubEK)
done

lemma Crypt_valid_pubSK:
     "[| Crypt (priSK RCA) \<lbrace>Agent (CA i), Key SKi, onlySig\<rbrace>
           \<in> parts (knows Spy evs);
         evs \<in> set_mr |] ==> SKi = pubSK (CA i)"
apply (erule rev_mp)
apply (erule set_mr.induct, auto)
done

lemma certificate_valid_pubSK:
    "[| cert (CA i) SKi onlySig (priSK RCA) \<in> parts (knows Spy evs);
        evs \<in> set_mr |] ==> SKi = pubSK (CA i)"
apply (unfold cert_def signCert_def)
apply (blast dest!: Crypt_valid_pubSK)
done

lemma Gets_certificate_valid:
     "[| Gets A \<lbrace> X, cert (CA i) EKi onlyEnc (priSK RCA),
                      cert (CA i) SKi onlySig (priSK RCA)\<rbrace> \<in> set evs;
         evs \<in> set_mr |]
      ==> EKi = pubEK (CA i) \<and> SKi = pubSK (CA i)"
by (blast dest: certificate_valid_pubEK certificate_valid_pubSK)

text\<open>Nobody can have used non-existent keys!\<close>
lemma new_keys_not_used [rule_format,simp]:
     "evs \<in> set_mr
      ==> Key K \<notin> used evs \<longrightarrow> K \<in> symKeys \<longrightarrow>
          K \<notin> keysFor (parts (knows Spy evs))"
apply (erule set_mr.induct, simp_all)
apply (force dest!: usedI keysFor_parts_insert)  \<comment> \<open>Fake\<close>
apply force  \<comment> \<open>Message 2\<close>
apply (blast dest: Gets_certificate_valid)  \<comment> \<open>Message 3\<close>
apply force  \<comment> \<open>Message 4\<close>
done

subsubsection\<open>New Versions: As Above, but Generalized with the Kk Argument\<close>

lemma gen_new_keys_not_used [rule_format]:
     "evs \<in> set_mr
      ==> Key K \<notin> used evs \<longrightarrow> K \<in> symKeys \<longrightarrow>
          K \<notin> keysFor (parts (Key`KK \<union> knows Spy evs))"
by auto

lemma gen_new_keys_not_analzd:
     "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> set_mr |]
      ==> K \<notin> keysFor (analz (Key`KK \<union> knows Spy evs))"
by (blast intro: keysFor_mono [THEN [2] rev_subsetD]
          dest: gen_new_keys_not_used)

lemma analz_Key_image_insert_eq:
     "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> set_mr |]
      ==> analz (Key ` (insert K KK) \<union> knows Spy evs) =
          insert (Key K) (analz (Key ` KK \<union> knows Spy evs))"
by (simp add: gen_new_keys_not_analzd)

lemma Crypt_parts_imp_used:
     "[|Crypt K X \<in> parts (knows Spy evs);
        K \<in> symKeys; evs \<in> set_mr |] ==> Key K \<in> used evs"
apply (rule ccontr)
apply (force dest: new_keys_not_used Crypt_imp_invKey_keysFor)
done

lemma Crypt_analz_imp_used:
     "[|Crypt K X \<in> analz (knows Spy evs);
        K \<in> symKeys; evs \<in> set_mr |] ==> Key K \<in> used evs"
by (blast intro: Crypt_parts_imp_used)

text\<open>Rewriting rule for private encryption keys.  Analogous rewriting rules
for other keys aren't needed.\<close>

lemma parts_image_priEK:
     "[|Key (priEK (CA i)) \<in> parts (Key`KK \<union> (knows Spy evs));
        evs \<in> set_mr|] ==> priEK (CA i) \<in> KK | CA i \<in> bad"
by auto

text\<open>trivial proof because (priEK (CA i)) never appears even in (parts evs)\<close>
lemma analz_image_priEK:
     "evs \<in> set_mr ==>
          (Key (priEK (CA i)) \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (priEK (CA i) \<in> KK | CA i \<in> bad)"
by (blast dest!: parts_image_priEK intro: analz_mono [THEN [2] rev_subsetD])

subsection\<open>Secrecy of Session Keys\<close>

text\<open>This holds because if (priEK (CA i)) appears in any traffic then it must
  be known to the Spy, by \<open>Spy_see_private_Key\<close>\<close>
lemma merK_neq_priEK:
     "[|Key merK \<notin> analz (knows Spy evs);
        Key merK \<in> parts (knows Spy evs);
        evs \<in> set_mr|] ==> merK \<noteq> priEK C"
by blast

text\<open>Lemma for message 4: either merK is compromised (when we don't care)
  or else merK hasn't been used to encrypt K.\<close>
lemma msg4_priEK_disj:
     "[|Gets B \<lbrace>Crypt KM1
                       (sign K \<lbrace>Agent M, Nonce NM2, Key merSK, Key merEK\<rbrace>),
                 Y\<rbrace> \<in> set evs;
        evs \<in> set_mr|]
  ==> (Key merSK \<in> analz (knows Spy evs) | merSK \<notin> range(\<lambda>C. priEK C))
   \<and>  (Key merEK \<in> analz (knows Spy evs) | merEK \<notin> range(\<lambda>C. priEK C))"
apply (unfold sign_def)
apply (blast dest: merK_neq_priEK)
done

lemma Key_analz_image_Key_lemma:
     "P \<longrightarrow> (Key K \<in> analz (Key`KK \<union> H)) \<longrightarrow> (K\<in>KK | Key K \<in> analz H)
      ==>
      P \<longrightarrow> (Key K \<in> analz (Key`KK \<union> H)) = (K\<in>KK | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemma symKey_compromise:
     "evs \<in> set_mr ==>
      (\<forall>SK KK. SK \<in> symKeys \<longrightarrow> (\<forall>K \<in> KK. K \<notin> range(\<lambda>C. priEK C)) \<longrightarrow>
               (Key SK \<in> analz (Key`KK \<union> (knows Spy evs))) =
               (SK \<in> KK | Key SK \<in> analz (knows Spy evs)))"
apply (erule set_mr.induct)
apply (safe del: impI intro!: Key_analz_image_Key_lemma [THEN impI])
apply (drule_tac [7] msg4_priEK_disj)
apply (frule_tac [6] Gets_certificate_valid)
apply (safe del: impI)
apply (simp_all del: image_insert image_Un imp_disjL
         add: analz_image_keys_simps abbrev_simps analz_knows_absorb
              analz_knows_absorb2 analz_Key_image_insert_eq notin_image_iff
              Spy_analz_private_Key analz_image_priEK)
  \<comment> \<open>5 seconds on a 1.6GHz machine\<close>
apply spy_analz  \<comment> \<open>Fake\<close>
apply auto  \<comment> \<open>Message 3\<close>
done

lemma symKey_secrecy [rule_format]:
     "[|CA i \<notin> bad; K \<in> symKeys;  evs \<in> set_mr|]
      ==> \<forall>X m. Says (Merchant m) (CA i) X \<in> set evs \<longrightarrow>
                Key K \<in> parts{X} \<longrightarrow>
                Merchant m \<notin> bad \<longrightarrow>
                Key K \<notin> analz (knows Spy evs)"
apply (erule set_mr.induct)
apply (drule_tac [7] msg4_priEK_disj)
apply (frule_tac [6] Gets_certificate_valid)
apply (safe del: impI)
apply (simp_all del: image_insert image_Un imp_disjL
         add: analz_image_keys_simps abbrev_simps analz_knows_absorb
              analz_knows_absorb2 analz_Key_image_insert_eq
              symKey_compromise notin_image_iff Spy_analz_private_Key
              analz_image_priEK)
apply spy_analz  \<comment> \<open>Fake\<close>
apply force  \<comment> \<open>Message 1\<close>
apply (auto intro: analz_into_parts [THEN usedI] in_parts_Says_imp_used)  \<comment> \<open>Message 3\<close>
done

subsection\<open>Unicity\<close>

lemma msg4_Says_imp_Notes:
 "[|Says (CA i) M \<lbrace>sign (priSK (CA i)) \<lbrace>Agent M, Nonce NM2, Agent (CA i)\<rbrace>,
                    cert  M      merSK    onlySig (priSK (CA i)),
                    cert  M      merEK    onlyEnc (priSK (CA i)),
                    cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)\<rbrace> \<in> set evs;
    evs \<in> set_mr |]
  ==> Notes (CA i) (Key merSK) \<in> set evs
   \<and>  Notes (CA i) (Key merEK) \<in> set evs"
apply (erule rev_mp)
apply (erule set_mr.induct)
apply (simp_all (no_asm_simp))
done

text\<open>Unicity of merSK wrt a given CA:
  merSK uniquely identifies the other components, including merEK\<close>
lemma merSK_unicity:
 "[|Says (CA i) M \<lbrace>sign (priSK(CA i)) \<lbrace>Agent M, Nonce NM2, Agent (CA i)\<rbrace>,
                    cert  M      merSK    onlySig (priSK (CA i)),
                    cert  M      merEK    onlyEnc (priSK (CA i)),
                    cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)\<rbrace> \<in> set evs;
    Says (CA i) M' \<lbrace>sign (priSK(CA i)) \<lbrace>Agent M', Nonce NM2', Agent (CA i)\<rbrace>,
                    cert  M'      merSK    onlySig (priSK (CA i)),
                    cert  M'      merEK'    onlyEnc (priSK (CA i)),
                    cert (CA i) (pubSK(CA i)) onlySig (priSK RCA)\<rbrace> \<in> set evs;
    evs \<in> set_mr |] ==> M=M' \<and> NM2=NM2' \<and> merEK=merEK'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_mr.induct)
apply (simp_all (no_asm_simp))
apply (blast dest!: msg4_Says_imp_Notes)
done

text\<open>Unicity of merEK wrt a given CA:
  merEK uniquely identifies the other components, including merSK\<close>
lemma merEK_unicity:
 "[|Says (CA i) M \<lbrace>sign (priSK(CA i)) \<lbrace>Agent M, Nonce NM2, Agent (CA i)\<rbrace>,
                    cert  M      merSK    onlySig (priSK (CA i)),
                    cert  M      merEK    onlyEnc (priSK (CA i)),
                    cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)\<rbrace> \<in> set evs;
    Says (CA i) M' \<lbrace>sign (priSK(CA i)) \<lbrace>Agent M', Nonce NM2', Agent (CA i)\<rbrace>,
                     cert  M'      merSK'    onlySig (priSK (CA i)),
                     cert  M'      merEK    onlyEnc (priSK (CA i)),
                     cert (CA i) (pubSK(CA i)) onlySig (priSK RCA)\<rbrace> \<in> set evs;
    evs \<in> set_mr |]
  ==> M=M' \<and> NM2=NM2' \<and> merSK=merSK'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_mr.induct)
apply (simp_all (no_asm_simp))
apply (blast dest!: msg4_Says_imp_Notes)
done

text\<open>-No interest on secrecy of nonces: they appear to be used
    only for freshness.
   -No interest on secrecy of merSK or merEK, as in CR.
   -There's no equivalent of the PAN\<close>

subsection\<open>Primary Goals of Merchant Registration\<close>

subsubsection\<open>The merchant's certificates really were created by the CA,
provided the CA is uncompromised\<close>

text\<open>The assumption \<^term>\<open>CA i \<noteq> RCA\<close> is required: step 2 uses
  certificates of the same form.\<close>
lemma certificate_merSK_valid_lemma [intro]:
     "[|Crypt (priSK (CA i)) \<lbrace>Agent M, Key merSK, onlySig\<rbrace>
          \<in> parts (knows Spy evs);
        CA i \<notin> bad;  CA i \<noteq> RCA;  evs \<in> set_mr|]
 ==> \<exists>X Y Z. Says (CA i) M
                  \<lbrace>X, cert M merSK onlySig (priSK (CA i)), Y, Z\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule set_mr.induct)
apply (simp_all (no_asm_simp))
apply auto
done

lemma certificate_merSK_valid:
     "[| cert M merSK onlySig (priSK (CA i)) \<in> parts (knows Spy evs);
         CA i \<notin> bad;  CA i \<noteq> RCA;  evs \<in> set_mr|]
 ==> \<exists>X Y Z. Says (CA i) M
                  \<lbrace>X, cert M merSK onlySig (priSK (CA i)), Y, Z\<rbrace> \<in> set evs"
by auto

lemma certificate_merEK_valid_lemma [intro]:
     "[|Crypt (priSK (CA i)) \<lbrace>Agent M, Key merEK, onlyEnc\<rbrace>
          \<in> parts (knows Spy evs);
        CA i \<notin> bad;  CA i \<noteq> RCA;  evs \<in> set_mr|]
 ==> \<exists>X Y Z. Says (CA i) M
                  \<lbrace>X, Y, cert M merEK onlyEnc (priSK (CA i)), Z\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule set_mr.induct)
apply (simp_all (no_asm_simp))
apply auto
done

lemma certificate_merEK_valid:
     "[| cert M merEK onlyEnc (priSK (CA i)) \<in> parts (knows Spy evs);
         CA i \<notin> bad;  CA i \<noteq> RCA;  evs \<in> set_mr|]
 ==> \<exists>X Y Z. Says (CA i) M
                  \<lbrace>X, Y, cert M merEK onlyEnc (priSK (CA i)), Z\<rbrace> \<in> set evs"
by auto

text\<open>The two certificates - for merSK and for merEK - cannot be proved to
  have originated together\<close>

end


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

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  pfslvl3.thy (Isabelle/HOL 2016-1)
  ID:      $Id: pfslvl3.thy 133183 2017-01-31 13:55:43Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Generic Level 3 protocol using ephemeral asymmetric keys to achieve
  forward secrecy.

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

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

section \<open>Key Transport Protocol with PFS (L3 locale)\<close>

theory pfslvl3
imports pfslvl2 Implem_lemmas
begin

(**************************************************************************************************)
subsection \<open>State and Events\<close>
(**************************************************************************************************)

text \<open>Level 3 state\<close>
text \<open>(The types have to be defined outside the locale.)\<close>

record l3_state = l1_state +
  bad :: "agent set"

type_synonym l3_obs = "l3_state"

type_synonym
  l3_pred = "l3_state set"

type_synonym
  l3_trans = "(l3_state \<times> l3_state) set"

text \<open>attacker event\<close>
definition
  l3_dy :: "msg \<Rightarrow> l3_trans"
where
  "l3_dy \<equiv> ik_dy"

text \<open>compromise events\<close>
definition
  l3_lkr_others :: "agent \<Rightarrow> l3_trans"
where
  "l3_lkr_others A \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    A \<noteq> test_owner \<and>
    A \<noteq> test_partner \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>bad := {A} \<union> bad s,
           ik := keys_of A \<union> ik s\<rparr>
  }"

definition
  l3_lkr_actor :: "agent \<Rightarrow> l3_trans"
where
  "l3_lkr_actor A \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    A = test_owner \<and>
    A \<noteq> test_partner \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>bad := {A} \<union> bad s,
           ik := keys_of A \<union> ik s\<rparr>
  }"

definition
  l3_lkr_after :: "agent \<Rightarrow> l3_trans"
where
  "l3_lkr_after A \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    test_ended s \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>bad := {A} \<union> bad s,
           ik := keys_of A \<union> ik s\<rparr>
  }"

definition
  l3_skr :: "rid_t \<Rightarrow> msg \<Rightarrow> l3_trans"
where
  "l3_skr R K \<equiv> {(s,s').
    \<comment> \<open>guards\<close>
    R \<noteq> test \<and> R \<notin> partners \<and>
    in_progress (progress s R) xsk \<and>
    guessed_frame R xsk = Some K \<and>
    \<comment> \<open>actions\<close>
    s' = s\<lparr>ik := {K} \<union> ik s\<rparr>
  }"

text \<open>New locale for the level 3 protocol\<close>
text \<open>This locale does not add new assumptions, it is only used to separate the level 3
protocol from the implementation locale.\<close>
locale pfslvl3 = valid_implem
begin

text \<open>protocol events\<close>
definition
    l3_step1 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> l3_trans"
where
  "l3_step1 Ra A B \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    Ra \<notin> dom (progress s) \<and>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      progress := (progress s)(Ra \<mapsto> {xpkE, xskE}),
      ik := {implAuth A B \<langle>Number 0, epubKF (Ra$kE)\<rangle>} \<union> (ik s)
      \<rparr>
  }"

definition
  l3_step2 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> l3_trans"
where
  "l3_step2 Rb A B KE \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Rb = \<lparr>role=Resp, owner=B, partner=A\<rparr> \<and>
    Rb \<notin> dom (progress s) \<and>
    guessed_frame Rb xpkE = Some KE \<and>
    implAuth A B \<langle>Number 0, KE\<rangle> \<in> ik s \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      progress := (progress s)(Rb \<mapsto> {xpkE, xsk}),
      ik := {implAuth B A (Aenc (NonceF (Rb$sk)) KE)} \<union> (ik s),
      signals := if can_signal s A B then
                   addSignal (signals s) (Running A B \<langle>KE, NonceF (Rb$sk)\<rangle>)
                 else
                   signals s,
      secret := {x. x = NonceF (Rb$sk) \<and> Rb = test} \<union> secret s
         \<rparr>
  }"

definition
  l3_step3 :: "rid_t \<Rightarrow> agent \<Rightarrow> agent \<Rightarrow> msg \<Rightarrow> l3_trans"
where
  "l3_step3 Ra A B K \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    guessed_runs Ra = \<lparr>role=Init, owner=A, partner=B\<rparr> \<and>
    progress s Ra = Some {xpkE, xskE} \<and>
    guessed_frame Ra xsk = Some K \<and>
    implAuth B A (Aenc K (epubKF (Ra$kE))) \<in> ik s \<and>
    \<comment> \<open>actions:\<close>
    s' = s\<lparr> progress := (progress s)(Ra \<mapsto> {xpkE, xskE, xsk}),
            signals := if can_signal s A B then
                         addSignal (signals s) (Commit A B \<langle>epubKF (Ra$kE), K\<rangle>)
                       else
                         signals s,
            secret := {x. x = K \<and> Ra = test} \<union> secret s
          \<rparr>
  }"

text \<open>specification\<close>

text \<open>initial compromise\<close>

definition
  ik_init :: "msg set"
where
  "ik_init \<equiv> {priK C |C. C \<in> bad_init} \<union> {pubK A | A. True} \<union>
             {shrK A B |A B. A \<in> bad_init \<or> B \<in> bad_init} \<union> Tags"

text \<open>lemmas about @{term "ik_init"}\<close>
lemma parts_ik_init [simp]: "parts ik_init = ik_init"
by (auto elim!: parts.induct, auto simp add: ik_init_def)

lemma analz_ik_init [simp]: "analz ik_init = ik_init"
by (auto dest: analz_into_parts)

lemma abs_ik_init [iff]: "abs ik_init = {}"
apply (auto elim!: absE)
apply (auto simp add: ik_init_def)
done

lemma payloadSet_ik_init [iff]: "ik_init \<inter> payload = {}"
by (auto simp add: ik_init_def)

lemma validSet_ik_init [iff]: "ik_init \<inter> valid = {}"
by (auto simp add: ik_init_def)

definition
  l3_init :: "l3_state set"
where
  "l3_init \<equiv> { \<lparr>
    ik = ik_init,
    secret = {},
    progress = Map.empty,
    signals = \<lambda>x. 0,
    bad = bad_init
    \<rparr>}"

lemmas l3_init_defs = l3_init_def ik_init_def

definition
l3_trans :: "l3_trans"
where
  "l3_trans \<equiv> (\<Union>m M KE Rb Ra A B K.
     l3_step1 Ra A B \<union>
     l3_step2 Rb A B KE \<union>
     l3_step3 Ra A B m \<union>
     l3_dy M \<union>
     l3_lkr_others A \<union>
     l3_lkr_after A \<union>
     l3_skr Ra K \<union>
     Id
  )"

definition
  l3 :: "(l3_state, l3_obs) spec" where
  "l3 \<equiv> \<lparr>
    init = l3_init,
    trans = l3_trans,
    obs = id
  \<rparr>"

lemmas l3_loc_defs =
  l3_step1_def l3_step2_def l3_step3_def
  l3_def l3_init_defs l3_trans_def
  l3_dy_def
  l3_lkr_others_def l3_lkr_after_def l3_skr_def

lemmas l3_defs = l3_loc_defs ik_dy_def
lemmas l3_nostep_defs = l3_def l3_init_def l3_trans_def

lemma l3_obs_id [simp]: "obs l3 = id"
by (simp add: l3_def)

(**************************************************************************************************)
subsection \<open>Invariants\<close>
(**************************************************************************************************)
subsubsection \<open>inv1: No long-term keys as message parts\<close>
(**************************************************************************************************)

definition
  l3_inv1 :: "l3_state set"
where
  "l3_inv1 \<equiv> {s.
     parts (ik s) \<inter> range LtK \<subseteq> ik s
  }"

lemmas l3_inv1I = l3_inv1_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv1E [elim] = l3_inv1_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv1D = l3_inv1_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv1D' [dest]: "\<lbrakk> LtK K \<in> parts (ik s); s \<in> l3_inv1\<rbrakk> \<Longrightarrow> LtK K \<in> ik s"
by (auto simp add: l3_inv1_def)

lemma l3_inv1_init [iff]:
  "init l3 \<subseteq> l3_inv1"
by (auto simp add: l3_def l3_init_def intro!:l3_inv1I)

lemma l3_inv1_trans [iff]:
  "{l3_inv1} trans l3 {> l3_inv1}"
apply (auto simp add: PO_hoare_defs l3_nostep_defs intro!: l3_inv1I)
apply (auto simp add: l3_defs dy_fake_msg_def dy_fake_chan_def
        parts_insert [where H="ik _"] parts_insert [where H="insert _ (ik _)"]
        dest!: Fake_parts_insert)
apply (auto dest:analz_into_parts)
done

lemma PO_l3_inv1 [iff]:
  "reach l3 \<subseteq> l3_inv1"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv2: @{term "bad s"} indeed contains "bad" keys\<close>
(**************************************************************************************************)

definition
  l3_inv2 :: "l3_state set"
where
  "l3_inv2 \<equiv> {s.
    Keys_bad (ik s) (bad s)
  }"

lemmas l3_inv2I = l3_inv2_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv2E [elim] = l3_inv2_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv2D = l3_inv2_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv2_init [simp,intro!]:
  "init l3 \<subseteq> l3_inv2"
by (auto simp add: l3_def l3_init_defs intro!:l3_inv2I Keys_badI)

lemma l3_inv2_trans [simp,intro!]:
  "{l3_inv2 \<inter> l3_inv1} trans l3 {> l3_inv2}"
apply (auto simp add: PO_hoare_defs l3_nostep_defs intro!: l3_inv2I)
apply (auto simp add: l3_defs dy_fake_msg_def dy_fake_chan_def)
text \<open>4 subgoals: dy, lkr*, skr\<close>
apply (auto intro: Keys_bad_insert_Fake Keys_bad_insert_keys_of)
apply (auto intro!: Keys_bad_insert_payload)
done

lemma PO_l3_inv2 [iff]: "reach l3 \<subseteq> l3_inv2"
by (rule_tac J="l3_inv1" in inv_rule_incr) (auto)

subsubsection \<open>inv3\<close>
(**************************************************************************************************)

text \<open>If a message can be analyzed from the intruder knowledge then it can
be derived (using synth/analz) from the sets of implementation, non-implementation, and
long-term key messages and the tags. That is, intermediate messages are not needed.
\<close>

definition
  l3_inv3 :: "l3_state set"
where
  "l3_inv3 \<equiv> {s.
    analz (ik s) \<subseteq>
    synth (analz ((ik s \<inter> payload) \<union> ((ik s) \<inter> valid) \<union> (ik s \<inter> range LtK) \<union> Tags))
  }"

lemmas l3_inv3I = l3_inv3_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv3E = l3_inv3_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv3D = l3_inv3_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv3_init [iff]:
  "init l3 \<subseteq> l3_inv3"
apply (auto simp add: l3_def l3_init_def intro!: l3_inv3I)
apply (auto simp add: ik_init_def intro!: synth_increasing [THEN [2] rev_subsetD])
done

declare domIff [iff del]

text \<open>Most of the cases in this proof are simple and very similar.
The proof could probably be shortened.\<close>
lemma l3_inv3_trans [simp,intro!]:
  "{l3_inv3} trans l3 {> l3_inv3}"
proof (simp add: l3_nostep_defs, safe)
  fix Ra A B
  show "{l3_inv3} l3_step1 Ra A B {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs intro!: l3_inv3I dest!: l3_inv3D)
    apply (auto intro!: validI dest!: analz_insert_partition [THEN [2] rev_subsetD])
    done
next
  fix Rb A B KE
  show "{l3_inv3} l3_step2 Rb A B KE {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs intro!: l3_inv3I dest!: l3_inv3D)
    apply (auto intro!: validI dest!: analz_insert_partition [THEN [2] rev_subsetD])
    done
next
  fix Ra A B K
  show "{l3_inv3} l3_step3 Ra A B K {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs intro!: l3_inv3I dest!: l3_inv3D)
    done
next
  fix m
  show "{l3_inv3} l3_dy m {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs dy_fake_chan_def dy_fake_msg_def
                intro!: l3_inv3I dest!: l3_inv3D)
    apply (drule synth_analz_insert)
    apply (blast intro: synth_analz_monotone dest: synth_monotone)
    done
next
  fix A
  show "{l3_inv3} l3_lkr_others A {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs intro!: l3_inv3I dest!: l3_inv3D)
    apply (drule analz_Un_partition [of _ "keys_of A"], auto)
    done
next
  fix A
  show "{l3_inv3} l3_lkr_after A {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs intro!: l3_inv3I dest!: l3_inv3D)
    apply (drule analz_Un_partition [of _ "keys_of A"], auto)
    done
next
  fix R K
  show "{l3_inv3} l3_skr R K {> l3_inv3}"
    apply (auto simp add: PO_hoare_def l3_defs intro!: l3_inv3I dest!: l3_inv3D)
    apply (auto dest!: analz_insert_partition [THEN [2] rev_subsetD])
    done
qed

lemma PO_l3_inv3 [iff]: "reach l3 \<subseteq> l3_inv3"
by (rule inv_rule_basic) (auto)

subsubsection \<open>inv4: the intruder knows the tags\<close>
(**************************************************************************************************)

definition
  l3_inv4 :: "l3_state set"
where
  "l3_inv4 \<equiv> {s.
    Tags \<subseteq> ik s
  }"

lemmas l3_inv4I = l3_inv4_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv4E [elim] = l3_inv4_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv4D = l3_inv4_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv4_init [simp,intro!]:
  "init l3 \<subseteq> l3_inv4"
by (auto simp add: l3_def l3_init_def ik_init_def intro!:l3_inv4I)

lemma l3_inv4_trans [simp,intro!]:
  "{l3_inv4} trans l3 {> l3_inv4}"
apply (auto simp add: PO_hoare_defs l3_nostep_defs intro!: l3_inv4I)
apply (auto simp add: l3_defs dy_fake_chan_def dy_fake_msg_def)
done

lemma PO_l3_inv4 [simp,intro!]: "reach l3 \<subseteq> l3_inv4"
by (rule inv_rule_basic) (auto)

text \<open>The remaining invariants are derived from the others.
They are not protocol dependent provided the previous invariants hold.\<close>

subsubsection \<open>inv5\<close>
(**************************************************************************************************)

text \<open>The messages that the L3 DY intruder can derive from the intruder knowledge
(using @{term "synth"}/@{term "analz"}), are either implementations or intermediate messages or
can also be derived by the L2 intruder from the set
@{term "extr (bad s) ((ik s) \<inter> payload) (abs (ik s))"}, that is, given the
non-implementation messages and the abstractions of (implementation) messages
in the intruder knowledge.
\<close>

definition
  l3_inv5 :: "l3_state set"
where
  "l3_inv5 \<equiv> {s.
    synth (analz (ik s)) \<subseteq>
    dy_fake_msg (bad s) (ik s \<inter> payload) (abs (ik s)) \<union> -payload
  }"

lemmas l3_inv5I = l3_inv5_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv5E = l3_inv5_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv5D = l3_inv5_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv5_derived: "l3_inv2 \<inter> l3_inv3 \<subseteq> l3_inv5"
by (auto simp add: abs_validSet dy_fake_msg_def intro!: l3_inv5I
            dest!: l3_inv3D [THEN synth_mono, THEN [2] rev_subsetD]
            dest!: synth_analz_NI_I_K_synth_analz_NI_E [THEN [2] rev_subsetD])

lemma PO_l3_inv5 [simp,intro!]: "reach l3 \<subseteq> l3_inv5"
using l3_inv5_derived PO_l3_inv2 PO_l3_inv3
by blast

subsubsection \<open>inv6\<close>
(**************************************************************************************************)

text \<open>If the level 3 intruder can deduce a message implementing an insecure channel message, then:
\begin{itemize}
  \item either the message is already in the intruder knowledge;
  \item or the message is constructed, and the payload can also be deduced by the intruder.
\end{itemize}
\<close>

definition
  l3_inv6 :: "l3_state set"
where
  "l3_inv6 \<equiv> {s. \<forall> A B M.
     (implInsec A B M \<in> synth (analz (ik s)) \<and> M \<in> payload) \<longrightarrow>
     (implInsec A B M \<in> ik s \<or> M \<in> synth (analz (ik s)))
  }"

lemmas l3_inv6I = l3_inv6_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv6E = l3_inv6_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv6D = l3_inv6_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv6_derived [simp,intro!]:
  "l3_inv3 \<inter> l3_inv4 \<subseteq> l3_inv6"
apply (auto intro!: l3_inv6I dest!: l3_inv3D)
text \<open>1 subgoal\<close>
apply (drule synth_mono, simp, drule subsetD, assumption)
apply (auto dest!: implInsec_synth_analz [rotated 1, where H="_ \<union> _"])
apply (auto dest!: synth_analz_monotone [of _ "_ \<union> _" "ik _"])
done

lemma PO_l3_inv6 [simp,intro!]: "reach l3 \<subseteq> l3_inv6"
using l3_inv6_derived PO_l3_inv3 PO_l3_inv4
by (blast)

subsubsection \<open>inv7\<close>
(**************************************************************************************************)

text \<open>If the level 3 intruder can deduce a message implementing a confidential channel message,
then:
\begin{itemize}
 \item either the message is already in the intruder knowledge;
 \item or the message is constructed, and the payload can also be deduced by the intruder.
\end{itemize}
\<close>

definition
  l3_inv7 :: "l3_state set"
where
  "l3_inv7 \<equiv> {s. \<forall> A B M.
     (implConfid A B M \<in> synth (analz (ik s)) \<and> M \<in> payload) \<longrightarrow>
     (implConfid A B M \<in> ik s \<or> M \<in> synth (analz (ik s)))
  }"

lemmas l3_inv7I = l3_inv7_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv7E = l3_inv7_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv7D = l3_inv7_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv7_derived [simp,intro!]:
  "l3_inv3 \<inter> l3_inv4 \<subseteq> l3_inv7"
apply (auto intro!: l3_inv7I dest!: l3_inv3D)
text \<open>1 subgoal\<close>
apply (drule synth_mono, simp, drule subsetD, assumption)
apply (auto dest!: implConfid_synth_analz [rotated 1, where H="_ \<union> _"])
apply (auto dest!: synth_analz_monotone [of _ "_ \<union> _" "ik _"])
done

lemma PO_l3_inv7 [simp,intro!]: "reach l3 \<subseteq> l3_inv7"
using l3_inv7_derived PO_l3_inv3 PO_l3_inv4
by (blast)

subsubsection \<open>inv8\<close>
(**************************************************************************************************)

text \<open>If the level 3 intruder can deduce a message implementing an authentic channel message then:
\begin{itemize}
  \item either the message is already in the intruder knowledge;
  \item or the message is constructed, and in this case the payload can also be deduced
     by the intruder, and one of the agents is bad.
\end{itemize}
\<close>

definition
  l3_inv8 :: "l3_state set"
where
  "l3_inv8 \<equiv> {s. \<forall> A B M.
     (implAuth A B M \<in> synth (analz (ik s)) \<and> M \<in> payload) \<longrightarrow>
     (implAuth A B M \<in> ik s \<or> (M \<in> synth (analz (ik s)) \<and> (A \<in> bad s \<or> B \<in> bad s)))
  }"

lemmas l3_inv8I = l3_inv8_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv8E = l3_inv8_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv8D = l3_inv8_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv8_derived [iff]:
  "l3_inv2 \<inter> l3_inv3 \<inter> l3_inv4 \<subseteq> l3_inv8"
apply (auto intro!: l3_inv8I dest!: l3_inv3D l3_inv2D)
text \<open>2 subgoals: M is deducible and the agents are bad\<close>
apply (drule synth_mono, simp, drule subsetD, assumption)
apply (auto dest!: implAuth_synth_analz [rotated 1, where H="_ \<union> _"] elim!: synth_analz_monotone)

apply (drule synth_mono, simp, drule subsetD, assumption)
apply (auto dest!: implAuth_synth_analz [rotated 1, where H="_ \<union> _"])
done

lemma PO_l3_inv8 [iff]: "reach l3 \<subseteq> l3_inv8"
using l3_inv8_derived
  PO_l3_inv3 PO_l3_inv2 PO_l3_inv4
by blast

subsubsection \<open>inv9\<close>
(**************************************************************************************************)

text \<open>If the level 3 intruder can deduce a message implementing a secure channel message then:
\begin{itemize}
  \item either the message is already in the intruder knowledge;
  \item or the message is constructed, and in this case the payload can also be deduced
 by the intruder, and one of the agents is bad.
\end{itemize}
\<close>

definition
  l3_inv9 :: "l3_state set"
where
  "l3_inv9 \<equiv> {s. \<forall> A B M.
     (implSecure A B M \<in> synth (analz (ik s)) \<and> M \<in> payload) \<longrightarrow>
     (implSecure A B M \<in> ik s \<or> (M \<in> synth (analz (ik s)) \<and> (A \<in> bad s \<or> B \<in> bad s)))
  }"

lemmas l3_inv9I = l3_inv9_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv9E = l3_inv9_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv9D = l3_inv9_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv9_derived [iff]:
  "l3_inv2 \<inter> l3_inv3 \<inter> l3_inv4 \<subseteq> l3_inv9"
apply (auto intro!: l3_inv9I dest!:l3_inv3D l3_inv2D)
text \<open>2 subgoals: M is deducible and the agents are bad\<close>
apply (drule synth_mono, simp, drule subsetD, assumption)
apply (auto dest!: implSecure_synth_analz [rotated 1, where H="_ \<union> _"] elim!: synth_analz_monotone)

apply (drule synth_mono, simp, drule subsetD, assumption)
apply (auto dest!: implSecure_synth_analz [rotated 1, where H="_ \<union> _"])
done

lemma PO_l3_inv9 [iff]: "reach l3 \<subseteq> l3_inv9"
using l3_inv9_derived
  PO_l3_inv3 PO_l3_inv2 PO_l3_inv4
by blast

(**************************************************************************************************)
subsection \<open>Refinement\<close>
(**************************************************************************************************)

text \<open>mediator function\<close>
definition
  med23s :: "l3_obs \<Rightarrow> l2_obs"
where
  "med23s t \<equiv> \<lparr>
    ik = ik t \<inter> payload,
    secret = secret t,
    progress = progress t,
    signals = signals t,
    chan = abs (ik t),
    bad = bad t
    \<rparr>"

text \<open>relation between states\<close>
definition
  R23s :: "(l2_state * l3_state) set"
where
  "R23s \<equiv> {(s, s').
    s = med23s s'
    }"

lemmas R23s_defs = R23s_def med23s_def

lemma R23sI:
  "\<lbrakk> ik s = ik t \<inter> payload; secret s = secret t; progress s = progress t; signals s = signals t;
     chan s = abs (ik t); l2_state.bad s = bad t \<rbrakk>
 \<Longrightarrow> (s, t) \<in> R23s"
by (auto simp add: R23s_def med23s_def)

lemma R23sD:
  "(s, t) \<in> R23s \<Longrightarrow>
    ik s = ik t \<inter> payload \<and> secret s = secret t \<and> progress s = progress t \<and> signals s = signals t \<and>
    chan s = abs (ik t) \<and> l2_state.bad s = bad t"
by (auto simp add: R23s_def med23s_def)

lemma R23sE [elim]:
  "\<lbrakk> (s, t) \<in> R23s;
     \<lbrakk> ik s = ik t \<inter> payload; secret s = secret t; progress s = progress t; signals s = signals t;
     chan s = abs (ik t); l2_state.bad s = bad t \<rbrakk> \<Longrightarrow> P \<rbrakk>
 \<Longrightarrow> P"
by (auto simp add: R23s_def med23s_def)

lemma can_signal_R23 [simp]:
  "(s2, s3) \<in> R23s \<Longrightarrow>
   can_signal s2 A B \<longleftrightarrow> can_signal s3 A B"
by (auto simp add: can_signal_def)

subsubsection \<open>Protocol events\<close>
(**************************************************************************************************)

lemma l3_step1_refines_step1:
  "{R23s} l2_step1 Ra A B, l3_step1 Ra A B {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs)
apply (auto simp add: l3_defs l2_step1_def)
done

lemma l3_step2_refines_step2:
  "{R23s} l2_step2 Rb A B KE, l3_step2 Rb A B KE{>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs l2_step2_def)
apply (auto simp add: l3_step2_def)
done

lemma l3_step3_refines_step3:
  "{R23s} l2_step3 Ra A B K, l3_step3 Ra A B K {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs l2_step3_def)
apply (auto simp add: l3_step3_def)
done

subsubsection \<open>Intruder events\<close>
(**************************************************************************************************)

lemma l3_dy_payload_refines_dy_fake_msg:
  "M \<in> payload \<Longrightarrow>
   {R23s \<inter> UNIV \<times> l3_inv5} l2_dy_fake_msg M, l3_dy M {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs)
apply (auto simp add: l3_defs l2_dy_fake_msg_def dest: l3_inv5D)
done

lemma l3_dy_valid_refines_dy_fake_chan:
  "\<lbrakk> M \<in> valid; M' \<in> abs {M} \<rbrakk> \<Longrightarrow>
   {R23s \<inter> UNIV \<times> (l3_inv5 \<inter> l3_inv6 \<inter> l3_inv7 \<inter> l3_inv8 \<inter> l3_inv9)}
      l2_dy_fake_chan M', l3_dy M
   {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs, simp add: l2_dy_fake_chan_def)
apply (auto simp add: l3_defs)
text \<open>1 subgoal\<close>
apply (erule valid_cases, simp_all add: dy_fake_chan_def)
  text \<open>Insec\<close>
  apply (blast dest: l3_inv6D l3_inv5D)
  text \<open>Confid\<close>
  apply (blast dest: l3_inv7D l3_inv5D)
  text \<open>Auth\<close>
  apply (blast dest: l3_inv8D l3_inv5D)
  text \<open>Secure\<close>
  apply (blast dest: l3_inv9D l3_inv5D)
done

lemma l3_dy_valid_refines_dy_fake_chan_Un:
  "M \<in> valid \<Longrightarrow>
   {R23s \<inter> UNIV \<times> (l3_inv5 \<inter> l3_inv6 \<inter> l3_inv7 \<inter> l3_inv8 \<inter> l3_inv9)}
      \<Union>M'. l2_dy_fake_chan M', l3_dy M
   {>R23s}"
by (auto dest: valid_abs intro: l3_dy_valid_refines_dy_fake_chan)

lemma l3_dy_isLtKey_refines_skip:
  "{R23s} Id, l3_dy (LtK ltk) {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs l3_defs)
apply (auto elim!: absE)
done

lemma l3_dy_others_refines_skip:
  "\<lbrakk> M \<notin> range LtK; M \<notin> valid; M \<notin> payload \<rbrakk> \<Longrightarrow>
   {R23s} Id, l3_dy M {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs)     (* auto SLOW *)
apply (auto simp add: l3_defs)
apply (auto elim!: absE intro: validI)
done

lemma l3_dy_refines_dy_fake_msg_dy_fake_chan_skip:
   "{R23s \<inter> UNIV \<times> (l3_inv5 \<inter> l3_inv6 \<inter> l3_inv7 \<inter> l3_inv8 \<inter> l3_inv9)}
      l2_dy_fake_msg M \<union> (\<Union>M'. l2_dy_fake_chan M') \<union> Id, l3_dy M
    {>R23s}"
by (cases "M \<in> payload \<union> valid \<union> range LtK")
   (auto dest: l3_dy_payload_refines_dy_fake_msg l3_dy_valid_refines_dy_fake_chan_Un
         intro: l3_dy_isLtKey_refines_skip dest!: l3_dy_others_refines_skip)

subsubsection \<open>Compromise events\<close>
(**************************************************************************************************)

lemma l3_lkr_others_refines_lkr_others:
  "{R23s} l2_lkr_others A, l3_lkr_others A {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs)
apply (auto simp add: l3_defs l2_lkr_others_def)
done

lemma l3_lkr_after_refines_lkr_after:
  "{R23s} l2_lkr_after A, l3_lkr_after A {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs)
apply (auto simp add: l3_defs l2_lkr_after_def)
done

lemma l3_skr_refines_skr:
  "{R23s} l2_skr R K, l3_skr R K {>R23s}"
apply (auto simp add: PO_rhoare_defs R23s_defs)
apply (auto simp add: l3_defs l2_skr_def)
done

lemmas l3_trans_refines_l2_trans =
  l3_step1_refines_step1 l3_step2_refines_step2 l3_step3_refines_step3
  l3_dy_refines_dy_fake_msg_dy_fake_chan_skip
  l3_lkr_others_refines_lkr_others l3_lkr_after_refines_lkr_after l3_skr_refines_skr

lemma l3_refines_init_l2 [iff]:
  "init l3 \<subseteq> R23s `` (init l2)"
by (auto simp add: R23s_defs l2_defs l3_def l3_init_def)

lemma l3_refines_trans_l2 [iff]:
  "{R23s \<inter> (UNIV \<times> (l3_inv1 \<inter> l3_inv2 \<inter> l3_inv3 \<inter> l3_inv4))} trans l2, trans l3 {> R23s}"
proof -
  let ?pre' = "R23s \<inter> (UNIV \<times> (l3_inv5 \<inter> l3_inv6 \<inter> l3_inv7 \<inter> l3_inv8 \<inter> l3_inv9))"
  show ?thesis (is "{?pre} ?t1, ?t2 {>?post}")
  proof (rule relhoare_conseq_left)
    show "?pre \<subseteq> ?pre'"
      using l3_inv5_derived l3_inv6_derived l3_inv7_derived l3_inv8_derived l3_inv9_derived by blast
  next
    show "{?pre'} ?t1, ?t2 {> ?post}"
      by (auto simp add: l2_def l3_def l2_trans_def l3_trans_def
               intro!: l3_trans_refines_l2_trans)
  qed
qed

lemma PO_obs_consistent_R23s [iff]:
  "obs_consistent R23s med23s l2 l3"
by (auto simp add: obs_consistent_def R23s_def med23s_def l2_defs)

lemma l3_refines_l2 [iff]:
  "refines
     (R23s \<inter>
      (reach l2 \<times> (l3_inv1 \<inter> l3_inv2 \<inter> l3_inv3 \<inter> l3_inv4)))
     med23s l2 l3"
by (rule Refinement_using_invariants, auto)

lemma l3_implements_l2 [iff]:
  "implements med23s l2 l3"
by (rule refinement_soundness) (auto)

(**************************************************************************************************)
subsection \<open>Derived invariants\<close>
(**************************************************************************************************)

subsubsection \<open>inv10: secrets contain no implementation material\<close>
(**************************************************************************************************)

definition
  l3_inv10 :: "l3_state set"
where
  "l3_inv10 \<equiv> {s.
    secret s \<subseteq> payload
  }"

lemmas l3_inv10I = l3_inv10_def [THEN setc_def_to_intro, rule_format]
lemmas l3_inv10E = l3_inv10_def [THEN setc_def_to_elim, rule_format]
lemmas l3_inv10D = l3_inv10_def [THEN setc_def_to_dest, rule_format]

lemma l3_inv10_init [iff]:
  "init l3 \<subseteq> l3_inv10"
by (auto simp add: l3_def l3_init_def ik_init_def intro!:l3_inv10I)

lemma l3_inv10_trans [iff]:
  "{l3_inv10} trans l3 {> l3_inv10}"
apply (auto simp add: PO_hoare_defs l3_nostep_defs)
apply (auto simp add: l3_defs l3_inv10_def)
done

lemma PO_l3_inv10 [iff]: "reach l3 \<subseteq> l3_inv10"
by (rule inv_rule_basic) (auto)

lemma l3_obs_inv10 [iff]: "oreach l3 \<subseteq> l3_inv10"
by (auto simp add: oreach_def)

subsubsection \<open>Partial secrecy\<close>
(**************************************************************************************************)

text \<open>We want to prove @{term "l3_secrecy"}, ie
  @{term "synth (analz (ik s)) \<inter> secret s = {}"},
  but by refinement we only get @{term "l3_partial_secrecy"}:
    @{term "dy_fake_msg (bad s) (payloadSet (ik s)) (abs (ik s)) \<inter> secret s = {}"}.
  This is fine if secrets contain no implementation material.
  Then, by @{term "inv5"}, a message in @{term "synth (analz (ik s))"} is in
    @{term "dy_fake_msg (bad s) (payloadSet (ik s)) (abs (ik s)) \<union> -payload"},
  and @{term "l3_partial_secrecy"} proves it is not a secret.
\<close>

definition
  l3_partial_secrecy :: "('a l3_state_scheme) set"
where
  "l3_partial_secrecy \<equiv> {s.
    dy_fake_msg (bad s) (ik s \<inter> payload) (abs (ik s)) \<inter> secret s = {}
  }"

lemma l3_obs_partial_secrecy [iff]: "oreach l3 \<subseteq> l3_partial_secrecy"
apply (rule external_invariant_translation [OF l2_obs_secrecy _ l3_implements_l2])
apply (auto simp add: med23s_def l2_secrecy_def l3_partial_secrecy_def)
done

subsubsection \<open>Secrecy\<close>
(**************************************************************************************************)

definition
  l3_secrecy :: "('a l3_state_scheme) set"
where
  "l3_secrecy \<equiv> l1_secrecy"

lemma l3_obs_secrecy [iff]: "oreach l3 \<subseteq> l3_secrecy"
apply (rule, frule l3_obs_inv5 [THEN [2] rev_subsetD], frule l3_obs_inv10 [THEN [2] rev_subsetD])
apply (auto simp add: med23s_def l2_secrecy_def l3_secrecy_def s0_secrecy_def l3_inv10_def)
using l3_partial_secrecy_def apply (blast dest!: l3_inv5D subsetD [OF l3_obs_partial_secrecy])
done

lemma l3_secrecy [iff]: "reach l3 \<subseteq> l3_secrecy"
by (rule external_to_internal_invariant [OF l3_obs_secrecy], auto)

subsubsection \<open>Injective agreement\<close>
(**************************************************************************************************)

abbreviation "l3_iagreement \<equiv> l1_iagreement"

lemma l3_obs_iagreement [iff]: "oreach l3 \<subseteq> l3_iagreement"
apply (rule external_invariant_translation [OF l2_obs_iagreement _ l3_implements_l2])
apply (auto simp add: med23s_def l1_iagreement_def)
done

lemma l3_iagreement [iff]: "reach l3 \<subseteq> l3_iagreement"
by (rule external_to_internal_invariant [OF l3_obs_iagreement], auto)

end
end


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

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_inv__38_on_rules imports n_germanSimp_lemma_on_inv__38
begin
section{*All lemmas on causal relation between inv__38*}
lemma lemma_inv__38_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__38  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__38) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

end


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

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__21 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__21 and some rule r*}
lemma n_SendInv__part__0Vsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''ExGntd'')) (Const false)) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__21:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__21  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__21:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvInvAckVsinv__21:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqE__part__0Vsinv__21:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqE__part__1Vsinv__21:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqSVsinv__21:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqS N i" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__21  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


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

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__8_on_rules imports n_german_lemma_on_inv__8
begin
section{*All lemmas on causal relation between inv__8*}
lemma lemma_inv__8_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__8  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__8) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


(*<*)
theory Monitor_Code
  imports Monitor
    "HOL-Library.Code_Target_Nat"
    "HOL.String"
    Containers.Containers
begin
  (*>*)

derive ccompare MFOTL.trm
derive (eq) ceq MFOTL.trm
derive (rbt) set_impl MFOTL.trm

lemma image_these: "f ` Option.these X = Option.these (map_option f ` X)"
  by (force simp: in_these_eq Bex_def image_iff map_option_case split: option.splits)

lemma meval_MPred: "meval n t db (MPred e ts) = ([Option.these
  ((map_option (\<lambda>f. tabulate f 0 n) o match ts) ` (\<Union>(e', x)\<in>db. if e = e' then {x} else {}))], MPred e ts)"
  unfolding meval.simps image_these image_image o_def ..

lemma meval_MPred': "meval n t db (MPred e ts) = ([Option.these
  (\<Union>(e', x)\<in>db. if e = e' then {map_option (\<lambda>f. tabulate f 0 n) (match ts x)} else {})], MPred e ts)"
  unfolding meval_MPred image_UN split_beta if_distrib[of "image _"] image_insert image_empty o_apply
  ..

lemma these_UNION: "Option.these (\<Union> (B ` A)) = (\<Union> ((Option.these o B) ` A))"
  by (auto simp: Option.these_def)

lemma meval_MPred'': "meval n t db (MPred e ts) = ([
  (\<Union>(e', x)\<in>db. if e = e' then set_option (map_option (\<lambda>f. tabulate f 0 n) (match ts x)) else {})], MPred e ts)"
  unfolding meval_MPred' these_UNION o_def prod.case_distrib[of Option.these]
  by (auto simp: Option.these_def map_option_case image_iff split: if_splits option.splits)

lemmas meval_code[code] = meval.simps(1) meval_MPred'' meval.simps(3-9)

definition db_code :: "(char list \<times> 'a list) list \<Rightarrow> (char list \<times> 'a list) set" where
  "db_code = set"

definition verdict_code :: "_ \<Rightarrow> (nat \<times> 'a :: ccompare option list) list" where
  "verdict_code = RBT_Set2.keys"

export_code HOL.equal Collection_Eq.ceq Collection_Order.ccompare Eq Lt Gt set_RBT set_impl phantom
  nat_of_integer integer_of_nat enat literal.explode db_code set interval RBT_set verdict_code
  MFOTL.Var MFOTL.Const
  MFOTL.Pred MFOTL.Eq MFOTL.Neg MFOTL.Or MFOTL.Exists
  MFOTL.Prev MFOTL.Next MFOTL.Since MFOTL.Until
  checking OCaml?

export_code HOL.equal Collection_Eq.ceq Collection_Order.ccompare Eq Lt Gt set_RBT set_impl phantom
  nat_of_integer integer_of_nat enat literal.explode db_code set interval RBT_set verdict_code
  MFOTL.Var MFOTL.Const
  MFOTL.Pred MFOTL.Eq MFOTL.Neg MFOTL.Or MFOTL.Exists
  MFOTL.Prev MFOTL.Next MFOTL.Since MFOTL.Until
  minit_safe mstep in OCaml module_name Monitor file_prefix "verified"

(*<*)
end
(*>*)


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

theory ArchArraysMemInstance
imports "../ArraysMemInstance"
begin

(* Showing arrays are in mem_type requires maximum sizes for objects,
   and maximum counts for elements *)
class array_outer_max_size = mem_type +
  assumes array_outer_max_size_ax: "size_of TYPE('a::c_type) < 2 ^ 26"

class array_max_count = finite +
  assumes array_max_count_ax: "CARD ('a) <= 2 ^ 20"

instance array :: (array_outer_max_size, array_max_count) mem_type
apply intro_classes
apply simp
apply (subgoal_tac "addr_card = 2 ^ (addr_bitsize - 26) * 2 ^ 26")
  apply (erule ssubst)
  apply (rule less_le_trans[where y = "card (UNIV::'b set) * 2 ^ 26"])
    apply (rule mult_less_mono2)
      apply (rule array_outer_max_size_ax)
    apply simp
  apply (rule mult_le_mono1)
    apply (rule le_trans[where j = "2 ^ 20"])
      apply (rule array_max_count_ax)
    apply simp
  apply simp
apply (simp add: addr_card)
done

class array_inner_max_size = array_outer_max_size +
  assumes array_inner_max_size_ax: "size_of TYPE('a::c_type) < 2 ^ 6"

instance array :: (array_inner_max_size, array_max_count) array_outer_max_size
apply intro_classes
apply simp
  apply (rule order_less_le_trans)
   apply (rule mult_le_less_imp_less)
    apply (rule array_max_count_ax)
   apply (rule array_inner_max_size_ax)
  apply simp
   apply simp
  apply simp
  done

instance word :: (len8) array_outer_max_size
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done

instance word :: (len8) array_inner_max_size
apply intro_classes
apply(simp add: size_of_def)
apply(subgoal_tac "len_of TYPE('a) \<le> 128")
 apply simp
apply(rule len8_width)
done

instance ptr :: (c_type) array_outer_max_size
apply intro_classes
apply (simp add: size_of_def)
done

instance ptr :: (c_type) array_inner_max_size
apply intro_classes
apply (simp add: size_of_def)
done

class lt19 = finite +
  assumes lt19_ax: "CARD ('a) < 2 ^ 19"
class lt18 = lt19 +
  assumes lt18_ax: "CARD ('a) < 2 ^ 18"
class lt17 = lt18 +
  assumes lt17_ax: "CARD ('a) < 2 ^ 17"
class lt16 = lt17 +
  assumes lt16_ax: "CARD ('a) < 2 ^ 16"
class lt15 = lt16 +
  assumes lt15_ax: "CARD ('a) < 2 ^ 15"
class lt14 = lt15 +
  assumes lt14_ax: "CARD ('a) < 2 ^ 14"
class lt13 = lt14 +
  assumes lt13_ax: "CARD ('a) < 2 ^ 13"
class lt12 = lt13 +
  assumes lt12_ax: "CARD ('a) < 2 ^ 12"
class lt11 = lt12 +
  assumes lt11_ax: "CARD ('a) < 2 ^ 11"
class lt10 = lt11 +
  assumes lt10_ax: "CARD ('a) < 2 ^ 10"
class lt9 = lt10 +
  assumes lt9_ax: "CARD ('a) < 2 ^ 9"
class lt8 = lt9 +
  assumes lt8_ax: "CARD ('a) < 2 ^ 8"
class lt7 = lt8 +
  assumes lt7_ax: "CARD ('a) < 2 ^ 7"
class lt6 = lt7 +
  assumes lt6_ax: "CARD ('a) < 2 ^ 6"
class lt5 = lt6 +
  assumes lt5_ax: "CARD ('a) < 2 ^ 5"
class lt4 = lt5 +
  assumes lt4_ax: "CARD ('a) < 2 ^ 4"
class lt3 = lt4 +
  assumes lt3_ax: "CARD ('a) < 2 ^ 3"
class lt2 = lt3 +
  assumes lt2_ax: "CARD ('a) < 2 ^ 2"
class lt1 = lt2 +
  assumes lt1_ax: "CARD ('a) < 2 ^ 1"

instance bit0 :: (lt19) array_max_count
  using lt19_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt19) array_max_count
  using lt19_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt18) lt19
  using lt18_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt18) lt19
  using lt18_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt17) lt18
  using lt17_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt17) lt18
  using lt17_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt16) lt17
  using lt16_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt16) lt17
  using lt16_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt15) lt16
  using lt15_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt15) lt16
  using lt15_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt14) lt15
  using lt14_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt14) lt15
  using lt14_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt13) lt14
  using lt13_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt13) lt14
  using lt13_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt12) lt13
  using lt12_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt12) lt13
  using lt12_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt11) lt12
  using lt11_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt11) lt12
  using lt11_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt10) lt11
  using lt10_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt10) lt11
  using lt10_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt9) lt10
  using lt9_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt9) lt10
  using lt9_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt8) lt9
  using lt8_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt8) lt9
  using lt8_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt7) lt8
  using lt7_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt7) lt8
  using lt7_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt6) lt7
  using lt6_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt6) lt7
  using lt6_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt5) lt6
  using lt5_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt5) lt6
  using lt5_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt4) lt5
  using lt4_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt4) lt5
  using lt4_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt3) lt4
  using lt3_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt3) lt4
  using lt3_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt2) lt3
  using lt2_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt2) lt3
  using lt2_ax[where 'a='a] by intro_classes simp

instance bit0 :: (lt1) lt2
  using lt1_ax[where 'a='a] by intro_classes simp

instance bit1 :: (lt1) lt2
  using lt1_ax[where 'a='a] by intro_classes simp

instance num1 :: lt1
  by (intro_classes, simp_all)

(* don't understand why this also seems to be necessary *)
instance num1 :: array_max_count
  by (intro_classes, simp)

(* introduce hackish handling of 8192 type by making a copy of the type
   under a constructor, and then manually showing that it is an instance of
   array_max_count *)
datatype array_max_count_ty = array_max_count_ty "1048576"

(* ML c-parser code also needs to know at which array size to use this type *)
ML \<open>
  structure ArchArrayMaxCount = struct
    val array_max_count = 1048576
  end
\<close>

lemma univ_array_max_count_ty:
  "(UNIV::array_max_count_ty set) = image array_max_count_ty (UNIV::1048576 set)"
  apply (simp add: set_eq_iff image_iff)
  apply (rule_tac allI)
  apply (rule_tac array_max_count_ty.induct)
  apply simp
  done

instance "array_max_count_ty" :: finite
  apply intro_classes
  apply (simp add: univ_array_max_count_ty)
  done

lemma card_array_max_count_ty[simp]: "CARD(array_max_count_ty) = CARD(1048576)"
  apply (simp add: univ_array_max_count_ty card_image inj_on_def)
  done

instance "array_max_count_ty" :: array_max_count
  by intro_classes simp

end


section \<open>Frame Inference\<close>
theory Sepref_Frame
imports Sepref_Basic Sepref_Constraints
begin
  text \<open> In this theory, we provide a specific frame inference tactic
    for Sepref.

    The first tactic, \<open>frame_tac\<close>, is a standard frame inference tactic,
    based on the assumption that only @{const hn_ctxt}-assertions need to be
    matched.

    The second tactic, \<open>merge_tac\<close>, resolves entailments of the form
      \<open>F1 \<or>\<^sub>A F2 \<Longrightarrow>\<^sub>t ?F\<close>
    that occur during translation of if and case statements.
    It synthesizes a new frame ?F, where refinements of variables
    with equal refinements in \<open>F1\<close> and \<open>F2\<close> are preserved,
    and the others are set to @{const hn_invalid}.
    \<close>

definition mismatch_assn :: "('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> assn) \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> assn"
  where "mismatch_assn R1 R2 x y \<equiv> R1 x y \<or>\<^sub>A R2 x y"

abbreviation "hn_mismatch R1 R2 \<equiv> hn_ctxt (mismatch_assn R1 R2)"

lemma recover_pure_aux: "CONSTRAINT is_pure R \<Longrightarrow> hn_invalid R x y \<Longrightarrow>\<^sub>t hn_ctxt R x y"
  by (auto simp: is_pure_conv invalid_pure_recover hn_ctxt_def)

lemma frame_thms:
  "P \<Longrightarrow>\<^sub>t P"
  "P\<Longrightarrow>\<^sub>tP' \<Longrightarrow> F\<Longrightarrow>\<^sub>tF' \<Longrightarrow> F*P \<Longrightarrow>\<^sub>t F'*P'"
  "hn_ctxt R x y \<Longrightarrow>\<^sub>t hn_invalid R x y"
  "hn_ctxt R x y \<Longrightarrow>\<^sub>t hn_ctxt (\<lambda>_ _. true) x y"
  "CONSTRAINT is_pure R \<Longrightarrow> hn_invalid R x y \<Longrightarrow>\<^sub>t hn_ctxt R x y"
  apply -
  applyS simp
  applyS (rule entt_star_mono; assumption)
  subgoal
    apply (simp add: hn_ctxt_def)
    apply (rule enttI)
    apply (rule ent_trans[OF invalidate[of R]])
    by (simp add: entt_refl')
  subgoal
    by (auto simp: hn_ctxt_def entailst_def)
  apply (erule recover_pure_aux)
  done

named_theorems_rev sepref_frame_match_rules \<open>Sepref: Additional frame rules\<close>

text \<open>Rules to discharge unmatched stuff\<close>
(*lemma frame_rem_thms:
  "P \<Longrightarrow>\<^sub>t P"
  "P \<Longrightarrow>\<^sub>t emp"
  by sep_auto+
*)
lemma frame_rem1: "P\<Longrightarrow>\<^sub>tP" by simp

lemma frame_rem2: "F \<Longrightarrow>\<^sub>t F' \<Longrightarrow> F * hn_ctxt A x y \<Longrightarrow>\<^sub>t F' * hn_ctxt A x y"
  apply (rule entt_star_mono) by auto

lemma frame_rem3: "F \<Longrightarrow>\<^sub>t F' \<Longrightarrow> F * hn_ctxt A x y \<Longrightarrow>\<^sub>t F'"
  using frame_thms(2) by fastforce

lemma frame_rem4: "P \<Longrightarrow>\<^sub>t emp" by simp

lemmas frame_rem_thms = frame_rem1 frame_rem2 frame_rem3 frame_rem4

named_theorems_rev sepref_frame_rem_rules
  \<open>Sepref: Additional rules to resolve remainder of frame-pairing\<close>

lemma ent_disj_star_mono:
  "\<lbrakk> A \<or>\<^sub>A C \<Longrightarrow>\<^sub>A E; B \<or>\<^sub>A D \<Longrightarrow>\<^sub>A F \<rbrakk> \<Longrightarrow> A*B \<or>\<^sub>A C*D \<Longrightarrow>\<^sub>A E*F"
  by (metis ent_disjI1 ent_disjI2 ent_disjE ent_star_mono)

lemma entt_disj_star_mono:
  "\<lbrakk> A \<or>\<^sub>A C \<Longrightarrow>\<^sub>t E; B \<or>\<^sub>A D \<Longrightarrow>\<^sub>t F \<rbrakk> \<Longrightarrow> A*B \<or>\<^sub>A C*D \<Longrightarrow>\<^sub>t E*F"
proof -
  assume a1: "A \<or>\<^sub>A C \<Longrightarrow>\<^sub>t E"
  assume "B \<or>\<^sub>A D \<Longrightarrow>\<^sub>t F"
  then have "A * B \<or>\<^sub>A C * D \<Longrightarrow>\<^sub>A true * E * (true * F)"
    using a1 by (simp add: assn_times_comm ent_disj_star_mono enttD)
  then show ?thesis
    by (metis (no_types) assn_times_comm enttI merge_true_star_ctx star_aci(3))
qed

lemma hn_merge1:
  (*"emp \<or>\<^sub>A emp \<Longrightarrow>\<^sub>A emp"*)
  "F \<or>\<^sub>A F \<Longrightarrow>\<^sub>t F"
  "\<lbrakk> hn_ctxt R1 x x' \<or>\<^sub>A hn_ctxt R2 x x' \<Longrightarrow>\<^sub>t hn_ctxt R x x'; Fl \<or>\<^sub>A Fr \<Longrightarrow>\<^sub>t F \<rbrakk>
    \<Longrightarrow> Fl * hn_ctxt R1 x x' \<or>\<^sub>A Fr * hn_ctxt R2 x x' \<Longrightarrow>\<^sub>t F * hn_ctxt R x x'"
  subgoal by (simp add: ent_disjE enttI entt_refl')
  by (rule entt_disj_star_mono; simp)

lemma hn_merge2:
  "hn_invalid R x x' \<or>\<^sub>A hn_ctxt R x x' \<Longrightarrow>\<^sub>t hn_invalid R x x'"
  "hn_ctxt R x x' \<or>\<^sub>A hn_invalid R x x' \<Longrightarrow>\<^sub>t hn_invalid R x x'"
  by (auto intro!: invalidate ent_disjE ent_imp_entt simp: hn_ctxt_def)+

lemma invalid_assn_mono: "hn_ctxt A x y \<Longrightarrow>\<^sub>t hn_ctxt B x y
  \<Longrightarrow> hn_invalid A x y \<Longrightarrow>\<^sub>t hn_invalid B x y"
  apply (clarsimp simp: invalid_assn_def entailst_def entails_def hn_ctxt_def)
  by (metis ent_iffI entails_def entails_pure entt_refl' move_back_pure)

lemma entt_disjE: "\<lbrakk> A\<Longrightarrow>\<^sub>tM; B\<Longrightarrow>\<^sub>tM \<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>t M"
  using ent_disjE enttD enttI by blast
lemma hn_merge3: (* Not used *)
  "\<lbrakk>NO_MATCH (hn_invalid XX) R2; hn_ctxt R1 x x' \<or>\<^sub>A hn_ctxt R2 x x' \<Longrightarrow>\<^sub>t hn_ctxt Rm x x'\<rbrakk> \<Longrightarrow> hn_invalid R1 x x' \<or>\<^sub>A hn_ctxt R2 x x' \<Longrightarrow>\<^sub>t hn_invalid Rm x x'"
  "\<lbrakk>NO_MATCH (hn_invalid XX) R1; hn_ctxt R1 x x' \<or>\<^sub>A hn_ctxt R2 x x' \<Longrightarrow>\<^sub>t hn_ctxt Rm x x'\<rbrakk> \<Longrightarrow> hn_ctxt R1 x x' \<or>\<^sub>A hn_invalid R2 x x' \<Longrightarrow>\<^sub>t hn_invalid Rm x x'"
  apply (meson entt_disjD1 entt_disjD2 entt_disjE entt_trans frame_thms(3) invalid_assn_mono)
  apply (meson entt_disjD1 entt_disjD2 entt_disjE entt_trans frame_thms(3) invalid_assn_mono)
  done

lemmas merge_thms = hn_merge1 hn_merge2

named_theorems sepref_frame_merge_rules \<open>Sepref: Additional merge rules\<close>

lemma hn_merge_mismatch: "hn_ctxt R1 x x' \<or>\<^sub>A hn_ctxt R2 x x' \<Longrightarrow>\<^sub>t hn_mismatch R1 R2 x x'"
  by (auto simp: hn_ctxt_def mismatch_assn_def)

lemma is_merge: "P1\<or>\<^sub>AP2\<Longrightarrow>\<^sub>tP \<Longrightarrow> P1\<or>\<^sub>AP2\<Longrightarrow>\<^sub>tP" .

lemma merge_mono: "\<lbrakk>A\<Longrightarrow>\<^sub>tA'; B\<Longrightarrow>\<^sub>tB'; A'\<or>\<^sub>AB' \<Longrightarrow>\<^sub>t C\<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>t C"
  by (meson entt_disjE entt_disjI1_direct entt_disjI2_direct entt_trans)

text \<open>Apply forward rule on left or right side of merge\<close>
lemma gen_merge_cons1: "\<lbrakk>A\<Longrightarrow>\<^sub>tA'; A'\<or>\<^sub>AB \<Longrightarrow>\<^sub>t C\<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>t C"
  by (meson merge_mono entt_refl)

lemma gen_merge_cons2: "\<lbrakk>B\<Longrightarrow>\<^sub>tB'; A\<or>\<^sub>AB' \<Longrightarrow>\<^sub>t C\<rbrakk> \<Longrightarrow> A\<or>\<^sub>AB \<Longrightarrow>\<^sub>t C"
  by (meson merge_mono entt_refl)

lemmas gen_merge_cons = gen_merge_cons1 gen_merge_cons2

text \<open>These rules are applied to recover pure values that have been destroyed by rule application\<close>

definition "RECOVER_PURE P Q \<equiv> P \<Longrightarrow>\<^sub>t Q"

lemma recover_pure:
  "RECOVER_PURE emp emp"
  "\<lbrakk>RECOVER_PURE P2 Q2; RECOVER_PURE P1 Q1\<rbrakk> \<Longrightarrow> RECOVER_PURE (P1*P2) (Q1*Q2)"
  "CONSTRAINT is_pure R \<Longrightarrow> RECOVER_PURE (hn_invalid R x y) (hn_ctxt R x y)"
  "RECOVER_PURE (hn_ctxt R x y) (hn_ctxt R x y)"
  unfolding RECOVER_PURE_def
  subgoal by auto
  subgoal by (drule (1) entt_star_mono)
  subgoal by (rule recover_pure_aux)
  subgoal by auto
  done

lemma recover_pure_triv:
  "RECOVER_PURE P P"
  unfolding RECOVER_PURE_def by auto

text \<open>Weakening the postcondition by converting @{const invalid_assn} to @{term "\<lambda>_ _. true"}\<close>
definition "WEAKEN_HNR_POST \<Gamma> \<Gamma>' \<Gamma>'' \<equiv> (\<exists>h. h\<Turnstile>\<Gamma>) \<longrightarrow> (\<Gamma>'' \<Longrightarrow>\<^sub>t \<Gamma>')"

lemma weaken_hnr_postI:
  assumes "WEAKEN_HNR_POST \<Gamma> \<Gamma>'' \<Gamma>'"
  assumes "hn_refine \<Gamma> c \<Gamma>' R a"
  shows "hn_refine \<Gamma> c \<Gamma>'' R a"
  apply (rule hn_refine_preI)
  apply (rule hn_refine_cons_post)
  apply (rule assms)
  using assms(1) unfolding WEAKEN_HNR_POST_def by blast

lemma weaken_hnr_post_triv: "WEAKEN_HNR_POST \<Gamma> P P"
  unfolding WEAKEN_HNR_POST_def
  by auto

lemma weaken_hnr_post:
  "\<lbrakk>WEAKEN_HNR_POST \<Gamma> P P'; WEAKEN_HNR_POST \<Gamma>' Q Q'\<rbrakk> \<Longrightarrow> WEAKEN_HNR_POST (\<Gamma>*\<Gamma>') (P*Q) (P'*Q')"
  "WEAKEN_HNR_POST (hn_ctxt R x y) (hn_ctxt R x y) (hn_ctxt R x y)"
  "WEAKEN_HNR_POST (hn_ctxt R x y) (hn_invalid R x y) (hn_ctxt (\<lambda>_ _. true) x y)"
proof (goal_cases)
  case 1 thus ?case
    unfolding WEAKEN_HNR_POST_def
    apply clarsimp
    apply (rule entt_star_mono)
    subgoal using entailsD' entails_def mod_false' by blast
    subgoal by (metis assn_times_comm entailsD' entails_def mod_false')
    done
next
  case 2 thus ?case by (rule weaken_hnr_post_triv)
next
  case 3 thus ?case
    unfolding WEAKEN_HNR_POST_def
    by (auto simp: invalid_assn_def hn_ctxt_def)
qed

lemma reorder_enttI:
  assumes "A*true = C*true"
  assumes "B*true = D*true"
  shows "(A\<Longrightarrow>\<^sub>tB) \<equiv> (C\<Longrightarrow>\<^sub>tD)"
  apply (intro eq_reflection)
  unfolding entt_def_true
  by (simp add: assms)

lemma merge_sat1: "(A\<or>\<^sub>AA' \<Longrightarrow>\<^sub>t Am) \<Longrightarrow> (A\<or>\<^sub>AAm \<Longrightarrow>\<^sub>t Am)"
  using entt_disjD1 entt_disjE by blast
lemma merge_sat2: "(A\<or>\<^sub>AA' \<Longrightarrow>\<^sub>t Am) \<Longrightarrow> (Am\<or>\<^sub>AA' \<Longrightarrow>\<^sub>t Am)"
  using entt_disjD2 entt_disjE by blast

ML \<open>
signature SEPREF_FRAME = sig

  (* Check if subgoal is a frame obligation *)
  (*val is_frame : term -> bool *)
  (* Check if subgoal is a merge obligation *)
  val is_merge: term -> bool
  (* Perform frame inference *)
  val frame_tac: (Proof.context -> tactic') -> Proof.context -> tactic'
  (* Perform merging *)
  val merge_tac: (Proof.context -> tactic') -> Proof.context -> tactic'

  val frame_step_tac: (Proof.context -> tactic') -> bool -> Proof.context -> tactic'

  (* Reorder frame *)
  val prepare_frame_tac : Proof.context -> tactic'
  (* Solve a RECOVER_PURE goal, inserting constraints as necessary *)
  val recover_pure_tac: Proof.context -> tactic'

  (* Split precondition of hnr-goal into frame and arguments *)
  val align_goal_tac: Proof.context -> tactic'
  (* Normalize goal's precondition *)
  val norm_goal_pre_tac: Proof.context -> tactic'
  (* Rearrange precondition of hnr-term according to parameter order, normalize all relations *)
  val align_rl_conv: Proof.context -> conv

  (* Convert hn_invalid to \<lambda>_ _. true in postcondition of hnr-goal. Makes proving the goal easier.*)
  val weaken_post_tac: Proof.context -> tactic'

  val add_normrel_eq : thm -> Context.generic -> Context.generic
  val del_normrel_eq : thm -> Context.generic -> Context.generic
  val get_normrel_eqs : Proof.context -> thm list

  val cfg_debug: bool Config.T

  val setup: theory -> theory
end

structure Sepref_Frame : SEPREF_FRAME = struct

  val cfg_debug =
    Attrib.setup_config_bool @{binding sepref_debug_frame} (K false)

  val DCONVERSION = Sepref_Debugging.DBG_CONVERSION cfg_debug
  val dbg_msg_tac = Sepref_Debugging.dbg_msg_tac cfg_debug

  structure normrel_eqs = Named_Thms (
    val name = @{binding sepref_frame_normrel_eqs}
    val description = "Equations to normalize relations for frame matching"
  )

  val add_normrel_eq = normrel_eqs.add_thm
  val del_normrel_eq = normrel_eqs.del_thm
  val get_normrel_eqs = normrel_eqs.get

  val mk_entailst = HOLogic.mk_binrel @{const_name "entailst"}

  local
    open Sepref_Basic Refine_Util Conv

    fun assn_ord p = case apply2 dest_hn_ctxt_opt p of
        (NONE,NONE) => EQUAL
      | (SOME _, NONE) => LESS
      | (NONE, SOME _) => GREATER
      | (SOME (_,a,_), SOME (_,a',_)) => Term_Ord.fast_term_ord (a,a')

  in
    fun reorder_ctxt_conv ctxt ct = let
      val cert = Thm.cterm_of ctxt

      val new_ct = Thm.term_of ct
        |> strip_star
        |> sort assn_ord
        |> list_star
        |> cert

      val thm = Goal.prove_internal ctxt [] (mk_cequals (ct,new_ct))
        (fn _ => simp_tac
          (put_simpset HOL_basic_ss ctxt addsimps @{thms star_aci}) 1)

    in
      thm
    end

    fun prepare_fi_conv ctxt ct = case Thm.term_of ct of
      @{mpat "?P \<Longrightarrow>\<^sub>t ?Q"} => let
        val cert = Thm.cterm_of ctxt

        (* Build table from abs-vars to ctxt *)
        val (Qm, Qum) = strip_star Q |> filter_out is_true |> List.partition is_hn_ctxt

        val Qtab = (
          Qm |> map (fn x => (#2 (dest_hn_ctxt x),(NONE,x)))
          |> Termtab.make
        ) handle
            e as (Termtab.DUP _) => (
              tracing ("Dup heap: " ^ @{make_string} ct); raise e)

        (* Go over entries in P and try to find a partner *)
        val (Qtab,Pum) = fold (fn a => fn (Qtab,Pum) =>
          case dest_hn_ctxt_opt a of
            NONE => (Qtab,a::Pum)
          | SOME (_,p,_) => ( case Termtab.lookup Qtab p of
              SOME (NONE,tg) => (Termtab.update (p,(SOME a,tg)) Qtab, Pum)
            | _ => (Qtab,a::Pum)
            )
        ) (strip_star P) (Qtab,[])

        val Pum = filter_out is_true Pum

        (* Read out information from Qtab *)
        val (pairs,Qum2) = Termtab.dest Qtab |> map #2
          |> List.partition (is_some o #1)
          |> apfst (map (apfst the))
          |> apsnd (map #2)

        (* Build reordered terms: P' = fst pairs * Pum, Q' = snd pairs * (Qum2*Qum) *)
        val P' = mk_star (list_star (map fst pairs), list_star Pum)
        val Q' = mk_star (list_star (map snd pairs), list_star (Qum2@Qum))

        val new_ct = mk_entailst (P', Q') |> cert

        val msg_tac = dbg_msg_tac (Sepref_Debugging.msg_allgoals "Solving frame permutation") ctxt 1
        val tac = msg_tac THEN ALLGOALS (resolve_tac ctxt @{thms reorder_enttI}) THEN star_permute_tac ctxt

        val thm = Goal.prove_internal ctxt [] (mk_cequals (ct,new_ct)) (fn _ => tac)

      in
        thm
      end
    | _ => no_conv ct

  end

  fun is_merge @{mpat "Trueprop (_ \<or>\<^sub>A _ \<Longrightarrow>\<^sub>t _)"} = true | is_merge _ = false
  fun is_gen_frame @{mpat "Trueprop (_ \<Longrightarrow>\<^sub>t _)"} = true | is_gen_frame _ = false

  fun prepare_frame_tac ctxt = let
    open Refine_Util Conv
    val frame_ss = put_simpset HOL_basic_ss ctxt addsimps
      @{thms mult_1_right[where 'a=assn] mult_1_left[where 'a=assn]}
  in
    CONVERSION Thm.eta_conversion THEN'
    (*CONCL_COND' is_frame THEN'*)
    simp_tac frame_ss THEN'
    CONVERSION (HOL_concl_conv (fn _ => prepare_fi_conv ctxt) ctxt)
  end

  local
    fun wrap_side_tac side_tac dbg tac = tac THEN_ALL_NEW_FWD (
      CONCL_COND' is_gen_frame
      ORELSE' (if dbg then TRY_SOLVED' else SOLVED') side_tac
    )
  in
    fun frame_step_tac side_tac dbg ctxt = let
      open Refine_Util Conv

      (* Constraint solving is built-in *)
      val side_tac = Sepref_Constraints.constraint_tac ctxt ORELSE' side_tac ctxt

      val frame_thms = @{thms frame_thms} @
        Named_Theorems_Rev.get ctxt @{named_theorems_rev sepref_frame_match_rules}
      val merge_thms = @{thms merge_thms} @
        Named_Theorems.get ctxt @{named_theorems sepref_frame_merge_rules}
      val ss = put_simpset HOL_basic_ss ctxt addsimps normrel_eqs.get ctxt
      fun frame_thm_tac dbg = wrap_side_tac side_tac dbg (resolve_tac ctxt frame_thms)
      fun merge_thm_tac dbg = wrap_side_tac side_tac dbg (resolve_tac ctxt merge_thms)

      fun thm_tac dbg = CONCL_COND' is_merge THEN_ELSE' (merge_thm_tac dbg, frame_thm_tac dbg)
    in
      full_simp_tac ss THEN' thm_tac dbg
    end
  end

  fun frame_loop_tac side_tac ctxt = let

  in
    TRY o (
      REPEAT_ALL_NEW (DETERM o frame_step_tac side_tac false ctxt)
    )
  end

  fun frame_tac side_tac ctxt = let
    open Refine_Util Conv
    val frame_rem_thms = @{thms frame_rem_thms}
      @ Named_Theorems_Rev.get ctxt @{named_theorems_rev sepref_frame_rem_rules}
    val solve_remainder_tac = TRY o REPEAT_ALL_NEW (DETERM o resolve_tac ctxt frame_rem_thms)
  in
    (prepare_frame_tac ctxt
      THEN' resolve_tac ctxt @{thms ent_star_mono entt_star_mono})
    THEN_ALL_NEW_LIST [
      frame_loop_tac side_tac ctxt,
      solve_remainder_tac
    ]
  end

  fun merge_tac side_tac ctxt = let
    open Refine_Util Conv
    val merge_conv = arg1_conv (binop_conv (reorder_ctxt_conv ctxt))
  in
    CONVERSION Thm.eta_conversion THEN'
    CONCL_COND' is_merge THEN'
    simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms star_aci}) THEN'
    CONVERSION (HOL_concl_conv (fn _ => merge_conv) ctxt) THEN'
    frame_loop_tac side_tac ctxt
  end

  val setup = normrel_eqs.setup

  local
    open Sepref_Basic
    fun is_invalid @{mpat "hn_invalid _ _ _ :: assn"} = true | is_invalid _ = false
    fun contains_invalid @{mpat "Trueprop (RECOVER_PURE ?Q _)"} = exists is_invalid (strip_star Q)
      | contains_invalid _ = false

  in
    fun recover_pure_tac ctxt =
      CONCL_COND' contains_invalid THEN_ELSE' (
        REPEAT_ALL_NEW (DETERM o (resolve_tac ctxt @{thms recover_pure} ORELSE' Sepref_Constraints.constraint_tac ctxt)),
        resolve_tac ctxt @{thms recover_pure_triv}
      )
  end

  local
    open Sepref_Basic Refine_Util
    datatype cte = Other of term | Hn of term * term * term
    fun dest_ctxt_elem @{mpat "hn_ctxt ?R ?a ?c"} = Hn (R,a,c)
      | dest_ctxt_elem t = Other t

    fun mk_ctxt_elem (Other t) = t
      | mk_ctxt_elem (Hn (R,a,c)) = @{mk_term "hn_ctxt ?R ?a ?c"}

    fun match x (Hn (_,y,_)) = x aconv y
      | match _ _ = false

    fun dest_with_frame (*ctxt*) _ t = let
      val (P,c,Q,R,a) = dest_hn_refine t

      val (_,(_,args)) = dest_hnr_absfun a
      val pre_ctes = strip_star P |> map dest_ctxt_elem

      val (pre_args,frame) =
        (case split_matching match args pre_ctes of
            NONE => raise TERM("align_conv: Could not match all arguments",[P,a])
          | SOME x => x)

    in
      ((frame,pre_args),c,Q,R,a)
    end

    fun align_goal_conv_aux ctxt t = let
      val ((frame,pre_args),c,Q,R,a) = dest_with_frame ctxt t
      val P' = apply2 (list_star o map mk_ctxt_elem) (frame,pre_args) |> mk_star
      val t' = mk_hn_refine (P',c,Q,R,a)
    in t' end

    fun align_rl_conv_aux ctxt t = let
      val ((frame,pre_args),c,Q,R,a) = dest_with_frame ctxt t

      val _ = frame = [] orelse raise TERM ("align_rl_conv: Extra preconditions in rule",[t,list_star (map mk_ctxt_elem frame)])

      val P' = list_star (map mk_ctxt_elem pre_args)
      val t' = mk_hn_refine (P',c,Q,R,a)
    in t' end

    fun normrel_conv ctxt = let
      val ss = put_simpset HOL_basic_ss ctxt addsimps normrel_eqs.get ctxt
    in
      Simplifier.rewrite ss
    end

  in
    fun align_goal_conv ctxt = f_tac_conv ctxt (align_goal_conv_aux ctxt) (star_permute_tac ctxt)

    fun norm_goal_pre_conv ctxt = let
      open Conv
      val nr_conv = normrel_conv ctxt
    in
      HOL_concl_conv (fn _ => hn_refine_conv nr_conv all_conv all_conv all_conv all_conv) ctxt
    end

    fun norm_goal_pre_tac ctxt = CONVERSION (norm_goal_pre_conv ctxt)

    fun align_rl_conv ctxt = let
      open Conv
      val nr_conv = normrel_conv ctxt
    in
      HOL_concl_conv (fn ctxt => f_tac_conv ctxt (align_rl_conv_aux ctxt) (star_permute_tac ctxt)) ctxt
      then_conv HOL_concl_conv (K (hn_refine_conv nr_conv all_conv nr_conv nr_conv all_conv)) ctxt
    end

    fun align_goal_tac ctxt =
      CONCL_COND' is_hn_refine_concl
      THEN' DCONVERSION ctxt (HOL_concl_conv align_goal_conv ctxt)
  end

  fun weaken_post_tac ctxt = TRADE (fn ctxt =>
    resolve_tac ctxt @{thms weaken_hnr_postI}
    THEN' SOLVED' (REPEAT_ALL_NEW (DETERM o resolve_tac ctxt @{thms weaken_hnr_post weaken_hnr_post_triv}))
  ) ctxt

end
\<close>

setup Sepref_Frame.setup

method_setup weaken_hnr_post = \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Sepref_Frame.weaken_post_tac ctxt))\<close>
  \<open>Convert "hn_invalid" to "hn_ctxt (\<lambda>_ _. true)" in postcondition of hn_refine goal\<close>

(* TODO: Improper, modifies all h\<Turnstile>_ premises that happen to be there. Use tagging to protect! *)
method extract_hnr_invalids = (
  rule hn_refine_preI,
  ((drule mod_starD hn_invalidI | elim conjE exE)+)?
) \<comment> \<open>Extract \<open>hn_invalid _ _ _ = true\<close> preconditions from \<open>hn_refine\<close> goal.\<close>

lemmas [sepref_frame_normrel_eqs] = the_pure_pure pure_the_pure

end