theory prop_25
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

theorem countIns: "S (count t ts) = count t (insert t ts)"
by hipster_induct_simp_metis

end


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

Very similar to Guard except:
- Guard is replaced by GuardK, guard by guardK, Nonce by Key
- some scripts are slightly modified (+ keyset_in, kparts_parts)
- the hypothesis Key n ~:G (keyset G) is added
*)

section{*protocol-independent confidentiality theorem on keys*}

theory GuardK
imports Analz Extensions
begin

(******************************************************************************
messages where all the occurrences of Key n are
in a sub-message of the form Crypt (invKey K) X with K:Ks
******************************************************************************)

inductive_set
  guardK :: "nat => key set => msg set"
  for n :: nat and Ks :: "key set"
where
  No_Key [intro]: "Key n ~:parts {X} ==> X:guardK n Ks"
| Guard_Key [intro]: "invKey K:Ks ==> Crypt K X:guardK n Ks"
| Crypt [intro]: "X:guardK n Ks ==> Crypt K X:guardK n Ks"
| Pair [intro]: "[| X:guardK n Ks; Y:guardK n Ks |] ==> {|X,Y|}:guardK n Ks"

subsection{*basic facts about @{term guardK}*}

lemma Nonce_is_guardK [iff]: "Nonce p:guardK n Ks"
by auto

lemma Agent_is_guardK [iff]: "Agent A:guardK n Ks"
by auto

lemma Number_is_guardK [iff]: "Number r:guardK n Ks"
by auto

lemma Key_notin_guardK: "X:guardK n Ks ==> X ~= Key n"
by (erule guardK.induct, auto)

lemma Key_notin_guardK_iff [iff]: "Key n ~:guardK n Ks"
by (auto dest: Key_notin_guardK)

lemma guardK_has_Crypt [rule_format]: "X:guardK n Ks ==> Key n:parts {X}
--> (EX K Y. Crypt K Y:kparts {X} & Key n:parts {Y})"
by (erule guardK.induct, auto)

lemma Key_notin_kparts_msg: "X:guardK n Ks ==> Key n ~:kparts {X}"
by (erule guardK.induct, auto dest: kparts_parts)

lemma Key_in_kparts_imp_no_guardK: "Key n:kparts H
==> EX X. X:H & X ~:guardK n Ks"
apply (drule in_kparts, clarify)
apply (rule_tac x=X in exI, clarify)
by (auto dest: Key_notin_kparts_msg)

lemma guardK_kparts [rule_format]: "X:guardK n Ks ==>
Y:kparts {X} --> Y:guardK n Ks"
by (erule guardK.induct, auto dest: kparts_parts parts_sub)

lemma guardK_Crypt: "[| Crypt K Y:guardK n Ks; K ~:invKey`Ks |] ==> Y:guardK n Ks"
  by (ind_cases "Crypt K Y:guardK n Ks") (auto intro!: image_eqI)

lemma guardK_MPair [iff]: "({|X,Y|}:guardK n Ks)
= (X:guardK n Ks & Y:guardK n Ks)"
by (auto, (ind_cases "{|X,Y|}:guardK n Ks", auto)+)

lemma guardK_not_guardK [rule_format]: "X:guardK n Ks ==>
Crypt K Y:kparts {X} --> Key n:kparts {Y} --> Y ~:guardK n Ks"
by (erule guardK.induct, auto dest: guardK_kparts)

lemma guardK_extand: "[| X:guardK n Ks; Ks <= Ks';
[| K:Ks'; K ~:Ks |] ==> Key K ~:parts {X} |] ==> X:guardK n Ks'"
by (erule guardK.induct, auto)

subsection{*guarded sets*}

definition GuardK :: "nat => key set => msg set => bool" where
"GuardK n Ks H == ALL X. X:H --> X:guardK n Ks"

subsection{*basic facts about @{term GuardK}*}

lemma GuardK_empty [iff]: "GuardK n Ks {}"
by (simp add: GuardK_def)

lemma Key_notin_kparts [simplified]: "GuardK n Ks H ==> Key n ~:kparts H"
by (auto simp: GuardK_def dest: in_kparts Key_notin_kparts_msg)

lemma GuardK_must_decrypt: "[| GuardK n Ks H; Key n:analz H |] ==>
EX K Y. Crypt K Y:kparts H & Key (invKey K):kparts H"
apply (drule_tac P="%G. Key n:G" in analz_pparts_kparts_substD, simp)
by (drule must_decrypt, auto dest: Key_notin_kparts)

lemma GuardK_kparts [intro]: "GuardK n Ks H ==> GuardK n Ks (kparts H)"
by (auto simp: GuardK_def dest: in_kparts guardK_kparts)

lemma GuardK_mono: "[| GuardK n Ks H; G <= H |] ==> GuardK n Ks G"
by (auto simp: GuardK_def)

lemma GuardK_insert [iff]: "GuardK n Ks (insert X H)
= (GuardK n Ks H & X:guardK n Ks)"
by (auto simp: GuardK_def)

lemma GuardK_Un [iff]: "GuardK n Ks (G Un H) = (GuardK n Ks G & GuardK n Ks H)"
by (auto simp: GuardK_def)

lemma GuardK_synth [intro]: "GuardK n Ks G ==> GuardK n Ks (synth G)"
by (auto simp: GuardK_def, erule synth.induct, auto)

lemma GuardK_analz [intro]: "[| GuardK n Ks G; ALL K. K:Ks --> Key K ~:analz G |]
==> GuardK n Ks (analz G)"
apply (auto simp: GuardK_def)
apply (erule analz.induct, auto)
by (ind_cases "Crypt K Xa:guardK n Ks" for K Xa, auto)

lemma in_GuardK [dest]: "[| X:G; GuardK n Ks G |] ==> X:guardK n Ks"
by (auto simp: GuardK_def)

lemma in_synth_GuardK: "[| X:synth G; GuardK n Ks G |] ==> X:guardK n Ks"
by (drule GuardK_synth, auto)

lemma in_analz_GuardK: "[| X:analz G; GuardK n Ks G;
ALL K. K:Ks --> Key K ~:analz G |] ==> X:guardK n Ks"
by (drule GuardK_analz, auto)

lemma GuardK_keyset [simp]: "[| keyset G; Key n ~:G |] ==> GuardK n Ks G"
by (simp only: GuardK_def, clarify, drule keyset_in, auto)

lemma GuardK_Un_keyset: "[| GuardK n Ks G; keyset H; Key n ~:H |]
==> GuardK n Ks (G Un H)"
by auto

lemma in_GuardK_kparts: "[| X:G; GuardK n Ks G; Y:kparts {X} |] ==> Y:guardK n Ks"
by blast

lemma in_GuardK_kparts_neq: "[| X:G; GuardK n Ks G; Key n':kparts {X} |]
==> n ~= n'"
by (blast dest: in_GuardK_kparts)

lemma in_GuardK_kparts_Crypt: "[| X:G; GuardK n Ks G; is_MPair X;
Crypt K Y:kparts {X}; Key n:kparts {Y} |] ==> invKey K:Ks"
apply (drule in_GuardK, simp)
apply (frule guardK_not_guardK, simp+)
apply (drule guardK_kparts, simp)
by (ind_cases "Crypt K Y:guardK n Ks", auto)

