(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

   Based on extracts from the Jinja theories:
      Common/Objects.thy by David von Oheimb
      Common/Conform.thy by David von Oheimb and Tobias Nipkow
      Common/Exceptions.thy by Gerwin Klein and Martin Strecker
      J/BigStep.thy by Tobias Nipkow
      J/SmallStep.thy by Tobias Nipkow
      J/WellTypeRT.thy by Tobias Nipkow
*)

section \<open>Heap Extension\<close>

theory HeapExtension
imports Progress
begin

subsection \<open>The Heap Extension\<close>

definition hext :: "heap \<Rightarrow> heap \<Rightarrow> bool" ("_ \<unlhd> _" [51,51] 50) where
  "h \<unlhd> h'  \<equiv>  \<forall>a C S. h a = Some(C,S) \<longrightarrow> (\<exists>S'. h' a = Some(C,S'))"

lemma hextI: "\<forall>a C S. h a = Some(C,S) \<longrightarrow> (\<exists>S'. h' a = Some(C,S')) \<Longrightarrow> h \<unlhd> h'"

apply (unfold hext_def)
apply auto
done

lemma hext_objD: "\<lbrakk> h \<unlhd> h'; h a = Some(C,S) \<rbrakk> \<Longrightarrow> \<exists>S'. h' a = Some(C,S')"

apply (unfold hext_def)
apply (force)
done

lemma hext_refl [iff]: "h \<unlhd> h"

apply (rule hextI)
apply (fast)
done

lemma hext_new [simp]: "h a = None \<Longrightarrow> h \<unlhd> h(a\<mapsto>x)"

apply (rule hextI)
apply (auto simp:fun_upd_apply)
done

lemma hext_trans: "\<lbrakk> h \<unlhd> h'; h' \<unlhd> h'' \<rbrakk> \<Longrightarrow> h \<unlhd> h''"

apply (rule hextI)
apply (fast dest: hext_objD)
done

lemma hext_upd_obj: "h a = Some (C,S) \<Longrightarrow> h \<unlhd> h(a\<mapsto>(C,S'))"

apply (rule hextI)
apply (auto simp:fun_upd_apply)
done

subsection \<open>\<open>\<unlhd>\<close> and preallocated\<close>

lemma preallocated_hext:
  "\<lbrakk> preallocated h; h \<unlhd> h' \<rbrakk> \<Longrightarrow> preallocated h'"
by (simp add: preallocated_def hext_def)

lemmas preallocated_upd_obj = preallocated_hext [OF _ hext_upd_obj]
lemmas preallocated_new  = preallocated_hext [OF _ hext_new]

subsection \<open>\<open>\<unlhd>\<close> in Small- and BigStep\<close>

lemma red_hext_incr: "P,E \<turnstile> \<langle>e,(h,l)\<rangle> \<rightarrow> \<langle>e',(h',l')\<rangle>  \<Longrightarrow> h \<unlhd> h'"
  and reds_hext_incr: "P,E \<turnstile> \<langle>es,(h,l)\<rangle> [\<rightarrow>] \<langle>es',(h',l')\<rangle>  \<Longrightarrow> h \<unlhd> h'"

proof(induct rule:red_reds_inducts)
  case RedNew thus ?case
    by(fastforce dest:new_Addr_SomeD simp:hext_def split:if_splits)
next
  case RedFAss thus ?case by(simp add:hext_def split:if_splits)
qed simp_all

lemma step_hext_incr: "P,E \<turnstile> \<langle>e,s\<rangle> \<rightarrow>* \<langle>e',s'\<rangle>  \<Longrightarrow> hp s \<unlhd> hp s'"

proof(induct rule:converse_rtrancl_induct2)
  case refl thus ?case by(rule hext_refl)
next
  case (step e s e'' s'')
  have Red:"((e, s), e'', s'') \<in> Red P E"
    and hext:"hp s'' \<unlhd> hp s'" by fact+
  from Red have "P,E \<turnstile> \<langle>e,s\<rangle> \<rightarrow> \<langle>e'',s''\<rangle>" by simp
  hence "hp s \<unlhd> hp s''"
    by(cases s,cases s'')(auto dest:red_hext_incr)
  with hext show ?case by-(rule hext_trans)
qed

lemma steps_hext_incr: "P,E \<turnstile> \<langle>es,s\<rangle> [\<rightarrow>]* \<langle>es',s'\<rangle>  \<Longrightarrow> hp s \<unlhd> hp s'"

proof(induct rule:converse_rtrancl_induct2)
  case refl thus ?case by(rule hext_refl)
next
  case (step es s es'' s'')
  have Reds:"((es, s), es'', s'') \<in> Reds P E"
    and hext:"hp s'' \<unlhd> hp s'" by fact+
  from Reds have "P,E \<turnstile> \<langle>es,s\<rangle> [\<rightarrow>] \<langle>es'',s''\<rangle>" by simp
  hence "hp s \<unlhd> hp s''"
    by(cases s,cases s'',auto dest:reds_hext_incr)
  with hext show ?case by-(rule hext_trans)
qed

lemma eval_hext: "P,E \<turnstile> \<langle>e,(h,l)\<rangle> \<Rightarrow> \<langle>e',(h',l')\<rangle> \<Longrightarrow> h \<unlhd> h'"
and evals_hext:  "P,E \<turnstile> \<langle>es,(h,l)\<rangle> [\<Rightarrow>] \<langle>es',(h',l')\<rangle> \<Longrightarrow> h \<unlhd> h'"

proof (induct rule:eval_evals_inducts)
  case New thus ?case
    by(fastforce intro!: hext_new intro:someI simp:new_Addr_def
                split:if_split_asm simp del:fun_upd_apply)
next
  case FAss thus ?case
    by(auto simp:sym[THEN hext_upd_obj] simp del:fun_upd_apply
            elim!: hext_trans)
qed (auto elim!: hext_trans)

subsection \<open>\<open>\<unlhd>\<close> and conformance\<close>

lemma conf_hext: "h \<unlhd> h' \<Longrightarrow> P,h \<turnstile> v :\<le> T \<Longrightarrow> P,h' \<turnstile> v :\<le> T"
by(cases T)(induct v,auto dest: hext_objD split:if_split_asm)+

lemma confs_hext: "P,h \<turnstile> vs [:\<le>] Ts \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> vs [:\<le>] Ts"
by (erule list_all2_mono, erule conf_hext, assumption)

lemma fconf_hext: "\<lbrakk> P,h \<turnstile> fs (:\<le>) E; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> fs (:\<le>) E"

apply (unfold fconf_def)
apply  (fast elim: conf_hext)
done

lemmas fconf_upd_obj = fconf_hext [OF _ hext_upd_obj]
lemmas fconf_new = fconf_hext [OF _ hext_new]

lemma oconf_hext: "P,h \<turnstile> obj \<surd> \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> obj \<surd>"

apply (auto simp:oconf_def)
apply (erule allE)
apply (erule_tac x="Cs" in allE)
apply (erule_tac x="fs'" in allE)
apply (fastforce elim:fconf_hext)
done

lemmas oconf_new = oconf_hext [OF _ hext_new]
lemmas oconf_upd_obj = oconf_hext [OF _ hext_upd_obj]

lemma hconf_new: "\<lbrakk> P \<turnstile> h \<surd>; h a = None; P,h \<turnstile> obj \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile> h(a\<mapsto>obj) \<surd>"
by (unfold hconf_def) (auto intro: oconf_new preallocated_new)

lemma "\<lbrakk>P \<turnstile> h \<surd>; h' = h(a \<mapsto> (C, Collect (init_obj P C))); h a = None; wf_prog wf_md P\<rbrakk>
  \<Longrightarrow> P \<turnstile> h' \<surd>"
apply (simp add:hconf_def oconf_def)
apply auto
     apply (rule_tac x="init_class_fieldmap P (last Cs)" in exI)
     apply (rule init_obj.intros)
     apply assumption
    apply (erule init_obj.cases)
    apply clarsimp
    apply (erule init_obj.cases)
    apply clarsimp
   apply (erule_tac x="a" in allE)
   apply clarsimp
   apply (erule init_obj.cases)
   apply simp
  apply (erule_tac x="a" in allE)
  apply clarsimp
  apply (erule init_obj.cases)
  apply clarsimp
  apply (drule Subobj_last_isClass)
   apply simp
  apply (auto simp:is_class_def)
  apply (rule fconf_init_fields)
  apply auto
 apply (erule_tac x="aa" in allE)
 apply (erule_tac x="aaa" in allE)
 apply (erule_tac x="b" in allE)
 apply clarsimp
 apply (rotate_tac -1)
 apply (erule_tac x="Cs" in allE)
 apply (erule_tac x="fs'" in allE)
 apply clarsimp thm fconf_new
 apply (erule fconf_new)
 apply simp
apply (rule preallocated_new)
apply simp_all
done

lemma hconf_upd_obj:
"\<lbrakk> P \<turnstile> h\<surd>; h a = Some(C,S); P,h \<turnstile> (C,S')\<surd> \<rbrakk> \<Longrightarrow> P \<turnstile> h(a\<mapsto>(C,S'))\<surd>"
by (unfold hconf_def) (auto intro: oconf_upd_obj preallocated_upd_obj)

