(*  Title:      HOL/Auth/Guard/Guard_Shared.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge
*)

section\<open>lemmas on guarded messages for protocols with symmetric keys\<close>

theory Guard_Shared imports Guard GuardK "../Shared" begin

subsection\<open>Extensions to Theory \<open>Shared\<close>\<close>

declare initState.simps [simp del]

subsubsection\<open>a little abbreviation\<close>

abbreviation
  Ciph :: "agent => msg => msg" where
  "Ciph A X == Crypt (shrK A) X"

subsubsection\<open>agent associated to a key\<close>

definition agt :: "key => agent" where
"agt K == SOME A. K = shrK A"

lemma agt_shrK [simp]: "agt (shrK A) = A"
by (simp add: agt_def)

subsubsection\<open>basic facts about \<^term>\<open>initState\<close>\<close>

lemma no_Crypt_in_parts_init [simp]: "Crypt K X \<notin> parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X \<notin> analz (initState A)"
by auto

lemma no_shrK_in_analz_init [simp]: "A \<notin> bad
\<Longrightarrow> Key (shrK A) \<notin> analz (initState Spy)"
by (auto simp: initState.simps)

lemma shrK_notin_initState_Friend [simp]: "A \<noteq> Friend C
\<Longrightarrow> Key (shrK A) \<notin> parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection\<open>sets of symmetric keys\<close>

definition shrK_set :: "key set => bool" where
"shrK_set Ks \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> (\<exists>A. K = shrK A)"

lemma in_shrK_set: "[| shrK_set Ks; K \<in> Ks |] ==> \<exists>A. K = shrK A"
by (simp add: shrK_set_def)

lemma shrK_set1 [iff]: "shrK_set {shrK A}"
by (simp add: shrK_set_def)

lemma shrK_set2 [iff]: "shrK_set {shrK A, shrK B}"
by (simp add: shrK_set_def)

subsubsection\<open>sets of good keys\<close>

definition good :: "key set \<Rightarrow> bool" where
"good Ks \<equiv> \<forall>K. K \<in> Ks \<longrightarrow> agt K \<notin> bad"

lemma in_good: "[| good Ks; K \<in> Ks |] ==> agt K \<notin> bad"
by (simp add: good_def)

lemma good1 [simp]: "A \<notin> bad \<Longrightarrow> good {shrK A}"
by (simp add: good_def)

lemma good2 [simp]: "[| A \<notin> bad; B \<notin> bad |] ==> good {shrK A, shrK B}"
by (simp add: good_def)

subsection\<open>Proofs About Guarded Messages\<close>

subsubsection\<open>small hack\<close>

lemma shrK_is_invKey_shrK: "shrK A = invKey (shrK A)"
by simp

lemmas shrK_is_invKey_shrK_substI = shrK_is_invKey_shrK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n \<in> parts {X} \<Longrightarrow> Crypt (shrK A) X \<in> guard n {shrK A}"
apply (rule shrK_is_invKey_shrK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection\<open>guardedness results on nonces\<close>

lemma guard_ciph [simp]: "shrK A \<in> Ks \<Longrightarrow> Ciph A X \<in> guard n Ks"
by (rule Guard_Nonce, simp)

lemma guardK_ciph [simp]: "shrK A \<in> Ks \<Longrightarrow> Ciph A X \<in> guardK n Ks"
by (rule Guard_Key, simp)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
==> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n \<notin> used evs
\<Longrightarrow> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "[| evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "[| evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "[| evs \<in> p; Nonce n \<notin> used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection\<open>guardedness results on keys\<close>

lemma GuardK_init [simp]: "n \<notin> range shrK \<Longrightarrow> GuardK n Ks (initState B)"
by (induct B, auto simp: GuardK_def initState.simps)

lemma GuardK_knows_max': "[| GuardK n A (knows_max' C evs); n \<notin> range shrK |]
==> GuardK n A (knows_max C evs)"
by (simp add: knows_max_def)

lemma Key_not_used_GuardK_spies [dest]: "Key n \<notin> used evs
\<Longrightarrow> GuardK n A (spies evs)"
by (auto simp: GuardK_def dest: not_used_not_known parts_sub)

lemma Key_not_used_GuardK [dest]: "[| evs \<in> p; Key n \<notin> used evs;
Gets_correct p; one_step p |] ==> GuardK n A (knows (Friend C) evs)"
by (auto simp: GuardK_def dest: known_used parts_trans)

lemma Key_not_used_GuardK_max [dest]: "[| evs \<in> p; Key n \<notin> used evs;
Gets_correct p; one_step p |] ==> GuardK n A (knows_max (Friend C) evs)"
by (auto simp: GuardK_def dest: known_max_used parts_trans)

lemma Key_not_used_GuardK_max' [dest]: "[| evs \<in> p; Key n \<notin> used evs;
Gets_correct p; one_step p |] ==> GuardK n A (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in GuardK_mono)
by (auto simp: knows_max_def)

subsubsection\<open>regular protocols\<close>

definition regular :: "event list set => bool" where
"regular p \<equiv> \<forall>evs A. evs \<in> p \<longrightarrow> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"

lemma shrK_parts_iff_bad [simp]: "[| evs \<in> p; regular p |] ==>
(Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
by (auto simp: regular_def)

lemma shrK_analz_iff_bad [simp]: "[| evs \<in> p; regular p |] ==>
(Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Guard_Nonce_analz: "[| Guard n Ks (spies evs); evs \<in> p;
shrK_set Ks; good Ks; regular p |] ==> Nonce n \<notin> analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_shrK_set, simp+, clarify)
apply (frule_tac A=A in shrK_analz_iff_bad)
by (simp add: knows_decomp)+

lemma GuardK_Key_analz:
  assumes "GuardK n Ks (spies evs)" "evs \<in> p" "shrK_set Ks"
    "good Ks" "regular p" "n \<notin> range shrK"
  shows "Key n \<notin> analz (spies evs)"
proof (rule ccontr)
  assume "\<not> Key n \<notin> analz (knows Spy evs)"
  then have *: "Key n \<in> analz (spies' evs \<union> initState Spy)"
    by (simp add: knows_decomp)
  from \<open>GuardK n Ks (spies evs)\<close>
  have "GuardK n Ks (spies' evs \<union> initState Spy)"
    by (simp add: knows_decomp)
  then have "GuardK n Ks (spies' evs)"
    and "finite (spies' evs)" "keyset (initState Spy)"
    by simp_all
  moreover have "Key n \<notin> initState Spy"
    using \<open>n \<notin> range shrK\<close> by (simp add: image_iff initState_Spy)
  ultimately obtain K
    where "K \<in> Ks" and **: "Key K \<in> analz (spies' evs \<union> initState Spy)"
    using * by (auto dest: GuardK_invKey_keyset)
  from \<open>K \<in> Ks\<close> and \<open>good Ks\<close> have "agt K \<notin> bad"
    by (auto dest: in_good)
  from \<open>K \<in> Ks\<close> \<open>shrK_set Ks\<close> obtain A
    where "K = shrK A"
    by (auto dest: in_shrK_set)
  then have "agt K \<in> bad"
    using ** \<open>evs \<in> p\<close> \<open>regular p\<close> shrK_analz_iff_bad [of evs p "agt K"]
    by (simp add: knows_decomp)
  with \<open>agt K \<notin> bad\<close> show False by simp
qed

end


(*  Title:      HOL/Auth/TLS.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge

Inductive relation "tls" for the TLS (Transport Layer Security) protocol.
This protocol is essentially the same as SSL 3.0.

Abstracted from "The TLS Protocol, Version 1.0" by Tim Dierks and Christopher
Allen, Transport Layer Security Working Group, 21 May 1997,
INTERNET-DRAFT draft-ietf-tls-protocol-03.txt.  Section numbers below refer
to that memo.

An RSA cryptosystem is assumed, and X.509v3 certificates are abstracted down
to the trivial form {A, publicKey(A)}privateKey(Server), where Server is a
global signing authority.

A is the client and B is the server, not to be confused with the constant
Server, who is in charge of all public keys.

The model assumes that no fraudulent certificates are present, but it does
assume that some private keys are to the spy.

REMARK.  The event "Notes A {|Agent B, Nonce PMS|}" appears in ClientKeyExch,
CertVerify, ClientFinished to record that A knows M.  It is a note from A to
herself.  Nobody else can see it.  In ClientKeyExch, the Spy can substitute
his own certificate for A's, but he cannot replace A's note by one for himself.

The Note event avoids a weakness in the public-key model.  Each
agent's state is recorded as the trace of messages.  When the true client (A)
invents PMS, he encrypts PMS with B's public key before sending it.  The model
does not distinguish the original occurrence of such a message from a replay.
In the shared-key model, the ability to encrypt implies the ability to
decrypt, so the problem does not arise.

Proofs would be simpler if ClientKeyExch included A's name within
Crypt KB (Nonce PMS).  As things stand, there is much overlap between proofs
about that message (which B receives) and the stronger event
Notes A {|Agent B, Nonce PMS|}.
*)

section{*The TLS Protocol: Transport Layer Security*}

theory TLS imports Public "~~/src/HOL/Library/Nat_Bijection" begin

definition certificate :: "[agent,key] => msg" where
    "certificate A KA == Crypt (priSK Server) {|Agent A, Key KA|}"

text{*TLS apparently does not require separate keypairs for encryption and
signature.  Therefore, we formalize signature as encryption using the
private encryption key.*}

datatype role = ClientRole | ServerRole

consts
  (*Pseudo-random function of Section 5*)
  PRF  :: "nat*nat*nat => nat"

  (*Client, server write keys are generated uniformly by function sessionK
    to avoid duplicating their properties.  They are distinguished by a
    tag (not a bool, to avoid the peculiarities of if-and-only-if).
    Session keys implicitly include MAC secrets.*)
  sessionK :: "(nat*nat*nat) * role => key"

abbreviation
  clientK :: "nat*nat*nat => key" where
  "clientK X == sessionK(X, ClientRole)"

abbreviation
  serverK :: "nat*nat*nat => key" where
  "serverK X == sessionK(X, ServerRole)"

specification (PRF)
  inj_PRF: "inj PRF"
  --{*the pseudo-random function is collision-free*}
   apply (rule exI [of _ "%(x,y,z). prod_encode(x, prod_encode(y,z))"])
   apply (simp add: inj_on_def prod_encode_eq)
   done

