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

section{*The Yahalom Protocol: A Flawed Version*}

theory Yahalom_Bad imports Public begin

text{*
Demonstrates of why Oops is necessary.  This protocol can be attacked because
it doesn't keep NB secret, but without Oops it can be "verified" anyway.
The issues are discussed in lcp's LICS 2000 invited lecture.
*}

inductive_set yahalom :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> yahalom"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "[| evsf \<in> yahalom;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> yahalom"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "[| evsr \<in> yahalom;  Says A B X \<in> set evsr |]
               ==> Gets B X # evsr \<in> yahalom"

         (*Alice initiates a protocol run*)
 | YM1:  "[| evs1 \<in> yahalom;  Nonce NA \<notin> used evs1 |]
          ==> Says A B {|Agent A, Nonce NA|} # evs1 \<in> yahalom"

         (*Bob's response to Alice's message.*)
 | YM2:  "[| evs2 \<in> yahalom;  Nonce NB \<notin> used evs2;
             Gets B {|Agent A, Nonce NA|} \<in> set evs2 |]
          ==> Says B Server
                  {|Agent B, Nonce NB, Crypt (shrK B) {|Agent A, Nonce NA|}|}
                # evs2 \<in> yahalom"

         (*The Server receives Bob's message.  He responds by sending a
            new session key to Alice, with a packet for forwarding to Bob.*)
 | YM3:  "[| evs3 \<in> yahalom;  Key KAB \<notin> used evs3;  KAB \<in> symKeys;
             Gets Server
                  {|Agent B, Nonce NB, Crypt (shrK B) {|Agent A, Nonce NA|}|}
               \<in> set evs3 |]
          ==> Says Server A
                   {|Crypt (shrK A) {|Agent B, Key KAB, Nonce NA, Nonce NB|},
                     Crypt (shrK B) {|Agent A, Key KAB|}|}
                # evs3 \<in> yahalom"

         (*Alice receives the Server's (?) message, checks her Nonce, and
           uses the new session key to send Bob his Nonce.  The premise
           A \<noteq> Server is needed to prove Says_Server_not_range.*)
 | YM4:  "[| evs4 \<in> yahalom;  A \<noteq> Server;  K \<in> symKeys;
             Gets A {|Crypt(shrK A) {|Agent B, Key K, Nonce NA, Nonce NB|}, X|}
                \<in> set evs4;
             Says A B {|Agent A, Nonce NA|} \<in> set evs4 |]
          ==> Says A B {|X, Crypt K (Nonce NB)|} # evs4 \<in> yahalom"

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

text{*A "possibility property": there are traces that reach the end*}
lemma "[| A \<noteq> Server; Key K \<notin> used []; K \<in> symKeys |]
       ==> \<exists>X NB. \<exists>evs \<in> yahalom.
              Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] yahalom.Nil
                    [THEN yahalom.YM1, THEN yahalom.Reception,
                     THEN yahalom.YM2, THEN yahalom.Reception,
                     THEN yahalom.YM3, THEN yahalom.Reception,
                     THEN yahalom.YM4])
apply (possibility, simp add: used_Cons)
done

subsection{*Regularity Lemmas for Yahalom*}

lemma Gets_imp_Says:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |] ==> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

(*Must be proved separately for each protocol*)
lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |]  ==> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

declare Gets_imp_knows_Spy [THEN analz.Inj, dest]

subsection{* For reasoning about the encrypted portion of messages *}

text{*Lets us treat YM4 using a similar argument as for the Fake case.*}
lemma YM4_analz_knows_Spy:
     "[| Gets A {|Crypt (shrK A) Y, X|} \<in> set evs;  evs \<in> yahalom |]
      ==> X \<in> analz (knows Spy evs)"
by blast

lemmas YM4_parts_knows_Spy =
       YM4_analz_knows_Spy [THEN analz_into_parts]

text{*Theorems of the form @{term "X \<notin> parts (knows Spy evs)"} imply
            that NOBODY sends messages containing X!*}

text{*Spy never sees a good agent's shared key!*}
lemma Spy_see_shrK [simp]:
     "evs \<in> yahalom ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
apply (erule yahalom.induct, force,
       drule_tac [6] YM4_parts_knows_Spy, simp_all, blast+)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> yahalom ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> yahalom|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

text{*Nobody can have used non-existent keys!
    Needed to apply @{text analz_insert_Key}*}
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> yahalom|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake*}
apply (force dest!: keysFor_parts_insert, auto)
done

subsection{*Secrecy Theorems*}

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

subsection{* Session keys are not used to encrypt other session keys *}