lemma lconf_hext: "\<lbrakk> P,h \<turnstile> l (:\<le>)\<^sub>w E; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> l (:\<le>)\<^sub>w E"

apply (unfold lconf_def)
apply  (fast elim: conf_hext)
done

subsection \<open>\<open>\<unlhd>\<close> in the runtime type system\<close>

lemma hext_typeof_mono: "\<lbrakk> h \<unlhd> h'; P \<turnstile> typeof\<^bsub>h\<^esub> v = Some T \<rbrakk> \<Longrightarrow> P \<turnstile> typeof\<^bsub>h'\<^esub> v = Some T"

apply(cases v)
    apply simp
   apply simp
  apply simp
 apply simp
apply(fastforce simp:hext_def)
done

lemma WTrt_hext_mono: "P,E,h \<turnstile> e : T \<Longrightarrow> (\<And>h'. h \<unlhd> h' \<Longrightarrow> P,E,h' \<turnstile> e : T)"
and WTrts_hext_mono: "P,E,h \<turnstile> es [:] Ts \<Longrightarrow> (\<And>h'. h \<unlhd> h' \<Longrightarrow> P,E,h' \<turnstile> es [:] Ts)"

apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce intro: WTrtDynCast)
apply(fastforce intro: WTrtStaticCast)
apply(fastforce simp: WTrtVal dest:hext_typeof_mono)
apply(simp add: WTrtVar)
apply(fastforce simp add: WTrtBinOp)
apply(fastforce simp add: WTrtLAss)
apply(fastforce simp: WTrtFAcc del:WTrt_WTrts.intros WTrt_elim_cases)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtFAssNT del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtCall del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtStaticCall del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce simp: WTrtCallNT del:WTrt_WTrts.intros WTrt_elim_cases)
apply(fastforce)
apply(fastforce simp add: WTrtSeq)
apply(fastforce simp add: WTrtCond)
apply(fastforce simp add: WTrtWhile)
apply(fastforce simp add: WTrtThrow)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
done

end


theory "Network_Equivalences-Diamond-Foundations"
  imports "Network_Equivalences-Communication"
begin

abbreviation diamond_sending where
  "diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<equiv>
    \<comment> \<open>Node 0:\<close> s\<^sub>0 \<Rightarrow> [l\<^sub>0\<^sub>1, l\<^sub>0\<^sub>2] \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>1\<^sub>3] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>2\<^sub>3] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"

abbreviation diamond_receiving where
  "diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<equiv>
    \<comment> \<open>Link 0--1:\<close> l\<^sub>0\<^sub>1 \<rightarrow> r\<^sub>1 \<parallel>
    \<comment> \<open>Link 0--2:\<close> l\<^sub>0\<^sub>2 \<rightarrow> r\<^sub>2 \<parallel>
    \<comment> \<open>Link 1--3:\<close> l\<^sub>1\<^sub>3 \<rightarrow> r\<^sub>3 \<parallel>
    \<comment> \<open>Link 2--3:\<close> l\<^sub>2\<^sub>3 \<rightarrow> r\<^sub>3 \<parallel>
    \<comment> \<open>Link 3--0:\<close> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>0"

abbreviation initial_core where
  "initial_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<equiv>
    \<comment> \<open>From link 0--1:\<close> l\<^sub>0\<^sub>1 \<rightarrow> l\<^sub>1\<^sub>3 \<parallel>
    \<comment> \<open>From link 0--2:\<close> l\<^sub>0\<^sub>2 \<rightarrow> l\<^sub>2\<^sub>3 \<parallel>
    \<comment> \<open>From link 1--3:\<close> l\<^sub>1\<^sub>3 \<rightarrow> l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>From link 2--3:\<close> l\<^sub>2\<^sub>3 \<rightarrow> l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>From link 3--0:\<close> l\<^sub>3\<^sub>0 \<rightarrow> l\<^sub>0\<^sub>1 \<parallel> l\<^sub>3\<^sub>0 \<rightarrow> l\<^sub>0\<^sub>2"

abbreviation transformed_core where
  "transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<equiv>
    \<comment> \<open>Link 0--1:\<close> l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>1 \<parallel>
    \<comment> \<open>Link 0--2:\<close> l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>2 \<parallel>
    \<comment> \<open>Link 1--3:\<close> l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>1\<^sub>3 \<parallel>
    \<comment> \<open>Link 2--3:\<close> l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>2\<^sub>3"

abbreviation cross_sending where
  "cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 m \<equiv>
    \<comment> \<open>Node 0:\<close> s\<^sub>0 \<rightarrow> m \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<rightarrow> m \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<rightarrow> m \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<rightarrow> m"

abbreviation cross_receiving where
  "cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 m \<equiv>
    \<comment> \<open>Node 0:\<close> m \<rightarrow> r\<^sub>0 \<parallel>
    \<comment> \<open>Node 1:\<close> m \<rightarrow> r\<^sub>1 \<parallel>
    \<comment> \<open>Node 2:\<close> m \<rightarrow> r\<^sub>2 \<parallel>
    \<comment> \<open>Node 3:\<close> m \<rightarrow> r\<^sub>3"

lemma focussing:
  shows "a \<rightarrow> b \<parallel> b \<rightarrow> c \<parallel> c \<rightarrow> a \<approx>\<^sub>s a \<leftrightarrow> b \<parallel> a \<leftrightarrow> c" (is "?p \<approx>\<^sub>s ?q")
proof-
  have "?p \<approx>\<^sub>s
    (a \<rightarrow> b \<parallel> b \<rightarrow> c) \<parallel>
    (b \<rightarrow> c \<parallel> c \<rightarrow> a)"
    using thorn_simps by equivalence
  also have "\<dots> \<approx>\<^sub>s
    (a \<rightarrow> b \<parallel> b \<rightarrow> c \<parallel> a \<rightarrow> c) \<parallel>
    (b \<rightarrow> c \<parallel> c \<rightarrow> a \<parallel> b \<rightarrow> a)"
    using unidirectional_bridge_shortcut_redundancy by equivalence
  also have "\<dots> \<approx>\<^sub>s
    a \<rightarrow> b \<parallel> c \<rightarrow> a \<parallel>
    (b \<rightarrow> a \<parallel> a \<rightarrow> c \<parallel> b \<rightarrow> c)"
    using thorn_simps by equivalence
  also have "\<dots> \<approx>\<^sub>s
    a \<rightarrow> b \<parallel> c \<rightarrow> a \<parallel>
    (b \<rightarrow> a \<parallel> a \<rightarrow> c)"
    using unidirectional_bridge_shortcut_redundancy by equivalence
  also have "\<dots> \<approx>\<^sub>s ?q"
    unfolding bidirectional_bridge_def using thorn_simps by equivalence
  finally show ?thesis .
qed

lemma core_transformation:
  shows "initial_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<approx>\<^sub>s transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0"
proof -
  have "initial_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<approx>\<^sub>s
    \<comment> \<open>Left triangle:\<close> (l\<^sub>3\<^sub>0 \<rightarrow> l\<^sub>0\<^sub>1 \<parallel> l\<^sub>0\<^sub>1 \<rightarrow> l\<^sub>1\<^sub>3 \<parallel> l\<^sub>1\<^sub>3 \<rightarrow> l\<^sub>3\<^sub>0) \<parallel>
    \<comment> \<open>Right triangle:\<close> (l\<^sub>3\<^sub>0 \<rightarrow> l\<^sub>0\<^sub>2 \<parallel> l\<^sub>0\<^sub>2 \<rightarrow> l\<^sub>2\<^sub>3 \<parallel> l\<^sub>2\<^sub>3 \<rightarrow> l\<^sub>3\<^sub>0)"
    using thorn_simps by equivalence
  also have "\<dots> \<approx>\<^sub>s
    \<comment> \<open>Left triangle:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>1 \<parallel> l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>1\<^sub>3) \<parallel>
    \<comment> \<open>Right triangle:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>2 \<parallel> l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>2\<^sub>3)"
    using focussing by equivalence
  also have "\<dots> \<approx>\<^sub>s transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0"
    unfolding bidirectional_bridge_def using thorn_simps by equivalence
  finally show ?thesis .
qed

lemma sending_collapse:
  shows "
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    diamond_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0
    \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    cross_sending s\<^sub>0 s\<^sub>1 s\<^sub>2 s\<^sub>3 l\<^sub>3\<^sub>0"
    (is "?p \<approx>\<^sub>s ?q")
