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

section{*The SET Cardholder Registration Protocol*}

theory Cardholder_Registration
imports Public_SET
begin

text{*Note: nonces seem to consist of 20 bytes.  That includes both freshness
challenges (Chall-EE, etc.) and important secrets (CardSecret, PANsecret)
*}

text{*Simplifications involving @{text analz_image_keys_simps} appear to
have become much slower. The cause is unclear. However, there is a big blow-up
and the rewriting is very sensitive to the set of rewrite rules given.*}

subsection{*Predicate Formalizing the Encryption Association between Keys *}

primrec KeyCryptKey :: "[key, key, event list] => bool"
where
  KeyCryptKey_Nil:
    "KeyCryptKey DK K [] = False"
| KeyCryptKey_Cons:
      --{*Says is the only important case.
        1st case: CR5, where KC3 encrypts KC2.
        2nd case: any use of priEK C.
        Revision 1.12 has a more complicated version with separate treatment of
          the dependency of KC1, KC2 and KC3 on priEK (CA i.)  Not needed since
          priEK C is never sent (and so can't be lost except at the start). *}
    "KeyCryptKey DK K (ev # evs) =
     (KeyCryptKey DK K evs |
      (case ev of
        Says A B Z =>
         ((\<exists>N X Y. A \<noteq> Spy &
                 DK \<in> symKeys &
                 Z = {|Crypt DK {|Agent A, Nonce N, Key K, X|}, Y|}) |
          (\<exists>C. DK = priEK C))
      | Gets A' X => False
      | Notes A' X => False))"

subsection{*Predicate formalizing the association between keys and nonces *}

primrec KeyCryptNonce :: "[key, key, event list] => bool"
where
  KeyCryptNonce_Nil:
    "KeyCryptNonce EK K [] = False"
| KeyCryptNonce_Cons:
  --{*Says is the only important case.
    1st case: CR3, where KC1 encrypts NC2 (distinct from CR5 due to EXH);
    2nd case: CR5, where KC3 encrypts NC3;
    3rd case: CR6, where KC2 encrypts NC3;
    4th case: CR6, where KC2 encrypts NonceCCA;
    5th case: any use of @{term "priEK C"} (including CardSecret).
    NB the only Nonces we need to keep secret are CardSecret and NonceCCA.
    But we can't prove @{text Nonce_compromise} unless the relation covers ALL
        nonces that the protocol keeps secret.
  *}
  "KeyCryptNonce DK N (ev # evs) =
   (KeyCryptNonce DK N evs |
    (case ev of
      Says A B Z =>
       A \<noteq> Spy &
       ((\<exists>X Y. DK \<in> symKeys &
               Z = (EXHcrypt DK X {|Agent A, Nonce N|} Y)) |
        (\<exists>X Y. DK \<in> symKeys &
               Z = {|Crypt DK {|Agent A, Nonce N, X|}, Y|}) |
        (\<exists>K i X Y.
          K \<in> symKeys &
          Z = Crypt K {|sign (priSK (CA i)) {|Agent B, Nonce N, X|}, Y|} &
          (DK=K | KeyCryptKey DK K evs)) |
        (\<exists>K C NC3 Y.
          K \<in> symKeys &
          Z = Crypt K
                {|sign (priSK C) {|Agent B, Nonce NC3, Agent C, Nonce N|},
                  Y|} &
          (DK=K | KeyCryptKey DK K evs)) |
        (\<exists>C. DK = priEK C))
    | Gets A' X => False
    | Notes A' X => False))"

subsection{*Formal protocol definition *}

inductive_set
  set_cr :: "event list set"
where

  Nil:    --{*Initial trace is empty*}
          "[] \<in> set_cr"

| Fake:    --{*The spy MAY say anything he CAN say.*}
           "[| evsf \<in> set_cr; X \<in> synth (analz (knows Spy evsf)) |]
            ==> Says Spy B X  # evsf \<in> set_cr"

| Reception: --{*If A sends a message X to B, then B might receive it*}
             "[| evsr \<in> set_cr; Says A B X \<in> set evsr |]
              ==> Gets B X  # evsr \<in> set_cr"

| SET_CR1: --{*CardCInitReq: C initiates a run, sending a nonce to CCA*}
             "[| evs1 \<in> set_cr;  C = Cardholder k;  Nonce NC1 \<notin> used evs1 |]
              ==> Says C (CA i) {|Agent C, Nonce NC1|} # evs1 \<in> set_cr"

| SET_CR2: --{*CardCInitRes: CA responds sending NC1 and its certificates*}
             "[| evs2 \<in> set_cr;
                 Gets (CA i) {|Agent C, Nonce NC1|} \<in> set evs2 |]
              ==> Says (CA i) C
                       {|sign (priSK (CA i)) {|Agent C, Nonce NC1|},
                         cert (CA i) (pubEK (CA i)) onlyEnc (priSK RCA),
                         cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|}
                    # evs2 \<in> set_cr"

| SET_CR3:
   --{*RegFormReq: C sends his PAN and a new nonce to CA.
   C verifies that
    - nonce received is the same as that sent;
    - certificates are signed by RCA;
    - certificates are an encryption certificate (flag is onlyEnc) and a
      signature certificate (flag is onlySig);
    - certificates pertain to the CA that C contacted (this is done by
      checking the signature).
   C generates a fresh symmetric key KC1.
   The point of encrypting @{term "{|Agent C, Nonce NC2, Hash (Pan(pan C))|}"}
   is not clear. *}
"[| evs3 \<in> set_cr;  C = Cardholder k;
    Nonce NC2 \<notin> used evs3;
    Key KC1 \<notin> used evs3; KC1 \<in> symKeys;
    Gets C {|sign (invKey SKi) {|Agent X, Nonce NC1|},
             cert (CA i) EKi onlyEnc (priSK RCA),
             cert (CA i) SKi onlySig (priSK RCA)|}
       \<in> set evs3;
    Says C (CA i) {|Agent C, Nonce NC1|} \<in> set evs3|]
 ==> Says C (CA i) (EXHcrypt KC1 EKi {|Agent C, Nonce NC2|} (Pan(pan C)))
       # Notes C {|Key KC1, Agent (CA i)|}
       # evs3 \<in> set_cr"

| SET_CR4:
    --{*RegFormRes:
    CA responds sending NC2 back with a new nonce NCA, after checking that
     - the digital envelope is correctly encrypted by @{term "pubEK (CA i)"}
     - the entire message is encrypted with the same key found inside the
       envelope (here, KC1) *}
"[| evs4 \<in> set_cr;
    Nonce NCA \<notin> used evs4;  KC1 \<in> symKeys;
    Gets (CA i) (EXHcrypt KC1 EKi {|Agent C, Nonce NC2|} (Pan(pan X)))
       \<in> set evs4 |]
  ==> Says (CA i) C
          {|sign (priSK (CA i)) {|Agent C, Nonce NC2, Nonce NCA|},
            cert (CA i) (pubEK (CA i)) onlyEnc (priSK RCA),
            cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|}
       # evs4 \<in> set_cr"

| SET_CR5:
   --{*CertReq: C sends his PAN, a new nonce, its proposed public signature key
       and its half of the secret value to CA.
       We now assume that C has a fixed key pair, and he submits (pubSK C).
       The protocol does not require this key to be fresh.
       The encryption below is actually EncX.*}
"[| evs5 \<in> set_cr;  C = Cardholder k;
    Nonce NC3 \<notin> used evs5;  Nonce CardSecret \<notin> used evs5; NC3\<noteq>CardSecret;
    Key KC2 \<notin> used evs5; KC2 \<in> symKeys;
    Key KC3 \<notin> used evs5; KC3 \<in> symKeys; KC2\<noteq>KC3;
    Gets C {|sign (invKey SKi) {|Agent C, Nonce NC2, Nonce NCA|},
             cert (CA i) EKi onlyEnc (priSK RCA),
             cert (CA i) SKi onlySig (priSK RCA) |}
        \<in> set evs5;
    Says C (CA i) (EXHcrypt KC1 EKi {|Agent C, Nonce NC2|} (Pan(pan C)))
         \<in> set evs5 |]
==> Says C (CA i)
         {|Crypt KC3
             {|Agent C, Nonce NC3, Key KC2, Key (pubSK C),
               Crypt (priSK C)
                 (Hash {|Agent C, Nonce NC3, Key KC2,
                         Key (pubSK C), Pan (pan C), Nonce CardSecret|})|},
           Crypt EKi {|Key KC3, Pan (pan C), Nonce CardSecret|} |}
    # Notes C {|Key KC2, Agent (CA i)|}
    # Notes C {|Key KC3, Agent (CA i)|}
    # evs5 \<in> set_cr"

  --{* CertRes: CA responds sending NC3 back with its half of the secret value,
   its signature certificate and the new cardholder signature
   certificate.  CA checks to have never certified the key proposed by C.
   NOTE: In Merchant Registration, the corresponding rule (4)
   uses the "sign" primitive. The encryption below is actually @{term EncK},
   which is just @{term "Crypt K (sign SK X)"}.
*}

| SET_CR6:
"[| evs6 \<in> set_cr;
    Nonce NonceCCA \<notin> used evs6;
    KC2 \<in> symKeys;  KC3 \<in> symKeys;  cardSK \<notin> symKeys;
    Notes (CA i) (Key cardSK) \<notin> set evs6;
    Gets (CA i)
      {|Crypt KC3 {|Agent C, Nonce NC3, Key KC2, Key cardSK,
                    Crypt (invKey cardSK)
                      (Hash {|Agent C, Nonce NC3, Key KC2,
                              Key cardSK, Pan (pan C), Nonce CardSecret|})|},
        Crypt (pubEK (CA i)) {|Key KC3, Pan (pan C), Nonce CardSecret|} |}
      \<in> set evs6 |]
==> Says (CA i) C
         (Crypt KC2
          {|sign (priSK (CA i))
                 {|Agent C, Nonce NC3, Agent(CA i), Nonce NonceCCA|},
            certC (pan C) cardSK (XOR(CardSecret,NonceCCA)) onlySig (priSK (CA i)),
            cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|})
      # Notes (CA i) (Key cardSK)
      # evs6 \<in> set_cr"

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{*A "possibility property": there are traces that reach the end.
      An unconstrained proof with many subgoals.*}

lemma Says_to_Gets:
     "Says A B X # evs \<in> set_cr ==> Gets B X # Says A B X # evs \<in> set_cr"
by (rule set_cr.Reception, auto)

text{*The many nonces and keys generated, some simultaneously, force us to
  introduce them explicitly as shown below.*}
lemma possibility_CR6:
     "[|NC1 < (NC2::nat);  NC2 < NC3;  NC3 < NCA ;
        NCA < NonceCCA;  NonceCCA < CardSecret;
        KC1 < (KC2::key);  KC2 < KC3;
        KC1 \<in> symKeys;  Key KC1 \<notin> used [];
        KC2 \<in> symKeys;  Key KC2 \<notin> used [];
        KC3 \<in> symKeys;  Key KC3 \<notin> used [];
        C = Cardholder k|]
   ==> \<exists>evs \<in> set_cr.
       Says (CA i) C
            (Crypt KC2
             {|sign (priSK (CA i))
                    {|Agent C, Nonce NC3, Agent(CA i), Nonce NonceCCA|},
               certC (pan C) (pubSK (Cardholder k)) (XOR(CardSecret,NonceCCA))
                     onlySig (priSK (CA i)),
               cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|})
          \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2]
       set_cr.Nil
        [THEN set_cr.SET_CR1 [of concl: C i NC1],
         THEN Says_to_Gets,
         THEN set_cr.SET_CR2 [of concl: i C NC1],
         THEN Says_to_Gets,
         THEN set_cr.SET_CR3 [of concl: C i KC1 _ NC2],
         THEN Says_to_Gets,
         THEN set_cr.SET_CR4 [of concl: i C NC2 NCA],
         THEN Says_to_Gets,
         THEN set_cr.SET_CR5 [of concl: C i KC3 NC3 KC2 CardSecret],
         THEN Says_to_Gets,
         THEN set_cr.SET_CR6 [of concl: i C KC2]])
apply basic_possibility
apply (simp_all (no_asm_simp) add: symKeys_neq_imp_neq)
done

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

lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> set_cr |]  ==> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)
declare Gets_imp_knows_Spy [THEN parts.Inj, dest]

subsection{*Proofs on keys *}

text{*Spy never sees an agent's private keys! (unless it's bad at start)*}

lemma Spy_see_private_Key [simp]:
     "evs \<in> set_cr
      ==> (Key(invKey (publicKey b A)) \<in> parts(knows Spy evs)) = (A \<in> bad)"
by (erule set_cr.induct, auto)

lemma Spy_analz_private_Key [simp]:
     "evs \<in> set_cr ==>
     (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!]

subsection{*Begin Piero's Theorems on Certificates*}
text{*Trivial in the current model, where certificates by RCA are secure *}

lemma Crypt_valid_pubEK:
     "[| Crypt (priSK RCA) {|Agent C, Key EKi, onlyEnc|}
           \<in> parts (knows Spy evs);
         evs \<in> set_cr |] ==> EKi = pubEK C"
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done

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

lemma Crypt_valid_pubSK:
     "[| Crypt (priSK RCA) {|Agent C, Key SKi, onlySig|}
           \<in> parts (knows Spy evs);
         evs \<in> set_cr |] ==> SKi = pubSK C"
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done

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

lemma Gets_certificate_valid:
     "[| Gets A {| X, cert C EKi onlyEnc (priSK RCA),
                      cert C SKi onlySig (priSK RCA)|} \<in> set evs;
         evs \<in> set_cr |]
      ==> EKi = pubEK C & SKi = pubSK C"