lemma GuardK_extand: "[| GuardK n Ks G; Ks <= Ks';
[| K:Ks'; K ~:Ks |] ==> Key K ~:parts G |] ==> GuardK n Ks' G"
by (auto simp: GuardK_def dest: guardK_extand parts_sub)

subsection{*set obtained by decrypting a message*}

abbreviation (input)
  decrypt :: "msg set => key => msg => msg set" where
  "decrypt H K Y == insert Y (H - {Crypt K Y})"

lemma analz_decrypt: "[| Crypt K Y:H; Key (invKey K):H; Key n:analz H |]
==> Key n:analz (decrypt H K Y)"
apply (drule_tac P="%H. Key n:analz H" in ssubst [OF insert_Diff])
apply assumption
apply (simp only: analz_Crypt_if, simp)
done

lemma parts_decrypt: "[| Crypt K Y:H; X:parts (decrypt H K Y) |] ==> X:parts H"
by (erule parts.induct, auto intro: parts.Fst parts.Snd parts.Body)

subsection{*number of Crypt's in a message*}

fun crypt_nb :: "msg => nat" where
"crypt_nb (Crypt K X) = Suc (crypt_nb X)" |
"crypt_nb {|X,Y|} = crypt_nb X + crypt_nb Y" |
"crypt_nb X = 0" (* otherwise *)

subsection{*basic facts about @{term crypt_nb}*}

lemma non_empty_crypt_msg: "Crypt K Y:parts {X} ==> crypt_nb X \<noteq> 0"
by (induct X, simp_all, safe, simp_all)

subsection{*number of Crypt's in a message list*}

primrec cnb :: "msg list => nat" where
"cnb [] = 0" |
"cnb (X#l) = crypt_nb X + cnb l"

subsection{*basic facts about @{term cnb}*}

lemma cnb_app [simp]: "cnb (l @ l') = cnb l + cnb l'"
by (induct l, auto)

lemma mem_cnb_minus: "x \<in> set l ==> cnb l = crypt_nb x + (cnb l - crypt_nb x)"
by (induct l, auto)

lemmas mem_cnb_minus_substI = mem_cnb_minus [THEN ssubst]

lemma cnb_minus [simp]: "x \<in> set l ==> cnb (remove l x) = cnb l - crypt_nb x"
apply (induct l, auto)
by (erule_tac l=l and x=x in mem_cnb_minus_substI, simp)

lemma parts_cnb: "Z:parts (set l) ==>
cnb l = (cnb l - crypt_nb Z) + crypt_nb Z"
by (erule parts.induct, auto simp: in_set_conv_decomp)

lemma non_empty_crypt: "Crypt K Y:parts (set l) ==> cnb l \<noteq> 0"
by (induct l, auto dest: non_empty_crypt_msg parts_insert_substD)

subsection{*list of kparts*}

lemma kparts_msg_set: "EX l. kparts {X} = set l & cnb l = crypt_nb X"
apply (induct X, simp_all)
apply (rename_tac agent, rule_tac x="[Agent agent]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Number nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Nonce nat]" in exI, simp)
apply (rename_tac nat, rule_tac x="[Key nat]" in exI, simp)
apply (rule_tac x="[Hash X]" in exI, simp)
apply (clarify, rule_tac x="l@la" in exI, simp)
by (clarify, rename_tac nat X y, rule_tac x="[Crypt nat X]" in exI, simp)

lemma kparts_set: "EX l'. kparts (set l) = set l' & cnb l' = cnb l"
apply (induct l)
apply (rule_tac x="[]" in exI, simp, clarsimp)
apply (rename_tac a b l')
apply (subgoal_tac "EX l''.  kparts {a} = set l'' & cnb l'' = crypt_nb a", clarify)
apply (rule_tac x="l''@l'" in exI, simp)
apply (rule kparts_insert_substI, simp)
by (rule kparts_msg_set)

subsection{*list corresponding to "decrypt"*}

definition decrypt' :: "msg list => key => msg => msg list" where
"decrypt' l K Y == Y # remove l (Crypt K Y)"

declare decrypt'_def [simp]

subsection{*basic facts about @{term decrypt'}*}

lemma decrypt_minus: "decrypt (set l) K Y <= set (decrypt' l K Y)"
by (induct l, auto)

text{*if the analysis of a finite guarded set gives n then it must also give
one of the keys of Ks*}

lemma GuardK_invKey_by_list [rule_format]: "ALL l. cnb l = p
--> GuardK n Ks (set l) --> Key n:analz (set l)
--> (EX K. K:Ks & Key K:analz (set l))"
apply (induct p)
(* case p=0 *)
apply (clarify, drule GuardK_must_decrypt, simp, clarify)
apply (drule kparts_parts, drule non_empty_crypt, simp)
(* case p>0 *)
apply (clarify, frule GuardK_must_decrypt, simp, clarify)
apply (drule_tac P="%G. Key n:G" in analz_pparts_kparts_substD, simp)
apply (frule analz_decrypt, simp_all)
apply (subgoal_tac "EX l'. kparts (set l) = set l' & cnb l' = cnb l", clarsimp)
apply (drule_tac G="insert Y (set l' - {Crypt K Y})"
and H="set (decrypt' l' K Y)" in analz_sub, rule decrypt_minus)
apply (rule_tac analz_pparts_kparts_substI, simp)
apply (case_tac "K:invKey`Ks")
(* K:invKey`Ks *)
apply (clarsimp, blast)
(* K ~:invKey`Ks *)
apply (subgoal_tac "GuardK n Ks (set (decrypt' l' K Y))")
apply (drule_tac x="decrypt' l' K Y" in spec, simp)
apply (subgoal_tac "Crypt K Y:parts (set l)")
apply (drule parts_cnb, rotate_tac -1, simp)
apply (clarify, drule_tac X="Key Ka" and H="insert Y (set l')" in analz_sub)
apply (rule insert_mono, rule set_remove)
apply (simp add: analz_insertD, blast)
(* Crypt K Y:parts (set l) *)
apply (blast dest: kparts_parts)
(* GuardK n Ks (set (decrypt' l' K Y)) *)
apply (rule_tac H="insert Y (set l')" in GuardK_mono)
apply (subgoal_tac "GuardK n Ks (set l')", simp)
apply (rule_tac K=K in guardK_Crypt, simp add: GuardK_def, simp)
apply (drule_tac t="set l'" in sym, simp)
apply (rule GuardK_kparts, simp, simp)
apply (rule_tac B="set l'" in subset_trans, rule set_remove, blast)
by (rule kparts_set)

lemma GuardK_invKey_finite: "[| Key n:analz G; GuardK n Ks G; finite G |]
==> EX K. K:Ks & Key K:analz G"
apply (drule finite_list, clarify)
by (rule GuardK_invKey_by_list, auto)

lemma GuardK_invKey: "[| Key n:analz G; GuardK n Ks G |]
==> EX K. K:Ks & Key K:analz G"
by (auto dest: analz_needs_only_finite GuardK_invKey_finite)

text{*if the analyse of a finite guarded set and a (possibly infinite) set of
keys gives n then it must also gives Ks*}

lemma GuardK_invKey_keyset: "[| Key n:analz (G Un H); GuardK n Ks G; finite G;
keyset H; Key n ~:H |] ==> EX K. K:Ks & Key K:analz (G Un H)"
apply (frule_tac P="%G. Key n:G" and G=G in analz_keyset_substD, simp_all)
apply (drule_tac G="G Un (H Int keysfor G)" in GuardK_invKey_finite)
apply (auto simp: GuardK_def intro: analz_sub)
by (drule keyset_in, auto)

end


(*  Title:      ZF/AC/AC17_AC1.thy
    Author:     Krzysztof Grabczewski

The equivalence of AC0, AC1 and AC17

Also, the proofs needed to show that each of AC2, AC3, ..., AC6 is equivalent
to AC0 and AC1.
*)

theory AC17_AC1
imports HH
begin

(** AC0 is equivalent to AC1.
    AC0 comes from Suppes, AC1 from Rubin & Rubin **)

lemma AC0_AC1_lemma: "\<lbrakk>f:(\<Prod>X \<in> A. X); D \<subseteq> A\<rbrakk> \<Longrightarrow> \<exists>g. g:(\<Prod>X \<in> D. X)"
by (fast intro!: lam_type apply_type)

lemma AC0_AC1: "AC0 \<Longrightarrow> AC1"
  unfolding AC0_def AC1_def
apply (blast intro: AC0_AC1_lemma)
done

lemma AC1_AC0: "AC1 \<Longrightarrow> AC0"
by (unfold AC0_def AC1_def, blast)

(**** The proof of AC1 \<Longrightarrow> AC17 ****)

lemma AC1_AC17_lemma: "f \<in> (\<Prod>X \<in> Pow(A) - {0}. X) \<Longrightarrow> f \<in> (Pow(A) - {0} -> A)"
apply (rule Pi_type, assumption)
apply (drule apply_type, assumption, fast)
done

lemma AC1_AC17: "AC1 \<Longrightarrow> AC17"
  unfolding AC1_def AC17_def
apply (rule allI)
apply (rule ballI)
apply (erule_tac x = "Pow (A) -{0}" in allE)
apply (erule impE, fast)
apply (erule exE)
apply (rule bexI)
apply (erule_tac [2] AC1_AC17_lemma)
apply (rule apply_type, assumption)
apply (fast dest!: AC1_AC17_lemma elim!: apply_type)
done

(**** The proof of AC17 \<Longrightarrow> AC1 ****)

(* *********************************************************************** *)
(* more properties of HH                                                   *)
(* *********************************************************************** *)

lemma UN_eq_imp_well_ord:
     "\<lbrakk>x - (\<Union>j \<in> \<mu> i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, i) = {x}.
        HH(\<lambda>X \<in> Pow(x)-{0}. {f`X}, x, j)) = 0;
        f \<in> Pow(x)-{0} -> x\<rbrakk>
        \<Longrightarrow> \<exists>r. well_ord(x,r)"
apply (rule exI)
apply (erule well_ord_rvimage
        [OF bij_Least_HH_x [THEN bij_converse_bij, THEN bij_is_inj]
            Ord_Least [THEN well_ord_Memrel]], assumption)
done

(* *********************************************************************** *)
(* theorems closer to the proof                                            *)
(* *********************************************************************** *)

lemma not_AC1_imp_ex:
     "\<not>AC1 \<Longrightarrow> \<exists>A. \<forall>f \<in> Pow(A)-{0} -> A. \<exists>u \<in> Pow(A)-{0}. f`u \<notin> u"
  unfolding AC1_def
apply (erule swap)
apply (rule allI)
apply (erule swap)
apply (rule_tac x = "\<Union>(A)" in exI)
apply (blast intro: lam_type)
done

lemma AC17_AC1_aux1:
     "\<lbrakk>\<forall>f \<in> Pow(x) - {0} -> x. \<exists>u \<in> Pow(x) - {0}. f`u\<notin>u;
         \<exists>f \<in> Pow(x)-{0}->x.
            x - (\<Union>a \<in> (\<mu> i. HH(\<lambda>X \<in> Pow(x)-{0}. {f`X},x,i)={x}).
            HH(\<lambda>X \<in> Pow(x)-{0}. {f`X},x,a)) = 0\<rbrakk>
        \<Longrightarrow> P"
apply (erule bexE)
apply (erule UN_eq_imp_well_ord [THEN exE], assumption)
apply (erule ex_choice_fun_Pow [THEN exE])
apply (erule ballE)
apply (fast intro: apply_type del: DiffE)
apply (erule notE)
apply (rule Pi_type, assumption)
apply (blast dest: apply_type)
done

lemma AC17_AC1_aux2:
      "\<not> (\<exists>f \<in> Pow(x)-{0}->x. x - F(f) = 0)
       \<Longrightarrow> (\<lambda>f \<in> Pow(x)-{0}->x . x - F(f))
           \<in> (Pow(x) -{0} -> x) -> Pow(x) - {0}"
by (fast intro!: lam_type dest!: Diff_eq_0_iff [THEN iffD1])

lemma AC17_AC1_aux3:
     "\<lbrakk>f`Z \<in> Z; Z \<in> Pow(x)-{0}\<rbrakk>
      \<Longrightarrow> (\<lambda>X \<in> Pow(x)-{0}. {f`X})`Z \<in> Pow(Z)-{0}"
by auto

lemma AC17_AC1_aux4:
     "\<exists>f \<in> F. f`((\<lambda>f \<in> F. Q(f))`f) \<in> (\<lambda>f \<in> F. Q(f))`f
      \<Longrightarrow> \<exists>f \<in> F. f`Q(f) \<in> Q(f)"
by simp

lemma AC17_AC1: "AC17 \<Longrightarrow> AC1"
  unfolding AC17_def
apply (rule classical)
apply (erule not_AC1_imp_ex [THEN exE])
apply (case_tac
       "\<exists>f \<in> Pow(x)-{0} -> x.
        x - (\<Union>a \<in> (\<mu> i. HH (\<lambda>X \<in> Pow (x) -{0}. {f`X},x,i) ={x}) . HH (\<lambda>X \<in> Pow (x) -{0}. {f`X},x,a)) = 0")
apply (erule AC17_AC1_aux1, assumption)
apply (drule AC17_AC1_aux2)
apply (erule allE)
apply (drule bspec, assumption)
apply (drule AC17_AC1_aux4)
apply (erule bexE)
apply (drule apply_type, assumption)
apply (simp add: HH_Least_eq_x del: Diff_iff )
apply (drule AC17_AC1_aux3, assumption)
apply (fast dest!: subst_elem [OF _ HH_Least_eq_x [symmetric]]
                   f_subset_imp_HH_subset elim!: mem_irrefl)
done

(* **********************************************************************
    AC1 \<Longrightarrow> AC2 \<Longrightarrow> AC1
    AC1 \<Longrightarrow> AC4 \<Longrightarrow> AC3 \<Longrightarrow> AC1
    AC4 \<Longrightarrow> AC5 \<Longrightarrow> AC4
    AC1 \<longleftrightarrow> AC6
************************************************************************* *)

(* ********************************************************************** *)
(* AC1 \<Longrightarrow> AC2                                                            *)
(* ********************************************************************** *)

lemma AC1_AC2_aux1:
     "\<lbrakk>f:(\<Prod>X \<in> A. X);  B \<in> A;  0\<notin>A\<rbrakk> \<Longrightarrow> {f`B} \<subseteq> B \<inter> {f`C. C \<in> A}"
by (fast elim!: apply_type)

lemma AC1_AC2_aux2:
        "\<lbrakk>pairwise_disjoint(A); B \<in> A; C \<in> A; D \<in> B; D \<in> C\<rbrakk> \<Longrightarrow> f`B = f`C"
by (unfold pairwise_disjoint_def, fast)

lemma AC1_AC2: "AC1 \<Longrightarrow> AC2"
  unfolding AC1_def AC2_def
apply (rule allI)
apply (rule impI)
apply (elim asm_rl conjE allE exE impE, assumption)
apply (intro exI ballI equalityI)
prefer 2 apply (rule AC1_AC2_aux1, assumption+)
apply (fast elim!: AC1_AC2_aux2 elim: apply_type)
done

(* ********************************************************************** *)
(* AC2 \<Longrightarrow> AC1                                                            *)
(* ********************************************************************** *)

lemma AC2_AC1_aux1: "0\<notin>A \<Longrightarrow> 0 \<notin> {B*{B}. B \<in> A}"
by (fast dest!: sym [THEN Sigma_empty_iff [THEN iffD1]])

lemma AC2_AC1_aux2: "\<lbrakk>X*{X} \<inter> C = {y}; X \<in> A\<rbrakk>
               \<Longrightarrow> (THE y. X*{X} \<inter> C = {y}): X*A"
apply (rule subst_elem [of y])
apply (blast elim!: equalityE)
apply (auto simp add: singleton_eq_iff)
done

lemma AC2_AC1_aux3:
     "\<forall>D \<in> {E*{E}. E \<in> A}. \<exists>y. D \<inter> C = {y}
      \<Longrightarrow> (\<lambda>x \<in> A. fst(THE z. (x*{x} \<inter> C = {z}))) \<in> (\<Prod>X \<in> A. X)"
apply (rule lam_type)
apply (drule bspec, blast)
apply (blast intro: AC2_AC1_aux2 fst_type)
done

lemma AC2_AC1: "AC2 \<Longrightarrow> AC1"
  unfolding AC1_def AC2_def pairwise_disjoint_def
apply (intro allI impI)
apply (elim allE impE)
prefer 2 apply (fast elim!: AC2_AC1_aux3)
apply (blast intro!: AC2_AC1_aux1)
done

(* ********************************************************************** *)
(* AC1 \<Longrightarrow> AC4                                                            *)
(* ********************************************************************** *)

lemma empty_notin_images: "0 \<notin> {R``{x}. x \<in> domain(R)}"
by blast

lemma AC1_AC4: "AC1 \<Longrightarrow> AC4"
  unfolding AC1_def AC4_def
apply (intro allI impI)
apply (drule spec, drule mp [OF _ empty_notin_images])
apply (best intro!: lam_type elim!: apply_type)
done

(* ********************************************************************** *)
(* AC4 \<Longrightarrow> AC3                                                            *)
(* ********************************************************************** *)

lemma AC4_AC3_aux1: "f \<in> A->B \<Longrightarrow> (\<Union>z \<in> A. {z}*f`z) \<subseteq> A*\<Union>(B)"
by (fast dest!: apply_type)

lemma AC4_AC3_aux2: "domain(\<Union>z \<in> A. {z}*f(z)) = {a \<in> A. f(a)\<noteq>0}"
by blast

lemma AC4_AC3_aux3: "x \<in> A \<Longrightarrow> (\<Union>z \<in> A. {z}*f(z))``{x} = f(x)"
by fast

lemma AC4_AC3: "AC4 \<Longrightarrow> AC3"
  unfolding AC3_def AC4_def
apply (intro allI ballI)
apply (elim allE impE)
apply (erule AC4_AC3_aux1)
apply (simp add: AC4_AC3_aux2 AC4_AC3_aux3 cong add: Pi_cong)
done

(* ********************************************************************** *)
(* AC3 \<Longrightarrow> AC1                                                            *)
(* ********************************************************************** *)

lemma AC3_AC1_lemma:
     "b\<notin>A \<Longrightarrow> (\<Prod>x \<in> {a \<in> A. id(A)`a\<noteq>b}. id(A)`x) = (\<Prod>x \<in> A. x)"
apply (simp add: id_def cong add: Pi_cong)
apply (rule_tac b = A in subst_context, fast)
done

lemma AC3_AC1: "AC3 \<Longrightarrow> AC1"
  unfolding AC1_def AC3_def
apply (fast intro!: id_type elim: AC3_AC1_lemma [THEN subst])
done

(* ********************************************************************** *)
(* AC4 \<Longrightarrow> AC5                                                            *)
(* ********************************************************************** *)

lemma AC4_AC5: "AC4 \<Longrightarrow> AC5"
  unfolding range_def AC4_def AC5_def
apply (intro allI ballI)
apply (elim allE impE)
apply (erule fun_is_rel [THEN converse_type])
apply (erule exE)
apply (rename_tac g)
apply (rule_tac x=g in bexI)
apply (blast dest: apply_equality range_type)
apply (blast intro: Pi_type dest: apply_type fun_is_rel)
done

(* ********************************************************************** *)
(* AC5 \<Longrightarrow> AC4, Rubin & Rubin, p. 11                                      *)
(* ********************************************************************** *)

lemma AC5_AC4_aux1: "R \<subseteq> A*B \<Longrightarrow> (\<lambda>x \<in> R. fst(x)) \<in> R -> A"
by (fast intro!: lam_type fst_type)

lemma AC5_AC4_aux2: "R \<subseteq> A*B \<Longrightarrow> range(\<lambda>x \<in> R. fst(x)) = domain(R)"
by (unfold lam_def, force)

lemma AC5_AC4_aux3: "\<lbrakk>\<exists>f \<in> A->C. P(f,domain(f)); A=B\<rbrakk> \<Longrightarrow>  \<exists>f \<in> B->C. P(f,B)"
apply (erule bexE)
apply (frule domain_of_fun, fast)
done

lemma AC5_AC4_aux4: "\<lbrakk>R \<subseteq> A*B; g \<in> C->R; \<forall>x \<in> C. (\<lambda>z \<in> R. fst(z))` (g`x) = x\<rbrakk>
                \<Longrightarrow> (\<lambda>x \<in> C. snd(g`x)): (\<Prod>x \<in> C. R``{x})"
apply (rule lam_type)
apply (force dest: apply_type)
done

lemma AC5_AC4: "AC5 \<Longrightarrow> AC4"
apply (unfold AC4_def AC5_def, clarify)
apply (elim allE ballE)
apply (drule AC5_AC4_aux3 [OF _ AC5_AC4_aux2], assumption)
apply (fast elim!: AC5_AC4_aux4)
apply (blast intro: AC5_AC4_aux1)
done

(* ********************************************************************** *)
(* AC1 \<longleftrightarrow> AC6                                                            *)
(* ********************************************************************** *)

lemma AC1_iff_AC6: "AC1 \<longleftrightarrow> AC6"
by (unfold AC1_def AC6_def, blast)

end


section {* Relational operational semantics *}

theory utp_rel_opsem
  imports "../hoare/Algebraic_Laws"
begin

fun trel :: "'\<alpha> usubst \<times> '\<alpha> hrel \<Rightarrow> '\<alpha> usubst \<times> '\<alpha> hrel \<Rightarrow> bool" (infix "\<rightarrow>\<^sub>u" 85) where
"(\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q) \<longleftrightarrow> (\<langle>\<sigma>\<rangle>\<^sub>a ;; P) \<sqsubseteq> (\<langle>\<rho>\<rangle>\<^sub>a ;; Q)"

lemma trans_trel:
  "\<lbrakk> (\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q); (\<rho>, Q) \<rightarrow>\<^sub>u (\<phi>, R) \<rbrakk> \<Longrightarrow> (\<sigma>, P) \<rightarrow>\<^sub>u (\<phi>, R)"
  by auto

lemma skip_trel: "(\<sigma>, II) \<rightarrow>\<^sub>u (\<sigma>, II)"
  by simp

lemma assigns_trel: "(\<sigma>, \<langle>\<rho>\<rangle>\<^sub>a) \<rightarrow>\<^sub>u (\<rho> \<circ> \<sigma>, II)"
  by (simp add: assigns_comp)

lemma assign_trel:
  fixes x :: "('a, '\<alpha>) uvar"
  assumes "uvar x"
  shows "(\<sigma>, x :== v) \<rightarrow>\<^sub>u (\<sigma>(x \<mapsto>\<^sub>s \<sigma> \<dagger> v), II)"
  by (simp add: assigns_comp subst_upd_comp)

lemma seq_trel:
  assumes "(\<sigma>, P) \<rightarrow>\<^sub>u (\<rho>, Q)"
  shows "(\<sigma>, P ;; R) \<rightarrow>\<^sub>u (\<rho>, Q ;; R)"
  by (metis (no_types, lifting) assms order_refl seqr_assoc seqr_mono trel.simps)

lemma seq_skip_trel:
  "(\<sigma>, II ;; P) \<rightarrow>\<^sub>u (\<sigma>, P)"
  by simp

lemma nondet_left_trel:
  "(\<sigma>, P \<sqinter> Q) \<rightarrow>\<^sub>u (\<sigma>, P)"
  by (metis (no_types, hide_lams) disj_comm disj_upred_def semilattice_sup_class.sup.absorb_iff1 semilattice_sup_class.sup.left_idem seqr_or_distr trel.simps)

lemma nondet_right_trel:
  "(\<sigma>, P \<sqinter> Q) \<rightarrow>\<^sub>u (\<sigma>, Q)"
  by (simp add: seqr_mono)

lemma rcond_true_trel:
  assumes "\<sigma> \<dagger> b = true"
  shows "(\<sigma>, P \<triangleleft> b \<triangleright>\<^sub>r Q) \<rightarrow>\<^sub>u (\<sigma>, P)"
  using assms
  by (simp add: assigns_r_comp usubst aext_true cond_unit_T)

lemma rcond_false_trel:
  assumes "\<sigma> \<dagger> b = false"
  shows "(\<sigma>, P \<triangleleft> b \<triangleright>\<^sub>r Q) \<rightarrow>\<^sub>u (\<sigma>, Q)"
  using assms
  by (simp add: assigns_r_comp usubst aext_false cond_unit_F)

lemma while_true_trel:
  assumes "\<sigma> \<dagger> b = true"
  shows "(\<sigma>, while b do P od) \<rightarrow>\<^sub>u (\<sigma>, P ;; while b do P od)"
  by (metis assms rcond_true_trel while_unfold)

lemma while_false_trel:
  assumes "\<sigma> \<dagger> b = false"
  shows "(\<sigma>, while b do P od) \<rightarrow>\<^sub>u (\<sigma>, II)"
  by (metis assms rcond_false_trel while_unfold)

declare trel.simps [simp del]
end


(*  Title:       variants/d_fwdrreqs/Aodv_Predicates.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
    Author:      Peter Höfner, NICTA
*)

section "Invariant assumptions and properties"

theory D_Aodv_Predicates
imports D_Aodv
begin

text \<open>Definitions for expression assumptions on incoming messages and properties of
      outgoing messages.\<close>

abbreviation not_Pkt :: "msg \<Rightarrow> bool"
where "not_Pkt m \<equiv> case m of Pkt _ _ _ \<Rightarrow> False | _ \<Rightarrow> True"

definition msg_sender :: "msg \<Rightarrow> ip"
where "msg_sender m \<equiv> case m of Rreq _ _ _ _ _ _ _ ipc _  \<Rightarrow> ipc
                              | Rrep _ _ _ _ ipc \<Rightarrow> ipc
                              | Rerr _ ipc \<Rightarrow> ipc
                              | Pkt _ _ ipc \<Rightarrow> ipc"

lemma msg_sender_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip handled.
                          msg_sender (Rreq hops rreqid dip dsn dsk oip osn sip handled) = sip"
  "\<And>hops dip dsn oip sip. msg_sender (Rrep hops dip dsn oip sip) = sip"
  "\<And>dests sip.            msg_sender (Rerr dests sip) = sip"
  "\<And>d dip sip.            msg_sender (Pkt d dip sip) = sip"
  unfolding msg_sender_def by simp_all

definition msg_zhops :: "msg \<Rightarrow> bool"
where "msg_zhops m \<equiv> case m of
                                 Rreq hopsc _ dipc _ _ oipc _ sipc _ \<Rightarrow> hopsc = 0 \<longrightarrow> oipc = sipc
                               | Rrep hopsc dipc _ _ sipc \<Rightarrow> hopsc = 0 \<longrightarrow> dipc = sipc
                               | _ \<Rightarrow> True"

lemma msg_zhops_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip handled.
           msg_zhops (Rreq hops rreqid dip dsn dsk oip osn sip handled) = (hops = 0 \<longrightarrow> oip = sip)"
  "\<And>hops dip dsn oip sip. msg_zhops (Rrep hops dip dsn oip sip) = (hops = 0 \<longrightarrow> dip = sip)"
  "\<And>dests sip.            msg_zhops (Rerr dests sip)        = True"
  "\<And>d dip.                msg_zhops (Newpkt d dip)          = True"
  "\<And>d dip sip.            msg_zhops (Pkt d dip sip)         = True"
  unfolding msg_zhops_def by simp_all

definition rreq_rrep_sn :: "msg \<Rightarrow> bool"
where "rreq_rrep_sn m \<equiv> case m of Rreq _ _ _ _ _ _ osnc _ _ \<Rightarrow> osnc \<ge> 1
                                | Rrep _ _ dsnc _ _ \<Rightarrow> dsnc \<ge> 1
                                | _ \<Rightarrow> True"

lemma rreq_rrep_sn_simps [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip handled.
           rreq_rrep_sn (Rreq hops rreqid dip dsn dsk oip osn sip handled) = (osn \<ge> 1)"
  "\<And>hops dip dsn oip sip. rreq_rrep_sn (Rrep hops dip dsn oip sip) = (dsn \<ge> 1)"
  "\<And>dests sip.            rreq_rrep_sn (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_sn (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_sn (Pkt d dip sip)  = True"
  unfolding rreq_rrep_sn_def by simp_all

definition rreq_rrep_fresh :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rreq_rrep_fresh crt m \<equiv> case m of Rreq hopsc _ _ _ _ oipc osnc ipcc _ \<Rightarrow> (ipcc \<noteq> oipc \<longrightarrow>
                                                oipc\<in>kD(crt) \<and> (sqn crt oipc > osnc
                                                                \<or> (sqn crt oipc = osnc
                                                                   \<and> the (dhops crt oipc) \<le> hopsc
                                                                   \<and> the (flag crt oipc) = val)))
                                | Rrep hopsc dipc dsnc _ ipcc \<Rightarrow> (ipcc \<noteq> dipc \<longrightarrow>
                                                                    dipc\<in>kD(crt)
                                                                  \<and> sqn crt dipc = dsnc
                                                                  \<and> the (dhops crt dipc) = hopsc
                                                                  \<and> the (flag crt dipc) = val)
                                | _ \<Rightarrow> True"

lemma rreq_rrep_fresh [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip handled.
           rreq_rrep_fresh crt (Rreq hops rreqid dip dsn dsk oip osn sip handled) =
                               (sip \<noteq> oip \<longrightarrow> oip\<in>kD(crt)
                                            \<and> (sqn crt oip > osn
                                               \<or> (sqn crt oip = osn
                                                  \<and> the (dhops crt oip) \<le> hops
                                                  \<and> the (flag crt oip) = val)))"
  "\<And>hops dip dsn oip sip. rreq_rrep_fresh crt (Rrep hops dip dsn oip sip) =
                               (sip \<noteq> dip \<longrightarrow> dip\<in>kD(crt)
                                              \<and> sqn crt dip = dsn
                                              \<and> the (dhops crt dip) = hops
                                              \<and> the (flag crt dip) = val)"
  "\<And>dests sip.            rreq_rrep_fresh crt (Rerr dests sip) = True"
  "\<And>d dip.                rreq_rrep_fresh crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rreq_rrep_fresh crt (Pkt d dip sip)  = True"
  unfolding rreq_rrep_fresh_def by simp_all

definition rerr_invalid :: "rt \<Rightarrow> msg \<Rightarrow> bool"
where "rerr_invalid crt m \<equiv> case m of Rerr destsc _ \<Rightarrow> (\<forall>ripc\<in>dom(destsc).
                                            (ripc\<in>iD(crt) \<and> the (destsc ripc) = sqn crt ripc))
                                | _ \<Rightarrow> True"

lemma rerr_invalid [simp]:
  "\<And>hops rreqid dip dsn dsk oip osn sip handled.
                           rerr_invalid crt (Rreq hops rreqid dip dsn dsk oip osn sip handled) = True"
  "\<And>hops dip dsn oip sip. rerr_invalid crt (Rrep hops dip dsn oip sip) = True"
  "\<And>dests sip.            rerr_invalid crt (Rerr dests sip) = (\<forall>rip\<in>dom(dests).
                                                 rip\<in>iD(crt) \<and> the (dests rip) = sqn crt rip)"
  "\<And>d dip.                rerr_invalid crt (Newpkt d dip)   = True"
  "\<And>d dip sip.            rerr_invalid crt (Pkt d dip sip)  = True"
  unfolding rerr_invalid_def by simp_all

definition
  initmissing :: "(nat \<Rightarrow> state option) \<times> 'a \<Rightarrow> (nat \<Rightarrow> state) \<times> 'a"
where
  "initmissing \<sigma> = (\<lambda>i. case (fst \<sigma>) i of None \<Rightarrow> aodv_init i | Some s \<Rightarrow> s, snd \<sigma>)"

lemma not_in_net_ips_fst_init_missing [simp]:
  assumes "i \<notin> net_ips \<sigma>"
    shows "fst (initmissing (netgmap fst \<sigma>)) i = aodv_init i"
  using assms unfolding initmissing_def by simp

lemma fst_initmissing_netgmap_pair_fst [simp]:
  "fst (initmissing (netgmap (\<lambda>(p, q). (fst (id p), snd (id p), q)) s))
                                               = fst (initmissing (netgmap fst s))"
  unfolding initmissing_def by auto

text \<open>We introduce a streamlined alternative to @{term initmissing} with @{term netgmap}
        to simplify invariant statements and thus facilitate their comprehension and
        presentation.\<close>

lemma fst_initmissing_netgmap_default_aodv_init_netlift:
  "fst (initmissing (netgmap fst s)) = default aodv_init (netlift fst s)"
  unfolding initmissing_def default_def
  by (simp add: fst_netgmap_netlift del: One_nat_def)

definition
  netglobal :: "((nat \<Rightarrow> state) \<Rightarrow> bool) \<Rightarrow> ((state \<times> 'b) \<times> 'c) net_state \<Rightarrow> bool"
where
  "netglobal P \<equiv> (\<lambda>s. P (default aodv_init (netlift fst s)))"

end


theory Adequacy
imports ResourcedAdequacy "Denotational-Related"
begin

theorem adequacy:
  assumes "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<noteq> \<bottom>"
  shows "\<exists> \<Delta> v. \<Gamma> : e \<Down>\<^bsub>S\<^esub> \<Delta> : v"
proof-
  have "\<lbrace>\<Gamma>\<rbrace> \<triangleleft>\<triangleright>\<^sup>* \<N>\<lbrace>\<Gamma>\<rbrace>" by (rule heaps_similar)
  hence  "\<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<triangleleft>\<triangleright> (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>C\<^sup>\<infinity>" by (rule denotational_semantics_similar)
  from bot_or_not_bot[OF this] assms
  have "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>C\<^sup>\<infinity> \<noteq> \<bottom>" by metis
  thus ?thesis by (rule resourced_adequacy)
qed

end


theory func_cor_OSMemGet
  imports func_cor_other
begin
thm OSMemGet_pre_def

definition inv_OS_Mem_info_mp1 :: "State \<Rightarrow> OS_MEM_ref \<Rightarrow> bool"
  where "inv_OS_Mem_info_mp1 s p \<equiv> let mp = OS_MEM_info s p in
       OSMemNBlks mp \<ge> 0 \<and> OSMemNFree mp \<ge> 0
     \<and> OSMemNBlks mp \<ge> OSMemNFree mp
     \<and> OSMemNFree mp = int (length (OSMemFreeList mp)) + 1
"

definition inv_OS_Mem_info1 :: "State \<Rightarrow> OS_MEM_ref \<Rightarrow> bool"
  where "inv_OS_Mem_info1 s pmem \<equiv>  (inv_OS_Mem_info_mp1 s pmem)
         \<and>(\<forall> p \<in> OS_MEMs s - {pmem}. inv_OS_Mem_info_mp s p)"

definition inv1 :: "State \<Rightarrow> OS_MEM_ref \<Rightarrow> bool"
  where "inv1 s pmem \<equiv> inv_cur s \<and> inv_OS_Mem_info1 s pmem"

definition Cond1 ::  "Thread \<Rightarrow> OS_MEM_ref \<Rightarrow> State set"
  where "Cond1 t pmem \<equiv> {s. inv1 s pmem}"

lemma stable_pmem :  "stable  \<lbrace>pmem \<in> \<acute>OS_MEMs\<rbrace> (OSMemGet_rely t)"
  by (simp add: stable_def OSMemGet_rely_def  gvars_conf_def gvars_conf_stable_def)

lemma OSMemGet_satRG_h1_cond1 : "inv V \<Longrightarrow>
               \<turnstile>\<^sub>I (W\<acute>ret_mem := \<acute>ret_mem(t \<mapsto> hd (OSMemFreeList (\<acute>OS_MEM_info pmem)));;
              \<acute>OS_MEM_info := \<acute>OS_MEM_info(pmem := \<acute>OS_MEM_info pmem\<lparr>OSMemFreeList :=
               tl (OSMemFreeList (\<acute>OS_MEM_info pmem))\<rparr>);;
              \<acute>OS_MEM_info := \<acute>OS_MEM_info(pmem := \<acute>OS_MEM_info pmem\<lparr>OSMemNFree :=
               OSMemNFree (\<acute>OS_MEM_info pmem) - 1\<rparr>);;
              \<acute>ret := \<acute>ret (t := OS_ERR_NONE))
               sat\<^sub>p [{V\<lparr>ret_mem := (ret_mem V)(t := None)\<rparr>} \<inter> \<lbrace>\<acute>cur = Some t\<rbrace> \<inter> {Va} \<inter> {Vaa} \<inter>
                      \<lbrace>OS_ERR_NONE < OSMemNFree (\<acute>OS_MEM_info pmem)\<rbrace>,
                      {(s, t). s = t}, UNIV, \<lbrace>\<acute>(Pair V) \<in> OSMemGet_guar t\<rbrace> \<inter> OSMemGet_post t]"
  apply (case_tac "{V\<lparr>ret_mem := (ret_mem V)(t := None)\<rparr>} \<inter> \<lbrace>\<acute>cur = Some t\<rbrace> \<inter> {Va}
                   \<inter> {Vaa} \<inter> \<lbrace>OS_ERR_NONE < OSMemNFree (\<acute>OS_MEM_info pmem)\<rbrace> = {}")
   apply (simp add: Emptyprecond)
  apply (rule Seq[where mid = "{V\<lparr>ret_mem := (ret_mem V)(t := Some (hd (OSMemFreeList ((OS_MEM_info V) pmem)))),
                 OS_MEM_info := (OS_MEM_info V)(pmem := OS_MEM_info V pmem
                 \<lparr>OSMemFreeList := tl (OSMemFreeList (OS_MEM_info V pmem)),
                  OSMemNFree := OSMemNFree (OS_MEM_info V pmem) - 1\<rparr>)\<rparr>}"])
  apply (rule Seq[where mid = "{V\<lparr>ret_mem := (ret_mem V)(t := Some (hd (OSMemFreeList ((OS_MEM_info V) pmem)))),
                 OS_MEM_info := (OS_MEM_info V)(pmem := OS_MEM_info V pmem
                  \<lparr>OSMemFreeList := tl (OSMemFreeList (OS_MEM_info V pmem))\<rparr>)\<rparr>}"])
  apply (rule Seq[where mid = "{V\<lparr>ret_mem := (ret_mem V)(t := Some (hd (OSMemFreeList ((OS_MEM_info V) pmem))))\<rparr>}"])
     apply (rule Basic, simp add:OSMemGet_pre_def inv_def Cond1_def)
         apply auto[1]
  using subset_UNIV apply blast
  using stable_id2 apply blast
     apply (simp add: stable_id2)
    apply (rule Basic)
       apply auto[1]
  using subset_UNIV apply blast
  using stable_id2 apply blast
  using stable_id2 apply blast
   apply (rule Basic)
      apply auto[1]
  using subset_UNIV apply blast
  using stable_id2 apply blast
  using stable_id2 apply blast
  apply (rule Basic)
     apply auto[1]
      apply (simp add: OSMemGet_guar_def, clarsimp)
      apply (rule conjI, simp add: gvars_conf_stable_def gvars_conf_def)
      apply (simp add: inv_def inv_cur_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
      apply auto[1]
         apply meson
        apply (smt One_nat_def int_ops(6) of_nat_1)
       apply (smt One_nat_def int_ops(6) of_nat_1)
      apply (simp add: lvars_nochange_def)
     apply (simp add: OSMemGet_post_def)
     apply (simp add: inv_def inv_cur_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
     apply auto[1]
       apply meson
      apply (metis diff_mono diff_zero of_nat_0_le_iff of_nat_1)
  defer
  using stable_id2 apply blast
  using stable_id2 apply blast
  using stable_id2 apply blast
proof -
  assume a1: "OS_ERR_NONE < OSMemNFree (OS_MEM_info V pmem)"
  assume a2: "\<forall>p\<in>OS_MEMs V. let mp = OS_MEM_info V p in OS_ERR_NONE \<le> OSMemNBlks mp \<and> OS_ERR_NONE
    \<le> OSMemNFree mp \<and> OSMemNFree mp \<le> OSMemNBlks mp \<and> OSMemNFree mp = int (length (OSMemFreeList mp))"
assume a3: "pmem \<in> OS_MEMs V"
  have "\<not> OSMemNFree (OS_MEM_info V pmem) < 1"
    using a1 by auto
  then show "OSMemNFree (OS_MEM_info V pmem) - 1 = int (length (OSMemFreeList (OS_MEM_info V pmem)) - Suc NULL)"
    using a3 a2 by (metis (no_types) One_nat_def int_ops(6) of_nat_1)
qed

lemma OSMemGet_satRG_h1_cond2:  "inv V \<Longrightarrow>
     \<turnstile>\<^sub>I (W\<acute>ret := \<acute>ret (t := OS_ERR_TIMEOUT)) sat\<^sub>p
     [{V\<lparr>ret_mem := (ret_mem V)(t := None)\<rparr>} \<inter> \<lbrace>\<acute>cur = Some t\<rbrace> \<inter> {Va} \<inter> {Vaa} \<inter>
      - \<lbrace>OS_ERR_NONE < OSMemNFree (\<acute>OS_MEM_info pmem)\<rbrace>, {(s, t). s = t}, UNIV,
        \<lbrace>\<acute>(Pair V) \<in> OSMemGet_guar t\<rbrace> \<inter> OSMemGet_post t]"
  apply (rule Basic)
     apply auto[1]
      apply (simp add: OSMemGet_guar_def, clarsimp)
      apply (rule conjI, simp add: gvars_conf_stable_def gvars_conf_def)
      apply (simp add: inv_def inv_cur_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
      apply auto[1]
      apply (simp add: lvars_nochange_def)
     apply (simp add: OSMemGet_post_def)
     apply (simp add: inv_def inv_cur_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
  apply auto[1]
    apply simp
  using stable_id2 apply blast
  using stable_id2 apply blast
  done

lemma OSMemGet_satRG_h1: "  \<turnstile>\<^sub>I (W\<acute>ret_mem := \<acute>ret_mem(t := None);;
               AWAIT \<acute>cur = Some t THEN
               Await UNIV
                (IF OS_ERR_NONE < OSMemNFree (\<acute>OS_MEM_info pmem)
                 THEN \<acute>ret_mem := \<acute>ret_mem(t \<mapsto> hd (OSMemFreeList (\<acute>OS_MEM_info pmem)));;
                      \<acute>OS_MEM_info := \<acute>OS_MEM_info
                      (pmem := \<acute>OS_MEM_info pmem\<lparr>OSMemFreeList := tl (OSMemFreeList (\<acute>OS_MEM_info pmem))\<rparr>);;
                      \<acute>OS_MEM_info := \<acute>OS_MEM_info(pmem := \<acute>OS_MEM_info pmem\<lparr>OSMemNFree := OSMemNFree (\<acute>OS_MEM_info pmem) - 1\<rparr>);;
                      \<acute>ret := \<acute>ret(t := OS_ERR_NONE)
                 ELSE \<acute>ret := \<acute>ret(t := OS_ERR_TIMEOUT)FI)
               END) sat\<^sub>p [OSMemGet_pre t \<inter> \<lbrace>pmem \<in> \<acute>OS_MEMs\<rbrace> \<inter> \<lbrace>\<acute>cur = Some t\<rbrace> \<inter>
                           {V}, {(s, t). s = t}, UNIV, \<lbrace>\<acute>(Pair V) \<in> OSMemGet_guar t\<rbrace> \<inter> OSMemGet_post t]"
  apply (case_tac "\<not> inv V")
   apply (simp add: OSMemGet_pre_def  Emptyprecond)
  apply (rule Seq[where mid = "{V\<lparr>ret_mem := (ret_mem V)(t := None)\<rparr>}"])
   apply (rule Basic, simp add:OSMemGet_pre_def inv_def Cond1_def)
      apply (simp add: inv_cur_def inv1_def inv_OS_Mem_info_def inv_OS_Mem_info_mp_def inv_thd_waitq_def)
      apply auto[1]
     apply simp
    apply (simp add: stable_id2)
  apply (simp add: stable_id2)
  apply (rule Await)
    apply (simp add: stable_id2)
   apply (simp add: stable_id2, clarsimp)
  apply (rule Await)
  using stable_id2 apply blast
   apply (simp add: stable_id2, clarsimp)
  apply (rule Cond)
  using stable_id2 apply blast
    apply (simp add: OSMemGet_satRG_h1_cond1)
   apply (simp add: OSMemGet_satRG_h1_cond2)
  by simp

lemma OSMemGet_satRG: "\<Gamma> (OSMemGet t pmem) \<turnstile> OSMemGet_RGCond t"
  apply (simp add:Evt_sat_RG_def)
  apply (simp add:OSMemGet_def OSMemGet_RGCond_def)
  apply (rule BasicEvt)
  apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                 Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
    apply(unfold stm_def)[1]
    apply (rule Await)
      apply (simp add: OSMemGet_pre_stb stable_int2 stable_pmem)
  apply (simp add: OSMemGet_post_stb)
    apply (simp add: OSMemGet_satRG_h1)
  apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                  Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
  using OSMemGet_pre_stb apply simp
  apply (simp add:getrgformula_def OSMemGet_guar_def)
  apply(simp add:body_def Pre\<^sub>f_def Post\<^sub>f_def guard_def
                  Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
  done

end


(*  Title:      HOL/Auth/NS_Shared.thy
    Author:     Lawrence C Paulson and Giampaolo Bella
    Copyright   1996  University of Cambridge
*)

section\<open>Needham-Schroeder Shared-Key Protocol and the Issues Property\<close>

theory NS_Shared imports Public begin

text\<open>
From page 247 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426
\<close>

definition
 (* A is the true creator of X if she has sent X and X never appeared on
    the trace before this event. Recall that traces grow from head. *)
  Issues :: "[agent, agent, msg, event list] => bool"
             ("_ Issues _ with _ on _") where
   "A Issues B with X on evs =
      (\<exists>Y. Says A B Y \<in> set evs & X \<in> parts {Y} &
        X \<notin> parts (spies (takeWhile (% z. z  \<noteq> Says A B Y) (rev evs))))"

inductive_set ns_shared :: "event list set"
 where
        (*Initial trace is empty*)
  Nil:  "[] \<in> ns_shared"
        (*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: "\<lbrakk>evsf \<in> ns_shared;  X \<in> synth (analz (spies evsf))\<rbrakk>
         \<Longrightarrow> Says Spy B X # evsf \<in> ns_shared"

        (*Alice initiates a protocol run, requesting to talk to any B*)
| NS1:  "\<lbrakk>evs1 \<in> ns_shared;  Nonce NA \<notin> used evs1\<rbrakk>
         \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> # evs1  \<in>  ns_shared"

        (*Server's response to Alice's message.
          !! It may respond more than once to A's request !!
          Server doesn't know who the true sender is, hence the A' in
              the sender field.*)
| NS2:  "\<lbrakk>evs2 \<in> ns_shared;  Key KAB \<notin> used evs2;  KAB \<in> symKeys;
          Says A' Server \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> \<in> set evs2\<rbrakk>
         \<Longrightarrow> Says Server A
               (Crypt (shrK A)
                  \<lbrace>Nonce NA, Agent B, Key KAB,
                    (Crypt (shrK B) \<lbrace>Key KAB, Agent A\<rbrace>)\<rbrace>)
               # evs2 \<in> ns_shared"

         (*We can't assume S=Server.  Agent A "remembers" her nonce.
           Need A \<noteq> Server because we allow messages to self.*)
| NS3:  "\<lbrakk>evs3 \<in> ns_shared;  A \<noteq> Server;
          Says S A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs3;
          Says A Server \<lbrace>Agent A, Agent B, Nonce NA\<rbrace> \<in> set evs3\<rbrakk>
         \<Longrightarrow> Says A B X # evs3 \<in> ns_shared"

        (*Bob's nonce exchange.  He does not know who the message came
          from, but responds to A because she is mentioned inside.*)
| NS4:  "\<lbrakk>evs4 \<in> ns_shared;  Nonce NB \<notin> used evs4;  K \<in> symKeys;
          Says A' B (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>) \<in> set evs4\<rbrakk>
         \<Longrightarrow> Says B A (Crypt K (Nonce NB)) # evs4 \<in> ns_shared"

        (*Alice responds with Nonce NB if she has seen the key before.
          Maybe should somehow check Nonce NA again.
          We do NOT send NB-1 or similar as the Spy cannot spoof such things.
          Letting the Spy add or subtract 1 lets him send all nonces.
          Instead we distinguish the messages by sending the nonce twice.*)
| NS5:  "\<lbrakk>evs5 \<in> ns_shared;  K \<in> symKeys;
          Says B' A (Crypt K (Nonce NB)) \<in> set evs5;
          Says S  A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>)
            \<in> set evs5\<rbrakk>
         \<Longrightarrow> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) # evs5 \<in> ns_shared"

        (*This message models possible leaks of session keys.
          The two Nonces identify the protocol run: the rule insists upon
          the true senders in order to make them accurate.*)
| Oops: "\<lbrakk>evso \<in> ns_shared;  Says B A (Crypt K (Nonce NB)) \<in> set evso;
          Says Server A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>)
              \<in> set evso\<rbrakk>
         \<Longrightarrow> Notes Spy \<lbrace>Nonce NA, Nonce NB, Key K\<rbrace> # evso \<in> ns_shared"

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

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "[| A \<noteq> Server; Key K \<notin> used []; K \<in> symKeys |]
       ==> \<exists>N. \<exists>evs \<in> ns_shared.
                    Says A B (Crypt K \<lbrace>Nonce N, Nonce N\<rbrace>) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] ns_shared.Nil
       [THEN ns_shared.NS1, THEN ns_shared.NS2, THEN ns_shared.NS3,
        THEN ns_shared.NS4, THEN ns_shared.NS5])
apply (possibility, simp add: used_Cons)
done

(*This version is similar, while instantiating ?K and ?N to epsilon-terms
lemma "A \<noteq> Server \<Longrightarrow> \<exists>evs \<in> ns_shared.
                Says A B (Crypt ?K \<lbrace>Nonce ?N, Nonce ?N\<rbrace>) \<in> set evs"
*)

subsection\<open>Inductive proofs about @{term ns_shared}\<close>

subsubsection\<open>Forwarding lemmas, to aid simplification\<close>

text\<open>For reasoning about the encrypted portion of message NS3\<close>
lemma NS3_msg_in_parts_spies:
     "Says S A (Crypt KA \<lbrace>N, B, K, X\<rbrace>) \<in> set evs \<Longrightarrow> X \<in> parts (spies evs)"
by blast

text\<open>For reasoning about the Oops message\<close>
lemma Oops_parts_spies:
     "Says Server A (Crypt (shrK A) \<lbrace>NA, B, K, X\<rbrace>) \<in> set evs
            \<Longrightarrow> K \<in> parts (spies evs)"
by blast

text\<open>Theorems of the form @{term "X \<notin> parts (spies evs)"} imply that NOBODY
    sends messages containing @{term X}\<close>

text\<open>Spy never sees another agent's shared key! (unless it's bad at start)\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> ns_shared \<Longrightarrow> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, simp_all, blast+)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> ns_shared \<Longrightarrow> (Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

text\<open>Nobody can have used non-existent keys!\<close>
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> ns_shared|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, simp_all)
txt\<open>Fake, NS2, NS4, NS5\<close>
apply (force dest!: keysFor_parts_insert, blast+)
done

subsubsection\<open>Lemmas concerning the form of items passed in messages\<close>

text\<open>Describes the form of K, X and K' when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "\<lbrakk>Says Server A (Crypt K' \<lbrace>N, Agent B, Key K, X\<rbrace>) \<in> set evs;
       evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK \<and>
          X = (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>) \<and>
          K' = shrK A"
by (erule rev_mp, erule ns_shared.induct, auto)

text\<open>If the encrypted message appears then it originated with the Server\<close>
lemma A_trusts_NS2:
     "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       A \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs"
apply (erule rev_mp)
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, auto)
done

lemma cert_A_form:
     "\<lbrakk>Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       A \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> K \<notin> range shrK \<and>  X = (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>)"
by (blast dest!: A_trusts_NS2 Says_Server_message_form)

text\<open>EITHER describes the form of X when the following message is sent,
  OR     reduces it to the Fake case.
  Use \<open>Says_Server_message_form\<close> if applicable.\<close>
lemma Says_S_message_form:
     "\<lbrakk>Says S A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
       evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> (K \<notin> range shrK \<and> X = (Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>))
          \<or> X \<in> analz (spies evs)"
by (blast dest: Says_imp_knows_Spy analz_shrK_Decrypt cert_A_form analz.Inj)

(*Alternative version also provable
lemma Says_S_message_form2:
  "\<lbrakk>Says S A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
    evs \<in> ns_shared\<rbrakk>
   \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace>) \<in> set evs
       \<or> X \<in> analz (spies evs)"
apply (case_tac "A \<in> bad")
apply (force dest!: Says_imp_knows_Spy [THEN analz.Inj])
by (blast dest!: A_trusts_NS2 Says_Server_message_form)
*)

(****
 SESSION KEY COMPROMISE THEOREM.  To prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (spies evs)) \<Longrightarrow>
  Key K \<in> analz (spies evs)

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

text\<open>NOT useful in this form, but it says that session keys are not used
  to encrypt messages containing other keys, in the actual protocol.
  We require that agents should behave like this subsequently also.\<close>
lemma  "\<lbrakk>evs \<in> ns_shared;  Kab \<notin> range shrK\<rbrakk> \<Longrightarrow>
         (Crypt KAB X) \<in> parts (spies evs) \<and>
         Key K \<in> parts {X} \<longrightarrow> Key K \<in> parts (spies evs)"
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, simp_all)
txt\<open>Fake\<close>
apply (blast dest: parts_insert_subset_Un)
txt\<open>Base, NS4 and NS5\<close>
apply auto
done

subsubsection\<open>Session keys are not used to encrypt other session keys\<close>

text\<open>The equality makes the induction hypothesis easier to apply\<close>

lemma analz_image_freshK [rule_format]:
 "evs \<in> ns_shared \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
             (Key K \<in> analz (Key`KK \<union> (spies evs))) =
             (K \<in> KK \<or> Key K \<in> analz (spies evs))"
apply (erule ns_shared.induct)
apply (drule_tac [8] Says_Server_message_form)
apply (erule_tac [5] Says_S_message_form [THEN disjE], analz_freshK, spy_analz)
txt\<open>NS2, NS3\<close>
apply blast+
done

lemma analz_insert_freshK:
     "\<lbrakk>evs \<in> ns_shared;  KAB \<notin> range shrK\<rbrakk> \<Longrightarrow>
       (Key K \<in> analz (insert (Key KAB) (spies evs))) =
       (K = KAB \<or> Key K \<in> analz (spies evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

subsubsection\<open>The session key K uniquely identifies the message\<close>

text\<open>In messages of this form, the session key uniquely identifies the rest\<close>
lemma unique_session_keys:
     "\<lbrakk>Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
       Says Server A' (Crypt (shrK A') \<lbrace>NA', Agent B', Key K, X'\<rbrace>) \<in> set evs;
       evs \<in> ns_shared\<rbrakk> \<Longrightarrow> A=A' \<and> NA=NA' \<and> B=B' \<and> X = X'"
by (erule rev_mp, erule rev_mp, erule ns_shared.induct, simp_all, blast+)

subsubsection\<open>Crucial secrecy property: Spy doesn't see the keys sent in NS2\<close>

text\<open>Beware of \<open>[rule_format]\<close> and the universal quantifier!\<close>
lemma secrecy_lemma:
     "\<lbrakk>Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K,
                                      Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>\<rbrace>)
              \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> (\<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs) \<longrightarrow>
         Key K \<notin> analz (spies evs)"
apply (erule rev_mp)
apply (erule ns_shared.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (frule_tac [4] Says_S_message_form)
apply (erule_tac [5] disjE)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes split_ifs, spy_analz)
txt\<open>NS2\<close>
apply blast
txt\<open>NS3\<close>
apply (blast dest!: Crypt_Spy_analz_bad A_trusts_NS2
             dest:  Says_imp_knows_Spy analz.Inj unique_session_keys)
txt\<open>Oops\<close>
apply (blast dest: unique_session_keys)
done

text\<open>Final version: Server's message in the most abstract form\<close>
lemma Spy_not_see_encrypted_key:
     "\<lbrakk>Says Server A (Crypt K' \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs;
       \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (spies evs)"
by (blast dest: Says_Server_message_form secrecy_lemma)

subsection\<open>Guarantees available at various stages of protocol\<close>

text\<open>If the encrypted message appears then it originated with the Server\<close>
lemma B_trusts_NS3:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace> \<in> parts (spies evs);
       B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> \<exists>NA. Says Server A
               (Crypt (shrK A) \<lbrace>NA, Agent B, Key K,
                                 Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>\<rbrace>)
              \<in> set evs"
apply (erule rev_mp)
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies, auto)
done

lemma A_trusts_NS4_lemma [rule_format]:
   "evs \<in> ns_shared \<Longrightarrow>
      Key K \<notin> analz (spies evs) \<longrightarrow>
      Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs \<longrightarrow>
      Crypt K (Nonce NB) \<in> parts (spies evs) \<longrightarrow>
      Says B A (Crypt K (Nonce NB)) \<in> set evs"
apply (erule ns_shared.induct, force, drule_tac [4] NS3_msg_in_parts_spies)
apply (analz_mono_contra, simp_all, blast)
txt\<open>NS2: contradiction from the assumptions @{term "Key K \<notin> used evs2"} and
    @{term "Crypt K (Nonce NB) \<in> parts (spies evs2)"}\<close>
apply (force dest!: Crypt_imp_keysFor)
txt\<open>NS4\<close>
apply (metis B_trusts_NS3 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst unique_session_keys)
done

text\<open>This version no longer assumes that K is secure\<close>
lemma A_trusts_NS4:
     "\<lbrakk>Crypt K (Nonce NB) \<in> parts (spies evs);
       Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       \<forall>NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Nonce NB)) \<in> set evs"
by (blast intro: A_trusts_NS4_lemma
          dest: A_trusts_NS2 Spy_not_see_encrypted_key)

text\<open>If the session key has been used in NS4 then somebody has forwarded
  component X in some instance of NS4.  Perhaps an interesting property,
  but not needed (after all) for the proofs below.\<close>
theorem NS4_implies_NS3 [rule_format]:
  "evs \<in> ns_shared \<Longrightarrow>
     Key K \<notin> analz (spies evs) \<longrightarrow>
     Says Server A (Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace>) \<in> set evs \<longrightarrow>
     Crypt K (Nonce NB) \<in> parts (spies evs) \<longrightarrow>
     (\<exists>A'. Says A' B X \<in> set evs)"
apply (erule ns_shared.induct, force)
apply (drule_tac [4] NS3_msg_in_parts_spies)
apply analz_mono_contra
apply (simp_all add: ex_disj_distrib, blast)
txt\<open>NS2\<close>
apply (blast dest!: new_keys_not_used Crypt_imp_keysFor)
txt\<open>NS4\<close>
apply (metis B_trusts_NS3 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst unique_session_keys)
done

lemma B_trusts_NS5_lemma [rule_format]:
  "\<lbrakk>B \<notin> bad;  evs \<in> ns_shared\<rbrakk> \<Longrightarrow>
     Key K \<notin> analz (spies evs) \<longrightarrow>
     Says Server A
          (Crypt (shrK A) \<lbrace>NA, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace>\<rbrace>) \<in> set evs \<longrightarrow>
     Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts (spies evs) \<longrightarrow>
     Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs"
apply (erule ns_shared.induct, force)
apply (drule_tac [4] NS3_msg_in_parts_spies)
apply (analz_mono_contra, simp_all, blast)
txt\<open>NS2\<close>
apply (blast dest!: new_keys_not_used Crypt_imp_keysFor)
txt\<open>NS5\<close>
apply (blast dest!: A_trusts_NS2
             dest: Says_imp_knows_Spy [THEN analz.Inj]
                   unique_session_keys Crypt_Spy_analz_bad)
done

text\<open>Very strong Oops condition reveals protocol's weakness\<close>
lemma B_trusts_NS5:
     "\<lbrakk>Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts (spies evs);
       Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace> \<in> parts (spies evs);
       \<forall>NA NB. Notes Spy \<lbrace>NA, NB, Key K\<rbrace> \<notin> set evs;
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs"
by (blast intro: B_trusts_NS5_lemma
          dest: B_trusts_NS3 Spy_not_see_encrypted_key)

text\<open>Unaltered so far wrt original version\<close>

subsection\<open>Lemmas for reasoning about predicate "Issues"\<close>

lemma spies_Says_rev: "spies (evs @ [Says A B X]) = insert X (spies evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_Gets_rev: "spies (evs @ [Gets A X]) = spies evs"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_Notes_rev: "spies (evs @ [Notes A X]) =
          (if A:bad then insert X (spies evs) else spies evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
done

lemma spies_evs_rev: "spies evs = spies (rev evs)"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a")
apply (simp_all (no_asm_simp) add: spies_Says_rev spies_Gets_rev spies_Notes_rev)
done

lemmas parts_spies_evs_revD2 = spies_evs_rev [THEN equalityD2, THEN parts_mono]

lemma spies_takeWhile: "spies (takeWhile P evs) <=  spies evs"
apply (induct_tac "evs")
apply (rename_tac [2] a b)
apply (induct_tac [2] "a", auto)
txt\<open>Resembles \<open>used_subset_append\<close> in theory Event.\<close>
done

lemmas parts_spies_takeWhile_mono = spies_takeWhile [THEN parts_mono]

subsection\<open>Guarantees of non-injective agreement on the session key, and
of key distribution. They also express forms of freshness of certain messages,
namely that agents were alive after something happened.\<close>

lemma B_Issues_A:
     "\<lbrakk> Says B A (Crypt K (Nonce Nb)) \<in> set evs;
         Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad; evs \<in> ns_shared \<rbrakk>
      \<Longrightarrow> B Issues A with (Crypt K (Nonce Nb)) on evs"
apply (simp (no_asm) add: Issues_def)
apply (rule exI)
apply (rule conjI, assumption)
apply (simp (no_asm))
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
apply (simp_all)
txt\<open>fake\<close>
apply blast
apply (simp_all add: takeWhile_tail)
txt\<open>NS3 remains by pure coincidence!\<close>
apply (force dest!: A_trusts_NS2 Says_Server_message_form)
txt\<open>NS4 would be the non-trivial case can be solved by Nb being used\<close>
apply (blast dest: parts_spies_takeWhile_mono [THEN subsetD]
                   parts_spies_evs_revD2 [THEN subsetD])
done

text\<open>Tells A that B was alive after she sent him the session key.  The
session key must be assumed confidential for this deduction to be meaningful,
but that assumption can be relaxed by the appropriate argument.

Precisely, the theorem guarantees (to A) key distribution of the session key
to B. It also guarantees (to A) non-injective agreement of B with A on the
session key. Both goals are available to A in the sense of Goal Availability.
\<close>
lemma A_authenticates_and_keydist_to_B:
     "\<lbrakk>Crypt K (Nonce NB) \<in> parts (spies evs);
       Crypt (shrK A) \<lbrace>NA, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
       Key K \<notin> analz(knows Spy evs);
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
      \<Longrightarrow> B Issues A with (Crypt K (Nonce NB)) on evs"
by (blast intro: A_trusts_NS4_lemma B_Issues_A dest: A_trusts_NS2)

lemma A_trusts_NS5:
  "\<lbrakk> Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts(spies evs);
     Crypt (shrK A) \<lbrace>Nonce NA, Agent B, Key K, X\<rbrace> \<in> parts(spies evs);
     Key K \<notin> analz (spies evs);
     A \<notin> bad; B \<notin> bad; evs \<in> ns_shared \<rbrakk>
 \<Longrightarrow> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
apply (simp_all)
txt\<open>Fake\<close>
apply blast
txt\<open>NS2\<close>
apply (force dest!: Crypt_imp_keysFor)
txt\<open>NS3\<close>
apply (metis NS3_msg_in_parts_spies parts_cut_eq)
txt\<open>NS5, the most important case, can be solved by unicity\<close>
apply (metis A_trusts_NS2 Crypt_Spy_analz_bad Says_imp_analz_Spy Says_imp_parts_knows_Spy analz.Fst analz.Snd unique_session_keys)
done

lemma A_Issues_B:
     "\<lbrakk> Says A B (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) \<in> set evs;
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad; evs \<in> ns_shared \<rbrakk>
    \<Longrightarrow> A Issues B with (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) on evs"
apply (simp (no_asm) add: Issues_def)
apply (rule exI)
apply (rule conjI, assumption)
apply (simp (no_asm))
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule ns_shared.induct, analz_mono_contra)
apply (simp_all)
txt\<open>fake\<close>
apply blast
apply (simp_all add: takeWhile_tail)
txt\<open>NS3 remains by pure coincidence!\<close>
apply (force dest!: A_trusts_NS2 Says_Server_message_form)
txt\<open>NS5 is the non-trivial case and cannot be solved as in @{term B_Issues_A}! because NB is not fresh. We need @{term A_trusts_NS5}, proved for this very purpose\<close>
apply (blast dest: A_trusts_NS5 parts_spies_takeWhile_mono [THEN subsetD]
        parts_spies_evs_revD2 [THEN subsetD])
done

text\<open>Tells B that A was alive after B issued NB.

Precisely, the theorem guarantees (to B) key distribution of the session key to A. It also guarantees (to B) non-injective agreement of A with B on the session key. Both goals are available to B in the sense of Goal Availability.
\<close>
lemma B_authenticates_and_keydist_to_A:
     "\<lbrakk>Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace> \<in> parts (spies evs);
       Crypt (shrK B) \<lbrace>Key K, Agent A\<rbrace> \<in> parts (spies evs);
       Key K \<notin> analz (spies evs);
       A \<notin> bad;  B \<notin> bad;  evs \<in> ns_shared\<rbrakk>
   \<Longrightarrow> A Issues B with (Crypt K \<lbrace>Nonce NB, Nonce NB\<rbrace>) on evs"
by (blast intro: A_Issues_B B_trusts_NS5_lemma dest: B_trusts_NS3)

end


section \<open>Weak Mutation Systems\<close>

theory "Transition_Systems-Weak_Mutation_Systems"
imports
  "Transition_Systems-Weak_Transition_Systems"
  "Transition_Systems-Mutation_Systems"
begin

locale weak_mutation_system =
  mutation_system
    \<open>transition\<close>
    \<open>transition\<close>
    \<open>shortcut_transition\<close>
    \<open>shortcut_transition\<close>
    \<open>\<U>\<close>
    \<open>mutation_transition_std\<close> +
  weak_transition_system \<open>transition\<close> \<open>\<tau>\<close>
  for
    transition :: "'a \<Rightarrow> 'p relation" (\<open>'(\<rightarrow>\<lparr>_\<rparr>')\<close>)
  and
    shortcut_transition :: "'a option \<Rightarrow> 'p relation" (\<open>'(\<rightarrow>\<^sup>?\<lparr>_\<rparr>')\<close>)
  and
    universe :: "'p relation set" (\<open>\<U>\<close>)
  and
    mutation_transition_std :: "'p relation \<Rightarrow> 'a \<Rightarrow> 'a option \<Rightarrow> 'p relation \<Rightarrow> bool"
    (\<open>(_ \<longrightarrow>\<lparr>_ \<bar> _\<rparr>/ _)\<close> [51, 0, 0, 51] 50)
  and
    silent :: 'a (\<open>\<tau>\<close>)
  +
  assumes silent_compatibility:
    "\<forall>I \<in> \<U>. I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>) \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>) OO I\<inverse>\<inverse>"
  assumes silent_absorption:
    "\<And>\<alpha> I J. I \<longrightarrow>\<lparr>\<alpha> \<bar> Some \<tau>\<rparr> J \<Longrightarrow> I\<inverse>\<inverse> \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
begin

definition weak_shortcut_transition :: "'a option \<Rightarrow> 'p relation" (\<open>'(\<Rightarrow>\<^sup>?\<lparr>_\<rparr>')\<close>) where
  [simp]: "weak_shortcut_transition = with_shortcut weak_transition"

text \<open>
  We cannot make this lemma private and use it in the \<^theory_text>\<open>sublocale\<close> specification, because \<^theory_text>\<open>private\<close>
  can only appear under \<^theory_text>\<open>context\<close>, but \<^theory_text>\<open>sublocale\<close> is forbidden there.
\<close>

lemma multi_silent_compatibility:
  assumes "I \<in> \<U>"
  shows "I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO I\<inverse>\<inverse>"
proof -
  have "I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^bsup>n\<^esup> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO I\<inverse>\<inverse>" for n
  proof (induction n)
    case 0
    show ?case by auto
  next
    case (Suc n)
    have "I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^bsup>Suc n\<^esup> = I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^bsup>n\<^esup> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)"
      by simp
    also have "\<dots> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)"
      using Suc.IH by blast
    also have "\<dots> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO (\<rightarrow>\<lparr>\<tau>\<rparr>) OO I\<inverse>\<inverse>"
      using silent_compatibility and \<open>I \<in> \<U>\<close>
      by blast
    also have "\<dots> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO I\<inverse>\<inverse>"
      by (blast intro: rtranclp.rtrancl_into_rtrancl)
    finally show ?case .
  qed
  then show ?thesis
    unfolding rtranclp_is_Sup_relpowp
    by blast
qed

sublocale mixed:
  mutation_system
    \<open>transition\<close>
    \<open>weak_transition\<close>
    \<open>shortcut_transition\<close>
    \<open>weak_shortcut_transition\<close>
    \<open>\<U>\<close>
    \<open>mutation_transition_std\<close>
proof (unfold_locales, fold original_shortcut_transition_def weak_shortcut_transition_def)
  fix \<alpha>
  have "I\<inverse>\<inverse> OO (\<Rightarrow>\<^sup>?\<lparr>\<omega>\<rparr>) \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>" if "J \<in> \<U>" and "I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J" for \<omega> and I and J
  proof -
    from that have concrete_connection: "I\<inverse>\<inverse> OO (\<rightarrow>\<^sup>?\<lparr>\<omega>\<rparr>) \<le> (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
      using connection
      by blast
    from \<open>I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J\<close> have \<open>I \<in> \<U>\<close>
      using mutation_transition_std_is_type_correct
      by simp
    consider
      (shortcut)
        "\<omega> = None" |
      (silent)
        "\<omega> = Some \<tau>" |
      (observable)
        \<beta> where "\<beta> \<noteq> \<tau>" and "\<omega> = Some \<beta>"
      by blast
    then show ?thesis
    proof cases
      case shortcut
      have "I\<inverse>\<inverse> OO (\<Rightarrow>\<^sup>?\<lparr>None\<rparr>) = I\<inverse>\<inverse>"
        by auto
      also have "\<dots> = I\<inverse>\<inverse> OO (\<rightarrow>\<^sup>?\<lparr>None\<rparr>)"
        by auto
      also have "\<dots> \<le> (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
        using concrete_connection
        unfolding \<open>\<omega> = None\<close> .
      also have "\<dots> \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
        by auto
      finally show ?thesis
        unfolding \<open>\<omega> = None\<close> .
    next
      case silent
      have "I\<inverse>\<inverse> OO (\<Rightarrow>\<^sup>?\<lparr>Some \<tau>\<rparr>) = I\<inverse>\<inverse> OO (\<Rightarrow>\<lparr>\<tau>\<rparr>)"
        by simp
      also have "\<dots> = I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>*"
        by simp
      also have "\<dots> \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>*"
        using silent_absorption and \<open>I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J\<close>
        unfolding \<open>\<omega> = Some \<tau>\<close>
        by blast
      also have "\<dots> \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO J\<inverse>\<inverse>"
        using multi_silent_compatibility [OF \<open>J \<in> \<U>\<close>]
        by blast
      also have "\<dots> = (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
        by (simp, blast intro: rtranclp_trans)
      finally show ?thesis
        unfolding \<open>\<omega> = Some \<tau>\<close> .
    next
      case observable
      have "I\<inverse>\<inverse> OO (\<Rightarrow>\<^sup>?\<lparr>Some \<beta>\<rparr>) = I\<inverse>\<inverse> OO (\<Rightarrow>\<lparr>\<beta>\<rparr>)"
        by simp
      also have "\<dots> = I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO (\<rightarrow>\<lparr>\<beta>\<rparr>) OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>*"
        using \<open>\<beta> \<noteq> \<tau>\<close>
        by simp
      also have "\<dots> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO I\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<beta>\<rparr>) OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>*"
        using multi_silent_compatibility [OF \<open>I \<in> \<U>\<close>]
        by blast
      also have "\<dots> = (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO I\<inverse>\<inverse> OO (\<rightarrow>\<^sup>?\<lparr>Some \<beta>\<rparr>) OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>*"
        by simp
      also have "\<dots> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse> OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>*"
        using concrete_connection
        unfolding \<open>\<omega> = Some \<beta>\<close>
        by blast
      also have "\<dots> \<le> (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO (\<rightarrow>\<lparr>\<alpha>\<rparr>) OO (\<rightarrow>\<lparr>\<tau>\<rparr>)\<^sup>*\<^sup>* OO J\<inverse>\<inverse>"
        using multi_silent_compatibility [OF \<open>J \<in> \<U>\<close>]
        by blast
      also have "\<dots> \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
        by (auto intro: converse_rtranclp_into_rtranclp rtranclp_trans)
      finally show ?thesis
        unfolding \<open>\<omega> = Some \<beta>\<close> .
    qed
  qed
  then show "\<forall>J \<in> \<U>. \<Squnion> {I\<inverse>\<inverse> OO (\<Rightarrow>\<^sup>?\<lparr>\<omega>\<rparr>) | \<omega> I. I \<longrightarrow>\<lparr>\<alpha> \<bar> \<omega>\<rparr> J} \<le> (\<Rightarrow>\<lparr>\<alpha>\<rparr>) OO J\<inverse>\<inverse>"
    by blast
qed (fact mutation_transition_std_is_type_correct, fact dissection)

text \<open>
  The notation \<open>\<M>\<close> now stands for \<^const>\<open>mutant_lifting\<close> and \<^const>\<open>mixed.mutant_lifting\<close>. We drop
  it as a notation of \<^const>\<open>mutant_lifting\<close>, so that it becomes unique. The identifiers
  \<^const>\<open>mutant_lifting\<close> and \<^const>\<open>mixed.mutant_lifting\<close> refer to the same entity. We chose to keep
  \<open>\<M>\<close> as the notation for \<^const>\<open>mixed.mutant_lifting\<close>, since this is used in term output.
\<close>

no_notation mutant_lifting (\<open>\<M>\<close>)

end

end


theory Substitution_Sema
imports Substitution Sema
begin

lemma substitution_lemma: "\<A> \<Turnstile> F[G / n] \<longleftrightarrow> \<A>(n := \<A> \<Turnstile> G) \<Turnstile> F" by(induction F; simp)

end


(******************************************************************************)
(* External Algorithm for Calculating the Transitive Closure in Isabelle/HOL  *)
(* Author: Frank Zeyda, University of York (UK)                               *)
(* Email: frank.zeyda@york.ac.uk                                              *)
(******************************************************************************)

section {* Transitive Closure Algorithm *}

theory transcl
imports Main Eisbach "~~/src/HOL/Eisbach/Eisbach_Tools"
begin

subsection {* Configuration *}

text \<open>
  The \<open>transcl_home\<close> option sets the home directory of the \<open>transcl\<close> tool:
  this is the location of the \<open>transcl\<close> executable binary. By default, that
  location is derived from the location of the \<open>transcl\<close> theory file. Hence,
  the latter should, if possible, not be compiled into a heap but manually
  imported. Alternatively, by changing the value of this option, a custom
  tool path can be easily configured if needed.
\<close>

ML \<open>
  val transcl_thy_dir = Path.implode (* Use Path.smart_implode? *)
    (Path.append (Resources.master_directory @{theory}) Path.parent);
\<close>

ML \<open>
  val (transcl_home, transcl_home_setup) =
    Attrib.config_string @{binding transcl_home} (K transcl_thy_dir);
\<close>

setup \<open>transcl_home_setup\<close>

text \<open>
  The \<open>transcl_algorithm\<close> option determines the algorithm to be used by the
  tool for computation of the transitive closure. Possible values here have
  to correspond to implemented algorithms inside the tool. For now, they are
  \<open>floyd-warshall\<close> and \<open>boost\<close>, the latter using the C++ Boost Library. The
  default is \<open>floyd-warshall\<close> which seems to work efficiently for graphs up
  to approximately 1024 vertices.
\<close>

ML \<open>
  val (transcl_algorithm, transcl_algorithm_setup) =
    Attrib.config_string @{binding transcl_algorithm} (K "floyd-warshall");
\<close>

setup \<open>transcl_algorithm_setup\<close>

text \<open>
  The \<open>transcl_robust\<close> option specifies whether a more robust way of encoding
  the relation for the external tool should be used. By default, the relation
  is communicated in its pretty-printed form. If, however, this option is set
  to true, the elements of the relation are communicated as ML ASTs. This may,
  in practice, be slower but is invariant to peculiarities of the term printer.
  The default for this option is false.
\<close>

ML \<open>
  val (transcl_robust, transcl_robust_setup) =
    Attrib.config_bool @{binding transcl_robust} (K false);
\<close>

setup \<open>transcl_robust_setup\<close>

subsection {* Pre-Simplifier *}

text \<open>
  The PreSimplifier is used to automatically unfold definitions of relations
  and simplify the result in order to obtain an enumerated set of pairs. The
  \<open>TRUE\<close> predicate below is used as a dummy in order to obtain a theorem for
  some term \<open>t\<close> that can then be transformed using Isabelle's simplifications
  and rules. Pre-simplification steps are automatically preformed before some
  term is submitted to the \<open>transcl\<close> tool.
\<close>

definition TRUE :: "'a::type \<Rightarrow> bool" where
"TRUE t = True"

text \<open>Introduction lemma of \<open>TRUE t\<close> for some arbitrary term \<open>t\<close>.\<close>

lemma TRUE_t:
"TRUE t"
apply (unfold TRUE_def)
apply (rule TrueI)
done

text \<open>Inclusion of the ML program code.\<close>

ML_file "presimplify.ML"

subsection {* Tool and Rewriter *}

text \<open>
  The following constants are pseudo-operators: they are replaced by the result
  of applying the external \<open>transcl\<close> C++ algorithm to their arguments during an
  automatic rewriting step that is carried out after parsing a term. Note that
  their argument has to simplify to an (enumerated) set of pairs, otherwise it
  is not possible to apply the external algorithm. Whereas \<open>transcl(R)\<close> yields
  the transitive (positive) closure of a relation, \<open>rangecl(R)\<close> calculates the
  range of the transitive (positive) closure.
\<close>

consts transcl :: "'a rel \<Rightarrow> 'a rel" ("transcl'(_')")
consts rangecl :: "'a rel \<Rightarrow> 'a set" ("rangecl'(_')")

text \<open>Inclusion of the ML program code.\<close>

ML_file "transcl.ML"

text \<open>Configuration of additional term checkers (rewrite procedures).\<close>

setup {*
  Context.theory_map
    (Syntax_Phases.term_check 2 "transcl" Transcl_Rewriter.transcl_tr)
*}

setup {*
  Context.theory_map
    (Syntax_Phases.term_check 2 "rangecl" Transcl_Rewriter.rangecl_tr)
*}

text \<open>The following prevents use of the constants on their own.\<close>

hide_const transcl
hide_const rangecl

subsection {* Laws and Tactics *}

text \<open>Can we apply the following laws via an Eisbach tactic?\<close>

definition acyclic_witness:
"acyclic_witness C R \<longleftrightarrow> R \<subseteq> C \<and> C O R \<subseteq> C \<and> irrefl C"

lemma acyclic_witnessI:
"(\<exists>C. acyclic_witness C R) \<Longrightarrow> acyclic R"
apply (unfold acyclic_witness)
apply (clarify)
apply (subgoal_tac "R\<^sup>+ \<subseteq> C")
apply (meson acyclicI irrefl_def subset_iff)
apply (erule trancl_Int_subset)
apply (auto)
done

text \<open>
  It turns out that the lemma below sadly is useless in practice generating too
  strong assumptions. Hence, remove \<open>rangecl(_)\<close> and all related functionality
  from the transcl tool.
\<close>

lemma useless_acyclic_witnessI:
"\<exists>S. Range R \<subseteq> S \<and> Domain R \<inter> S = {} \<and> R `` S \<subseteq> S \<Longrightarrow> acyclic R"
apply (clarify)
apply (unfold acyclic_def)
apply (unfold set_eq_iff subset_iff)
apply (clarsimp)
apply (metis Domain.DomainI Range.intros trancl_domain trancl_range)
done

(*<*)
(********************)
(* WORK IN PROGRESS *)
(********************)

method_setup transcl_ex = \<open>
  Args.term >> (fn term => (fn ctx => Method.rule ctx [@{thm exI}]))
\<close>

method acyclic_tac =
  (match conclusion in "acyclic R" for R \<Rightarrow> \<open>print_term R\<close>)

subsection {* Examples *}

term "transcl({(A, B), (B, C), (A, D), (B, E)})"

definition myrel1 :: "string rel" where
"myrel1 = {(''A'', ''B''), (''B'', ''C''), (''A'', ''D''), (''B'', ''E'')}"

definition myrel2 :: "string rel" where
"myrel2 = {(''D'', ''A'')}"

definition myrel3 :: "nat rel" where
"myrel3 = {(1, 2), (2, 3), (1, 4), (2, 5)}"

term "transcl(myrel1)"
term "transcl(myrel2)"
term "transcl(myrel1 \<union> myrel2)"
term "transcl(myrel3)" -- \<open>Note that \<open>transcl(R)\<close> forces \<open>R\<close> to be homogeneous.\<close>

term "rangecl(myrel1)"
term "rangecl(myrel2)"
term "rangecl(myrel1 \<union> myrel2)"
term "rangecl(myrel3)" -- \<open>Note that \<open>transcl(R)\<close> forces \<open>R\<close> to be homogeneous.\<close>

hide_const myrel1 myrel2 myrel3
(*>*)
end


(*  Title:       Deriving class instances for datatypes
    Author:      Christian Sternagel and René Thiemann  <christian.sternagel|rene.thiemann@uibk.ac.at>
    Maintainer:  Christian Sternagel and René Thiemann
    License:     LGPL
*)
subsection \<open>Compare Generator\<close>

theory Compare_Generator
imports
  Comparator_Generator
  Compare
begin

text \<open>We provide a generator which takes the comparators of the comparator generator
  to synthesize suitable @{const compare}-functions from the @{class compare}-class.

One can further also use these comparison functions to derive an instance of the
@{class compare_order}-class, and therefore also for @{class linorder}. In total, we provide the three
\<open>derive\<close>-methods where the example type @{type prod} can be replaced by any other datatype.

\begin{itemize}
\item \<open>derive compare prod\<close> creates an instance @{type prod} :: (@{class compare}, @{class compare}) @{class compare}.
\item \<open>derive compare_order prod\<close> creates an instance @{type prod} :: (@{class compare}, @{class compare}) @{class compare_order}.
\item \<open>derive linorder prod\<close> creates an instance @{type prod} :: (@{class linorder}, @{class linorder}) @{class linorder}.
\end{itemize}

Usually, the use of \<open>derive linorder\<close> is not recommended if there are comparators available:
Internally, the linear orders will directly be converted into comparators, so a direct use of the
comparators will result in more efficient generated code. This command is mainly provided as a convenience method
where comparators are not yet present. For example, at the time of writing, the Container Framework
has partly been adapted to internally use comparators, whereas in other AFP-entries, we did not
integrate comparators.
\<close>

lemma linorder_axiomsD: assumes "class.linorder le lt"
  shows
  "lt x y = (le x y \<and> \<not> le y x)" (is ?a)
  "le x x" (is ?b)
  "le x y \<Longrightarrow> le y z \<Longrightarrow> le x z" (is "?c1 \<Longrightarrow> ?c2 \<Longrightarrow> ?c3")
  "le x y \<Longrightarrow> le y x \<Longrightarrow> x = y" (is "?d1 \<Longrightarrow> ?d2 \<Longrightarrow> ?d3")
  "le x y \<or> le y x" (is ?e)
proof -
  interpret linorder le lt by fact
  show ?a ?b "?c1 \<Longrightarrow> ?c2 \<Longrightarrow> ?c3" "?d1 \<Longrightarrow> ?d2 \<Longrightarrow> ?d3" ?e by auto
qed

named_theorems compare_simps "simp theorems to derive \"compare = comparator_of\""

ML_file \<open>compare_generator.ML\<close>

end


theory ArityEtaExpansionSafe
imports EtaExpansionSafe ArityStack ArityEtaExpansion
begin

lemma Aeta_expand_safe:
  assumes "Astack S \<sqsubseteq> a"
  shows "(\<Gamma>, Aeta_expand a e, S) \<Rightarrow>\<^sup>* (\<Gamma>, e, S)"
proof-
  have "arg_prefix S = Rep_Arity (Astack S)"
    by (induction S arbitrary: a rule: arg_prefix.induct) (auto simp add: Arity.zero_Arity.rep_eq[symmetric])
  also
 from assms
  have "Rep_Arity a \<le> Rep_Arity (Astack S)" by (metis below_Arity.rep_eq)
  finally
  show ?thesis
    by transfer (rule eta_expansion_safe')
qed

end