lemma analz_image_freshK [rule_format]:
 "evs \<in> yahalom ==>
   \<forall>K KK. KK <= - (range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
by (erule yahalom.induct,
    drule_tac [7] YM4_analz_knows_Spy, analz_freshK, spy_analz, blast)

lemma analz_insert_freshK:
     "[| evs \<in> yahalom;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text{*The Key K uniquely identifies the Server's  message.*}
lemma unique_session_keys:
     "[| Says Server A
          {|Crypt (shrK A) {|Agent B, Key K, na, nb|}, X|} \<in> set evs;
        Says Server A'
          {|Crypt (shrK A') {|Agent B', Key K, na', nb'|}, X'|} \<in> set evs;
        evs \<in> yahalom |]
     ==> A=A' & B=B' & na=na' & nb=nb'"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt{*YM3, by freshness, and YM4*}
apply blast+
done

text{* Crucial secrecy property: Spy does not see the keys sent in msg YM3 *}
lemma secrecy_lemma:
     "[| A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Says Server A
            {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
              Crypt (shrK B) {|Agent A, Key K|}|}
           \<in> set evs -->
          Key K \<notin> analz (knows Spy evs)"
apply (erule yahalom.induct, force, drule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: pushes analz_insert_eq analz_insert_freshK, spy_analz)  (*Fake*)
apply (blast dest: unique_session_keys)  (*YM3*)
done

text{*Final version*}
lemma Spy_not_see_encrypted_key:
     "[| Says Server A
            {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
              Crypt (shrK B) {|Agent A, Key K|}|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: secrecy_lemma)

subsection{* Security Guarantee for A upon receiving YM3 *}

text{*If the encrypted message appears then it originated with the Server*}
lemma A_trusts_YM3:
     "[| Crypt (shrK A) {|Agent B, Key K, na, nb|} \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> yahalom |]
       ==> Says Server A
            {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
              Crypt (shrK B) {|Agent A, Key K|}|}
           \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM3*}
apply blast+
done

text{*The obvious combination of @{text A_trusts_YM3} with
  @{text Spy_not_see_encrypted_key}*}
lemma A_gets_good_key:
     "[| Crypt (shrK A) {|Agent B, Key K, na, nb|} \<in> parts (knows Spy evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: A_trusts_YM3 Spy_not_see_encrypted_key)

subsection{* Security Guarantees for B upon receiving YM4 *}

text{*B knows, by the first part of A's message, that the Server distributed
  the key for A and B.  But this part says nothing about nonces.*}
lemma B_trusts_YM4_shrK:
     "[| Crypt (shrK B) {|Agent A, Key K|} \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>NA NB. Says Server A
                      {|Crypt (shrK A) {|Agent B, Key K, Nonce NA, Nonce NB|},
                        Crypt (shrK B) {|Agent A, Key K|}|}
                     \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt{*Fake, YM3*}
apply blast+
done

subsection{*The Flaw in the Model*}

text{* Up to now, the reasoning is similar to standard Yahalom.  Now the
    doubtful reasoning occurs.  We should not be assuming that an unknown
    key is secure, but the model allows us to: there is no Oops rule to
    let session keys become compromised.*}

text{*B knows, by the second part of A's message, that the Server distributed
  the key quoting nonce NB.  This part says nothing about agent names.
  Secrecy of K is assumed; the valid Yahalom proof uses (and later proves)
  the secrecy of NB.*}
lemma B_trusts_YM4_newK [rule_format]:
     "[|Key K \<notin> analz (knows Spy evs);  evs \<in> yahalom|]
      ==> Crypt K (Nonce NB) \<in> parts (knows Spy evs) -->
          (\<exists>A B NA. Says Server A
                      {|Crypt (shrK A) {|Agent B, Key K,
                                Nonce NA, Nonce NB|},
                        Crypt (shrK B) {|Agent A, Key K|}|}
                     \<in> set evs)"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt{*Fake*}