by (blast dest: certificate_valid_pubEK certificate_valid_pubSK)

text{*Nobody can have used non-existent keys!*}
lemma new_keys_not_used:
     "[|K \<in> symKeys; Key K \<notin> used evs; evs \<in> set_cr|]
      ==> K \<notin> keysFor (parts (knows Spy evs))"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (frule_tac [8] Gets_certificate_valid)
apply (frule_tac [6] Gets_certificate_valid, simp_all)
apply (force dest!: usedI keysFor_parts_insert) --{*Fake*}
apply (blast,auto)  --{*Others*}
done

subsection{*New versions: as above, but generalized to have the KK argument *}

lemma gen_new_keys_not_used:
     "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> set_cr |]
      ==> Key K \<notin> used evs --> K \<in> symKeys -->
          K \<notin> keysFor (parts (Key`KK Un knows Spy evs))"
by (auto simp add: new_keys_not_used)

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

lemma analz_Key_image_insert_eq:
     "[|K \<in> symKeys; Key K \<notin> used evs; evs \<in> set_cr |]
      ==> 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_cr |] ==> 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_cr |] ==> Key K \<in> used evs"
by (blast intro: Crypt_parts_imp_used)

(*<*)
subsection{*Messages signed by CA*}

text{*Message @{text SET_CR2}: C can check CA's signature if he has received
     CA's certificate.*}
lemma CA_Says_2_lemma:
     "[| Crypt (priSK (CA i)) (Hash{|Agent C, Nonce NC1|})
           \<in> parts (knows Spy evs);
         evs \<in> set_cr; (CA i) \<notin> bad |]
     ==> \<exists>Y. Says (CA i) C {|sign (priSK (CA i)) {|Agent C, Nonce NC1|}, Y|}
                 \<in> set evs"
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done

text{*Ever used?*}
lemma CA_Says_2:
     "[| Crypt (invKey SK) (Hash{|Agent C, Nonce NC1|})
           \<in> parts (knows Spy evs);
         cert (CA i) SK onlySig (priSK RCA) \<in> parts (knows Spy evs);
         evs \<in> set_cr; (CA i) \<notin> bad |]
      ==> \<exists>Y. Says (CA i) C {|sign (priSK (CA i)) {|Agent C, Nonce NC1|}, Y|}
                  \<in> set evs"
by (blast dest!: certificate_valid_pubSK intro!: CA_Says_2_lemma)

text{*Message @{text SET_CR4}: C can check CA's signature if he has received
      CA's certificate.*}
lemma CA_Says_4_lemma:
     "[| Crypt (priSK (CA i)) (Hash{|Agent C, Nonce NC2, Nonce NCA|})
           \<in> parts (knows Spy evs);
         evs \<in> set_cr; (CA i) \<notin> bad |]
      ==> \<exists>Y. Says (CA i) C {|sign (priSK (CA i))
                     {|Agent C, Nonce NC2, Nonce NCA|}, Y|} \<in> set evs"
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done

text{*NEVER USED*}
lemma CA_Says_4:
     "[| Crypt (invKey SK) (Hash{|Agent C, Nonce NC2, Nonce NCA|})
           \<in> parts (knows Spy evs);
         cert (CA i) SK onlySig (priSK RCA) \<in> parts (knows Spy evs);
         evs \<in> set_cr; (CA i) \<notin> bad |]
      ==> \<exists>Y. Says (CA i) C {|sign (priSK (CA i))
                   {|Agent C, Nonce NC2, Nonce NCA|}, Y|} \<in> set evs"
by (blast dest!: certificate_valid_pubSK intro!: CA_Says_4_lemma)

text{*Message @{text SET_CR6}: C can check CA's signature if he has
      received CA's certificate.*}
lemma CA_Says_6_lemma:
     "[| Crypt (priSK (CA i))
               (Hash{|Agent C, Nonce NC3, Agent (CA i), Nonce NonceCCA|})
           \<in> parts (knows Spy evs);
         evs \<in> set_cr; (CA i) \<notin> bad |]
      ==> \<exists>Y K. Says (CA i) C (Crypt K {|sign (priSK (CA i))
      {|Agent C, Nonce NC3, Agent (CA i), Nonce NonceCCA|}, Y|}) \<in> set evs"
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done

text{*NEVER USED*}
lemma CA_Says_6:
     "[| Crypt (invKey SK) (Hash{|Agent C, Nonce NC3, Agent (CA i), Nonce NonceCCA|})
           \<in> parts (knows Spy evs);
         cert (CA i) SK onlySig (priSK RCA) \<in> parts (knows Spy evs);
         evs \<in> set_cr; (CA i) \<notin> bad |]
      ==> \<exists>Y K. Says (CA i) C (Crypt K {|sign (priSK (CA i))
                    {|Agent C, Nonce NC3, Agent (CA i), Nonce NonceCCA|}, Y|}) \<in> set evs"
by (blast dest!: certificate_valid_pubSK intro!: CA_Says_6_lemma)
(*>*)

subsection{*Useful lemmas *}

text{*Rewriting rule for private encryption keys.  Analogous rewriting rules
for other keys aren't needed.*}

lemma parts_image_priEK:
     "[|Key (priEK C) \<in> parts (Key`KK Un (knows Spy evs));
        evs \<in> set_cr|] ==> priEK C \<in> KK | C \<in> bad"
by auto

text{*trivial proof because (priEK C) never appears even in (parts evs)*}
lemma analz_image_priEK:
     "evs \<in> set_cr ==>
          (Key (priEK C) \<in> analz (Key`KK Un (knows Spy evs))) =
          (priEK C \<in> KK | C \<in> bad)"
by (blast dest!: parts_image_priEK intro: analz_mono [THEN [2] rev_subsetD])

subsection{*Secrecy of Session Keys *}

subsubsection{*Lemmas about the predicate KeyCryptKey *}

text{*A fresh DK cannot be associated with any other
  (with respect to a given trace). *}
lemma DK_fresh_not_KeyCryptKey:
     "[| Key DK \<notin> used evs; evs \<in> set_cr |] ==> ~ KeyCryptKey DK K evs"
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (simp_all (no_asm_simp))
apply (blast dest: Crypt_analz_imp_used)+
done

text{*A fresh K cannot be associated with any other.  The assumption that
  DK isn't a private encryption key may be an artifact of the particular
  definition of KeyCryptKey.*}
lemma K_fresh_not_KeyCryptKey:
     "[|\<forall>C. DK \<noteq> priEK C; Key K \<notin> used evs|] ==> ~ KeyCryptKey DK K evs"
apply (induct evs)
apply (auto simp add: parts_insert2 split add: event.split)
done

text{*This holds because if (priEK (CA i)) appears in any traffic then it must
  be known to the Spy, by @{term Spy_see_private_Key}*}
lemma cardSK_neq_priEK:
     "[|Key cardSK \<notin> analz (knows Spy evs);
        Key cardSK : parts (knows Spy evs);
        evs \<in> set_cr|] ==> cardSK \<noteq> priEK C"
by blast

lemma not_KeyCryptKey_cardSK [rule_format (no_asm)]:
     "[|cardSK \<notin> symKeys;  \<forall>C. cardSK \<noteq> priEK C;  evs \<in> set_cr|] ==>
      Key cardSK \<notin> analz (knows Spy evs) --> ~ KeyCryptKey cardSK K evs"
by (erule set_cr.induct, analz_mono_contra, auto)

text{*Lemma for message 5: pubSK C is never used to encrypt Keys.*}
lemma pubSK_not_KeyCryptKey [simp]: "~ KeyCryptKey (pubSK C) K evs"
apply (induct_tac "evs")
apply (auto simp add: parts_insert2 split add: event.split)
done

text{*Lemma for message 6: either cardSK is compromised (when we don't care)
  or else cardSK hasn't been used to encrypt K.  Previously we treated
  message 5 in the same way, but the current model assumes that rule
  @{text SET_CR5} is executed only by honest agents.*}
lemma msg6_KeyCryptKey_disj:
     "[|Gets B {|Crypt KC3 {|Agent C, Nonce N, Key KC2, Key cardSK, X|}, Y|}
          \<in> set evs;
        cardSK \<notin> symKeys;  evs \<in> set_cr|]
      ==> Key cardSK \<in> analz (knows Spy evs) |
          (\<forall>K. ~ KeyCryptKey cardSK K evs)"
by (blast dest: not_KeyCryptKey_cardSK intro: cardSK_neq_priEK)

text{*As usual: we express the property as a logical equivalence*}
lemma Key_analz_image_Key_lemma:
     "P --> (Key K \<in> analz (Key`KK Un H)) --> (K \<in> KK | Key K \<in> analz H)
      ==>
      P --> (Key K \<in> analz (Key`KK Un H)) = (K \<in> KK | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

method_setup valid_certificate_tac = {*
  Args.goal_spec >> (fn quant => fn ctxt => SIMPLE_METHOD'' quant
    (fn i =>
      EVERY [ftac @{thm Gets_certificate_valid} i,
             assume_tac ctxt i,
             etac conjE i, REPEAT (hyp_subst_tac ctxt i)]))
*}

text{*The @{text "(no_asm)"} attribute is essential, since it retains
  the quantifier and allows the simprule's condition to itself be simplified.*}
lemma symKey_compromise [rule_format (no_asm)]:
     "evs \<in> set_cr ==>
      (\<forall>SK KK. SK \<in> symKeys \<longrightarrow> (\<forall>K \<in> KK. ~ KeyCryptKey K SK evs)   -->
               (Key SK \<in> analz (Key`KK Un (knows Spy evs))) =
               (SK \<in> KK | Key SK \<in> analz (knows Spy evs)))"
apply (erule set_cr.induct)
apply (rule_tac [!] allI) +
apply (rule_tac [!] impI [THEN Key_analz_image_Key_lemma, THEN impI])+
apply (valid_certificate_tac [8]) --{*for message 5*}
apply (valid_certificate_tac [6]) --{*for message 5*}
apply (erule_tac [9] msg6_KeyCryptKey_disj [THEN disjE])
apply (simp_all
         del: image_insert image_Un imp_disjL
         add: analz_image_keys_simps analz_knows_absorb
              analz_Key_image_insert_eq notin_image_iff
              K_fresh_not_KeyCryptKey
              DK_fresh_not_KeyCryptKey ball_conj_distrib
              analz_image_priEK disj_simps)
  --{*9 seconds on a 1.6GHz machine*}
apply spy_analz
apply blast  --{*3*}
apply blast  --{*5*}
done

text{*The remaining quantifiers seem to be essential.
  NO NEED to assume the cardholder's OK: bad cardholders don't do anything
  wrong!!*}
lemma symKey_secrecy [rule_format]:
     "[|CA i \<notin> bad;  K \<in> symKeys;  evs \<in> set_cr|]
      ==> \<forall>X c. Says (Cardholder c) (CA i) X \<in> set evs -->
                Key K \<in> parts{X} -->
                Cardholder c \<notin> bad -->
                Key K \<notin> analz (knows Spy evs)"
apply (erule set_cr.induct)
apply (frule_tac [8] Gets_certificate_valid) --{*for message 5*}
apply (frule_tac [6] Gets_certificate_valid) --{*for message 3*}
apply (erule_tac [11] msg6_KeyCryptKey_disj [THEN disjE])
apply (simp_all del: image_insert image_Un imp_disjL
         add: symKey_compromise fresh_notin_analz_knows_Spy
              analz_image_keys_simps analz_knows_absorb
              analz_Key_image_insert_eq notin_image_iff
              K_fresh_not_KeyCryptKey
              DK_fresh_not_KeyCryptKey
              analz_image_priEK)
  --{*2.5 seconds on a 1.6GHz machine*}
apply spy_analz  --{*Fake*}
apply (auto intro: analz_into_parts [THEN usedI] in_parts_Says_imp_used)
done

subsection{*Primary Goals of Cardholder Registration *}

text{*The cardholder's certificate really was created by the CA, provided the
    CA is uncompromised *}

text{*Lemma concerning the actual signed message digest*}
lemma cert_valid_lemma:
     "[|Crypt (priSK (CA i)) {|Hash {|Nonce N, Pan(pan C)|}, Key cardSK, N1|}
          \<in> parts (knows Spy evs);
        CA i \<notin> bad; evs \<in> set_cr|]
  ==> \<exists>KC2 X Y. Says (CA i) C
                     (Crypt KC2
                       {|X, certC (pan C) cardSK N onlySig (priSK (CA i)), Y|})
                  \<in> set evs"
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (simp_all (no_asm_simp))
apply auto
done

text{*Pre-packaged version for cardholder.  We don't try to confirm the values
  of KC2, X and Y, since they are not important.*}
lemma certificate_valid_cardSK:
    "[|Gets C (Crypt KC2 {|X, certC (pan C) cardSK N onlySig (invKey SKi),
                              cert (CA i) SKi onlySig (priSK RCA)|}) \<in> set evs;
        CA i \<notin> bad; evs \<in> set_cr|]
  ==> \<exists>KC2 X Y. Says (CA i) C
                     (Crypt KC2
                       {|X, certC (pan C) cardSK N onlySig (priSK (CA i)), Y|})
                   \<in> set evs"
by (force dest!: Gets_imp_knows_Spy [THEN parts.Inj, THEN parts.Body]
                    certificate_valid_pubSK cert_valid_lemma)

lemma Hash_imp_parts [rule_format]:
     "evs \<in> set_cr
      ==> Hash{|X, Nonce N|} \<in> parts (knows Spy evs) -->
          Nonce N \<in> parts (knows Spy evs)"
