(*File: VDM_OBJ.thy*)
(*Authors: Lennart Beringer and Martin Hofmann, LMU Munich 2008*)
theory VDM_OBJ imports OBJ begin

subsection\<open>Program logic\<close>

text\<open>\label{sec:ObjLogic}Apart from the addition of proof rules for the three new
instructions, this section is essentially identical to Section
\ref{sec:VDM}.\<close>

subsubsection \<open>Assertions and their semantic validity\<close>

text\<open>Assertions are binary state predicates, as before.\<close>

type_synonym "Assn" = "State \<Rightarrow> State \<Rightarrow> bool"

definition VDM_validn :: "nat \<Rightarrow> OBJ \<Rightarrow> Assn \<Rightarrow> bool"
                         (" \<Turnstile>\<^sub>_ _ : _ " 50)
where "(\<Turnstile>\<^sub>n c : A) = (\<forall> m . m \<le> n \<longrightarrow> (\<forall> s t . (s,c \<rightarrow>\<^sub>m t) \<longrightarrow> A s t))"

definition VDM_valid :: "OBJ \<Rightarrow> Assn \<Rightarrow> bool"
                         (" \<Turnstile> _ : _ " 50)
where "(\<Turnstile> c : A) = (\<forall> s t . (s,c \<Down> t) \<longrightarrow> A s t)"

lemma VDM_valid_validn: "\<Turnstile> c:A \<Longrightarrow> \<Turnstile>\<^sub>n c:A"
(*<*)
by (simp add: VDM_valid_def VDM_validn_def Sem_def, fastforce)
(*>*)

lemma VDM_validn_valid: "(\<forall> n . \<Turnstile>\<^sub>n c:A) \<Longrightarrow> \<Turnstile> c:A"
(*<*)
by (simp add: VDM_valid_def VDM_validn_def Sem_def, fastforce)
(*>*)

lemma VDM_lowerm: "\<lbrakk> \<Turnstile>\<^sub>n c:A; m < n \<rbrakk> \<Longrightarrow> \<Turnstile>\<^sub>m c:A"
(*<*)
apply (simp add: VDM_validn_def, clarsimp)
apply (erule_tac x="ma" in allE, simp)
done
(*>*)

definition Ctxt_validn :: "nat \<Rightarrow> (Assn set) \<Rightarrow> bool"
                       (" \<Turnstile>\<^sub>_ _  " 50)
where "(\<Turnstile>\<^sub>n G) = (\<forall> m . m \<le> n \<longrightarrow> (\<forall> A. A \<in> G \<longrightarrow> \<Turnstile>\<^sub>n Call : A))"

definition Ctxt_valid :: "Assn set \<Rightarrow> bool" (" \<Turnstile> _ " 50)
where "(\<Turnstile> G) = (\<forall> A . A \<in> G \<longrightarrow> \<Turnstile> Call : A)"

lemma Ctxt_valid_validn: "\<Turnstile> G \<Longrightarrow> \<Turnstile>\<^sub>n G"
(*<*)
apply (simp add: Ctxt_valid_def Ctxt_validn_def, clarsimp)
apply (rule VDM_valid_validn) apply fast
done
(*>*)

lemma Ctxt_lowerm: "\<lbrakk> \<Turnstile>\<^sub>n G; m < n \<rbrakk> \<Longrightarrow> \<Turnstile>\<^sub>m G"
(*<*)
apply (simp add: Ctxt_validn_def, clarsimp)
apply (rule VDM_lowerm) prefer 2 apply assumption apply fast
done
(*>*)

definition valid :: "(Assn set) \<Rightarrow> OBJ \<Rightarrow> Assn \<Rightarrow> bool"
                      ("_ \<Turnstile> _ : _ " 50)
where "(G \<Turnstile> c : A) = (Ctxt_valid G \<longrightarrow> VDM_valid c A)"

definition validn :: "(Assn set) \<Rightarrow> nat \<Rightarrow> OBJ \<Rightarrow> Assn \<Rightarrow> bool"
                     ("_ \<Turnstile>\<^sub>_ _ : _" 50)
where "(G \<Turnstile>\<^sub>n c : A) = (\<Turnstile>\<^sub>n G \<longrightarrow> \<Turnstile>\<^sub>n c : A)"

lemma validn_valid: "(\<forall> n . G \<Turnstile>\<^sub>n c : A) \<Longrightarrow> G \<Turnstile> c : A"
(*<*)
apply (simp add: valid_def validn_def, clarsimp)
apply (rule VDM_validn_valid, clarsimp)
apply (erule_tac x=n in allE, erule mp)
apply (erule Ctxt_valid_validn)
done
(*>*)

lemma ctxt_consn: "\<lbrakk> \<Turnstile>\<^sub>n G;  \<Turnstile>\<^sub>n Call:A \<rbrakk> \<Longrightarrow> \<Turnstile>\<^sub>n {A} \<union> G"
(*<*)
by (simp add: Ctxt_validn_def)
(*>*)

subsubsection\<open>Proof system\<close>

inductive_set VDM_proof :: "(Assn set \<times> OBJ \<times> Assn) set"
where
VDMSkip: "(G, Skip, \<lambda> s t . t=s):VDM_proof"

| VDMAssign:
  "(G, Assign x e,
       \<lambda> s t . t = (update (fst s) x (evalE e (fst s)), snd s)):VDM_proof"

| VDMNew:
  "(G, New x C,
       \<lambda> s t . \<exists> l . l \<notin> Dom (snd s) \<and>
                         t = (update (fst s) x (RVal (Loc l)),
                              (l,(C,[])) # (snd s))):VDM_proof"

| VDMGet:
  "(G, Get x y F,
       \<lambda> s t . \<exists> l C Flds v. (fst s) y = RVal(Loc l) \<and>
                         lookup (snd s) l = Some(C,Flds) \<and>
                         lookup Flds F = Some v \<and>
                         t = (update (fst s) x v, snd s)):VDM_proof"

