(*  Title:      Monad_Normalisation.thy
    Author:     Manuel Eberl, TU München
    Author:     Joshua Schneider, ETH Zurich
    Author:     Andreas Lochbihler, ETH Zurich

Normalisation of monadic expressions.
*)

section \<open>Normalisation of monadic expressions\<close>

theory Monad_Normalisation
imports "HOL-Probability.Probability"
keywords "print_monad_rules" :: diag
begin

text \<open>
  The standard monad laws
  \begin{gather}
    \label{eq:return:bind}
    \<open>return a \<bind> f = f a\<close>
    \\
    \label{eq:bind:return}
    \<open>x \<bind> return = x\<close>
    \\
    \label{eq:bind:assoc}
    \<open>(x \<bind> f) \<bind> g = x \<bind> (\<lambda>a. f a \<bind> g)\<close>
  \end{gather}
  yield a confluent and terminating rewrite system.
  Thus, when these equations are added to the simpset, the simplifier can normalise monadic
  expressions and decide the equivalence of monadic programs (in the free monad).

  However, many monads satisfy additional laws.
  In some monads, it is possible to discard unused effects
  \begin{gather}
    \label{eq:discard}
    \<open>x \<bind> (\<lambda>_. y) = y\<close>
  \end{gather}
  or duplicate effects
  \begin{gather}
    \label{eq:duplicate}
    \<open>x \<bind> (\<lambda>a. x \<bind> f a) = x \<bind> (\<lambda>a. f a a)\<close>
  \end{gather}
  or commute independent computations
  \begin{gather}
    \label{eq:commute}
    \<open>x \<bind> (\<lambda>a. y \<bind> f a) = y \<bind> (\<lambda>b. x \<bind> (\<lambda>a. f a b))\<close>.
  \end{gather}
  For example, @{typ "_ option"} satisfies \eqref{eq:duplicate} and \eqref{eq:commute},
  @{typ "_ set"} validates \eqref{eq:commute}, and
  @{typ "_ pmf"} satisfies \eqref{eq:discard} and \eqref{eq:commute}.
  Equations \eqref{eq:discard} and \eqref{eq:duplicate} can be directly used as rewrite rules.%
  \footnote{%
    If they both hold, then \eqref{eq:commute} holds, too \cite{LochbihlerSchneider2016ITP}.
  }
  However, the simplifier does not handle \eqref{eq:commute} well because \eqref{eq:commute} is a
  higher-order permutative rewrite rule and ordered rewriting in the simplifier can only handle
  first-order permutative rewrite rules.
  Consequently, when \eqref{eq:commute} is added to the simpset, the simplifier will loop.

  This AFP entry implements a simproc for the simplifier to simplify HOL expressions over commutative
  monads based on ordered rewriting.  This yields a decision procedure for equality of monadic
  expressions in any (free) monad satisfying any of the laws (\ref{eq:discard}--\ref{eq:commute}).
  If further commutative operators show up in the HOL term, then the ordered rewrite system need not
  be confluent and the simproc only performs a best effort.  We do not know whether this general case
  can be solved by ordered rewriting as a complete solution would have to solve the graph isomorphism
  problem by term rewriting \cite{Basin1994IPL}.
\<close>

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

subsection \<open>Usage\<close>

text \<open>
  The monad laws \eqref{eq:return:bind}, \eqref{eq:bind:return}, \eqref{eq:bind:assoc}, \eqref{eq:commute}
  must be registered with the attribute @{attribute monad_rule}.
  The simproc does not need \eqref{eq:discard} and \eqref{eq:duplicate}, so these properties need not
  be registered, but can simply be added to the simpset if needed.
  The simproc is activated by including the bundle \<open>monad_normalisation\<close>.

  Additionally, distributivity laws for control operators like @{const If} and @{const case_nat}
  specialised to \<open>\<bind>\<close> can be declared with the attribute @{attribute monad_distrib}.
  Then, the simproc will also commute computations over these control operators.

  The set of registered monad laws can be inspected with the command @{command print_monad_rules}.
\<close>

subsection \<open>Registration of the monads from the Isabelle/HOL library\<close>

lemmas [monad_rule] = Set.bind_bind

lemma set_bind_commute [monad_rule]:
  fixes A :: "'a set" and B :: "'b set"
  shows "A \<bind> (\<lambda>x. B \<bind> C x) = B \<bind> (\<lambda>y. A \<bind> (\<lambda>x. C x y))"
  unfolding Set.bind_def by auto

lemma set_return_bind [monad_rule]:
  fixes A :: "'a \<Rightarrow> 'b set"
  shows "{x} \<bind> A = A x"
  unfolding Set.bind_def by auto

lemma set_bind_return [monad_rule]:
  fixes A :: "'a set"
  shows "A \<bind> (\<lambda>x. {x}) = A"
  unfolding Set.bind_def by auto

lemmas [monad_rule] = Predicate.bind_bind Predicate.bind_single Predicate.single_bind

lemma predicate_bind_commute [monad_rule]:
  fixes A :: "'a Predicate.pred" and B :: "'b Predicate.pred"
  shows "A \<bind> (\<lambda>x. B \<bind> C x) = B \<bind> (\<lambda>y. A \<bind> (\<lambda>x. C x y))"
  by (intro pred_eqI) auto

lemmas [monad_rule] = Option.bind_assoc Option.bind_lunit Option.bind_runit

lemma option_bind_commute [monad_rule]:
  fixes A :: "'a option" and B :: "'b option"
  shows "A \<bind> (\<lambda>x. B \<bind> C x) = B \<bind> (\<lambda>y. A \<bind> (\<lambda>x. C x y))"
  by (cases A) auto

lemmas [monad_rule] =
  bind_assoc_pmf
  bind_commute_pmf
  bind_return_pmf
  bind_return_pmf'

lemmas [monad_rule] =
  bind_spmf_assoc
  bind_commute_spmf
  bind_return_spmf
  return_bind_spmf

subsection \<open>Distributive operators\<close>

lemma bind_if [monad_distrib]:
  "f A (\<lambda>x. if P then B x else C x) = (if P then f A B else f A C)"
by simp

lemma bind_case_prod [monad_distrib]:
  "f A (\<lambda>x. case y of (a,b) \<Rightarrow> B a b x) = (case y of (a,b) \<Rightarrow> f A (B a b))"
by (simp split: prod.split)

lemma bind_case_sum [monad_distrib]:
  "f A (\<lambda>x. case y of Inl a \<Rightarrow> B a x | Inr a \<Rightarrow> C a x) =
    (case y of Inl a \<Rightarrow> f A (B a) | Inr a \<Rightarrow> f A (C a))"
by (simp split: sum.split)

lemma bind_case_option [monad_distrib]:
  "f A (\<lambda>x. case y of Some a \<Rightarrow> B a x | None \<Rightarrow> C x) =
    (case y of Some a \<Rightarrow> f A (B a) | None \<Rightarrow> f A C)"
by (simp split: option.split)

lemma bind_case_list [monad_distrib]:
  "f A (\<lambda>x. case y of [] \<Rightarrow> B x | y # ys \<Rightarrow> C y ys x) = (case y of [] \<Rightarrow> f A B | y # ys \<Rightarrow> f A (C y ys))"
by (simp split: list.split)

lemma bind_case_nat [monad_distrib]:
  "f A (\<lambda>x. case y of 0 \<Rightarrow> B x | Suc n \<Rightarrow> C n x) = (case y of 0 \<Rightarrow> f A B | Suc n \<Rightarrow> f A (C n))"
by (simp split: nat.split)

subsection \<open>Setup of the normalisation simproc\<close>

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

simproc_setup monad_normalisation ("f x y") = \<open>K Monad_Normalisation.normalise_step\<close>
declare [[simproc del: monad_normalisation]]

text \<open>
  The following bundle enables normalisation of monadic expressions by the simplifier.
  We use @{attribute monad_rule_internal} instead of \<open>monad_rule[simp]\<close> such that
  the theorems in @{thm [source] monad_rule} get dynamically added to the simpset instead of
  only those that are in there when the bundle is declared.
\<close>

bundle monad_normalisation = [[simproc add: monad_normalisation, monad_rule_internal]]

end


theory ChainedEnvironment
  imports "../08FlatCode/ByteCode" "../09HeapMemory/Heap"
begin

datatype ceclosure =
  CEConst nat
  | CELam ptr nat

datatype chained_state =
  CES "ceclosure heap" "(ptr \<times> ptr) heap" "ptr list" "(ptr \<times> nat) list"

fun chain_lookup :: "('a \<times> ptr) heap \<Rightarrow> ptr \<Rightarrow> nat \<rightharpoonup> 'a" where
  "chain_lookup h 0 x = None"
| "chain_lookup h (Suc p) 0 = Some (case hlookup h p of (a, b) \<Rightarrow> a)"
| "chain_lookup h (Suc p) (Suc x) = chain_lookup h (case hlookup h p of (a, b) \<Rightarrow> b) x"