apply (erule set_cr.induct, force)
apply (simp_all (no_asm_simp))
apply (blast intro: parts_mono [THEN [2] rev_subsetD])
done

lemma Hash_imp_parts2 [rule_format]:
     "evs \<in> set_cr
      ==> Hash{|X, Nonce M, Y, Nonce N|} \<in> parts (knows Spy evs) -->
          Nonce M \<in> parts (knows Spy evs) & Nonce N \<in> parts (knows Spy evs)"
apply (erule set_cr.induct, force)
apply (simp_all (no_asm_simp))
apply (blast intro: parts_mono [THEN [2] rev_subsetD])
done

subsection{*Secrecy of Nonces*}

subsubsection{*Lemmas about the predicate KeyCryptNonce *}

text{*A fresh DK cannot be associated with any other
  (with respect to a given trace). *}
lemma DK_fresh_not_KeyCryptNonce:
     "[| DK \<in> symKeys; Key DK \<notin> used evs; evs \<in> set_cr |]
      ==> ~ KeyCryptNonce DK K evs"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (simp_all (no_asm_simp))
apply blast
apply blast
apply (auto simp add: DK_fresh_not_KeyCryptKey)
done

text{*A fresh N cannot be associated with any other
      (with respect to a given trace). *}
lemma N_fresh_not_KeyCryptNonce:
     "\<forall>C. DK \<noteq> priEK C ==> Nonce N \<notin> used evs --> ~ KeyCryptNonce DK N evs"
apply (induct_tac "evs")
apply (rename_tac [2] a evs')
apply (case_tac [2] "a")
apply (auto simp add: parts_insert2)
done

lemma not_KeyCryptNonce_cardSK [rule_format (no_asm)]:
     "[|cardSK \<notin> symKeys;  \<forall>C. cardSK \<noteq> priEK C;  evs \<in> set_cr|] ==>
      Key cardSK \<notin> analz (knows Spy evs) --> ~ KeyCryptNonce cardSK N evs"
apply (erule set_cr.induct, analz_mono_contra, simp_all)
apply (blast dest: not_KeyCryptKey_cardSK)  --{*6*}
done

subsubsection{*Lemmas for message 5 and 6:
  either cardSK is compromised (when we don't care)
  or else cardSK hasn't been used to encrypt K. *}

text{*Lemma for message 5: pubSK C is never used to encrypt Nonces.*}
lemma pubSK_not_KeyCryptNonce [simp]: "~ KeyCryptNonce (pubSK C) N evs"
apply (induct_tac "evs")
apply (auto simp add: parts_insert2 split add: event.split)
done

text{*Lemma for message 6: either cardSK is compromised (when we don't care)
  or else cardSK hasn't been used to encrypt K.*}
lemma msg6_KeyCryptNonce_disj:
     "[|Gets B {|Crypt KC3 {|Agent C, Nonce N, Key KC2, Key cardSK, X|}, Y|}
          \<in> set evs;
        cardSK \<notin> symKeys;  evs \<in> set_cr|]
      ==> Key cardSK \<in> analz (knows Spy evs) |
          ((\<forall>K. ~ KeyCryptKey cardSK K evs) &
           (\<forall>N. ~ KeyCryptNonce cardSK N evs))"
by (blast dest: not_KeyCryptKey_cardSK not_KeyCryptNonce_cardSK
          intro: cardSK_neq_priEK)

text{*As usual: we express the property as a logical equivalence*}
lemma Nonce_analz_image_Key_lemma:
     "P --> (Nonce N \<in> analz (Key`KK Un H)) --> (Nonce N \<in> analz H)
      ==> P --> (Nonce N \<in> analz (Key`KK Un H)) = (Nonce N \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

text{*The @{text "(no_asm)"} attribute is essential, since it retains
  the quantifier and allows the simprule's condition to itself be simplified.*}
lemma Nonce_compromise [rule_format (no_asm)]:
     "evs \<in> set_cr ==>
      (\<forall>N KK. (\<forall>K \<in> KK. ~ KeyCryptNonce K N evs)   -->
               (Nonce N \<in> analz (Key`KK Un (knows Spy evs))) =
               (Nonce N \<in> analz (knows Spy evs)))"
apply (erule set_cr.induct)
apply (rule_tac [!] allI)+
apply (rule_tac [!] impI [THEN Nonce_analz_image_Key_lemma])+
apply (frule_tac [8] Gets_certificate_valid) --{*for message 5*}
apply (frule_tac [6] Gets_certificate_valid) --{*for message 3*}
apply (frule_tac [11] msg6_KeyCryptNonce_disj)
apply (erule_tac [13] disjE)
apply (simp_all del: image_insert image_Un
         add: symKey_compromise
              analz_image_keys_simps analz_knows_absorb
              analz_Key_image_insert_eq notin_image_iff
              N_fresh_not_KeyCryptNonce
              DK_fresh_not_KeyCryptNonce K_fresh_not_KeyCryptKey
              ball_conj_distrib analz_image_priEK)
  --{*14 seconds on a 1.6GHz machine*}
apply spy_analz  --{*Fake*}
apply blast  --{*3*}
apply blast  --{*5*}
txt{*Message 6*}
apply (metis symKey_compromise)
  --{*cardSK compromised*}
txt{*Simplify again--necessary because the previous simplification introduces
  some logical connectives*}
apply (force simp del: image_insert image_Un imp_disjL
          simp add: analz_image_keys_simps symKey_compromise)
done

subsection{*Secrecy of CardSecret: the Cardholder's secret*}

lemma NC2_not_CardSecret:
     "[|Crypt EKj {|Key K, Pan p, Hash {|Agent D, Nonce N|}|}
          \<in> parts (knows Spy evs);
        Key K \<notin> analz (knows Spy evs);
        Nonce N \<notin> analz (knows Spy evs);
       evs \<in> set_cr|]
      ==> Crypt EKi {|Key K', Pan p', Nonce N|} \<notin> parts (knows Spy evs)"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct, analz_mono_contra, simp_all)
apply (blast dest: Hash_imp_parts)+
done

lemma KC2_secure_lemma [rule_format]:
     "[|U = Crypt KC3 {|Agent C, Nonce N, Key KC2, X|};
        U \<in> parts (knows Spy evs);
        evs \<in> set_cr|]
  ==> Nonce N \<notin> analz (knows Spy evs) -->
      (\<exists>k i W. Says (Cardholder k) (CA i) {|U,W|} \<in> set evs &
               Cardholder k \<notin> bad & CA i \<notin> bad)"
apply (erule_tac P = "U \<in> ?H" in rev_mp)
apply (erule set_cr.induct)
apply (valid_certificate_tac [8])  --{*for message 5*}
apply (simp_all del: image_insert image_Un imp_disjL
         add: analz_image_keys_simps analz_knows_absorb
              analz_knows_absorb2 notin_image_iff)
  --{*4 seconds on a 1.6GHz machine*}
apply (simp_all (no_asm_simp)) --{*leaves 4 subgoals*}
apply (blast intro!: analz_insertI)+
done

lemma KC2_secrecy:
     "[|Gets B {|Crypt K {|Agent C, Nonce N, Key KC2, X|}, Y|} \<in> set evs;
        Nonce N \<notin> analz (knows Spy evs);  KC2 \<in> symKeys;
        evs \<in> set_cr|]
       ==> Key KC2 \<notin> analz (knows Spy evs)"
by (force dest!: refl [THEN KC2_secure_lemma] symKey_secrecy)

text{*Inductive version*}
lemma CardSecret_secrecy_lemma [rule_format]:
     "[|CA i \<notin> bad;  evs \<in> set_cr|]
      ==> Key K \<notin> analz (knows Spy evs) -->
          Crypt (pubEK (CA i)) {|Key K, Pan p, Nonce CardSecret|}
             \<in> parts (knows Spy evs) -->
          Nonce CardSecret \<notin> analz (knows Spy evs)"
apply (erule set_cr.induct, analz_mono_contra)
apply (valid_certificate_tac [8]) --{*for message 5*}
apply (valid_certificate_tac [6]) --{*for message 5*}
apply (frule_tac [9] msg6_KeyCryptNonce_disj [THEN disjE])
apply (simp_all
         del: image_insert image_Un imp_disjL
         add: analz_image_keys_simps analz_knows_absorb
              analz_Key_image_insert_eq notin_image_iff
              EXHcrypt_def Crypt_notin_image_Key
              N_fresh_not_KeyCryptNonce DK_fresh_not_KeyCryptNonce
              ball_conj_distrib Nonce_compromise symKey_compromise
              analz_image_priEK)
  --{*2.5 seconds on a 1.6GHz machine*}
apply spy_analz  --{*Fake*}
apply (simp_all (no_asm_simp))
apply blast  --{*1*}
apply (blast dest!: Gets_imp_knows_Spy [THEN analz.Inj])  --{*2*}
apply blast  --{*3*}
apply (blast dest: NC2_not_CardSecret Gets_imp_knows_Spy [THEN analz.Inj] analz_symKeys_Decrypt)  --{*4*}
apply blast  --{*5*}
apply (blast dest: KC2_secrecy)+  --{*Message 6: two cases*}
done

text{*Packaged version for cardholder*}
lemma CardSecret_secrecy:
     "[|Cardholder k \<notin> bad;  CA i \<notin> bad;
        Says (Cardholder k) (CA i)
           {|X, Crypt EKi {|Key KC3, Pan p, Nonce CardSecret|}|} \<in> set evs;
        Gets A {|Z, cert (CA i) EKi onlyEnc (priSK RCA),
                    cert (CA i) SKi onlySig (priSK RCA)|} \<in> set evs;
        KC3 \<in> symKeys;  evs \<in> set_cr|]
      ==> Nonce CardSecret \<notin> analz (knows Spy evs)"
apply (frule Gets_certificate_valid, assumption)
apply (subgoal_tac "Key KC3 \<notin> analz (knows Spy evs) ")
apply (blast dest: CardSecret_secrecy_lemma)
apply (rule symKey_secrecy)
apply (auto simp add: parts_insert2)
done