| VDMPut:
  "(G, Put x F e,
       \<lambda> s t . \<exists> l C Flds. (fst s) x = RVal(Loc l) \<and>
                         lookup (snd s) l = Some(C,Flds) \<and>
                         t = (fst s,
                              (l,(C,(F,evalE e (fst s)) # Flds))
                                           # (snd s))):VDM_proof"

| VDMComp:
  "\<lbrakk> (G, c, A):VDM_proof; (G, d, B):VDM_proof\<rbrakk> \<Longrightarrow>
  (G, Comp c d, \<lambda> s t . \<exists> r . A s r \<and> B r t):VDM_proof"

| VDMIff:
  "\<lbrakk> (G, c, A):VDM_proof; (G, d, B):VDM_proof\<rbrakk> \<Longrightarrow>
  (G, Iff b c d,
     \<lambda> s t . (((evalB b (fst s)) \<longrightarrow> A s t) \<and>
                      ((\<not> (evalB b (fst s))) \<longrightarrow> B s t))):VDM_proof"
(*VDMWhile:  "\<lbrakk>\<rhd> c : (\<lambda> s t . (evalB b s \<longrightarrow> I s t)); Trans I; Refl I\<rbrakk>
            \<Longrightarrow> \<rhd> (While b c) : (\<lambda> s t . I s t \<and> \<not> (evalB b t))"*)

| VDMWhile:
  "\<lbrakk> (G,c,B):VDM_proof;
        \<forall> s . (\<not> evalB b (fst s)) \<longrightarrow> A s s;
        \<forall> s r t. evalB b (fst s) \<longrightarrow> B s r \<longrightarrow> A r t \<longrightarrow> A s t \<rbrakk>
 \<Longrightarrow> (G, While b c, \<lambda> s t . A s t \<and> \<not> (evalB b (fst t))):VDM_proof"

| VDMCall:
  "({A} \<union> G, body, A):VDM_proof \<Longrightarrow> (G, Call, A):VDM_proof"

| VDMAx: "A \<in> G \<Longrightarrow>  (G, Call, A):VDM_proof"

| VDMConseq:
  "\<lbrakk> (G, c,A):VDM_proof; \<forall> s t. A s t \<longrightarrow> B s t\<rbrakk> \<Longrightarrow>
  (G, c, B):VDM_proof"

abbreviation VDM_deriv :: "[Assn set, OBJ, Assn] \<Rightarrow> bool"
                   ("_ \<rhd> _ : _" [100,100] 50)
where "G \<rhd> c : A == (G,c,A) \<in> VDM_proof"

text\<open>The while-rule is in fact inter-derivable with the following rule.\<close>
lemma Hoare_While:
 "G \<rhd> c : (\<lambda> s t . \<forall> r . evalB b (fst s) \<longrightarrow> I s r \<longrightarrow> I t r) \<Longrightarrow>
  G \<rhd> While b c : (\<lambda> s t. \<forall> r . I s r \<longrightarrow> (I t r \<and> \<not> evalB b (fst t)))"
apply (subgoal_tac "G \<rhd> (While b c) :
           (\<lambda> s t . (\<lambda> s t . \<forall>r. I s r \<longrightarrow> I t r) s t \<and> \<not> (evalB b (fst t)))")
apply (erule VDMConseq)
apply simp
apply (rule VDMWhile) apply assumption apply simp apply simp
done

text\<open>Here's the proof in the opposite direction.\<close>

subsubsection\<open>Soundness\<close>
(*<*)
lemma MAX:"Suc (max k m) \<le> n \<Longrightarrow> k \<le> n \<and> m \<le> n"
by (simp add: max_def, case_tac "k \<le> m", simp+)
(*>*)

text\<open>The following auxiliary lemma for loops is proven by induction
on $n$.\<close>

lemma SoundWhile[rule_format]:
 "(\<forall>n. G \<Turnstile>\<^sub>n c : B)
    \<longrightarrow> (\<forall>s. (\<not> evalB b (fst s)) \<longrightarrow> A s s)
    \<longrightarrow> (\<forall>s. evalB b (fst s)
              \<longrightarrow> (\<forall>r. B s r \<longrightarrow> (\<forall>t. A r t \<longrightarrow> A s t)))
    \<longrightarrow> G \<Turnstile>\<^sub>n (While b c) : (\<lambda>s t. A s t \<and> \<not> evalB b (fst t))"
(*<*)
apply (induct n)
apply clarsimp apply (simp add: validn_def VDM_validn_def, clarsimp)
  apply (drule Sem_no_zero_height_derivs) apply simp
apply clarsimp apply (simp add: validn_def VDM_validn_def, clarsimp)
  apply (erule Sem_eval_cases)
  prefer 2 apply clarsimp
  apply clarsimp
   apply (erule_tac x=n in allE, erule impE) apply (erule Ctxt_lowerm) apply simp
   apply (rotate_tac -1)
   apply (erule_tac x=ma in allE, clarsimp)
   apply(erule impE) apply (erule Ctxt_lowerm) apply simp
   apply (erule_tac x=na in allE, clarsimp) apply fast
done
(*>*)

lemma SoundCall[rule_format]:
"\<lbrakk>\<forall>n. \<Turnstile>\<^sub>n ({A} \<union> G) \<longrightarrow> \<Turnstile>\<^sub>n body : A\<rbrakk> \<Longrightarrow> \<Turnstile>\<^sub>n G \<longrightarrow> \<Turnstile>\<^sub>n Call : A"
(*<*)
apply (induct_tac n)
apply (simp add: VDM_validn_def, clarsimp)
  apply (drule Sem_no_zero_height_derivs) apply simp
apply clarsimp
  apply (drule Ctxt_lowerm) apply (subgoal_tac "n < Suc n", assumption) apply simp apply clarsimp
  apply (drule ctxt_consn) apply assumption
  apply (simp add: VDM_validn_def, clarsimp)
  apply (erule Sem_eval_cases, clarsimp)
done
(*>*)

theorem VDM_Sound: "G \<rhd> c: A \<Longrightarrow> G \<Turnstile> c:A"
(*<*)
by (drule VDM_Sound_n, erule validn_valid)
(*>*)

text\<open>A simple corollary is soundness w.r.t.~an empty context.\<close>

lemma VDM_Sound_emptyCtxt:"{} \<rhd> c : A \<Longrightarrow>  \<Turnstile> c : A"
(*<*)
apply (drule VDM_Sound)
apply (simp add: valid_def, erule mp)
apply (simp add: Ctxt_valid_def)
done
(*>*)

subsubsection\<open>Derived rules\<close>

lemma WEAK[rule_format]:
  "G \<rhd> c : A \<Longrightarrow> (\<forall> H . G \<subseteq> H \<longrightarrow> H \<rhd> c :A)"
(*<*)
apply (erule VDM_proof.induct)
apply clarsimp apply (rule VDMSkip)
apply clarsimp apply (rule VDMAssign)
apply clarsimp apply (rule VDMNew)
apply (rule, rule) apply (rule VDMGet)
apply (rule, rule) apply (rule VDMPut)
apply (rule, rule) apply (rule VDMComp) apply (erule_tac x=H in allE, simp) apply (erule_tac x=H in allE, simp)
apply (rule,rule) apply (rule VDMIff)  apply (erule_tac x=H in allE, simp) apply (erule_tac x=H in allE, simp)
apply (rule,rule) apply (rule VDMWhile) apply (erule_tac x=H in allE, simp)  apply (assumption) apply simp
apply (rule,rule) apply (rule VDMCall) apply (erule_tac x="({A} \<union> H)" in allE, simp) apply fast
apply (rule,rule) apply (rule VDMAx) apply fast
apply (rule,rule) apply (rule VDMConseq) apply (erule_tac x=H in allE, clarsimp) apply assumption apply assumption
done
(*>*)

lemma CutAux:
 "(H \<rhd> c : A) \<Longrightarrow>
  (\<forall> G P D . (H = (insert P D) \<longrightarrow> G \<rhd> Call :P \<longrightarrow> (G \<subseteq> D)
             \<longrightarrow> D \<rhd> c:A))"
(*<*)
apply (erule VDM_proof.induct)
apply clarify
apply (fast intro: VDMSkip)
apply (fast intro: VDMAssign)
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (rule VDMNew)
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (rule VDMGet)
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (rule VDMPut)
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (erule_tac x=Ga in allE) apply (erule_tac x=Ga in allE)
  apply (erule_tac x=P in allE) apply (erule_tac x=P in allE)
  apply (erule_tac x=D in allE, erule impE, assumption)
  apply (erule_tac x=D in allE, erule impE, assumption)
  apply (rule VDMComp) apply simp apply simp
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (erule_tac x=Ga in allE) apply (erule_tac x=Ga in allE)
  apply (erule_tac x=P in allE) apply (erule_tac x=P in allE)
  apply (erule_tac x=D in allE, erule impE, assumption)
  apply (erule_tac x=D in allE, erule impE, assumption)
  apply (rule VDMIff) apply simp apply simp
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (erule_tac x=Ga in allE)
  apply (erule_tac x=P in allE)
  apply (erule_tac x=D in allE, erule impE, assumption)
  apply (rule VDMWhile) apply simp apply simp
  apply simp
apply (rule, rule, rule)
  apply (rule, rule, rule)
  apply (erule_tac x=Ga in allE)
  apply (erule_tac x=P in allE)
  apply (erule_tac x="insert A D" in allE, erule impE, simp)
  apply (rule VDMCall) apply fastforce
apply clarsimp
  apply (erule disjE)
  apply clarsimp apply (erule WEAK) apply assumption
  apply (erule VDMAx)
apply clarsimp
apply (subgoal_tac "D \<rhd>  c : A")
apply (erule VDMConseq) apply simp
  apply simp
done
(*>*)

lemma Cut:"\<lbrakk> G \<rhd> Call : P ; (insert P G) \<rhd> c : A \<rbrakk> \<Longrightarrow> G \<rhd> c : A"
(*<*)by (drule CutAux , simp)(*>*)

definition verified::"Assn set \<Rightarrow> bool"
where "verified G = (\<forall> A . A:G \<longrightarrow> G \<rhd> body : A)"

lemma verified_preserved: "\<lbrakk>verified G; A:G\<rbrakk> \<Longrightarrow> verified (G - {A})"
(*<*)
apply (simp add: verified_def, (rule allI)+, rule)
apply (subgoal_tac "(G - {A}) \<rhd> Call:A")
(*now use the subgoal (G - {A}) \<rhd> Call:A to prove the goal*)
apply (subgoal_tac "G = insert A (G - {A})") prefer 2 apply fast
apply (erule_tac x=Aa in allE)
apply (erule impE, simp)
apply (erule Cut)  apply simp
(* now prove the subgoal (G - {A}) \<rhd>  Call : A *)
  apply (erule_tac x=A in allE, clarsimp)
  apply (rule VDMCall) apply simp apply (erule WEAK) apply fast
done
(*>*)

(*<*)
lemma SetNonSingleton:
  "\<lbrakk>G \<noteq> {A}; A \<in> G\<rbrakk> \<Longrightarrow> \<exists>B. B \<noteq> A \<and> B \<in> G"
by auto

theorem Mutrec:
"\<lbrakk> finite G; card G = n; verified G; A : G \<rbrakk> \<Longrightarrow> {} \<rhd> Call:A"
(*<*)
by (rule MutrecAux, fast)
(*>*)

subsubsection\<open>Completeness\<close>
definition SSpec::"OBJ \<Rightarrow> Assn"
where "SSpec c s t = (s,c \<Down> t)"

lemma SSpec_valid: "\<Turnstile> c : (SSpec c)"
(*<*)by (simp add: VDM_valid_def SSpec_def)(*>*)

lemma SSpec_strong: "\<Turnstile> c :A \<Longrightarrow> \<forall> s t . SSpec c s t \<longrightarrow> A s t"
(*<*)by (simp add: VDM_valid_def SSpec_def)(*>*)

lemma SSpec_derivable:"G \<rhd> Call : SSpec Call \<Longrightarrow> G \<rhd> c : SSpec c"
(*<*)
apply (induct c)
  apply (rule VDMConseq)
  apply (rule VDMSkip) apply (simp add: SSpec_def Sem_def, rule, rule, rule) apply (rule SemSkip) apply simp
  apply (rule VDMConseq)
  apply (rule VDMAssign) apply (simp add: SSpec_def Sem_def, rule, rule, rule) apply (rule SemAssign) apply simp
  apply (rule VDMConseq)
  apply (rule VDMNew) apply (simp only: SSpec_def Sem_def, rule, rule, rule, rule)
    apply (erule exE, erule conjE)
    apply (rule SemNew) apply assumption apply assumption
  apply (rule VDMConseq)
  apply (rule VDMGet) apply (simp only: SSpec_def Sem_def, rule, rule, rule, rule)
    apply (erule exE)+
    apply (erule conjE)+
    apply (rule SemGet) apply assumption apply assumption apply assumption apply assumption
  apply (rule VDMConseq)
  apply (rule VDMPut) apply (simp only: SSpec_def Sem_def, rule, rule, rule, rule)
    apply (erule exE)+
    apply (erule conjE)+
    apply (rule SemPut) apply assumption apply assumption apply assumption
apply clarsimp
  apply (rule VDMConseq)
  apply (rule VDMComp) apply assumption+ apply (simp add: SSpec_def Sem_def, clarsimp)
  apply rule apply (rule SemComp) apply assumption+ apply simp
apply clarsimp
apply (rule VDMConseq)
  apply (erule VDMWhile)
    prefer 3
    apply (rename_tac BExpr c)
    apply (subgoal_tac "\<forall>s t. SSpec (While BExpr c) s t \<and> \<not> evalB BExpr (fst t) \<longrightarrow> SSpec (While BExpr c) s t", assumption)
    apply simp
    apply (simp only: SSpec_def Sem_def) apply (rule, rule, rule) apply (erule SemWhileF) apply simp
    apply (simp only: SSpec_def Sem_def) apply (rule, rule, rule)
      apply (rule, rule, rule) apply (erule exE)+ apply (rule, erule SemWhileT) apply assumption+ apply simp
apply clarsimp
apply (rule VDMConseq)
  apply (rule VDMIff) apply assumption+ apply (simp only: SSpec_def Sem_def)
  apply (erule thin_rl, erule thin_rl)
  apply (rule, rule, rule)
  apply (erule conjE)
  apply (rename_tac BExpr c1 c2 s t)
  apply (case_tac "evalB BExpr (fst s)")
  apply (erule impE, assumption) apply (erule exE) apply (rule, rule SemTrue) apply assumption+
  apply (rotate_tac 2, erule impE, assumption) apply (erule exE) apply (rule, rule SemFalse) apply assumption+
done
(*>*)

definition StrongG :: "Assn set"
where "StrongG = {SSpec Call}"

lemma StrongG_Body: "StrongG \<rhd> body : SSpec Call"
(*<*)
apply (subgoal_tac "StrongG \<rhd> body : SSpec body")
  apply (erule VDMConseq) apply (simp add: SSpec_def Sem_def, clarsimp)
  apply (rule, erule SemCall)
apply (rule SSpec_derivable) apply (rule VDMAx) apply (simp add: StrongG_def)
done
(*>*)

lemma StrongG_verified: "verified StrongG"
(*<*)
apply (simp add: verified_def)
apply (rule allI)+
apply rule
apply (subgoal_tac "StrongG \<rhd> body : SSpec Call")
apply (simp add: StrongG_def)
apply (rule StrongG_Body)
done
(*>*)

lemma SSpec_derivable_empty:"{} \<rhd> c : SSpec c"
(*<*)
apply (rule Cut)
apply (rule Mutrec) apply (subgoal_tac "finite StrongG", assumption)
  apply (simp add: StrongG_def)
  apply (simp add: StrongG_def)
  apply (rule StrongG_verified)
  apply (simp add: StrongG_def)
  apply (rule SSpec_derivable) apply (rule VDMAx) apply simp
done
(*>*)

theorem VDM_Complete: "\<Turnstile> c : A \<Longrightarrow> {} \<rhd> c : A"
(*<*)
apply (rule VDMConseq)
apply (rule SSpec_derivable_empty)
apply (erule SSpec_strong)
done
(*>*)

(*<*)

lemma Ctxt_valid_verified: "\<Turnstile> G \<Longrightarrow> verified G"
(*<*)
apply (simp add: Ctxt_valid_def verified_def, clarsimp)
apply (erule_tac x=A in allE, simp)
apply (subgoal_tac "\<Turnstile> body : A")
apply (rotate_tac 1, erule thin_rl, drule VDM_Complete) apply (erule WEAK) apply fast
apply (simp only: VDM_valid_def Sem_def)
apply (rule, rule, rule)
apply (erule exE)
apply (erule_tac x=s in allE, erule_tac x=t in allE, erule mp)
apply (rule, erule SemCall)
done
(*>*)

lemma Ctxt_verified_valid: "\<lbrakk>verified G; finite G\<rbrakk> \<Longrightarrow> \<Turnstile> G"
(*<*)
apply (subgoal_tac "(\<forall> A . A:G \<longrightarrow> G \<rhd> body : A)")
prefer 2 apply (simp add: verified_def)
apply (simp add: Ctxt_valid_def, clarsimp)
apply (erule_tac x=A in allE, simp)
apply (rule VDM_Sound_emptyCtxt)
apply (rule Mutrec, assumption)
  apply (insert card_def) apply fast
  apply assumption
  apply assumption
done
(*>*)

text\<open>End of theory VDM_Obj\<close>
end


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

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

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

********************************************************************************

  Edited:  Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Integrated and adapted for security protocol refinement and to add a constructor for finite sets.

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

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

theory Message imports Keys "HOL-Library.Sublist" "HOL.Finite_Set" "HOL-Library.FSet"
begin

datatype msgterm =
    \<epsilon>                                  \<comment> \<open>Empty message. Used for instance to denote non-existent interface\<close>
  | AS as                              \<comment> \<open>Autonomous System identifier, i.e. agents. Note that AS is an alias of nat\<close>
  | Num nat                            \<comment> \<open>Ordinary integers, timestamps, ...\<close>
  | Key    key                         \<comment> \<open>Crypto keys\<close>
  | Nonce  nonce                       \<comment> \<open>Unguessable nonces\<close>
  | L      "msgterm list"              \<comment> \<open>Lists\<close>
  | FS     "msgterm fset"              \<comment> \<open>Finite Sets. Used to represent XOR values.\<close>
  | MPair  msgterm msgterm             \<comment> \<open>Compound messages\<close>
  | Hash    msgterm                    \<comment> \<open>Hashing\<close>
  | Crypt  key msgterm                 \<comment> \<open>Encryption, public- or shared-key\<close>

text \<open>Syntax sugar\<close>
syntax
  "_MTuple" :: "['a, args] \<Rightarrow> 'a * 'b"       ("(2\<langle>_,/ _\<rangle>)")

syntax (xsymbols)
  "_MTuple" :: "['a, args] \<Rightarrow> 'a * 'b"       ("(2\<langle>_,/ _\<rangle>)")

translations
  "\<langle>x, y, z\<rangle>" \<rightleftharpoons> "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
  "\<langle>x, y\<rangle>"    \<rightleftharpoons> "CONST MPair x y"

syntax
  "_MHF" :: "['a, 'b , 'c, 'd, 'e] \<Rightarrow> 'a * 'b * 'c * 'd * 'e"  ("(5HF\<lhd>_,/ _,/ _,/ _,/ _\<rhd>)")

abbreviation
  Mac :: "[msgterm,msgterm] \<Rightarrow> msgterm"                       ("(4Mac[_] /_)" [0, 1000])
where
  \<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
  "Mac[X] Y \<equiv> Hash \<langle>X,Y\<rangle>"

abbreviation macKey where "macKey a \<equiv> Key (macK a)"

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

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

inductive_set
  parts :: "msgterm set \<Rightarrow> msgterm set"
  for H :: "msgterm set"
  where
    Inj [intro]: "X \<in> H \<Longrightarrow> X \<in> parts H"
  | Fst:         "\<langle>X,_\<rangle> \<in> parts H \<Longrightarrow> X \<in> parts H"
  | Snd:         "\<langle>_,Y\<rangle> \<in> parts H \<Longrightarrow> Y \<in> parts H"
  | Lst:         "\<lbrakk> L xs \<in> parts H; X \<in> set xs \<rbrakk> \<Longrightarrow> X \<in> parts H"
  | FSt:          "\<lbrakk> FS xs \<in> parts H; X |\<in>| xs \<rbrakk> \<Longrightarrow> X \<in> parts H"
(*| Hd:          "L (X # xs) \<in> parts H \<Longrightarrow> X \<in> parts H"
  | Tl:          "L (X # xs) \<in> parts H \<Longrightarrow> L xs \<in> parts H" *)
  | Body:        "Crypt K X \<in> parts H \<Longrightarrow> X \<in> parts H"

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

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

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

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

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

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 \<Longrightarrow> keysFor G \<subseteq> keysFor H"
by (unfold keysFor_def, blast)

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

lemma keysFor_insert_Num [simp]: "keysFor (insert (Num 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_Nonce [simp]: "keysFor (insert (Nonce n) H) = keysFor H"
by (unfold keysFor_def, auto)

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

lemma keysFor_insert_FS [simp]: "keysFor (insert (FS X) 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 \<langle>X,Y\<rangle> 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 \<Longrightarrow> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

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

lemma MPair_parts:
  "\<lbrakk>
    \<langle>X,Y\<rangle> \<in> parts H;
    \<lbrakk> X \<in> parts H; Y \<in> parts H \<rbrakk> \<Longrightarrow> P
   \<rbrakk> \<Longrightarrow> P"
by (blast dest: parts.Fst parts.Snd)

lemma L_parts:
  "\<lbrakk>
    L l \<in> parts H;
    \<lbrakk> set l \<subseteq> parts H \<rbrakk> \<Longrightarrow> P
   \<rbrakk> \<Longrightarrow> P"
  by (blast dest: parts.Lst)

lemma FS_parts:
  "\<lbrakk>
    FS l \<in> parts H;
    \<lbrakk> fset l \<subseteq> parts H \<rbrakk> \<Longrightarrow> P
   \<rbrakk> \<Longrightarrow> P"
  by (simp add: fmember_iff_member_fset parts.FSt subsetI)
thm fmember_iff_member_fset parts.FSt subsetI

declare fmember_iff_member_fset[simp]
declare MPair_parts [elim!] L_parts [elim!] FS_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.
        @{text MPair_parts} 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{} \<Longrightarrow> P"
by simp

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

lemma parts_singleton_set: "x \<in> parts {s . P s} \<Longrightarrow> \<exists>Y. P Y \<and> x \<in> parts {Y}"
  by(auto dest: parts_singleton)

lemma parts_singleton_set_rev: "\<lbrakk>x \<in> parts {Y}; P Y\<rbrakk> \<Longrightarrow> x \<in> parts {s . P s}"
  by (induction rule: parts.induct)
     (blast dest: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)+

lemma parts_Hash: "\<lbrakk>\<And>t . t \<in> H \<Longrightarrow> \<exists>t' . t = Hash t'\<rbrakk> \<Longrightarrow> parts H = H"
  by (auto, 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+)
  using parts.FSt by auto

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"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

text \<open>TWO inserts to avoid looping.  This rewrite is better than nothing.
        Not suitable for Addsimps: its behaviour can be strange.\<close>
lemma parts_insert2:
  "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done

(*needed?!*)
lemma parts_two: "\<lbrakk>x \<in> parts {e1, e2}; x \<notin> parts {e1}\<rbrakk>\<Longrightarrow> x \<in> parts {e2}"
  by (simp add: parts_insert2)

text \<open>Added to simplify arguments to parts, analz and synth.\<close>

text \<open>This allows @{text blast} to simplify occurrences of
        @{term "parts(G\<union>H)"} 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\<close>

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

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)"
apply (rule iffI)
apply (iprover intro: subset_trans parts_increasing)
apply (frule parts_mono, simp)
done

subsubsection \<open>Transitivity\<close>
lemma parts_trans: "\<lbrakk> X\<in> parts G;  G \<subseteq> parts H \<rbrakk> \<Longrightarrow> X\<in> parts H"
by (drule parts_mono, blast)

subsubsection \<open>Unions, revisited\<close>
text \<open>You can take the union of parts h for all h in H\<close>
lemma parts_split: "parts H = \<Union> { parts {h} | h . h \<in> H}"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)+
using parts_trans apply blast
done

text \<open>Cut\<close>
lemma parts_cut:
  "\<lbrakk> Y\<in> parts (insert X G);  X \<in> parts H \<rbrakk> \<Longrightarrow> Y \<in> parts (G \<union> H)"
by (blast intro: parts_trans)

lemma parts_cut_eq [simp]: "X \<in> parts H \<Longrightarrow> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

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

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_AS [simp]:
  "parts (insert (AS agt) H) = insert (AS agt) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto elim!: FS_parts)

lemma parts_insert_Epsilon [simp]:
  "parts (insert \<epsilon> H) = insert \<epsilon> (parts H)"
apply (rule parts_insert_eq_I)
  by (erule parts.induct, auto)

lemma parts_insert_Num [simp]:
  "parts (insert (Num N) H) = insert (Num N) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto)

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

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

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

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)
by (blast intro: parts.Body)

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

lemma parts_insert_L [simp]:
  "parts (insert (L xs) H) =
    insert (L xs) (parts ((set xs) \<union>  H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
by (blast intro: parts.Lst)+

lemma parts_insert_FS [simp]:
  "parts (insert (FS xs) H) =
    insert (FS xs) (parts ((fset xs) \<union>  H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
by (auto intro: parts.FSt)+

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

text \<open>Parts of lists and finite sets.\<close>

lemma parts_list_set (*[simp]*):
  "parts (L`ls) =  (L`ls) \<union> (\<Union>l \<in> ls. parts (set l)) "
apply (rule equalityI, rule subsetI)
apply (erule parts.induct, auto)
by (meson L_parts image_subset_iff parts_increasing parts_trans)

lemma parts_insert_list_set (*[simp]*):
  "parts ((L`ls) \<union> H) =  (L`ls) \<union> (\<Union>l \<in> ls. parts ((set l))) \<union> parts H"
apply (rule equalityI, rule subsetI)
by (erule parts.induct, auto simp add: parts_list_set)

(*needed?!*)
lemma parts_fset_set (*[simp]*):
  "parts (FS`ls) =  (FS`ls) \<union> (\<Union>l \<in> ls. parts (fset l)) "
apply (rule equalityI, rule subsetI)
apply (erule parts.induct, auto)
by (meson FS_parts image_subset_iff parts_increasing parts_trans)

subsubsection \<open>suffix of parts\<close>
lemma suffix_in_parts:
  "suffix (x#xs) ys \<Longrightarrow> x \<in> parts {L ys}"
by (auto simp add: suffix_def)

lemma parts_L_set:
  "\<lbrakk>x \<in> parts {L ys}; ys \<in> St\<rbrakk> \<Longrightarrow> x \<in> parts (L`St)"
by (metis (no_types, lifting) image_insert insert_iff mk_disjoint_insert parts.Inj
    parts_cut_eq parts_insert parts_insert2)

lemma suffix_in_parts_set:
  "\<lbrakk>suffix (x#xs) ys; ys \<in> St\<rbrakk> \<Longrightarrow> x \<in> parts (L`St)"
using parts_L_set suffix_in_parts
by blast

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 :: "msgterm set \<Rightarrow> msgterm set"
  for H :: "msgterm set"
  where
    Inj [intro,simp] : "X \<in> H \<Longrightarrow> X \<in> analz H"
  | Fst:               "\<langle>X,Y\<rangle> \<in> analz H \<Longrightarrow> X \<in> analz H"
  | Snd:               "\<langle>X,Y\<rangle> \<in> analz H \<Longrightarrow> Y \<in> analz H"
  | Lst:               "(L y) \<in> analz H  \<Longrightarrow> x \<in> set (y) \<Longrightarrow> x \<in> analz H "
  | FSt:               "\<lbrakk> FS xs \<in> analz H; X |\<in>| xs \<rbrakk> \<Longrightarrow> X \<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 \<Longrightarrow> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd analz.Lst analz.FSt )
done

lemmas analz_monotonic = analz_mono [THEN [2] rev_subsetD]

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

lemma L_analz [elim!]:
  "\<lbrakk>
    L l \<in> analz H;
    \<lbrakk> set l \<subseteq> analz H \<rbrakk> \<Longrightarrow> P
   \<rbrakk> \<Longrightarrow> P"
by (blast dest: analz.Lst analz.FSt)

lemma FS_analz [elim!]:
  "\<lbrakk>
    FS l \<in> analz H;
    \<lbrakk> fset l \<subseteq> analz H \<rbrakk> \<Longrightarrow> P
   \<rbrakk> \<Longrightarrow> P"
  by (simp add: fmember_iff_member_fset analz.FSt subsetI)

thm fmember_iff_member_fset parts.FSt subsetI
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+)
  apply auto
done

text \<open>If there is no cryptography, then analz and parts is equivalent.\<close>
lemma no_crypt_analz_is_parts:
  "\<not> (\<exists> K X . Crypt K X \<in> parts A) \<Longrightarrow> analz A = parts A"
apply (rule equalityI, simp add: analz_subset_parts)
apply (rule subsetI)
by (erule parts.induct, blast+, auto)

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"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done

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_AS [simp]:
  "analz (insert (AS agt) H) = insert (AS agt) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)

lemma analz_insert_Num [simp]:
  "analz (insert (Num N) H) = insert (Num N) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)

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) \<Longrightarrow>
    analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)

lemma analz_insert_LEmpty [simp]:
  "analz (insert (L []) H) = insert (L []) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)

lemma analz_insert_L [simp]:
  "analz (insert (L l) H) = insert (L l) (analz (set l \<union> H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct, auto)
using analz.Inj by blast

lemma analz_insert_FS [simp]:
  "analz (insert (FS l) H) = insert (FS l) (analz (fset l \<union> H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct, auto)
using analz.Inj by blast

lemma "L[] \<in> analz {L[L[]]}"
using analz.Inj by simp

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

lemma analz_insert_MPair [simp]:
  "analz (insert \<langle>X,Y\<rangle> H) =
    insert \<langle>X,Y\<rangle> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct, auto)
using Fst Snd analz.Inj insertI1
by (metis)+

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

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

lemma analz_insert_Decrypt2:
  "Key (invKey K) \<in> analz H \<Longrightarrow>
    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)
by (blast intro: analz_insertI analz.Decrypt)

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

text \<open>Case analysis: either the message is secure, or it is not! Effective,
        but can cause subgoals to blow up! Use with @{text "split_if"}; apparently
        @{text "split_tac"} does not cope with patterns such as @{term"analz (insert
        (Crypt K X) H)"}\<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)
by (erule analz.induct, auto)

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) \<Longrightarrow> X\<in> analz H"
by (erule analz.induct, auto)

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)"
apply (rule iffI)
apply (iprover intro: subset_trans analz_increasing)
apply (frule analz_mono, simp)
done