proof -
  have "?p \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> (\<Prod>x\<leftarrow>[(l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>1), (l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>2)]. fst x \<leftrightarrow> snd x \<parallel> s\<^sub>0 \<Rightarrow> map snd [(l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>1), (l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>2)]) \<parallel>
    \<comment> \<open>Node 1:\<close> (\<Prod>x\<leftarrow>[(l\<^sub>3\<^sub>0, l\<^sub>1\<^sub>3)]. fst x \<leftrightarrow> snd x \<parallel> s\<^sub>1 \<Rightarrow> map snd [(l\<^sub>3\<^sub>0, l\<^sub>1\<^sub>3)]) \<parallel>
    \<comment> \<open>Node 2:\<close> (\<Prod>x\<leftarrow>[(l\<^sub>3\<^sub>0, l\<^sub>2\<^sub>3)]. fst x \<leftrightarrow> snd x \<parallel> s\<^sub>2 \<Rightarrow> map snd [(l\<^sub>3\<^sub>0, l\<^sub>2\<^sub>3)]) \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    unfolding general_parallel.simps
    using thorn_simps
    by (equivalence simplification: fst_conv snd_conv list.map)
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> (\<Prod>x\<leftarrow>[(l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>1), (l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>2)]. fst x \<leftrightarrow> snd x \<parallel> s\<^sub>0 \<Rightarrow> map fst [(l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>1), (l\<^sub>3\<^sub>0, l\<^sub>0\<^sub>2)]) \<parallel>
    \<comment> \<open>Node 1:\<close> (\<Prod>x\<leftarrow>[(l\<^sub>3\<^sub>0, l\<^sub>1\<^sub>3)]. fst x \<leftrightarrow> snd x \<parallel> s\<^sub>1 \<Rightarrow> map fst [(l\<^sub>3\<^sub>0, l\<^sub>1\<^sub>3)]) \<parallel>
    \<comment> \<open>Node 2:\<close> (\<Prod>x\<leftarrow>[(l\<^sub>3\<^sub>0, l\<^sub>2\<^sub>3)]. fst x \<leftrightarrow> snd x \<parallel> s\<^sub>2 \<Rightarrow> map fst [(l\<^sub>3\<^sub>0, l\<^sub>2\<^sub>3)]) \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    by (intro
      distributor_target_switch [THEN synchronous.weak.bisimilarity_symmetry_rule]
      synchronous.weak.bisimilarity_reflexivity_rule
      synchronous.weak.parallel_is_compatible_with_bisimilarity
    )
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> s\<^sub>0 \<Rightarrow> [l\<^sub>3\<^sub>0, l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    unfolding general_parallel.simps
    using thorn_simps
    by (equivalence simplification: fst_conv snd_conv list.map)
  also have "\<dots> \<approx>\<^sub>s
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> (\<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> s\<^sub>0 \<triangleright>\<^sup>\<infinity> x. (l\<^sub>3\<^sub>0 \<triangleleft> \<box> x \<parallel> l\<^sub>3\<^sub>0 \<triangleleft> \<box> x)) \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    unfolding distributor_def and general_parallel.simps using thorn_simps sorry
    (* FIXME:
      This should by solvable by \<^theory_text>\<open>equivalence\<close> again once it is configured to reason under
      \<^theory_text>\<open>repeated_receive\<close>.
    *)
  also have "\<dots> \<approx>\<^sub>s
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> (\<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> s\<^sub>0 \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> l\<^sub>3\<^sub>0 \<triangleleft> \<box> x \<parallel> l\<^sub>3\<^sub>0 \<triangleleft> \<box> x)) \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    using inner_duploss_redundancy by equivalence
  also have "\<dots> \<approx>\<^sub>s
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> (\<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> s\<^sub>0 \<triangleright>\<^sup>\<infinity> x. (\<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> l\<^sub>3\<^sub>0 \<triangleleft> \<box> x)) \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    using send_idempotency_under_duploss sorry
    (* FIXME:
      This should by solvable by \<^theory_text>\<open>equivalence\<close> again once it is configured to reason under
      \<^theory_text>\<open>repeated_receive\<close>.
    *)
  also have "\<dots> \<approx>\<^sub>s
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> (\<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> s\<^sub>0 \<triangleright>\<^sup>\<infinity> x. l\<^sub>3\<^sub>0 \<triangleleft> \<box> x) \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    using inner_duploss_redundancy by equivalence
  also have "\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Node 0:\<close> s\<^sub>0 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 1:\<close> s\<^sub>1 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 2:\<close> s\<^sub>2 \<Rightarrow> [l\<^sub>3\<^sub>0] \<parallel>
    \<comment> \<open>Node 3:\<close> s\<^sub>3 \<Rightarrow> [l\<^sub>3\<^sub>0]"
    unfolding distributor_def and general_parallel.simps using thorn_simps sorry
    (* FIXME:
      This should by solvable by \<^theory_text>\<open>equivalence\<close> again once it is configured to reason under
      \<^theory_text>\<open>repeated_receive\<close>.
    *)
  also have "\<dots> \<approx>\<^sub>s ?q"
    unfolding unidirectional_bridge_def by equivalence
  finally show ?thesis .
qed

lemma receiving_collapse:
  shows "
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    diamond_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0
    \<approx>\<^sub>s
    transformed_core l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3 l\<^sub>3\<^sub>0 \<parallel>
    cross_receiving r\<^sub>0 r\<^sub>1 r\<^sub>2 r\<^sub>3 l\<^sub>3\<^sub>0"
    (is "?p \<approx>\<^sub>s ?q")
proof -
  have "?p \<approx>\<^sub>s
    \<comment> \<open>Link 0--1:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>1 \<parallel> l\<^sub>0\<^sub>1 \<rightarrow> r\<^sub>1) \<parallel>
    \<comment> \<open>Link 0--2:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>2 \<parallel> l\<^sub>0\<^sub>2 \<rightarrow> r\<^sub>2) \<parallel>
    \<comment> \<open>Link 1--3:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>1\<^sub>3 \<parallel> l\<^sub>1\<^sub>3 \<rightarrow> r\<^sub>3) \<parallel>
    \<comment> \<open>Link 2--3:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>2\<^sub>3 \<parallel> l\<^sub>2\<^sub>3 \<rightarrow> r\<^sub>3) \<parallel>
    \<comment> \<open>Link 3--0:\<close> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>0"
    using thorn_simps by equivalence
  also have "\<dots> \<approx>\<^sub>s
    \<comment> \<open>Link 0--1:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>1 \<parallel> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>1) \<parallel>
    \<comment> \<open>Link 0--2:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>0\<^sub>2 \<parallel> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>2) \<parallel>
    \<comment> \<open>Link 1--3:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>1\<^sub>3 \<parallel> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>3) \<parallel>
    \<comment> \<open>Link 2--3:\<close> (l\<^sub>3\<^sub>0 \<leftrightarrow> l\<^sub>2\<^sub>3 \<parallel> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>3) \<parallel>
    \<comment> \<open>Link 3--0:\<close> l\<^sub>3\<^sub>0 \<rightarrow> r\<^sub>0"
    using unidirectional_bridge_source_switch by equivalence
  also have "\<dots> \<approx>\<^sub>s ?q"
    using thorn_simps by equivalence
  finally show ?thesis .
qed

lemma core_collapse:
  shows "
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    \<nu> l\<^sub>0\<^sub>1 l\<^sub>0\<^sub>2 l\<^sub>1\<^sub>3 l\<^sub>2\<^sub>3. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel>
      transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) l\<^sub>3\<^sub>0
    )
    \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0"
proof -
  have "
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. (
      \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> \<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel>
      transformed_core (\<box> l\<^sub>0\<^sub>1) (\<box> l\<^sub>0\<^sub>2) (\<box> l\<^sub>1\<^sub>3) (\<box> l\<^sub>2\<^sub>3) l\<^sub>3\<^sub>0
    )
    \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel>
    \<comment> \<open>Link 0--1:\<close> \<langle>0\<rangle> \<nu> l\<^sub>0\<^sub>1. (\<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>1) \<parallel> l\<^sub>3\<^sub>0 \<leftrightarrow> \<box> l\<^sub>0\<^sub>1) \<parallel>
    \<comment> \<open>Link 0--2:\<close> \<langle>1\<rangle> \<nu> l\<^sub>0\<^sub>2. (\<currency>\<^sup>* (\<box> l\<^sub>0\<^sub>2) \<parallel> l\<^sub>3\<^sub>0 \<leftrightarrow> \<box> l\<^sub>0\<^sub>2) \<parallel>
    \<comment> \<open>Link 1--3:\<close> \<langle>2\<rangle> \<nu> l\<^sub>1\<^sub>3. (\<currency>\<^sup>* (\<box> l\<^sub>1\<^sub>3) \<parallel> l\<^sub>3\<^sub>0 \<leftrightarrow> \<box> l\<^sub>1\<^sub>3) \<parallel>
    \<comment> \<open>Link 2--3:\<close> \<langle>3\<rangle> \<nu> l\<^sub>2\<^sub>3. (\<currency>\<^sup>* (\<box> l\<^sub>2\<^sub>3) \<parallel> l\<^sub>3\<^sub>0 \<leftrightarrow> \<box> l\<^sub>2\<^sub>3)"
    using thorn_simps sorry
    (* FIXME:
      This goal started to cause problems with the switch to the Þ-calculus. We hope that the
      \<^theory_text>\<open>iprover\<close>-based equivalence reasoner will be able to solve it.
    *)
  also have"\<dots> \<approx>\<^sub>s
    \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> \<currency>\<^sup>*l\<^sub>3\<^sub>0 \<parallel> \<currency>\<^sup>*l\<^sub>3\<^sub>0"
    unfolding tagged_new_channel_def using duploss_detour_collapse by equivalence
  also have "\<dots> \<approx>\<^sub>s \<currency>\<^sup>*l\<^sub>3\<^sub>0"
    using thorn_simps by equivalence
  finally show ?thesis unfolding tagged_new_channel_def .
qed

end


theory "Kerberos_V4_cert_auto"
imports
  "ESPLogic"
begin

(* section:  The Kerberos Protocol, Version 4  *)