specification (sessionK)
  inj_sessionK: "inj sessionK"
  --{*sessionK is collision-free; also, no clientK clashes with any serverK.*}
   apply (rule exI [of _
         "%((x,y,z), r). prod_encode(case_role 0 1 r,
                           prod_encode(x, prod_encode(y,z)))"])
   apply (simp add: inj_on_def prod_encode_eq split: role.split)
   done

axiomatization where
  --{*sessionK makes symmetric keys*}
  isSym_sessionK: "sessionK nonces \<in> symKeys" and

  --{*sessionK never clashes with a long-term symmetric key
     (they don't exist in TLS anyway)*}
  sessionK_neq_shrK [iff]: "sessionK nonces \<noteq> shrK A"

inductive_set tls :: "event list set"
  where
   Nil:  --{*The initial, empty trace*}
         "[] \<in> tls"

 | Fake: --{*The Spy may say anything he can say.  The sender field is correct,
          but agents don't use that information.*}
         "[| evsf \<in> tls;  X \<in> synth (analz (spies evsf)) |]
          ==> Says Spy B X # evsf \<in> tls"

 | SpyKeys: --{*The spy may apply @{term PRF} and @{term sessionK}
                to available nonces*}
         "[| evsSK \<in> tls;
             {Nonce NA, Nonce NB, Nonce M} <= analz (spies evsSK) |]
          ==> Notes Spy {| Nonce (PRF(M,NA,NB)),
                           Key (sessionK((NA,NB,M),role)) |} # evsSK \<in> tls"

 | ClientHello:
         --{*(7.4.1.2)
           PA represents @{text CLIENT_VERSION}, @{text CIPHER_SUITES} and @{text COMPRESSION_METHODS}.
           It is uninterpreted but will be confirmed in the FINISHED messages.
           NA is CLIENT RANDOM, while SID is @{text SESSION_ID}.
           UNIX TIME is omitted because the protocol doesn't use it.
           May assume @{term "NA \<notin> range PRF"} because CLIENT RANDOM is
           28 bytes while MASTER SECRET is 48 bytes*}
         "[| evsCH \<in> tls;  Nonce NA \<notin> used evsCH;  NA \<notin> range PRF |]
          ==> Says A B {|Agent A, Nonce NA, Number SID, Number PA|}
                # evsCH  \<in>  tls"

 | ServerHello:
         --{*7.4.1.3 of the TLS Internet-Draft
           PB represents @{text CLIENT_VERSION}, @{text CIPHER_SUITE} and @{text COMPRESSION_METHOD}.
           SERVER CERTIFICATE (7.4.2) is always present.
           @{text CERTIFICATE_REQUEST} (7.4.4) is implied.*}
         "[| evsSH \<in> tls;  Nonce NB \<notin> used evsSH;  NB \<notin> range PRF;
             Says A' B {|Agent A, Nonce NA, Number SID, Number PA|}
               \<in> set evsSH |]
          ==> Says B A {|Nonce NB, Number SID, Number PB|} # evsSH  \<in>  tls"

 | Certificate:
         --{*SERVER (7.4.2) or CLIENT (7.4.6) CERTIFICATE.*}
         "evsC \<in> tls ==> Says B A (certificate B (pubK B)) # evsC  \<in>  tls"

 | ClientKeyExch:
         --{*CLIENT KEY EXCHANGE (7.4.7).
           The client, A, chooses PMS, the PREMASTER SECRET.
           She encrypts PMS using the supplied KB, which ought to be pubK B.
           We assume @{term "PMS \<notin> range PRF"} because a clash betweem the PMS
           and another MASTER SECRET is highly unlikely (even though
           both items have the same length, 48 bytes).
           The Note event records in the trace that she knows PMS
               (see REMARK at top). *}
         "[| evsCX \<in> tls;  Nonce PMS \<notin> used evsCX;  PMS \<notin> range PRF;
             Says B' A (certificate B KB) \<in> set evsCX |]
          ==> Says A B (Crypt KB (Nonce PMS))
              # Notes A {|Agent B, Nonce PMS|}
              # evsCX  \<in>  tls"

 | CertVerify:
        --{*The optional Certificate Verify (7.4.8) message contains the
          specific components listed in the security analysis, F.1.1.2.
          It adds the pre-master-secret, which is also essential!
          Checking the signature, which is the only use of A's certificate,
          assures B of A's presence*}
         "[| evsCV \<in> tls;
             Says B' A {|Nonce NB, Number SID, Number PB|} \<in> set evsCV;
             Notes A {|Agent B, Nonce PMS|} \<in> set evsCV |]
          ==> Says A B (Crypt (priK A) (Hash{|Nonce NB, Agent B, Nonce PMS|}))
              # evsCV  \<in>  tls"

        --{*Finally come the FINISHED messages (7.4.8), confirming PA and PB
          among other things.  The master-secret is PRF(PMS,NA,NB).
          Either party may send its message first.*}

 | ClientFinished:
        --{*The occurrence of Notes A {|Agent B, Nonce PMS|} stops the
          rule's applying when the Spy has satisfied the "Says A B" by
          repaying messages sent by the true client; in that case, the
          Spy does not know PMS and could not send ClientFinished.  One
          could simply put @{term "A\<noteq>Spy"} into the rule, but one should not
          expect the spy to be well-behaved.*}
         "[| evsCF \<in> tls;
             Says A  B {|Agent A, Nonce NA, Number SID, Number PA|}
               \<in> set evsCF;
             Says B' A {|Nonce NB, Number SID, Number PB|} \<in> set evsCF;
             Notes A {|Agent B, Nonce PMS|} \<in> set evsCF;
             M = PRF(PMS,NA,NB) |]
          ==> Says A B (Crypt (clientK(NA,NB,M))
                        (Hash{|Number SID, Nonce M,
                               Nonce NA, Number PA, Agent A,
                               Nonce NB, Number PB, Agent B|}))
              # evsCF  \<in>  tls"

 | ServerFinished:
        --{*Keeping A' and A'' distinct means B cannot even check that the
          two messages originate from the same source. *}
         "[| evsSF \<in> tls;
             Says A' B  {|Agent A, Nonce NA, Number SID, Number PA|}
               \<in> set evsSF;
             Says B  A  {|Nonce NB, Number SID, Number PB|} \<in> set evsSF;
             Says A'' B (Crypt (pubK B) (Nonce PMS)) \<in> set evsSF;
             M = PRF(PMS,NA,NB) |]
          ==> Says B A (Crypt (serverK(NA,NB,M))
                        (Hash{|Number SID, Nonce M,
                               Nonce NA, Number PA, Agent A,
                               Nonce NB, Number PB, Agent B|}))
              # evsSF  \<in>  tls"

 | ClientAccepts:
        --{*Having transmitted ClientFinished and received an identical
          message encrypted with serverK, the client stores the parameters
          needed to resume this session.  The "Notes A ..." premise is
          used to prove @{text Notes_master_imp_Crypt_PMS}.*}
         "[| evsCA \<in> tls;
             Notes A {|Agent B, Nonce PMS|} \<in> set evsCA;
             M = PRF(PMS,NA,NB);
             X = Hash{|Number SID, Nonce M,
                       Nonce NA, Number PA, Agent A,
                       Nonce NB, Number PB, Agent B|};
             Says A  B (Crypt (clientK(NA,NB,M)) X) \<in> set evsCA;
             Says B' A (Crypt (serverK(NA,NB,M)) X) \<in> set evsCA |]
          ==>
             Notes A {|Number SID, Agent A, Agent B, Nonce M|} # evsCA  \<in>  tls"

 | ServerAccepts:
        --{*Having transmitted ServerFinished and received an identical
          message encrypted with clientK, the server stores the parameters
          needed to resume this session.  The "Says A'' B ..." premise is
          used to prove @{text Notes_master_imp_Crypt_PMS}.*}
         "[| evsSA \<in> tls;
             A \<noteq> B;
             Says A'' B (Crypt (pubK B) (Nonce PMS)) \<in> set evsSA;
             M = PRF(PMS,NA,NB);
             X = Hash{|Number SID, Nonce M,
                       Nonce NA, Number PA, Agent A,
                       Nonce NB, Number PB, Agent B|};
             Says B  A (Crypt (serverK(NA,NB,M)) X) \<in> set evsSA;
             Says A' B (Crypt (clientK(NA,NB,M)) X) \<in> set evsSA |]
          ==>
             Notes B {|Number SID, Agent A, Agent B, Nonce M|} # evsSA  \<in>  tls"

 | ClientResume:
         --{*If A recalls the @{text SESSION_ID}, then she sends a FINISHED
             message using the new nonces and stored MASTER SECRET.*}
         "[| evsCR \<in> tls;
             Says A  B {|Agent A, Nonce NA, Number SID, Number PA|}: set evsCR;
             Says B' A {|Nonce NB, Number SID, Number PB|} \<in> set evsCR;
             Notes A {|Number SID, Agent A, Agent B, Nonce M|} \<in> set evsCR |]
          ==> Says A B (Crypt (clientK(NA,NB,M))
                        (Hash{|Number SID, Nonce M,
                               Nonce NA, Number PA, Agent A,
                               Nonce NB, Number PB, Agent B|}))
              # evsCR  \<in>  tls"

 | ServerResume:
         --{*Resumption (7.3):  If B finds the @{text SESSION_ID} then he can
             send a FINISHED message using the recovered MASTER SECRET*}
         "[| evsSR \<in> tls;
             Says A' B {|Agent A, Nonce NA, Number SID, Number PA|}: set evsSR;
             Says B  A {|Nonce NB, Number SID, Number PB|} \<in> set evsSR;
             Notes B {|Number SID, Agent A, Agent B, Nonce M|} \<in> set evsSR |]
          ==> Says B A (Crypt (serverK(NA,NB,M))
                        (Hash{|Number SID, Nonce M,
                               Nonce NA, Number PA, Agent A,
                               Nonce NB, Number PB, Agent B|})) # evsSR
                \<in>  tls"

 | Oops:
         --{*The most plausible compromise is of an old session key.  Losing
           the MASTER SECRET or PREMASTER SECRET is more serious but
           rather unlikely.  The assumption @{term "A\<noteq>Spy"} is essential:
           otherwise the Spy could learn session keys merely by
           replaying messages!*}
         "[| evso \<in> tls;  A \<noteq> Spy;
             Says A B (Crypt (sessionK((NA,NB,M),role)) X) \<in> set evso |]
          ==> Says A Spy (Key (sessionK((NA,NB,M),role))) # evso  \<in>  tls"

(*
Protocol goals:
* M, serverK(NA,NB,M) and clientK(NA,NB,M) will be known only to the two
     parties (though A is not necessarily authenticated).

* B upon receiving CertVerify knows that A is present (But this
    message is optional!)

* A upon receiving ServerFinished knows that B is present

* Each party who has received a FINISHED message can trust that the other
  party agrees on all message components, including PA and PB (thus foiling
  rollback attacks).
*)

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

text{*Automatically unfold the definition of "certificate"*}
declare certificate_def [simp]

text{*Injectiveness of key-generating functions*}
declare inj_PRF [THEN inj_eq, iff]
declare inj_sessionK [THEN inj_eq, iff]
declare isSym_sessionK [simp]

(*** clientK and serverK make symmetric keys; no clashes with pubK or priK ***)

lemma pubK_neq_sessionK [iff]: "publicKey b A \<noteq> sessionK arg"
by (simp add: symKeys_neq_imp_neq)

declare pubK_neq_sessionK [THEN not_sym, iff]

lemma priK_neq_sessionK [iff]: "invKey (publicKey b A) \<noteq> sessionK arg"
by (simp add: symKeys_neq_imp_neq)

declare priK_neq_sessionK [THEN not_sym, iff]

lemmas keys_distinct = pubK_neq_sessionK priK_neq_sessionK

subsection{*Protocol Proofs*}

text{*Possibility properties state that some traces run the protocol to the
end.  Four paths and 12 rules are considered.*}

(** These proofs assume that the Nonce_supply nonces
        (which have the form  @ N. Nonce N \<notin> used evs)
    lie outside the range of PRF.  It seems reasonable, but as it is needed
    only for the possibility theorems, it is not taken as an axiom.
**)

text{*Possibility property ending with ClientAccepts.*}
lemma "[| \<forall>evs. (@ N. Nonce N \<notin> used evs) \<notin> range PRF;  A \<noteq> B |]
      ==> \<exists>SID M. \<exists>evs \<in> tls.
            Notes A {|Number SID, Agent A, Agent B, Nonce M|} \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] tls.Nil
                    [THEN tls.ClientHello, THEN tls.ServerHello,
                     THEN tls.Certificate, THEN tls.ClientKeyExch,
                     THEN tls.ClientFinished, THEN tls.ServerFinished,
                     THEN tls.ClientAccepts], possibility, blast+)
done

text{*And one for ServerAccepts.  Either FINISHED message may come first.*}
lemma "[| \<forall>evs. (@ N. Nonce N \<notin> used evs) \<notin> range PRF; A \<noteq> B |]
      ==> \<exists>SID NA PA NB PB M. \<exists>evs \<in> tls.
           Notes B {|Number SID, Agent A, Agent B, Nonce M|} \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] tls.Nil
                    [THEN tls.ClientHello, THEN tls.ServerHello,
                     THEN tls.Certificate, THEN tls.ClientKeyExch,
                     THEN tls.ServerFinished, THEN tls.ClientFinished,
                     THEN tls.ServerAccepts], possibility, blast+)
done

text{*Another one, for CertVerify (which is optional)*}
lemma "[| \<forall>evs. (@ N. Nonce N \<notin> used evs) \<notin> range PRF;  A \<noteq> B |]
       ==> \<exists>NB PMS. \<exists>evs \<in> tls.
              Says A B (Crypt (priK A) (Hash{|Nonce NB, Agent B, Nonce PMS|}))
                \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] tls.Nil
                    [THEN tls.ClientHello, THEN tls.ServerHello,
                     THEN tls.Certificate, THEN tls.ClientKeyExch,
                     THEN tls.CertVerify], possibility, blast+)
done

text{*Another one, for session resumption (both ServerResume and ClientResume).
  NO tls.Nil here: we refer to a previous session, not the empty trace.*}
lemma "[| evs0 \<in> tls;
          Notes A {|Number SID, Agent A, Agent B, Nonce M|} \<in> set evs0;
          Notes B {|Number SID, Agent A, Agent B, Nonce M|} \<in> set evs0;
          \<forall>evs. (@ N. Nonce N \<notin> used evs) \<notin> range PRF;
          A \<noteq> B |]
      ==> \<exists>NA PA NB PB X. \<exists>evs \<in> tls.
                X = Hash{|Number SID, Nonce M,
                          Nonce NA, Number PA, Agent A,
                          Nonce NB, Number PB, Agent B|}  &
                Says A B (Crypt (clientK(NA,NB,M)) X) \<in> set evs  &
                Says B A (Crypt (serverK(NA,NB,M)) X) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] tls.ClientHello
                    [THEN tls.ServerHello,
                     THEN tls.ServerResume, THEN tls.ClientResume], possibility, blast+)
done

subsection{*Inductive proofs about tls*}

(** Theorems of the form X \<notin> parts (spies evs) imply that NOBODY
    sends messages containing X! **)