lemma analz_trans: "\<lbrakk> X\<in> analz G;  G \<subseteq> analz H \<rbrakk> \<Longrightarrow> X\<in> analz H"
by (drule analz_mono, blast)

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

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) \<Longrightarrow> X: analz H --> 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 \<Longrightarrow> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

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

lemma analz_subset_cong:
  "\<lbrakk> analz G \<subseteq> analz G'; analz H \<subseteq> analz H' \<rbrakk>
    \<Longrightarrow> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (iprover intro: conjI subset_trans analz_mono Un_upper1 Un_upper2)
done

lemma analz_cong:
  "\<lbrakk> analz G = analz G'; analz H = analz H' \<rbrakk>
    \<Longrightarrow> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

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

text \<open>If there are no pairs, lists or encryptions then analz does nothing\<close>
(*needed?*)
lemma analz_trivial:
  "\<lbrakk>
    \<forall>X Y. \<langle>X,Y\<rangle> \<notin> H; \<forall>xs. L xs \<notin> H; \<forall>xs. FS xs \<notin> H;
    \<forall>X K. Crypt K X \<notin> H
   \<rbrakk> \<Longrightarrow> analz H = H"
apply safe
by (erule analz.induct, auto)

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)) \<Longrightarrow> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
by (auto intro: analz_mono [THEN [2] rev_subsetD])

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])

