theory Deduction imports Main Term begin

(* assignment 6 *)
(* (a) *)

inductive deduce::  "msg set\<Rightarrow>msg\<Rightarrow>bool"   (infix "\<turnstile>" 72)
  for T :: "msg set" where
deduce_axiom: "u \<in> T \<Longrightarrow> deduce T u"
| deduce_comp_hash: "deduce T x \<Longrightarrow> deduce T (Hash x)"
| deduce_comp_concat: "deduce T x \<Longrightarrow> deduce T y \<Longrightarrow> deduce T (Concat x y)"
| deduce_comp_sym_encrypt: "deduce T x \<Longrightarrow> deduce T y \<Longrightarrow> deduce T (Sym_encrypt x y)"
| deduce_comp_pub_encrypt: "deduce T x \<Longrightarrow> deduce T y \<Longrightarrow> deduce T (Pub_encrypt x y)"
| deduce_comp_sign: "deduce T x \<Longrightarrow> deduce T (Sign x (Const ''intruder''))"
| deduce_proj1: "deduce T (Concat x y) \<Longrightarrow> deduce T x"
| deduce_proj2: "deduce T (Concat x y) \<Longrightarrow> deduce T y"
| deduce_sym_decrypt: "deduce T (Sym_encrypt x y) \<Longrightarrow> deduce T y \<Longrightarrow> deduce T x"
| deduce_pub_decrypt: "deduce T (Pub_encrypt x (Const ''intruder'')) \<Longrightarrow> deduce T x"

(* testing *)
lemma "deduce {Sym_encrypt x y, y} x" by(auto intro:deduce.intros)
lemma "deduce {m, n} (Hash (Concat m n))" by(auto intro:deduce.intros)
lemma "deduce {Sym_encrypt m k, Pub_encrypt k (Const ''intruder'')} (Concat m (Sign m (Const ''intruder'')))" (is "deduce ?T ?g")
proof-
  have "deduce ?T k" by(auto intro:deduce.intros)
  then show "deduce ?T ?g" by(auto intro:deduce.intros)
qed

(* (b) *)
lemma deduce_weaken:
  assumes "G \<turnstile> t" and "G \<subseteq> H"
  shows "H \<turnstile> t"
  using assms
proof(induction rule:deduce.induct)
qed(auto intro:deduce.intros)

lemma deduce_cut:
  assumes "(insert t H) \<turnstile> u" and "H \<turnstile> t"
  shows "H \<turnstile> u"
  using assms
proof(induction rule:deduce.induct)
qed(auto intro:deduce.intros)

(* assignment 7 *)
datatype constraint =
Constraint "msg list " "msg list " "msg " ( "((2_/|_)/} _) " [67,67,67]66)
(* elements go from the first list to the second.
they are popped from the head of the first list and are push to the top
of the second one *)

type_synonym system = "constraint list"

(* (a) *)
(* functions lifted to msg list get a postfix l
functions lifted to constraints get a postfix c
functions lifted to systems get a postfix s *)
definition sapplyl::"subst_msg \<Rightarrow> msg list \<Rightarrow> msg list" where
"sapplyl s l = map (sapply_msg s) l"
definition sapplyc:: "subst_msg \<Rightarrow> constraint \<Rightarrow> constraint" where
"sapplyc s c = (case c of  a|m}t \<Rightarrow> (sapplyl s a)|(sapplyl s m)}( sapply_msg s t))"
definition sapplys:: "subst_msg \<Rightarrow> system \<Rightarrow> system" where
"sapplys s cs = map (sapplyc s) cs"

lemma sapplyc_scomp:"sapplyc (scomp_msg t s) c = sapplyc t (sapplyc s (c))"
  apply(cases c)
  apply(auto simp add:sapplyc_def sapplyl_def)
    apply(simp_all add:sapply_msg_scomp_msg)
  done

lemma sapplyl_Variable[simp]: "sapplyl Variable x = x"
proof(induction x)
  case Nil
  then show ?case by(simp add:sapplyl_def sapply_msg_simps)
next
  case (Cons a x)
  then show ?case by(simp add:sapplyl_def sapply_msg_simps)
qed

lemma sapplyc_Variablei[simp]: "sapplyc Variable x = x"
  by(cases x)(simp add:sapplyc_def sapply_msg_simps)

lemma sapplys_Variable[simp]: "sapplys Variable x = x"
proof(induction x)
  case Nil
then show ?case by(simp add:sapplys_def)
next
  case (Cons a x)
  then show ?case by(simp add:sapplys_def)
qed

fun fvl:: "msg list \<Rightarrow> var set" where
"fvl l = (\<Union>m \<in> set l. fv_msg m)"
fun fvc:: "constraint \<Rightarrow> var set" where
"fvc c = (case c of a|m}t \<Rightarrow> (fvl a) \<union> (fvl m) \<union> (fv_msg t))"
fun fvs:: "system \<Rightarrow> var set" where
"fvs cs = (\<Union>c \<in> set cs. fvc c)"

lemma finite_fv_msg[simp]: "finite (fv_msg cs)" by(simp add:fv_msg_def)
lemma finite_fvl[simp]: "finite (fvl l)" by(induction l)simp_all
lemma finite_fvc[simp]: "finite (fvc c)" by(cases c)simp_all
lemma finite_fvs[simp]: "finite (fvs cs)" by(induction cs)(simp_all del:fvc.simps)

lemma fv_sapplyl_sdom_svran: "fvl (sapplyl s l) \<subseteq> ((fvl l) - sdom_msg s) \<union> (svran_msg s)" (is "?lhs \<subseteq> ?rhs")
proof(induction l)
  case Nil
  then show ?case by(simp add:sapplyl_def fv_sapply_sdom_svran_msg)
next
  case (Cons a as)
  have "fv_msg (sapply_msg s a) \<subseteq> ((fv_msg (a)) - sdom_msg s) \<union> (svran_msg s)"
    by(rule fv_sapply_sdom_svran_msg)
  then have "fv_msg (sapply_msg s a) \<subseteq> ((fvl (a#as)) - sdom_msg s) \<union> (svran_msg s)"
    by(auto)
  moreover have "fvl (sapplyl s as) \<subseteq> ((fvl (as)) - sdom_msg s) \<union> (svran_msg s)"
    by(rule Cons)
  then have "fvl (sapplyl s as) \<subseteq> ((fvl (a#as)) - sdom_msg s) \<union> (svran_msg s)" by auto
  moreover have "fvl (sapplyl s (a#as)) = fv_msg (sapply_msg s a) \<union> fvl (sapplyl s as)"
    by(simp add:sapplyl_def)
  ultimately show "fvl (sapplyl s (a#as)) \<subseteq> ((fvl (a#as)) - sdom_msg s) \<union> (svran_msg s)"
    by(simp add:sapplyl_def)