apply blast
txt{*YM3*}
apply blast
txt{*A is uncompromised because NB is secure
  A's certificate guarantees the existence of the Server message*}
apply (blast dest!: Gets_imp_Says Crypt_Spy_analz_bad
             dest: Says_imp_spies
                   parts.Inj [THEN parts.Fst, THEN A_trusts_YM3])
done

text{*B's session key guarantee from YM4.  The two certificates contribute to a
  single conclusion about the Server's message. *}
lemma B_trusts_YM4:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Key K|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         Says B Server
           {|Agent B, Nonce NB, Crypt (shrK B) {|Agent A, Nonce NA|}|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
       ==> \<exists>na nb. Says Server A
                   {|Crypt (shrK A) {|Agent B, Key K, na, nb|},
                     Crypt (shrK B) {|Agent A, Key K|}|}
             \<in> set evs"
by (blast dest: B_trusts_YM4_newK B_trusts_YM4_shrK Spy_not_see_encrypted_key
                unique_session_keys)

text{*The obvious combination of @{text B_trusts_YM4} with
  @{text Spy_not_see_encrypted_key}*}
lemma B_gets_good_key:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Key K|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         Says B Server
           {|Agent B, Nonce NB, Crypt (shrK B) {|Agent A, Nonce NA|}|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: B_trusts_YM4 Spy_not_see_encrypted_key)

(*** Authenticating B to A: these proofs are not considered.
     They are irrelevant to showing the need for Oops. ***)

(*** Authenticating A to B using the certificate Crypt K (Nonce NB) ***)

text{*Assuming the session key is secure, if both certificates are present then
  A has said NB.  We can't be sure about the rest of A's message, but only
  NB matters for freshness.*}
lemma A_Said_YM3_lemma [rule_format]:
     "evs \<in> yahalom
      ==> Key K \<notin> analz (knows Spy evs) -->
          Crypt K (Nonce NB) \<in> parts (knows Spy evs) -->
          Crypt (shrK B) {|Agent A, Key K|} \<in> parts (knows Spy evs) -->
          B \<notin> bad -->
          (\<exists>X. Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs)"
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt{*Fake*}
apply blast
txt{*YM3: by @{text new_keys_not_used}, the message
   @{term "Crypt K (Nonce NB)"} could not exist*}
apply (force dest!: Crypt_imp_keysFor)
txt{*YM4: was @{term "Crypt K (Nonce NB)"} the very last message?
    If not, use the induction hypothesis*}
apply (simp add: ex_disj_distrib)
txt{*yes: apply unicity of session keys*}
apply (blast dest!: Gets_imp_Says A_trusts_YM3 B_trusts_YM4_shrK
                    Crypt_Spy_analz_bad
             dest: Says_imp_knows_Spy [THEN parts.Inj] unique_session_keys)
done

text{*If B receives YM4 then A has used nonce NB (and therefore is alive).
  Moreover, A associates K with NB (thus is talking about the same run).
  Other premises guarantee secrecy of K.*}
lemma YM4_imp_A_Said_YM3 [rule_format]:
     "[| Gets B {|Crypt (shrK B) {|Agent A, Key K|},
                  Crypt K (Nonce NB)|} \<in> set evs;
         Says B Server
           {|Agent B, Nonce NB, Crypt (shrK B) {|Agent A, Nonce NA|}|}
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>X. Says A B {|X, Crypt K (Nonce NB)|} \<in> set evs"
by (blast intro!: A_Said_YM3_lemma
          dest: Spy_not_see_encrypted_key B_trusts_YM4 Gets_imp_Says)

end


(*  Title:       Labelled Transition Systems
    Authors:     Thomas Tuerk <tuerk@in.tum.de>
*)

section \<open> Labeled transition systems implementation \<close>

theory LTS_Impl
imports Main "../LTS" "LTSSpec"
        "../../Accessible"
begin

subsubsection \<open> Reachability \<close>

fun (in StdCommonLTS) is_reachable_impl where
   "is_reachable_impl l q [] Q = Q q"
 | "is_reachable_impl l q (\<sigma> # w) Q =
      (succ_bex l (\<lambda>q''. is_reachable_impl l q'' w Q) q \<sigma>)"

lemma (in StdCommonLTS) is_reachable_impl_correct :
  "invar l \<Longrightarrow>
   is_reachable_impl l q w Q =
   (\<exists>q'. Q q' \<and> LTS_is_reachable (\<alpha> l) q w q')"
apply (induct w arbitrary: q)
apply (auto simp add: correct_common)
done

text \<open> The definition above is very simple, but inefficient.
 If a state is reachable via several paths all paths starting at this node
 are searched multiple times. The following definition solves this problem by
 replacing the depth first search with a breath first one. \<close>

fun is_reachable_breath_impl where
   "is_reachable_breath_impl s_emp s_insert s_it succ_it l [] Q = Q"
 | "is_reachable_breath_impl s_emp s_insert s_it succ_it l (a # as) Q =
    is_reachable_breath_impl s_emp s_insert s_it succ_it l as
    (s_it Q (\<lambda>_. True) (\<lambda>q Q'.
       succ_it l q a (\<lambda>_. True) (\<lambda>q' Q'. s_insert q' Q') Q') (s_emp ()))"

lemma is_reachable_breath_impl_alt_def :
  "is_reachable_breath_impl s_emp s_insert s_it succ_it l w Q =
   foldl (\<lambda>Q a. (s_it Q (\<lambda>_. True) (\<lambda>q Q'.
       succ_it l q a (\<lambda>_. True) (\<lambda>q' Q'. s_insert q' Q') Q') (s_emp ()))) Q w"
by (induct w arbitrary: Q) simp_all

lemma is_reachable_breath_impl_correct :
 fixes Q :: 's
 fixes l :: 'l
 fixes w :: "'a list"
 fixes \<alpha> :: "'s \<Rightarrow> 'q set"
 assumes s_emp_OK: "set_empty \<alpha> invar s_emp"
     and s_ins_OK: "set_ins \<alpha> invar s_insert"
     and s_it_OK: "set_iteratei \<alpha> invar s_it"
     and succ_it_OK: "lts_succ_it l_\<alpha> l_invar succ_it"
     and invar_l: "l_invar l"
     and invar_Q: "invar Q"
  defines "Q' \<equiv> is_reachable_breath_impl s_emp s_insert s_it succ_it l w Q"
  shows "invar Q' \<and> \<alpha> Q' = LTS_is_reachable_fun (l_\<alpha> l) w (\<alpha> Q)"
  unfolding Q'_def
  using invar_Q
  proof (induct w arbitrary: Q)
    case Nil thus ?case by simp
  next
    case (Cons a as)
    note ind_hyp = Cons(1)
    note invar_Q = Cons(2)

    define Q'' where "Q'' \<equiv> s_it Q (\<lambda>_. True) (\<lambda>q. succ_it l q a (\<lambda>_. True) s_insert) (s_emp ())"

    have Q''_props: "invar Q'' \<and> \<alpha> Q'' = {q'. \<exists>q \<in> \<alpha> Q. (q, a, q') \<in> l_\<alpha> l}"
    unfolding Q''_def
    proof (rule set_iteratei.iterate_rule_insert_P [OF s_it_OK, where
        I = "\<lambda>QQ Q''. invar Q'' \<and> \<alpha> Q'' = {q'. \<exists>q \<in> QQ. (q, a, q') \<in> l_\<alpha> l}"])
      fix q QQ Q''
      assume asm:"q \<in> \<alpha> Q - QQ" "QQ \<subseteq> \<alpha> Q" "invar Q'' \<and> \<alpha> Q'' = {q'. \<exists>q\<in>QQ. (q, a, q') \<in> l_\<alpha> l}"

      from lts_succ_it.lts_succ_it_correct [OF succ_it_OK, OF invar_l, of q a]
      have it_OK: "set_iterator (succ_it l q a) {q'. (q, a, q') \<in> l_\<alpha> l}" by simp

      show "invar (succ_it l q a (\<lambda>_. True) s_insert Q'') \<and> \<alpha> (succ_it l q a (\<lambda>_. True) s_insert Q'') = {q'. \<exists>q\<in>insert q QQ. (q, a, q') \<in> l_\<alpha> l}"
        apply (rule set_iterator_no_cond_rule_insert_P [OF it_OK, where
                I = "\<lambda>QQ Q'''. invar Q''' \<and> \<alpha> Q''' = \<alpha> Q'' \<union> QQ"])
        apply (auto simp add: asm set_ins.ins_correct[OF s_ins_OK])
      done
    qed (simp_all add: invar_Q set_empty.empty_correct[OF s_emp_OK])
    with ind_hyp[of Q'']
    show ?case by (simp add: Q''_def[symmetric] Bex_def set_eq_iff)
  qed

text \<open> For deterministic transition systems, it is easier \<close>

fun (in StdCommonLTS) DLTS_reach_impl where
   "DLTS_reach_impl l q [] = Some q"
 | "DLTS_reach_impl l q (\<sigma> # w) =
    (case succ l q \<sigma> of None \<Rightarrow> None | Some q' \<Rightarrow>
     DLTS_reach_impl l q' w)"

lemma (in StdCommonLTS) DLTS_reach_impl_alt_def :
  "DLTS_reach_impl l q w =
   foldli w (\<lambda>q_opt. q_opt \<noteq> None) (\<lambda>\<sigma> q_opt. succ l (the q_opt) \<sigma>) (Some q)"
by (induct w arbitrary: q) (simp_all split: option.split)

lemma (in StdCommonLTS) DLTS_reach_impl_correct :
assumes inv_l: "invar l"
    and det_l: "LTS_is_deterministic (\<alpha> l)"
shows "DLTS_reach_impl l q w = DLTS_reach (LTS_to_DLTS (\<alpha> l)) q w"
proof (induct w arbitrary: q)
  case Nil thus ?case by simp
next
  case (Cons a as q)  note ind_hyp = this

  note succ_simps = lts_succ_det_correct [OF inv_l det_l]
  have succ_eq: "LTS_to_DLTS (\<alpha> l) (q, a) = succ l q a"
    apply (cases "succ l q a")
    apply (simp_all)
    apply (simp_all add: succ_simps LTS_to_DLTS_is_none LTS_to_DLTS_is_some_det[OF det_l])
  done

  show ?case
    by (simp add: succ_eq ind_hyp split: option.split)
qed

subsection \<open> Determinism check \<close>

definition LTS_is_complete_deterministic_impl where
  "LTS_is_complete_deterministic_impl Q_ball A_ball succ_it l \<equiv>
   Q_ball (\<lambda>q. A_ball (\<lambda>a. (iterate_is_sng (succ_it l q a))))"

lemma LTS_is_complete_deterministic_impl_correct :
assumes Q_ball_OK: "\<And>P. Q_ball P \<longleftrightarrow> (\<forall>q \<in> Q. P q)"
    and A_ball_OK: "\<And>P. A_ball P \<longleftrightarrow> (\<forall>a \<in> A. P a)"
    and succ_it_OK: "lts_succ_it \<alpha> invar succ_it"
    and Q_A_OK: "\<And>q a q'. (q, a, q') \<in> \<alpha> l \<Longrightarrow> q \<in> Q \<and> a \<in> A \<and> q' \<in> Q"
    and invar_l: "invar l"
shows "LTS_is_complete_deterministic_impl Q_ball A_ball succ_it l \<longleftrightarrow>
       LTS_is_complete_deterministic Q A (\<alpha> l)"
proof -
  have "(\<forall>q\<in>Q. \<forall>a\<in>A. card {v'. (q, a, v') \<in> \<alpha> l} = Suc 0) =
        (LTS_is_deterministic (\<alpha> l) \<and> LTS_is_complete Q A (\<alpha> l))"
        (is "?ls = ?rs")
  proof -
    have ls_eq: "?ls \<longleftrightarrow> (\<forall>q\<in>Q. \<forall>a\<in>A. \<exists>!q'. (q, a, q') \<in> \<alpha> l)"
      apply (simp add: card_Suc_eq Ball_def)
      apply (unfold set_eq_iff)
      apply auto
      apply metis+
    done

    show "?ls = ?rs"
        unfolding ls_eq LTS_is_deterministic_def LTS_is_complete_def Bex_def
      apply (rule_tac iffI)
      apply (metis Q_A_OK)
      apply metis
    done
  qed
  moreover
  { fix q a
    note succ_it_l_OK = lts_succ_it.lts_succ_it_correct [OF succ_it_OK, OF invar_l, of q a]
    note iterate_is_sng_correct[of "succ_it l q a", OF succ_it_l_OK]
  }
  ultimately show ?thesis
    unfolding LTS_is_complete_deterministic_impl_def LTS_is_complete_deterministic_def
      by (simp add: Q_ball_OK A_ball_OK)
qed

end


(*  Title:      ZF/Resid/Residuals.thy
    Author:     Ole Rasmussen
    Copyright   1995  University of Cambridge
*)

theory Residuals imports Substitution begin

consts
  Sres          :: "i"

abbreviation
  "residuals(u,v,w) == <u,v,w> \<in> Sres"

inductive
  domains       "Sres" \<subseteq> "redexes*redexes*redexes"
  intros
    Res_Var:    "n \<in> nat ==> residuals(Var(n),Var(n),Var(n))"
    Res_Fun:    "[|residuals(u,v,w)|]==>
                     residuals(Fun(u),Fun(v),Fun(w))"
    Res_App:    "[|residuals(u1,v1,w1);
                   residuals(u2,v2,w2); b \<in> bool|]==>
                 residuals(App(b,u1,u2),App(0,v1,v2),App(b,w1,w2))"
    Res_redex:  "[|residuals(u1,v1,w1);
                   residuals(u2,v2,w2); b \<in> bool|]==>
                 residuals(App(b,Fun(u1),u2),App(1,Fun(v1),v2),w2/w1)"
  type_intros    subst_type nat_typechecks redexes.intros bool_typechecks

definition
  res_func      :: "[i,i]=>i"     (infixl \<open>|>\<close> 70)  where
  "u |> v == THE w. residuals(u,v,w)"

subsection\<open>Setting up rule lists\<close>

declare Sres.intros [intro]
declare Sreg.intros [intro]
declare subst_type [intro]

inductive_cases [elim!]:
  "residuals(Var(n),Var(n),v)"
  "residuals(Fun(t),Fun(u),v)"
  "residuals(App(b, u1, u2), App(0, v1, v2),v)"
  "residuals(App(b, u1, u2), App(1, Fun(v1), v2),v)"
  "residuals(Var(n),u,v)"
  "residuals(Fun(t),u,v)"
  "residuals(App(b, u1, u2), w,v)"
  "residuals(u,Var(n),v)"
  "residuals(u,Fun(t),v)"
  "residuals(w,App(b, u1, u2),v)"

inductive_cases [elim!]:
  "Var(n) \<Longleftarrow> u"
  "Fun(n) \<Longleftarrow> u"
  "u \<Longleftarrow> Fun(n)"
  "App(1,Fun(t),a) \<Longleftarrow> u"
  "App(0,t,a) \<Longleftarrow> u"

inductive_cases [elim!]:
  "Fun(t) \<in> redexes"

declare Sres.intros [simp]

subsection\<open>residuals is a  partial function\<close>

lemma residuals_function [rule_format]:
     "residuals(u,v,w) ==> \<forall>w1. residuals(u,v,w1) \<longrightarrow> w1 = w"
by (erule Sres.induct, force+)

lemma residuals_intro [rule_format]:
     "u \<sim> v ==> regular(v) \<longrightarrow> (\<exists>w. residuals(u,v,w))"
by (erule Scomp.induct, force+)

lemma comp_resfuncD:
     "[| u \<sim> v;  regular(v) |] ==> residuals(u, v, THE w. residuals(u, v, w))"
apply (frule residuals_intro, assumption, clarify)
apply (subst the_equality)
apply (blast intro: residuals_function)+
done

subsection\<open>Residual function\<close>

lemma res_Var [simp]: "n \<in> nat ==> Var(n) |> Var(n) = Var(n)"
by (unfold res_func_def, blast)

lemma res_Fun [simp]:
    "[|s \<sim> t; regular(t)|]==> Fun(s) |> Fun(t) = Fun(s |> t)"
apply (unfold res_func_def)
apply (blast intro: comp_resfuncD residuals_function)
done

lemma res_App [simp]:
    "[|s \<sim> u; regular(u); t \<sim> v; regular(v); b \<in> bool|]
     ==> App(b,s,t) |> App(0,u,v) = App(b, s |> u, t |> v)"
apply (unfold res_func_def)
apply (blast dest!: comp_resfuncD intro: residuals_function)
done

lemma res_redex [simp]:
    "[|s \<sim> u; regular(u); t \<sim> v; regular(v); b \<in> bool|]
     ==> App(b,Fun(s),t) |> App(1,Fun(u),v) = (t |> v)/ (s |> u)"
apply (unfold res_func_def)
apply (blast elim!: redexes.free_elims dest!: comp_resfuncD
             intro: residuals_function)
done

lemma resfunc_type [simp]:
     "[|s \<sim> t; regular(t)|]==> regular(t) \<longrightarrow> s |> t \<in> redexes"
  by (erule Scomp.induct, auto)

subsection\<open>Commutation theorem\<close>

lemma sub_comp [simp]: "u \<Longleftarrow> v \<Longrightarrow> u \<sim> v"
by (erule Ssub.induct, simp_all)

lemma sub_preserve_reg [rule_format, simp]:
     "u \<Longleftarrow> v \<Longrightarrow> regular(v) \<longrightarrow> regular(u)"
by (erule Ssub.induct, auto)

lemma residuals_lift_rec: "[|u \<sim> v; k \<in> nat|]==> regular(v)\<longrightarrow> (\<forall>n \<in> nat.
         lift_rec(u,n) |> lift_rec(v,n) = lift_rec(u |> v,n))"
apply (erule Scomp.induct, safe)
apply (simp_all add: lift_rec_Var subst_Var lift_subst)
done

lemma residuals_subst_rec:
     "u1 \<sim> u2 ==>  \<forall>v1 v2. v1 \<sim> v2 \<longrightarrow> regular(v2) \<longrightarrow> regular(u2) \<longrightarrow>
                  (\<forall>n \<in> nat. subst_rec(v1,u1,n) |> subst_rec(v2,u2,n) =
                    subst_rec(v1 |> v2, u1 |> u2,n))"
apply (erule Scomp.induct, safe)
apply (simp_all add: lift_rec_Var subst_Var residuals_lift_rec)
apply (drule_tac psi = "\<forall>x. P(x)" for P in asm_rl)
apply (simp add: substitution)
done

lemma commutation [simp]:
     "[|u1 \<sim> u2; v1 \<sim> v2; regular(u2); regular(v2)|]
      ==> (v1/u1) |> (v2/u2) = (v1 |> v2)/(u1 |> u2)"
by (simp add: residuals_subst_rec)

subsection\<open>Residuals are comp and regular\<close>

lemma residuals_preserve_comp [rule_format, simp]:
     "u \<sim> v ==> \<forall>w. u \<sim> w \<longrightarrow> v \<sim> w \<longrightarrow> regular(w) \<longrightarrow> (u|>w) \<sim> (v|>w)"
by (erule Scomp.induct, force+)

lemma residuals_preserve_reg [rule_format, simp]:
     "u \<sim> v ==> regular(u) \<longrightarrow> regular(v) \<longrightarrow> regular(u|>v)"
apply (erule Scomp.induct, auto)
done

subsection\<open>Preservation lemma\<close>

lemma union_preserve_comp: "u \<sim> v ==> v \<sim> (u \<squnion> v)"
by (erule Scomp.induct, simp_all)

lemma preservation [rule_format]:
     "u \<sim> v ==> regular(v) \<longrightarrow> u|>v = (u \<squnion> v)|>v"
apply (erule Scomp.induct, safe)
apply (drule_tac [3] psi = "Fun (u) |> v = w" for u v w in asm_rl)
apply (auto simp add: union_preserve_comp comp_sym_iff)
done

declare sub_comp [THEN comp_sym, simp]

subsection\<open>Prism theorem\<close>

(* Having more assumptions than needed -- removed below  *)
lemma prism_l [rule_format]:
     "v \<Longleftarrow> u \<Longrightarrow>
       regular(u) \<longrightarrow> (\<forall>w. w \<sim> v \<longrightarrow> w \<sim> u \<longrightarrow>
                            w |> u = (w|>v) |> (u|>v))"
by (erule Ssub.induct, force+)

lemma prism: "[|v \<Longleftarrow> u; regular(u); w \<sim> v|] ==> w |> u = (w|>v) |> (u|>v)"
apply (rule prism_l)
apply (rule_tac [4] comp_trans, auto)
done

subsection\<open>Levy's Cube Lemma\<close>

lemma cube: "[|u \<sim> v; regular(v); regular(u); w \<sim> u|]==>
           (w|>u) |> (v|>u) = (w|>v) |> (u|>v)"
apply (subst preservation [of u], assumption, assumption)
apply (subst preservation [of v], erule comp_sym, assumption)
apply (subst prism [symmetric, of v])
apply (simp add: union_r comp_sym_iff)
apply (simp add: union_preserve_regular comp_sym_iff)
apply (erule comp_trans, assumption)
apply (simp add: prism [symmetric] union_l union_preserve_regular
                 comp_sym_iff union_sym)
done

subsection\<open>paving theorem\<close>

lemma paving: "[|w \<sim> u; w \<sim> v; regular(u); regular(v)|]==>
           \<exists>uv vu. (w|>u) |> vu = (w|>v) |> uv & (w|>u) \<sim> vu \<and>
             regular(vu) & (w|>v) \<sim> uv \<and> regular(uv)"
apply (subgoal_tac "u \<sim> v")
apply (safe intro!: exI)
apply (rule cube)
apply (simp_all add: comp_sym_iff)
apply (blast intro: residuals_preserve_comp comp_trans comp_sym)+
done

end


theory Term2
imports "Nominal2_Atoms" "Nominal2_Eqvt" "Nominal2_Supp" "Abs" "Perm" "Fv" "Rsp" "../Attic/Prove"
begin

atom_decl name

section {*** lets with single assignments ***}

datatype rtrm2 =
  rVr2 "name"
| rAp2 "rtrm2" "rtrm2"
| rLm2 "name" "rtrm2" --"bind (name) in (rtrm2)"
| rLt2 "rassign" "rtrm2" --"bind (bv2 rassign) in (rtrm2)"
and rassign =
  rAs "name" "rtrm2"

(* to be given by the user *)
primrec
  rbv2
where
  "rbv2 (rAs x t) = {atom x}"

setup {* snd o define_raw_perms (Datatype.the_info @{theory} "Term2.rtrm2") 2 *}

local_setup {* snd o define_fv_alpha (Datatype.the_info @{theory} "Term2.rtrm2")
  [[[],
    [],
    [(NONE, 0, 1)],
    [(SOME @{term rbv2}, 0, 1)]],
   [[]]] *}

notation
  alpha_rtrm2 ("_ \<approx>2 _" [100, 100] 100) and
  alpha_rassign ("_ \<approx>2b _" [100, 100] 100)
thm alpha_rtrm2_alpha_rassign.intros

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha2_inj}, []), (build_alpha_inj @{thms alpha_rtrm2_alpha_rassign.intros} @{thms rtrm2.distinct rtrm2.inject rassign.distinct rassign.inject} @{thms alpha_rtrm2.cases alpha_rassign.cases} ctxt)) ctxt)) *}
thm alpha2_inj