subsubsection \<open>Lemmas assuming absense of keys\<close>
text \<open>If there are no keys in analz H, you can take the union of analz h for all h in H\<close>

lemma analz_split:
  "\<not>(\<exists> K . Key K \<in> analz H)
    \<Longrightarrow> analz H = \<Union> { analz {h} | h . h \<in> H}"
apply auto
subgoal
  apply (erule analz.induct)
  apply (auto dest: analz.Fst analz.Snd analz.Lst analz.FSt)
done
  apply (erule analz.induct)
  apply (auto dest: analz.Fst analz.Snd analz.Lst analz.FSt)
done

lemma analz_Un_eq:
  assumes "\<not>(\<exists> K . Key K \<in> analz H)" and "\<not>(\<exists> K . Key K \<in> analz G)"
  shows "analz (H \<union> G) = analz H \<union> analz G"
apply (intro equalityI, rule subsetI)
apply (erule analz.induct)
using assms by auto

lemma analz_Un_eq_Crypt:
  assumes "\<not>(\<exists> K . Key K \<in> analz G)" and "\<not>(\<exists> K X . Crypt K X \<in> analz G)"
  shows "analz (H \<union> G) = analz H \<union> analz G"
apply (intro equalityI, rule subsetI)
apply (erule analz.induct)
using assms by auto