subsection{*Secrecy of NonceCCA [the CA's secret] *}

lemma NC2_not_NonceCCA:
     "[|Hash {|Agent C', Nonce N', Agent C, Nonce N|}
          \<in> parts (knows Spy evs);
        Nonce N \<notin> analz (knows Spy evs);
       evs \<in> set_cr|]
      ==> Crypt KC1 {|{|Agent B, Nonce N|}, Hash p|} \<notin> parts (knows Spy evs)"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct, analz_mono_contra, simp_all)
apply (blast dest: Hash_imp_parts2)+
done

text{*Inductive version*}
lemma NonceCCA_secrecy_lemma [rule_format]:
     "[|CA i \<notin> bad;  evs \<in> set_cr|]
      ==> Key K \<notin> analz (knows Spy evs) -->
          Crypt K
            {|sign (priSK (CA i))
                   {|Agent C, Nonce N, Agent(CA i), Nonce NonceCCA|},
              X, Y|}
             \<in> parts (knows Spy evs) -->
          Nonce NonceCCA \<notin> analz (knows Spy evs)"
apply (erule set_cr.induct, analz_mono_contra)
apply (valid_certificate_tac [8]) --{*for message 5*}
apply (valid_certificate_tac [6]) --{*for message 5*}
apply (frule_tac [9] msg6_KeyCryptNonce_disj [THEN disjE])
apply (simp_all
         del: image_insert image_Un imp_disjL
         add: analz_image_keys_simps analz_knows_absorb sign_def
              analz_Key_image_insert_eq notin_image_iff
              EXHcrypt_def Crypt_notin_image_Key
              N_fresh_not_KeyCryptNonce DK_fresh_not_KeyCryptNonce
              ball_conj_distrib Nonce_compromise symKey_compromise
              analz_image_priEK)
  --{*3 seconds on a 1.6GHz machine*}
apply spy_analz  --{*Fake*}
apply blast  --{*1*}
apply (blast dest!: Gets_imp_knows_Spy [THEN analz.Inj])  --{*2*}
apply blast  --{*3*}
apply (blast dest: NC2_not_NonceCCA)  --{*4*}
apply blast  --{*5*}
apply (blast dest: KC2_secrecy)+  --{*Message 6: two cases*}
done

text{*Packaged version for cardholder*}
lemma NonceCCA_secrecy:
     "[|Cardholder k \<notin> bad;  CA i \<notin> bad;
        Gets (Cardholder k)
           (Crypt KC2
            {|sign (priSK (CA i)) {|Agent C, Nonce N, Agent(CA i), Nonce NonceCCA|},
              X, Y|}) \<in> set evs;
        Says (Cardholder k) (CA i)
           {|Crypt KC3 {|Agent C, Nonce NC3, Key KC2, X'|}, Y'|} \<in> set evs;
        Gets A {|Z, cert (CA i) EKi onlyEnc (priSK RCA),
                    cert (CA i) SKi onlySig (priSK RCA)|} \<in> set evs;
        KC2 \<in> symKeys;  evs \<in> set_cr|]
      ==> Nonce NonceCCA \<notin> analz (knows Spy evs)"
apply (frule Gets_certificate_valid, assumption)
apply (subgoal_tac "Key KC2 \<notin> analz (knows Spy evs) ")
apply (blast dest: NonceCCA_secrecy_lemma)
apply (rule symKey_secrecy)
apply (auto simp add: parts_insert2)
done

text{*We don't bother to prove guarantees for the CA.  He doesn't care about
  the PANSecret: it isn't his credit card!*}

subsection{*Rewriting Rule for PANs*}

text{*Lemma for message 6: either cardSK isn't a CA's private encryption key,
  or if it is then (because it appears in traffic) that CA is bad,
  and so the Spy knows that key already.  Either way, we can simplify
  the expression @{term "analz (insert (Key cardSK) X)"}.*}
lemma msg6_cardSK_disj:
     "[|Gets A {|Crypt K {|c, n, k', Key cardSK, X|}, Y|}
          \<in> set evs;  evs \<in> set_cr |]
      ==> cardSK \<notin> range(invKey o pubEK o CA) | Key cardSK \<in> knows Spy evs"
by auto

lemma analz_image_pan_lemma:
     "(Pan P \<in> analz (Key`nE Un H)) --> (Pan P \<in> analz H)  ==>
      (Pan P \<in> analz (Key`nE Un H)) =   (Pan P \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

lemma analz_image_pan [rule_format]:
     "evs \<in> set_cr ==>
       \<forall>KK. KK <= - invKey ` pubEK ` range CA -->
            (Pan P \<in> analz (Key`KK Un (knows Spy evs))) =
            (Pan P \<in> analz (knows Spy evs))"
apply (erule set_cr.induct)
apply (rule_tac [!] allI impI)+
apply (rule_tac [!] analz_image_pan_lemma)
apply (valid_certificate_tac [8]) --{*for message 5*}
apply (valid_certificate_tac [6]) --{*for message 5*}
apply (erule_tac [9] msg6_cardSK_disj [THEN disjE])
apply (simp_all
         del: image_insert image_Un
         add: analz_image_keys_simps disjoint_image_iff
              notin_image_iff analz_image_priEK)
  --{*6 seconds on a 1.6GHz machine*}
apply spy_analz
apply (simp add: insert_absorb)  --{*6*}
done

lemma analz_insert_pan:
     "[| evs \<in> set_cr;  K \<notin> invKey ` pubEK ` range CA |] ==>
          (Pan P \<in> analz (insert (Key K) (knows Spy evs))) =
          (Pan P \<in> analz (knows Spy evs))"
by (simp del: image_insert image_Un
         add: analz_image_keys_simps analz_image_pan)

text{*Confidentiality of the PAN\@.  Maybe we could combine the statements of
  this theorem with @{term analz_image_pan}, requiring a single induction but
  a much more difficult proof.*}
lemma pan_confidentiality:
     "[| Pan (pan C) \<in> analz(knows Spy evs); C \<noteq>Spy; evs :set_cr|]
    ==> \<exists>i X K HN.
        Says C (CA i) {|X, Crypt (pubEK (CA i)) {|Key K, Pan (pan C), HN|} |}
           \<in> set evs
      & (CA i) \<in> bad"
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (valid_certificate_tac [8]) --{*for message 5*}
apply (valid_certificate_tac [6]) --{*for message 5*}
apply (erule_tac [9] msg6_cardSK_disj [THEN disjE])
apply (simp_all
         del: image_insert image_Un
         add: analz_image_keys_simps analz_insert_pan analz_image_pan
              notin_image_iff analz_image_priEK)
  --{*3.5 seconds on a 1.6GHz machine*}
apply spy_analz  --{*fake*}
apply blast  --{*3*}
apply blast  --{*5*}
apply (simp (no_asm_simp) add: insert_absorb)  --{*6*}
done

subsection{*Unicity*}

lemma CR6_Says_imp_Notes:
     "[|Says (CA i) C (Crypt KC2
          {|sign (priSK (CA i)) {|Agent C, Nonce NC3, Agent (CA i), Nonce Y|},
            certC (pan C) cardSK X onlySig (priSK (CA i)),
            cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|})  \<in> set evs;
        evs \<in> set_cr |]
      ==> Notes (CA i) (Key cardSK) \<in> set evs"
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (simp_all (no_asm_simp))
done

text{*Unicity of cardSK: it uniquely identifies the other components.
      This holds because a CA accepts a cardSK at most once.*}
lemma cardholder_key_unicity:
     "[|Says (CA i) C (Crypt KC2
          {|sign (priSK (CA i)) {|Agent C, Nonce NC3, Agent (CA i), Nonce Y|},
            certC (pan C) cardSK X onlySig (priSK (CA i)),
            cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|})
          \<in> set evs;
        Says (CA i) C' (Crypt KC2'
          {|sign (priSK (CA i)) {|Agent C', Nonce NC3', Agent (CA i), Nonce Y'|},
            certC (pan C') cardSK X' onlySig (priSK (CA i)),
            cert (CA i) (pubSK (CA i)) onlySig (priSK RCA)|})
          \<in> set evs;
        evs \<in> set_cr |] ==> C=C' & NC3=NC3' & X=X' & KC2=KC2' & Y=Y'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct)
apply (simp_all (no_asm_simp))
apply (blast dest!: CR6_Says_imp_Notes)
done

(*<*)
text{*UNUSED unicity result*}
lemma unique_KC1:
     "[|Says C B {|Crypt KC1 X, Crypt EK {|Key KC1, Y|}|}
          \<in> set evs;
        Says C B' {|Crypt KC1 X', Crypt EK' {|Key KC1, Y'|}|}
          \<in> set evs;
        C \<notin> bad;  evs \<in> set_cr|] ==> B'=B & Y'=Y"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done

text{*UNUSED unicity result*}
lemma unique_KC2:
     "[|Says C B {|Crypt K {|Agent C, nn, Key KC2, X|}, Y|} \<in> set evs;
        Says C B' {|Crypt K' {|Agent C, nn', Key KC2, X'|}, Y'|} \<in> set evs;
        C \<notin> bad;  evs \<in> set_cr|] ==> B'=B & X'=X"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule set_cr.induct, auto)
done
(*>*)

text{*Cannot show cardSK to be secret because it isn't assumed to be fresh
  it could be a previously compromised cardSK [e.g. involving a bad CA]*}

end


theory Scratch
  imports "../DP_Consistency"
begin
term int
term fold

context dp_consistency
begin
context
  includes lifting_syntax
begin
term 0 (**)

definition ceq :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('param \<rightharpoonup> 'result, 'a) state \<Rightarrow> ('param \<rightharpoonup> 'result, 'a) state \<Rightarrow> bool" where
  "ceq R s0 s1 \<equiv> (eq_onp cmem ===> rel_prod R (eq_onp cmem)) (runState s0) (runState s1)"

lemma ceq_intro:
  fixes R s0 s1
  assumes "\<And>M v0 M0 v1 M1. \<lbrakk>cmem M; runState s0 M = (v0,M0); runState s1 M = (v1,M1)\<rbrakk> \<Longrightarrow> R v0 v1 \<and> M0=M1 \<and> cmem M1"
  shows "ceq R s0 s1"
  unfolding ceq_def eq_onp_def rel_fun_def rel_prod_conv by (auto split: prod.split dest: assms)
term 0 (**)

lemma ceq_elim:
  fixes R s0 s1
  assumes "ceq R s0 s1" "cmem M"
  obtains v0 M0 v1 M1 where "runState s0 M = (v0, M0)" "runState s1 M = (v1, M1)" "R v0 v1" "M0=M1" "cmem M1"
  using assms unfolding ceq_def eq_onp_def rel_fun_def by (blast elim: rel_prod.cases)

term 0 (**)

lemma id\<^sub>T_cong:
  fixes R x y
  shows "(R ===> ceq R) return return"
  unfolding rel_fun_def return_def by (fastforce intro: ceq_intro)
thm id\<^sub>T_cong[THEN rel_funD]
term 0 (**)

lemma bind_cong[transfer_rule]:
  fixes R0 R1
  shows "(ceq R0 ===> (R0 ===> ceq R1) ===> ceq R1) (op \<bind>) (op \<bind>)"
  unfolding rel_fun_def bind_def by (fastforce intro!: ceq_intro elim!: ceq_elim)
thm bind_cong[THEN rel_funD, THEN rel_funD]
term 0 (**)

lemma app\<^sub>T_cong[transfer_rule]:
  shows "(ceq (R0 ===> ceq R1) ===> ceq R0 ===> ceq R1) (op .) (op .)"
  unfolding fun_app_lifted_def by transfer_prover
thm app\<^sub>T_cong[THEN rel_funD, THEN rel_funD]
term 0 (**)

lemma map\<^sub>T_cong:
  assumes "ceq R0 xs\<^sub>T ys\<^sub>T"
  assumes "\<And>M. cmem M \<Longrightarrow> case (runState f\<^sub>T M, runState g\<^sub>T M) of ((f, Mf), (g, Mg)) \<Rightarrow>
            Mf = Mg \<and> cmem Mg \<and> (case runState ys\<^sub>T Mg of (ys, Mys) \<Rightarrow> (\<forall>x\<in>set ys. ceq R1 (f x) (g x)))"
  shows "ceq (list_all2 R1) (map\<^sub>T . f\<^sub>T . xs\<^sub>T) (map\<^sub>T . g\<^sub>T . ys\<^sub>T)"
  oops

lemma
  assumes "ceq R0 xs\<^sub>T ys\<^sub>T"
  assumes "\<And>M. cmem M \<Longrightarrow> case (runState f\<^sub>T M, runState g\<^sub>T M) of ((f, Mf), (g, Mg)) \<Rightarrow>
            Mf = Mg \<and> cmem Mg \<and> (case runState ys\<^sub>T Mg of (ys, Mys) \<Rightarrow> (\<forall>x\<in>set ys. ceq R1 (f x) (g x)))"
  assumes "ceq (\<lambda>f g. (\<forall>M. cmem M \<longrightarrow> )) f\<^sub>T g\<^sub>T"
  shows "ceq (list_all2 R1) (map\<^sub>T . f\<^sub>T . xs\<^sub>T) (map\<^sub>T . g\<^sub>T . ys\<^sub>T)"


theory CallArityEnd2EndSafe
imports CallArityEnd2End CardArityTransformSafe CoCallImplSafe CoCallImplTTreeSafe TTreeImplCardinalitySafe
begin

locale CallArityEnd2EndSafe
begin
sublocale CoCallImplSafe.
sublocale CallArityEnd2End.

abbreviation transform_syn' ("\<T>\<^bsub>_\<^esub>") where "\<T>\<^bsub>a\<^esub> \<equiv> transform a"

lemma end2end:
  "c \<Rightarrow>\<^sup>* c' \<Longrightarrow>
  \<not> boring_step c' \<Longrightarrow>
  heap_upds_ok_conf c \<Longrightarrow>
  consistent (ae, ce, a, as, r) c \<Longrightarrow>
  \<exists>ae' ce' a' as' r'. consistent  (ae', ce', a', as', r') c' \<and> conf_transform  (ae, ce, a, as, r) c \<Rightarrow>\<^sub>G\<^sup>* conf_transform  (ae', ce', a', as', r') c'"
  by (rule card_arity_transform_safe)

theorem end2end_closed:
  assumes closed: "fv e = ({} :: var set)"
  assumes "([], e, []) \<Rightarrow>\<^sup>* (\<Gamma>,v,[])" and "isVal v"
  obtains \<Gamma>' and v'
  where "([], \<T>\<^bsub>0\<^esub> e, []) \<Rightarrow>\<^sup>* (\<Gamma>',v',[])" and "isVal v'"
    and "card (domA \<Gamma>') \<le> card (domA \<Gamma>)"