text{*Spy never sees a good agent's private key!*}
lemma Spy_see_priK [simp]:
     "evs \<in> tls ==> (Key (privateKey b A) \<in> parts (spies evs)) = (A \<in> bad)"
by (erule tls.induct, force, simp_all, blast)

lemma Spy_analz_priK [simp]:
     "evs \<in> tls ==> (Key (privateKey b A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Spy_see_priK_D [dest!]:
    "[|Key (privateKey b A) \<in> parts (knows Spy evs);  evs \<in> tls|] ==> A \<in> bad"
by (blast dest: Spy_see_priK)

text{*This lemma says that no false certificates exist.  One might extend the
  model to include bogus certificates for the agents, but there seems
  little point in doing so: the loss of their private keys is a worse
  breach of security.*}
lemma certificate_valid:
    "[| certificate B KB \<in> parts (spies evs);  evs \<in> tls |] ==> KB = pubK B"
apply (erule rev_mp)
apply (erule tls.induct, force, simp_all, blast)
done

lemmas CX_KB_is_pubKB = Says_imp_spies [THEN parts.Inj, THEN certificate_valid]

subsubsection{*Properties of items found in Notes*}

lemma Notes_Crypt_parts_spies:
     "[| Notes A {|Agent B, X|} \<in> set evs;  evs \<in> tls |]
      ==> Crypt (pubK B) X \<in> parts (spies evs)"
apply (erule rev_mp)
apply (erule tls.induct,
       frule_tac [7] CX_KB_is_pubKB, force, simp_all)
apply (blast intro: parts_insertI)
done

text{*C may be either A or B*}
lemma Notes_master_imp_Crypt_PMS:
     "[| Notes C {|s, Agent A, Agent B, Nonce(PRF(PMS,NA,NB))|} \<in> set evs;
         evs \<in> tls |]
      ==> Crypt (pubK B) (Nonce PMS) \<in> parts (spies evs)"
apply (erule rev_mp)
apply (erule tls.induct, force, simp_all)
txt{*Fake*}
apply (blast intro: parts_insertI)
txt{*Client, Server Accept*}
apply (blast dest!: Notes_Crypt_parts_spies)+
done

text{*Compared with the theorem above, both premise and conclusion are stronger*}
lemma Notes_master_imp_Notes_PMS:
     "[| Notes A {|s, Agent A, Agent B, Nonce(PRF(PMS,NA,NB))|} \<in> set evs;
         evs \<in> tls |]
      ==> Notes A {|Agent B, Nonce PMS|} \<in> set evs"
apply (erule rev_mp)
apply (erule tls.induct, force, simp_all)
txt{*ServerAccepts*}
apply blast
done

subsubsection{*Protocol goal: if B receives CertVerify, then A sent it*}

text{*B can check A's signature if he has received A's certificate.*}
lemma TrustCertVerify_lemma:
     "[| X \<in> parts (spies evs);
         X = Crypt (priK A) (Hash{|nb, Agent B, pms|});
         evs \<in> tls;  A \<notin> bad |]
      ==> Says A B X \<in> set evs"
apply (erule rev_mp, erule ssubst)
apply (erule tls.induct, force, simp_all, blast)
done

text{*Final version: B checks X using the distributed KA instead of priK A*}
lemma TrustCertVerify:
     "[| X \<in> parts (spies evs);
         X = Crypt (invKey KA) (Hash{|nb, Agent B, pms|});
         certificate A KA \<in> parts (spies evs);
         evs \<in> tls;  A \<notin> bad |]
      ==> Says A B X \<in> set evs"
by (blast dest!: certificate_valid intro!: TrustCertVerify_lemma)

text{*If CertVerify is present then A has chosen PMS.*}
lemma UseCertVerify_lemma:
     "[| Crypt (priK A) (Hash{|nb, Agent B, Nonce PMS|}) \<in> parts (spies evs);
         evs \<in> tls;  A \<notin> bad |]
      ==> Notes A {|Agent B, Nonce PMS|} \<in> set evs"
apply (erule rev_mp)
apply (erule tls.induct, force, simp_all, blast)
done

text{*Final version using the distributed KA instead of priK A*}
lemma UseCertVerify:
     "[| Crypt (invKey KA) (Hash{|nb, Agent B, Nonce PMS|})
           \<in> parts (spies evs);
         certificate A KA \<in> parts (spies evs);
         evs \<in> tls;  A \<notin> bad |]
      ==> Notes A {|Agent B, Nonce PMS|} \<in> set evs"
by (blast dest!: certificate_valid intro!: UseCertVerify_lemma)

lemma no_Notes_A_PRF [simp]:
     "evs \<in> tls ==> Notes A {|Agent B, Nonce (PRF x)|} \<notin> set evs"
apply (erule tls.induct, force, simp_all)
txt{*ClientKeyExch: PMS is assumed to differ from any PRF.*}
apply blast
done

lemma MS_imp_PMS [dest!]:
     "[| Nonce (PRF (PMS,NA,NB)) \<in> parts (spies evs);  evs \<in> tls |]
      ==> Nonce PMS \<in> parts (spies evs)"
apply (erule rev_mp)
apply (erule tls.induct, force, simp_all)
txt{*Fake*}
apply (blast intro: parts_insertI)
txt{*Easy, e.g. by freshness*}
apply (blast dest: Notes_Crypt_parts_spies)+
done

subsubsection{*Unicity results for PMS, the pre-master-secret*}

text{*PMS determines B.*}
lemma Crypt_unique_PMS:
     "[| Crypt(pubK B)  (Nonce PMS) \<in> parts (spies evs);
         Crypt(pubK B') (Nonce PMS) \<in> parts (spies evs);
         Nonce PMS \<notin> analz (spies evs);
         evs \<in> tls |]
      ==> B=B'"
apply (erule rev_mp, erule rev_mp, erule rev_mp)
apply (erule tls.induct, analz_mono_contra, force, simp_all (no_asm_simp))
txt{*Fake, ClientKeyExch*}
apply blast+
done

(** It is frustrating that we need two versions of the unicity results.
    But Notes A {|Agent B, Nonce PMS|} determines both A and B.  Sometimes
    we have only the weaker assertion Crypt(pubK B) (Nonce PMS), which
    determines B alone, and only if PMS is secret.
**)

text{*In A's internal Note, PMS determines A and B.*}
lemma Notes_unique_PMS:
     "[| Notes A  {|Agent B,  Nonce PMS|} \<in> set evs;
         Notes A' {|Agent B', Nonce PMS|} \<in> set evs;
         evs \<in> tls |]
      ==> A=A' & B=B'"
apply (erule rev_mp, erule rev_mp)
apply (erule tls.induct, force, simp_all)
txt{*ClientKeyExch*}
apply (blast dest!: Notes_Crypt_parts_spies)
done

subsection{*Secrecy Theorems*}

text{*Key compromise lemma needed to prove @{term analz_image_keys}.
  No collection of keys can help the spy get new private keys.*}
lemma analz_image_priK [rule_format]:
     "evs \<in> tls
      ==> \<forall>KK. (Key(priK B) \<in> analz (Key`KK Un (spies evs))) =
          (priK B \<in> KK | B \<in> bad)"
apply (erule tls.induct)
apply (simp_all (no_asm_simp)
                del: image_insert
                add: image_Un [THEN sym]
                     insert_Key_image Un_assoc [THEN sym])
txt{*Fake*}
apply spy_analz
done

text{*slightly speeds up the big simplification below*}
lemma range_sessionkeys_not_priK:
     "KK <= range sessionK ==> priK B \<notin> KK"
by blast

text{*Lemma for the trivial direction of the if-and-only-if*}
lemma analz_image_keys_lemma:
     "(X \<in> analz (G Un H)) --> (X \<in> analz H)  ==>
      (X \<in> analz (G Un H))  =  (X \<in> analz H)"
by (blast intro: analz_mono [THEN subsetD])

(** Strangely, the following version doesn't work:
\<forall>Z. (Nonce N \<in> analz (Key`(sessionK`Z) Un (spies evs))) =
    (Nonce N \<in> analz (spies evs))"
**)

lemma analz_image_keys [rule_format]:
     "evs \<in> tls ==>
      \<forall>KK. KK <= range sessionK -->
              (Nonce N \<in> analz (Key`KK Un (spies evs))) =
              (Nonce N \<in> analz (spies evs))"
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (safe del: iffI)
apply (safe del: impI iffI intro!: analz_image_keys_lemma)
apply (simp_all (no_asm_simp)               (*faster*)
                del: image_insert imp_disjL (*reduces blow-up*)
                add: image_Un [THEN sym]  Un_assoc [THEN sym]
                     insert_Key_singleton
                     range_sessionkeys_not_priK analz_image_priK)
apply (simp_all add: insert_absorb)
txt{*Fake*}
apply spy_analz
done

text{*Knowing some session keys is no help in getting new nonces*}
lemma analz_insert_key [simp]:
     "evs \<in> tls ==>
      (Nonce N \<in> analz (insert (Key (sessionK z)) (spies evs))) =
      (Nonce N \<in> analz (spies evs))"
by (simp del: image_insert
         add: insert_Key_singleton analz_image_keys)

subsubsection{*Protocol goal: serverK(Na,Nb,M) and clientK(Na,Nb,M) remain secure*}

(** Some lemmas about session keys, comprising clientK and serverK **)

text{*Lemma: session keys are never used if PMS is fresh.
  Nonces don't have to agree, allowing session resumption.
  Converse doesn't hold; revealing PMS doesn't force the keys to be sent.
  THEY ARE NOT SUITABLE AS SAFE ELIM RULES.*}
lemma PMS_lemma:
     "[| Nonce PMS \<notin> parts (spies evs);
         K = sessionK((Na, Nb, PRF(PMS,NA,NB)), role);
         evs \<in> tls |]
   ==> Key K \<notin> parts (spies evs) & (\<forall>Y. Crypt K Y \<notin> parts (spies evs))"
apply (erule rev_mp, erule ssubst)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*Fake*}
apply (blast intro: parts_insertI)
txt{*SpyKeys*}
apply blast
txt{*Many others*}
apply (force dest!: Notes_Crypt_parts_spies Notes_master_imp_Crypt_PMS)+
done

lemma PMS_sessionK_not_spied:
     "[| Key (sessionK((Na, Nb, PRF(PMS,NA,NB)), role)) \<in> parts (spies evs);
         evs \<in> tls |]
      ==> Nonce PMS \<in> parts (spies evs)"
by (blast dest: PMS_lemma)

lemma PMS_Crypt_sessionK_not_spied:
     "[| Crypt (sessionK((Na, Nb, PRF(PMS,NA,NB)), role)) Y
           \<in> parts (spies evs);  evs \<in> tls |]
      ==> Nonce PMS \<in> parts (spies evs)"
by (blast dest: PMS_lemma)

text{*Write keys are never sent if M (MASTER SECRET) is secure.
  Converse fails; betraying M doesn't force the keys to be sent!
  The strong Oops condition can be weakened later by unicity reasoning,
  with some effort.
  NO LONGER USED: see @{text clientK_not_spied} and @{text serverK_not_spied}*}
lemma sessionK_not_spied:
     "[| \<forall>A. Says A Spy (Key (sessionK((NA,NB,M),role))) \<notin> set evs;
         Nonce M \<notin> analz (spies evs);  evs \<in> tls |]
      ==> Key (sessionK((NA,NB,M),role)) \<notin> parts (spies evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule tls.induct, analz_mono_contra)
apply (force, simp_all (no_asm_simp))
txt{*Fake, SpyKeys*}
apply blast+
done

text{*If A sends ClientKeyExch to an honest B, then the PMS will stay secret.*}
lemma Spy_not_see_PMS:
     "[| Notes A {|Agent B, Nonce PMS|} \<in> set evs;
         evs \<in> tls;  A \<notin> bad;  B \<notin> bad |]
      ==> Nonce PMS \<notin> analz (spies evs)"
apply (erule rev_mp, erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*Fake*}
apply spy_analz
txt{*SpyKeys*}
apply force
apply (simp_all add: insert_absorb)
txt{*ClientHello, ServerHello, ClientKeyExch: mostly freshness reasoning*}
apply (blast dest: Notes_Crypt_parts_spies)
apply (blast dest: Notes_Crypt_parts_spies)
apply (blast dest: Notes_Crypt_parts_spies)
txt{*ClientAccepts and ServerAccepts: because @{term "PMS \<notin> range PRF"}*}
apply force+
done

text{*If A sends ClientKeyExch to an honest B, then the MASTER SECRET
  will stay secret.*}
lemma Spy_not_see_MS:
     "[| Notes A {|Agent B, Nonce PMS|} \<in> set evs;
         evs \<in> tls;  A \<notin> bad;  B \<notin> bad |]
      ==> Nonce (PRF(PMS,NA,NB)) \<notin> analz (spies evs)"
apply (erule rev_mp, erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*Fake*}
apply spy_analz
txt{*SpyKeys: by secrecy of the PMS, Spy cannot make the MS*}
apply (blast dest!: Spy_not_see_PMS)
apply (simp_all add: insert_absorb)
txt{*ClientAccepts and ServerAccepts: because PMS was already visible;
  others, freshness etc.*}
apply (blast dest: Notes_Crypt_parts_spies Spy_not_see_PMS
                   Notes_imp_knows_Spy [THEN analz.Inj])+