lemma analz_list_set (*[simp]*):
  "\<not>(\<exists> K . Key K \<in> analz (L`ls))
    \<Longrightarrow> analz (L`ls) =  (L`ls) \<union> (\<Union>l \<in> ls. analz (set l)) "
apply (rule equalityI, rule subsetI)
apply (erule analz.induct, auto)
using L_analz image_subset_iff analz_increasing analz_trans by metis

lemma analz_fset_set (*[simp]*):
  "\<not>(\<exists> K . Key K \<in> analz (FS`ls))
    \<Longrightarrow> analz (FS`ls) =  (FS`ls) \<union> (\<Union>l \<in> ls. analz (fset l)) "
apply (rule equalityI, rule subsetI)
apply (erule analz.induct, auto)
using FS_analz image_subset_iff analz_increasing analz_trans by metis

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.  AS names are public domain.
        Nums can be guessed, but Nonces cannot be.\<close>

inductive_set
  synth :: "msgterm set \<Rightarrow> msgterm set"
  for H :: "msgterm set"
  where
    Inj    [intro]:   "X \<in> H \<Longrightarrow> X \<in> synth H"
  | \<epsilon>  [simp,intro!]:   "\<epsilon> \<in> synth H"
  | AS  [simp,intro!]:   "AS agt \<in> synth H"
  | Num [simp,intro!]:   "Num n  \<in> synth H"
  | Lst [intro]:      "\<lbrakk> \<And>x . x \<in> set xs \<Longrightarrow> x \<in> synth H \<rbrakk> \<Longrightarrow> L xs \<in> synth H"
  | FSt [intro]:      "\<lbrakk> \<And>x . x \<in> fset xs \<Longrightarrow> x \<in> synth H;
                         \<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys \<rbrakk>
                      \<Longrightarrow> FS xs \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H \<Longrightarrow> Hash X \<in> synth H"
  | MPair  [intro]:   "\<lbrakk> X \<in> synth H;  Y \<in> synth H \<rbrakk> \<Longrightarrow> \<langle>X,Y\<rangle> \<in> synth H"
  | Crypt  [intro]:   "\<lbrakk> X \<in> synth H;  Key K \<in> H \<rbrakk> \<Longrightarrow> Crypt K X \<in> synth H"

(*removed fcard xs \<noteq> Suc 0 from FSt premise*)

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

text \<open>NO @{text AS_synth}, as any AS name can be synthesized.
        The same holds for @{term Num}\<close>
inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Hash_synth  [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<langle>X,Y\<rangle> \<in> synth H"
inductive_cases L_synth     [elim!]: "L X \<in> synth H"
inductive_cases FS_synth    [elim!]: "FS X \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"

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

lemma synth_analz_self: "x \<in> H \<Longrightarrow> x \<in> synth (analz 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) \<Longrightarrow> X \<in> synth H"
apply (erule synth.induct, blast)
apply auto by blast

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

lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
apply (rule iffI)
apply (iprover intro: subset_trans synth_increasing)
apply (frule synth_mono, simp add: synth_idem)
done

lemma synth_trans: "\<lbrakk> X\<in> synth G;  G \<subseteq> synth H \<rbrakk> \<Longrightarrow> X\<in> synth H"
by (drule synth_mono, blast)

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

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]:
  "Key K \<notin> H \<Longrightarrow> (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)

lemma L_cons_synth [simp]:
  "(set xs \<subseteq> H) \<Longrightarrow> (L xs \<in> synth H)"
by auto

lemma FS_cons_synth [simp]:
  "\<lbrakk>fset xs \<subseteq> H; \<And>x ys. x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys; fcard xs \<noteq> Suc 0 \<rbrakk> \<Longrightarrow> (FS xs \<in> synth H)"
by auto

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

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
proof (safe del: UnCI)
  fix X
  assume "X \<in> parts (synth H)"
  thus "X \<in> parts H \<union> synth H"
  by (induct rule: parts.induct)
     (auto intro: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)
next
  fix X
  assume "X \<in> parts H"
  thus "X \<in> parts (synth H)"
  by (induction rule: parts.induct)
     (auto intro: parts.Fst parts.Snd  parts.Lst parts.FSt parts.Body)
next
  fix X
  assume "X \<in> synth H"
  thus "X \<in> parts (synth H)"
    apply (induction rule: synth.induct)
    apply(auto intro: parts.Fst parts.Snd  parts.Lst parts.FSt parts.Body)
    by blast
qed

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"
proof (safe del: UnCI)
  fix X
  assume "X \<in> analz (synth G \<union> H)"
  thus "X \<in> analz (G \<union> H) \<union> synth G"
  by (induction rule: analz.induct)
     (auto intro: analz.Fst analz.Snd analz.Lst analz.FSt analz.Decrypt)
qed (auto elim: analz_mono [THEN [2] rev_subsetD])

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done

lemma analz_Un_analz [simp]: "analz (G \<union> analz H) = analz (G \<union> H)"
by (subst Un_commute, auto)+

lemma analz_synth_Un2 [simp]: "analz (G \<union> synth H) = analz (G \<union> H) \<union> synth H"
by (subst Un_commute, auto)+

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

lemma parts_insert_subset_Un: "X\<in> G \<Longrightarrow> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (rule subset_trans [OF parts_mono parts_Un_subset2], blast)

text \<open>More specifically for Fake.  Very occasionally we could do with a version
  of the form  @{term"parts{X} \<subseteq> synth (analz H) \<union> parts H"}\<close>