inductive evalce :: "byte_code list \<Rightarrow> chained_state \<Rightarrow> chained_state \<Rightarrow> bool"
    (infix "\<tturnstile> _ \<leadsto>\<^sub>c\<^sub>e" 50) where
  evce_lookup [simp]: "lookup cd pc = Some (BLookup x) \<Longrightarrow> chain_lookup env p x = Some v \<Longrightarrow>
    cd \<tturnstile> CES h env vs ((p, Suc pc) # sfs) \<leadsto>\<^sub>c\<^sub>e CES h env (v # vs) ((p, pc) # sfs)"
| evce_pushcon [simp]: "lookup cd pc = Some (BPushCon k) \<Longrightarrow> halloc h (CEConst k) = (h', v) \<Longrightarrow>
    cd \<tturnstile> CES h env vs ((p, Suc pc) # sfs) \<leadsto>\<^sub>c\<^sub>e CES h' env (v # vs) ((p, pc) # sfs)"
| evce_pushlam [simp]: "lookup cd pc = Some (BPushLam pc') \<Longrightarrow>
    halloc h (CELam p pc') = (h', v) \<Longrightarrow>
      cd \<tturnstile> CES h env vs ((p, Suc pc) # sfs) \<leadsto>\<^sub>c\<^sub>e CES h' env (v # vs) ((p, pc) # sfs)"
| evce_apply [simp]: "lookup cd pc = Some BApply \<Longrightarrow> hlookup h v2 = CELam p' pc' \<Longrightarrow>
    halloc env (v1, p') = (env', p'') \<Longrightarrow>
      cd \<tturnstile> CES h env (v1 # v2 # vs) ((p, Suc pc) # sfs) \<leadsto>\<^sub>c\<^sub>e
        CES h env' vs ((Suc p'', pc') # (p, pc) # sfs)"
| evce_return [simp]: "lookup cd pc = Some BReturn \<Longrightarrow>
    cd \<tturnstile> CES h env vs ((p, Suc pc) # sfs) \<leadsto>\<^sub>c\<^sub>e CES h env vs sfs"
| evce_jump [simp]: "lookup cd pc = Some BJump \<Longrightarrow> hlookup h v2 = CELam p' pc' \<Longrightarrow>
    halloc env (v1, p') = (env', p'') \<Longrightarrow>
      cd \<tturnstile> CES h env (v1 # v2 # vs) ((p, Suc pc) # sfs) \<leadsto>\<^sub>c\<^sub>e CES h env' vs ((Suc p'', pc') # sfs)"

theorem determinismh: "cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>c\<^sub>e \<Sigma>' \<Longrightarrow> cd \<tturnstile> \<Sigma> \<leadsto>\<^sub>c\<^sub>e \<Sigma>'' \<Longrightarrow> \<Sigma>' = \<Sigma>''"
proof (induction \<Sigma> \<Sigma>' rule: evalce.induct)
  case (evce_lookup cd pc x env p v h vs sfs)
  from evce_lookup(3, 1, 2) show ?case
    by (induction cd "CES h env vs ((p, Suc pc) # sfs)" \<Sigma>'' rule: evalce.induct) simp_all
next
  case (evce_pushcon cd pc k h h' v env vs p sfs)
  from evce_pushcon(3, 1, 2) show ?case
    by (induction cd "CES h env vs ((p, Suc pc) # sfs)" \<Sigma>'' rule: evalce.induct) simp_all
next
  case (evce_pushlam cd pc pc' h p h' v env vs sfs)
  from evce_pushlam(3, 1, 2) show ?case
    by (induction cd "CES h env vs ((p, Suc pc) # sfs)" \<Sigma>'' rule: evalce.induct) simp_all
next
  case (evce_apply cd pc h v2 p' pc' env v1 env' p'' vs p sfs)
  from evce_apply(4, 1, 2, 3) show ?case
    by (induction cd "CES h env (v1 # v2 # vs) ((p, Suc pc) # sfs)" \<Sigma>'' rule: evalce.induct)
       simp_all
next
  case (evce_return cd pc h env vs p sfs)
  from evce_return(2, 1) show ?case
    by (induction cd "CES h env vs ((p, Suc pc) # sfs)" \<Sigma>'' rule: evalce.induct) simp_all
next
  case (evce_jump cd pc h v2 p' pc' env v1 env' p'' vs p sfs)
  from evce_jump(4, 1, 2, 3) show ?case
    by (induction cd "CES h env (v1 # v2 # vs) ((p, Suc pc) # sfs)" \<Sigma>'' rule: evalce.induct)
       simp_all
qed

end


theory Gen_Hash
imports "../Intf/Intf_Hash"
begin

definition "prod_bhc bhc1 bhc2 \<equiv> \<lambda>n (a,b). (bhc1 n a * 33 + bhc2 n b) mod n"

lemma prod_bhc_ga[autoref_ga_rules]:
  "\<lbrakk> GEN_ALGO_tag (is_bounded_hashcode R eq1 bhc1);
     GEN_ALGO_tag (is_bounded_hashcode S eq2 bhc2)\<rbrakk>
  \<Longrightarrow> is_bounded_hashcode (R\<times>\<^sub>rS) (prod_eq eq1 eq2) (prod_bhc bhc1 bhc2)"
  unfolding is_bounded_hashcode_def prod_bhc_def prod_eq_def[abs_def]
  apply safe
  apply (auto dest: fun_relD)
  done

lemma prod_dhs_ga[autoref_ga_rules]:
  "\<lbrakk> GEN_ALGO_tag (is_valid_def_hm_size TYPE('a) n1);
     GEN_ALGO_tag (is_valid_def_hm_size TYPE('b) n2) \<rbrakk>
   \<Longrightarrow> is_valid_def_hm_size TYPE('a*'b) (n1+n2)"
   unfolding is_valid_def_hm_size_def by auto

end


(*  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 Main begin
ML_file \<open>../../antiquote_setup.ML\<close>

(*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
(*>*)

section\<open>Agents and Messages\<close>

text \<open>
All protocol specifications refer to a syntactic theory of messages.
Datatype
\<open>agent\<close> introduces the constant \<open>Server\<close> (a trusted central
machine, needed for some protocols), an infinite population of
friendly agents, and the~\<open>Spy\<close>:
\<close>

datatype agent = Server | Friend nat | Spy

text \<open>
Keys are just natural numbers.  Function \<open>invKey\<close> maps a public key to
the matching private key, and vice versa:
\<close>

type_synonym key = nat
consts invKey :: "key \<Rightarrow> key"
(*<*)
consts all_symmetric :: bool        \<comment> \<open>true if all keys are symmetric\<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}"
(*>*)

text \<open>
Datatype
\<open>msg\<close> introduces the message forms, which include agent names, nonces,
keys, compound messages, and encryptions.
\<close>

datatype
     msg = Agent  agent
         | Nonce  nat
         | Key    key
         | MPair  msg msg
         | Crypt  key msg

text \<open>
\noindent
The notation $\comp{X\sb 1,\ldots X\sb{n-1},X\sb n}$
abbreviates
$\isa{MPair}\,X\sb 1\,\ldots\allowbreak(\isa{MPair}\,X\sb{n-1}\,X\sb n)$.

Since datatype constructors are injective, we have the theorem
@{thm [display,indent=0] msg.inject(5) [THEN iffD1, of K X K' X']}
A ciphertext can be decrypted using only one key and
can yield only one plaintext.  In the real world, decryption with the
wrong key succeeds but yields garbage.  Our model of encryption is
realistic if encryption adds some redundancy to the plaintext, such as a
checksum, so that garbage can be detected.
\<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>"   == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
  "\<lbrace>x, y\<rbrace>"      == "CONST MPair x y"

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 \<Longrightarrow> X \<in> parts H"
  | Fst:         "\<lbrace>X,Y\<rbrace>   \<in> parts H \<Longrightarrow> X \<in> parts H"
  | Snd:         "\<lbrace>X,Y\<rbrace>   \<in> parts H \<Longrightarrow> Y \<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.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')"
apply safe
apply (drule_tac f = invKey in arg_cong, simp)
done

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_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_Key [simp]: "keysFor (insert (Key K) 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 \<Longrightarrow> 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{} \<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}"
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"
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

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)

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

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (drule parts_mono, blast)

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 (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_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_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_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"
apply auto
apply (erule parts.induct, auto)
done

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}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
 txt\<open>MPair case: blast works out the necessary sum itself!\<close>
 prefer 2 apply auto apply (blast elim!: add_leE)
txt\<open>Nonce case\<close>
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI, auto)
done
(*>*)

section\<open>Modelling the Adversary\<close>

text \<open>
The spy is part of the system and must be built into the model.  He is
a malicious user who does not have to follow the protocol.  He
watches the network and uses any keys he knows to decrypt messages.
Thus he accumulates additional keys and nonces.  These he can use to
compose new messages, which he may send to anybody.

Two functions enable us to formalize this behaviour: \<open>analz\<close> and
\<open>synth\<close>.  Each function maps a sets of messages to another set of
messages. The set \<open>analz H\<close> formalizes what the adversary can learn
from the set of messages~$H$.  The closure properties of this set are
defined inductively.
\<close>

inductive_set
  analz :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] : "X \<in> H \<Longrightarrow> X \<in> analz H"
  | Fst:     "\<lbrace>X,Y\<rbrace> \<in> analz H \<Longrightarrow> X \<in> analz H"
  | Snd:     "\<lbrace>X,Y\<rbrace> \<in> analz H \<Longrightarrow> 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 \<Longrightarrow> 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"
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_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

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)
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
      \<Longrightarrow> 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 \<Longrightarrow>
               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 \<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)
apply (blast intro: analz_insertI analz.Decrypt)
done

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

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 \<in> analz (insert X H) \<Longrightarrow> X \<in> analz H \<longrightarrow> Y \<in> 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:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' |]
      ==> 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:
     "[| 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' \<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 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)) \<Longrightarrow> 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])
(*>*)
text \<open>
Note the \<open>Decrypt\<close> rule: the spy can decrypt a
message encrypted with key~$K$ if he has the matching key,~$K^{-1}$.
Properties proved by rule induction include the following:
@{named_thms [display,indent=0] analz_mono [no_vars] (analz_mono) analz_idem [no_vars] (analz_idem)}

The set of fake messages that an intruder could invent
starting from~\<open>H\<close> is \<open>synth(analz H)\<close>, where \<open>synth H\<close>
formalizes what the adversary can build from the set of messages~$H$.
\<close>

inductive_set
  synth :: "msg set \<Rightarrow> msg set"
  for H :: "msg set"
  where
    Inj    [intro]: "X \<in> H \<Longrightarrow> X \<in> synth H"
  | Agent  [intro]: "Agent agt \<in> synth H"
  | MPair  [intro]:
              "\<lbrakk>X \<in> synth H;  Y \<in> synth H\<rbrakk> \<Longrightarrow> \<lbrace>X,Y\<rbrace> \<in> synth H"
  | Crypt  [intro]:
              "\<lbrakk>X \<in> synth H;  Key K \<in> H\<rbrakk> \<Longrightarrow> Crypt K X \<in> synth H"
(*<*)
lemma synth_mono: "G\<subseteq>H \<Longrightarrow> synth(G) \<subseteq> synth(H)"
  by (auto, erule synth.induct, auto)

inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<lbrace>X,Y\<rbrace> \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"

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"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done
(*>*)
text \<open>
The set includes all agent names.  Nonces and keys are assumed to be
unguessable, so none are included beyond those already in~$H$.   Two
elements of \<^term>\<open>synth H\<close> can be combined, and an element can be encrypted
using a key present in~$H$.

Like \<open>analz\<close>, this set operator is monotone and idempotent.  It also
satisfies an interesting equation involving \<open>analz\<close>:
@{named_thms [display,indent=0] analz_synth [no_vars] (analz_synth)}
Rule inversion plays a major role in reasoning about \<open>synth\<close>, through
declarations such as this one:
\<close>

inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"

text \<open>
\noindent
The resulting elimination rule replaces every assumption of the form
\<^term>\<open>Nonce n \<in> synth H\<close> by \<^term>\<open>Nonce n \<in> H\<close>,
expressing that a nonce cannot be guessed.

A third operator, \<open>parts\<close>, is useful for stating correctness
properties.  The set
\<^term>\<open>parts H\<close> consists of the components of elements of~$H$.  This set
includes~\<open>H\<close> and is closed under the projections from a compound
message to its immediate parts.
Its definition resembles that of \<open>analz\<close> except in the rule
corresponding to the constructor \<open>Crypt\<close>:
@{thm [display,indent=5] parts.Body [no_vars]}
The body of an encrypted message is always regarded as part of it.  We can
use \<open>parts\<close> to express general well-formedness properties of a protocol,
for example, that an uncompromised agent's private key will never be
included as a component of any message.
\<close>
(*<*)
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) \<Longrightarrow> X\<in> synth H"
by (erule synth.induct, 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: "[| 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 Agent_synth [simp]: "Agent A \<in> synth H"
by 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)

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

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>\<open>parts{X} \<subseteq> synth (analz H) \<union> parts H\<close>\<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:
     "[|Z \<in> parts (insert X H);  X \<in> synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert  [THEN subsetD, dest])

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) \<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]:
     "(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
      (X \<in> synth (analz H) & 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

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" "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" "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>Tactics useful for many protocol proofs\<close>
ML
\<open>
val invKey = @{thm invKey};
val keysFor_def = @{thm keysFor_def};
val symKeys_def = @{thm symKeys_def};
val parts_mono = @{thm parts_mono};
val analz_mono = @{thm analz_mono};
val synth_mono = @{thm synth_mono};
val analz_increasing = @{thm analz_increasing};

val analz_insertI = @{thm analz_insertI};
val analz_subset_parts = @{thm analz_subset_parts};
val Fake_parts_insert = @{thm Fake_parts_insert};
val Fake_analz_insert = @{thm Fake_analz_insert};
val pushes = @{thms pushes};

(*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.
  Abstraction over i is ESSENTIAL: it delays the dereferencing of claset
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

fun Fake_insert_tac ctxt =
    dresolve_tac ctxt [impOfSubs Fake_analz_insert,
                  impOfSubs 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 [analz_insertI, impOfSubs 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 synth_analz_mono: "G\<subseteq>H \<Longrightarrow> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_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 \<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) \<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]

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
(*>*)


theory ex7_01 imports Main "~~/src/HOL/IMP/Big_Step"
begin

fun assigned :: "com \<Rightarrow> vname set" where
"assigned SKIP = {}" |
"assigned (v ::= x) = {v}" |
"assigned (c1;;c2) = assigned c1 \<union> assigned c2" |
"assigned (IF b THEN c1 ELSE c2) = assigned c1 \<union> assigned c2" |
"assigned (WHILE b DO c) = assigned c"

theorem "\<lbrakk> (c,s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
by(induction arbitrary: rule: big_step_induct, auto)

end


section \<open> Weakest Prespecification \<close>

theory utp_wprespec
  imports "UTP2.utp_rel_laws" "UTP2.utp_wlp"
begin

named_theorems wp

no_notation Equiv_Relations.quotient (infixl "'/'/" 90)

definition wprespec :: "('a, 'c) urel \<Rightarrow> ('b, 'c) urel \<Rightarrow> ('a, 'b) urel" (infixl "'/'/" 70) where
[rel]: "wprespec Y K = (\<not> ((\<not> Y) ;; K\<^sup>-))"

lemma wprespec_alt_def: "(P // Q) = (\<not> Q ;; (\<not> P\<^sup>-))\<^sup>-"
  by (simp add: wprespec_def)

theorem wprespec: "R \<sqsubseteq> P ;; Q \<longleftrightarrow> R // Q \<sqsubseteq> P"
  by (pred_auto add: wprespec_def)

lemma wprespec1: "R \<sqsubseteq> (R // Q) ;; Q"
  by (simp add: wprespec)

lemma wprespec2: "(P ;; Q) // Q \<sqsubseteq> P"
  using wprespec by blast

lemma wprespec3: "R // Q \<sqsubseteq> II \<longleftrightarrow> R \<sqsubseteq> Q"
  by (metis seqr_left_unit wprespec)

lemma wprespec4: "Q // Q \<sqsubseteq> II"
  by (simp add: wprespec3)

lemma wprespec5 [wp]: "P // II = P"
  by (metis antisym ref_by_pred_is_leq seqr_right_unit wprespec1 wprespec2)

lemma wprespec6 [wp]: "(R \<and> S) // Q = ((R // Q) \<and> (S // Q))"
  by (rel_auto)

lemma wprespec6a [wp]: "(\<Squnion> n\<in>A. R(n)) // Q = (\<Squnion> n\<in>A. R(n) // Q)"
  by (rel_auto)

lemma wprespec7 [wp]: "R // (P \<or> Q) = ((R // P) \<and> (R // Q))"
  by (simp add: seqr_or_distr subst_pred(4) wprespec_def)

lemma wprespec7a [wp]: "R // (\<Sqinter> i\<in>A. P(i)) = (\<Squnion> i\<in>A. R // P(i))"
  by (pred_auto add: wprespec_def)

lemma wprespec8 [wp]: "R // (P ;; Q)= R // Q // P"
  by (metis (no_types, lifting) pred_ba.order.eq_iff seqr_assoc wprespec wprespec wprespec wprespec1 wprespec1)

theorem wprespec9: "R // Q = \<Sqinter> {Y. R \<sqsubseteq> Y ;; Q}" (is "?lhs = ?rhs")
  by (metis (no_types, lifting) mem_Collect_eq ref_lattice.Inf_eqI wprespec wprespec1)

theorem wprespec10: "(R // Q) (s\<^sub>0, s) = (\<forall> s'. Q (s, s') \<longrightarrow> R (s\<^sub>0, s'))"
  by (pred_auto add: wprespec_def)

lemma wprespec12: "Q\<^sup>- = ((\<not>II) // (\<not>Q))"
  by (simp add: wprespec_def)

lemma wprespec13: "(\<not> (R // Q)) = (\<not>II) // ((\<not>Q) // (\<not>R))"
  by (pred_auto add: wprespec_def)

lemma wprespec17 [wp]: "R // \<langle>\<sigma>\<rangle>\<^sub>a = R ;; (II // \<langle>\<sigma>\<rangle>\<^sub>a)"
  apply (pred_auto add: wprespec_def)
  by metis

lemma wprespec17a [wp]: "II // \<langle>\<sigma>\<rangle>\<^sub>a = \<langle>\<sigma>\<rangle>\<^sub>a\<^sup>-"
  by (pred_auto add: wprespec_def)

theorem wlp_as_wprespec: "P wlp b = post ((b\<^sup>>) // P )"
  apply (simp add: post_def)
  by (pred_auto add: wprespec_def)

end


subsection \<open> Weakest Liberal Preconditions \<close>

theory utp_wlp
  imports utp_rel_laws utp_hoare
begin

named_theorems wp

definition wlp_pred :: "('s\<^sub>1, 's\<^sub>2) urel \<Rightarrow> ('s\<^sub>2 \<Rightarrow> bool) \<Rightarrow> ('s\<^sub>1 \<Rightarrow> bool)" where
[pred]: "wlp_pred Q r = pre (\<not> (Q ;; (\<not> r\<^sup><)\<^sub>e) :: ('s\<^sub>1, 's\<^sub>2) urel)"

expr_constructor wlp_pred

syntax
  "_wlp" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infix "wlp" 60)

translations
  "_wlp Q r" == "CONST wlp_pred Q (r)\<^sub>e"

lemma wlp_seq [wp]: "(P ;; Q) wlp b = P wlp (Q wlp b)"
  by (pred_auto)

lemma wlp_assigns [wp]: "\<langle>\<sigma>\<rangle>\<^sub>a wlp b = (\<sigma> \<dagger> b)\<^sub>e"
  by pred_auto

lemma wlp_true [wp]: "p wlp True = (True)\<^sub>e"
  by pred_auto

lemma wlp_conj [wp]: "(P wlp (b \<and> c))\<^sub>e = ((P wlp b)\<^sub>e \<and> (P wlp c)\<^sub>e)"
  by (pred_auto)

theorem wlp_cond [wp]: "((P \<lhd> b \<rhd> Q) wlp r)  =((b \<longrightarrow> P  wlp r) \<and> ((\<not> b) \<longrightarrow> Q wlp r))\<^sub>e"
  by pred_auto

theorem wlp_skip_r [wp]: "II wlp r = r"
  by pred_auto

theorem wlp_abort [wp]:
  assumes"r \<noteq> (True)\<^sub>e"
  shows
  "true wlp r =( False)\<^sub>e"
  using assms by pred_auto

lemma wlp_nd_assign [wp]: "(x := * ) wlp b = (\<forall> v. [x\<leadsto>v] \<dagger> b)\<^sub>e"
  by pred_auto

theorem wlp_choice [wp]: "(P \<sqinter> Q) wlp R = (P wlp R \<and> Q wlp R)\<^sub>e"
  by (pred_auto)

theorem wlp_choice' [wp]: "(P \<or> Q) wlp R = (P wlp R \<and> Q wlp R)\<^sub>e"
  by (pred_auto)

lemma wlp_UINF_ind [wp]: "(\<Sqinter> i . P(i)) wlp b = (\<forall> i . P(i) wlp b)\<^sub>e"
  by (pred_auto)

lemma wlp_USUP_pre [wp]:
  shows "P wlp (\<forall> i  . Q(i)) = (\<forall> i. P wlp Q(i))\<^sub>e"
  by (pred_auto; blast)

lemma wlp_test [wp]: "(\<questiondown>b? wlp c)\<^sub>e = (b \<longrightarrow> c)\<^sub>e"
  by (pred_auto)

(*
lemma wlp_rel_aext_unrest [wp]: "(\<lbrakk> vwb_lens a; a \<sharp> b \<rbrakk> \<longrightarrow> a:[P]\<^sup>+ wlp b)\<^sub>e = ((P wlp false) \<up>\<^sub>p a \<or> b)\<^sub>e"
  by (rel_simp, metis mwb_lens_def vwb_lens_def weak_lens.put_get)

lemma wlp_rel_aext_usedby [wp]: "\<lbrakk> vwb_lens a; a \<natural> b \<rbrakk> \<Longrightarrow> a:[P]\<^sup>+ wlp b = (P wlp (b \<restriction>\<^sub>e a)) \<oplus>\<^sub>p a"
  by (pred_auto, metis mwb_lens_def vwb_lens_mwb weak_lens.put_get)

lemma wlp_gcmd [wp]:
 "((b \<longrightarrow> P) wlp c)\<^sub>e = (b \<longrightarrow> P wlp c)\<^sub>e"
  by (simp add: rgcmd_def wp)
*)

theorem wlp_hoare_link:
  "\<^bold>{p\<^bold>}Q\<^bold>{r\<^bold>} \<longleftrightarrow> `p \<longrightarrow> Q wlp r`"
  by pred_auto

text \<open> We can use the above theorem as a means to discharge Hoare triples with the following tactic \<close>

method hoare_wlp_auto uses defs = (simp add: wlp_hoare_link wp unrest usubst defs; pred_auto)

text \<open> If two programs have the same weakest precondition for any postcondition then the programs
  are the same. \<close>

theorem wlp_eq_intro: "\<lbrakk> \<And> r. P wlp r = Q wlp r \<rbrakk> \<Longrightarrow> P = Q"
  by (pred_auto, fastforce+)

end


(*
Author:  Christian Sternagel <c.sternagel@gmail.com>
Author:  René Thiemann <rene.thiemann@uibk.ac.at>
License: LGPL
*)
section \<open>Unification\<close>

subsection \<open>Unifiers\<close>

text \<open>Definition and properties of (most general) unifiers\<close>

theory Unifiers
  imports Term
begin

(*TODO: move*)
lemma map_eq_set_zipD [dest]:
  assumes "map f xs = map f ys"
    and "(x, y) \<in> set (zip xs ys)"
  shows "f x = f y"
using assms
proof (induct xs arbitrary: ys)
  case (Cons x xs)
  then show ?case by (cases ys) auto
qed simp

type_synonym ('f, 'v) equation = "('f, 'v) term \<times> ('f, 'v) term"
type_synonym ('f, 'v) equations = "('f, 'v) equation set"

text \<open>The set of unifiers for a given set of equations.\<close>
definition unifiers :: "('f, 'v) equations \<Rightarrow> ('f, 'v) subst set"
  where
    "unifiers E = {\<sigma>. \<forall>p\<in>E. fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>}"

text \<open>Check whether a set of equations is unifiable.\<close>
definition "unifiable E \<longleftrightarrow> (\<exists>\<sigma>. \<sigma> \<in> unifiers E)"

lemma in_unifiersE [elim]:
  "\<lbrakk>\<sigma> \<in> unifiers E; (\<And>e. e \<in> E \<Longrightarrow> fst e \<cdot> \<sigma> = snd e \<cdot> \<sigma>) \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (force simp: unifiers_def)

text \<open>Applying a substitution to a set of equations.\<close>
definition subst_set :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equations \<Rightarrow> ('f, 'v) equations"
  where
    "subst_set \<sigma> E = (\<lambda>e. (fst e \<cdot> \<sigma>, snd e \<cdot> \<sigma>)) ` E"

text \<open>Check whether a substitution is a most-general unifier (mgu) of a set of equations.\<close>
definition is_mgu :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equations \<Rightarrow> bool"
  where
    "is_mgu \<sigma> E \<longleftrightarrow> \<sigma> \<in> unifiers E \<and> (\<forall>\<tau> \<in> unifiers E. (\<exists>\<gamma>. \<tau> = \<sigma> \<circ>\<^sub>s \<gamma>))"

text \<open>The following property characterizes idempotent mgus, that is,
  mgus \<^term>\<open>\<sigma>\<close> for which \<^prop>\<open>\<sigma> \<circ>\<^sub>s \<sigma> = \<sigma>\<close> holds.\<close>
definition is_imgu :: "('f, 'v) subst \<Rightarrow> ('f, 'v) equations \<Rightarrow> bool"
  where
    "is_imgu \<sigma> E \<longleftrightarrow> \<sigma> \<in> unifiers E \<and> (\<forall>\<tau> \<in> unifiers E. \<tau> = \<sigma> \<circ>\<^sub>s \<tau>)"

subsubsection \<open>Properties of sets of unifiers\<close>

lemma unifiers_Un [simp]:
  "unifiers (s \<union> t) = unifiers s \<inter> unifiers t"
  by (auto simp: unifiers_def)

lemma unifiers_empty [simp]:
  "unifiers {} = UNIV"
  by (auto simp: unifiers_def)

lemma unifiers_insert: (* "simp not added for readability (and termination)" *)
  "unifiers (insert p t) = {\<sigma>. fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>} \<inter> unifiers t"
  by (auto simp: unifiers_def)

lemma unifiers_insert_ident [simp]:
  "unifiers (insert (t, t) E) = unifiers E"
  by (auto simp: unifiers_insert)

lemma unifiers_insert_swap:
  "unifiers (insert (s, t) E) = unifiers (insert (t, s) E)"
  by (auto simp: unifiers_insert)

lemma unifiers_insert_Var_swap [simp]:
  "unifiers (insert (t, Var x) E) = unifiers (insert (Var x, t) E)"
  by (rule unifiers_insert_swap)

lemma unifiers_subst_set [simp]:
  "\<tau> \<in> unifiers (subst_set \<sigma> E) \<longleftrightarrow> \<sigma> \<circ>\<^sub>s \<tau> \<in> unifiers E"
  by (auto simp: unifiers_def subst_set_def)

lemma unifiers_insert_VarD:
  shows "\<sigma> \<in> unifiers (insert (Var x, t) E) \<Longrightarrow> subst x t \<circ>\<^sub>s \<sigma> = \<sigma>"
    and "\<sigma> \<in> unifiers (insert (t, Var x) E) \<Longrightarrow> subst x t \<circ>\<^sub>s \<sigma> = \<sigma>"
  by (auto simp: unifiers_def)

lemma unifiers_insert_Var_left:
  "\<sigma> \<in> unifiers (insert (Var x, t) E) \<Longrightarrow> \<sigma> \<in> unifiers (subst_set (subst x t) E)"
  by (auto simp: unifiers_def subst_set_def)

lemma unifiers_set_zip [simp]:
  assumes "length ss = length ts"
  shows "unifiers (set (zip ss ts)) = {\<sigma>. map (\<lambda>t. t \<cdot> \<sigma>) ss = map (\<lambda>t. t \<cdot> \<sigma>) ts}"
  using assms by (induct ss ts rule: list_induct2) (auto simp: unifiers_def)

lemma unifiers_Fun [simp]:
  "\<sigma> \<in> unifiers {(Fun f ss, Fun g ts)} \<longleftrightarrow>
    length ss = length ts \<and> f = g \<and> \<sigma> \<in> unifiers (set (zip ss ts))"
  by (auto simp: unifiers_def dest: map_eq_imp_length_eq)
    (induct ss ts rule: list_induct2, simp_all)

lemma unifiers_occur_left_is_Fun:
  fixes t :: "('f, 'v) term"
  assumes "x \<in> vars_term t" and "is_Fun t"
  shows "unifiers (insert (Var x, t) E) = {}"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain \<sigma> :: "('f, 'v) subst" where "\<sigma> x = t \<cdot> \<sigma>" by (auto simp: unifiers_def)
  with is_Fun_num_funs_less [OF assms, of \<sigma>] show False by auto
qed

lemma unifiers_occur_left_not_Var:
  "x \<in> vars_term t \<Longrightarrow> t \<noteq> Var x \<Longrightarrow> unifiers (insert (Var x, t) E) = {}"
  using unifiers_occur_left_is_Fun [of x t] by (cases t) simp_all

lemma unifiers_occur_left_Fun:
  "x \<in> (\<Union>t\<in>set ts. vars_term t) \<Longrightarrow> unifiers (insert (Var x, Fun f ts) E) = {}"
  using unifiers_occur_left_is_Fun [of x "Fun f ts"] by simp

lemmas unifiers_occur_left_simps [simp] =
  unifiers_occur_left_is_Fun
  unifiers_occur_left_not_Var
  unifiers_occur_left_Fun

subsubsection \<open>Properties of unifiability\<close>

lemma in_vars_is_Fun_not_unifiable:
  assumes "x \<in> vars_term t" and "is_Fun t"
  shows "\<not> unifiable {(Var x, t)}"
proof
  assume "unifiable {(Var x, t)}"
  then obtain \<sigma> where "\<sigma> \<in> unifiers {(Var x, t)}"
    by (auto simp: unifiable_def)
  then have "\<sigma> x = t \<cdot> \<sigma>" by (auto)
  moreover have "num_funs (\<sigma> x) < num_funs (t \<cdot> \<sigma>)"
    using is_Fun_num_funs_less [OF assms] by auto
  ultimately show False by auto
qed

lemma unifiable_insert_swap:
  "unifiable (insert (s, t) E) = unifiable (insert (t, s) E)"
  by (auto simp: unifiable_def unifiers_insert_swap)

lemma subst_set_reflects_unifiable:
  fixes \<sigma> :: "('f, 'v) subst"
  assumes "unifiable (subst_set \<sigma> E)"
  shows "unifiable E"
proof -
  { fix \<tau> :: "('f, 'v) subst" assume "\<forall>p\<in>E. fst p \<cdot> \<sigma> \<cdot> \<tau> = snd p \<cdot> \<sigma> \<cdot> \<tau>"
    then have "\<exists>\<sigma> :: ('f, 'v) subst. \<forall>p\<in>E. fst p \<cdot> \<sigma> = snd p \<cdot> \<sigma>"
      by (intro exI [of _ "\<sigma> \<circ>\<^sub>s \<tau>"]) auto }
  then show ?thesis using assms by (auto simp: unifiable_def unifiers_def subst_set_def)
qed

subsubsection \<open>Properties of \<^term>\<open>is_mgu\<close>\<close>

lemma is_mgu_empty [simp]:
  "is_mgu Var {}"
  by (auto simp: is_mgu_def)

lemma is_mgu_insert_trivial [simp]:
  "is_mgu \<sigma> (insert (t, t) E) = is_mgu \<sigma> E"
  by (auto simp: is_mgu_def)

lemma is_mgu_insert_decomp [simp]:
  assumes "length ss = length ts"
  shows "is_mgu \<sigma> (insert (Fun f ss, Fun f ts) E) \<longleftrightarrow>
    is_mgu \<sigma> (E \<union> set (zip ss ts))"
  using assms by (auto simp: is_mgu_def unifiers_insert)

lemma is_mgu_insert_swap:
  "is_mgu \<sigma> (insert (s, t) E) = is_mgu \<sigma> (insert (t, s) E)"
  by (auto simp: is_mgu_def unifiers_def)

lemma is_mgu_insert_Var_swap [simp]:
  "is_mgu \<sigma> (insert (t, Var x) E) = is_mgu \<sigma> (insert (Var x, t) E)"
  by (rule is_mgu_insert_swap)

lemma is_mgu_subst_set_subst:
  assumes "x \<notin> vars_term t"
    and "is_mgu \<sigma> (subst_set (subst x t) E)" (is "is_mgu \<sigma> ?E")
  shows "is_mgu (subst x t \<circ>\<^sub>s \<sigma>) (insert (Var x, t) E)" (is "is_mgu ?\<sigma> ?E'")
proof -
  from \<open>is_mgu \<sigma> ?E\<close>
    have "?\<sigma> \<in> unifiers E"
    and *: "\<forall>\<tau>. (subst x t \<circ>\<^sub>s \<tau>) \<in> unifiers E \<longrightarrow> (\<exists>\<mu>. \<tau> = \<sigma> \<circ>\<^sub>s \<mu>)"
    by (auto simp: is_mgu_def)
  then have "?\<sigma> \<in> unifiers ?E'" using assms by (simp add: unifiers_insert subst_compose)
  moreover have "\<forall>\<tau>. \<tau> \<in> unifiers ?E' \<longrightarrow> (\<exists>\<mu>. \<tau> = ?\<sigma> \<circ>\<^sub>s \<mu>)"
  proof (intro allI impI)
    fix \<tau>
    assume **: "\<tau> \<in> unifiers ?E'"
    then have [simp]: "subst x t \<circ>\<^sub>s \<tau> = \<tau>" by (blast dest: unifiers_insert_VarD)
    from unifiers_insert_Var_left [OF **]
      have "subst x t \<circ>\<^sub>s \<tau> \<in> unifiers E" by (simp)
    with * obtain \<mu> where "\<tau> = \<sigma> \<circ>\<^sub>s \<mu>" by blast
    then have "subst x t \<circ>\<^sub>s \<tau> = subst x t \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<mu>" by (auto simp: ac_simps)
    then show "\<exists>\<mu>. \<tau> = subst x t \<circ>\<^sub>s \<sigma> \<circ>\<^sub>s \<mu>" by auto
  qed
  ultimately show "is_mgu ?\<sigma> ?E'" by (simp add: is_mgu_def)
qed

lemma is_imgu_imp_is_mgu:
  assumes "is_imgu \<sigma> E"
  shows "is_mgu \<sigma> E"
  using assms by (auto simp: is_imgu_def is_mgu_def)

end


(*  Title:       Proving the Correctness of Disk Paxos

    Author:      Mauro J. Jaskelioff, Stephan Merz, 2005
    Maintainer:  Mauro J. Jaskelioff <mauro at fceia.unr.edu.ar>
*)

theory DiskPaxos_Inv6 imports DiskPaxos_Chosen  begin

subsection {* Invariant 6 *}

text{*
The final conjunct of $HInv$ asserts that, once an output has been chosen,
$valueChosen(chosen)$ holds, and each processor's output equals either $chosen$ or
$NotAnInput$.
*}

definition HInv6 :: "state \<Rightarrow> bool"
where
  "HInv6 s = ((chosen s \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s))
              \<and> (\<forall>p. outpt s p \<in> {chosen s, NotAnInput}))"

theorem HInit_HInv6: "HInit s \<Longrightarrow> HInv6 s"
  by(auto simp add: HInit_def Init_def InitDB_def HInv6_def)

lemma HEndPhase2_Inv6_1:
  assumes act: "HEndPhase2 s s' p"
  and inv: "HInv6 s"
  and inv2b: "Inv2b s"
  and inv2c: "Inv2c s"
  and inv3: "HInv3 s"
  and inv5: "HInv5_inner s p"
  and chosen': "chosen s' \<noteq> NotAnInput"
  shows "valueChosen s' (chosen s')"
proof(cases "chosen s=NotAnInput")
  from inv5 act
  have inv5R: "HInv5_inner_R s p"
    and phase: "phase s p = 2"
    and ep2_maj: "IsMajority {d .    d \<in> disksWritten s p
                                  \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)}"
    by(auto simp add: EndPhase2_def HInv5_inner_def)
  case True
  have p32: "maxBalInp s (bal(dblock s p)) (inp(dblock s p))"
  proof-
    have "\<not>(\<exists>D \<in> MajoritySet.\<exists>q. (\<forall>d\<in>D. bal (dblock s p) < mbal (disk s d q) \<and> \<not> hasRead s p d q))"
    proof auto
      fix D q
      assume Dmaj: "D\<in>MajoritySet"
      from ep2_maj Dmaj majorities_intersect
      have "\<exists>d\<in>D. d \<in> disksWritten s p
        \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)"
        by(auto simp add: MajoritySet_def, blast)
      then obtain d
        where dinD: "d\<in>D"
        and ddisk: "d \<in> disksWritten s p"
        and dhasR: "\<forall>q \<in> UNIV - {p}. hasRead s p d q"
        by auto
      from inv2b
      have "Inv2b_inner s p d"
        by(auto simp add: Inv2b_def)
      with ddisk
      have "disk s d p = dblock s p"
        by(auto simp add: Inv2b_inner_def)
      with inv2c phase
      have "bal (dblock s p) = mbal(disk s d p)"
        by(auto simp add: Inv2c_def Inv2c_inner_def)
      with dhasR dinD
      show "\<exists>d\<in>D. bal (dblock s p) < mbal (disk s d q) \<longrightarrow> hasRead s p d q"
        by auto
    qed
    with inv5R
    show ?thesis
      by(auto simp add: HInv5_inner_R_def)
  qed
  have p33: "maxBalInp s' (bal(dblock s' p)) (chosen s')"
  proof -
    from act
    have outpt': "outpt s' = (outpt s) (p:= inp (dblock s p))"
      by(auto simp add: EndPhase2_def)
    have outpt'_q: "\<forall>q. p\<noteq>q \<longrightarrow> outpt s' q = NotAnInput"
    proof auto
      fix q
      assume pnq: "p\<noteq>q"
      from outpt' pnq
      have "outpt s' q= outpt s q"
        by(auto simp add: EndPhase2_def)
      with True inv2c
      show "outpt s' q= NotAnInput"
        by(auto simp add: Inv2c_def Inv2c_inner_def)
    qed
    from True act chosen'
    have "chosen s' = inp (dblock s p)"
    proof(auto simp add: HNextPart_def split: split_if_asm)
      fix pa
      assume outpt'_pa: "outpt s' pa \<noteq> NotAnInput"
      from outpt'_q
      have someeq2: "\<And>pa. outpt s' pa \<noteq> NotAnInput \<Longrightarrow> pa=p"
        by auto
      with outpt'_pa
      have "outpt s' p \<noteq> NotAnInput"
        by auto
      from some_equality[of "\<lambda>p. outpt s' p \<noteq> NotAnInput", OF this someeq2]
      have "(SOME p. outpt s' p \<noteq> NotAnInput) = p" .
      with outpt'
      show  "outpt s' (SOME p. outpt s' p \<noteq> NotAnInput) = inp (dblock s p)"
        by auto
    qed
    moreover
    from act
    have"bal(dblock s' p) = bal(dblock s p)"
      by(auto simp add: EndPhase2_def)
    ultimately
    have "maxBalInp s (bal(dblock s' p)) (chosen s')"
      using p32
      by auto
    with HEndPhase2_allBlocks[OF act]
    show ?thesis
      by(auto simp add: maxBalInp_def)
  qed
  from ep2_maj inv2b majorities_intersect
  have "\<exists>D\<in>MajoritySet. (\<forall>d\<in>D.   disk s d p = dblock s p
                              \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q))"
    by(auto simp add: Inv2b_def Inv2b_inner_def MajoritySet_def)
  then obtain D
    where Dmaj: "D\<in>MajoritySet"
    and p34: "\<forall>d\<in>D.   disk s d p = dblock s p
    \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)"
    by auto
  have p35: "\<forall>q. \<forall>d\<in>D. ( phase s q=1 \<and> bal(dblock s p)\<le>mbal(dblock s q)\<and> hasRead s q d p)
                        \<longrightarrow> \<lparr>block=dblock s p, proc=p\<rparr>\<in>blocksRead s q d"
  proof auto
    fix q d
    assume dD: "d\<in>D" and phase_q: "phase s q= Suc 0"
      and bal_mbal: "bal(dblock s p)\<le>mbal(dblock s q)" and hasRead: "hasRead s q d p"
    from phase inv2c
    have "bal(dblock s p)=mbal(dblock s p)"
      by(auto simp add: Inv2c_def Inv2c_inner_def)
    moreover
    from inv2c phase
    have "\<forall>br\<in>blocksRead s p d. mbal(block br) < mbal(dblock s p)"
      by(auto simp add: Inv2c_def Inv2c_inner_def)
    ultimately
    have p41: "\<lparr>block=dblock s q, proc=q\<rparr>\<notin>blocksRead s p d"
      using bal_mbal
      by auto
    from phase phase_q
    have "p\<noteq>q" by auto
    with p34 dD
    have "hasRead s p d q"
      by auto
    with phase phase_q hasRead inv3 p41
    show "\<lparr>block = dblock s p, proc = p\<rparr> \<in> blocksRead s q d"
      by(auto simp add: HInv3_def HInv3_inner_def
                        HInv3_L_def HInv3_R_def)
  qed
  have p36: "\<forall>q. \<forall>d\<in>D. phase s' q=1 \<and> bal(dblock s p) \<le> mbal(dblock s' q) \<and> hasRead s' q d p
                        \<longrightarrow> (\<exists>br\<in>blocksRead s' q d. bal(block br) = bal(dblock s p))"
  proof(auto)
    fix q d
    assume dD: "d \<in> D" and phase_q: "phase s' q = Suc 0"
           and bal: "bal (dblock s p) \<le> mbal (dblock s' q)"
           and hasRead: "hasRead s' q d p"
    from phase_q act
    have "phase s' q=phase s q \<and> dblock s' q=dblock s q \<and> hasRead s' q d p=hasRead s q d p \<and> blocksRead s' q d=blocksRead s q d"
      by(auto simp add: EndPhase2_def hasRead_def InitializePhase_def)
    with p35 phase_q bal hasRead dD
    have "\<lparr>block=dblock s p, proc=p\<rparr>\<in>blocksRead s' q d"
      by auto
    thus "\<exists>br\<in>blocksRead s' q d. bal(block br) = bal(dblock s p)"
      by force
  qed
  hence p36_2: "\<forall>q. \<forall>d\<in>D. phase s' q=1 \<and> bal(dblock s p) \<le> mbal(dblock s' q) \<and> hasRead s' q d p
                         \<longrightarrow> (\<exists>br\<in>blocksRead s' q d. bal(dblock s p) \<le> bal(block br))"
    by force
  from act
  have bal_dblock: "bal(dblock s' p)=bal(dblock s p)"
    and disk: "disk s'= disk s"
    by(auto simp add: EndPhase2_def)
  from bal_dblock p33
  have "maxBalInp s' (bal(dblock s p)) (chosen s')"
    by auto
  moreover
  from disk p34
  have  "\<forall>d\<in>D. bal(dblock s p) \<le> bal(disk s' d p) "
    by auto
  ultimately
  have "maxBalInp s' (bal(dblock s p)) (chosen s') \<and>
           (\<exists>D\<in>MajoritySet.
                   \<forall>d\<in>D. bal(dblock s p) \<le> bal (disk s' d p) \<and>
                         (\<forall>q. phase s' q = Suc 0 \<and>
                              bal(dblock s p) \<le> mbal (dblock s' q) \<and> hasRead s' q d p \<longrightarrow>
                              (\<exists>br\<in>blocksRead s' q d. bal(dblock s p) \<le> bal (block br))))"
    using p36_2 Dmaj
    by auto
  moreover
  from phase inv2c
  have "bal(dblock s p)\<in> Ballot p"
    by(auto simp add: Inv2c_def Inv2c_inner_def)
  ultimately
  show ?thesis
    by(auto simp add: valueChosen_def)
next
  case False
  with act
  have p31: "chosen s' = chosen s"
    by(auto simp add: HNextPart_def)
  from False inv
  have "valueChosen s (chosen s)"
    by(auto simp add: HInv6_def)
  from HEndPhase2_valueChosen[OF act this] p31 False InputsOrNi
  show ?thesis
    by auto
qed

lemma valueChosen_equal_case:
  assumes max_v: "maxBalInp s b v"
  and Dmaj: "D \<in> MajoritySet"
  and asm_v: "\<forall>d\<in>D. b \<le> bal (disk s d p)"
  and max_w: "maxBalInp s ba w"
  and Damaj: "Da \<in> MajoritySet"
  and asm_w: "\<forall>d\<in>Da. ba \<le> bal (disk s d pa)"
  and b_ba: "b\<le>ba"
  shows "v=w"
proof -
  have "\<forall>d. disk s d pa \<in> allBlocks s"
    by(auto simp add: allBlocks_def blocksOf_def)
  with majorities_intersect Dmaj Damaj
  have "\<exists>d\<in>D\<inter>Da. disk s d pa \<in> allBlocks s"
    by(auto simp add: MajoritySet_def, blast)
  then obtain d
    where dinmaj: "d\<in>D\<inter>Da" and dab: "disk s d pa \<in> allBlocks s"
    by auto
  with asm_w
  have ba: "ba \<le> bal (disk s d pa)"
    by auto
  with b_ba
  have "b \<le> bal (disk s d pa)"
    by auto
  with max_v dab
  have v_value: "inp (disk s d pa) = v"
    by(auto simp add: maxBalInp_def)
  from ba max_w dab
  have w_value: "inp (disk s d pa) = w"
    by(auto simp add: maxBalInp_def)
  with v_value
  show ?thesis by auto
qed

lemma valueChosen_equal:
  assumes v: "valueChosen s v"
  and w: "valueChosen s w"
  shows "v=w" using assms
proof (auto simp add: valueChosen_def)
  fix a b aa ba p D pa Da
  assume max_v: "maxBalInp s b v"
    and Dmaj: "D \<in> MajoritySet"
    and asm_v: "\<forall>d\<in>D. b \<le> bal (disk s d p) \<and>
              (\<forall>q. phase s q = Suc 0 \<and>
                   b \<le> mbal (dblock s q) \<and> hasRead s q d p \<longrightarrow>
                   (\<exists>br\<in>blocksRead s q d. b \<le> bal (block br)))"
    and max_w: "maxBalInp s ba w"
    and Damaj: "Da \<in> MajoritySet"
    and asm_w: "\<forall>d\<in>Da. ba \<le> bal (disk s d pa) \<and>
              (\<forall>q. phase s q = Suc 0 \<and>
                   ba \<le> mbal (dblock s q) \<and> hasRead s q d pa \<longrightarrow>
                   (\<exists>br\<in>blocksRead s q d. ba \<le> bal (block br)))"
  from asm_v
  have asm_v: "\<forall>d\<in>D. b \<le> bal (disk s d p)" by auto
  from asm_w
  have asm_w: "\<forall>d\<in>Da. ba \<le> bal (disk s d pa)" by auto
  show "v=w"
  proof(cases "b\<le>ba")
    case True
    from valueChosen_equal_case[OF max_v Dmaj asm_v max_w Damaj asm_w True]
    show ?thesis .
  next
    case False
    from valueChosen_equal_case[OF max_w Damaj asm_w max_v Dmaj asm_v] False
    show ?thesis
      by auto
  qed
qed

lemma HEndPhase2_Inv6_2:
  assumes act: "HEndPhase2 s s' p"
  and inv: "HInv6 s"
  and inv2b: "Inv2b s"
  and inv2c: "Inv2c s"
  and inv3: "HInv3 s"
  and inv5: "HInv5_inner s p"
  and asm: "outpt s' r \<noteq> NotAnInput"
  shows "outpt s' r = chosen s'"
proof(cases "chosen s=NotAnInput")
  case True
  with inv2c
  have "\<forall>q. outpt s q = NotAnInput"
    by(auto simp add: Inv2c_def Inv2c_inner_def)
  with True act asm
  show ?thesis
    by(auto simp add: EndPhase2_def HNextPart_def
               split: split_if_asm)
next
  case False
  with inv
  have p31: "valueChosen s (chosen s)"
    by(auto simp add: HInv6_def)
  with False act
  have "chosen s'\<noteq> NotAnInput"
    by(auto simp add: HNextPart_def)
  from HEndPhase2_Inv6_1[OF act inv inv2b inv2c inv3 inv5 this]
  have p32: "valueChosen s'(chosen s')" .
  from False InputsOrNi
  have "chosen s \<in> Inputs" by auto
  from valueChosen_equal[OF HEndPhase2_valueChosen[OF act p31 this] p32]
  have p33: "chosen s = chosen s'" .
  from act
  have maj: "IsMajority {d .    d \<in> disksWritten s p
                             \<and> (\<forall>q \<in> UNIV - {p}. hasRead s p d q)}" (is "IsMajority ?D")
    and phase: "phase s p = 2"
    by(auto simp add: EndPhase2_def)
  show ?thesis
  proof(cases "outpt s r = NotAnInput")
    case True
    with asm act
    have p41: "r=p"
      by(auto simp add: EndPhase2_def split: split_if_asm)
    from maj
    have p42: "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. \<forall>q\<in>UNIV-{p}. hasRead s p d q"
      by(auto simp add: MajoritySet_def)
    have p43: "\<not>(\<exists>D\<in>MajoritySet. \<exists>q. (\<forall>d\<in>D.    bal(dblock s p) < mbal(disk s d q)
                                             \<and> \<not>hasRead s p d q))"
    proof auto
      fix D q
      assume Dmaj: "D \<in> MajoritySet"
      show "\<exists>d\<in>D. bal (dblock s p) < mbal (disk s d q) \<longrightarrow> hasRead s p d q"
      proof(cases "p=q")
        assume pq: "p=q"
        thus ?thesis
        proof auto
          from maj majorities_intersect Dmaj
          have "?D\<inter>D\<noteq>{}"
            by(auto simp add: MajoritySet_def)
          hence "\<exists>d\<in>?D\<inter>D. d\<in> disksWritten s p" by auto
          then obtain d where d: "d\<in> disksWritten s p" and "d\<in>?D\<inter>D"
            by auto
          hence dD: "d\<in>D" by auto
          from d inv2b
          have "disk s d p = dblock s p"
            by(auto simp add: Inv2b_def Inv2b_inner_def)
          with inv2c phase
          have "bal(dblock s p) = mbal(disk s d p) "
            by(auto simp add: Inv2c_def Inv2c_inner_def)
          with dD pq
          show  "\<exists>d\<in>D. bal (dblock s q) < mbal (disk s d q) \<longrightarrow> hasRead s q d q"
            by auto
        qed
      next
        case False
        with p42
        have "\<exists>D\<in>MajoritySet. \<forall>d\<in>D. hasRead s p d q"
          by auto
        with majorities_intersect Dmaj
        show ?thesis
          by(auto simp add: MajoritySet_def, blast)
      qed
    qed
    with inv5 act
    have p44: "maxBalInp s (bal(dblock s p)) (inp(dblock s p))"
      by(auto simp add: EndPhase2_def HInv5_inner_def
                        HInv5_inner_R_def)
    have "\<exists>bk\<in>allBlocks s. \<exists>b\<in>(UN p. Ballot p). (maxBalInp s b (chosen s)) \<and> b\<le> bal bk"
    proof -
      have disk_allblks: "\<forall>d p. disk s d p \<in> allBlocks s"
        by(auto simp add: allBlocks_def blocksOf_def)
      from p31
      have "\<exists>b\<in> (UN p. Ballot p). maxBalInp s b (chosen s) \<and>
      (\<exists>p. \<exists>D\<in>MajoritySet.(\<forall>d\<in>D.  b \<le> bal(disk s d p)))"
        by(auto simp add: valueChosen_def, force)
      with majority_nonempty obtain b p D d
        where "IsMajority D \<and> b\<in> (UN p. Ballot p) \<and>
               maxBalInp s b (chosen s) \<and> d\<in>D \<and> b \<le> bal(disk s d p)"
        by(auto simp add: MajoritySet_def, blast)
      with disk_allblks
      show ?thesis
        by(auto)
    qed
    then obtain bk b
      where p45_bk: "bk\<in>allBlocks s \<and> b\<le> bal bk"
        and p45_b: "b\<in>(UN p. Ballot p) \<and> (maxBalInp s b (chosen s))"
      by auto
    have p46: "inp(dblock s p) = chosen s"
    proof(cases "b \<le> bal(dblock s p)")
      case True
      have "dblock s p \<in> allBlocks s"
        by(auto simp add: allBlocks_def blocksOf_def)
      with p45_b True
      show ?thesis
        by(auto simp add: maxBalInp_def)
    next
      case False
      from p44 p45_bk False
      have "inp bk = inp(dblock s p)"
        by(auto simp add: maxBalInp_def)
      with p45_b p45_bk
      show ?thesis
        by(auto simp add: maxBalInp_def)
    qed
    with p41 p33 act
    show ?thesis
      by(auto simp add: EndPhase2_def)
  next
    case False
    from inv2c
    have "Inv2c_inner s r"
      by(auto simp add: Inv2c_def)
    with False asm inv2c act
    have "outpt s' r = outpt s r"
      by(auto simp add: Inv2c_inner_def EndPhase2_def
                 split: split_if_asm)
    with inv p33 False
    show ?thesis
      by(auto simp add: HInv6_def)
  qed
qed

theorem HEndPhase2_Inv6:
  assumes act: "HEndPhase2 s s' p"
  and inv: "HInv6 s"
  and inv2b: "Inv2b s"
  and inv2c: "Inv2c s"
  and inv3: "HInv3 s"
  and inv5: "HInv5_inner s p"
  shows "HInv6 s'"
proof(auto simp add: HInv6_def)
  assume "chosen s' \<noteq> NotAnInput"
  from HEndPhase2_Inv6_1[OF act inv inv2b inv2c inv3 inv5 this]
  show "valueChosen s' (chosen s')" .
next
  fix p
  assume "outpt s' p\<noteq> NotAnInput"
  from HEndPhase2_Inv6_2[OF act inv inv2b inv2c inv3 inv5 this]
  show "outpt s' p = chosen s'" .
qed

lemma outpt_chosen:
  assumes outpt: "outpt s = outpt s'"
  and inv2c: "Inv2c s"
  and nextp: "HNextPart s s'"
  shows "chosen s' = chosen s"
proof -
  from inv2c
  have "chosen s = NotAnInput \<longrightarrow> (\<forall>p. outpt s p = NotAnInput)"
    by(auto simp add: Inv2c_inner_def Inv2c_def)
  with outpt nextp
  show ?thesis
    by(auto simp add: HNextPart_def)
qed

lemma outpt_Inv6:
  "\<lbrakk> outpt s = outpt s'; \<forall>p. outpt s p \<in> {chosen s, NotAnInput};
     Inv2c s; HNextPart s s' \<rbrakk> \<Longrightarrow> \<forall>p. outpt s' p \<in> {chosen s', NotAnInput}"
  using assms and outpt_chosen
  by auto

theorem HStartBallot_Inv6:
  assumes act: "HStartBallot s s' p"
  and inv: "HInv6 s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: StartBallot_def HInv6_def)
  from HStartBallot_valueChosen[OF act] this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s = outpt s'"
    by(auto simp add: StartBallot_def)
  from outpt_Inv6[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

theorem HPhase1or2Write_Inv6:
  assumes act: "HPhase1or2Write s s' p d"
  and inv: "HInv6 s"
  and inv4: "HInv4a s p"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: Phase1or2Write_def HInv6_def)
  from HPhase1or2Write_valueChosen[OF act] inv4 this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s = outpt s'"
    by(auto simp add: Phase1or2Write_def)
  from outpt_Inv6[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

theorem HPhase1or2ReadThen_Inv6:
  assumes act: "HPhase1or2ReadThen s s' p d q"
  and inv: "HInv6 s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: Phase1or2ReadThen_def HInv6_def)
  from HPhase1or2ReadThen_valueChosen[OF act] this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s = outpt s'"
    by(auto simp add: Phase1or2ReadThen_def)
  from outpt_Inv6[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

theorem HPhase1or2ReadElse_Inv6:
  assumes act: "HPhase1or2ReadElse s s' p d q"
  and inv: "HInv6 s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
  using assms and HStartBallot_Inv6
  by(auto simp add: Phase1or2ReadElse_def)

theorem HEndPhase1_Inv6:
  assumes act: "HEndPhase1 s s' p"
  and inv: "HInv6 s"
  and inv1: "Inv1 s"
  and inv2a: "Inv2a s"
  and inv2b: "Inv2b s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: EndPhase1_def HInv6_def)
  from HEndPhase1_valueChosen[OF act] inv1 inv2a inv2b this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s = outpt s'"
    by(auto simp add: EndPhase1_def)
  from outpt_Inv6[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

lemma outpt_chosen_2:
  assumes outpt: "outpt s' = (outpt s) (p:= NotAnInput)"
  and inv2c: "Inv2c s"
  and nextp: "HNextPart s s'"
  shows "chosen s = chosen s'"
proof -
  from inv2c
  have "chosen s = NotAnInput \<longrightarrow> (\<forall>p. outpt s p = NotAnInput)"
    by(auto simp add: Inv2c_inner_def Inv2c_def)
  with outpt nextp
  show ?thesis
    by(auto simp add: HNextPart_def)
qed

lemma outpt_HInv6_2:
  assumes outpt: "outpt s' = (outpt s) (p:= NotAnInput)"
  and inv: "\<forall>p. outpt s p \<in> {chosen s, NotAnInput}"
  and inv2c: "Inv2c s"
  and nextp: "HNextPart s s'"
  shows "\<forall>p. outpt s' p \<in> {chosen s', NotAnInput}"
proof -
  from outpt_chosen_2[OF outpt inv2c nextp]
  have "chosen s = chosen s'" .
  with inv outpt
  show ?thesis
    by auto
qed

theorem HFail_Inv6:
  assumes act: "HFail s s' p"
  and inv: "HInv6 s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen_2 act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: Fail_def HInv6_def)
  from HFail_valueChosen[OF act] this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s' = (outpt s) (p:=NotAnInput) "
    by(auto simp add: Fail_def)
  from outpt_HInv6_2[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

theorem HPhase0Read_Inv6:
  assumes act: "HPhase0Read s s' p d"
  and inv: "HInv6 s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: Phase0Read_def HInv6_def)
  from HPhase0Read_valueChosen[OF act] this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s = outpt s'"
    by(auto simp add: Phase0Read_def)
  from outpt_Inv6[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

theorem HEndPhase0_Inv6:
  assumes act: "HEndPhase0 s s' p"
  and inv: "HInv6 s"
  and inv1: "Inv1 s"
  and inv2c: "Inv2c s"
  shows "HInv6 s'"
proof -
  from outpt_chosen act inv2c inv
  have "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s (chosen s')"
    by(auto simp add: EndPhase0_def HInv6_def)
  from HEndPhase0_valueChosen[OF act] inv1 this InputsOrNi
  have t1: "chosen s' \<noteq> NotAnInput \<longrightarrow> valueChosen s' (chosen s')"
    by auto
  from act
  have outpt: "outpt s = outpt s'"
    by(auto simp add: EndPhase0_def)
  from outpt_Inv6[OF outpt] act inv2c inv
  have "\<forall>p. outpt s' p = chosen s' \<or> outpt s' p = NotAnInput"
    by(auto simp add: HInv6_def)
  with t1
  show ?thesis
    by(simp add: HInv6_def)
qed

text{*
  $HInv1 \wedge HInv2 \wedge HInv2' \wedge HInv3 \wedge HInv4 \wedge HInv5 \wedge HInv6$
  is an invariant of $HNext$.
*}

lemma I2f:
  assumes nxt: "HNext s s'"
  and inv: "HInv1 s \<and> HInv2 s \<and> HInv2 s' \<and> HInv3 s \<and> HInv4 s \<and> HInv5 s \<and> HInv6 s"
  shows "HInv6 s'" using assms
  by(auto simp add: HNext_def Next_def,
     auto simp add: HInv2_def intro: HStartBallot_Inv6,
     auto intro: HPhase0Read_Inv6,
     auto simp add: HInv4_def intro: HPhase1or2Write_Inv6,
     auto simp add: Phase1or2Read_def
          intro: HPhase1or2ReadThen_Inv6
                 HPhase1or2ReadElse_Inv6,
     auto simp add: EndPhase1or2_def HInv1_def HInv5_def
          intro: HEndPhase1_Inv6
                 HEndPhase2_Inv6,
     auto intro: HFail_Inv6,
     auto intro: HEndPhase0_Inv6)

end


(*  Title:      Util_Set.thy
    Date:       Feb 2008
    Author:     David Trachtenherz
*)

section \<open>Convenience results for set quantifiers\<close>

theory Util_Set
imports Main
begin

subsection \<open>Some auxiliary results for HOL rules\<close>

lemma conj_disj_absorb: "(P \<and> Q \<or> Q) = Q" by blast
lemma disj_eq_distribL: "((a \<or> b) = (a \<or> c)) = (a \<or> (b = c))" by blast
lemma disj_eq_distribR: "((a \<or> c) = (b \<or> c)) = ((a = b) \<or> c)" by blast

subsubsection \<open>Some auxiliary results for  \<open>Let\<close>\<close>

lemma Let_swap: "f (let x=a in g x) = (let x=a in f (g x))" by simp

subsubsection \<open>Some auxiliary \<open>if\<close>-rules\<close>

lemma if_P': "\<lbrakk> P; x = z \<rbrakk> \<Longrightarrow> (if P then x else y) = z" by simp
lemma if_not_P': "\<lbrakk> \<not> P; y = z \<rbrakk> \<Longrightarrow> (if P then x else y) = z" by simp

lemma if_P_both: "\<lbrakk> Q x; Q y \<rbrakk> \<Longrightarrow> Q (if P then x else y)" by simp
lemma if_P_both_in_set: "\<lbrakk> x \<in> s; y \<in> s \<rbrakk> \<Longrightarrow> (if P then x else y) \<in> s" by simp

subsubsection \<open>Some auxiliary rules for function composition\<close>

lemma comp2_conv: "f1 \<circ> f2 = (\<lambda>x. f1 (f2 x))" by (simp add: comp_def)
lemma comp3_conv: "f1 \<circ> f2 \<circ> f3 = (\<lambda>x. f1 (f2 (f3 x)))" by (simp add: comp_def)

subsection \<open>Some auxiliary lemmata for quantifiers\<close>

subsubsection \<open>Auxiliary results for universal and existential quantifiers\<close>

lemma ball_cong2: "
  \<lbrakk> I \<subseteq> A; \<forall>x\<in>A. f x = g x \<rbrakk> \<Longrightarrow> (\<forall>x\<in>I. P (f x)) = (\<forall>x\<in>I. P (g x))" by fastforce
lemma bex_cong2: "
  \<lbrakk> I \<subseteq> A; \<forall>x\<in>I. f x = g x \<rbrakk> \<Longrightarrow> (\<exists>x\<in>I. P (f x)) = (\<exists>x\<in>I. P (g x))" by simp
lemma ball_all_cong: "
  \<forall>x. f x = g x \<Longrightarrow> (\<forall>x\<in>I. P (f x)) = (\<forall>x\<in>I. P (g x))" by simp
lemma bex_all_cong: "
  \<forall>x. f x = g x \<Longrightarrow> (\<exists>x\<in>I. P (f x)) = (\<exists>x\<in>I. P (g x))" by simp
lemma all_cong: "
  \<forall>x. f x = g x \<Longrightarrow> (\<forall>x. P (f x)) = (\<forall>x. P (g x))" by simp
lemma ex_cong: "
  \<forall>x. f x = g x \<Longrightarrow> (\<exists>x. P (f x)) = (\<exists>x. P (g x))" by simp

(*lemma all_eqI: "(\<And>x. P x = Q x) \<Longrightarrow> (\<forall>x. P x) = (\<forall>x. Q x)"*)
lemmas all_eqI = iff_allI
(*lemma ex_eqI: "(\<And>x. P x = Q x) \<Longrightarrow> (\<exists>x. P x) = (\<exists>x. Q x)"*)
lemmas ex_eqI = iff_exI

lemma all_imp_eqI: "
  \<lbrakk> P = P'; \<And>x. P x \<Longrightarrow> Q x = Q' x \<rbrakk> \<Longrightarrow>
  (\<forall>x. P x \<longrightarrow> Q x) = (\<forall>x. P' x \<longrightarrow> Q' x)"
by blast
lemma ex_imp_eqI: "
  \<lbrakk> P = P'; \<And>x. P x \<Longrightarrow> Q x = Q' x \<rbrakk> \<Longrightarrow>
  (\<exists>x. P x \<and> Q x) = (\<exists>x. P' x \<and> Q' x)"
by blast

subsubsection \<open>Auxiliary results for \<open>empty\<close> sets\<close>

lemma empty_imp_not_in: "x \<notin> {}" by blast
lemma ex_imp_not_empty: "\<exists>x. x \<in> A \<Longrightarrow> A \<noteq> {}" by blast
lemma in_imp_not_empty: "x \<in> A \<Longrightarrow> A \<noteq> {}" by blast
lemma not_empty_imp_ex: "A \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> A" by blast
lemma not_ex_in_conv: "(\<not> (\<exists>x. x \<in> A)) = (A = {})" by blast

subsubsection \<open>Some auxiliary results for subset and membership relation\<close>

lemma bex_subset_imp_bex: "\<lbrakk> \<exists>x\<in>A. P x; A \<subseteq> B \<rbrakk> \<Longrightarrow> \<exists>x\<in>B. P x" by blast
lemma bex_imp_ex: "\<exists>x\<in>A. P x \<Longrightarrow> \<exists>x. P x" by blast
lemma ball_subset_imp_ball: "\<lbrakk> \<forall>x\<in>B. P x; A \<subseteq> B \<rbrakk> \<Longrightarrow> \<forall>x\<in>A. P x" by blast
lemma all_imp_ball: "\<forall>x. P x \<Longrightarrow> \<forall>x\<in>A. P x" by blast

lemma mem_Collect_eq_not: "(a \<notin> {x. P x}) = (\<not> P a)" by blast
lemma Collect_not_in_imp_not: "a \<notin> {x. P x} \<Longrightarrow> \<not> P a" by blast
lemma Collect_not_imp_not_in: "\<not> P a \<Longrightarrow> a \<notin> {x. P x}" by blast
lemma Collect_is_subset: "{x \<in> A. P x} \<subseteq> A" by blast

end


section \<open>CNOT Circuit\<close>

theory CNOT
  imports
  Isabelle_Marries_Dirac.Basics
  Isabelle_Marries_Dirac.Quantum
  Isabelle_Marries_Dirac.More_Tensor
  Isabelle_Marries_Dirac.Deutsch
begin

abbreviation \<psi>\<^sub>0\<^sub>0 :: "complex Matrix.mat" where
"\<psi>\<^sub>0\<^sub>0 \<equiv> mat_of_cols_list 4 [[1,0,0,0]]"

abbreviation \<psi>\<^sub>1\<^sub>0 :: "complex Matrix.mat" where
"\<psi>\<^sub>1\<^sub>0 \<equiv> mat_of_cols_list 4 [[0,0,1,0]]"

abbreviation \<psi>\<^sub>1\<^sub>1 :: "complex Matrix.mat" where
"\<psi>\<^sub>1\<^sub>1 \<equiv> mat_of_cols_list 4 [[0,0,0,1]]"

lemma \<psi>\<^sub>0\<^sub>0_is_zero_zero:
  shows "\<psi>\<^sub>0\<^sub>0 = |zero\<rangle> \<Otimes> |zero\<rangle>"
proof
  show "dim_row \<psi>\<^sub>0\<^sub>0 = dim_row ( |zero\<rangle> \<Otimes> |zero\<rangle>)"
    by (simp add: mat_of_cols_list_def)
  show "dim_col \<psi>\<^sub>0\<^sub>0 = dim_col ( |zero\<rangle> \<Otimes> |zero\<rangle>)"
    by (simp add: mat_of_cols_list_def)
  fix i j:: nat
  assume "i < dim_row ( |zero\<rangle> \<Otimes> |zero\<rangle>)"
    and "j < dim_col ( |zero\<rangle> \<Otimes> |zero\<rangle>)"
  then have "i \<in> {0,1,2,3}" and "j = 0"
    using mat_of_cols_list_def by auto
  show "\<psi>\<^sub>0\<^sub>0 $$ (i,j) = ( |zero\<rangle> \<Otimes> |zero\<rangle>) $$ (i,j)"
    using ket_zero_is_state
    by auto
qed

lemma \<psi>\<^sub>0\<^sub>0_is_state:
  shows "state 2 \<psi>\<^sub>0\<^sub>0"
proof
  show "dim_col \<psi>\<^sub>0\<^sub>0 = 1"
    by (simp add: mat_of_cols_list_def)
  show "dim_row \<psi>\<^sub>0\<^sub>0 = 2\<^sup>2"
    by (simp add: mat_of_cols_list_def)
  have "\<parallel>Matrix.col |zero\<rangle> 0\<parallel> = 1"
    using ket_zero_is_state state.is_normal by auto
  thus "\<parallel>Matrix.col \<psi>\<^sub>0\<^sub>0 0\<parallel> = 1"
    using state.is_normal tensor_state2 \<psi>\<^sub>0\<^sub>0_is_zero_zero
    ket_zero_is_state by force
qed

subsection "First Operation"

abbreviation X_on_ctrl where "X_on_ctrl \<equiv> (X \<Otimes> Id 1)"

lemma X_tensor_id:
  defines d: "v \<equiv> mat_of_cols_list 4 [[0,0,1,0],
                                      [0,0,0,1],
                                      [1,0,0,0],
                                      [0,1,0,0]]"
  shows "X_on_ctrl = v"
proof
  show "dim_col X_on_ctrl = dim_col v"
    by (simp add: d X_def Id_def mat_of_cols_list_def)
  show "dim_row X_on_ctrl = dim_row v"
    by (simp add: d X_def Id_def mat_of_cols_list_def)
  fix i j:: nat assume "i < dim_row v"
                and "j < dim_col v"
  then have "i \<in> {0..<4} \<and> j \<in> {0..<4}"
    by (auto simp add: d mat_of_cols_list_def)
  thus "X_on_ctrl $$ (i, j) = v $$ (i, j)"
    by (auto simp add: d Id_def X_def
        mat_of_cols_list_def)
qed

lemma X_on_ctrl_is_gate:
  shows "gate 2 X_on_ctrl"
proof
  show "unitary X_on_ctrl"
    using X_is_gate id_is_gate gate_def tensor_gate
    by blast
  show "square_mat X_on_ctrl"
    using X_is_gate id_is_gate gate_def tensor_gate
    by blast
  show "dim_row X_on_ctrl = 2\<^sup>2"
    using X_tensor_id by (simp add: mat_of_cols_list_def)
qed

lemma \<psi>\<^sub>0\<^sub>0_to_\<psi>\<^sub>1\<^sub>0:
  shows "(X \<Otimes> Id 1) * \<psi>\<^sub>0\<^sub>0 = \<psi>\<^sub>1\<^sub>0"
proof
  fix i j:: nat
  assume "i < dim_row \<psi>\<^sub>1\<^sub>0" and "j < dim_col \<psi>\<^sub>1\<^sub>0"
  then have a0:"i \<in> {0,1,2,3} \<and> j = 0"
    by (auto simp add: mat_of_cols_list_def)
  then have "i < dim_row (X_on_ctrl) \<and> j < dim_col \<psi>\<^sub>0\<^sub>0"
    using mat_of_cols_list_def X_tensor_id by auto
  then have "(X_on_ctrl*\<psi>\<^sub>0\<^sub>0) $$ (i,j)
        = (\<Sum> k \<in> {0 ..< dim_vec \<psi>\<^sub>0\<^sub>0}. (Matrix.row (X_on_ctrl) i) $ k * (Matrix.col \<psi>\<^sub>0\<^sub>0 j) $ k)"
    by (auto simp: times_mat_def scalar_prod_def)
  thus "(X_on_ctrl * \<psi>\<^sub>0\<^sub>0) $$ (i, j) = \<psi>\<^sub>1\<^sub>0 $$ (i, j)"
    using  mat_of_cols_list_def X_tensor_id a0
    by (auto simp: diff_divide_distrib)
next
  show "dim_row (X_on_ctrl * \<psi>\<^sub>0\<^sub>0) = dim_row \<psi>\<^sub>1\<^sub>0"
    using X_tensor_id mat_of_cols_list_def by simp
  show "dim_col (X_on_ctrl * \<psi>\<^sub>0\<^sub>0) = dim_col \<psi>\<^sub>1\<^sub>0"
    using X_tensor_id mat_of_cols_list_def by simp
qed

lemma \<psi>\<^sub>1\<^sub>0_is_state:
  shows "state 2 \<psi>\<^sub>1\<^sub>0"
  using X_on_ctrl_is_gate \<psi>\<^sub>0\<^sub>0_is_state \<psi>\<^sub>0\<^sub>0_to_\<psi>\<^sub>1\<^sub>0
  by (metis gate_on_state_is_state)

subsection "Second Operation"

lemma \<psi>\<^sub>1\<^sub>0_to_\<psi>\<^sub>1\<^sub>1:
  shows "CNOT * \<psi>\<^sub>1\<^sub>0 = \<psi>\<^sub>1\<^sub>1"
proof
  show "dim_row (CNOT * \<psi>\<^sub>1\<^sub>0) = dim_row \<psi>\<^sub>1\<^sub>1"
    by (simp add: CNOT_def mat_of_cols_list_def)
  show "dim_col (CNOT * \<psi>\<^sub>1\<^sub>0) = dim_col \<psi>\<^sub>1\<^sub>1"
    by (simp add: CNOT_def mat_of_cols_list_def)
  fix i j:: nat
  assume "i < dim_row \<psi>\<^sub>1\<^sub>1" and "j < dim_col \<psi>\<^sub>1\<^sub>1"
  then have asm:"i \<in> {0,1,2,3} \<and> j = 0"
    by (auto simp add: mat_of_cols_list_def)
  then have "i < dim_row CNOT \<and> j < dim_col \<psi>\<^sub>1\<^sub>0"
    by (auto simp: mat_of_cols_list_def CNOT_def)
  then have "(CNOT * \<psi>\<^sub>1\<^sub>0) $$ (i,j)
        = (\<Sum> k \<in> {0 ..< dim_vec \<psi>\<^sub>1\<^sub>0}. (Matrix.row (CNOT) i) $ k * (Matrix.col \<psi>\<^sub>1\<^sub>0 j) $ k)"
    by (auto simp: times_mat_def scalar_prod_def)
  thus "(CNOT * \<psi>\<^sub>1\<^sub>0) $$ (i, j) = \<psi>\<^sub>1\<^sub>1 $$ (i, j)"
    using mat_of_cols_list_def asm
    by (auto simp add:  CNOT_def)
qed

lemma \<psi>\<^sub>1\<^sub>1_is_state:
  shows "state 2 \<psi>\<^sub>1\<^sub>1"
  using CNOT_is_gate \<psi>\<^sub>1\<^sub>0_is_state \<psi>\<^sub>1\<^sub>0_to_\<psi>\<^sub>1\<^sub>1
  by (metis gate_on_state_is_state)

subsection "Circuit"

definition circ:: "complex Matrix.mat" where
  "circ \<equiv> CNOT * ((X_on_ctrl) * ( |zero\<rangle> \<Otimes> |zero\<rangle>))"

lemma circ_result [simp]:
  shows "circ = \<psi>\<^sub>1\<^sub>1"
  using circ_def \<psi>\<^sub>0\<^sub>0_is_zero_zero \<psi>\<^sub>0\<^sub>0_to_\<psi>\<^sub>1\<^sub>0 \<psi>\<^sub>1\<^sub>0_to_\<psi>\<^sub>1\<^sub>1
  by simp

lemma circ_res_is_state:
  shows "state 2 circ"
  using \<psi>\<^sub>1\<^sub>1_is_state by auto

end