done

subsubsection{*Weakening the Oops conditions for leakage of clientK*}

text{*If A created PMS then nobody else (except the Spy in replays)
  would send a message using a clientK generated from that PMS.*}
lemma Says_clientK_unique:
     "[| Says A' B' (Crypt (clientK(Na,Nb,PRF(PMS,NA,NB))) Y) \<in> set evs;
         Notes A {|Agent B, Nonce PMS|} \<in> set evs;
         evs \<in> tls;  A' \<noteq> Spy |]
      ==> A = A'"
apply (erule rev_mp, erule rev_mp)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all)
txt{*ClientKeyExch*}
apply (blast dest!: PMS_Crypt_sessionK_not_spied)
txt{*ClientFinished, ClientResume: by unicity of PMS*}
apply (blast dest!: Notes_master_imp_Notes_PMS
             intro: Notes_unique_PMS [THEN conjunct1])+
done

text{*If A created PMS and has not leaked her clientK to the Spy,
  then it is completely secure: not even in parts!*}
lemma clientK_not_spied:
     "[| Notes A {|Agent B, Nonce PMS|} \<in> set evs;
         Says A Spy (Key (clientK(Na,Nb,PRF(PMS,NA,NB)))) \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;
         evs \<in> tls |]
      ==> Key (clientK(Na,Nb,PRF(PMS,NA,NB))) \<notin> parts (spies evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*ClientKeyExch*}
apply blast
txt{*SpyKeys*}
apply (blast dest!: Spy_not_see_MS)
txt{*ClientKeyExch*}
apply (blast dest!: PMS_sessionK_not_spied)
txt{*Oops*}
apply (blast intro: Says_clientK_unique)
done

subsubsection{*Weakening the Oops conditions for leakage of serverK*}

text{*If A created PMS for B, then nobody other than B or the Spy would
  send a message using a serverK generated from that PMS.*}
lemma Says_serverK_unique:
     "[| Says B' A' (Crypt (serverK(Na,Nb,PRF(PMS,NA,NB))) Y) \<in> set evs;
         Notes A {|Agent B, Nonce PMS|} \<in> set evs;
         evs \<in> tls;  A \<notin> bad;  B \<notin> bad;  B' \<noteq> Spy |]
      ==> B = B'"
apply (erule rev_mp, erule rev_mp)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all)
txt{*ClientKeyExch*}
apply (blast dest!: PMS_Crypt_sessionK_not_spied)
txt{*ServerResume, ServerFinished: by unicity of PMS*}
apply (blast dest!: Notes_master_imp_Crypt_PMS
             dest: Spy_not_see_PMS Notes_Crypt_parts_spies Crypt_unique_PMS)+
done

text{*If A created PMS for B, and B has not leaked his serverK to the Spy,
  then it is completely secure: not even in parts!*}
lemma serverK_not_spied:
     "[| Notes A {|Agent B, Nonce PMS|} \<in> set evs;
         Says B Spy (Key(serverK(Na,Nb,PRF(PMS,NA,NB)))) \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> tls |]
      ==> Key (serverK(Na,Nb,PRF(PMS,NA,NB))) \<notin> parts (spies evs)"
apply (erule rev_mp, erule rev_mp)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*Fake*}
apply blast
txt{*SpyKeys*}
apply (blast dest!: Spy_not_see_MS)
txt{*ClientKeyExch*}
apply (blast dest!: PMS_sessionK_not_spied)
txt{*Oops*}
apply (blast intro: Says_serverK_unique)
done

subsubsection{*Protocol goals: if A receives ServerFinished, then B is present
     and has used the quoted values PA, PB, etc.  Note that it is up to A
     to compare PA with what she originally sent.*}

text{*The mention of her name (A) in X assures A that B knows who she is.*}
lemma TrustServerFinished [rule_format]:
     "[| X = Crypt (serverK(Na,Nb,M))
               (Hash{|Number SID, Nonce M,
                      Nonce Na, Number PA, Agent A,
                      Nonce Nb, Number PB, Agent B|});
         M = PRF(PMS,NA,NB);
         evs \<in> tls;  A \<notin> bad;  B \<notin> bad |]
      ==> Says B Spy (Key(serverK(Na,Nb,M))) \<notin> set evs -->
          Notes A {|Agent B, Nonce PMS|} \<in> set evs -->
          X \<in> parts (spies evs) --> Says B A X \<in> set evs"
apply (erule ssubst)+
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*Fake: the Spy doesn't have the critical session key!*}
apply (blast dest: serverK_not_spied)
txt{*ClientKeyExch*}
apply (blast dest!: PMS_Crypt_sessionK_not_spied)
done

text{*This version refers not to ServerFinished but to any message from B.
  We don't assume B has received CertVerify, and an intruder could
  have changed A's identity in all other messages, so we can't be sure
  that B sends his message to A.  If CLIENT KEY EXCHANGE were augmented
  to bind A's identity with PMS, then we could replace A' by A below.*}
lemma TrustServerMsg [rule_format]:
     "[| M = PRF(PMS,NA,NB);  evs \<in> tls;  A \<notin> bad;  B \<notin> bad |]
      ==> Says B Spy (Key(serverK(Na,Nb,M))) \<notin> set evs -->
          Notes A {|Agent B, Nonce PMS|} \<in> set evs -->
          Crypt (serverK(Na,Nb,M)) Y \<in> parts (spies evs)  -->
          (\<exists>A'. Says B A' (Crypt (serverK(Na,Nb,M)) Y) \<in> set evs)"
apply (erule ssubst)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp) add: ex_disj_distrib)
txt{*Fake: the Spy doesn't have the critical session key!*}
apply (blast dest: serverK_not_spied)
txt{*ClientKeyExch*}
apply (clarify, blast dest!: PMS_Crypt_sessionK_not_spied)
txt{*ServerResume, ServerFinished: by unicity of PMS*}
apply (blast dest!: Notes_master_imp_Crypt_PMS
             dest: Spy_not_see_PMS Notes_Crypt_parts_spies Crypt_unique_PMS)+
done

subsubsection{*Protocol goal: if B receives any message encrypted with clientK
      then A has sent it*}

text{*ASSUMING that A chose PMS.  Authentication is
     assumed here; B cannot verify it.  But if the message is
     ClientFinished, then B can then check the quoted values PA, PB, etc.*}

lemma TrustClientMsg [rule_format]:
     "[| M = PRF(PMS,NA,NB);  evs \<in> tls;  A \<notin> bad;  B \<notin> bad |]
      ==> Says A Spy (Key(clientK(Na,Nb,M))) \<notin> set evs -->
          Notes A {|Agent B, Nonce PMS|} \<in> set evs -->
          Crypt (clientK(Na,Nb,M)) Y \<in> parts (spies evs) -->
          Says A B (Crypt (clientK(Na,Nb,M)) Y) \<in> set evs"
apply (erule ssubst)
apply (erule tls.induct, frule_tac [7] CX_KB_is_pubKB)
apply (force, simp_all (no_asm_simp))
txt{*Fake: the Spy doesn't have the critical session key!*}
apply (blast dest: clientK_not_spied)
txt{*ClientKeyExch*}
apply (blast dest!: PMS_Crypt_sessionK_not_spied)
txt{*ClientFinished, ClientResume: by unicity of PMS*}
apply (blast dest!: Notes_master_imp_Notes_PMS dest: Notes_unique_PMS)+
done

subsubsection{*Protocol goal: if B receives ClientFinished, and if B is able to
     check a CertVerify from A, then A has used the quoted
     values PA, PB, etc.  Even this one requires A to be uncompromised.*}
lemma AuthClientFinished:
     "[| M = PRF(PMS,NA,NB);
         Says A Spy (Key(clientK(Na,Nb,M))) \<notin> set evs;
         Says A' B (Crypt (clientK(Na,Nb,M)) Y) \<in> set evs;
         certificate A KA \<in> parts (spies evs);
         Says A'' B (Crypt (invKey KA) (Hash{|nb, Agent B, Nonce PMS|}))
           \<in> set evs;
         evs \<in> tls;  A \<notin> bad;  B \<notin> bad |]
      ==> Says A B (Crypt (clientK(Na,Nb,M)) Y) \<in> set evs"
by (blast intro!: TrustClientMsg UseCertVerify)

(*22/9/97: loads in 622s, which is 10 minutes 22 seconds*)
(*24/9/97: loads in 672s, which is 11 minutes 12 seconds [stronger theorems]*)
(*29/9/97: loads in 481s, after removing Certificate from ClientKeyExch*)
(*30/9/97: loads in 476s, after removing unused theorems*)
(*30/9/97: loads in 448s, after fixing ServerResume*)

(*08/9/97: loads in 189s (pike), after much reorganization,
           back to 621s on albatross?*)

(*10/2/99: loads in 139s (pike)
           down to 433s on albatross*)

(*5/5/01: conversion to Isar script
          loads in 137s (perch)
          the last ML version loaded in 122s on perch, a 600MHz machine:
                twice as fast as pike.  No idea why it's so much slower!
          The Isar script is slower still, perhaps because simp_all simplifies
          the assumptions be default.
*)

(*20/11/11: loads in 5.8s elapses time, 9.3s CPU time on dual-core laptop*)

end


theory SafeSubRename
  imports WTLemma SubstExp
begin

definition rename_use_env where
  "rename_use_env r_s x y = (add_use_env (rem_use_env r_s x) y (r_s x))"

lemma rename_leq_use_env: "\<lbrakk> leq_use_env r_x r_s \<rbrakk> \<Longrightarrow>
  leq_use_env (rename_use_env r_x x y) (rename_use_env r_s x y)"
  apply (simp add: leq_use_env_def)
  apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: rem_use_env_def)
  done

lemma rename_ereq_use_env: "ereq_use_env y tau = rename_use_env (ereq_use_env x tau) x y"
  apply (case_tac "\<forall> x'. ereq_use_env y tau x' = rename_use_env (ereq_use_env x tau) x y x'")
   apply (auto)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_ereq_use_env2: "\<lbrakk> z \<noteq> x ; z \<noteq> y\<rbrakk> \<Longrightarrow> ereq_use_env z tau = rename_use_env (ereq_use_env z tau) x y"
  apply (case_tac "\<forall> x'. ereq_use_env z tau x' = rename_use_env (ereq_use_env z tau) x y x'")
   apply (auto)
  apply (simp add: ereq_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "z = x'")
   apply (auto)
   apply (simp add: rem_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_req_use_env: "req_use_env y tau = rename_use_env (req_use_env x tau) x y"
  apply (case_tac "\<forall> x'. req_use_env y tau x' = rename_use_env (req_use_env x tau) x y x'")
   apply (auto)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_req_use_env2: "\<lbrakk> z \<noteq> x ; z \<noteq> y\<rbrakk> \<Longrightarrow> req_use_env z tau = rename_use_env (req_use_env z tau) x y"
  apply (case_tac "\<forall> x'. req_use_env z tau x' = rename_use_env (req_use_env z tau) x y x'")
   apply (auto)
  apply (simp add: req_use_env_def)
  apply (simp add: one_use_env_def)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "z = x'")
   apply (auto)
   apply (simp add: rem_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_add_use_env: "add_use_env (rename_use_env r_s x y) y r = rename_use_env (add_use_env r_s x r) x y"
  apply (case_tac "\<forall> x'. add_use_env (rename_use_env r_s x y) y r x' = rename_use_env (add_use_env r_s x r) x y x'")
   apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_add_use_env2: "\<lbrakk> z \<noteq> x; z \<noteq> y \<rbrakk> \<Longrightarrow> add_use_env (rename_use_env r_s x y) z r = rename_use_env (add_use_env r_s z r) x y"
  apply (case_tac "\<forall> x'. add_use_env (rename_use_env r_s x y) z r x' = rename_use_env (add_use_env r_s z r) x y x'")
   apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "z = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_add_use_env3: "\<lbrakk> r_s x = NoPerm \<rbrakk> \<Longrightarrow> add_use_env r_s y r = rename_use_env (add_use_env r_s x r) x y"
  apply (case_tac "\<forall> x'. add_use_env r_s y r x' = rename_use_env (add_use_env r_s x r) x y x'")
   apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_comp_use_env: "comp_use_env (rename_use_env r_x x y) (rename_use_env r_s x y) = rename_use_env (comp_use_env r_x r_s) x y"
  apply (case_tac "\<forall> x'. comp_use_env (rename_use_env r_x x y) (rename_use_env r_s x y) x' = rename_use_env (comp_use_env r_x r_s) x y x'")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_diff_use_env: "diff_use_env (rename_use_env r_x x y) (rename_use_env r_s x y) = rename_use_env (diff_use_env r_x r_s) x y"
  apply (case_tac "\<forall> x'. diff_use_env (rename_use_env r_x x y) (rename_use_env r_s x y) x' = rename_use_env (diff_use_env r_x r_s) x y x'")
  apply (auto)
  apply (simp add: diff_use_env_def)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma rename_lift_use_env: "lift_use_env (rename_use_env r_s x y) r = rename_use_env (lift_use_env r_s r) x y"
  apply (case_tac "\<forall> x'. lift_use_env (rename_use_env r_s x y) r x' = rename_use_env (lift_use_env r_s r) x y x'")
   apply (auto)
  apply (case_tac r)
    apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac "y = x'")
   apply (auto)
   apply (simp add: rem_use_env_def)
   apply (case_tac "x = x'")
    apply (auto)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = x'")
   apply (auto)
  done