proof-
  note assms(2)
  moreover
  have "\<not> boring_step (\<Gamma>,v,[])" by (simp add: boring_step.simps)
  moreover
  have "heap_upds_ok_conf ([], e, [])" by simp
  moreover
  have "consistent (\<bottom>,\<bottom>,0,[],[]) ([], e, [])" using closed by (rule closed_consistent)
  ultimately
  obtain ae ce a as r where
    *: "consistent  (ae, ce, a, as, r) (\<Gamma>,v,[])" and
    **: "conf_transform  (\<bottom>, \<bottom>, 0, [], []) ([],e,[]) \<Rightarrow>\<^sub>G\<^sup>* conf_transform (ae, ce, a, as, r) (\<Gamma>,v,[])"
    by (metis end2end)

  let ?\<Gamma> = "map_transform Aeta_expand ae (map_transform transform ae (restrictA (-set r) \<Gamma>))"
  let ?v = "transform a v"

  from * have "set r \<subseteq> domA \<Gamma>" by auto

  have "conf_transform  (\<bottom>, \<bottom>, 0, [], []) ([],e,[]) = ([],transform 0 e,[])" by simp
  with **
  have "([], transform 0 e, []) \<Rightarrow>\<^sub>G\<^sup>* (?\<Gamma>, ?v, map Dummy (rev r))" by simp

  have "isVal ?v" using \<open>isVal v\<close> by simp

  have "fv (transform 0 e) = ({} :: var set)" using closed
    by (auto dest: subsetD[OF fv_transform])

  note sestoftUnGC'[OF \<open>([], transform 0 e, []) \<Rightarrow>\<^sub>G\<^sup>* (?\<Gamma>, ?v, map Dummy (rev r))\<close> \<open>isVal ?v\<close> \<open>fv (transform 0 e) = {}\<close>]
  then obtain \<Gamma>'
    where "([], transform 0 e, []) \<Rightarrow>\<^sup>* (\<Gamma>', ?v, [])"
    and "?\<Gamma> = restrictA (- set r) \<Gamma>'"
    and "set r \<subseteq> domA \<Gamma>'"
    by auto

  have "card (domA \<Gamma>) = card (domA ?\<Gamma> \<union> (set r \<inter> domA \<Gamma>))"
    by (rule arg_cong[where f = card]) auto
  also have "\<dots> = card (domA ?\<Gamma>) + card (set r \<inter> domA \<Gamma>)"
    by (rule card_Un_disjoint) auto
  also note \<open>?\<Gamma> = restrictA (- set r) \<Gamma>'\<close>
  also have "set r \<inter> domA \<Gamma> = set r \<inter> domA \<Gamma>'"
    using \<open>set r \<subseteq> domA \<Gamma>\<close>  \<open>set r \<subseteq> domA \<Gamma>'\<close> by auto
  also have "card (domA (restrictA (- set r) \<Gamma>')) + card (set r \<inter> domA \<Gamma>') = card (domA \<Gamma>')"
    by (subst card_Un_disjoint[symmetric]) (auto intro: arg_cong[where f = card])
  finally
  have "card (domA \<Gamma>') \<le> card (domA \<Gamma>)" by simp
  with \<open>([], transform 0 e, []) \<Rightarrow>\<^sup>* (\<Gamma>', ?v, [])\<close>  \<open>isVal ?v\<close>
  show thesis using that by blast
qed

lemma fresh_var_eqE[elim_format]: "fresh_var e = x \<Longrightarrow> x \<notin>  fv e"
  by (metis fresh_var_not_free)

lemma example1:
  fixes e :: exp
  fixes f g x y z :: var
  assumes Aexp_e: "\<And>a. Aexp e\<cdot>a = esing x\<cdot>(up\<cdot>a) \<squnion> esing y\<cdot>(up\<cdot>a)"
  assumes ccExp_e: "\<And>a. CCexp e\<cdot>a = \<bottom>"
  assumes [simp]: "transform 1 e = e"
  assumes "isVal e"
  assumes disj: "y \<noteq> f" "y \<noteq> g" "x \<noteq> y" "z \<noteq> f" "z \<noteq> g" "y \<noteq> x"
  assumes fresh: "atom z \<sharp> e"
  shows "transform 1 (let y be  App (Var f) g in (let x be e in (Var x))) =
         let y be (Lam [z]. App (App (Var f) g) z) in (let x be (Lam [z]. App e z) in (Var x))"
proof-
  from arg_cong[where f = edom, OF Aexp_e]
  have "x \<in> fv e" by simp (metis Aexp_edom' insert_subset)
  hence [simp]: "\<not> nonrec [(x,e)]"
    by (simp add: nonrec_def)

  from \<open>isVal e\<close>
  have [simp]: "thunks [(x, e)] = {}"
    by (simp add: thunks_Cons)

  have [simp]: "CCfix [(x, e)]\<cdot>(esing x\<cdot>(up\<cdot>1) \<squnion> esing y\<cdot>(up\<cdot>1), \<bottom>) = \<bottom>"
    unfolding CCfix_def
    apply (simp add: fix_bottom_iff ccBindsExtra_simp)
    apply (simp add: ccBind_eq disj ccExp_e)
    done

  have [simp]: "Afix [(x, e)]\<cdot>(esing x\<cdot>(up\<cdot>1)) = esing x\<cdot>(up\<cdot>1) \<squnion> esing y\<cdot>(up\<cdot>1)"
    unfolding Afix_def
    apply simp
    apply (rule fix_eqI)
    apply (simp add: disj Aexp_e)
    apply (case_tac "z x")
    apply (auto simp add: disj Aexp_e)
    done

  have [simp]: "Aheap [(y, App (Var f) g)] (let x be e in Var x)\<cdot>1 = esing y\<cdot>((Aexp (let x be e in Var x )\<cdot>1) y)"
    by (auto simp add:  Aheap_nonrec_simp ABind_nonrec_eq pure_fresh fresh_at_base disj)

  have [simp]: "(Aexp (let x be e in Var x)\<cdot>1) = esing y\<cdot>(up\<cdot>1)"
    by (simp add: env_restr_join disj)

  have [simp]: "Aheap [(x, e)] (Var x)\<cdot>1 = esing x\<cdot>(up\<cdot>1)"
    by (simp add: env_restr_join disj)

  have [simp]: "Aeta_expand 1 (App (Var f) g) = (Lam [z]. App (App (Var f) g) z)"
    apply (simp add: one_is_inc_zero del: exp_assn.eq_iff)
    apply (subst change_Lam_Variable[of z "fresh_var (App (Var f) g)"])
    apply (auto simp add: fresh_Pair fresh_at_base pure_fresh disj intro!: flip_fresh_fresh  elim!: fresh_var_eqE)
    done

  have [simp]: "Aeta_expand 1 e = (Lam [z]. App e z)"
    apply (simp add: one_is_inc_zero del: exp_assn.eq_iff)
    apply (subst change_Lam_Variable[of z "fresh_var e"])
    apply (auto simp add: fresh_Pair fresh_at_base pure_fresh disj fresh intro!: flip_fresh_fresh  elim!: fresh_var_eqE)
    done

  show ?thesis
    by (simp del: Let_eq_iff add: map_transform_Cons disj[symmetric])
qed

end
end


theory Inca_to_Ubx_compiler
  imports Inca_to_Ubx_simulation Result
    Inca_Verification
    "VeriComp.Compiler"
    "HOL-Library.Monad_Syntax"
begin

section \<open>Generic program rewriting\<close>

primrec monadic_fold_map where
  "monadic_fold_map f acc [] = Some (acc, [])" |
  "monadic_fold_map f acc (x # xs) = do {
    (acc', x') \<leftarrow> f acc x;
    (acc'', xs') \<leftarrow> monadic_fold_map f acc' xs;
    Some (acc'', x' # xs')
  }"

lemma monadic_fold_map_length:
  "monadic_fold_map f acc xs = Some (acc', xs') \<Longrightarrow> length xs = length xs'"
  by (induction xs arbitrary: acc xs') (auto simp: bind_eq_Some_conv)

lemma monadic_fold_map_ConsD[dest]:
  assumes "monadic_fold_map f a (x # xs) = Some (c, ys)"
  shows "\<exists>y ys' b. ys = y # ys' \<and> f a x = Some (b, y) \<and> monadic_fold_map f b xs = Some (c, ys')"
  using assms
  by (auto simp add: bind_eq_Some_conv)

lemma monadic_fold_map_eq_Some_conv:
  "monadic_fold_map f a (x # xs) = Some (c, ys) \<longleftrightarrow>
    (\<exists>y ys' b. f a x = Some (b, y) \<and> monadic_fold_map f b xs = Some (c, ys') \<and> ys = y # ys')"
  by (auto simp add: bind_eq_Some_conv)

lemma monadic_fold_map_eq_Some_conv':
  "monadic_fold_map f a (x # xs) = Some p \<longleftrightarrow>
    (\<exists>y ys' b. f a x = Some (b, y) \<and> monadic_fold_map f b xs = Some (fst p, ys') \<and> snd p = y # ys')"
  by (cases p) (auto simp add: bind_eq_Some_conv)

lemma monadic_fold_map_list_all2:
  assumes "monadic_fold_map f acc xs = Some (acc', ys)" and
    "\<And>acc acc' x y. f acc x = Some (acc', y) \<Longrightarrow> P x y"
  shows "list_all2 P xs ys"
  using assms(1)
proof (induction xs arbitrary: acc ys)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  show ?case
    using Cons.prems
    by (auto simp: bind_eq_Some_conv intro: assms(2) Cons.IH)
qed

lemma monadic_fold_map_list_all:
  assumes "monadic_fold_map f acc xs = Some (acc', ys)" and
    "\<And>acc acc' x y. f acc x = Some (acc', y) \<Longrightarrow> P y"
  shows "list_all P ys"
proof -
  have "list_all2 (\<lambda>_. P) xs ys"
    using assms
    by (auto elim: monadic_fold_map_list_all2)
  thus ?thesis
    by (auto elim: list_rel_imp_pred2)
qed

fun gen_pop_push where
  "gen_pop_push instr (domain, codomain) \<Sigma> = (
    let ar = length domain in
    if ar \<le> length \<Sigma> \<and> take ar \<Sigma> = domain then
      Some (instr, codomain @ drop ar \<Sigma>)
    else
      None
  )"

context inca_to_ubx_simulation begin

section \<open>Lifting\<close>

fun lift_instr :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow>
  ((_, _, _, _, _, _, 'opubx, 'ubx1, 'ubx2) Ubx.instr \<times> _) option" where
  "lift_instr F L ret N (Inca.IPush d) \<Sigma> = Some (IPush d, None # \<Sigma>)" |
  "lift_instr F L ret N Inca.IPop (_ # \<Sigma>) = Some (IPop, \<Sigma>)" |
  "lift_instr F L ret N (Inca.IGet n) \<Sigma> = (if n < N then Some (IGet n, None # \<Sigma>) else None)" |
  "lift_instr F L ret N (Inca.ISet n) (None # \<Sigma>) = (if n < N then Some (ISet n, \<Sigma>) else None)" |
  "lift_instr F L ret N (Inca.ILoad x) (None # \<Sigma>) = Some (ILoad x, None # \<Sigma>)" |
  "lift_instr F L ret N (Inca.IStore x) (None # None # \<Sigma>) = Some (IStore x, \<Sigma>)" |
  "lift_instr F L ret N (Inca.IOp op) \<Sigma> =
    gen_pop_push (IOp op) (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> op) None, [None]) \<Sigma>" |
  "lift_instr F L ret N (Inca.IOpInl opinl) \<Sigma> =
    gen_pop_push (IOpInl opinl) (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> (\<DD>\<ee>\<II>\<nn>\<ll> opinl)) None, [None]) \<Sigma>" |
  "lift_instr F L ret N (Inca.ICJump l\<^sub>t l\<^sub>f) [None] =
    (if List.member L l\<^sub>t \<and> List.member L l\<^sub>f then Some (ICJump l\<^sub>t l\<^sub>f, []) else None)" |
  "lift_instr F L ret N (Inca.ICall f) \<Sigma> = do {
    (ar, ret) \<leftarrow> F f;
    gen_pop_push (ICall f) (replicate ar None, replicate ret None) \<Sigma>
  }" |
  "lift_instr F L ret N Inca.IReturn \<Sigma> =
    (if \<Sigma> = replicate ret None then Some (IReturn, []) else None)" |
  "lift_instr _ _ _ _ _ _ = None"

definition lift_instrs where
  "lift_instrs F L ret N \<equiv>
    monadic_fold_map (\<lambda>\<Sigma> instr. map_option prod.swap (lift_instr F L ret N instr \<Sigma>))"

lemma lift_instrs_length:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "length xs = length ys"
  using assms unfolding lift_instrs_def
  by (auto intro: monadic_fold_map_length)

lemma lift_instrs_not_Nil: "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys) \<Longrightarrow> xs \<noteq> [] \<longleftrightarrow> ys \<noteq> []"
  using lift_instrs_length by fastforce

lemma lift_instrs_NilD[dest]:
  assumes "lift_instrs F L ret N \<Sigma>i [] = Some (\<Sigma>o, ys)"
  shows "\<Sigma>o = \<Sigma>i \<and> ys = []"
  using assms
  by (simp_all add: lift_instrs_def)

lemmas Some_eq_bind_conv =
  bind_eq_Some_conv[unfolded eq_commute[of "Option.bind f g" "Some x" for f g x]]

lemma lift_instr_is_jump:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Inca.is_jump x \<longleftrightarrow> Ubx.is_jump y"
  using assms
  by (rule lift_instr.elims)
    (auto simp add: if_split_eq2 Let_def Some_eq_bind_conv)

lemma lift_instr_is_return:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Inca.is_return x \<longleftrightarrow> Ubx.is_return y"
  using assms
  by (rule lift_instr.elims)
    (auto simp add: if_split_eq2 Let_def Some_eq_bind_conv)

lemma lift_instrs_all_not_jump_not_return:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows
    "list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) xs \<longleftrightarrow>
     list_all (\<lambda>i. \<not> Ubx.is_jump i \<and> \<not> Ubx.is_return i) ys"
  using assms
proof (induction xs arbitrary: \<Sigma>i \<Sigma>o ys)
  case Nil
  then show ?case by (simp add: lift_instrs_def)
next
  case (Cons x xs)
  from Cons.prems show ?case
    apply (simp add: lift_instrs_def bind_eq_Some_conv)
    apply (fold lift_instrs_def)
    by (auto simp add: Cons.IH lift_instr_is_jump lift_instr_is_return)
qed

lemma lift_instrs_all_butlast_not_jump_not_return:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows
    "list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) (butlast xs) \<longleftrightarrow>
     list_all (\<lambda>i. \<not> Ubx.is_jump i \<and> \<not> Ubx.is_return i) (butlast ys)"
  using lift_instrs_length[OF assms(1)] assms unfolding lift_instrs_def
proof (induction xs ys arbitrary: \<Sigma>i \<Sigma>o rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons x xs y ys)
  thus ?case
    by (auto simp add: bind_eq_Some_conv lift_instr_is_jump lift_instr_is_return)
qed

lemma lift_instr_sp:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.sp_instr F ret y \<Sigma>i \<Sigma>o"
  using assms
  apply (induction F L ret N x \<Sigma>i rule: lift_instr.induct;
      auto simp: Let_def intro: Subx.sp_instr.intros)
    apply (rule Subx.sp_instr.Op, metis append_take_drop_id)
   apply (rule Subx.sp_instr.OpInl, metis append_take_drop_id)
  apply (auto simp add: bind_eq_Some_conv intro!: Subx.sp_instr.Call, metis append_take_drop_id)
  done

lemma lift_instrs_sp:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "Subx.sp_instrs F ret ys \<Sigma>i \<Sigma>o"
  using assms unfolding lift_instrs_def
proof (induction xs arbitrary: \<Sigma>i \<Sigma>o ys)
  case Nil
  thus ?case by (auto intro: Subx.sp_instrs.Nil)
next
  case (Cons x xs)
  from Cons.prems show ?case
    by (auto simp add: bind_eq_Some_conv intro: Subx.sp_instrs.Cons lift_instr_sp Cons.IH)
qed

lemma lift_instr_fun_call_in_range:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.fun_call_in_range F y"
  using assms
  by (induction F L ret N x \<Sigma>i rule: lift_instr.induct) (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instrs_all_fun_call_in_range:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.fun_call_in_range F) ys"
  using assms unfolding lift_instrs_def
  by (auto intro!: monadic_fold_map_list_all intro: lift_instr_fun_call_in_range)

lemma lift_instr_local_var_in_range:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.local_var_in_range N y"
  using assms
  by (induction F L ret N x \<Sigma>i rule: lift_instr.induct) (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instrs_all_local_var_in_range:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.local_var_in_range N) ys"
  using assms unfolding lift_instrs_def
  by (auto intro!: monadic_fold_map_list_all intro: lift_instr_local_var_in_range)

lemma lift_instr_jump_in_range:
  assumes "lift_instr F L ret N x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.jump_in_range (set L) y"
  using assms
  by (induction F L ret N x \<Sigma>i rule: lift_instr.induct)
    (auto simp: Let_def bind_eq_Some_conv in_set_member)

lemma lift_instrs_all_jump_in_range:
  assumes "lift_instrs F L ret N \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.jump_in_range (set L)) ys"
  using assms unfolding lift_instrs_def
  by (auto intro!: monadic_fold_map_list_all intro: lift_instr_jump_in_range)

lemma lift_instr_norm:
  "lift_instr F L ret N instr1 \<Sigma>1 = Some (instr2, \<Sigma>2) \<Longrightarrow> norm_eq instr1 instr2"
  by (induction instr1 \<Sigma>1 rule: lift_instr.induct) (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instrs_all_norm:
  assumes "lift_instrs F L ret N \<Sigma>1 instrs1 = Some (\<Sigma>2, instrs2)"
  shows "list_all2 norm_eq instrs1 instrs2"
  using assms unfolding lift_instrs_def
  by (auto simp: lift_instr_norm elim!: monadic_fold_map_list_all2)

section \<open>Optimization\<close>

context
  fixes load_oracle :: "nat \<Rightarrow> type option"
begin

definition orelse :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option"  (infixr "orelse" 55) where
  "x orelse y = (case x of Some x' \<Rightarrow> Some x' | None \<Rightarrow> y)"

lemma None_orelse[simp]: "None orelse y = y"
  by (simp add: orelse_def)

lemma orelse_None[simp]: "x orelse None = x"
  by (cases x) (simp_all add: orelse_def)

lemma Some_orelse[simp]: "Some x orelse y = Some x"
  by (simp add: orelse_def)

lemma orelse_eq_Some_conv:
  "x orelse y = Some z \<longleftrightarrow> (x = Some z \<or> x = None \<and> y = Some z)"
  by (cases x) simp_all

lemma orelse_eq_SomeE:
  assumes
    "x orelse y = Some z" and
    "x = Some z \<Longrightarrow> P" and
    "x = None \<Longrightarrow> y = Some z \<Longrightarrow> P"
  shows "P"
  using assms(1)
  unfolding orelse_def
  by (cases x; auto intro: assms(2,3))

fun drop_prefix where
  "drop_prefix [] ys = Some ys" |
  "drop_prefix (x # xs) (y # ys) = (if x = y then drop_prefix xs ys else None)" |
  "drop_prefix _ _ = None "

lemma drop_prefix_append_prefix[simp]: "drop_prefix xs (xs @ ys) = Some ys"
  by (induction xs) simp_all

lemma drop_prefix_eq_Some_conv: "drop_prefix xs ys = Some zs \<longleftrightarrow> ys = xs @ zs"
  by (induction xs ys arbitrary: zs rule: drop_prefix.induct)
    (auto simp: if_split_eq1)

fun optim_instr where
  "optim_instr _ _ _ (IPush d) \<Sigma> =
    Some Pair \<diamondop> (Some IPushUbx1 \<diamondop> (unbox_ubx1 d)) \<diamondop> Some (Some Ubx1 # \<Sigma>) orelse
    Some Pair \<diamondop> (Some IPushUbx2 \<diamondop> (unbox_ubx2 d)) \<diamondop> Some (Some Ubx2 # \<Sigma>) orelse
    Some (IPush d, None # \<Sigma>)
  " |
  "optim_instr _ _ _ (IPushUbx1 n) \<Sigma> = Some (IPushUbx1 n, Some Ubx1 # \<Sigma>)" |
  "optim_instr _ _ _ (IPushUbx2 b) \<Sigma> = Some (IPushUbx2 b, Some Ubx2 # \<Sigma>)" |
  "optim_instr _ _ _ IPop (_ # \<Sigma>) = Some (IPop, \<Sigma>)" |
  "optim_instr _ _ pc (IGet n) \<Sigma> =
    map_option (\<lambda>\<tau>. (IGetUbx \<tau> n, Some \<tau> # \<Sigma>)) (load_oracle pc) orelse
    Some (IGet n, None # \<Sigma>)" |
  "optim_instr _ _ pc (IGetUbx \<tau> n) \<Sigma> = Some (IGetUbx \<tau> n, Some \<tau> # \<Sigma>)" |
  "optim_instr _ _ _ (ISet n) (None # \<Sigma>) = Some (ISet n, \<Sigma>)" |
  "optim_instr _ _ _ (ISet n) (Some \<tau> # \<Sigma>) = Some (ISetUbx \<tau> n, \<Sigma>)" |
  "optim_instr _ _ _ (ISetUbx _ n) (None # \<Sigma>) = Some (ISet n, \<Sigma>)" |
  "optim_instr _ _ _ (ISetUbx _ n) (Some \<tau> # \<Sigma>) = Some (ISetUbx \<tau> n, \<Sigma>)" |
  "optim_instr _ _ pc (ILoad x) (None # \<Sigma>) =
    map_option (\<lambda>\<tau>. (ILoadUbx \<tau> x, Some \<tau> # \<Sigma>)) (load_oracle pc) orelse
    Some (ILoad x, None # \<Sigma>)" |
  "optim_instr _ _ _ (ILoadUbx \<tau> x) (None # \<Sigma>) = Some (ILoadUbx \<tau> x, Some \<tau> # \<Sigma>)" |
  "optim_instr _ _ _ (IStore x) (None # None # \<Sigma>) = Some (IStore x, \<Sigma>)" |
  "optim_instr _ _ _ (IStore x) (None # Some \<tau> # \<Sigma>) = Some (IStoreUbx \<tau> x, \<Sigma>)" |
  "optim_instr _ _ _ (IStoreUbx _ x) (None # None # \<Sigma>) = Some (IStore x, \<Sigma>)" |
  "optim_instr _ _ _ (IStoreUbx _ x) (None # Some \<tau> # \<Sigma>) = Some (IStoreUbx \<tau> x, \<Sigma>)" |
  "optim_instr _ _ _ (IOp op) \<Sigma> =
    map_option (\<lambda>\<Sigma>o. (IOp op, None # \<Sigma>o)) (drop_prefix (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> op) None) \<Sigma>)" |
  "optim_instr _ _ _ (IOpInl opinl) \<Sigma> = (
    let ar = \<AA>\<rr>\<ii>\<tt>\<yy> (\<DD>\<ee>\<II>\<nn>\<ll> opinl) in
    if ar \<le> length \<Sigma> then
      case \<UU>\<bb>\<xx> opinl (take ar \<Sigma>) of
        None \<Rightarrow> map_option (\<lambda>\<Sigma>o. (IOpInl opinl, None # \<Sigma>o)) (drop_prefix (replicate ar None) \<Sigma>) |
        Some opubx \<Rightarrow> map_option (\<lambda>\<Sigma>o. (IOpUbx opubx, snd (\<TT>\<yy>\<pp>\<ee>\<OO>\<ff>\<OO>\<pp> opubx) # \<Sigma>o))
          (drop_prefix (fst (\<TT>\<yy>\<pp>\<ee>\<OO>\<ff>\<OO>\<pp> opubx)) \<Sigma>)
    else
      None
  )" |
  "optim_instr _ _ _ (IOpUbx opubx) \<Sigma> =
    (let p = \<TT>\<yy>\<pp>\<ee>\<OO>\<ff>\<OO>\<pp> opubx in
     map_option (\<lambda>\<Sigma>o. (IOpUbx opubx, snd p # \<Sigma>o)) (drop_prefix (fst p) \<Sigma>))" |
  "optim_instr _ _ _ (ICJump l\<^sub>t l\<^sub>f) [None] = Some (ICJump l\<^sub>t l\<^sub>f, []) " |
  "optim_instr F _ _ (ICall f) \<Sigma> = do {
    (ar, ret) \<leftarrow> F f;
    \<Sigma>o \<leftarrow> drop_prefix (replicate ar None) \<Sigma>;
    Some (ICall f, replicate ret None @ \<Sigma>o)
  }" |
  "optim_instr _ ret _ IReturn \<Sigma> = (if \<Sigma> = replicate ret None then Some (IReturn, []) else None)" |
  "optim_instr _ _ _ _ _ = None"

definition optim_instrs where
  "optim_instrs F ret \<equiv> \<lambda>pc \<Sigma>i instrs.
    map_option (\<lambda>((_, \<Sigma>o), instrs'). (\<Sigma>o, instrs'))
      (monadic_fold_map (\<lambda>(pc, \<Sigma>) instr.
        map_option (\<lambda>(instr', \<Sigma>o). ((Suc pc, \<Sigma>o), instr')) (optim_instr F ret pc instr \<Sigma>))
      (pc, \<Sigma>i) instrs)"

lemma optim_instrs_Cons_eq_Some_conv:
  "optim_instrs F ret pc \<Sigma>i (instr # instrs) = Some (\<Sigma>o, ys) \<longleftrightarrow> (\<exists>y ys' \<Sigma>.
    ys = y # ys' \<and>
    optim_instr F ret pc instr \<Sigma>i = Some (y, \<Sigma>) \<and>
    optim_instrs F ret (Suc pc) \<Sigma> instrs = Some (\<Sigma>o, ys'))"
  unfolding optim_instrs_def
  by (auto simp: bind_eq_Some_conv)

lemma optim_instrs_length:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "length xs = length ys"
  using assms unfolding optim_instrs_def
  by (auto intro: monadic_fold_map_length)

lemma optim_instrs_not_Nil: "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys) \<Longrightarrow> xs \<noteq> [] \<longleftrightarrow> ys \<noteq> []"
  using optim_instrs_length by fastforce

lemma optim_instrs_NilD[dest]:
  assumes "optim_instrs F ret pc \<Sigma>i [] = Some (\<Sigma>o, ys)"
  shows "\<Sigma>o = \<Sigma>i \<and> ys = []"
  using assms
  by (simp_all add: optim_instrs_def)

lemma optim_instrs_ConsD[dest]:
  assumes "optim_instrs F ret pc \<Sigma>i (x # xs) = Some (\<Sigma>o, ys)"
  shows "\<exists>y ys' \<Sigma>. ys = y # ys' \<and>
    optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>) \<and>
    optim_instrs F ret (Suc pc) \<Sigma> xs = Some (\<Sigma>o, ys')"
  using assms
  unfolding optim_instrs_def
  by (auto simp: bind_eq_Some_conv)

lemma optim_instr_norm:
  assumes "optim_instr F ret pc instr1 \<Sigma>1 = Some (instr2, \<Sigma>2)"
  shows "norm_instr instr1 = norm_instr instr2"
  using assms
  by (cases "(F, ret, pc, instr1, \<Sigma>1)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 bind_eq_Some_conv option.case_eq_if
      orelse_eq_Some_conv
      dest!: Subx.box_unbox_inverse dest: Subx.\<UU>\<bb>\<xx>_invertible)

lemma optim_instrs_all_norm:
  assumes "optim_instrs F ret pc \<Sigma>1 instrs1 = Some (\<Sigma>2, instrs2)"
  shows "list_all2 (\<lambda>i1 i2. norm_instr i1 = norm_instr i2) instrs1 instrs2"
  using assms unfolding optim_instrs_def
  by (auto simp: optim_instr_norm elim!: monadic_fold_map_list_all2)

lemma optim_instr_is_jump:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "is_jump x \<longleftrightarrow> is_jump y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases;
      simp add: orelse_eq_Some_conv ap_option_eq_Some_conv bind_eq_Some_conv
        Let_def if_split_eq1 option.case_eq_if;
      safe; simp)

lemma optim_instr_is_return:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "is_return x \<longleftrightarrow> is_return y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases;
      simp add: orelse_eq_Some_conv ap_option_eq_Some_conv bind_eq_Some_conv
        Let_def if_split_eq1 option.case_eq_if;
      safe; simp)

lemma optim_instrs_all_butlast_not_jump_not_return:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows
    "list_all (\<lambda>i. \<not> is_jump i \<and> \<not> is_return i) (butlast xs) \<longleftrightarrow>
     list_all (\<lambda>i. \<not> is_jump i \<and> \<not> is_return i) (butlast ys)"
  using optim_instrs_length[OF assms(1)] assms
proof (induction xs ys arbitrary: pc \<Sigma>i \<Sigma>o rule: list_induct2)
  case Nil
  thus ?case by simp
next
  case (Cons x xs y ys)
  from Cons.prems obtain \<Sigma> where
    optim_x: "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>)" and
    optim_xs: "optim_instrs F ret (Suc pc) \<Sigma> xs = Some (\<Sigma>o, ys)"
    by auto
  show ?case
    using Cons.hyps
    using optim_x optim_xs
    apply (simp add: Cons.IH optim_instr_is_jump optim_instr_is_return)
    by fastforce
qed

lemma optim_instr_jump_in_range:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.jump_in_range L x \<longleftrightarrow> Subx.jump_in_range L y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 option.case_eq_if
      bind_eq_Some_conv orelse_eq_Some_conv)

lemma optim_instrs_all_jump_in_range:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.jump_in_range L) xs \<longleftrightarrow> list_all (Subx.jump_in_range L) ys"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys) (auto simp: optim_instr_jump_in_range)

lemma optim_instr_fun_call_in_range:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.fun_call_in_range F x \<longleftrightarrow> Subx.fun_call_in_range F y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 option.case_eq_if
      bind_eq_Some_conv orelse_eq_Some_conv)

lemma optim_instrs_all_fun_call_in_range:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.fun_call_in_range F) xs \<longleftrightarrow> list_all (Subx.fun_call_in_range F) ys"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys) (auto simp: optim_instr_fun_call_in_range)

lemma optim_instr_local_var_in_range:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.local_var_in_range N x \<longleftrightarrow> Subx.local_var_in_range N y"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp: ap_option_eq_Some_conv Let_def if_split_eq1 option.case_eq_if
      bind_eq_Some_conv orelse_eq_Some_conv)

lemma optim_instrs_all_local_var_in_range:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "list_all (Subx.local_var_in_range N) xs \<longleftrightarrow> list_all (Subx.local_var_in_range N) ys"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys) (auto simp: optim_instr_local_var_in_range)

lemma optim_instr_sp:
  assumes "optim_instr F ret pc x \<Sigma>i = Some (y, \<Sigma>o)"
  shows "Subx.sp_instr F ret y \<Sigma>i \<Sigma>o"
  using assms
  by (cases "(F, ret, pc, x, \<Sigma>i)" rule: optim_instr.cases)
    (auto simp add: Let_def if_split_eq1 option.case_eq_if
      simp: ap_option_eq_Some_conv orelse_eq_Some_conv drop_prefix_eq_Some_conv bind_eq_Some_conv
      intro: Subx.sp_instr.intros)

lemma optim_instrs_sp:
  assumes "optim_instrs F ret pc \<Sigma>i xs = Some (\<Sigma>o, ys)"
  shows "Subx.sp_instrs F ret ys \<Sigma>i \<Sigma>o"
  using assms
  by (induction xs arbitrary: pc \<Sigma>i \<Sigma>o ys)
    (auto intro!: Subx.sp_instrs.intros optim_instr_sp)

section \<open>Compilation of function definition\<close>

definition compile_basic_block where
  "compile_basic_block F L ret N \<equiv>
    ap_map_prod Some (\<lambda>i1. do {
      _ \<leftarrow> if i1 \<noteq> [] then Some () else None;
      _ \<leftarrow> if list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) (butlast i1) then Some () else None;
      (\<Sigma>o, i2) \<leftarrow> lift_instrs F L ret N ([] :: type option list) i1;
      if \<Sigma>o = [] then
        case optim_instrs F ret 0 ([] :: type option list) i2 of
          Some (\<Sigma>o', i2') \<Rightarrow> Some (if \<Sigma>o' = [] then i2' else i2) |
          None \<Rightarrow> Some i2
      else
        None
    })"

lemma compile_basic_block_rel_prod_all_norm_eq:
  assumes "compile_basic_block F L ret N bblock1 = Some bblock2"
  shows "rel_prod (=) (list_all2 norm_eq) bblock1 bblock2"
  using assms
  unfolding compile_basic_block_def
  apply (auto simp add: ap_map_prod_eq_Some_conv bind_eq_Some_conv
      simp: if_split_eq1
      intro: lift_instrs_all_norm
      dest!: optim_instrs_all_norm lift_instrs_all_norm)
  subgoal premises prems for _ xs zs ys
    using \<open>list_all2 norm_eq xs ys\<close>
  proof (rule list_all2_trans[of norm_eq "\<lambda>i. norm_eq (norm_instr i)" norm_eq xs ys zs, simplified])
    show "list_all2 (\<lambda>i. norm_eq (norm_instr i)) ys zs"
    proof (cases "optim_instrs F ret 0 [] ys")
      case None
      with prems show ?thesis by (simp add: list.rel_refl)
    next
      case (Some p)
      with prems show ?thesis
        by (cases p) (auto simp: list.rel_refl intro: optim_instrs_all_norm)
    qed
  qed
  done

lemma list_all_iff_butlast_last:
  assumes "xs \<noteq> []"
  shows "list_all P xs \<longleftrightarrow> list_all P (butlast xs) \<and> P (last xs)"
  using assms
  by (induction xs) auto

lemma compile_basic_block_wf:
  assumes "compile_basic_block F L ret N x = Some y"
  shows "Subx.wf_basic_block F (set L) ret N y"
proof -
  obtain f instrs1 instrs2 instrs3 where
    x_def: "x = (f, instrs1)" and
    y_def: "y = (f, instrs3)" and
    "instrs1 \<noteq> []" and
    all_not_jump_not_return_instrs1:
      "list_all (\<lambda>i. \<not> Inca.is_jump i \<and> \<not> Inca.is_return i) (butlast instrs1)" and
    lift_instrs1: "lift_instrs F L ret N ([] :: type option list) instrs1 = Some ([], instrs2)" and
    instr4_defs: "instrs3 = instrs2 \<or>
      optim_instrs F ret 0 ([] :: type option list) instrs2 = Some ([], instrs3)"
    using assms
    unfolding compile_basic_block_def
    apply (auto simp: ap_map_prod_eq_Some_conv bind_eq_Some_conv if_split_eq1 option.case_eq_if)
    by blast

  have "instrs3 \<noteq> []"
    using instr4_defs \<open>instrs1 \<noteq> []\<close>
    using lift_instrs_not_Nil[OF lift_instrs1]
    by (auto simp: optim_instrs_not_Nil)
  moreover have "list_all (Subx.local_var_in_range N) instrs3"
    using instr4_defs lift_instrs1
    by (auto dest: lift_instrs_all_local_var_in_range simp: optim_instrs_all_local_var_in_range)
  moreover have "list_all (Subx.fun_call_in_range F) instrs3"
    using instr4_defs lift_instrs1
    by (auto dest: lift_instrs_all_fun_call_in_range simp: optim_instrs_all_fun_call_in_range)
  moreover have "list_all (Subx.jump_in_range (set L)) instrs3"
    using instr4_defs lift_instrs1
    by (auto dest: lift_instrs_all_jump_in_range simp: optim_instrs_all_jump_in_range)
  moreover have "list_all (\<lambda>i. \<not> Ubx.instr.is_jump i \<and> \<not> Ubx.instr.is_return i) (butlast instrs3)"
    using instr4_defs lift_instrs1 all_not_jump_not_return_instrs1
    by (auto simp:
        lift_instrs_all_butlast_not_jump_not_return
        optim_instrs_all_butlast_not_jump_not_return)
  moreover have "Subx.sp_instrs F ret instrs3 [] []"
    using instr4_defs lift_instrs1
    by (auto intro: lift_instrs_sp optim_instrs_sp)
  ultimately show ?thesis
    by (auto simp: y_def intro!: Subx.wf_basic_blockI)
qed

fun compile_fundef where
  "compile_fundef F (Fundef bblocks1 ar ret locals) = do {
    _ \<leftarrow> if bblocks1 = [] then None else Some ();
    bblocks2 \<leftarrow> ap_map_list (compile_basic_block F (map fst bblocks1) ret (ar + locals)) bblocks1;
    Some (Fundef bblocks2 ar ret locals)
  }"

lemma compile_fundef_arities: "compile_fundef F fd1 = Some fd2 \<Longrightarrow> arity fd1 = arity fd2"
  by (cases fd1) (auto simp: bind_eq_Some_conv)

lemma compile_fundef_returns: "compile_fundef F fd1 = Some fd2 \<Longrightarrow> return fd1 = return fd2"
  by (cases fd1) (auto simp: bind_eq_Some_conv)

lemma compile_fundef_locals:
  "compile_fundef F fd1 = Some fd2 \<Longrightarrow> fundef_locals fd1 = fundef_locals fd2"
  by (cases fd1) (auto simp: bind_eq_Some_conv)

lemma if_then_None_else_Some_eq[simp]:
  "(if a then None else Some b) = Some c \<longleftrightarrow> \<not> a \<and> b = c"
  "(if a then None else Some b) = None \<longleftrightarrow> a"
  by (cases a) simp_all

lemma
  assumes "compile_fundef F fd1 = Some fd2"
  shows
    rel_compile_fundef: "rel_fundef (=) norm_eq fd1 fd2" (is ?REL) and
    wf_compile_fundef: "Subx.wf_fundef F fd2" (is ?WF)
  unfolding atomize_conj
proof (cases fd1)
  case (Fundef bblocks1 ar ret locals)
  with assms obtain bblocks2 where
    "bblocks1 \<noteq> []" and
    lift_bblocks1:
      "ap_map_list (compile_basic_block F (map fst bblocks1) ret (ar + locals)) bblocks1 = Some bblocks2" and
    fd2_def: "fd2 = Fundef bblocks2 ar ret locals"
    by (auto simp add: bind_eq_Some_conv)

  show "?REL \<and> ?WF"
  proof (rule conjI)
    show ?REL
      unfolding Fundef fd2_def
    proof (rule fundef.rel_intros)
      show "list_all2 (rel_prod (=) (list_all2 norm_eq)) bblocks1 bblocks2"
        using lift_bblocks1
        unfolding ap_map_list_iff_list_all2
        by (auto elim: list.rel_mono_strong intro: compile_basic_block_rel_prod_all_norm_eq)
    qed simp_all
  next
    have "bblocks2 \<noteq> []"
      using \<open>bblocks1 \<noteq> []\<close> length_ap_map_list[OF lift_bblocks1] by force
    moreover have "list_all (Subx.wf_basic_block F (fst ` set bblocks1) ret (ar + locals)) bblocks2"
      using lift_bblocks1
      unfolding ap_map_list_iff_list_all2
      by (auto elim!: list_rel_imp_pred2 dest: compile_basic_block_wf)
    moreover have "fst ` set bblocks1 = fst ` set bblocks2"
      using lift_bblocks1
      unfolding ap_map_list_iff_list_all2
      by (induction bblocks1 bblocks2 rule: list.rel_induct)
        (auto simp add: compile_basic_block_def ap_map_prod_eq_Some_conv)
    ultimately show ?WF
      unfolding fd2_def
      by (auto intro: Subx.wf_fundefI)
  qed
qed

end

end

locale inca_ubx_compiler =
  inca_to_ubx_simulation Finca_empty Finca_get
  for
    Finca_empty and
    Finca_get :: "_ \<Rightarrow> 'fun \<Rightarrow> _ option" +
  fixes
    load_oracle :: "'fun \<Rightarrow> nat \<Rightarrow> type option"
begin

section \<open>Compilation of function environment\<close>

definition compile_env_entry where
  "compile_env_entry F \<equiv> \<lambda>p. ap_map_prod Some (compile_fundef (load_oracle (fst p)) F) p"

lemma rel_compile_env_entry:
  assumes "compile_env_entry F (f, fd1) = Some (f, fd2)"
  shows "rel_fundef (=) norm_eq fd1 fd2"
  using assms unfolding compile_env_entry_def
  by (auto simp: ap_map_prod_eq_Some_conv intro!: rel_compile_fundef)

definition compile_env where
  "compile_env e \<equiv> do {
    let fundefs1 = Finca_to_list e;
    fundefs2 \<leftarrow> ap_map_list (compile_env_entry (map_option funtype \<circ> Finca_get e)) fundefs1;
    Some (Subx.Fenv.from_list fundefs2)
  }"

lemma rel_ap_map_list_ap_map_list_compile_env_entries:
  assumes "ap_map_list (compile_env_entry F) xs = Some ys"
  shows "rel_fundefs (Finca_get (Sinca.Fenv.from_list xs)) (Fubx_get (Subx.Fenv.from_list ys))"
  using assms
proof (induction xs arbitrary: ys)
  case Nil
  thus ?case
    using rel_fundefs_empty by simp
next
  case (Cons x xs)
  from Cons.prems obtain y ys' where
    ys_def: "ys = y # ys'" and
    compile_env_x: "compile_env_entry F x = Some y" and
    compile_env_xs: "ap_map_list (compile_env_entry F) xs = Some ys'"
    by (auto simp add: ap_option_eq_Some_conv)

  obtain f fd1 fd2 where
    prods: "x = (f, fd1)" "y = (f, fd2)" and "compile_fundef (load_oracle f) F fd1 = Some fd2"
    using compile_env_x
    by (cases x) (auto simp: compile_env_entry_def eq_fst_iff ap_map_prod_eq_Some_conv)

  have "rel_fundef (=) norm_eq fd1 fd2"
    using compile_env_x[unfolded prods]
    by (auto intro: rel_compile_env_entry)
  thus ?case
    using Cons.IH[OF compile_env_xs, THEN rel_fundefsD]
    unfolding prods ys_def
    unfolding Sinca.Fenv.from_list_correct Subx.Fenv.from_list_correct
    by (auto intro: rel_fundefsI)
qed

lemma rel_fundefs_compile_env:
  assumes "compile_env F1 = Some F2"
  shows "rel_fundefs (Finca_get F1) (Fubx_get F2)"
proof -
  from assms obtain xs where
    ap_map_list_F1: "ap_map_list (compile_env_entry (map_option funtype \<circ> Finca_get F1)) (Finca_to_list F1) = Some xs" and
    F2_def: "F2 = Subx.Fenv.from_list xs"
    by (auto simp: compile_env_def bind_eq_Some_conv)

  show ?thesis
    using rel_ap_map_list_ap_map_list_compile_env_entries[OF ap_map_list_F1]
    unfolding F2_def Sinca.Fenv.get_from_list_to_list
    by assumption
qed

section \<open>Compilation of program\<close>

fun compile where
  "compile (Prog F1 H f) = Some Prog \<diamondop> compile_env F1 \<diamondop> Some H \<diamondop> Some f"

lemma ap_map_list_cong:
  assumes "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x" and "xs = ys"
  shows "ap_map_list f xs = ap_map_list g ys"
  using assms
  by (induction xs arbitrary: ys) auto

lemma compile_env_wf_fundefs:
  assumes "compile_env F1 = Some F2"
  shows "Subx.wf_fundefs (Fubx_get F2)"
proof (intro Subx.wf_fundefsI allI)
  fix f
  obtain xs where
    ap_map_list_F1: "ap_map_list (compile_env_entry (map_option funtype \<circ> Finca_get F1)) (Finca_to_list F1) = Some xs" and
    F2_def: "F2 = Subx.Fenv.from_list xs"
    using assms by (auto simp: compile_env_def bind_eq_Some_conv)

  have rel_map_of_F1_xs:
    "\<And>f. rel_option (\<lambda>x y. compile_fundef (load_oracle f) (map_option funtype \<circ> Finca_get F1) x = Some y)
      (map_of (Finca_to_list F1) f) (map_of xs f)"
    using ap_map_list_F1
    by (auto simp: compile_env_entry_def ap_map_prod_eq_Some_conv
        dest: ap_map_list_imp_rel_option_map_of)

  have funtype_F1_eq_funtype_F2:
    "map_option funtype \<circ> Finca_get F1 = map_option funtype \<circ> Fubx_get F2"
  proof (rule ext, simp)
    fix x
    show "map_option funtype (Finca_get F1 x) = map_option funtype (Fubx_get F2 x)"
      unfolding F2_def Subx.Fenv.from_list_correct Sinca.Fenv.to_list_correct[symmetric]
      using rel_map_of_F1_xs[of x]
      by (cases rule: option.rel_cases)
        (simp_all add: funtype_def compile_fundef_arities compile_fundef_returns)
  qed

  show "pred_option (Subx.wf_fundef (map_option funtype \<circ> Fubx_get F2)) (Fubx_get F2 f) "
  proof (cases "map_of (Finca_to_list F1) f")
    case None
    thus ?thesis
      using rel_map_of_F1_xs[of f, unfolded None]
      by (simp add: F2_def Subx.Fenv.from_list_correct)
  next
    case (Some fd1)
    show ?thesis
      using rel_map_of_F1_xs[of f, unfolded Some option_rel_Some1]
      unfolding funtype_F1_eq_funtype_F2 F2_def Subx.Fenv.from_list_correct
      by (auto intro: wf_compile_fundef)
  qed
qed

lemma compile_load:
  assumes
    compile_p1: "compile p1 = Some p2" and
    load: "Subx.load p2 s2"
  shows "\<exists>s1. Sinca.load p1 s1 \<and> match s1 s2"
proof -
  obtain F1 H main where p1_def: "p1 = Prog F1 H main"
    by (cases p1) simp
  then obtain F2 where
    compile_F1: "compile_env F1 = Some F2" and
    p2_def: "p2 = Prog F2 H main"
    using compile_p1
    by (auto simp: ap_option_eq_Some_conv)

  note rel_F1_F2 = rel_fundefs_compile_env[OF compile_F1]

  show ?thesis
    using assms(2) unfolding p2_def Subx.load_def
  proof (cases _ _ _ s2 rule: Global.load.cases)
    case (1 fd2)
    then obtain fd1 where
      F1_main: "Finca_get F1 main = Some fd1" and rel_fd1_fd2: "rel_fundef (=) norm_eq fd1 fd2"
      using rel_fundefs_Some2[OF rel_F1_F2]
      by auto

    let ?s1 = "State F1 H [allocate_frame main fd1 [] uninitialized]"

    show ?thesis
    proof (intro exI conjI)
      show "Sinca.load p1 ?s1"
        unfolding Sinca.load_def p1_def
        using 1 F1_main rel_fd1_fd2
        by (auto simp: rel_fundef_arities intro!: Global.load.intros dest: rel_fundef_body_length)
    next
      have "Subx.wf_state s2"
        unfolding 1
        using compile_F1
        by (auto intro!: Subx.wf_stateI intro: compile_env_wf_fundefs)
      then show "match ?s1 s2"
        using 1 rel_F1_F2 rel_fd1_fd2
        by (auto simp: allocate_frame_def rel_fundef_locals
            simp: rel_fundef_rel_fst_hd_bodies[OF rel_fd1_fd2 disjI2]
            intro!: match.intros rel_stacktraces.intros intro: Subx.sp_instrs.Nil)
    qed
  qed
qed

interpretation std_to_inca_compiler:
  compiler Sinca.step Subx.step "final Finca_get Inca.IReturn" "final Fubx_get Ubx.IReturn"
    Sinca.load Subx.load
    "\<lambda>_ _. False" "\<lambda>_. match" compile
using compile_load
  by unfold_locales auto

subsection \<open>Completeness of compilation\<close>

lemma lift_instr_None_preservation:
  assumes "lift_instr F L ret N instr \<Sigma> = Some (instr', \<Sigma>')" and "list_all ((=) None) \<Sigma>"
  shows "list_all ((=) None) \<Sigma>'"
  using assms
  by (cases "(F, L, ret, N, instr, \<Sigma>)" rule: lift_instr.cases)
    (auto simp: Let_def bind_eq_Some_conv)

lemma lift_instr_complete:
  assumes
    "Sinca.local_var_in_range N instr" and
    "Sinca.jump_in_range (set L) instr" and
    "Sinca.fun_call_in_range F instr" and
    "Sinca.sp_instr F ret instr (length \<Sigma>) k" and
    "list_all ((=) None) \<Sigma>"
  shows "\<exists>instr' \<Sigma>'. lift_instr F L ret N instr \<Sigma> = Some (instr', \<Sigma>') \<and> length \<Sigma>' = k"
  using assms
  by (cases "(F, L, ret, N, instr, \<Sigma>)" rule: lift_instr.cases)
    (auto simp add: in_set_member Let_def
      dest: Map.domD dest!: list_all_eq_const_imp_replicate' elim: Sinca.sp_instr.cases)

lemma lift_instrs_complete:
  fixes \<Sigma> :: "type option list"
  assumes
    "list_all (Sinca.local_var_in_range N) instrs" and
    "list_all (Sinca.jump_in_range (set L)) instrs" and
    "list_all (Sinca.fun_call_in_range F) instrs" and
    "Sinca.sp_instrs F ret instrs (length \<Sigma>) k" and
    "list_all ((=) None) \<Sigma>"
  shows "\<exists>\<Sigma>' instrs'. lift_instrs F L ret N \<Sigma> instrs = Some (\<Sigma>', instrs') \<and> length \<Sigma>' = k"
  using assms
proof (induction instrs arbitrary: \<Sigma>)
  case Nil
  thus ?case
    unfolding lift_instrs_def
    by (auto elim: Sinca.sp_instrs.cases)
next
  case (Cons instr instrs')
  from Cons.prems(4) obtain k' where
    sp_head: "Sinca.sp_instr F ret instr (length \<Sigma>) k'" and
    sp_tail: "Sinca.sp_instrs F ret instrs' k' k"
    by (cases rule: Sinca.sp_instrs.cases) simp

  have inv_instrs':
    "list_all (Sinca.local_var_in_range N) instrs'"
    "list_all (Sinca.jump_in_range (set L)) instrs'"
    "list_all (Sinca.fun_call_in_range F) instrs'"
    using Cons.prems(1-3) by simp_all

  from Cons.prems(1-3,5) obtain instr2 \<Sigma>tmp where
    lift_head: "lift_instr F L ret N instr \<Sigma> = Some (instr2, \<Sigma>tmp)" and
    "length \<Sigma>tmp = k'"
    using lift_instr_complete[OF _ _ _ sp_head, of N L] by auto
  hence "list_all ((=) None) \<Sigma>tmp"
    by (meson Cons.prems(5) lift_instr_None_preservation)
  then obtain instrs2 and \<Sigma>' :: "type option list" where
    lift_tail: "lift_instrs F L ret N \<Sigma>tmp instrs' = Some (\<Sigma>', instrs2)" and
    "length \<Sigma>' = k"
    using Cons.IH[OF inv_instrs', of \<Sigma>tmp] sp_tail
    unfolding \<open>length \<Sigma>tmp = k'\<close>
    by auto
  show ?case
  proof (intro exI conjI)
    show "lift_instrs F L ret N \<Sigma> (instr # instrs') = Some (\<Sigma>', instr2 # instrs2)"
      using lift_head lift_tail
      by (simp add: lift_instrs_def)
  next
    show "length \<Sigma>' = k"
      by (rule \<open>length \<Sigma>' = k\<close>)
  qed
qed

lemma optim_instr_complete:
  assumes sp: "Subx.sp_instr F ret instr \<Sigma> \<Sigma>'"
  shows "\<exists>\<Sigma>'' instr'. optim_instr \<O> F ret pc instr \<Sigma> = Some (instr', \<Sigma>'') \<and> length \<Sigma>' = length \<Sigma>''"
  using sp
proof (cases F ret instr \<Sigma> \<Sigma>' rule: Subx.sp_instr.cases)
  case (Push d)
  thus ?thesis
    by (cases "unbox_ubx1 d"; cases "unbox_ubx2 d") simp_all
next
  case (Get n)
  thus ?thesis
    by (cases "\<O> pc") simp_all
next
  case (Load x \<Sigma>)
  then show ?thesis
    by (cases "\<O> pc") simp_all
next
  case (OpInl opinl \<Sigma>)
  then show ?thesis
    by (cases "\<UU>\<bb>\<xx> opinl (replicate (\<AA>\<rr>\<ii>\<tt>\<yy> (\<DD>\<ee>\<II>\<nn>\<ll> opinl)) None)")
      (simp_all add: Let_def Subx.\<UU>\<bb>\<xx>_opubx_type)
qed simp_all

lemma compile_basic_block_complete:
  assumes wf_bblock1: "Sinca.wf_basic_block F (set L) ret n bblock1"
  shows "\<exists>bblock2. compile_basic_block \<O> F L ret n bblock1 = Some bblock2"
proof (cases bblock1)
  case (Pair label instrs1)
  moreover obtain instrs2 where
    "lift_instrs F L ret n ([] :: type option list) instrs1 = Some ([], instrs2)"
    using wf_bblock1[unfolded Pair, simplified]
    using lift_instrs_complete[of n instrs1 L F ret "[]" 0]
    by (auto simp: Sinca.wf_basic_block_def)
  ultimately show ?thesis
    using wf_bblock1[unfolded Pair, simplified]
    apply (simp add: compile_basic_block_def ap_map_prod_eq_Some_conv)
    by (cases "optim_instrs \<O> F ret 0 [] instrs2") (auto simp: Sinca.wf_basic_block_def)
qed

lemma bind_eq_map_option[simp]: "x \<bind> (\<lambda>y. Some (f y)) = map_option f x"
  by (cases x) simp_all

lemma compile_fundef_complete:
  assumes wf_fd1: "Sinca.wf_fundef F fd1"
  shows "\<exists>fd2. compile_fundef \<O> F fd1 = Some fd2"
proof (cases fd1)
  case (Fundef bblocks ar ret locals)
  then obtain bblock bblocks' where bblocks_def: "bblocks = bblock # bblocks'"
    using wf_fd1 by (cases bblocks; auto simp: Sinca.wf_fundef_def)
  obtain label instrs where "bblock = (label, instrs)"
    by (cases bblock) simp
  show ?thesis
    using wf_fd1
    by (auto simp add: Fundef Sinca.wf_fundef_def
        intro!: ex_ap_map_list_eq_SomeI intro: compile_basic_block_complete
        elim!: list.pred_mono_strong)
qed

lemma compile_env_entry_complete:
  assumes wf_fd1: "Sinca.wf_fundef F fd1"
  shows "\<exists>fd2. compile_env_entry F (f, fd1) = Some fd2"
    using compile_fundef_complete[OF wf_fd1]
    by (simp add: compile_env_entry_def ap_map_prod_eq_Some_conv)

lemma compile_env_complete:
  assumes wf_F1: "pred_map (Sinca.wf_fundef (map_option funtype \<circ> Finca_get F1)) (Finca_get F1)"
  shows "\<exists>F2. compile_env F1 = Some F2"
proof -
  show ?thesis
    using wf_F1
    by (auto simp add: compile_env_def
        intro: ex_ap_map_list_eq_SomeI Sinca.Fenv.to_list_list_allI compile_env_entry_complete
          pred_map_get)
qed

theorem compile_complete:
  assumes wf_p1: "Sinca.wf_prog p1"
  shows "\<exists>p2. compile p1 = Some p2"
proof (cases p1)
  case (Prog F1 H main)
  then show ?thesis
    using wf_p1 unfolding Sinca.wf_prog_def
    by (auto simp: Let_def dest: compile_env_complete)
qed

end

end