qed

lemma fv_sapplyc_sdom_svran: "fvc (sapplyc s c) \<subseteq> ((fvc c) - sdom_msg s) \<union> (svran_msg s)" (is "?lhs \<subseteq> ?rhs")
proof(cases c)
  case (Constraint a m t)
  from fv_sapply_sdom_svran_msg[of s t] have "fv_msg (sapply_msg s t) \<subseteq> ?rhs"
    by(auto simp add:Constraint Un_commute Un_assoc insert_commute)
  moreover from fv_sapplyl_sdom_svran[of s a] have "fvl (sapplyl s a) \<subseteq> ?rhs"
    by(auto simp add:Constraint Un_commute Un_assoc insert_commute)
  moreover from fv_sapplyl_sdom_svran[of s m] have "fvl (sapplyl s m) \<subseteq> ?rhs"
    by(auto simp add:Constraint Un_commute Un_assoc insert_commute)
  ultimately show ?thesis
    by(simp add:sapplyc_def Constraint)
qed

lemma fv_sapplys_sdom_svran: "fvs (sapplys s cs) \<subseteq> ((fvs cs) - sdom_msg s) \<union> (svran_msg s)"
proof(induction cs)
  case Nil
then show ?case by(simp add:sapplys_def fv_sapplyc_sdom_svran)
next
  case (Cons a as)
  from fv_sapplyc_sdom_svran[of s a] have "fvc (sapplyc s a) \<subseteq> ((fvs (a#as)) - sdom_msg s) \<union> (svran_msg s)"
    by(auto simp add:Cons Un_commute Un_assoc insert_commute)
  moreover from Cons have "fvs (sapplys s as) \<subseteq> ((fvs (a#as)) - sdom_msg s) \<union> (svran_msg s)"
    by(auto simp add:Cons Un_commute Un_assoc insert_commute)
  ultimately show ?case by(auto simp add:sapplys_def Un_commute Un_assoc insert_commute)
qed

(* (b) *)
(* solution set *)
definition solved:: "constraint \<Rightarrow> bool" where
"solved c = (case c of (m|a}t) \<Rightarrow> ((set m \<union> set a) \<turnstile> t))"

lemma solvedI: "(set a \<union> set m) \<turnstile> t \<Longrightarrow> solved (a|m}t)"
  by(auto simp add:solved_def)

lemma solvedE: "solved (a|m}t) \<Longrightarrow> ((set a \<union> set m) \<turnstile> t \<Longrightarrow> P) \<Longrightarrow> P"
  by(auto simp add:solved_def)

definition sol:: "system \<Rightarrow> subst_msg set" where
"sol cs = {s. (\<forall> c \<in> set cs. solved (sapplyc s c))}"

lemma solE: "s \<in> sol cs \<Longrightarrow> ((\<And>c. c \<in> set cs \<Longrightarrow> solved (sapplyc s c)) \<Longrightarrow> P) \<Longrightarrow>P"
  by(auto simp add:sol_def)

lemma solI: "(\<And>c. c \<in> set cs \<Longrightarrow> solved (sapplyc s c)) \<Longrightarrow> s \<in> sol cs"
  by(auto simp add:sol_def)

(* lemmas *)

lemma sol_concat: "sol(cs @ cs') = sol(cs) \<inter> sol(cs')"
proof((rule equalityI;rule subsetI),rule IntI)
qed(auto simp add:sol_def)

lemma "sol_scomp": "t \<in> sol(sapplys s cs) \<Longrightarrow> (scomp_msg t s) \<in> sol(cs)"
proof(rule solI, erule solE)
  fix c
  assume w:"c \<in> set cs"
  assume x:"\<And>d. d \<in> set (sapplys s cs) \<Longrightarrow> solved (sapplyc t d)"
  have "solved (sapplyc (scomp_msg t s) c) = solved (sapplyc t (sapplyc s c))" (is "_ = solved (sapplyc t (?d))")
    by(simp add: sapplyc_scomp)
  moreover have "?d \<in> set (sapplys s cs)" by(simp add:w sapplys_def)
  ultimately show "solved (sapplyc (scomp_msg t s) c)"
    by(simp add:x)
qed