lemma Fake_parts_insert:
  "X \<in> synth (analz H) \<Longrightarrow>
    parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done

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 (blast dest: Fake_parts_insert  [THEN subsetD, dest])

text \<open>@{term H} is sometimes @{term"Key ` KK \<union> spies evs"}, so can't put @{term "G=H"}.\<close>
lemma Fake_analz_insert:
  "X\<in> synth (analz G) \<Longrightarrow>
    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) ")
prefer 2
  apply (blast intro: analz_mono [THEN [2] rev_subsetD]
                      analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
apply (simp (no_asm_use))
apply blast
done

lemma analz_conj_parts [simp]:
  "(X \<in> analz H & 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]:
  "(\<langle>X,Y\<rangle> \<in> synth (analz H)) =
    (X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast

lemma L_cons_synth_analz [iff]:
  "(L xs \<in> synth (analz H)) =
    (set xs \<subseteq> synth (analz H))"
by blast

lemma L_cons_synth_parts [iff]:
  "(L xs \<in> synth (parts H)) =
    (set xs \<subseteq> synth (parts H))"
by blast

lemma FS_cons_synth_analz [iff]:
  "\<lbrakk>\<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys; fcard xs \<noteq> Suc 0 \<rbrakk> \<Longrightarrow>
    (FS xs \<in> synth (analz H)) =
    (fset xs \<subseteq> synth (analz H))"
by blast

lemma FS_cons_synth_parts [iff]:
  "\<lbrakk>\<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys; fcard xs \<noteq> Suc 0 \<rbrakk> \<Longrightarrow>
    (FS xs \<in> synth (parts H)) =
    (fset xs \<subseteq> synth (parts H))"
by blast

lemma Crypt_synth_analz:
  "\<lbrakk> Key K \<in> analz H;  Key (invKey K) \<in> analz H \<rbrakk>
    \<Longrightarrow> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

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

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

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 @{text analz_insert} rules\<close>

(*needed?*)
lemmas pushKeys =
  insert_commute [of "Key K" "AS C" for K C]
  insert_commute [of "Key K" "Nonce N" for K N]
  insert_commute [of "Key K" "Num N" for K N]
  insert_commute [of "Key K" "Hash X" for K X]
  insert_commute [of "Key K" "MPair X Y" for K X Y]
  insert_commute [of "Key K" "Crypt X K'" for K K' X]

(*needed?*)
lemmas pushCrypts =
  insert_commute [of "Crypt X K" "AS C" for X K C]
  insert_commute [of "Crypt X K" "AS C" for X K C]
  insert_commute [of "Crypt X K" "Nonce N" for X K N]
  insert_commute [of "Crypt X K" "Num N"  for X K N]
  insert_commute [of "Crypt X K" "Hash X'"  for X K X']
  insert_commute [of "Crypt X K" "MPair X' Y"  for X K X' Y]

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

text \<open>By default only @{text o_apply} is built-in.  But in the presence of
        eta-expansion this means that some terms displayed as @{term "f o g"} 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 \<Longrightarrow> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)

lemma synth_parts_mono: "G\<subseteq>H \<Longrightarrow> synth (parts G) \<subseteq> synth (parts H)"
by (iprover intro: synth_mono parts_mono)

lemma Fake_analz_eq [simp]:
  "X \<in> synth(analz H) \<Longrightarrow> synth (analz (insert X H)) = synth (analz H)"
apply (drule Fake_analz_insert[of _ _ "H"])
apply (simp add: synth_increasing[THEN Un_absorb2])
apply (drule synth_mono)
apply (simp add: synth_idem)
apply (rule equalityI)
apply (simp add: )
apply (rule synth_analz_mono, blast)
done

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

lemma Fake_parts_sing:
  "X \<in> synth (analz H) \<Longrightarrow> parts{X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
 apply (erule_tac [2] Fake_parts_insert)
apply (rule parts_mono, blast)
done

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

text \<open>For some reason, moving this up can make some proofs loop!\<close>
declare invKey_K [simp]

lemma synth_analz_insert:
  assumes "analz H \<subseteq> synth (analz H')"
  shows "analz (insert X H) \<subseteq> synth (analz (insert X H'))"
proof
  fix x
  assume "x \<in> analz (insert X H)"
  then have "x \<in> analz (insert X (synth (analz H')))"
    using assms by (meson analz_increasing analz_monotonic insert_mono)
  then show "x \<in> synth (analz (insert X H'))"
    by (metis (no_types) Un_iff analz_idem analz_insert analz_monotonic analz_synth synth.Inj
        synth_insert synth_mono)
qed

lemma synth_parts_insert:
  assumes "parts H \<subseteq> synth (parts H')"
  shows "parts (insert X H) \<subseteq> synth (parts (insert X H'))"
proof
  fix x
  assume "x \<in> parts (insert X H)"
  then have "x \<in> parts (insert X (synth (parts H')))"
    using assms parts_increasing
    by (metis UnE UnI1 analz_monotonic analz_parts parts_insert parts_insertI)
  then show "x \<in> synth (parts (insert X H'))"
  using Un_iff parts_idem parts_insert parts_synth synth.Inj
  by (metis Un_subset_iff synth_increasing synth_trans)
qed

lemma parts_insert_subset_impl:
  "\<lbrakk>x \<in> parts (insert a G); x \<in> parts G \<Longrightarrow> x \<in> synth (parts H); a \<in> synth (parts H)\<rbrakk>
    \<Longrightarrow> x \<in> synth (parts H)"
using Fake_parts_sing in_parts_UnE insert_is_Un
          parts_idem parts_synth subsetCE sup.absorb2 synth_idem synth_increasing
by (metis (no_types, lifting) analz_parts)

lemma synth_parts_subset_elem:
  "\<lbrakk>A \<subseteq> synth (parts B); x \<in> parts A\<rbrakk> \<Longrightarrow> x \<in> synth (parts B)"
by (meson parts_emptyE parts_insert_subset_impl parts_singleton subset_iff)

lemma synth_parts_subset:
  "A \<subseteq> synth (parts B) \<Longrightarrow> parts A \<subseteq> synth (parts B)"
by (auto simp add: synth_parts_subset_elem)

lemma parts_synth_parts[simp]: "parts (synth (parts H)) = synth (parts H)"
by auto

lemma synth_parts_trans:
  assumes "A \<subseteq> synth (parts B)" and "B \<subseteq> synth (parts C)"
  shows "A \<subseteq> synth (parts C)"
using assms by (metis order_trans parts_synth_parts synth_idem synth_parts_mono)

lemma synth_parts_trans_elem:
  assumes "x \<in> A" and "A \<subseteq> synth (parts B)" and "B \<subseteq> synth (parts C)"
  shows "x \<in> synth (parts C)"
using synth_parts_trans assms by auto

lemma synth_un_parts_split:
  assumes "x \<in> synth (parts A \<union> parts B)"
    and "\<And>x . x \<in> A \<Longrightarrow> x \<in> synth (parts C)"
    and "\<And>x . x \<in> B \<Longrightarrow> x \<in> synth (parts C)"
  shows "x \<in> synth (parts C)"
proof -
  have "parts A \<subseteq> synth (parts C)" "parts B \<subseteq> synth (parts C)"
    using assms(2) assms(3) synth_parts_subset by blast+
  then have "x \<in> synth (synth (parts C) \<union> synth (parts C))" using assms(1)
    using synth_trans by auto
  then show ?thesis by auto
qed

subsubsection \<open>Normalization of Messages\<close>
text\<open>Prevent FS from being contained directly in other FS.
For instance, a term @{term "FS {| FS {| Num 0 |}, Num 0 |}"} is
not normalized, whereas @{term "FS {| Hash (FS {| Num 0 |}), Num 0 |}"} is normalized.\<close>

inductive normalized :: "msgterm \<Rightarrow> bool" where
    \<epsilon>  [simp,intro!]:    "normalized \<epsilon>"
  | AS  [simp,intro!]:   "normalized (AS agt)"
  | Num [simp,intro!]:   "normalized (Num n)"
  | Key [simp,intro!]:   "normalized (Key n)"
  | Nonce [simp,intro!]:  "normalized (Nonce n)"
  | Lst [intro]:      "\<lbrakk> \<And>x . x \<in> set xs \<Longrightarrow> normalized x \<rbrakk> \<Longrightarrow> normalized (L xs)"
  | FSt [intro]:      "\<lbrakk> \<And>x . x \<in> fset xs \<Longrightarrow> normalized x;
                         \<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys \<rbrakk>
                      \<Longrightarrow> normalized (FS xs)"
  | Hash   [intro]:   "normalized X \<Longrightarrow> normalized (Hash X)"
  | MPair  [intro]:   "\<lbrakk> normalized X; normalized Y \<rbrakk> \<Longrightarrow> normalized \<langle>X,Y\<rangle>"
  | Crypt  [intro]:   "\<lbrakk> normalized X \<rbrakk> \<Longrightarrow> normalized (Crypt K X)"

thm normalized.simps
find_theorems normalized

text\<open>Examples\<close>
lemma "normalized (FS {| Hash (FS {| Num 0 |}), Num 0 |})" by fastforce
lemma "\<not> normalized (FS {| FS {| Num 0 |}, Num 0 |})" by (auto elim: normalized.cases)

subsubsection\<open>Closure of @{text "normalized"} under @{text "parts"}, @{text "analz"} and @{text "synth"}\<close>

text\<open>All synthesized terms are normalized (since @{text "synth"} prevents directly nested FSets).\<close>
lemma normalized_synth[elim!]: "\<lbrakk>t \<in> synth H; \<And>t. t \<in> H \<Longrightarrow> normalized t\<rbrakk> \<Longrightarrow> normalized t"
  by(induction t, auto 3 4)

lemma normalized_parts[elim!]: "\<lbrakk>t \<in> parts H; \<And>t. t \<in> H \<Longrightarrow> normalized t\<rbrakk> \<Longrightarrow> normalized t"
  by(induction t rule: parts.induct)
    (auto elim: normalized.cases)

lemma normalized_analz[elim!]: "\<lbrakk>t \<in> analz H; \<And>t. t \<in> H \<Longrightarrow> normalized t\<rbrakk> \<Longrightarrow> normalized t"
  by(induction t rule: analz.induct)
    (auto elim: normalized.cases)

subsubsection\<open>Properties of @{text "normalized"}\<close>

lemma normalized_FS[elim]: "\<lbrakk>normalized (FS xs); x |\<in>| xs\<rbrakk> \<Longrightarrow> normalized x"
  by(auto simp add: normalized.simps[of "FS xs"])

lemma normalized_FS_FS[elim]: "\<lbrakk>normalized (FS xs); x |\<in>| xs; x = FS ys\<rbrakk> \<Longrightarrow> False"
  by(auto simp add: normalized.simps[of "FS xs"])

lemma normalized_subset: "\<lbrakk>normalized (FS xs); ys |\<subseteq>| xs\<rbrakk> \<Longrightarrow> normalized (FS ys)"
  by (auto intro!: normalized.FSt)

lemma normalized_insert[elim!]: "normalized (FS (finsert x xs)) \<Longrightarrow> normalized (FS xs)"
  by(auto elim!: normalized_subset)

lemma normalized_union:
  assumes "normalized (FS xs)" "normalized (FS ys)" "zs |\<subseteq>| xs |\<union>| ys"
  shows "normalized (FS zs)"
  using assms by(auto intro!: normalized.FSt)

lemma normalized_minus[elim]:
  assumes "normalized (FS (ys |-| xs))" "normalized (FS xs)"
  shows "normalized (FS ys)"
  using normalized_union assms by blast

subsubsection\<open>Lemmas that do not use @{text "normalized"}, but are helpful in proving its properties\<close>
lemma FS_mono: "\<lbrakk>zs_s = finsert (f (FS zs_s)) zs_b; \<And> x. size (f x) > size x\<rbrakk> \<Longrightarrow> False"
  by (metis (no_types) add.right_neutral add_Suc_right finite_fset finsert.rep_eq less_add_Suc1
      msgterm.size(17) not_less_eq size_fset_simps sum.insert_remove)

lemma FS_contr: "\<lbrakk>zs = f (FS {|zs|}); \<And> x. size (f x) > size x\<rbrakk> \<Longrightarrow> False"
  using FS_mono by blast

end


(*  Title:      HOL/SPARK/Examples/RIPEMD-160/RMD_Lemmas.thy
    Author:     Fabian Immler, TU Muenchen

Verification of the RIPEMD-160 hash function
*)

theory RMD_Lemmas
imports MainRLT
begin

definition "fun_of_list i xs g j =
  (if j < i \<or> i + int (length xs) \<le> j then g j else xs ! nat (j - i))"

lemma fun_of_list_Nil [simp]: "fun_of_list i [] g = g"
  by (auto simp add: fun_eq_iff fun_of_list_def)

lemma fun_of_list_Cons [simp]:
  "fun_of_list i (x # xs) g = fun_of_list (i + 1) xs (g(i:=x))"
  by (auto simp add: fun_eq_iff fun_of_list_def nth_Cons'
    nat_diff_distrib [of "int (Suc 0)", simplified, symmetric]
    diff_diff_eq)

lemma nth_fun_of_list_eq:
  "0 \<le> i \<Longrightarrow> i < int (length xs) \<Longrightarrow> xs ! nat i = fun_of_list 0 xs g i"
  by (simp add: fun_of_list_def)

end


(* Author: Florian Haftmann, TU Muenchen
   Author: Andreas Lochbihler, ETH Zurich *)

section \<open>Lists with elements distinct as canonical example for datatype invariants\<close>

theory Dlist
imports Confluent_Quotient
begin

subsection \<open>The type of distinct lists\<close>

typedef 'a dlist = "{xs::'a list. distinct xs}"
  morphisms list_of_dlist Abs_dlist
proof
  show "[] \<in> {xs. distinct xs}" by simp
qed

context begin

qualified definition dlist_eq where "dlist_eq = BNF_Def.vimage2p remdups remdups (=)"

qualified lemma equivp_dlist_eq: "equivp dlist_eq"
  unfolding dlist_eq_def by(rule equivp_vimage2p)(rule identity_equivp)

qualified definition abs_dlist :: "'a list \<Rightarrow> 'a dlist" where "abs_dlist = Abs_dlist o remdups"

definition qcr_dlist :: "'a list \<Rightarrow> 'a dlist \<Rightarrow> bool" where "qcr_dlist x y \<longleftrightarrow> y = abs_dlist x"

qualified lemma Quotient_dlist_remdups: "Quotient dlist_eq abs_dlist list_of_dlist qcr_dlist"
  unfolding Quotient_def dlist_eq_def qcr_dlist_def vimage2p_def abs_dlist_def
  by (auto simp add: fun_eq_iff Abs_dlist_inject
    list_of_dlist[simplified] list_of_dlist_inverse distinct_remdups_id)

end

locale Quotient_dlist begin
setup_lifting Dlist.Quotient_dlist_remdups Dlist.equivp_dlist_eq[THEN equivp_reflp2]
end

setup_lifting type_definition_dlist

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
  by (simp add: list_of_dlist_inject)

lemma dlist_eqI:
  "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

text \<open>Formal, totalized constructor for \<^typ>\<open>'a dlist\<close>:\<close>

definition Dlist :: "'a list \<Rightarrow> 'a dlist" where
  "Dlist xs = Abs_dlist (remdups xs)"

lemma distinct_list_of_dlist [simp, intro]:
  "distinct (list_of_dlist dxs)"
  using list_of_dlist [of dxs] by simp

lemma list_of_dlist_Dlist [simp]:
  "list_of_dlist (Dlist xs) = remdups xs"
  by (simp add: Dlist_def Abs_dlist_inverse)

lemma remdups_list_of_dlist [simp]:
  "remdups (list_of_dlist dxs) = list_of_dlist dxs"
  by simp

lemma Dlist_list_of_dlist [simp, code abstype]:
  "Dlist (list_of_dlist dxs) = dxs"
  by (simp add: Dlist_def list_of_dlist_inverse distinct_remdups_id)

text \<open>Fundamental operations:\<close>

context
begin

qualified definition empty :: "'a dlist" where
  "empty = Dlist []"

qualified definition insert :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "insert x dxs = Dlist (List.insert x (list_of_dlist dxs))"

qualified definition remove :: "'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "remove x dxs = Dlist (remove1 x (list_of_dlist dxs))"

qualified definition map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist" where
  "map f dxs = Dlist (remdups (List.map f (list_of_dlist dxs)))"

qualified definition filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "filter P dxs = Dlist (List.filter P (list_of_dlist dxs))"

qualified definition rotate :: "nat \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist" where
  "rotate n dxs = Dlist (List.rotate n (list_of_dlist dxs))"

end

text \<open>Derived operations:\<close>

context
begin

qualified definition null :: "'a dlist \<Rightarrow> bool" where
  "null dxs = List.null (list_of_dlist dxs)"

qualified definition member :: "'a dlist \<Rightarrow> 'a \<Rightarrow> bool" where
  "member dxs = List.member (list_of_dlist dxs)"

qualified definition length :: "'a dlist \<Rightarrow> nat" where
  "length dxs = List.length (list_of_dlist dxs)"

qualified definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "fold f dxs = List.fold f (list_of_dlist dxs)"

qualified definition foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b" where
  "foldr f dxs = List.foldr f (list_of_dlist dxs)"

end

subsection \<open>Executable version obeying invariant\<close>

lemma list_of_dlist_empty [simp, code abstract]:
  "list_of_dlist Dlist.empty = []"
  by (simp add: Dlist.empty_def)

lemma list_of_dlist_insert [simp, code abstract]:
  "list_of_dlist (Dlist.insert x dxs) = List.insert x (list_of_dlist dxs)"
  by (simp add: Dlist.insert_def)

lemma list_of_dlist_remove [simp, code abstract]:
  "list_of_dlist (Dlist.remove x dxs) = remove1 x (list_of_dlist dxs)"
  by (simp add: Dlist.remove_def)

lemma list_of_dlist_map [simp, code abstract]:
  "list_of_dlist (Dlist.map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by (simp add: Dlist.map_def)

lemma list_of_dlist_filter [simp, code abstract]:
  "list_of_dlist (Dlist.filter P dxs) = List.filter P (list_of_dlist dxs)"
  by (simp add: Dlist.filter_def)

lemma list_of_dlist_rotate [simp, code abstract]:
  "list_of_dlist (Dlist.rotate n dxs) = List.rotate n (list_of_dlist dxs)"
  by (simp add: Dlist.rotate_def)

text \<open>Explicit executable conversion\<close>

definition dlist_of_list [simp]:
  "dlist_of_list = Dlist"

lemma [code abstract]:
  "list_of_dlist (dlist_of_list xs) = remdups xs"
  by simp

text \<open>Equality\<close>

instantiation dlist :: (equal) equal
begin

definition "HOL.equal dxs dys \<longleftrightarrow> HOL.equal (list_of_dlist dxs) (list_of_dlist dys)"

instance
  by standard (simp add: equal_dlist_def equal list_of_dlist_inject)

end

declare equal_dlist_def [code]

lemma [code nbe]: "HOL.equal (dxs :: 'a::equal dlist) dxs \<longleftrightarrow> True"
  by (fact equal_refl)

subsection \<open>Induction principle and case distinction\<close>

lemma dlist_induct [case_names empty insert, induct type: dlist]:
  assumes empty: "P Dlist.empty"
  assumes insrt: "\<And>x dxs. \<not> Dlist.member dxs x \<Longrightarrow> P dxs \<Longrightarrow> P (Dlist.insert x dxs)"
  shows "P dxs"
proof (cases dxs)
  case (Abs_dlist xs)
  then have "distinct xs" and dxs: "dxs = Dlist xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  from \<open>distinct xs\<close> have "P (Dlist xs)"
  proof (induct xs)
    case Nil from empty show ?case by (simp add: Dlist.empty_def)
  next
    case (Cons x xs)
    then have "\<not> Dlist.member (Dlist xs) x" and "P (Dlist xs)"
      by (simp_all add: Dlist.member_def List.member_def)
    with insrt have "P (Dlist.insert x (Dlist xs))" .
    with Cons show ?case by (simp add: Dlist.insert_def distinct_remdups_id)
  qed
  with dxs show "P dxs" by simp
qed

lemma dlist_case [cases type: dlist]:
  obtains (empty) "dxs = Dlist.empty"
    | (insert) x dys where "\<not> Dlist.member dys x" and "dxs = Dlist.insert x dys"
proof (cases dxs)
  case (Abs_dlist xs)
  then have dxs: "dxs = Dlist xs" and distinct: "distinct xs"
    by (simp_all add: Dlist_def distinct_remdups_id)
  show thesis
  proof (cases xs)
    case Nil with dxs
    have "dxs = Dlist.empty" by (simp add: Dlist.empty_def)
    with empty show ?thesis .
  next
    case (Cons x xs)
    with dxs distinct have "\<not> Dlist.member (Dlist xs) x"
      and "dxs = Dlist.insert x (Dlist xs)"
      by (simp_all add: Dlist.member_def List.member_def Dlist.insert_def distinct_remdups_id)
    with insert show ?thesis .
  qed
qed

subsection \<open>Functorial structure\<close>

functor map: map
  by (simp_all add: remdups_map_remdups fun_eq_iff dlist_eq_iff)

subsection \<open>Quickcheck generators\<close>

quickcheck_generator dlist predicate: distinct constructors: Dlist.empty, Dlist.insert

subsection \<open>BNF instance\<close>

context begin

qualified inductive double :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  "double (xs @ ys) (xs @ x # ys)" if "x \<in> set ys"

qualified lemma strong_confluentp_double: "strong_confluentp double"
proof
  fix xs ys zs :: "'a list"
  assume ys: "double xs ys" and zs: "double xs zs"
  consider (left) as y bs z cs where "xs = as @ bs @ cs" "ys = as @ y # bs @ cs" "zs = as @ bs @ z # cs" "y \<in> set (bs @ cs)" "z \<in> set cs"
    | (right) as y bs z cs where "xs = as @ bs @ cs" "ys = as @ bs @ y # cs" "zs = as @ z # bs @ cs" "y \<in> set cs" "z \<in> set (bs @ cs)"
  proof -
    show thesis using ys zs
      by(clarsimp simp add: double.simps append_eq_append_conv2)(auto intro: that)
  qed
  then show "\<exists>us. double\<^sup>*\<^sup>* ys us \<and> double\<^sup>=\<^sup>= zs us"
  proof cases
    case left
    let ?us = "as @ y # bs @ z # cs"
    have "double ys ?us" "double zs ?us" using left
      by(auto 4 4 simp add: double.simps)(metis append_Cons append_assoc)+
    then show ?thesis by blast
  next
    case right
    let ?us = "as @ z # bs @ y # cs"
    have "double ys ?us" "double zs ?us" using right
      by(auto 4 4 simp add: double.simps)(metis append_Cons append_assoc)+
    then show ?thesis by blast
  qed
qed

qualified lemma double_Cons1 [simp]: "double xs (x # xs)" if "x \<in> set xs"
  using double.intros[of x xs "[]"] that by simp

qualified lemma double_Cons_same [simp]: "double xs ys \<Longrightarrow> double (x # xs) (x # ys)"
  by(auto simp add: double.simps Cons_eq_append_conv)

qualified lemma doubles_Cons_same: "double\<^sup>*\<^sup>* xs ys \<Longrightarrow> double\<^sup>*\<^sup>* (x # xs) (x # ys)"
  by(induction rule: rtranclp_induct)(auto intro: rtranclp.rtrancl_into_rtrancl)

qualified lemma remdups_into_doubles: "double\<^sup>*\<^sup>* (remdups xs) xs"
  by(induction xs)(auto intro: doubles_Cons_same rtranclp.rtrancl_into_rtrancl)

qualified lemma dlist_eq_into_doubles: "Dlist.dlist_eq \<le> equivclp double"
  by(auto 4 4 simp add: Dlist.dlist_eq_def vimage2p_def
     intro: equivclp_trans converse_rtranclp_into_equivclp rtranclp_into_equivclp remdups_into_doubles)

qualified lemma factor_double_map: "double (map f xs) ys \<Longrightarrow> \<exists>zs. Dlist.dlist_eq xs zs \<and> ys = map f zs \<and> set zs \<subseteq> set xs"
  by(auto simp add: double.simps Dlist.dlist_eq_def vimage2p_def map_eq_append_conv)
    (metis (no_types, opaque_lifting) list.simps(9) map_append remdups.simps(2) remdups_append2 set_append set_eq_subset set_remdups)

qualified lemma dlist_eq_set_eq: "Dlist.dlist_eq xs ys \<Longrightarrow> set xs = set ys"
  by(simp add: Dlist.dlist_eq_def vimage2p_def)(metis set_remdups)

qualified lemma dlist_eq_map_respect: "Dlist.dlist_eq xs ys \<Longrightarrow> Dlist.dlist_eq (map f xs) (map f ys)"
  by(clarsimp simp add: Dlist.dlist_eq_def vimage2p_def)(metis remdups_map_remdups)

qualified lemma confluent_quotient_dlist:
  "confluent_quotient double Dlist.dlist_eq Dlist.dlist_eq Dlist.dlist_eq Dlist.dlist_eq Dlist.dlist_eq
     (map fst) (map snd) (map fst) (map snd) list_all2 list_all2 list_all2 set set"
  by(unfold_locales)(auto intro: strong_confluentp_imp_confluentp strong_confluentp_double
    dest: factor_double_map dlist_eq_into_doubles[THEN predicate2D] dlist_eq_set_eq
    simp add: list.in_rel list.rel_compp dlist_eq_map_respect Dlist.equivp_dlist_eq equivp_imp_transp)

lifting_update dlist.lifting
lifting_forget dlist.lifting

end

context begin
interpretation Quotient_dlist: Quotient_dlist .

lift_bnf (plugins del: code) 'a dlist
  subgoal for A B by(rule confluent_quotient.subdistributivity[OF Dlist.confluent_quotient_dlist])
  subgoal by(force dest: Dlist.dlist_eq_set_eq intro: equivp_reflp[OF Dlist.equivp_dlist_eq])
  done

qualified lemma list_of_dlist_transfer[transfer_rule]:
  "bi_unique R \<Longrightarrow> (rel_fun (Quotient_dlist.pcr_dlist R) (list_all2 R)) remdups list_of_dlist"
  unfolding rel_fun_def Quotient_dlist.pcr_dlist_def qcr_dlist_def Dlist.abs_dlist_def
  by (auto simp: Abs_dlist_inverse intro!: remdups_transfer[THEN rel_funD])

lemma list_of_dlist_map_dlist[simp]:
  "list_of_dlist (map_dlist f xs) = remdups (map f (list_of_dlist xs))"
  by transfer (auto simp: remdups_map_remdups)

end

end