lemma aff_rename_use_env: "\<lbrakk> aff_use_env r_s a \<rbrakk> \<Longrightarrow> aff_use_env (rename_use_env r_s x y) a"
  apply (simp add: aff_use_env_def)
  apply (case_tac a)
    apply (auto)
   apply (simp add: rename_use_env_def)
   apply (simp add: add_use_env_def)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (erule_tac x="xa" in allE)
   apply (simp add: rem_use_env_def)
   apply (case_tac "x = xa")
    apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: rem_use_env_def)
  done
  (*
lemma safe_lift_rename_use_env: "\<lbrakk> safe_use_lift r_s r \<rbrakk> \<Longrightarrow> safe_use_lift (rename_use_env r_s x y) r"
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (case_tac r)
    apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: rem_use_env_def)
  apply (case_tac "x = xa")
   apply (auto)
  done*)

lemma disj_rename_use_env: "\<lbrakk> disj_use_env r_x r_s \<rbrakk> \<Longrightarrow> disj_use_env (rename_use_env r_x x y) (rename_use_env r_s x y)"
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (auto)
   apply (simp add: rename_use_env_def)
   apply (simp add: add_use_env_def)
   apply (auto)
   apply (simp add: rem_use_env_def)
   apply (auto)
  apply (simp add: rename_use_env_def)
  apply (simp add: add_use_env_def)
  apply (auto)
  apply (simp add: rem_use_env_def)
  apply (auto)
  done