(* (c) *)
inductive rer1 :: "constraint \<Rightarrow> subst_msg \<Rightarrow> system \<Rightarrow> bool "
("(_)/\<leadsto>1[_]/ (_)" [64,64,64]63)    where
rer1_unify: "(\<And> z. t\<noteq>Variable z) \<Longrightarrow> u \<in> set m \<union> set a \<Longrightarrow> unify_msg [(t,u)] = Some s \<Longrightarrow> (a|m}t)\<leadsto>1[s] []"
| rer1_comp_hash:"(a|m} (Hash t)) \<leadsto>1[Variable] [(a|m} t)]"
| rer1_comp_concat:"(a|m} (Concat t u)) \<leadsto>1[Variable] [ a|m} t, a|m}u ]"
| rer1_comp_sym_encrypt:"(a|m} (Sym_encrypt t u)) \<leadsto>1[Variable] [ a|m}t, a|m}u ]"
| rer1_comp_pub_encrypt:"(a|m} (Pub_encrypt t u)) \<leadsto>1[Variable] [ a|m}t, a|m}u ]"
| rer1_comp_sign:"(a|m} (Sign t (Const ''intruder''))) \<leadsto>1[Variable] [a|m} t]"
| rer1_proj: "x=Concat u v \<Longrightarrow> (head@x#tail) | m } t \<leadsto>1[Variable] [ (u#v#head@tail) | (x#m) } t ]"
| rer1_sdec: "x=Sym_encrypt u k \<Longrightarrow> (head@x#tail) | m } t \<leadsto>1[Variable]
 [  ((u#head@tail) | (x#m) } t) ,
    ((head@tail) | (x#m) } k)     ]"
| rer1_adec: "x=Pub_encrypt u (Const ''intruder'') \<Longrightarrow> (head@x#tail) | m } t \<leadsto>1[Variable]
 [ ((u#head@tail) | (x#m) } t) ]"
| rer1_ksub: "Pub_encrypt u (Variable agent) \<in> set a \<Longrightarrow>
s=(Variable (agent:=Const ''intruder'')) \<Longrightarrow>
a|m}t  \<leadsto>1[s] [ sapplyc s (a|m}t) ]"

inductive rer :: "system \<Rightarrow> subst_msg \<Rightarrow> system \<Rightarrow> bool " ("(_)/\<leadsto>[_]/ _ " [73,73,73]72) where
"c \<leadsto>1[s] cs \<Longrightarrow> (head@c#tail) \<leadsto>[s] (cs @ (sapplys s (head@tail)))"

inductive rer_star :: "system \<Rightarrow> subst_msg \<Rightarrow> system \<Rightarrow> bool" ("(_)/\<leadsto>*[_]/ _ " [73,73,73]72) where
rer_star_id: "cs \<leadsto>*[Variable] cs"
| rer_star_step: "cs \<leadsto>[s] cs'' \<Longrightarrow> cs'' \<leadsto>*[t] cs' \<Longrightarrow> cs \<leadsto>*[scomp_msg t s] cs'"

(* (d) *)
definition simplec:: "constraint \<Rightarrow> bool" where
"simplec c = (case c of (a|m}Variable x) \<Rightarrow> True | _ \<Rightarrow> False)"

definition simples:: "system \<Rightarrow> bool" where
"simples cs = (\<forall> c \<in> set cs. simplec c)"

inductive is_red:: "system \<Rightarrow> subst_msg \<Rightarrow> bool" where
"cs \<leadsto>*[s] cs' \<Longrightarrow> simples cs' \<Longrightarrow> t \<in> sol(cs') \<Longrightarrow> is_red cs (scomp_msg t s)"

definition red:: "system \<Rightarrow> subst_msg set" where
"red cs = {t . is_red cs t}"

lemma redE: "x \<in> red cs \<Longrightarrow> (is_red cs x \<Longrightarrow> P) \<Longrightarrow> P"
  by(simp add:red_def)

lemma is_redE: "is_red cs u \<Longrightarrow>
(\<And>t s cs'. u=scomp_msg t s \<Longrightarrow> cs \<leadsto>*[s] cs' \<Longrightarrow> simples cs' \<Longrightarrow> t \<in> sol(cs')  \<Longrightarrow> P)
\<Longrightarrow> P"
proof(cases rule:is_red.cases)
qed(simp_all)

(* Assignment 8 *)
lemma sol_rer1:"c \<leadsto>1[s] cs \<Longrightarrow> v \<in> sol cs \<Longrightarrow> (scomp_msg v s) \<in> sol [c]"
proof(induction c s cs arbitrary: v rule:rer1.induct)
case (rer1_unify t u m a s v)
  then show ?case
  proof -
    let ?target = "scomp_msg v s"
assume nvar:"\<And>z. t \<noteq> Variable z" and app:"u \<in> set m \<union> set a"
      and unif:"unify_msg [(t, u)] = Some s" and sol:"v \<in> sol []"
  from unif have "unifiess_msg s [(t, u)]" by(rule unify_msg_return)
  then have "sapply_msg s t = sapply_msg s u"
    by(auto elim!:unifiess_msgE unifies_msgE)
  then have eq:"sapply_msg ?target t = sapply_msg ?target u" by(simp add:sapply_msg_scomp_msg)
  have "u \<in> set m \<union> set a \<Longrightarrow> solved (sapplyl ?target a| sapplyl ?target m}sapply_msg ?target u)"
  proof(erule UnE; (rule solvedI, rule deduce_axiom))
  qed(auto simp add:sapplyl_def)
  from app and this have "solved (sapplyl ?target a| sapplyl ?target m}sapply_msg ?target t)" by(simp add:eq)
  then have "solved (sapplyc ?target (a|m}t))" by(simp add:sapplyc_def)
  then show "?target \<in> sol [a|m} t ]" by(auto intro:solI)
qed
next
  case (rer1_proj x u u' head tail m t)
  show ?case
  proof -
    from rer1_proj have xdef:"x = Concat u u'"
      and sol:"v \<in> sol [(u # u' # head @ tail)|(x # m)} t ]"
          (is "v \<in> sol [?c]") .
    let ?T = "set (map (sapply_msg v) (x#m@head@tail))"

    from sol have "solved (sapplyc v ?c)" by(auto elim:solE)
    then have cut1:"(insert (sapply_msg v u) (insert (sapply_msg v u') ?T)) \<turnstile> (sapply_msg v t)"
      by(auto simp add:sapplyl_def sapplyc_def elim!: solvedE)(simp only:Un_commute Un_assoc insert_commute)

    have pair:"(insert (sapply_msg v u') ?T) \<turnstile> (sapply_msg v x)" (is "?T' \<turnstile> _")
      by(rule deduce_axiom)(simp add:sapply_msg_simps xdef)
    then have "?T' \<turnstile> (sapply_msg v u)" by(auto intro:deduce_proj1 simp add:sapply_msg_simps xdef)
    from cut1 and this have cut2:"?T' \<turnstile> (sapply_msg v t)" by(rule deduce_cut)
    have "?T \<turnstile> (sapply_msg v x)"
      by(rule deduce_axiom)(simp add:sapply_msg_simps xdef)
    then have "?T \<turnstile> (sapply_msg v u')" by(auto intro:deduce_proj2 simp add:sapply_msg_simps xdef)
    from cut2 and this have "?T \<turnstile> (sapply_msg v t)" by(rule deduce_cut)
    then show "scomp_msg v Variable \<in> sol [(head @ x # tail)|m} t ]"
      by(auto simp add:sapplyc_def Un_commute sapplyl_def intro!:solI solvedI)
  qed
next
  case (rer1_sdec x u k head tail m t)
  show ?case
  proof -
    from rer1_sdec have xdef:"x = Sym_encrypt u k"
      and sol:"v \<in> sol [(u # head @ tail)|(x # m)} t , (head @ tail)|(x # m)} k ]"
          (is "v \<in> sol [?c1, ?c2]") .
    let ?T = "set (map (sapply_msg v) (x#m@head@tail))"

    have "sapply_msg v x \<in> ?T" by simp
    then have "deduce ?T (sapply_msg v x)" by(rule deduce_axiom)
    then have sdec1:"deduce ?T (Sym_encrypt (sapply_msg v u) (sapply_msg v k))"
      by(simp add:sapply_msg_simps xdef)

    from sol have "solved (sapplyc v ?c2)" by(auto elim:solE)
    then have sdec2:"?T \<turnstile> (sapply_msg v k)"
      by(auto simp add:sapplyl_def sapplyc_def Un_commute elim!: solvedE)

    from sdec1 and sdec2 have cut1:"?T \<turnstile> (sapply_msg v u)" by(rule deduce_sym_decrypt)

    from sol have "solved (sapplyc v ?c1)" by(auto elim:solE)
    then have cut2:"insert (sapply_msg v u) ?T \<turnstile> (sapply_msg v t)"
      by(auto simp add:sapplyl_def sapplyc_def Un_commute elim:solvedE)

    from cut2 and cut1 have "?T \<turnstile> (sapply_msg v t)" by(rule deduce_cut)
    then show "scomp_msg v Variable \<in> sol [(head @ x # tail)|m} t ]"
      by(auto simp add:sapplyc_def Un_commute sapplyl_def intro!:solI solvedI)
  qed
next
  case (rer1_adec x u head tail m t)
  show ?case
  proof -
    from rer1_adec have xdef:"x = Pub_encrypt u (Const ''intruder'')" (is "x = Pub_encrypt u ?i")
      and sol:"v \<in> sol [(u # head @ tail)|(x # m)} t ]"
          (is "v \<in> sol [?c]").
    let ?T = "set (map (sapply_msg v) (x#m@head@tail))"

    from sol have "solved (sapplyc v ?c)" by(auto elim:solE)
    then have cut1:"(insert (sapply_msg v u) ?T) \<turnstile> (sapply_msg v t)"
      by(auto simp add:sapplyl_def sapplyc_def elim!: solvedE)(simp only:Un_commute Un_assoc insert_commute)

    have "?T \<turnstile> (sapply_msg v x)"
      by(rule deduce_axiom)(simp add:sapply_msg_simps xdef)
    then have "?T \<turnstile> (sapply_msg v u)" by(auto intro:deduce_pub_decrypt simp add:sapply_msg_simps xdef)
    from cut1 and this have "?T \<turnstile> (sapply_msg v t)" by(rule deduce_cut)
    then show "scomp_msg v Variable \<in> sol [(head @ x # tail)|m} t ]"
      by(auto simp add:sapplyc_def Un_commute sapplyl_def intro!:solI solvedI)
  qed
next
  case (rer1_ksub u agent a s m t)
  then have "v \<in> sol (sapplys s [(a|m} t )])" by(simp add:sapplys_def)
  then show ?case by(rule sol_scomp)
qed(auto simp add:sapplyc_def sapplyl_def sapply_msg_simps elim!:solE solvedE
intro!:solI solvedI deduce_comp_hash deduce_comp_sign deduce_comp_concat
deduce_comp_pub_encrypt deduce_comp_sym_encrypt)

lemma sol_rer: "cs \<leadsto>[s] cs' \<Longrightarrow> t \<in> sol(cs') \<Longrightarrow> (scomp_msg t s) \<in> sol cs"
proof(induction cs s cs' arbitrary: t rule:rer.induct)
  case hyp:(1 c s cs head tail)
  then have "t \<in> sol cs" by(simp add:sol_concat)
  from `c\<leadsto>1[s] cs` and this have half:"scomp_msg t s \<in> sol [c]" by(rule sol_rer1)

  from hyp have "t \<in> sol (sapplys s (head@tail))" by(simp add:sol_concat)
  then have half2:"scomp_msg t s \<in> sol (head@tail)" by(auto simp add:sol_scomp)

  have "sol (head @ c # tail) = sol head \<inter> sol [c] \<inter> sol tail"
    by(simp add:sol_concat[symmetric, of "[c]" tail] sol_concat[symmetric])
  from this and half and half2 show ?case by(simp add:sol_concat)
qed

lemma sol_rer_star: "cs \<leadsto>*[s] cs' \<Longrightarrow> simples cs' \<Longrightarrow> t \<in> sol(cs') \<Longrightarrow> (scomp_msg t s) \<in> sol cs"
proof(induction cs s cs' arbitrary: t rule:rer_star.induct)
case (rer_star_id cs)
  then show ?case by simp
next
  case (rer_star_step cs s cs'' t cs' u)
  from `simples cs'` and `u \<in> sol cs'` have "scomp_msg u t \<in> sol cs''" by(rule rer_star_step)
  from `cs \<leadsto>[s] cs''` and this have "scomp_msg (scomp_msg u t) s \<in> sol cs" by(rule sol_rer)
  then show ?case by(simp add:scomp_msg_assoc)
qed

lemma cs_sound: "red cs \<subseteq> sol cs"
  by(auto simp add:sol_rer_star elim!:redE is_redE)

(* termination -- 8b *)
fun \<theta>:: "msg \<Rightarrow> nat" where
"\<theta> (Hash x) = \<theta> x + 1"
| "\<theta> (Concat x y) = \<theta> x  + \<theta> y + 1"
| "\<theta> (Sym_encrypt x y) = \<theta> x  + \<theta> y + 1"
| "\<theta> (Pub_encrypt x y) = \<theta> x  + \<theta> y + 1"
| "\<theta> (Sign x y) = (if y= Const ''intruder'' then \<theta> x + 1 else 1)"
| "\<theta> x = 1"

fun \<chi>:: "msg \<Rightarrow> nat" where
"\<chi> (Hash x) = \<chi> x +1"
| "\<chi> (Concat x y) = (\<chi> x)*(\<chi> y) +1"
| "\<chi> (Sym_encrypt x y) = (\<chi> x) + \<theta> y + 1"
| "\<chi> (Pub_encrypt x y) = (\<chi> x) + 1"
| "\<chi> (Sign x y) = (\<chi> x) + 1"
| "\<chi> x  = 1"

fun \<chi>l :: "msg list \<Rightarrow> nat" where
"\<chi>l [] = 1" | "\<chi>l (x#tail) = (\<chi> x) * (\<chi>l tail)"

fun weight:: "constraint \<Rightarrow> nat" where
"weight (m|a}t) = (\<chi>l m)*(\<theta> t)"

fun weights:: "constraint list \<Rightarrow> nat" where
"weights [] = 0" | "weights (c#cs) = weight c + weights cs"

lemma non_zero_theta[simp]: "\<theta> x > 0"
proof(induction x rule:\<theta>.induct)
qed(simp_all)

lemma non_zero_chi[simp]: "\<chi> x > 0"
proof(induction x rule:\<chi>.induct)
qed(simp_all)

lemma non_zero_chil[simp]: "\<chi>l x > 0" by(induction x)(simp_all)
lemma non_zero_weight[simp]: "weight x > 0" by(cases x)(simp)
lemma non_zero_weights[simp]: "x \<noteq> [] \<Longrightarrow>  weights x>0" by(induction x)simp_all

lemma \<chi>l_append[simp]: "\<chi>l (a@b) = (\<chi>l a) * (\<chi>l b)"
proof(induction a;induction b)
qed simp_all

lemma weights_append[simp]: "weights (a@b) = (weights a) + (weights b)"
proof(induction a;induction b)
qed simp_all

lemma rer1_fv: "c \<leadsto>1[s] cs \<Longrightarrow> fvs(cs@(sapplys s (head@tail))) \<subseteq> fvs(head@c#tail)"
proof(induction c s cs arbitrary:head tail rule:rer1.induct)
  case (rer1_unify t u m a s)
  then show ?case
  proof -
    let ?cs="head@tail"
    from `u \<in> set m \<union> set a` have x:"fv_msg u \<subseteq> fvc (a|m}t)" by(auto)
    from  `unify_msg [(t, u)] = Some s` have "svran_msg s \<subseteq> fv_eqs_msg [(t, u)]" by(rule l3_msg)
    also have "... \<subseteq> fv_msg t \<union> fv_msg u" by(auto simp add:fv_eqs_msg_def fv_msg_def)
    also have "... \<subseteq> fv_msg t \<union> fvc (a|m}t)" using x by(auto simp add:Un_commute Un_assoc insert_commute)
    finally have svinc:"svran_msg s \<subseteq> fvc (a|m}t)" by(auto)

    have "fvs (sapplys s ?cs) \<subseteq> fvs ?cs - sdom_msg s \<union> svran_msg s" by(rule fv_sapplys_sdom_svran)
    also have "... \<subseteq> fvs ?cs \<union> svran_msg s" by blast
    also have "... \<subseteq> fvs ?cs \<union> fvc (a|m}t)" using svinc by auto
    finally show ?case by(simp add:Un_commute Un_assoc insert_commute sapplys_def del:fvc.simps)
  qed
next
  case (rer1_ksub u agent a s m t)
  let ?cs="head @ a|m} t  # tail"
  have "svran_msg (Variable(agent := Const ''intruder'')) = {}"
    by(auto simp add:svran_msg_def_real sran_msg_def_real sdom_msg_def_real fv_msg_def)
  then have svran:"svran_msg s = {}"
    by(simp add:`s = Variable(agent := Const ''intruder'')`)

  have "fvs (sapplys s ?cs) \<subseteq> fvs ?cs - sdom_msg s \<union> svran_msg s" by(rule fv_sapplys_sdom_svran)
  also have "... \<subseteq> fvs ?cs - sdom_msg s" by(simp add:svran)
  finally have "fvs (sapplys s ?cs) \<subseteq> fvs ?cs" by blast

  then show ?case by(simp add:Un_commute Un_assoc insert_commute sapplys_def del:fvc.simps)
qed(auto simp add:fv_msg_def)

lemma rer1_fv2: "c \<leadsto>1[s] cs \<Longrightarrow> s \<noteq> Variable \<Longrightarrow> fvs (cs @ sapplys s (head @ tail)) \<noteq> fvs(head @ c#tail)"
proof(induction c s cs arbitrary:head tail rule:rer1.induct)
  case (rer1_unify t u m a s)
  then show ?case  proof -
    let ?cs="head@tail"
    from `u \<in> set m \<union> set a` have x:"fv_msg u \<subseteq> fvc (a|m}t)" by(auto)
    from  `unify_msg [(t, u)] = Some s` have "sdom_msg s \<subseteq> fv_eqs_msg [(t, u)]" by(rule l3_msg)
    also have "... \<subseteq> fv_msg t \<union> fv_msg u" by(auto simp add:fv_eqs_msg_def fv_msg_def)
    also have "... \<subseteq> fv_msg t \<union> fvc (a|m}t)" using x by(auto simp add:Un_commute Un_assoc insert_commute)
    finally have sdominc:"sdom_msg s \<subseteq> fvc (a|m}t)" by(auto)

    from `s \<noteq> Variable` obtain x where xdef:"x \<in> sdom_msg s" by(auto simp add:sdom_msg_def_real)
    from this and sdominc have "x \<in> fvc (a|m}t)" by auto
    then have part1:"x \<in> fvs(head @ (a|m}t)#tail)" by auto

    from  `unify_msg [(t, u)] = Some s` have "sdom_msg s \<inter> svran_msg s = {}" by(rule l3_msg)
    from this and xdef have svninc:"x \<notin> svran_msg s" by auto

    have "fvs (sapplys s ?cs) \<subseteq> fvs ?cs - sdom_msg s \<union> svran_msg s" (is "?lhs \<subseteq> ?rhs") by(rule fv_sapplys_sdom_svran)
    moreover from xdef and svninc have "x \<notin> ?rhs" by auto
    ultimately have "x \<notin> ?lhs" by blast
    then have "x \<notin> fvs ([] @ sapplys s (head @ tail))" by auto

    from this and part1 show ?case by blast
  qed
next
  case (rer1_ksub u agent a s m t)
  then show ?case
  proof -
    have "agent \<in> fv_msg (Pub_encrypt u (Variable agent))" by(simp add:fv_msg_simps)
    from this and `Pub_encrypt u (Variable agent) \<in> set a`
    have part1:"agent \<in> fvs (head @ a|m} t  # tail)" by auto

    let ?cs="head @ a|m} t  # tail"
    let ?s="Variable(agent := Const ''intruder'')"
    have "svran_msg ?s = {}" and "sdom_msg ?s={agent}"
      by(auto simp add:svran_msg_def_real sran_msg_def_real sdom_msg_def_real fv_msg_def)
    then have svran:"svran_msg s = {}" "sdom_msg s = {agent}"
      by(simp_all add:`s = ?s`)
    have "fvs (sapplys s ?cs) \<subseteq> fvs ?cs - sdom_msg s \<union> svran_msg s" (is "?lhs \<subseteq> ?rhs") by(rule fv_sapplys_sdom_svran)
    then have "fvs (sapplys s ?cs) \<subseteq> fvs ?cs - {agent}" by(simp add:svran)

    moreover have "fvs ([sapplyc s (a|m} t )] @ sapplys s (head @ tail)) = (fvs (sapplys s ?cs))" (is "?lhs = ?rhs")
      by(simp add:sapplys_def)
    ultimately have "?lhs \<subseteq> fvs ?cs - {agent}" by simp
    then have "agent \<notin> ?lhs" by blast
    from this and  part1 show ?thesis by blast
  qed
qed(auto)

lemma rer1_weights: "c \<leadsto>1[s] cs \<Longrightarrow> s = Variable \<Longrightarrow> weights cs < weight c"
proof(induction c s cs rule:rer1.induct)
  case (rer1_sdec x u k head tail m t)
  then show ?case
  proof -
    from non_zero_theta have "Suc 0 \<le> \<theta> t" by (simp add: Suc_leI)
      then  have "\<chi> u * \<theta> t < (1+\<chi> u)*(\<theta> t)" and "\<theta> k \<le> \<theta> k* \<theta> t" by auto
    then have "\<chi> u * \<theta> t + \<theta> k < (1 + \<chi> u + \<theta> k) * \<theta> t" (is "?lhs < ?rhs")
      by (metis add_less_cancel_right add_less_mono distrib_right le_neq_implies_less)
    then have "\<chi>l head * \<chi>l tail * ?lhs < \<chi>l head * \<chi>l tail * ?rhs" by auto
    then have "\<chi> u * (\<chi>l head * \<chi>l tail) * \<theta> t + \<chi>l head * \<chi>l tail * \<theta> k
    < \<chi>l head * (\<chi>l tail + (\<chi> u + \<theta> k) * \<chi>l tail) * \<theta> t"
    (* sledgehammer *)
    proof -
      have f1: "\<chi> u * (\<chi>l head * \<chi>l tail) * \<theta> t + \<chi>l head * \<chi>l tail * \<theta> k = \<theta> t * \<chi> u * (\<chi>l tail * \<chi>l head) + \<theta> k * (\<chi>l tail * \<chi>l head)"
        by simp
      have f2: "\<chi>l head * (\<chi>l tail + (\<chi> u + \<theta> k) * \<chi>l tail) = (\<chi> u + \<theta> k + 1) * (\<chi>l head * \<chi>l tail)"
        by (metis (no_types) semiring_normalization_rules(19) semiring_normalization_rules(3))
      have "1 + \<chi> u + \<theta> k = \<chi> u + \<theta> k + 1"
        by auto
      then have "\<chi>l head * (\<chi>l tail + (\<chi> u + \<theta> k) * \<chi>l tail) * \<theta> t = (1 + \<chi> u + \<theta> k) * (\<theta> t * (\<chi>l tail * \<chi>l head))"
        using f2 by (metis semiring_normalization_rules(19) semiring_normalization_rules(7))
      then have "\<chi>l head * (\<chi>l tail + (\<chi> u + \<theta> k) * \<chi>l tail) * \<theta> t = (1 + \<chi> u + \<theta> k) * (\<chi>l head * \<chi>l tail * \<theta> t)"
        by simp
      then have "\<chi>l head * (\<chi>l tail + (\<chi> u + \<theta> k) * \<chi>l tail) * \<theta> t = \<chi>l head * \<chi>l tail * ((1 + \<chi> u + \<theta> k) * \<theta> t)"
        by (simp add: semiring_normalization_rules(19))
      then show ?thesis
        using f1 by (metis (no_types) \<open>\<chi>l head * \<chi>l tail * (\<chi> u * \<theta> t + \<theta> k) < \<chi>l head * \<chi>l tail * ((1 + \<chi> u + \<theta> k) * \<theta> t)\<close> semiring_normalization_rules(1) semiring_normalization_rules(7))
    qed
      (* end sledgehammer *)
    from this and rer1_sdec show ?case by auto
  qed
next
  case (rer1_ksub u agent a s m t)
  from ` s = Variable(agent := Const ''intruder'')` have "s agent = Const ''intruder''" by simp
  moreover from `s=Variable` have "s agent = Variable agent" by simp
  ultimately have False by simp
  then show ?case by(rule FalseE)
qed (simp_all add: add_mult_distrib2)

lemma rer_fv: "cs \<leadsto>[s] cs' \<Longrightarrow> fvs(cs') \<subseteq> fvs(cs)"
proof(induction cs s cs' rule:rer.induct)
  case (1 c s cs head tail)
  then show ?case by(rule rer1_fv)
qed

lemma rer_fv2: "cs \<leadsto>[s] cs' \<Longrightarrow> s \<noteq> Variable \<Longrightarrow> fvs(cs') \<noteq> fvs(cs)"
proof(induction cs s cs' rule:rer.induct)
  case (1 c s cs head tail)
  then show ?case by(rule rer1_fv2)
qed

lemma rer_weights: "cs \<leadsto>[s] cs' \<Longrightarrow> s = Variable \<Longrightarrow> weights cs' < weights cs"
proof(induction cs s cs' rule:rer.induct)
  case (1 c s cs head tail)
  then show ?case by(simp add:rer1_weights)
qed

inductive reducesto:: "system \<Rightarrow> system \<Rightarrow> bool" where
"cs \<leadsto>[s] cs' \<Longrightarrow> reducesto cs cs'"

definition termination_order::"(system \<times> system) set" where
"termination_order = (% cs. card (fvs cs)) <*mlex*> (measure weights)"

lemma reducesto_subset_termination_order: "reducesto cs cs' \<Longrightarrow> (cs', cs) \<in> termination_order"
proof(induction cs cs' rule:reducesto.induct)
  case (1 cs s cs')
  then have inc:"fvs cs' \<subseteq> fvs cs" by(rule rer_fv)
  then have part1:"card (fvs cs') \<le> card (fvs cs)" by(simp add:card_mono del:fvs.simps)
  show ?case
proof(cases "s=Variable")
  case True
  from `cs \<leadsto>[s] cs'` and True have "weights cs' < weights cs" by(rule rer_weights)
  then have "(cs', cs) \<in> measure weights" by simp
  then show ?thesis by(auto simp add:termination_order_def part1 mlex_leq simp del:fvs.simps)
next
  case False
  from `cs \<leadsto>[s] cs'` and False have "fvs cs' \<noteq> fvs cs" by(rule rer_fv2)
  from this and inc have "fvs cs' \<subset> fvs cs" by blast
  then have "card (fvs cs') < card (fvs cs)" by(simp add:psubset_card_mono del:fvs.simps)
  then show ?thesis by(auto simp add:termination_order_def part1 mlex_less simp del:fvs.simps)
qed
qed

lemma termination_red: "wf {(y, x). reducesto x y}" (is "wf ?o")
proof -
  have "?o \<subseteq> termination_order" by(auto simp add: reducesto_subset_termination_order simp del:fvs.simps)
  moreover have "wf termination_order" by(auto simp add:termination_order_def wf_mlex)
  ultimately show "wf ?o" by(simp add:wf_subset)
qed

end


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

Datatypes of agents and messages;
Inductive relations "parts", "analz" and "synth"
*)

section\<open>Theory of Agents and Messages for Security Protocols\<close>

theory Message
imports MainRLT
begin

(*Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK*)
lemma [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

type_synonym
  key = nat

consts
  all_symmetric :: bool        \<comment> \<open>true if all keys are symmetric\<close>
  invKey        :: "key\<Rightarrow>key"  \<comment> \<open>inverse of a symmetric key\<close>

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric \<longrightarrow> invKey = id"
    by (rule exI [of _ id], auto)

text\<open>The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa\<close>

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

datatype  \<comment> \<open>We allow any number of friendly agents\<close>
  agent = Server | Friend nat | Spy

datatype
     msg = Agent  agent     \<comment> \<open>Agent names\<close>
         | Number nat       \<comment> \<open>Ordinary integers, timestamps, ...\<close>
         | Nonce  nat       \<comment> \<open>Unguessable nonces\<close>
         | Key    key       \<comment> \<open>Crypto keys\<close>
         | Hash   msg       \<comment> \<open>Hashing\<close>
         | MPair  msg msg   \<comment> \<open>Compound messages\<close>
         | Crypt  key msg   \<comment> \<open>Encryption, public- or shared-key\<close>

text\<open>Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...\<close>
syntax
  "_MTuple" :: "['a, args] \<Rightarrow> 'a * 'b"  ("(2\<lbrace>_,/ _\<rbrace>)")
translations
  "\<lbrace>x, y, z\<rbrace>" \<rightleftharpoons> "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>" \<rightleftharpoons> "CONST MPair x y"

definition HPair :: "[msg,msg] \<Rightarrow> msg" ("(4Hash[_] /_)" [0, 1000]) where
    \<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
    "Hash[X] Y == \<lbrace>Hash\<lbrace>X,Y\<rbrace>, Y\<rbrace>"

definition keysFor :: "msg set \<Rightarrow> key set" where
    \<comment> \<open>Keys useful to decrypt elements of a message set\<close>
  "keysFor H == invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection\<open>Inductive Definition of All Parts" of a Message\<close>

inductive_set
  parts :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro]: "X \<in> H ==> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace> \<in> parts H ==> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace> \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

text\<open>Monotonicity\<close>
lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Body)+
done

text\<open>Equations hold because constructors are injective.\<close>
lemma Friend_image_eq [simp]: "(Friend x \<in> Friend`A) = (x\<in>A)"
by auto

lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

subsubsection\<open>Inverse of keys\<close>

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
by (metis invKey)

subsection\<open>keysFor operator\<close>

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

text\<open>Monotonicity\<close>
lemma keysFor_mono: "G \<subseteq> H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection\<open>Inductive relation "parts"\<close>

lemma MPair_parts:
     "[| \<lbrace>X,Y\<rbrace> \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text\<open>NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  \<open>MPair_parts\<close> is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

text\<open>WARNING: loops if H = {Y}, therefore must not be repeated!\<close>
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection\<open>Unions\<close>

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
by (metis insert_is_Un parts_Un)

text\<open>TWO inserts to avoid looping.  This rewrite is better than nothing.
  But its behaviour can be strange.\<close>
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
by (metis Un_commute Un_empty_right Un_insert_right insert_is_Un parts_Un)

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]:
  "parts (\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts (H x))"
  by (intro equalityI parts_UN_subset1 parts_UN_subset2)

lemma parts_image [simp]:
  "parts (f ` A) = (\<Union>x\<in>A. parts {f x})"
  apply auto
  apply (metis (mono_tags, opaque_lifting) image_iff parts_singleton)
  apply (metis empty_subsetI image_eqI insert_absorb insert_subset parts_mono)
  done

text\<open>Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!\<close>

text\<open>This allows \<open>blast\<close> to simplify occurrences of
  \<^term>\<open>parts(G\<union>H)\<close> in the assumption.\<close>
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
by (metis parts_idem parts_increasing parts_mono subset_trans)

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (metis parts_subset_iff subsetD)

text\<open>Cut\<close>
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (metis insert_absorb parts_idem parts_insert)

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Body)
done

lemma parts_insert_MPair [simp]:
     "parts (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
by auto

text\<open>In any message, there is an upper bound N on its greatest nonce.\<close>
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n \<longrightarrow> Nonce n \<notin> parts {msg}"
proof (induct msg)
  case (Nonce n)
    show ?case
      by simp (metis Suc_n_not_le_n)
next
  case (MPair X Y)
    then show ?case \<comment> \<open>metis works out the necessary sum itself!\<close>
      by (simp add: parts_insert2) (metis le_trans nat_le_linear)
qed auto

subsection\<open>Inductive relation "analz"\<close>

text\<open>Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.\<close>

inductive_set
  analz :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro,simp]: "X \<in> H ==> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "\<lbrakk>Crypt K X \<in> analz H; Key(invKey K) \<in> analz H\<rbrakk> \<Longrightarrow> X \<in> analz H"

text\<open>Monotonicity; Lemma 1 of Lowe's paper\<close>
lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd)
done

text\<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
     "[| \<lbrace>X,Y\<rbrace> \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
by (metis analz_increasing analz_subset_parts equalityI parts_mono parts_subset_iff)

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection\<open>General equational properties\<close>

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other\<close>
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection\<open>Rewrite rules for pulling out atomic messages\<close>

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

text\<open>Can only pull out Keys if they are not needed to decrypt the rest\<close>
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert \<lbrace>X,Y\<rbrace> H) =
          insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

text\<open>Can pull out enCrypted message if the Key is not known\<close>
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)

done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

text\<open>Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with \<open>if_split\<close>; apparently
\<open>split_tac\<close> does not cope with patterns such as \<^term>\<open>analz (insert
(Crypt K X) H)\<close>\<close>
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text\<open>This rule supposes "for the sake of argument" that we have the key.\<close>
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

subsubsection\<open>Idempotence and transitivity\<close>

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
by (metis analz_idem analz_increasing analz_mono subset_trans)

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

text\<open>Cut; Lemma 2 of Lowe\<close>
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H \<longrightarrow> Y: analz H"
*)

text\<open>This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated.\<close>
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (metis analz_cut analz_insert_eq_I insert_absorb)

text\<open>A congruence rule for "analz"\<close>

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
by (metis Un_mono analz_Un analz_subset_iff subset_trans)

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H' |]
      ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

text\<open>If there are no pairs or encryptions then analz does nothing\<close>
lemma analz_trivial:
     "[| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

text\<open>These two are obsolete (with a single Spy) but cost little to prove...\<close>
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection\<open>Inductive relation "synth"\<close>

text\<open>Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

text\<open>Monotonicity\<close>
lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

text\<open>NO \<open>Agent_synth\<close>, as any Agent name can be synthesized.
  The same holds for \<^term>\<open>Number\<close>\<close>

inductive_simps synth_simps [iff]:
 "Nonce n \<in> synth H"
 "Key K \<in> synth H"
 "Hash X \<in> synth H"
 "\<lbrace>X,Y\<rbrace> \<in> synth H"
 "Crypt K X \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection\<open>Unions\<close>

text\<open>Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.\<close>
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection\<open>Idempotence and transitivity\<close>

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, auto)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
by (metis subset_trans synth_idem synth_increasing synth_mono)

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

text\<open>Cut; Lemma 2 of Lowe\<close>
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Crypt_synth_eq [simp]:
     "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection\<open>Combinations of parts, analz and synth\<close>

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
by (metis Un_empty_right analz_synth_Un)

subsubsection\<open>For reasoning about the Fake rule in traces\<close>

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (metis UnCI Un_upper2 insert_subset parts_Un parts_mono)

text\<open>More specifically for Fake. See also \<open>Fake_parts_sing\<close> below\<close>
lemma Fake_parts_insert:
     "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
by (metis Un_commute analz_increasing insert_subset parts_analz parts_mono
          parts_synth synth_mono synth_subset_iff)

lemma Fake_parts_insert_in_Un:
     "\<lbrakk>Z \<in> parts (insert X H);  X \<in> synth (analz H)\<rbrakk>
      \<Longrightarrow> Z \<in> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert subsetD)

text\<open>\<^term>\<open>H\<close> is sometimes \<^term>\<open>Key ` KK \<union> spies evs\<close>, so can't put
  \<^term>\<open>G=H\<close>.\<close>
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H)", force)
apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H \<and> X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

text\<open>Without this equation, other rules for synth and analz would yield
  redundant cases\<close>
lemma MPair_synth_analz [iff]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) \<and> Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) = (Hash\<lbrace>X,Y\<rbrace> \<in> analz H)"
by blast

subsection\<open>HPair: a combination of Hash and MPair\<close>

subsubsection\<open>Freeness\<close>

lemma Agent_neq_HPair: "Agent A \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Nonce_neq_HPair: "Nonce N \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Number_neq_HPair: "Number N \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Key_neq_HPair: "Key K \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Hash_neq_HPair: "Hash Z \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemma Crypt_neq_HPair: "Crypt K X' \<noteq> Hash[X] Y"
  unfolding HPair_def by simp

lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
                    Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

declare HPair_neqs [iff]
declare HPair_neqs [symmetric, iff]

lemma HPair_eq [iff]: "(Hash[X'] Y' = Hash[X] Y) = (X' = X \<and> Y'=Y)"
by (simp add: HPair_def)

lemma MPair_eq_HPair [iff]:
     "(\<lbrace>X',Y'\<rbrace> = Hash[X] Y) = (X' = Hash\<lbrace>X,Y\<rbrace> \<and> Y'=Y)"
by (simp add: HPair_def)

lemma HPair_eq_MPair [iff]:
     "(Hash[X] Y = \<lbrace>X',Y'\<rbrace>) = (X' = Hash\<lbrace>X,Y\<rbrace> \<and> Y'=Y)"
by (auto simp add: HPair_def)

subsubsection\<open>Specialized laws, proved in terms of those for Hash and MPair\<close>

lemma keysFor_insert_HPair [simp]: "keysFor (insert (Hash[X] Y) H) = keysFor H"
by (simp add: HPair_def)

lemma parts_insert_HPair [simp]:
    "parts (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (parts (insert Y H)))"
by (simp add: HPair_def)

lemma analz_insert_HPair [simp]:
    "analz (insert (Hash[X] Y) H) =
     insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (analz (insert Y H)))"
by (simp add: HPair_def)

lemma HPair_synth_analz [simp]:
     "X \<notin> synth (analz H)
    ==> (Hash[X] Y \<in> synth (analz H)) =
        (Hash \<lbrace>X, Y\<rbrace> \<in> analz H \<and> Y \<in> synth (analz H))"
by (auto simp add: HPair_def)

text\<open>We do NOT want Crypt... messages broken up in protocols!!\<close>
declare parts.Body [rule del]

text\<open>Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the \<open>analz_insert\<close> rules\<close>

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N X' Y

text\<open>Cannot be added with \<open>[simp]\<close> -- messages should not always be
  re-ordered.\<close>
lemmas pushes = pushKeys pushCrypts

subsection\<open>The set of key-free messages\<close>

(*Note that even the encryption of a key-free message remains key-free.
  This concept is valuable because of the theorem analz_keyfree_into_Un, proved below. *)

inductive_set
  keyfree :: "msg set"
  where
    Agent:  "Agent A \<in> keyfree"
  | Number: "Number N \<in> keyfree"
  | Nonce:  "Nonce N \<in> keyfree"
  | Hash:   "Hash X \<in> keyfree"
  | MPair:  "[|X \<in> keyfree;  Y \<in> keyfree|] ==> \<lbrace>X,Y\<rbrace> \<in> keyfree"
  | Crypt:  "[|X \<in> keyfree|] ==> Crypt K X \<in> keyfree"

declare keyfree.intros [intro]

inductive_cases keyfree_KeyE: "Key K \<in> keyfree"
inductive_cases keyfree_MPairE: "\<lbrace>X,Y\<rbrace> \<in> keyfree"
inductive_cases keyfree_CryptE: "Crypt K X \<in> keyfree"

lemma parts_keyfree: "parts (keyfree) \<subseteq> keyfree"
  by (clarify, erule parts.induct, auto elim!: keyfree_KeyE keyfree_MPairE keyfree_CryptE)

(*The key-free part of a set of messages can be removed from the scope of the analz operator.*)
lemma analz_keyfree_into_Un: "\<lbrakk>X \<in> analz (G \<union> H); G \<subseteq> keyfree\<rbrakk> \<Longrightarrow> X \<in> parts G \<union> analz H"
apply (erule analz.induct, auto dest: parts.Body)
apply (metis Un_absorb2 keyfree_KeyE parts_Un parts_keyfree UnI2)
done

subsection\<open>Tactics useful for many protocol proofs\<close>
ML
\<open>
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac ctxt [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac ctxt i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
   (Fake_insert_simp_tac ctxt 1 THEN
    IF_UNSOLVED
      (Blast.depth_tac
        (ctxt addIs [@{thm analz_insertI}, impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
         (Rule_Insts.res_inst_tac ctxt [((("x", 1), Position.none), "X")] []
           (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac ctxt [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
\<close>

text\<open>By default only \<open>o_apply\<close> is built-in.  But in the presence of
eta-expansion this means that some terms displayed as \<^term>\<open>f o g\<close> will be
rewritten, and others will not!\<close>
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G\<subseteq>H ==> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
by (metis Fake_analz_insert Un_absorb Un_absorb1 Un_commute
          subset_insertI synth_analz_mono synth_increasing synth_subset_iff)

text\<open>Two generalizations of \<open>analz_insert_eq\<close>\<close>
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H \<Longrightarrow> \<forall>G. H \<subseteq> G \<longrightarrow> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      \<Longrightarrow> \<forall>G. H \<subseteq> G \<longrightarrow> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
by (metis Fake_parts_insert empty_subsetI insert_mono parts_mono subset_trans)

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac)\<close>
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = \<open>
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac)\<close>
    "for debugging spy_analz"

method_setup Fake_insert_simp = \<open>
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac)\<close>
    "for debugging spy_analz"

end


section {* Relational operational semantics *}

theory utp_rel_opsem
  imports "../../Isabelle-UTP-Extended/AlgebraicLaws/Algebraic_Laws"
begin

text {* This theory uses the laws of relational calculus to create a basic operational semantics.
  It is based on Chapter 10 of the UTP book~\cite{Hoare&98}. *}

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:
  "(\<sigma>, x :== v) \<rightarrow>\<^sub>u (\<sigma>(x \<mapsto>\<^sub>s \<sigma> \<dagger> v), II)"
  by (simp add: assigns_comp usubst)

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\<^sub>\<bottom> b do P od) \<rightarrow>\<^sub>u (\<sigma>, P ;; while\<^sub>\<bottom> b do P od)"
  by (metis assms rcond_true_trel while_lfp_rel_unfold)

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

declare trel.simps [simp del]
end