(* text:
  Modeled after the description given by Bella [1] based on the original
  technical report [2].

  Notable differences:

    1. We do not model the timestamps and the timing properties because our
       model does not support reasoning about them yet. We model them as
       freshly generated nonces that are leaked immediately after generation.

    2. We do not model session key leakage, as our support for key compromise
       properties is not ready yet.

    3. We provide more general authentication and secrecy properties, as we do
       not assume a priory the uncompromisedness of the ticket granting server.
       Furthermore, the authentication propertis are more fine-grained due to
       our more precise execution model.

    4. We use explicit global constants instead of implicit typing to identify
       the different encryptions.

    5. We use the abbreviations: C for Client, A for authenticator, G for
       ticket granting server, S for server.

[1] Bella, Giampaolo and Paulson, Lawrence C., "Kerberos Version 4: Inductive
    Analysis of the Secrecy Goals", in ESORICS, 1998, pp. 361-375.

[2] Miller, S. P. and Neuman, B. C. and Schiller, J. I. and Saltzer, J. H.,
    "Kerberos Authentication and Authorization System", in Project Athena Technical
    Plan, 1987, pp. 1-36.
 *)

role A
where "A =
  [ Recv ''1'' <| sMV ''C'', sMV ''G'', sMV ''Tc1'' |>
  , Send ''2_leak'' ( sN ''Ta'' )
  , Send ''2'' <| sAV ''A'',
                  PEnc <| sC ''21'', sN ''AuthKey'', sMV ''G'', sN ''Ta'',
                          PEnc <| sC ''22'', sMV ''C'', sMV ''G'', sN ''AuthKey'', sN ''Ta'' |>
                               ( PSymK ( sAV ''A'' ) ( sMV ''G'' ) )
                       |>
                       ( PSymK ( sMV ''C'' ) ( sAV ''A'' ) )
               |>
  ]"

role C
where "C =
  [ Send ''1_leak'' ( sN ''Tc1'' )
  , Send ''1'' <| sAV ''C'', sAV ''G'', sN ''Tc1'' |>
  , Recv ''2'' <| sMV ''A'',
                  PEnc <| sC ''21'', sMV ''AuthKey'', sAV ''G'', sMV ''Ta'',
                          sMV ''AuthTicket''
                       |>
                       ( PSymK ( sAV ''C'' ) ( sMV ''A'' ) )
               |>
  , Send ''3_leak'' ( sN ''Tc2'' )
  , Send ''3'' <| sMV ''A'', sMV ''AuthTicket'',
                  PEnc <| sC ''3'', sAV ''C'', sN ''Tc2'' |> ( sMV ''AuthKey'' ), sAV ''S''
               |>
  , Recv ''4'' ( PEnc <| sC ''41'', sMV ''ServKey'', sAV ''S'', sMV ''Tg'',
                         sMV ''ServTicket''
                      |>
                      ( sMV ''AuthKey'' )
               )
  , Send ''5_leak'' ( sN ''Tc3'' )
  , Send ''5'' <| sAV ''G'', sMV ''ServTicket'',
                  PEnc <| sC ''5'', sAV ''C'', sN ''Tc3'' |> ( sMV ''ServKey'' )
               |>
  , Recv ''6'' ( PEnc <| sC ''6'', sN ''Tc3'' |> ( sMV ''ServKey'' ) )
  ]"

role G
where "G =
  [ Recv ''3'' <| sMV ''A'',
                  PEnc <| sC ''22'', sMV ''C'', sAV ''G'', sMV ''AuthKey'', sMV ''Ta'' |>
                       ( PSymK ( sMV ''A'' ) ( sAV ''G'' ) ),
                  PEnc <| sC ''3'', sMV ''C'', sMV ''Tc2'' |> ( sMV ''AuthKey'' ),
                  sMV ''S''
               |>
  , Send ''4_leak'' ( sN ''Tg'' )
  , Send ''4'' ( PEnc <| sC ''41'', sN ''ServKey'', sMV ''S'', sN ''Tg'',
                         PEnc <| sC ''42'', sMV ''C'', sMV ''S'', sN ''ServKey'', sN ''Tg'' |>
                              ( PSymK ( sAV ''G'' ) ( sMV ''S'' ) )
                      |>
                      ( sMV ''AuthKey'' )
               )
  ]"

role S
where "S =
  [ Recv ''5'' <| sMV ''G'',
                  PEnc <| sC ''42'', sMV ''C'', sAV ''S'', sMV ''ServKey'', sMV ''Tg'' |>
                       ( PSymK ( sMV ''G'' ) ( sAV ''S'' ) ),
                  PEnc <| sC ''5'', sMV ''C'', sMV ''Tc3'' |> ( sMV ''ServKey'' )
               |>
  , Send ''6'' ( PEnc <| sC ''6'', sMV ''Tc3'' |> ( sMV ''ServKey'' ) )
  ]"

protocol Kerberos
where "Kerberos = { A, C, G, S }"

locale restricted_Kerberos_state = Kerberos_state

type_invariant Kerberos_typing for Kerberos
where "Kerberos_typing = mk_typing
  [ ((C, ''A''), (KnownT C_2))
  , ((G, ''A''), (KnownT G_3))
  , ((C, ''AuthKey''), (SumT (KnownT C_2) (NonceT A ''AuthKey'')))
  , ((G, ''AuthKey''), (SumT (KnownT G_3) (NonceT A ''AuthKey'')))
  , ((C, ''AuthTicket''),
     (SumT (KnownT C_2) (EncT (TupT (ConstT ''22'') (TupT (KnownT C_2) (TupT AgentT (TupT (NonceT A ''AuthKey'') (NonceT A ''Ta''))))) (KT AgentT AgentT))))
  , ((A, ''C''), (KnownT A_1))
  , ((G, ''C''), (SumT (KnownT G_3) AgentT))
  , ((S, ''C''), (SumT (KnownT S_5) AgentT))
  , ((A, ''G''), (KnownT A_1))
  , ((S, ''G''), (KnownT S_5))
  , ((G, ''S''), (KnownT G_3))
  , ((C, ''ServKey''), (SumT (KnownT C_4) (NonceT G ''ServKey'')))
  , ((S, ''ServKey''), (SumT (KnownT S_5) (NonceT G ''ServKey'')))
  , ((C, ''ServTicket''),
     (SumT (KnownT C_4) (EncT (TupT (ConstT ''42'') (TupT (KnownT C_4) (TupT AgentT (TupT (NonceT G ''ServKey'') (NonceT G ''Tg''))))) (KT AgentT AgentT))))
  , ((C, ''Ta''), (SumT (KnownT C_2) (NonceT A ''Ta'')))
  , ((G, ''Ta''), (SumT (KnownT G_3) (NonceT A ''Ta'')))
  , ((A, ''Tc1''), (KnownT A_1))
  , ((G, ''Tc2''), (SumT (KnownT G_3) (NonceT C ''Tc2'')))
  , ((S, ''Tc3''), (SumT (KnownT S_5) (NonceT C ''Tc3'')))
  , ((C, ''Tg''), (SumT (KnownT C_4) (NonceT G ''Tg'')))
  , ((S, ''Tg''), (SumT (KnownT S_5) (NonceT G ''Tg'')))
  ]"