lemma artp_var_case1: "\<lbrakk>y \<noteq> x; add_env env (Var x) t (Var x) = Some tau_x; leq_use_env (ereq_use_env (Var x) tau_x) r_s1;
        leq_use_env r_s2 (diff_use_env r_s1 (comp_use_env (ereq_use_env (Var x) tau_x) r_ex)); leq_use_env rx r_s2; leq_use_env r_ex r_s1;
        leq_use_env (diff_use_env (ereq_use_env (Var x) tau_x) (comp_use_env (ereq_use_env (Var x) tau_x) r_ex)) rx\<rbrakk>
       \<Longrightarrow> \<exists>r_ex tau_x.
              add_env env (Var y) t (Var y) = Some tau_x \<and>
              leq_use_env (ereq_use_env (Var y) tau_x) (rename_use_env r_s1 (Var x) (Var y)) \<and>
              leq_use_env (rename_use_env r_s2 (Var x) (Var y))
               (diff_use_env (rename_use_env r_s1 (Var x) (Var y)) (comp_use_env (ereq_use_env (Var y) tau_x) r_ex)) \<and>
              leq_use_env (rename_use_env rx (Var x) (Var y)) (rename_use_env r_s2 (Var x) (Var y)) \<and>
              leq_use_env r_ex (rename_use_env r_s1 (Var x) (Var y)) \<and>
              leq_use_env (diff_use_env (ereq_use_env (Var y) tau_x) (comp_use_env (ereq_use_env (Var y) tau_x) r_ex)) (rename_use_env rx (Var x) (Var y))"
  apply (simp add: add_env_def)
  apply (auto)
   apply (case_tac "\<not> leq_perm (end_req_perm tau_x) (r_s1 (Var x))")
    apply (cut_tac r_x="ereq_use_env (Var x) tau_x" and r_s="r_s1" and x="Var x" in spec_leq_perm)
     apply (simp)
    apply (simp add: ereq_use_env_def)
    apply (simp add: one_use_env_def)
   apply (simp add: leq_use_env_def)
   apply (simp add: ereq_use_env_def)
   apply (simp add: one_use_env_def)
   apply (simp add: rename_use_env_def)
   apply (simp add: add_use_env_def)
  apply (cut_tac x="Var x" and y="Var y" and tau="tau_x" in rename_ereq_use_env)
  apply (simp)
  apply (case_tac "\<not> comp_use_env (ereq_use_env (Var y) tau_x) (rename_use_env r_ex (Var x) (Var y)) =
    rename_use_env (comp_use_env (ereq_use_env (Var x) tau_x) r_ex) (Var x) (Var y)")
   apply (cut_tac r_x="ereq_use_env (Var x) tau_x" and r_s="r_ex" and x="Var x" and y="Var y" in rename_comp_use_env)
   apply (simp)
  apply (rule_tac x="rename_use_env r_ex (Var x) (Var y)" in exI)
  apply (auto)
     apply (cut_tac r_x="r_s1" and r_s="comp_use_env (ereq_use_env (Var x) tau_x) r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
     apply (simp)
     apply (rule_tac rename_leq_use_env)
     apply (simp)
    apply (rule_tac rename_leq_use_env)
    apply (simp)
   apply (rule_tac rename_leq_use_env)
   apply (simp)
  apply (cut_tac r_x="ereq_use_env (Var x) tau_x" and r_s="comp_use_env (ereq_use_env (Var x) tau_x) r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
  apply (simp)
  apply (rule_tac rename_leq_use_env)
  apply (simp)
  done

lemma artp_var_case2: "\<lbrakk>Var y \<noteq> xa; add_env env (Var x) t xa = Some tau_x; leq_use_env (ereq_use_env xa tau_x) r_s1;
        leq_use_env r_s2 (diff_use_env r_s1 (comp_use_env (ereq_use_env xa tau_x) r_ex)); leq_use_env rx r_s2; leq_use_env r_ex r_s1;
        leq_use_env (diff_use_env (ereq_use_env xa tau_x) (comp_use_env (ereq_use_env xa tau_x) r_ex)) rx; Var x \<noteq> xa\<rbrakk>
       \<Longrightarrow> leq_use_env (ereq_use_env xa tau_x) (rename_use_env r_s1 (Var x) (Var y)) \<and>
           (\<exists>r_ex. leq_use_env (rename_use_env r_s2 (Var x) (Var y))
                    (diff_use_env (rename_use_env r_s1 (Var x) (Var y)) (comp_use_env (ereq_use_env xa tau_x) r_ex)) \<and>
                   leq_use_env (rename_use_env rx (Var x) (Var y)) (rename_use_env r_s2 (Var x) (Var y)) \<and>
                   leq_use_env r_ex (rename_use_env r_s1 (Var x) (Var y)) \<and>
                   leq_use_env (diff_use_env (ereq_use_env xa tau_x) (comp_use_env (ereq_use_env xa tau_x) r_ex)) (rename_use_env rx (Var x) (Var y)))"
  apply (auto)
   apply (case_tac "\<not>  leq_use_env (ereq_use_env xa tau_x) (rename_use_env r_s1 (Var x) (Var y)) =
    leq_use_env (rename_use_env (ereq_use_env xa tau_x) (Var x) (Var y)) (rename_use_env r_s1 (Var x) (Var y))")
    apply (cut_tac z="xa" and x="Var x" and y="Var y" and tau="tau_x" in rename_ereq_use_env2)
      apply (simp_all)
   apply (rule_tac rename_leq_use_env)
   apply (simp)
  apply (case_tac "\<not> rename_use_env (ereq_use_env xa tau_x) (Var x) (Var y) = ereq_use_env xa tau_x")
   apply (cut_tac z="xa" and x="Var x" and y="Var y" and tau="tau_x" in rename_ereq_use_env2)
  apply (simp_all)
  apply (cut_tac r_x="ereq_use_env xa tau_x" and r_s="r_ex" and x="Var x" and y="Var y" in rename_comp_use_env)
  apply (simp_all)
  apply (rule_tac x="rename_use_env r_ex (Var x) (Var y)" in exI)
  apply (auto)
     apply (cut_tac r_x="r_s1" and r_s="comp_use_env (ereq_use_env xa tau_x) r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
     apply (simp_all)
     apply (rule_tac rename_leq_use_env)
     apply (simp)
    apply (rule_tac rename_leq_use_env)
    apply (simp)
   apply (rule_tac rename_leq_use_env)
   apply (simp)
  apply (cut_tac r_x="ereq_use_env xa tau_x" and r_s="comp_use_env (ereq_use_env xa tau_x) r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
  apply (simp_all)
  apply (rule_tac rename_leq_use_env)
  apply (simp)
  done

lemma alpha_rename_type_preserve: "\<lbrakk> well_typed (add_env env (Var x) t) r_s1 e tau r_s2 rx; (*env x = None;*)
  y \<notin> free_vars e; y \<notin> lam_vars e \<rbrakk> \<Longrightarrow>
  well_typed (add_env env (Var y) t) (rename_use_env r_s1 (Var x) (Var y)) (deep_alpha_rename e x y) tau
    (rename_use_env r_s2 (Var x) (Var y)) (rename_use_env rx (Var x) (Var y))"
  apply (induct e arbitrary: env tau t r_s1 r_s2 rx)
        apply (auto)
    (* const + op cases *)
           apply (rule_tac x="Var x" in rename_leq_use_env)
           apply (simp_all)
          apply (rule_tac x="Var x" in rename_leq_use_env)
          apply (simp_all)
         apply (rule_tac x="Var x" in rename_leq_use_env)
         apply (simp_all)
        apply (rule_tac x="Var x" in rename_leq_use_env)
        apply (simp_all)
    (* var case. *)
       apply (case_tac "xa = VarType x")
        apply (auto)
         apply (simp add: add_env_def)
        apply (rule_tac artp_var_case1)
              apply (auto)
       apply (case_tac xa)
        apply (auto)
          apply (simp add: add_env_def)
         apply (simp add: add_env_def)
         apply (rule_tac artp_var_case2)
                apply (auto)
         apply (simp add: add_env_def)
        apply (simp add: add_env_def)
       apply (simp add: add_env_def)
       apply (rule_tac artp_var_case2)
              apply (auto)
       apply (simp add: add_env_def)
    (* pair case *)
        apply (cut_tac r_s="rx1" and x="Var x" and y="Var y" and r="r" in rename_lift_use_env)
        apply (cut_tac r_s="rx2" and x="Var x" and y="Var y" and r="r" in rename_lift_use_env)
        apply (rule_tac x="rename_use_env r_s2a (Var x) (Var y)" in exI)
        apply (rule_tac x="rename_use_env r_s3 (Var x) (Var y)" in exI)
        apply (rule_tac x="rename_use_env rx1 (Var x) (Var y)" in exI)
        apply (auto)
        apply (rule_tac x="rename_use_env rx2 (Var x) (Var y)" in exI)
        apply (auto)
             apply (rule_tac rename_leq_use_env)
             apply (simp)
            apply (rule_tac rename_leq_use_env)
            apply (simp)(*
           apply (rule_tac safe_lift_rename_use_env)
           apply (simp)
          apply (rule_tac safe_lift_rename_use_env)
          apply (simp)*)
         apply (rule_tac disj_rename_use_env)
         apply (simp)
        apply (cut_tac r_x="r_s3" and r_s="r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
        apply (rule_tac x="rename_use_env r_ex (Var x) (Var y)" in exI)
        apply (auto)
           apply (rule_tac rename_leq_use_env)
           apply (simp)
          apply (rule_tac rename_leq_use_env)
          apply (simp)
         apply (rule_tac rename_leq_use_env)
         apply (simp)
        apply (case_tac "req_type (PairTy t1 t2 r) = Prim")
         apply (simp add: pair_req_def)
         apply (rule_tac leq_empty_use_env)
        apply (simp add: pair_req_def)
        apply (simp add: rename_comp_use_env)
        apply (simp add: rename_diff_use_env)
        apply (rule_tac rename_leq_use_env)
        apply (simp)
    (* if case *)
       apply (rule_tac x="rename_use_env rx' (Var x) (Var y)" in exI)
       apply (rule_tac x="rename_use_env r_s2a (Var x) (Var y)" in exI)
       apply (auto)
       apply (rule_tac x="rename_use_env rx1 (Var x) (Var y)" in exI)
       apply (auto)
       apply (rule_tac x="rename_use_env rx2 (Var x) (Var y)" in exI)
       apply (auto)
       apply (cut_tac r_x="rx1" and r_s="rx2" and x="Var x" and y="Var y" in rename_comp_use_env)
       apply (auto)
    (* lam case p1. *)(*
      apply (cut_tac y="Var y" and x="Var x" and e="e" in rename_ref_vars2)
        apply (auto)*)
     apply (rule_tac x="rename_use_env rxa (Var x) (Var y)" in exI)
     apply (auto)
        apply (rule_tac x="rename_use_env r_end (Var x) (Var y)" in exI)
        apply (rule_tac x="rename_use_env r_s' (Var x) (Var y)" in exI)
        apply (cut_tac env="env" and x="Var x" and t="t" and t'="t1" in double_add_env)
        apply (cut_tac env="env" and x="Var y" and t="t" and t'="t1" in double_add_env)
        apply (cut_tac r_s="rxa" and x="Var x" and y="Var y" and r="r" in rename_add_use_env)
        apply (simp)
       apply (rule_tac aff_rename_use_env)
       apply (simp)
      apply (rule_tac rename_leq_use_env)
      apply (simp)
     apply (rule_tac x="rename_use_env r_ex (Var x) (Var y)" in exI)
     apply (auto)
        apply (cut_tac r_x="r_s1" and r_s="r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
        apply (simp)
        apply (rule_tac rename_leq_use_env)
        apply (simp)
       apply (rule_tac rename_leq_use_env)
       apply (simp)
      apply (rule_tac rename_leq_use_env)
      apply (simp)
     apply (cut_tac r_x="rxa" and r_s="r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
     apply (simp)
     apply (rule_tac rename_leq_use_env)
     apply (simp)
    (* lam case p2. *)(*
    apply (cut_tac z="x1a" and x="Var x" and y="Var y" and e="e" in rename_ref_vars1)
      apply (auto)*)
   apply (rule_tac x="rename_use_env rxa (Var x) (Var y)" in exI)
   apply (auto)
      apply (rule_tac x="rename_use_env r_end (Var x) (Var y)" in exI)
      apply (rule_tac x="rename_use_env r_s' (Var x) (Var y)" in exI)
      apply (cut_tac env="env" and x="Var x1a" and y="Var x" and t="t" and t'="t1" in almost_comm_add_env)
       apply (simp_all)
      apply (cut_tac env="env" and x="Var x1a" and y="Var y" and t="t" and t'="t1" in almost_comm_add_env)
       apply (simp_all)
      apply (cut_tac r_s="rxa" and x="Var x" and y="Var y" and z="Var x1a" and r="r" in rename_add_use_env2)
        apply (simp_all)
     apply (rule_tac aff_rename_use_env)
     apply (simp)
    apply (rule_tac rename_leq_use_env)
    apply (simp)
   apply (rule_tac x="rename_use_env r_ex (Var x) (Var y)" in exI)
   apply (auto)
      apply (cut_tac r_x="r_s1" and r_s="r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
      apply (simp)
      apply (rule_tac rename_leq_use_env)
      apply (simp)
     apply (rule_tac rename_leq_use_env)
     apply (simp)
    apply (rule_tac rename_leq_use_env)
    apply (simp)
   apply (cut_tac r_x="rxa" and r_s="r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
   apply (simp)
   apply (rule_tac rename_leq_use_env)
   apply (simp)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="rename_use_env r_s2a (Var x) (Var y)" in exI)
  apply (rule_tac x="rename_use_env rx1 (Var x) (Var y)" in exI)
  apply (auto)
  apply (rule_tac x="rename_use_env rx2 (Var x) (Var y)" in exI)
  apply (rule_tac x="rename_use_env r_s3 (Var x) (Var y)" in exI)
  apply (auto)
  apply (cut_tac r_s="rx2" and x="Var x" and y="Var y" and r="r" in rename_lift_use_env)
  apply (simp)
  apply (cut_tac r_x="rx1" and r_s="lift_use_env rx2 r" and x="Var x" and y="Var y" in rename_comp_use_env)
  apply (cut_tac r_x="comp_use_env rx1 (lift_use_env rx2 r)" and r_s="r_ex" and x="Var x" and y="Var y" in rename_comp_use_env)
  apply (rule_tac x="rename_use_env r_ex (Var x) (Var y)" in exI)
  apply (auto)
        apply (cut_tac r_x="r_s3" and r_s="comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
        apply (simp)
        apply (rule_tac rename_leq_use_env)
        apply (simp)(*
       apply (rule_tac safe_lift_rename_use_env)
       apply (simp)*)
      apply (rule_tac rename_leq_use_env)
      apply (simp)
     apply (rule_tac disj_rename_use_env)
     apply (simp)
    apply (rule_tac rename_leq_use_env)
    apply (simp)
   apply (rule_tac rename_leq_use_env)
   apply (simp)
  apply (simp add: app_req_def)
  apply (auto)
   apply (rule_tac leq_empty_use_env)
  apply (cut_tac r_x="rx1" and r_s="rx2" and x="Var x" and y="Var y" in rename_comp_use_env)
  apply (simp)
  apply (cut_tac r_x="comp_use_env rx1 rx2" and r_s="comp_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_ex" and x="Var x" and y="Var y" in rename_diff_use_env)
  apply (simp)
  apply (rule_tac rename_leq_use_env)
  apply (simp)
  done

lemma alpha_rename_free_var_id: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> x \<notin> free_vars (deep_alpha_rename e x y)"
  apply (induct e)
        apply (auto)
  apply (case_tac xa)
   apply (auto)
  apply (case_tac "x = x1")
   apply (auto)
  done

lemma alpha_rename_free_var_none: "\<lbrakk> a \<notin> free_vars e; a \<noteq> y \<rbrakk> \<Longrightarrow> a \<notin> free_vars (deep_alpha_rename e x y)"
  apply (induction e)
        apply (auto)
   apply (case_tac xa)
    apply (auto)
   apply (case_tac "x = x1")
    apply (auto)
  apply (cut_tac e="e" and x="a" and y="y" in alpha_rename_free_var_id)
   apply (auto)
  done

lemma alpha_rename_lam_var_none: "\<lbrakk> a \<notin> lam_vars e; a \<noteq> y \<rbrakk> \<Longrightarrow> a \<notin> lam_vars (deep_alpha_rename e x y)"
  apply (induct e)
       apply (auto)
  apply (case_tac xa)
   apply (auto)
  apply (case_tac "x = x1")
   apply (auto)
  done

lemma lam_var_remove_free_var_none: "\<lbrakk> x \<notin> free_vars e \<rbrakk> \<Longrightarrow> x \<notin> free_vars (lam_var_remove e a b)"
  apply (induct e)
       apply (auto)
   apply (case_tac "x \<noteq> b")
    apply (cut_tac e="e" and a="x" and x="a" and y="b" in alpha_rename_free_var_none)
      apply (auto)
  apply (case_tac "x \<noteq> b")
   apply (cut_tac e="e" and x="x" and y="b" in alpha_rename_free_var_id)
    apply (auto)
  done

lemma lam_var_remove_lam_var_none: "\<lbrakk> x \<notin> lam_vars e; x \<noteq> b \<rbrakk> \<Longrightarrow> x \<notin> lam_vars (lam_var_remove e a b)"
  apply (induct e)
       apply (auto)
  apply (cut_tac a="x" and e="e" and x="a" and y="b" in alpha_rename_lam_var_none)
    apply (auto)
  done

lemma lam_var_remove_type_preserve: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; y \<notin> free_vars e; y \<notin> lam_vars e \<rbrakk> \<Longrightarrow>
  well_typed env r_s1 (lam_var_remove e x y) tau r_s2 rx"
  apply (induct e arbitrary: env tau r_s1 r_s2 rx)
        apply (auto)
    (* pair case *)
      apply (rule_tac x="r_s2a" in exI)
      apply (rule_tac x="r_s3" in exI)
      apply (rule_tac x="rx1" in exI)
      apply (auto)
      apply (rule_tac x="rx2" in exI)
      apply (auto)
    (* if case *)
     apply (rule_tac x="rx'" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (auto)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
    (* lam case p1. *)
    apply (rule_tac x="rxa" in exI)
    apply (auto)
    apply (rule_tac x="rename_use_env r_end (Var x) (Var y)" in exI)
    apply (rule_tac x="rename_use_env r_s' (Var x) (Var y)" in exI)
    apply (rule_tac ?r_s1.0="rem_use_env (add_use_env rxa (Var y) r) (Var x)" in well_typed_incr_start_perm)
     apply (cut_tac r_s="rxa" and x="Var y" and y="Var x" and r="r" in almost_comm_rem_add_use_env)
      apply (simp_all)
     apply (case_tac "\<not> add_use_env (rem_use_env rxa (Var x)) (Var y) r = rename_use_env (add_use_env rxa (Var x) r) (Var x) (Var y)")
      apply (case_tac "\<not> (\<forall> x'. add_use_env (rem_use_env rxa (Var x)) (Var y) r x' = rename_use_env (add_use_env rxa (Var x) r) (Var x) (Var y) x')")
       apply (auto)
      apply (simp add: rename_use_env_def)
      apply (simp add: add_use_env_def)
      apply (case_tac "Var y = x'")
       apply (auto)
      apply (simp add: rem_use_env_def)
      apply (case_tac "Var x = x'")
       apply (auto)
     apply (rule_tac alpha_rename_type_preserve)
       apply (simp_all)
    apply (rule_tac self_rem_leq_use_env)
    (* lam case p2. *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="r_end" in exI)
   apply (rule_tac x="r_s'" in exI)
   apply (auto)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (auto)
  done

    (* basically, we want to make sure that when we replace a var, we dont end up with the post_vars of vl overlapping with
      any of the ref vars of e. in other words, that we arent changing any of the ref vars. now the thing is, when we do lam var remove,
      we dont expect any of the ref vars to change actually  *)
lemma lam_var_list_remove_type_preserve: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx; unique_post_vars vl;(* pre_vars vl \<subseteq> lam_vars e;*)
  post_vars vl \<inter> (free_vars e \<union> lam_vars e) = {} \<rbrakk> \<Longrightarrow> well_typed env r_s1 (lam_var_list_remove e vl) tau r_s2 rx"
  apply (induct vl arbitrary: e)
   apply (auto)
  apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="e" and tau="tau" and ?r_s2.0="r_s2" and rx="rx" and x="a" and y="b" in lam_var_remove_type_preserve)
      apply (auto)
  apply (case_tac "\<not> post_vars vl \<inter> (free_vars (lam_var_remove e a b) \<union> lam_vars (lam_var_remove e a b)) = {}")
   apply (auto)
    apply (cut_tac e="e" and x="x" and a="a" and b="b" in lam_var_remove_free_var_none)
     apply (auto)
  apply (cut_tac e="e" and x="x" and a="a" and b="b" in lam_var_remove_lam_var_none)
    apply (auto)
  done

lemma alpha_rename_free_var_some: "\<lbrakk> x \<in> free_vars e; x \<noteq> a; x \<noteq> b \<rbrakk> \<Longrightarrow> x \<in> free_vars (deep_alpha_rename e a b)"
  apply (induct e)
        apply (auto)
  apply (case_tac xa)
   apply (auto)
  done

lemma lam_var_remove_free_var_some: "\<lbrakk> x \<in> free_vars e; x \<noteq> b \<rbrakk> \<Longrightarrow> x \<in> free_vars (lam_var_remove e a b)"
  apply (induct e)
       apply (auto)
  apply (rule_tac alpha_rename_free_var_some)
    apply (auto)
  done

lemma lam_var_list_remove_free_var_some: "\<lbrakk> x \<in> free_vars e; x \<notin> post_vars vl \<rbrakk> \<Longrightarrow> x \<in> free_vars (lam_var_list_remove e vl)"
  apply (induct vl arbitrary: e)
   apply (auto)
  apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_free_var_some)
    apply (auto)
  done

lemma lam_var_list_remove_lam_var_none1: "\<lbrakk> x \<notin> lam_vars e; x \<notin> post_vars vl \<rbrakk> \<Longrightarrow> x \<notin> lam_vars (lam_var_list_remove e vl)"
  apply (induct vl arbitrary: e)
   apply (auto)
  apply (cut_tac e="e" and x="x" and a="a" and b="b" in lam_var_remove_lam_var_none)
    apply (auto)
  done

lemma alpha_rename_lam_var_none2: "\<lbrakk> x \<noteq> b \<rbrakk> \<Longrightarrow> x \<notin> lam_vars (deep_alpha_rename e x b)"
  apply (induct e)
        apply (auto)
  apply (case_tac xa)
   apply (auto)
  apply (case_tac "x = x1")
   apply (auto)
  done

lemma lam_var_remove_lam_var_none2: "\<lbrakk> x \<noteq> b \<rbrakk> \<Longrightarrow> x \<notin> lam_vars (lam_var_remove e x b)"
  apply (induct e)
       apply (auto)
  apply (cut_tac e="e" and x="x" and b="b" in alpha_rename_lam_var_none2)
   apply (auto)
  done

lemma lam_var_list_remove_lam_var_none2: "\<lbrakk> x \<in> pre_vars vl; x \<notin> post_vars vl \<rbrakk> \<Longrightarrow> x \<notin> lam_vars (lam_var_list_remove e vl)"
  apply (induct vl arbitrary: e)
   apply (auto)
  apply (cut_tac e="e" and x="x" and b="b" in lam_var_remove_lam_var_none2)
   apply (auto)
  apply (cut_tac e="lam_var_remove e x b" and x="x" and vl="vl" in lam_var_list_remove_lam_var_none1)
    apply (auto)
  done

lemma lam_var_list_remove_free_var_some_rev: "\<lbrakk> x \<in> free_vars (lam_var_list_remove e vl) \<rbrakk> \<Longrightarrow> x \<in> free_vars e"
  apply (induction vl arbitrary: e)
   apply (auto)
  apply (case_tac "x \<notin> free_vars e")
   apply (auto)
  apply (cut_tac x="x" and e="e" and a="a" and b="b" in lam_var_remove_free_var_none)
   apply (auto)
  done

lemma lam_var_list_remove_free_var_none: "\<lbrakk> x \<notin> free_vars e \<rbrakk> \<Longrightarrow> x \<notin> free_vars (lam_var_list_remove e vl)"
  apply (case_tac "x \<in> free_vars (lam_var_list_remove e vl)")
   apply (auto)
  apply (cut_tac x="x" and e="e" and vl="vl" in lam_var_list_remove_free_var_some_rev)
   apply (auto)
  done

end


theory UPPAAL_State_Networks_Impl
  imports TA_Impl.Normalized_Zone_Semantics_Impl UPPAAL_State_Networks
begin

chapter \<open>Implementation of UPPAAL Style Networks\<close>

no_notation OR (infix "or" 60)

lemma step_resets:
  "\<forall> c \<in> set r'. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc"
  if "stepc cmd u (pc, st, s, f, r) = Some (pc', st', s', f', r')"
    "\<forall> c \<in> set r. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc" "P pc = Some cmd"
  using that
  apply -
  apply (erule stepc.elims)
  by (auto split: option.splits if_splits elim!: step.elims) metis+

lemma step_resets':
  "\<forall> c \<in> set r'. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc"
  if "step instr (pc, st, s, f, r) = Some (pc', st', s', f', r')"
    "\<forall> c \<in> set r. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc" "P pc = Some (INSTR instr)"
  using that
  by (auto split: option.splits if_splits elim!: step.elims) metis+

lemma step_resets'':
  "\<forall> c \<in> set r'. \<exists> x pc. Some (STOREC c x) = P pc"
  if "step instr (pc, st, s, f, r) = Some (pc', st', s', f', r')"
    "\<forall> c \<in> set r. \<exists> x pc. Some (STOREC c x) = P pc" "P pc = Some instr"
  using that
  by (auto split: option.splits if_splits elim!: step.elims) metis+

lemma steps_reset:
  "\<forall> c \<in> set r'. \<exists> x pc. Some (STOREC c x) = P pc"
  if "steps P n (pc, st, s, f, r) (pc', st', s', f', r')" "\<forall> c \<in> set r. \<exists> x pc. Some (STOREC c x) = P pc"
  using that
  by (induction P \<equiv> P n "(pc, st, s, f, r :: nat list)" "(pc', st', s', f', r')" arbitrary: pc st s f r rule: steps.induct)
     (auto dest!: step_resets''[where P = P])

lemma exec_reset:
  "\<forall> c \<in> set r'. \<exists> x pc. Some (STOREC c x) = P pc"
  if "Some ((pc', st', s', f', r'), pcs') = exec P n (pc, st, s, f, []) pcs"
  using exec_steps[OF that[symmetric]] steps_reset by force

lemma exec_pointers:
  "\<forall> pc \<in> set pcs'. \<exists> pc instr. Some instr = P pc"
  if "Some ((pc', st', s', f', r'), pcs') = exec P n (pc, st, s, f, r) pcs"
     "\<forall> pc \<in> set pcs. \<exists> pc instr. Some instr = P pc"
  using that
  apply (induction rule: exec.induct)
  by (auto split: option.splits if_splits) metis+

lemma exec_pointers':
  "\<forall> pc \<in> set pcs'. \<exists> pc instr. Some instr = P pc"
  if "Some ((pc', st', s', f', r'), pcs') = exec P n (pc, st, s, f, r) []"
  using that exec_pointers by fastforce

context Prod_TA_Defs
begin

lemma finite_range_I':
  assumes "\<forall>A\<in>{0..<p}. finite (range (snd (N ! A)))"
    shows "finite (range (I' s))"
    using assms unfolding inv_of_def Product_TA_Defs.product_ta_def N_s_def
    by (auto simp: inv_of_def p_def intro!: Product_TA_Defs.finite_invariant_of_product)

lemma range_prod_invariant:
  "range prod_invariant = range (I' s)"
  unfolding prod_invariant_def using I'_simp by auto

lemma finite_rangeI:
  assumes "\<forall>A\<in>{0..<p}. finite (range (snd (N ! A)))"
  shows "finite (range prod_invariant)"
  using assms by (metis finite_range_I' range_prod_invariant)

thm prod_trans_i_alt_def

end

context Equiv_TA_Defs
begin

thm defs.prod_trans_i_alt_def

lemma states'_len_simp[simp]:
  "length L = p" if "L \<in> defs.states' s"
  using that
  using Product_TA_Defs.states_length defs.N_s_def state_ta_def by fastforce

 lemma [simp]:
  "defs.p = p"
  unfolding defs.p_def by simp

lemma P_Storec_iff:
  "(Some (INSTR (STOREC x xa)) = P pc) \<longleftrightarrow> (Some (STOREC x xa) = PF pc)"
  unfolding stripfp_def apply (cases "P pc")
   apply force
  subgoal for a
    by (cases a) auto
  done

(* XXX Unused but is explaining what is going on below *)
lemma product_trans_i_resets:
  "collect_clkvt (Product_TA_Defs.product_trans_i (defs.N_s s))
  \<subseteq> {c. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc}"
  unfolding collect_clkvt_def
  unfolding Product_TA_Defs.product_trans_i_def
  apply clarsimp
  unfolding defs.N_s_def
  unfolding trans_of_def
  unfolding defs.T_s_def
  unfolding state_ta_def
  unfolding state_trans_t_def
  unfolding make_f_def
  apply (clarsimp split: option.split_asm)
  by (auto dest: exec_reset simp: P_Storec_iff)

(* XXX Unused but is explaining what is going on below *)
lemma product_trans_s_resets:
  "collect_clkvt (Product_TA_Defs.product_trans_s (defs.N_s s))
  \<subseteq> {c. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc}"
  unfolding collect_clkvt_def
  unfolding Product_TA_Defs.product_trans_s_def
  apply clarsimp
  unfolding defs.N_s_def
  unfolding trans_of_def
  unfolding defs.T_s_def
  unfolding state_ta_def
  unfolding state_trans_t_def
  unfolding make_f_def
  apply (clarsimp split: option.split_asm)
  by (auto dest: exec_reset simp: P_Storec_iff)

lemma product_trans_resets:
  "collect_clkvt (\<Union>s. defs.T' s) \<subseteq> {c. \<exists> x pc. Some (INSTR (STOREC c x)) = P pc}"
  unfolding trans_of_def
  unfolding Product_TA_Defs.product_ta_def
  apply simp
  unfolding Product_TA_Defs.product_trans_def
  unfolding collect_clkvt_def
  apply safe
  unfolding Product_TA_Defs.product_trans_i_def Product_TA_Defs.product_trans_s_def
   apply clarsimp_all
  unfolding defs.N_s_def
  unfolding trans_of_def
  unfolding defs.T_s_def
  unfolding state_ta_def
  unfolding state_trans_t_def
  unfolding make_f_def
  apply (clarsimp_all split: option.split_asm)
  by (auto dest: exec_reset simp: P_Storec_iff)

lemma product_trans_guards:
  "Timed_Automata.collect_clkt (\<Union>s. defs.T' s)
  \<subseteq> {constraint_pair ac | ac. \<exists> pc. Some (CEXP ac) = P pc}"
  unfolding trans_of_def
  unfolding Product_TA_Defs.product_ta_def
  apply simp
  unfolding Product_TA_Defs.product_trans_def
  unfolding Timed_Automata.collect_clkt_def collect_clock_pairs_def
  apply safe
  unfolding Product_TA_Defs.product_trans_i_def Product_TA_Defs.product_trans_s_def
   apply clarsimp_all
  unfolding defs.N_s_def
  unfolding trans_of_def
  unfolding defs.T_s_def
  unfolding state_ta_def
  unfolding state_trans_t_def
  unfolding make_g_def
   apply (clarsimp_all split: option.split_asm)
  subgoal premises prems
    using prems(1,3-)
    unfolding set_map_filter
    by - (drule exec_pointers'; auto split: option.splits; auto split: instrc.split_asm; metis)
  subgoal premises prems
    using prems(1,2,4-)
    apply safe
    unfolding set_map_filter
    by (drule exec_pointers'; auto split: option.splits; auto split: instrc.split_asm; metis)+
  done

end

datatype bexp =
  not bexp | "and" bexp bexp | or bexp bexp | imply bexp bexp | \<comment> \<open>Boolean connectives\<close>
  loc nat nat | \<comment> \<open>Is process p in location l?\<close>
  eq nat int \<comment> \<open>Does var i equal x?\<close> |
  le nat int |
  lt nat int |
  ge nat int |
  gt nat int

fun check_bexp :: "bexp \<Rightarrow> nat list \<Rightarrow> int list \<Rightarrow> bool" where
  "check_bexp (not a) L s \<longleftrightarrow> \<not> check_bexp a L s" |
  "check_bexp (and a b ) L s \<longleftrightarrow> check_bexp a L s \<and> check_bexp b L s" |
  "check_bexp (or a b ) L s \<longleftrightarrow> check_bexp a L s \<or> check_bexp b L s" |
  "check_bexp (imply a b ) L s \<longleftrightarrow> (check_bexp a L s \<longrightarrow> check_bexp b L s)" |
  "check_bexp (loc p l) L _ \<longleftrightarrow> L ! p = l" |
  "check_bexp (eq i x) _ s \<longleftrightarrow> s ! i = x" |
  "check_bexp (le i x) _ s \<longleftrightarrow> s ! i \<le> x" |
  "check_bexp (lt i x) _ s \<longleftrightarrow> s ! i < x" |
  "check_bexp (ge i x) _ s \<longleftrightarrow> s ! i \<ge> x" |
  "check_bexp (gt i x) _ s \<longleftrightarrow> s ! i > x"

datatype formula =
  EX bexp | EG bexp | AX bexp | AG bexp | Leadsto bexp bexp

abbreviation "repeat x n \<equiv> map (\<lambda> _. x) [0..<n]"

abbreviation "conv_prog P pc \<equiv> map_option (map_instrc real_of_int) (P pc)"
abbreviation "conv_A' \<equiv> \<lambda> (T, I). (T, conv_cc o I)"

fun hd_of_formula :: "formula \<Rightarrow> nat list \<Rightarrow> int list \<Rightarrow> bool" where
  "hd_of_formula (formula.EX \<phi>) = check_bexp \<phi>" |
  "hd_of_formula (EG \<phi>) = check_bexp \<phi>" |
  "hd_of_formula (AX \<phi>) = Not oo check_bexp \<phi>" |
  "hd_of_formula (AG \<phi>) = Not oo check_bexp \<phi>" |
  "hd_of_formula (Leadsto \<phi> _) = check_bexp \<phi>"

subsection \<open>Pre-compiled networks with states and clocks as natural numbers\<close>
locale UPPAAL_Reachability_Problem_precompiled_defs =
  fixes p :: nat \<comment> \<open>Number of processes\<close>
    and m :: nat \<comment> \<open>Number of clocks\<close>
    (*
    and k :: "nat list list"
      -- "Clock ceiling. Maximal constant appearing in automaton for each state"
    *)
    and max_steps :: nat \<comment> \<open>Maximal number of execution for steps of programs in the automaton\<close>
    and inv :: "(nat, int) cconstraint list list" \<comment> \<open>Clock invariants on locations per process\<close>
    and pred :: "addr list list" \<comment> \<open>State invariants on locations per process\<close>
    and trans :: "(addr * nat act * addr * nat) list list list"
      \<comment> \<open>Transitions between states per process\<close>
    and prog :: "int instrc option list"
    and formula :: formula \<comment> \<open>Model checking formula\<close>
    and bounds :: "(int * int) list"
begin
  definition "clkp_set' \<equiv>
    \<Union> (collect_clock_pairs ` set (concat inv))
    \<union> {constraint_pair ac | ac. Some (CEXP ac) \<in> set prog}"
  definition clk_set'_def: "clk_set' =
    (fst ` clkp_set' \<union> {c. \<exists> x. Some (INSTR (STOREC c x)) \<in> set prog})"

  text \<open>Definition of the corresponding network\<close>
  definition "I i l \<equiv> if l < length (inv ! i) then inv ! i ! l else []"
  definition "T i \<equiv>
    {(l, trans ! i ! l ! j) | l j. l < length (trans ! i) \<and> j < length (trans ! i ! l)}"
  definition "P \<equiv> map (\<lambda> P l. P ! l) pred"
  definition "PROG pc \<equiv> (if pc < length prog then prog ! pc else None)"
  definition N :: "(nat, int, nat) unta" where
    "N \<equiv> (PROG, map (\<lambda> i. (T i, I i)) [0..<p], P, bounds)"
  definition "init \<equiv> repeat (0::nat) p"
  definition "F \<equiv> hd_of_formula formula"

  sublocale equiv: Equiv_TA_Defs N max_steps .

  thm equiv.defs.prod_trans_i_alt_def

  abbreviation "EA \<equiv> equiv.state_ta"

  abbreviation "A \<equiv> equiv.defs.prod_ta"

  lemma [simp]:
    "equiv.p = p"
    unfolding equiv.p_def N_def Equiv_TA_Defs.p_def by simp

  lemma [simp]:
    "length (equiv.defs.N_s s) = p"
    unfolding equiv.defs.N_s_def by simp

  lemma length_N[simp]:
    "length equiv.defs.N = p"
    by simp

  lemma
    "equiv.defs.I' s L = concat (map (\<lambda> q. if q < p then I q (L ! q) else []) [0..<length L])"
    unfolding inv_of_def
    unfolding Product_TA_Defs.product_ta_def
    apply simp
    unfolding Product_TA_Defs.product_invariant_def
    unfolding equiv.defs.N_s_def inv_of_def
    apply (rule arg_cong[where f = concat])
    unfolding Equiv_TA_Defs.state_ta_def
      apply simp
    unfolding N_def Equiv_TA_Defs.state_inv_def
      by simp

end (* End of definitions locale *)

  lemma snd_comp[simp]:
    "snd o (\<lambda> i. (f i, g i)) = g"
  by auto

locale UPPAAL_Reachability_Problem_precompiled =
  UPPAAL_Reachability_Problem_precompiled_defs +
  assumes process_length: "length inv = p" "length trans = p" "length pred = p"
    and lengths:
    "\<forall> i < p. length (pred ! i) = length (trans ! i) \<and> length (inv ! i) = length (trans ! i)"
    and state_set: "\<forall> T \<in> set trans. \<forall> xs \<in> set T. \<forall> (_, _, _, l) \<in> set xs. l < length T"
  assumes consts_nats: "snd ` clkp_set' \<subseteq> \<nat>"
  (* XXX This could also be subset for now but is left like this as an input sanity check right now *)
  assumes clock_set: "clk_set' = {1..m}"
    and p_gt_0: "p > 0"
    and m_gt_0: "m > 0"
    (* XXX Can get rid of these two? *)
    and processes_have_trans: "\<forall> i < p. trans ! i \<noteq> []" \<comment> \<open>Necessary for refinement\<close>
    and start_has_trans: "\<forall> q < p. trans ! q ! 0 \<noteq> []" \<comment> \<open>Necessary for refinement\<close>
  (* XXX Do not need this but a useful cautious check for the user? *)
  assumes resets_zero: "\<forall> x c. Some (INSTR (STOREC c x)) \<in> set prog \<longrightarrow> x = 0"

(*
locale UPPAAL_Reachability_Problem_precompiled =
  UPPAAL_Reachability_Problem_precompiled_raw +
  assumes discrete_state_finite: "\<forall> i < p. \<forall> l < length (trans ! i). finite {s. (pred ! i ! l) s}"
*)
begin

  lemma consts_nats':
    "\<forall> I \<in> set inv. \<forall> cc \<in> set I. \<forall> (c, d) \<in> collect_clock_pairs cc. d \<in> \<nat>"
    (* "\<forall> T \<in> set trans. \<forall> xs \<in> set T. \<forall> (g, _) \<in> set xs. \<forall> (c, d) \<in> collect_clock_pairs g. d \<in> \<nat>" *)
    "\<forall> ac. Some (CEXP ac) \<in> set prog \<longrightarrow> (snd (constraint_pair ac) \<in> \<nat>)"
    using consts_nats unfolding clkp_set'_def by force+

  thm equiv.defs.collect_clkt_prod_trans_subs
  thm equiv.defs.collect_clki_prod_invariant[of init]
  thm equiv.defs.collect_clkvt_prod_trans_subs

  term "range (snd (equiv.defs.N ! p))" term "snd (equiv.defs.N ! p)"
    term "set inv" term "set (concat inv)"
    term "equiv.defs.N"

  lemma clk_pairs_N_inv:
    "\<Union> (collect_clock_pairs ` range (snd x)) \<subseteq> \<Union> (collect_clock_pairs ` set (concat inv))"
    if "x \<in> set equiv.defs.N" for x
    using that process_length(1)
    unfolding equiv.state_ta_def equiv.state_inv_def equiv.p_def
    unfolding N_def I_def
    by clarsimp (auto split: if_split_asm dest: nth_mem)+

  lemma clkp_set_simp_1:
    "\<Union> (collect_clock_pairs ` set (concat inv)) \<supseteq> Timed_Automata.collect_clki (snd A)"
    unfolding equiv.defs.prod_ta_def inv_of_def
    apply (rule subset_trans)
     apply simp
     apply (rule equiv.defs.collect_clki_prod_invariant')
    unfolding Timed_Automata.collect_clki_def using clk_pairs_N_inv nth_mem by blast

  lemma clk_set_simp_2:
    "{c. \<exists> x. Some (INSTR (STOREC c x)) \<in> set prog} \<supseteq> collect_clkvt (trans_of A)"
    unfolding equiv.defs.prod_ta_def trans_of_def
    apply (rule subset_trans)
     apply simp
     apply (rule equiv.defs.collect_clkvt_prod_trans_subs)
    apply (rule subset_trans)
     apply (rule equiv.product_trans_resets)
    unfolding N_def PROG_def by (auto dest!: nth_mem) metis

  lemma clkp_set_simp_3:
    "{constraint_pair ac | ac. Some (CEXP ac) \<in> set prog} \<supseteq> Timed_Automata.collect_clkt (trans_of A)"
    unfolding equiv.defs.prod_ta_def trans_of_def
    apply (rule subset_trans)
     apply simp
     apply (rule equiv.defs.collect_clkt_prod_trans_subs)
    apply (rule subset_trans)
     apply (rule equiv.product_trans_guards)
    unfolding N_def PROG_def by (auto dest!: nth_mem)

  lemma clkp_set'_subs:
    "Timed_Automata.clkp_set A \<subseteq> clkp_set'"
    using clkp_set_simp_1 clkp_set_simp_3
    by (auto simp add: clkp_set'_def Timed_Automata.clkp_set_def inv_of_def)

  lemma clk_set'_subs:
    "clk_set A \<subseteq> clk_set'"
    using clkp_set'_subs clk_set_simp_2 by (auto simp: clk_set'_def)

  lemma clk_set:
    "clk_set A \<subseteq> {1..m}"
    using clock_set m_gt_0 clk_set'_subs by auto

  lemma
    "\<forall>(_, d)\<in>Timed_Automata.clkp_set A. d \<in> \<int>"
    unfolding Ints_def by auto

  lemma clkp_set'_consts_nat:
    "\<forall>(_, d)\<in>clkp_set'. d \<in> \<nat>"
    using consts_nats' unfolding clkp_set'_def
    apply auto
     apply force
    by (metis snd_conv)

  lemma clkp_set_consts_nat:
    "\<forall>(_, d)\<in>Timed_Automata.clkp_set A. d \<in> \<nat>"
    using clkp_set'_subs clkp_set'_consts_nat by auto

  lemma finite_clkp_set':
    "finite clkp_set'"
    unfolding clkp_set'_def
    using [[simproc add: finite_Collect]]
    by (auto simp: inj_on_def intro!: finite_vimageI)

  lemma finite_clkp_set_A[intro, simp]:
    "finite (Timed_Automata.clkp_set A)"
    using clkp_set'_subs finite_clkp_set' by (rule finite_subset)

  lemma clkp_set'_bounds:
    "a \<in> {Suc 0..m}" if "(a, b) \<in> clkp_set'"
    using that clock_set unfolding clk_set'_def by auto

  lemma finite_range_inv_of_A[intro, simp]:
    "finite (range (inv_of A))"
    unfolding inv_of_def equiv.defs.prod_ta_def
    apply simp
    apply (rule equiv.defs.finite_rangeI)
      apply simp
    unfolding Equiv_TA_Defs.state_ta_def
    apply simp
    unfolding equiv.state_inv_def
    unfolding N_def
    unfolding I_def
    by (auto intro: finite_subset[where B = "{[]}"])

  (* XXX Interesting for finiteness *)
  (* XXX Move *)
  lemma Collect_fold_pair:
    "{f a b | a b. P a b} = (\<lambda> (a, b). f a b) ` {(a, b). P a b}" for P
    by auto

  lemma finite_T[intro, simp]:
    "finite (trans_of A)"
  unfolding trans_of_def equiv.defs.prod_ta_def
  proof (simp, rule equiv.defs.finite_prod_trans, goal_cases)
    case (1 s)
    show "\<forall>l q. q < equiv.defs.p \<longrightarrow> (equiv.defs.P ! q) l s \<longrightarrow> (bounded equiv.B) s"
      apply simp
      unfolding equiv.state_ta_def equiv.state_pred_def
      by (simp split: option.split)
  next
    case 2
    show "finite {s. bounded equiv.B s}" by (rule equiv.bounded_finite)
  next
    case 3
    show ?case
    proof
      fix A assume A: "A \<in> set equiv.defs.N"
      have
        "{(l, j). l < length (trans ! i) \<and> j < length (trans ! i ! l)}
        = \<Union> ((\<lambda> l. {(l, j) | j. j < length (trans ! i ! l)}) ` {l. l < length (trans ! i)})" for i
        by auto
      then have "finite (T q)" if "q < p" for q
        using that unfolding T_def by (fastforce simp: Collect_fold_pair)
      then have "finite (fst (equiv.N ! q))" if "q < p" for q
        using that unfolding N_def by simp
      then have "finite (equiv.state_trans q)" if "q < p" for q
        using that
        unfolding Equiv_TA_Defs.state_trans_t_def
        using [[simproc add: finite_Collect]]
          by auto
      then show "finite (fst A)" using A unfolding Equiv_TA_Defs.state_ta_def by auto
    qed
  qed (auto simp: p_gt_0)

  sublocale TA_Start_No_Ceiling A "(init, s\<^sub>0)" m
    using clkp_set_consts_nat clk_set m_gt_0 by - (standard; blast)

(*
  sublocale Reachability_Problem_no_ceiling A "(init, s\<^sub>0)" "PR_CONST (\<lambda> (l, s). F l s)" m
    using clkp_set_consts_nat clk_set m_gt_0 by - (standard; blast)
*)

  lemma [simp]:
    "length P = p"
    unfolding P_def using process_length(3) by simp

  lemma [simp]:
    "length equiv.I = p"
    unfolding N_def by simp

  lemma [simp]:
    "length equiv.N = p"
    unfolding N_def by simp

end (* End of locale *)

(*
context UPPAAL_Reachability_Problem_precompiled_defs
begin
  (*definition "clkp_set'' \<equiv>
    \<Union> (collect_clock_pairs ` set (concat inv))
    \<union> {constraint_pair ac | ac. Some (CEXP ac) \<in> set prog}"
*)

  definition "clkp_set'' i l \<equiv>
    collect_clock_pairs (inv ! i ! l) \<union> \<Union> ((\<lambda> (g, _). collect_clock_pairs g) ` set (trans ! i ! l))"

end
*)

(*
locale UPPAAL_Reachability_Problem_precompiled_ceiling =
  UPPAAL_Reachability_Problem_precompiled +
  fixes k :: "nat list list list"
  (*
    and k_length: "length k = p" "\<forall> l \<in> set k. length l = m + 1"
      -- \<open>Zero entry is just a dummy for the zero clock\<close>
    (* XXX Make this an abbreviation? *)
  assumes k_ceiling:
    (* "\<forall> c \<in> {1..m}. k ! c = Max ({d. (c, d) \<in> clkp_set'} \<union> {0})" *)
    "\<forall> (c, d) \<in> clkp_set'. int (k ! c) \<ge> d"
    "k ! 0 = 0"
  *)
begin

  definition
    "k_fun \<equiv> \<lambda> (l, s). \<lambda> c. if 0 < c \<and> c \<le> m then Max {k ! i ! (l ! i) ! c | i. i < p} else 0"

  lemma [intro, simp]:
    "k_fun st 0 = 0"
    unfolding k_fun_def by (simp split: prod.split)

  lemma [intro, simp]:
    "k_fun st i = 0" if "i > m"
    unfolding k_fun_def using that by (simp split: prod.split)

  lemma [intro]:
    "b \<le> int (k_fun a)" if "(a, b) \<in> clkp_set A"
    using that k_ceiling clkp_set'_subs k_length clkp_set'_bounds unfolding k_fun_def by force

  sublocale Reachability_Problem "(init, s\<^sub>0)" "PR_CONST (\<lambda> (l, s). F l s)" m A k_fun
    using clkp_set_consts_nat clk_set m_gt_0 apply - apply standard
       prefer 4 apply simp
      prefer 3 apply simp
      oops

end (* End of locale *)
*)

end (* End of theory *)