lemma alpha2_eqvt:
  "t \<approx>2 s \<Longrightarrow> (pi \<bullet> t) \<approx>2 (pi \<bullet> s)"
  "a \<approx>2b b \<Longrightarrow> (pi \<bullet> a) \<approx>2b (pi \<bullet> b)"
sorry

local_setup {* (fn ctxt => snd (Local_Theory.note ((@{binding alpha2_equivp}, []),
  (build_equivps [@{term alpha_rtrm2}, @{term alpha_rassign}] @{thm rtrm2_rassign.induct} @{thm alpha_rtrm2_alpha_rassign.induct} @{thms rtrm2.inject rassign.inject} @{thms alpha2_inj} @{thms rtrm2.distinct rassign.distinct} @{thms alpha_rtrm2.cases alpha_rassign.cases} @{thms alpha2_eqvt} ctxt)) ctxt)) *}
thm alpha2_equivp

local_setup  {* define_quotient_type
  [(([], @{binding trm2}, NoSyn), (@{typ rtrm2}, @{term alpha_rtrm2})),
   (([], @{binding assign}, NoSyn), (@{typ rassign}, @{term alpha_rassign}))]
  ((rtac @{thm alpha2_equivp(1)} 1) THEN (rtac @{thm alpha2_equivp(2)}) 1) *}