sublocale Kerberos_state < Kerberos_typing_state
proof -
  have "(t,r,s) : approx Kerberos_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF Kerberos_typing.monoTyp, completeness_cases_rule])
    case (A_1_C t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_1_C
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_1_G t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_1_G
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_1_Tc1 t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_1_Tc1
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (C_2_A t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_2_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (C_2_AuthKey t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_2_AuthKey
    thus ?case
    proof(sources! "
        Enc {| LC ''21'', s(MV ''AuthKey'' tid0), s(AV ''G'' tid0),
               s(MV ''Ta'' tid0), s(MV ''AuthTicket'' tid0)
            |}
            ( K ( s(AV ''C'' tid0) ) ( s(MV ''A'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (C_2_AuthTicket t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_2_AuthTicket
    thus ?case
    proof(sources! "
        Enc {| LC ''21'', s(MV ''AuthKey'' tid0), s(AV ''G'' tid0),
               s(MV ''Ta'' tid0), s(MV ''AuthTicket'' tid0)
            |}
            ( K ( s(AV ''C'' tid0) ) ( s(MV ''A'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (C_2_Ta t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_2_Ta
    thus ?case
    proof(sources! "
        Enc {| LC ''21'', s(MV ''AuthKey'' tid0), s(AV ''G'' tid0),
               s(MV ''Ta'' tid0), s(MV ''AuthTicket'' tid0)
            |}
            ( K ( s(AV ''C'' tid0) ) ( s(MV ''A'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (C_4_ServKey t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_4_ServKey
    thus ?case
    proof(sources! "
        Enc {| LC ''41'', s(MV ''ServKey'' tid0), s(AV ''S'' tid0),
               s(MV ''Tg'' tid0), s(MV ''ServTicket'' tid0)
            |}
            ( s(MV ''AuthKey'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (C_4_ServTicket t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_4_ServTicket
    thus ?case
    proof(sources! "
        Enc {| LC ''41'', s(MV ''ServKey'' tid0), s(AV ''S'' tid0),
               s(MV ''Tg'' tid0), s(MV ''ServTicket'' tid0)
            |}
            ( s(MV ''AuthKey'' tid0) ) ")
      case (G_4_enc tid1) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''3'', s(MV ''C'' tid1), s(MV ''Tc2'' tid1) |}
                           ( s(MV ''AuthKey'' tid0) ) ")
      qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (C_4_Tg t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = C_4_Tg
    thus ?case
    proof(sources! "
        Enc {| LC ''41'', s(MV ''ServKey'' tid0), s(AV ''S'' tid0),
               s(MV ''Tg'' tid0), s(MV ''ServTicket'' tid0)
            |}
            ( s(MV ''AuthKey'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (G_3_A t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = G_3_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (G_3_AuthKey t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = G_3_AuthKey
    thus ?case
    proof(sources! "
        Enc {| LC ''22'', s(MV ''C'' tid0), s(AV ''G'' tid0),
               s(MV ''AuthKey'' tid0), s(MV ''Ta'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''G'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (G_3_C t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = G_3_C
    thus ?case
    proof(sources! "
        Enc {| LC ''3'', s(MV ''C'' tid0), s(MV ''Tc2'' tid0) |}
            ( s(MV ''AuthKey'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (G_3_S t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = G_3_S
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (G_3_Ta t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = G_3_Ta
    thus ?case
    proof(sources! "
        Enc {| LC ''22'', s(MV ''C'' tid0), s(AV ''G'' tid0),
               s(MV ''AuthKey'' tid0), s(MV ''Ta'' tid0)
            |}
            ( K ( s(MV ''A'' tid0) ) ( s(AV ''G'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (G_3_Tc2 t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = G_3_Tc2
    thus ?case
    proof(sources! "
        Enc {| LC ''3'', s(MV ''C'' tid0), s(MV ''Tc2'' tid0) |}
            ( s(MV ''AuthKey'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_5_C t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_5_C
    thus ?case
    proof(sources! "
        Enc {| LC ''5'', s(MV ''C'' tid0), s(MV ''Tc3'' tid0) |}
            ( s(MV ''ServKey'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_5_G t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_5_G
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_5_ServKey t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_5_ServKey
    thus ?case
    proof(sources! "
        Enc {| LC ''42'', s(MV ''C'' tid0), s(AV ''S'' tid0),
               s(MV ''ServKey'' tid0), s(MV ''Tg'' tid0)
            |}
            ( K ( s(MV ''G'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_5_Tc3 t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_5_Tc3
    thus ?case
    proof(sources! "
        Enc {| LC ''5'', s(MV ''C'' tid0), s(MV ''Tc3'' tid0) |}
            ( s(MV ''ServKey'' tid0) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (S_5_Tg t r s tid0)
    then interpret state: Kerberos_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_5_Tg
    thus ?case
    proof(sources! "
        Enc {| LC ''42'', s(MV ''C'' tid0), s(AV ''S'' tid0),
               s(MV ''ServKey'' tid0), s(MV ''Tg'' tid0)
            |}
            ( K ( s(MV ''G'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  qed
  thus "Kerberos_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context Kerberos_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Secrecy Properties  *)

lemma (in restricted_Kerberos_state) A_AuthKey_secret:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "RLKR(s(MV ''G'' tid0)) ~: reveals t"
    "LN ''AuthKey'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''AuthKey'' tid0 ")
  case A_2_AuthKey note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case A_2_AuthKey_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case (C_3_AuthTicket_AuthKey tid1 a0 a1 tid3 a2 a3) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''21'', s(MV ''AuthKey'' tid1), s(AV ''G'' tid1),
                          s(MV ''Ta'' tid1),
                          Enc {| LC ''22'', a0, a1, LN ''AuthKey'' tid0, LN ''Ta'' tid3 |}
                              ( K ( a2 ) ( a3 ) )
                       |}
                       ( K ( s(AV ''C'' tid1) ) ( s(MV ''A'' tid1) ) ) ")
    case (A_2_enc tid4) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_Kerberos_state) C_AuthKey_secret:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''C'' tid0)) ~: reveals t"
    "RLKR(s(AV ''G'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, C_2 ) : steps t"
    "s(MV ''AuthKey'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''21'', s(MV ''AuthKey'' tid0), s(AV ''G'' tid0),
                          s(MV ''Ta'' tid0), s(MV ''AuthTicket'' tid0)
                       |}
                       ( K ( s(AV ''C'' tid0) ) ( s(MV ''A'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_2_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Kerberos_state) G_AuthKey_secret:
  assumes facts:
    "roleMap r tid0 = Some G"
    "RLKR(s(AV ''G'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "( tid0, G_3 ) : steps t"
    "s(MV ''AuthKey'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''22'', s(MV ''C'' tid0), s(AV ''G'' tid0),
                          s(MV ''AuthKey'' tid0), s(MV ''Ta'' tid0)
                       |}
                       ( K ( s(MV ''A'' tid0) ) ( s(AV ''G'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_2_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (C_3_AuthTicket_enc tid1 a0 a1 tid2 tid3 a2 a3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''21'', s(MV ''AuthKey'' tid1), s(AV ''G'' tid1),
                            s(MV ''Ta'' tid1),
                            Enc {| LC ''22'', a0, s(AV ''G'' tid0), LN ''AuthKey'' tid2,
                                   LN ''Ta'' tid3
                                |}
                                ( K ( a2 ) ( s(AV ''G'' tid0) ) )
                         |}
                         ( K ( s(AV ''C'' tid1) ) ( s(MV ''A'' tid1) ) ) ")
      case (A_2_enc tid4) note_unified facts = this facts
      thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
    qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Kerberos_state) G_ServKey_sec:
  assumes facts:
    "roleMap r tid0 = Some G"
    "RLKR(s(AV ''G'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''C'' tid0)) ~: reveals t"
    "RLKR(s(MV ''S'' tid0)) ~: reveals t"
    "LN ''ServKey'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''ServKey'' tid0 ")
  case (C_5_ServTicket_ServKey tid1 a0 a1 tid3 a2 a3) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''41'', s(MV ''ServKey'' tid1), s(AV ''S'' tid1),
                          s(MV ''Tg'' tid1),
                          Enc {| LC ''42'', a0, a1, LN ''ServKey'' tid0, LN ''Tg'' tid3 |}
                              ( K ( a2 ) ( a3 ) )
                       |}
                       ( s(MV ''AuthKey'' tid1) ) ")
    case (G_4_enc tid4) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case G_4_ServKey note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''22'', s(MV ''C'' tid0), s(AV ''G'' tid0),
                          s(MV ''AuthKey'' tid0), s(MV ''Ta'' tid0)
                       |}
                       ( K ( s(MV ''A'' tid0) ) ( s(AV ''G'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_2_enc_1 tid1) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (C_3_AuthTicket_enc tid1 a0 a1 tid2 tid3 a2 a3) note_unified facts = this facts
    thus ?thesis by (fastforce dest: G_AuthKey_secret intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
next
  case G_4_ServKey_1 note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_Kerberos_state) C_ServKey_sec:
  assumes facts:
    "roleMap r tid0 = Some C"
    "RLKR(s(AV ''C'' tid0)) ~: reveals t"
    "RLKR(s(AV ''G'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "( tid0, C_4 ) : steps t"
    "s(MV ''ServKey'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''21'', s(MV ''AuthKey'' tid0), s(AV ''G'' tid0),
                          s(MV ''Ta'' tid0), s(MV ''AuthTicket'' tid0)
                       |}
                       ( K ( s(AV ''C'' tid0) ) ( s(MV ''A'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_2_enc tid1) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''41'', s(MV ''ServKey'' tid0), s(AV ''S'' tid0),
                            s(MV ''Tg'' tid0), s(MV ''ServTicket'' tid0)
                         |}
                         ( LN ''AuthKey'' tid1 ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
    next
      case (G_4_enc tid2) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''22'', s(MV ''C'' tid2), s(AV ''G'' tid2),
                              LN ''AuthKey'' tid1, s(MV ''Ta'' tid2)
                           |}
                           ( K ( s(MV ''A'' tid2) ) ( s(AV ''G'' tid2) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
      next
        case (A_2_enc_1 tid3) note_unified facts = this facts
        thus ?thesis by (auto dest!: ltk_secrecy)
      next
        case (C_3_AuthTicket_enc tid3 a0 a1 tid4 tid5 a2 a3) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''21'', s(MV ''AuthKey'' tid3), s(AV ''G'' tid3),
                                s(MV ''Ta'' tid3),
                                Enc {| LC ''22'', a0, s(AV ''G'' tid2), LN ''AuthKey'' tid1,
                                       LN ''Ta'' tid5
                                    |}
                                    ( K ( a2 ) ( s(AV ''G'' tid2) ) )
                             |}
                             ( K ( s(AV ''C'' tid3) ) ( s(MV ''A'' tid3) ) ) ")
          case (A_2_enc tid6) note_unified facts = this facts
          thus ?thesis by (fastforce dest: G_ServKey_sec intro: event_predOrdI)
        qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

(* subsection:  Authentication Properties  *)

lemma (in restricted_Kerberos_state) C_auth:
  assumes facts:
    "roleMap r tid1 = Some C"
    "RLKR(s(AV ''C'' tid1)) ~: reveals t"
    "RLKR(s(AV ''G'' tid1)) ~: reveals t"
    "RLKR(s(AV ''S'' tid1)) ~: reveals t"
    "RLKR(s(MV ''A'' tid1)) ~: reveals t"
    "( tid1, C_6 ) : steps t"
  shows
    "(?  tid2.
        (?  tid3.
           (?  tid4.
              roleMap r tid2 = Some A &
              roleMap r tid3 = Some G &
              roleMap r tid4 = Some S &
              s(MV ''A'' tid1) = s(AV ''A'' tid2) &
              s(AV ''C'' tid1) = s(MV ''C'' tid2) &
              s(AV ''G'' tid1) = s(MV ''G'' tid2) &
              s(MV ''Ta'' tid1) = LN ''Ta'' tid2 &
              s(MV ''AuthKey'' tid1) = LN ''AuthKey'' tid2 &
              s(MV ''A'' tid1) = s(MV ''A'' tid3) &
              s(AV ''C'' tid1) = s(MV ''C'' tid3) &
              s(AV ''G'' tid1) = s(AV ''G'' tid3) &
              s(AV ''S'' tid1) = s(MV ''S'' tid3) &
              s(MV ''Tg'' tid1) = LN ''Tg'' tid3 &
              s(MV ''AuthKey'' tid1) = s(MV ''AuthKey'' tid3) &
              s(MV ''ServKey'' tid1) = LN ''ServKey'' tid3 &
              s(AV ''C'' tid1) = s(MV ''C'' tid4) &
              s(AV ''G'' tid1) = s(MV ''G'' tid4) &
              s(AV ''S'' tid1) = s(AV ''S'' tid4) &
              LN ''Tc3'' tid1 = s(MV ''Tc3'' tid4) &
              s(MV ''ServKey'' tid1) = s(MV ''ServKey'' tid4))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''21'', s(MV ''AuthKey'' tid1), s(AV ''G'' tid1),
                          s(MV ''Ta'' tid1), s(MV ''AuthTicket'' tid1)
                       |}
                       ( K ( s(AV ''C'' tid1) ) ( s(MV ''A'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_2_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''6'', LN ''Tc3'' tid1 |} ( s(MV ''ServKey'' tid1) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: C_ServKey_sec intro: event_predOrdI)
    next
      case (S_6_enc tid3) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''41'', s(MV ''ServKey'' tid1), s(AV ''S'' tid1),
                              s(MV ''Tg'' tid1), s(MV ''ServTicket'' tid1)
                           |}
                           ( LN ''AuthKey'' tid2 ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
      next
        case (G_4_enc tid4) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''22'', s(MV ''C'' tid4), s(AV ''G'' tid4),
                                LN ''AuthKey'' tid2, s(MV ''Ta'' tid4)
                             |}
                             ( K ( s(MV ''A'' tid4) ) ( s(AV ''G'' tid4) ) ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
        next
          case (A_2_enc_1 tid5) note_unified facts = this facts
          thus ?thesis by (auto dest!: ltk_secrecy)
        next
          case (C_3_AuthTicket_enc tid5 a0 a1 tid6 tid7 a2 a3) note_unified facts = this facts
          thus ?thesis proof(sources! "
                           Enc {| LC ''42'', s(MV ''C'' tid3), s(AV ''S'' tid3),
                                  LN ''ServKey'' tid4, s(MV ''Tg'' tid3)
                               |}
                               ( K ( s(MV ''G'' tid3) ) ( s(AV ''S'' tid3) ) ) ")
            case fake note_unified facts = this facts
            thus ?thesis by (fastforce dest: C_ServKey_sec intro: event_predOrdI)
          next
            case (C_5_ServTicket_enc tid8 a3 a4 tid9 tid10 a5 a6) note_unified facts = this facts
            thus ?thesis proof(sources! "
                             Enc {| LC ''21'', s(MV ''AuthKey'' tid5), s(AV ''G'' tid5),
                                    s(MV ''Ta'' tid5),
                                    Enc {| LC ''22'', a0, s(AV ''G'' tid4), LN ''AuthKey'' tid2,
                                           LN ''Ta'' tid7
                                        |}
                                        ( K ( a2 ) ( s(AV ''G'' tid4) ) )
                                 |}
                                 ( K ( s(AV ''C'' tid5) ) ( s(MV ''A'' tid5) ) ) ")
              case (A_2_enc tid11) note_unified facts = this facts
              thus ?thesis proof(sources! "
                               Enc {| LC ''41'', s(MV ''ServKey'' tid8), s(AV ''S'' tid8),
                                      s(MV ''Tg'' tid8),
                                      Enc {| LC ''42'', a3, s(AV ''S'' tid3), LN ''ServKey'' tid4,
                                             LN ''Tg'' tid10
                                          |}
                                          ( K ( a5 ) ( s(AV ''S'' tid3) ) )
                                   |}
                                   ( s(MV ''AuthKey'' tid8) ) ")
                case (G_4_enc tid11) note_unified facts = this facts
                thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
              qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
            qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
          next
            case (G_4_enc_1 tid8) note_unified facts = this facts
            thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
          qed (safe?, simp_all?, insert facts, (fastforce+)?)
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Kerberos_state) G_auth:
  assumes facts:
    "roleMap r tid3 = Some G"
    "RLKR(s(AV ''G'' tid3)) ~: reveals t"
    "RLKR(s(MV ''A'' tid3)) ~: reveals t"
    "RLKR(s(MV ''C'' tid3)) ~: reveals t"
    "( tid3, G_3 ) : steps t"
  shows
    "(?  tid1.
        (?  tid2.
           roleMap r tid1 = Some C &
           roleMap r tid2 = Some A &
           s(MV ''A'' tid1) = s(MV ''A'' tid3) &
           s(AV ''C'' tid1) = s(MV ''C'' tid3) &
           s(AV ''G'' tid1) = s(AV ''G'' tid3) &
           LN ''Tc2'' tid1 = s(MV ''Tc2'' tid3) &
           s(MV ''AuthKey'' tid1) = s(MV ''AuthKey'' tid3) &
           s(MV ''A'' tid1) = s(AV ''A'' tid2) &
           s(AV ''C'' tid1) = s(MV ''C'' tid2) &
           s(AV ''G'' tid1) = s(MV ''G'' tid2) &
           s(MV ''AuthKey'' tid1) = LN ''AuthKey'' tid2))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''22'', s(MV ''C'' tid3), s(AV ''G'' tid3),
                          s(MV ''AuthKey'' tid3), s(MV ''Ta'' tid3)
                       |}
                       ( K ( s(MV ''A'' tid3) ) ( s(AV ''G'' tid3) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (A_2_enc_1 tid4) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (C_3_AuthTicket_enc tid4 a0 a1 tid5 tid6 a2 a3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''3'', a0, s(MV ''Tc2'' tid3) |} ( LN ''AuthKey'' tid5 ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: G_AuthKey_secret intro: event_predOrdI)
    next
      case (C_3_enc tid7) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''21'', s(MV ''AuthKey'' tid4), s(AV ''G'' tid4),
                              s(MV ''Ta'' tid4),
                              Enc {| LC ''22'', s(AV ''C'' tid7), s(AV ''G'' tid3),
                                     LN ''AuthKey'' tid5, LN ''Ta'' tid6
                                  |}
                                  ( K ( a2 ) ( s(AV ''G'' tid3) ) )
                           |}
                           ( K ( s(AV ''C'' tid4) ) ( s(MV ''A'' tid4) ) ) ")
        case (A_2_enc tid8) note_unified facts = this facts
        thus ?thesis proof(sources! "
                         Enc {| LC ''21'', LN ''AuthKey'' tid5, s(AV ''G'' tid7),
                                s(MV ''Ta'' tid7), s(MV ''AuthTicket'' tid7)
                             |}
                             ( K ( s(AV ''C'' tid4) ) ( s(MV ''A'' tid7) ) ) ")
          case fake note_unified facts = this facts
          thus ?thesis by (fastforce dest: A_AuthKey_secret intro: event_predOrdI)
        next
          case (A_2_enc tid8) note_unified facts = this facts
          thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
        qed (safe?, simp_all?, insert facts, (fastforce+)?)
      qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2005         |
            |                January 2006               |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory FNF_F_sf_def
imports CSP_F_Main
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*  The following simplification rules are deleted in this theory file *)
(*       P (if Q then x else y) = ((Q --> P x) & (~ Q --> P y))        *)

(* Isabelle 2017 *)
declare if_split  [split del]

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

         1. definition of full sequential-formed process
         2.
         3.

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

(*==========================================================*
 |                                                          |
 |                    Definition of fsfF                    |
 |                                                          |
 *==========================================================*)

(*
Isabelle 2005

consts
  fsfF_proc :: "('p,'a) proc set"

inductive "fsfF_proc"

intros
fsfF_proc_int:
  "[| sumset C ~= {} ; ALL c: sumset C. Rf c : fsfF_proc |]
   ==> (!! :C .. Rf) : fsfF_proc"

fsfF_proc_ext:
  "[| ALL a:A. Pf a : fsfF_proc ;
      Q = SKIP | Q = DIV | Q = STOP |]
   ==> ((? :A -> Pf) [+] Q) : fsfF_proc"
*)

inductive_set
  fsfF_proc :: "('p,'a) proc set"
where
fsfF_proc_int:
  "[| sumset C ~= {} ; ALL c: sumset C. Rf c : fsfF_proc |]
   ==> (!! :C .. Rf) : fsfF_proc" |

fsfF_proc_ext:
  "[| ALL a:A. Pf a : fsfF_proc ;
      Q = SKIP | Q = DIV | Q = STOP |]
   ==> ((? :A -> Pf) [+] Q) : fsfF_proc"

(*-------------------------------------------*
 |   sequential-formed SSKIP, SDIV, SSTOP    |
 *-------------------------------------------*)

definition
  SSKIP     :: "('p,'a) proc"
  where
  SSKIP_def : "SSKIP == (? y:{} -> DIV) [+] SKIP"

definition
  SDIV      :: "('p,'a) proc"
  where
  SDIV_def  : "SDIV  == (? y:{} -> DIV) [+] DIV"

definition
  SSTOP     :: "('p,'a) proc"
  where
  SSTOP_def : "SSTOP == (? y:{} -> DIV) [+] STOP"

(*** small lemmas ***)

(* in *)

lemma fsfF_SSKIP_in[simp]: "SSKIP : fsfF_proc"
apply (simp add: SSKIP_def)
apply (simp add: fsfF_proc.intros)
done

lemma fsfF_SDIV_in[simp]: "SDIV : fsfF_proc"
apply (simp add: SDIV_def)
apply (simp add: fsfF_proc.intros)
done

lemma fsfF_SSTOP_in[simp]: "SSTOP : fsfF_proc"
apply (simp add: SSTOP_def)
apply (simp add: fsfF_proc.intros)
done

(* eqF *)

lemma cspF_SSKIP_eqF: "SKIP =F SSKIP"
apply (simp add: SSKIP_def)
apply (rule cspF_rw_right)
apply (rule cspF_Ext_choice_rule)
apply (simp)
done

lemma cspF_SDIV_eqF: "DIV =F SDIV"
apply (simp add: SDIV_def)
apply (rule cspF_rw_right)
apply (rule cspF_Ext_choice_rule)
apply (simp)
done

lemma cspF_SSTOP_eqF: "STOP =F SSTOP"
apply (simp add: SSTOP_def)
apply (rule cspF_rw_right)
apply (rule cspF_Ext_choice_rule)
apply (simp)
done

(*----------------------------------------------------------*
 |                          iff                             |
 *----------------------------------------------------------*)

(* proc *)

lemma fsfF_proc_iff:
  "(SP : fsfF_proc) =
    ((EX C Rf.
  sumset C ~= {} & SP = !! :C .. Rf & (ALL c: sumset C. Rf c : fsfF_proc)) |
     (EX A Pf Q.
        SP = (? :A -> Pf) [+] Q & (ALL a:A. Pf a : fsfF_proc) &
        (Q = SKIP | Q = DIV | Q = STOP)))"

apply (rule iffI)

(* => *)
 apply (erule fsfF_proc.cases)
 apply (simp_all)

(* <= *)
 apply (elim conjE exE disjE)
 apply (simp_all add: fsfF_proc.intros)
done

lemma fsfF_procI:
   "((EX C Rf.
  sumset C ~= {} & SP = !! :C .. Rf & (ALL c: sumset C. Rf c : fsfF_proc)) |
     (EX A Pf Q.
        SP = (? :A -> Pf) [+] Q & (ALL a:A. Pf a : fsfF_proc) &
        (Q = SKIP | Q = DIV | Q = STOP)))
    ==> SP : fsfF_proc"
apply (simp add: fsfF_proc_iff[of SP])
done

lemma fsfF_procE:
  "[| SP : fsfF_proc ;
     ((EX C Rf.
  sumset C ~= {} & SP = !! :C .. Rf & (ALL c: sumset C. Rf c : fsfF_proc)) |
     (EX A Pf Q.
        SP = (? :A -> Pf) [+] Q & (ALL a:A. Pf a : fsfF_proc) &
        (Q = SKIP | Q = DIV | Q = STOP)))
      ==> S |]
    ==> S"
apply (simp add: fsfF_proc_iff[of SP])
done

(*----------------------------------------------------------*
 |                    subexpression                         |
 *----------------------------------------------------------*)

(* proc *)

lemma Rf_fsfF_proc:
  "[| !! :C .. Rf : fsfF_proc ; c: sumset C |]
   ==> Rf c : fsfF_proc"
apply (erule fsfF_procE)
apply (elim disjE conjE exE)
apply (simp_all)
done

lemma Pf_fsfF_proc:
  "[| (? :A -> Pf) [+] Q : fsfF_proc ; a:A |]
   ==> Pf a : fsfF_proc"
apply (erule fsfF_procE)
apply (simp)
done

lemma Qf_range:
  "(? :A -> Pf) [+] Q : fsfF_proc
   ==> Q = SKIP | Q = DIV | Q = STOP"
apply (erule fsfF_procE)
apply (simp)
done

(*======================================================*
 |                                                      |
 |    function to decompose : fsfF_decompo_int, ext     |
 |                                                      |
 *======================================================*)

(*
isabelle 2011

consts
  fsfF_C ::
     "('p,'a) proc => 'a sets_nats"
  fsfF_Rf ::
     "('p,'a) proc => ('a aset_anat => ('p,'a) proc)"

  fsfF_A ::
     "('p,'a) proc => 'a set"
  fsfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
  fsfF_Q ::
     "('p,'a) proc => ('p,'a) proc"

(* they are partial functions *)

recdef fsfF_C "{}"
  "fsfF_C (!! :C .. Rf) = C"
recdef fsfF_Rf "{}"
  "fsfF_Rf (!! :C .. Rf) = Rf"
recdef fsfF_A "{}"
  "fsfF_A ((? :A -> Pf) [+] Q) = A"
recdef fsfF_Pf "{}"
  "fsfF_Pf ((? :A -> Pf) [+] Q) = Pf"
recdef fsfF_Q "{}"
  "fsfF_Q ((? :A -> Pf) [+] Q) = Q"
*)

fun
  fsfF_C ::
     "('p,'a) proc => 'a sets_nats"
where
  "fsfF_C (!! :C .. Rf) = C"

fun
  fsfF_Rf ::
     "('p,'a) proc => ('a aset_anat => ('p,'a) proc)"
where
  "fsfF_Rf (!! :C .. Rf) = Rf"

fun
  fsfF_A ::
     "('p,'a) proc => 'a set"
where
  "fsfF_A ((? :A -> Pf) [+] Q) = A"

fun
  fsfF_Pf ::
     "('p,'a) proc => ('a => ('p,'a) proc)"
where
  "fsfF_Pf ((? :A -> Pf) [+] Q) = Pf"

fun
  fsfF_Q ::
     "('p,'a) proc => ('p,'a) proc"
where
  "fsfF_Q ((? :A -> Pf) [+] Q) = Q"

(* they are partial functions *)

(*------------------------*
 |     decomposition      |
 *------------------------*)

lemma cspF_fsfF_proc_decompo:
   "P : fsfF_proc ==>
     ((P = (!! : fsfF_C P .. fsfF_Rf P)) |
      (P = (? : fsfF_A P -> fsfF_Pf P [+] fsfF_Q P)))"
apply (erule fsfF_proc.cases)
apply (simp_all)
done

(****************** to add them again ******************)

declare if_split    [split]
declare disj_not1   [simp]

end


(* Author: Florian Haftmann & Lukas Bulwahn, TU Muenchen *)

section {* A simple counterexample generator performing random testing *}

theory Quickcheck_Random
imports Random Code_Evaluation Enum
begin

notation fcomp (infixl "\<circ>>" 60)
notation scomp (infixl "\<circ>\<rightarrow>" 60)

setup {* Code_Target.add_derived_target ("Quickcheck", [(Code_Runtime.target, I)]) *}

subsection {* Catching Match exceptions *}

axiomatization catch_match :: "'a => 'a => 'a"

code_printing
  constant catch_match \<rightharpoonup> (Quickcheck) "((_) handle Match => _)"

subsection {* The @{text random} class *}

class random = typerep +
  fixes random :: "natural \<Rightarrow> Random.seed \<Rightarrow> ('a \<times> (unit \<Rightarrow> term)) \<times> Random.seed"

subsection {* Fundamental and numeric types*}

instantiation bool :: random
begin

definition
  "random i = Random.range 2 \<circ>\<rightarrow>
    (\<lambda>k. Pair (if k = 0 then Code_Evaluation.valtermify False else Code_Evaluation.valtermify True))"

instance ..

end

instantiation itself :: (typerep) random
begin

definition
  random_itself :: "natural \<Rightarrow> Random.seed \<Rightarrow> ('a itself \<times> (unit \<Rightarrow> term)) \<times> Random.seed"
where "random_itself _ = Pair (Code_Evaluation.valtermify TYPE('a))"

instance ..

end

instantiation char :: random
begin

definition
  "random _ = Random.select (Enum.enum :: char list) \<circ>\<rightarrow> (\<lambda>c. Pair (c, \<lambda>u. Code_Evaluation.term_of c))"

instance ..

end

instantiation String.literal :: random
begin

definition
  "random _ = Pair (STR '''', \<lambda>u. Code_Evaluation.term_of (STR ''''))"

instance ..

end

instantiation nat :: random
begin

definition random_nat :: "natural \<Rightarrow> Random.seed
  \<Rightarrow> (nat \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
where
  "random_nat i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
     let n = nat_of_natural k
     in (n, \<lambda>_. Code_Evaluation.term_of n)))"

instance ..

end

instantiation int :: random
begin

definition
  "random i = Random.range (2 * i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
     let j = (if k \<ge> i then int (nat_of_natural (k - i)) else - (int (nat_of_natural (i - k))))
     in (j, \<lambda>_. Code_Evaluation.term_of j)))"

instance ..

end

instantiation natural :: random
begin

definition random_natural :: "natural \<Rightarrow> Random.seed
  \<Rightarrow> (natural \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
where
  "random_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>n. Pair (n, \<lambda>_. Code_Evaluation.term_of n))"

instance ..

end

instantiation integer :: random
begin

definition random_integer :: "natural \<Rightarrow> Random.seed
  \<Rightarrow> (integer \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
where
  "random_integer i = Random.range (2 * i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
     let j = (if k \<ge> i then integer_of_natural (k - i) else - (integer_of_natural (i - k)))
      in (j, \<lambda>_. Code_Evaluation.term_of j)))"

instance ..

end

subsection {* Complex generators *}

text {* Towards @{typ "'a \<Rightarrow> 'b"} *}

axiomatization random_fun_aux :: "typerep \<Rightarrow> typerep \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> term)
  \<Rightarrow> (Random.seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> Random.seed)
  \<Rightarrow> (Random.seed \<Rightarrow> Random.seed \<times> Random.seed)
  \<Rightarrow> Random.seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> Random.seed"

definition random_fun_lift :: "(Random.seed \<Rightarrow> ('b \<times> (unit \<Rightarrow> term)) \<times> Random.seed)
  \<Rightarrow> Random.seed \<Rightarrow> (('a\<Colon>term_of \<Rightarrow> 'b\<Colon>typerep) \<times> (unit \<Rightarrow> term)) \<times> Random.seed"
where
  "random_fun_lift f =
    random_fun_aux TYPEREP('a) TYPEREP('b) (op =) Code_Evaluation.term_of f Random.split_seed"

instantiation "fun" :: ("{equal, term_of}", random) random
begin

definition
  random_fun :: "natural \<Rightarrow> Random.seed \<Rightarrow> (('a \<Rightarrow> 'b) \<times> (unit \<Rightarrow> term)) \<times> Random.seed"
  where "random i = random_fun_lift (random i)"

instance ..

end

text {* Towards type copies and datatypes *}

definition collapse :: "('a \<Rightarrow> ('a \<Rightarrow> 'b \<times> 'a) \<times> 'a) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'a"
  where "collapse f = (f \<circ>\<rightarrow> id)"

definition beyond :: "natural \<Rightarrow> natural \<Rightarrow> natural"
  where "beyond k l = (if l > k then l else 0)"

lemma beyond_zero: "beyond k 0 = 0"
  by (simp add: beyond_def)

definition (in term_syntax) [code_unfold]:
  "valterm_emptyset = Code_Evaluation.valtermify ({} :: ('a :: typerep) set)"

definition (in term_syntax) [code_unfold]:
  "valtermify_insert x s = Code_Evaluation.valtermify insert {\<cdot>} (x :: ('a :: typerep * _)) {\<cdot>} s"

instantiation set :: (random) random
begin

fun random_aux_set
where
  "random_aux_set 0 j = collapse (Random.select_weight [(1, Pair valterm_emptyset)])"
| "random_aux_set (Code_Numeral.Suc i) j =
    collapse (Random.select_weight
      [(1, Pair valterm_emptyset),
       (Code_Numeral.Suc i,
        random j \<circ>\<rightarrow> (%x. random_aux_set i j \<circ>\<rightarrow> (%s. Pair (valtermify_insert x s))))])"

definition "random_set i = random_aux_set i i"

instance ..

end

lemma random_aux_rec:
  fixes random_aux :: "natural \<Rightarrow> 'a"
  assumes "random_aux 0 = rhs 0"
    and "\<And>k. random_aux (Code_Numeral.Suc k) = rhs (Code_Numeral.Suc k)"
  shows "random_aux k = rhs k"
  using assms by (rule natural.induct)

subsection {* Deriving random generators for datatypes *}

ML_file "Tools/Quickcheck/quickcheck_common.ML"
ML_file "Tools/Quickcheck/random_generators.ML"

subsection {* Code setup *}

code_printing
  constant random_fun_aux \<rightharpoonup> (Quickcheck) "Random'_Generators.random'_fun"
  -- {* With enough criminal energy this can be abused to derive @{prop False};
  for this reason we use a distinguished target @{text Quickcheck}
  not spoiling the regular trusted code generation *}

code_reserved Quickcheck Random_Generators

no_notation fcomp (infixl "\<circ>>" 60)
no_notation scomp (infixl "\<circ>\<rightarrow>" 60)

hide_const (open) catch_match random collapse beyond random_fun_aux random_fun_lift

hide_fact (open) collapse_def beyond_def random_fun_lift_def

end


theory Presimplified_Semantics_Manual
  imports "artifact_setup.Artifact_Setup"
begin

(*5 flags generation CF,SF,OF,ZF,PF *)
instruction_semantics_parser "../InstructionSemantics/strata_rules_5flags"
lemmas strata_rules_5flags.semantics_def[code]

locale presimplified_semantics = execution_context + strata_rules_5flags
begin

named_theorems presimplify

(* MANUAL SEMANTICS *)

schematic_goal unfold_semantics:
  shows \<open>instr_semantics semantics instr_sig = ?x\<close>
  by (simp add: semantics_def simp_rules)

(* push and pop *)
schematic_goal get_semantics_Push[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Push) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Pop[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Pop) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* shifting *)

schematic_goal get_semantics_Shl[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Shl) op1 op2) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Shr[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Shr) op1 op2) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* Bsr *)

schematic_goal get_semantics_Bsr[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_80386 Bsr) op1 op2) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* nop *)

lemma get_semantics_nop_unary[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Nop) op) s = id"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply rewrite_one_let'+
  apply (auto simp add: Let'_def simp_rules)
  done

lemma get_semantics_nop_binary[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Nop) op\<^sub>1 op\<^sub>2) s = id"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (rewrite_one_let')+
  apply (auto simp add: Let'_def simp_rules )
  done

lemma get_semantics_nop_ternary[presimplify]:
  shows "get_semantics assembly semantics (Ternary (IS_8088 Nop) op\<^sub>1 op\<^sub>2 op3) s = id"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (rewrite_one_let')+
  apply (auto simp add: Let'_def simp_rules )
  done

(* call / ret / leave *)

schematic_goal get_semantics_Leave[presimplify]:
  shows "get_semantics assembly semantics (Nullary (IS_80188 Leave)) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Ret[presimplify]:
  shows "get_semantics assembly semantics (Nullary (IS_8088 Ret)) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Call[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Call) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* lea *)
schematic_goal get_semantics_Lea[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Lea) op1 op2) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* imul *)
schematic_goal get_semantics_imul_binary[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Imul) op1 op2) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_imul_unary[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Imul) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_imul_r64_r64_imm[presimplify]:
  shows "get_semantics assembly semantics (Ternary (IS_8088 Imul) op1 op2 op3) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

(* jumps *)

schematic_goal get_semantics_Jmp[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Jmp) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Ja[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Ja) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Jae[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Jae) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Jb[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Jb) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Jbe[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Jbe) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Je[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Je) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Jle[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Jle) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Jne[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Jne) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

schematic_goal get_semantics_Jg[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jg) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jge[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jge) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jl[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jl) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jnb[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jnb) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jno[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jno) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jnp[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jnp) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jns[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jns) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jo[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jo) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Jp[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Jp) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

schematic_goal get_semantics_Js[presimplify]:
  "get_semantics assembly semantics (Unary (IS_8088 Js) op) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

(* sub *)
schematic_goal get_semantics_sub_m64_imm64[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Sub) (Memory SixtyFour Mem) (Immediate ImmSize (ImmVal Immvalue))) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* bswap *)
schematic_goal get_semantics_bswap_unary[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_80486 Bswap) op) s = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

(* sbb *)
schematic_goal get_semantics_sbb[presimplify]:
  shows "get_semantics assembly semantics (Binary (IS_8088 Sbb) op1 op2) s = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules)
  done

(* sar *)
schematic_goal get_semantics_Sar[presimplify]:
  shows "get_semantics \<alpha> semantics (Binary (IS_8088 Sar) op\<^sub>1 op\<^sub>2) si = ?x"
   apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* ucomisd *)
schematic_goal get_semantics_ucomisd_xmm_m64[presimplify]:
  shows "get_semantics \<alpha> semantics (Binary (IS_SSE2_SIMD Ucomisd) (Reg (SIMD OneHundredTwentyEight r0 r\<^sub>1 r\<^sub>2 r3)) (Storage (Memory SixtyFour Mem))) si = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* div *)
schematic_goal get_semantics_div[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Div) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

(* idiv *)
schematic_goal get_semantics_idiv[presimplify]:
  shows "get_semantics assembly semantics (Unary (IS_8088 Idiv) op1) = ?x"
  apply (rule ext)
  apply (subst get_semantics_def)
  apply (subst unfold_semantics)
  apply (auto simp add: Let'_def simp_rules )
  done

end
end