local_setup {*
(fn ctxt => ctxt
 |> snd o (Quotient_Def.quotient_lift_const ("Vr2", @{term rVr2}))
 |> snd o (Quotient_Def.quotient_lift_const ("Ap2", @{term rAp2}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lm2", @{term rLm2}))
 |> snd o (Quotient_Def.quotient_lift_const ("Lt2", @{term rLt2}))
 |> snd o (Quotient_Def.quotient_lift_const ("As", @{term rAs}))
 |> snd o (Quotient_Def.quotient_lift_const ("fv_trm2", @{term fv_rtrm2}))
 |> snd o (Quotient_Def.quotient_lift_const ("bv2", @{term rbv2})))
*}
print_theorems

local_setup {* snd o prove_const_rsp @{binding fv_rtrm2_rsp} [@{term fv_rtrm2}, @{term fv_rassign}]
  (fn _ => fvbv_rsp_tac @{thm alpha_rtrm2_alpha_rassign.induct} @{thms fv_rtrm2_fv_rassign.simps} 1) *}
local_setup {* snd o prove_const_rsp @{binding rbv2_rsp} [@{term rbv2}]
  (fn _ => fvbv_rsp_tac @{thm alpha_rtrm2_alpha_rassign.inducts(2)} @{thms rbv2.simps} 1) *}
local_setup {* snd o prove_const_rsp @{binding rVr2_rsp} [@{term rVr2}]
  (fn _ => constr_rsp_tac @{thms alpha2_inj} @{thms fv_rtrm2_rsp} @{thms alpha2_equivp} 1) *}
local_setup {* snd o prove_const_rsp @{binding rAp2_rsp} [@{term rAp2}]
  (fn _ => constr_rsp_tac @{thms alpha2_inj} @{thms fv_rtrm2_rsp} @{thms alpha2_equivp} 1) *}
local_setup {* snd o prove_const_rsp @{binding rLm2_rsp} [@{term rLm2}]
  (fn _ => constr_rsp_tac @{thms alpha2_inj} @{thms fv_rtrm2_rsp} @{thms alpha2_equivp} 1) *}
local_setup {* snd o prove_const_rsp @{binding rLt2_rsp} [@{term rLt2}]
  (fn _ => constr_rsp_tac @{thms alpha2_inj} @{thms fv_rtrm2_rsp rbv2_rsp} @{thms alpha2_equivp} 1) *}
local_setup {* snd o prove_const_rsp @{binding permute_rtrm2_rsp} [@{term "permute :: perm \<Rightarrow> rtrm2 \<Rightarrow> rtrm2"}]
  (fn _ => asm_simp_tac (HOL_ss addsimps @{thms alpha2_eqvt}) 1) *}

end