section\<open>Theory of Agents and Messages for Security Protocols against the General Attacker\<close>

theory MessageGA imports Main begin

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

type_synonym
  key = nat

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

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

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

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

datatype  \<comment> \<open>We only allow for any number of friendly agents\<close>
  agent = Friend nat

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

text\<open>Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...\<close>
syntax
  "_MTuple"      :: "['a, args] => '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 HPair :: "[msg,msg] => msg" ("(4Hash[_] /_)" [0, 1000]) where
    \<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
    "Hash[X] Y == \<lbrace> Hash\<lbrace>X,Y\<rbrace>, Y\<rbrace>"

definition keysFor :: "msg set => 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}"

subsection\<open>Inductive definition of all parts of a message\<close>

inductive_set
  parts :: "msg set => 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: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

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

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

subsection\<open>keysFor operator\<close>

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

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

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

text\<open>Monotonicity\<close>
lemma keysFor_mono: "G \<subseteq> H \<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_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

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

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

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

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

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

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H \<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"
by (metis insert_is_Un parts_Un)

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"
by (metis Un_commute Un_empty_right Un_insert_right insert_is_Un parts_Un)

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

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

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

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 "parts(G\<union>H)"} in the assumption.\<close>
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]

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

subsubsection\<open>Idempotence 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)"
by (metis parts_idem parts_increasing parts_mono subset_trans)

lemma parts_trans: "[| X \<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (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 \<Longrightarrow> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

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

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

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

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

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

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

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

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

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

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
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 msg)
apply (simp_all (no_asm_simp) add: exI parts_insert2)
txt\<open>Nonce case\<close>
apply (metis Suc_n_not_le_n)
txt\<open>MPair case: metis works out the necessary sum itself!\<close>
apply (metis le_trans nat_le_linear)
done

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

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

inductive_set
  analz :: "msg set => 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]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> 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"
by (metis analz_increasing analz_subset_parts equalityI parts_mono parts_subset_iff)

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

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

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

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

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

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

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

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

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

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

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

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

text\<open>Can only pull out Keys if they are not needed to decrypt the rest\<close>
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) \<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"analz (insert
(Crypt K X) H)"}\<close>
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

text\<open>This rule supposes "for the sake of argument" that we have the key.\<close>
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
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)"
by (metis analz_idem analz_increasing analz_mono subset_trans)

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

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

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

text\<open>This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated.\<close>
lemma analz_insert_eq: "X \<in> analz H \<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 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])

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

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

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

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

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

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

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

subsubsection\<open>Unions\<close>

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

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

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

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

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

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

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

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

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<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

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

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

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

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

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

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (metis Fake_parts_insert subsetD)

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

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

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

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

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

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

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

subsubsection\<open>Freeness\<close>

lemma Agent_neq_HPair: "Agent A ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Nonce_neq_HPair: "Nonce N ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Number_neq_HPair: "Number N ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Key_neq_HPair: "Key K ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Hash_neq_HPair: "Hash Z ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemma Crypt_neq_HPair: "Crypt K X' ~= Hash[X] Y"
by (unfold HPair_def, simp)

lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
                    Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

declare keyfree.intros [intro]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

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

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

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

end


theory Closure
  imports Regions
begin

section \<open>Correct Approximation of Zones with \<open>\<alpha>\<close>-regions\<close>

locale AlphaClosure =
  fixes X k \<R> and V :: "('c, t) cval set"
  defines "\<R> \<equiv> {region X I r | I r. valid_region X k I r}"
  defines "V \<equiv> {v . \<forall> x \<in> X. v x \<ge> 0}"
  assumes finite: "finite X"
begin

lemmas set_of_regions_spec = set_of_regions[OF _ _ _ finite, of _ k, folded \<R>_def]
lemmas region_cover_spec = region_cover[of X _ k, folded \<R>_def]
lemmas region_unique_spec = region_unique[of \<R> X k, folded \<R>_def, simplified]
lemmas regions_closed'_spec = regions_closed'[of \<R> X k, folded \<R>_def, simplified]

lemma valid_regions_distinct_spec:
  "R \<in> \<R> \<Longrightarrow> R' \<in> \<R> \<Longrightarrow> v \<in> R \<Longrightarrow> v \<in> R' \<Longrightarrow> R = R'"
unfolding \<R>_def using valid_regions_distinct
by auto (drule valid_regions_distinct, assumption+, simp)+

definition cla ("Closure\<^sub>\<alpha> _" [71] 71)
where
  "cla Z = \<Union> {R \<in> \<R>. R \<inter> Z \<noteq> {}}"

subsubsection \<open>The nice and easy properties proved by Bouyer\<close>

lemma closure_constraint_id:
  "\<forall>(x, m)\<in>collect_clock_pairs g. m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat> \<Longrightarrow> Closure\<^sub>\<alpha> \<lbrace>g\<rbrace> = \<lbrace>g\<rbrace> \<inter> V"
proof goal_cases
  case 1
  show ?case
  proof auto
    fix v assume v: "v \<in> Closure\<^sub>\<alpha> \<lbrace>g\<rbrace>"
    then obtain R where R: "v \<in> R" "R \<in> \<R>" "R \<inter> \<lbrace>g\<rbrace> \<noteq> {}" unfolding cla_def by auto
    with ccompatible[OF 1, folded \<R>_def] show "v \<in> \<lbrace>g\<rbrace>" unfolding ccompatible_def by auto
    from R show "v \<in> V" unfolding V_def \<R>_def by auto
  next
    fix v assume v: "v \<in> \<lbrace>g\<rbrace>" "v \<in> V"
    with region_cover[of X v k, folded \<R>_def] obtain R where "R \<in> \<R>" "v \<in> R" unfolding V_def by auto
    then show "v \<in> Closure\<^sub>\<alpha> \<lbrace>g\<rbrace>" unfolding cla_def using v by auto
  qed
qed

lemma closure_id':
  "Z \<noteq> {} \<Longrightarrow> Z \<subseteq> R \<Longrightarrow> R \<in> \<R> \<Longrightarrow> Closure\<^sub>\<alpha> Z = R"
proof goal_cases
  case 1
  note A = this
  then have "R \<subseteq> Closure\<^sub>\<alpha> Z" unfolding cla_def by auto
  moreover
  { fix R' assume R': "Z \<inter> R' \<noteq> {}" "R' \<in> \<R>" "R \<noteq> R'"
    with A obtain v where "v \<in> R" "v \<in> R'" by auto
    with \<R>_regions_distinct[OF _ A(3) this(1) R'(2-)] \<R>_def have False by auto
  }
  ultimately show ?thesis unfolding cla_def by auto
qed

lemma closure_id:
  "Closure\<^sub>\<alpha> Z \<noteq> {} \<Longrightarrow> Z \<subseteq> R \<Longrightarrow> R \<in> \<R> \<Longrightarrow> Closure\<^sub>\<alpha> Z = R"
proof goal_cases
  case 1
  then have "Z \<noteq> {}" unfolding cla_def by auto
  with 1 closure_id' show ?case by blast
qed

lemma closure_update_mono:
  "Z \<subseteq> V \<Longrightarrow> set r \<subseteq> X \<Longrightarrow> zone_set (Closure\<^sub>\<alpha> Z) r \<subseteq> Closure\<^sub>\<alpha>(zone_set Z r)"
proof -
  assume A: "Z \<subseteq> V" "set r \<subseteq> X"
  let ?U = "{R \<in> \<R>. Z \<inter> R \<noteq> {}}"
  from A(1) region_cover_spec  have "\<forall> v \<in> Z. \<exists> R. R \<in> \<R> \<and> v \<in> R" unfolding V_def by auto
  then have "Z = \<Union> {Z \<inter> R | R. R \<in> ?U}"
  proof (auto, goal_cases)
    case (1 v)
    then obtain R where "R \<in> \<R>" "v \<in> R" by auto
    moreover with 1 have "Z \<inter> R \<noteq> {}" "v \<in> Z \<inter> R" by auto
    ultimately show ?case by auto
  qed
  then obtain U where U: "Z = \<Union> {Z \<inter> R | R. R \<in> U}" "\<forall> R \<in> U. R \<in> \<R>" by blast
  { fix R assume R: "R \<in> U"
    { fix v' assume v': "v' \<in> zone_set (Closure\<^sub>\<alpha> (Z \<inter> R)) r - Closure\<^sub>\<alpha>(zone_set (Z \<inter> R) r)"
      then obtain v where *:
        "v \<in> Closure\<^sub>\<alpha> (Z \<inter> R)" "v' = [r \<rightarrow> 0]v"
      unfolding zone_set_def by auto
      with closure_id[of "Z \<inter> R" R] R U(2) have **:
        "Closure\<^sub>\<alpha> (Z \<inter> R) = R" "Closure\<^sub>\<alpha> (Z \<inter> R) \<in> \<R>"
      by fastforce+
      with region_set'_id[OF _ *(1) finite _ _ A(2), of k 0, folded \<R>_def, OF this(2)]
      have ***: "zone_set R r \<in> \<R>" "[r\<rightarrow>0]v \<in> zone_set R r"
      unfolding zone_set_def region_set'_def by auto
      from * have "Z \<inter> R \<noteq> {}" unfolding cla_def by auto
      then have "zone_set (Z \<inter> R) r \<noteq> {}" unfolding zone_set_def by auto
      from closure_id'[OF this _ ***(1)] have "Closure\<^sub>\<alpha> zone_set (Z \<inter> R) r = zone_set R r"
      unfolding zone_set_def by auto
      with v' **(1) have False by auto
    }
    then have "zone_set (Closure\<^sub>\<alpha> (Z \<inter> R)) r \<subseteq> Closure\<^sub>\<alpha>(zone_set (Z \<inter> R) r)" by auto
  } note Z_i = this
  from U(1) have "Closure\<^sub>\<alpha> Z = \<Union> {Closure\<^sub>\<alpha> (Z \<inter> R) | R. R \<in> U}" unfolding cla_def by auto
  then have "zone_set (Closure\<^sub>\<alpha> Z) r = \<Union> {zone_set (Closure\<^sub>\<alpha> (Z \<inter> R)) r | R. R \<in> U}"
  unfolding zone_set_def by auto
  also have "\<dots> \<subseteq> \<Union> {Closure\<^sub>\<alpha>(zone_set (Z \<inter> R) r) | R. R \<in> U}" using Z_i by auto
  also have "\<dots> = Closure\<^sub>\<alpha> \<Union> {(zone_set (Z \<inter> R) r) | R. R \<in> U}" unfolding cla_def by auto
  also have "\<dots> = Closure\<^sub>\<alpha> zone_set (\<Union> {Z \<inter> R| R. R \<in> U}) r"
  proof goal_cases
    case 1
    have "zone_set (\<Union> {Z \<inter> R| R. R \<in> U}) r = \<Union> {(zone_set (Z \<inter> R) r) | R. R \<in> U}"
    unfolding zone_set_def by auto
    then show ?case by auto
  qed
  finally show "zone_set (Closure\<^sub>\<alpha> Z) r \<subseteq> Closure\<^sub>\<alpha>(zone_set Z r)" using U by simp
qed

lemma SuccI3:
  "R \<in> \<R> \<Longrightarrow> v \<in> R \<Longrightarrow> t \<ge> 0 \<Longrightarrow> (v \<oplus> t) \<in> R' \<Longrightarrow> R' \<in> \<R> \<Longrightarrow> R' \<in> Succ \<R> R"
 apply (intro SuccI2[of \<R> X k, folded \<R>_def, simplified])
    apply assumption+
   apply (intro region_unique[of \<R> X k, folded \<R>_def, simplified, symmetric])
by assumption+

lemma closure_delay_mono:
  "Z \<subseteq> V \<Longrightarrow> (Closure\<^sub>\<alpha> Z)\<^sup>\<up> \<subseteq> Closure\<^sub>\<alpha> (Z\<^sup>\<up>)"
proof
  fix v assume v: "v \<in> (Closure\<^sub>\<alpha> Z)\<^sup>\<up>" and Z: "Z \<subseteq> V"
  then obtain u u' t R where A:
    "u \<in> Closure\<^sub>\<alpha> Z" "v = (u \<oplus> t)" "u \<in> R" "u' \<in> R" "R \<in> \<R>" "u' \<in> Z" "t \<ge> 0"
  unfolding cla_def zone_delay_def by blast
  from A(3,5) have "\<forall> x \<in> X. u x \<ge> 0" unfolding \<R>_def by fastforce
  with region_cover_spec[of v] A(2,7) obtain R' where R':
    "R' \<in> \<R>" "v \<in> R'"
  unfolding cval_add_def by auto
  with set_of_regions_spec[OF A(5,4), OF SuccI3, of u] A obtain t where t:
    "t \<ge> 0" "[u' \<oplus> t]\<^sub>\<R> = R'"
  by auto
  with A have "(u' \<oplus> t) \<in> Z\<^sup>\<up>" unfolding zone_delay_def by auto
  moreover from regions_closed'_spec[OF A(5,4)] t have "(u' \<oplus> t) \<in> R'" by auto
  ultimately have "R' \<inter> (Z\<^sup>\<up>) \<noteq> {}" by auto
  with R' show "v \<in> Closure\<^sub>\<alpha> (Z\<^sup>\<up>)" unfolding cla_def by auto
qed

lemma region_V: "R \<in> \<R> \<Longrightarrow> R \<subseteq> V" using V_def \<R>_def region.cases by auto

lemma closure_V:
  "Closure\<^sub>\<alpha> Z \<subseteq> V"
unfolding cla_def using region_V by auto

lemma closure_V_int:
  "Closure\<^sub>\<alpha> Z = Closure\<^sub>\<alpha> (Z \<inter> V)"
unfolding cla_def using region_V by auto

lemma closure_constraint_mono:
  "Closure\<^sub>\<alpha> g = g \<Longrightarrow> g \<inter> (Closure\<^sub>\<alpha> Z) \<subseteq> Closure\<^sub>\<alpha> (g \<inter> Z)"
unfolding cla_def by auto

lemma closure_constraint_mono':
  assumes "Closure\<^sub>\<alpha> g = g \<inter> V"
  shows "g \<inter> (Closure\<^sub>\<alpha> Z) \<subseteq> Closure\<^sub>\<alpha> (g \<inter> Z)"
proof -
  from assms closure_V_int have "Closure\<^sub>\<alpha> (g \<inter> V) = g \<inter> V" by auto
  from closure_constraint_mono[OF this, of Z] have
    "g \<inter> (V \<inter> Closure\<^sub>\<alpha> Z) \<subseteq> Closure\<^sub>\<alpha> (g \<inter> Z \<inter> V)"
  by (metis Int_assoc Int_commute)
  with closure_V[of Z] closure_V_int[of "g \<inter> Z"] show ?thesis by auto
qed

lemma cla_empty_iff:
  "Z \<subseteq> V \<Longrightarrow> Z = {} \<longleftrightarrow> Closure\<^sub>\<alpha> Z = {}"
unfolding cla_def V_def using region_cover_spec by fast

lemma closure_involutive_aux':
  "\<exists> U. U \<subseteq> \<R> \<and> Closure\<^sub>\<alpha> Z = \<Union> U"
unfolding cla_def by (rule exI[where x = "{R \<in> \<R>. R \<inter> Z \<noteq> {}}"]) auto

lemma closure_involutive:
  "Closure\<^sub>\<alpha> Closure\<^sub>\<alpha> Z = Closure\<^sub>\<alpha> Z"
using closure_involutive_aux closure_involutive_aux' by metis

lemma closure_involutive':
  "Z \<subseteq> Closure\<^sub>\<alpha> W \<Longrightarrow> Closure\<^sub>\<alpha> Z \<subseteq> Closure\<^sub>\<alpha> W"
unfolding cla_def using valid_regions_distinct_spec by fast

lemma closure_subs:
  "Z \<subseteq> V \<Longrightarrow> Z \<subseteq> Closure\<^sub>\<alpha> Z"
unfolding cla_def V_def using region_cover_spec by fast

lemma cla_mono':
  "Z' \<subseteq> V \<Longrightarrow> Z \<subseteq> Z' \<Longrightarrow> Closure\<^sub>\<alpha> Z \<subseteq> Closure\<^sub>\<alpha> Z'"
by (meson closure_involutive' closure_subs subset_trans)

lemma cla_mono:
  "Z \<subseteq> Z' \<Longrightarrow> Closure\<^sub>\<alpha> Z \<subseteq> Closure\<^sub>\<alpha> Z'"
using closure_V_int cla_mono'[of "Z' \<inter> V" "Z \<inter> V"] by auto

section \<open>A New Zone Semantics Abstracting with \<open>Closure\<^sub>\<alpha>\<close>\<close>

subsection \<open>Single step\<close>

inductive step_z_alpha ::
  "('a, 'c, t, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>_, _\<rangle>" [61,61,61] 61)
where
  step_alpha: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l', Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l', Closure\<^sub>\<alpha> Z'\<rangle>"

inductive_cases[elim!]: "A \<turnstile> \<langle>l, u\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l',u'\<rangle>"

declare step_z_alpha.intros[intro]

lemma up_V: "Z \<subseteq> V \<Longrightarrow> Z\<^sup>\<up> \<subseteq> V"
unfolding V_def zone_delay_def cval_add_def by auto

lemma reset_V: "Z \<subseteq> V \<Longrightarrow> (zone_set Z r) \<subseteq> V"
unfolding V_def unfolding zone_set_def by (induction r, auto)

lemma step_z_V: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<subseteq> V"
 apply (induction rule: step_z.induct)
  apply (rule le_infI1)
  apply (rule up_V)
  apply blast
 apply (rule le_infI1)
 apply (rule reset_V)
by blast

text \<open>Single-step soundness and completeness follows trivially from \<open>cla_empty_iff\<close>.\<close>

lemma step_z_alpha_sound:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<noteq> {} \<Longrightarrow> \<exists> Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z''\<rangle> \<and> Z'' \<noteq> {}"
 apply (induction rule: step_z_alpha.induct)
  apply (frule step_z_V)
  apply assumption
 apply (rotate_tac 3)
 apply (drule cla_empty_iff)
by auto

lemma step_z_alpha_complete:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<noteq> {} \<Longrightarrow> \<exists> Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l',Z''\<rangle> \<and> Z'' \<noteq> {}"
 apply (frule step_z_V)
  apply assumption
 apply (rotate_tac 3)
 apply (drule cla_empty_iff)
by auto

lemma zone_set_mono:
  "A \<subseteq> B \<Longrightarrow> zone_set A r \<subseteq> zone_set B r"
unfolding zone_set_def by auto

lemma zone_delay_mono:
  "A \<subseteq> B \<Longrightarrow> A\<^sup>\<up> \<subseteq> B\<^sup>\<up>"
unfolding zone_delay_def by auto

subsection \<open>Multi step\<close>

inductive
  steps_z_alpha :: "('a, 'c, t, 's) ta \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> 's \<Rightarrow> ('c, t) zone \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>_, _\<rangle>" [61,61,61] 61)
where
  refl: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l, Z\<rangle>" |
  step: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l', Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l'', Z''\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l'', Z''\<rangle>"

declare steps_z_alpha.intros[intro]

lemma subset_int_mono: "A \<subseteq> B \<Longrightarrow> A \<inter> C \<subseteq> B \<inter> C" by blast

text \<open>P. Bouyer's calculation for @{term "Post(Closure\<^sub>\<alpha> Z, e) \<subseteq> Closure\<^sub>\<alpha>(Post (Z, e))"}\<close>
text \<open>This is now obsolete as we argue solely with monotonicty of \<open>steps_z\<close> w.r.t \<open>Closure\<^sub>\<alpha>\<close>\<close>

lemma calc:
  "valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> A \<turnstile> \<langle>l, Closure\<^sub>\<alpha> Z\<rangle> \<leadsto> \<langle>l', Z'\<rangle>
  \<Longrightarrow> \<exists>Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l', Z''\<rangle> \<and> Z' \<subseteq> Z''"
proof (cases rule: step_z.cases, assumption, goal_cases)
  case 1
  note A = this
  from A(1) have "\<forall>(x, m)\<in>clkp_set A. m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
  by (fastforce elim: valid_abstraction.cases)
  then have "\<forall>(x, m)\<in>collect_clock_pairs (inv_of A l). m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
  unfolding clkp_set_def collect_clki_def inv_of_def by auto
  from closure_constraint_id[OF this] have *: "Closure\<^sub>\<alpha> \<lbrace>inv_of A l\<rbrace> = \<lbrace>inv_of A l\<rbrace> \<inter> V" .
  from closure_constraint_mono'[OF *, of Z] have
    "(Closure\<^sub>\<alpha> Z) \<inter> {u. u \<turnstile> inv_of A l} \<subseteq> Closure\<^sub>\<alpha> (Z \<inter> {u. u \<turnstile> inv_of A l})"
  unfolding ccval_def by (subst Int_commute) (subst (asm) (2) Int_commute, assumption)
  moreover have "\<dots>\<^sup>\<up> \<subseteq> Closure\<^sub>\<alpha> ((Z \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up>)" using A(2) by (blast intro!: closure_delay_mono)
  ultimately have "Z' \<subseteq> Closure\<^sub>\<alpha> ((Z \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l})"
  using closure_constraint_mono'[OF *, of "(Z \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up>"] unfolding ccval_def
   apply (subst A(5))
   apply (subst (asm) (5 7) Int_commute)
   apply (rule subset_trans)
    defer
    apply assumption
   apply (subst subset_int_mono)
    defer
    apply rule
   apply (rule subset_trans)
    defer
    apply assumption
   apply (rule zone_delay_mono)
   apply assumption
  done
  with A(4,3) show ?thesis by auto
next
  case (2 g a r)
  note A = this
  from A(1) have *:
    "\<forall>(x, m)\<in>clkp_set A. m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
    "collect_clkvt (trans_of A) \<subseteq> X"
    "finite X"
  by (auto elim: valid_abstraction.cases)
  from *(1) A(5) have "\<forall>(x, m)\<in>collect_clock_pairs (inv_of A l'). m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
  unfolding clkp_set_def collect_clki_def inv_of_def by fastforce
  from closure_constraint_id[OF this] have **: "Closure\<^sub>\<alpha> \<lbrace>inv_of A l'\<rbrace> = \<lbrace>inv_of A l'\<rbrace> \<inter> V" .
  from *(1) A(5) have "\<forall>(x, m)\<in>collect_clock_pairs g. m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
  unfolding clkp_set_def collect_clkt_def by fastforce
  from closure_constraint_id[OF this] have ***: "Closure\<^sub>\<alpha> \<lbrace>g\<rbrace> = \<lbrace>g\<rbrace> \<inter> V" .
  from *(2) A(5) have ****: "set r \<subseteq> X" unfolding collect_clkvt_def by fastforce
  from closure_constraint_mono'[OF ***, of Z] have
    "(Closure\<^sub>\<alpha> Z) \<inter> {u. u \<turnstile> g} \<subseteq> Closure\<^sub>\<alpha> (Z \<inter> {u. u \<turnstile> g})" unfolding ccval_def
  by (subst Int_commute) (subst (asm) (2) Int_commute, assumption)
  moreover have "zone_set \<dots> r \<subseteq> Closure\<^sub>\<alpha> (zone_set (Z \<inter> {u. u \<turnstile> g}) r)" using **** A(2)
  by (intro closure_update_mono, auto)
  ultimately have "Z' \<subseteq> Closure\<^sub>\<alpha> (zone_set (Z \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'})"
  using closure_constraint_mono'[OF **, of "zone_set (Z \<inter> {u. u \<turnstile> g}) r"] unfolding ccval_def
    apply (subst A(4))
    apply (subst (asm) (5 7) Int_commute)
    apply (rule subset_trans)
     defer
     apply assumption
    apply (subst subset_int_mono)
     defer
     apply rule
    apply (rule subset_trans)
     defer
     apply assumption
    apply (rule zone_set_mono)
    apply assumption
  done
  with A(5) show ?thesis by auto
qed

text \<open>
  Turning P. Bouyers argument for multiple steps into an inductive proof is not direct.
  With this initial argument we can get to a point where the induction hypothesis is applicable.
  This breaks the "information hiding" induced by the different variants of steps.
\<close>

lemma steps_z_alpha_closure_involutive'_aux:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle> \<Longrightarrow> Closure\<^sub>\<alpha> Z \<subseteq> Closure\<^sub>\<alpha> W \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V
  \<Longrightarrow> \<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',W'\<rangle> \<and> Closure\<^sub>\<alpha> Z' \<subseteq> Closure\<^sub>\<alpha> W'"
proof (induction rule: step_z.induct)
  case A: (step_t_z A l Z)
  let ?Z' = "(Z \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  let ?W' = "(W \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  from \<R>_def have \<R>_def': "\<R> = {region X I r |I r. valid_region X k I r}" by simp
  have step_z: "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l,?W'\<rangle>" by auto
  moreover have "Closure\<^sub>\<alpha> ?Z' \<subseteq> Closure\<^sub>\<alpha> ?W'"
  proof
    fix v assume v: "v \<in> Closure\<^sub>\<alpha> ?Z'"
    then obtain R' v' where 1: "R' \<in> \<R>" "v \<in> R'" "v' \<in> R'" "v' \<in> ?Z'" unfolding cla_def by auto
    then obtain u d where
      "u \<in> Z" and v': "v' = u \<oplus> d" "u \<turnstile> inv_of A l" "u \<oplus> d \<turnstile> inv_of A l" "0 \<le> d"
    unfolding zone_delay_def by blast
    with closure_subs[OF A(3)] A(1) obtain u' R where u': "u' \<in> W" "u \<in> R" "u' \<in> R" "R \<in> \<R>"
    unfolding cla_def by blast
    then have "\<forall>x\<in>X. 0 \<le> u x" unfolding \<R>_def by fastforce
    from region_cover'[OF \<R>_def' this] have R: "[u]\<^sub>\<R> \<in> \<R>" "u \<in> [u]\<^sub>\<R>" by auto
    from SuccI2[OF \<R>_def' this(2,1) v'(4), of "[v']\<^sub>\<R>"] v'(1) have v'1:
      "[v']\<^sub>\<R> \<in> Succ \<R> ([u]\<^sub>\<R>)" "[v']\<^sub>\<R> \<in> \<R>"
    by auto
    from regions_closed'_spec[OF R(1,2) v'(4)] v'(1) have v'2: "v' \<in> [v']\<^sub>\<R>" by simp
    from A(2) have *:
      "\<forall>(x, m)\<in>clkp_set A. m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
      "collect_clkvt (trans_of A) \<subseteq> X"
      "finite X"
    by (auto elim: valid_abstraction.cases)
    from *(1) u'(2) have "\<forall>(x, m)\<in>collect_clock_pairs (inv_of A l). m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
    unfolding clkp_set_def collect_clki_def inv_of_def by fastforce
    from ccompatible[OF this, folded \<R>_def'] v'1(2) v'2 v'(1,2,3) R have 3:
      "[v']\<^sub>\<R> \<subseteq> \<lbrace>inv_of A l\<rbrace>" "([u]\<^sub>\<R>) \<subseteq> \<lbrace>inv_of A l\<rbrace>"
    unfolding ccompatible_def ccval_def by auto
    with A v'1 R(1) \<R>_def' have "A,\<R> \<turnstile> \<langle>l, ([u]\<^sub>\<R>)\<rangle> \<leadsto> \<langle>l,([v']\<^sub>\<R>)\<rangle>" by auto
    with valid_regions_distinct_spec[OF v'1(2) 1(1) v'2 1(3)] region_unique_spec[OF u'(2,4)]
    have step_r: "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto> \<langle>l, R'\<rangle>" and 2: "[v']\<^sub>\<R> = R'" "[u]\<^sub>\<R> = R" by auto
    from set_of_regions_spec[OF u'(4,3)] v'1(1) 2 obtain t where t: "t \<ge> 0" "[u' \<oplus> t]\<^sub>\<R> = R'" by auto
    with regions_closed'_spec[OF u'(4,3) this(1)] step_t_r(1) have *: "u' \<oplus> t \<in> R'" by auto
    with t(1) 3 2 u'(1,3) have "A \<turnstile> \<langle>l, u'\<rangle> \<rightarrow> \<langle>l, u' \<oplus> t\<rangle>" "u' \<oplus> t \<in> ?W'"
    unfolding zone_delay_def ccval_def by auto
    with * 1(1) have "R' \<subseteq> Closure\<^sub>\<alpha> ?W'" unfolding cla_def by auto
    with 1(2) show "v \<in> Closure\<^sub>\<alpha> ?W'" ..
  qed
  ultimately show ?case by auto
next
  case A: (step_a_z A l g a r l' Z)
  let ?Z' = "zone_set (Z \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  let ?W' = "zone_set (W \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  from \<R>_def have \<R>_def': "\<R> = {region X I r |I r. valid_region X k I r}" by simp
  from A(1) have step_z: "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',?W'\<rangle>" by auto
  moreover have "Closure\<^sub>\<alpha> ?Z' \<subseteq> Closure\<^sub>\<alpha> ?W'"
  proof
    fix v assume v: "v \<in> Closure\<^sub>\<alpha> ?Z'"
    then obtain R' v' where 1: "R' \<in> \<R>" "v \<in> R'" "v' \<in> R'" "v' \<in> ?Z'" unfolding cla_def by auto
    then obtain u where
      "u \<in> Z" and v': "v' = [r\<rightarrow>0]u" "u \<turnstile> g" "v' \<turnstile> inv_of A l'"
    unfolding zone_set_def by blast
    let ?R'= "region_set' (([u]\<^sub>\<R>) \<inter> {u. u \<turnstile> g}) r 0 \<inter> {u. u \<turnstile> inv_of A l'}"
    from \<open>u \<in> Z\<close> closure_subs[OF A(4)] A(2) obtain u' R where u': "u' \<in> W" "u \<in> R" "u' \<in> R" "R \<in> \<R>"
    unfolding cla_def by blast
    then have "\<forall>x\<in>X. 0 \<le> u x" unfolding \<R>_def by fastforce
    from region_cover'[OF \<R>_def' this] have R: "[u]\<^sub>\<R> \<in> \<R>" "u \<in> [u]\<^sub>\<R>" by auto
    from step_r_complete_aux[OF \<R>_def' A(3) this(2,1) A(1) v'(2)] v'
    have *: "[u]\<^sub>\<R> = ([u]\<^sub>\<R>) \<inter> {u. u \<turnstile> g}" "?R' = region_set' ([u]\<^sub>\<R>) r 0" "?R' \<in> \<R>" by auto
    from \<R>_def' A(3) have "collect_clkvt (trans_of A) \<subseteq> X" "finite X"
    by (auto elim: valid_abstraction.cases)
    with A(1) have r: "set r \<subseteq> X" unfolding collect_clkvt_def by fastforce
    from * v'(1) R(2) have "v' \<in> ?R'" unfolding region_set'_def by auto
    moreover have "A,\<R> \<turnstile> \<langle>l,([u]\<^sub>\<R>)\<rangle> \<leadsto> \<langle>l',?R'\<rangle>" using R(1) \<R>_def' A(1,3) v'(2) by auto
    thm valid_regions_distinct_spec
    with valid_regions_distinct_spec[OF *(3) 1(1) \<open>v' \<in> ?R'\<close> 1(3)] region_unique_spec[OF u'(2,4)]
    have 2: "?R' = R'" "[u]\<^sub>\<R> = R" by auto
    with * u' have *: "[r\<rightarrow>0]u' \<in> ?R'" "u' \<turnstile> g" "[r\<rightarrow>0]u' \<turnstile> inv_of A l'"
    unfolding region_set'_def by auto
    with A(1) have "A \<turnstile> \<langle>l, u'\<rangle> \<rightarrow> \<langle>l',[r\<rightarrow>0]u'\<rangle>" apply (intro step.intros(1)) apply rule by auto
    moreover from * u'(1) have "[r\<rightarrow>0]u' \<in> ?W'" unfolding zone_set_def by auto
    ultimately have "R' \<subseteq> Closure\<^sub>\<alpha> ?W'" using *(1) 1(1) 2(1) unfolding cla_def by auto
    with 1(2) show "v \<in> Closure\<^sub>\<alpha> ?W'" ..
  qed
  ultimately show ?case by meson
qed

lemma steps_z_alpha_closure_involutive'_aux':
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle> \<Longrightarrow> Closure\<^sub>\<alpha> Z \<subseteq> Closure\<^sub>\<alpha> W \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> W \<subseteq> Z
  \<Longrightarrow> \<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',W'\<rangle> \<and> Closure\<^sub>\<alpha> Z' \<subseteq> Closure\<^sub>\<alpha> W' \<and> W' \<subseteq> Z'"
proof (induction rule: step_z.induct)
  case A: (step_t_z A l Z)
  let ?Z' = "(Z \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  let ?W' = "(W \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  from \<R>_def have \<R>_def': "\<R> = {region X I r |I r. valid_region X k I r}" by simp
  have step_z: "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l,?W'\<rangle>" by auto
  moreover have "Closure\<^sub>\<alpha> ?Z' \<subseteq> Closure\<^sub>\<alpha> ?W'"
  proof
    fix v assume v: "v \<in> Closure\<^sub>\<alpha> ?Z'"
    then obtain R' v' where 1: "R' \<in> \<R>" "v \<in> R'" "v' \<in> R'" "v' \<in> ?Z'" unfolding cla_def by auto
    then obtain u d where
      "u \<in> Z" and v': "v' = u \<oplus> d" "u \<turnstile> inv_of A l" "u \<oplus> d \<turnstile> inv_of A l" "0 \<le> d"
    unfolding zone_delay_def by blast
    with closure_subs[OF A(3)] A(1) obtain u' R where u': "u' \<in> W" "u \<in> R" "u' \<in> R" "R \<in> \<R>"
    unfolding cla_def by blast
    then have "\<forall>x\<in>X. 0 \<le> u x" unfolding \<R>_def by fastforce
    from region_cover'[OF \<R>_def' this] have R: "[u]\<^sub>\<R> \<in> \<R>" "u \<in> [u]\<^sub>\<R>" by auto
    from SuccI2[OF \<R>_def' this(2,1) v'(4), of "[v']\<^sub>\<R>"] v'(1) have v'1:
      "[v']\<^sub>\<R> \<in> Succ \<R> ([u]\<^sub>\<R>)" "[v']\<^sub>\<R> \<in> \<R>"
    by auto
    from regions_closed'_spec[OF R(1,2) v'(4)] v'(1) have v'2: "v' \<in> [v']\<^sub>\<R>" by simp
    from A(2) have *:
      "\<forall>(x, m)\<in>clkp_set A. m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
      "collect_clkvt (trans_of A) \<subseteq> X"
      "finite X"
    by (auto elim: valid_abstraction.cases)
    from *(1) u'(2) have "\<forall>(x, m)\<in>collect_clock_pairs (inv_of A l). m \<le> real (k x) \<and> x \<in> X \<and> m \<in> \<nat>"
    unfolding clkp_set_def collect_clki_def inv_of_def by fastforce
    from ccompatible[OF this, folded \<R>_def'] v'1(2) v'2 v'(1,2,3) R have 3:
      "[v']\<^sub>\<R> \<subseteq> \<lbrace>inv_of A l\<rbrace>" "([u]\<^sub>\<R>) \<subseteq> \<lbrace>inv_of A l\<rbrace>"
    unfolding ccompatible_def ccval_def by auto
    with A v'1 R(1) \<R>_def' have "A,\<R> \<turnstile> \<langle>l, ([u]\<^sub>\<R>)\<rangle> \<leadsto> \<langle>l,([v']\<^sub>\<R>)\<rangle>" by auto
    with valid_regions_distinct_spec[OF v'1(2) 1(1) v'2 1(3)] region_unique_spec[OF u'(2,4)]
    have step_r: "A,\<R> \<turnstile> \<langle>l, R\<rangle> \<leadsto> \<langle>l, R'\<rangle>" and 2: "[v']\<^sub>\<R> = R'" "[u]\<^sub>\<R> = R" by auto
    from set_of_regions_spec[OF u'(4,3)] v'1(1) 2 obtain t where t: "t \<ge> 0" "[u' \<oplus> t]\<^sub>\<R> = R'" by auto
    with regions_closed'_spec[OF u'(4,3) this(1)] step_t_r(1) have *: "u' \<oplus> t \<in> R'" by auto
    with t(1) 3 2 u'(1,3) have "A \<turnstile> \<langle>l, u'\<rangle> \<rightarrow> \<langle>l, u' \<oplus> t\<rangle>" "u' \<oplus> t \<in> ?W'"
    unfolding zone_delay_def ccval_def by auto
    with * 1(1) have "R' \<subseteq> Closure\<^sub>\<alpha> ?W'" unfolding cla_def by auto
    with 1(2) show "v \<in> Closure\<^sub>\<alpha> ?W'" ..
  qed
  moreover have "?W' \<subseteq> ?Z'" using \<open>W \<subseteq> Z\<close> unfolding zone_delay_def by auto
  ultimately show ?case by auto
next
  case A: (step_a_z A l g a r l' Z)
  let ?Z' = "zone_set (Z \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  let ?W' = "zone_set (W \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  from \<R>_def have \<R>_def': "\<R> = {region X I r |I r. valid_region X k I r}" by simp
  from A(1) have step_z: "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',?W'\<rangle>" by auto
  moreover have "Closure\<^sub>\<alpha> ?Z' \<subseteq> Closure\<^sub>\<alpha> ?W'"
  proof
    fix v assume v: "v \<in> Closure\<^sub>\<alpha> ?Z'"
    then obtain R' v' where 1: "R' \<in> \<R>" "v \<in> R'" "v' \<in> R'" "v' \<in> ?Z'" unfolding cla_def by auto
    then obtain u where
      "u \<in> Z" and v': "v' = [r\<rightarrow>0]u" "u \<turnstile> g" "v' \<turnstile> inv_of A l'"
    unfolding zone_set_def by blast
    let ?R'= "region_set' (([u]\<^sub>\<R>) \<inter> {u. u \<turnstile> g}) r 0 \<inter> {u. u \<turnstile> inv_of A l'}"
    from \<open>u \<in> Z\<close> closure_subs[OF A(4)] A(2) obtain u' R where u': "u' \<in> W" "u \<in> R" "u' \<in> R" "R \<in> \<R>"
    unfolding cla_def by blast
    then have "\<forall>x\<in>X. 0 \<le> u x" unfolding \<R>_def by fastforce
    from region_cover'[OF \<R>_def' this] have R: "[u]\<^sub>\<R> \<in> \<R>" "u \<in> [u]\<^sub>\<R>" by auto
    from step_r_complete_aux[OF \<R>_def' A(3) this(2,1) A(1) v'(2)] v'
    have *: "[u]\<^sub>\<R> = ([u]\<^sub>\<R>) \<inter> {u. u \<turnstile> g}" "?R' = region_set' ([u]\<^sub>\<R>) r 0" "?R' \<in> \<R>" by auto
    from \<R>_def' A(3) have "collect_clkvt (trans_of A) \<subseteq> X" "finite X"
    by (auto elim: valid_abstraction.cases)
    with A(1) have r: "set r \<subseteq> X" unfolding collect_clkvt_def by fastforce
    from * v'(1) R(2) have "v' \<in> ?R'" unfolding region_set'_def by auto
    moreover have "A,\<R> \<turnstile> \<langle>l,([u]\<^sub>\<R>)\<rangle> \<leadsto> \<langle>l',?R'\<rangle>" using R(1) \<R>_def' A(1,3) v'(2) by auto
    thm valid_regions_distinct_spec
    with valid_regions_distinct_spec[OF *(3) 1(1) \<open>v' \<in> ?R'\<close> 1(3)] region_unique_spec[OF u'(2,4)]
    have 2: "?R' = R'" "[u]\<^sub>\<R> = R" by auto
    with * u' have *: "[r\<rightarrow>0]u' \<in> ?R'" "u' \<turnstile> g" "[r\<rightarrow>0]u' \<turnstile> inv_of A l'"
    unfolding region_set'_def by auto
    with A(1) have "A \<turnstile> \<langle>l, u'\<rangle> \<rightarrow> \<langle>l',[r\<rightarrow>0]u'\<rangle>" apply (intro step.intros(1)) apply rule by auto
    moreover from * u'(1) have "[r\<rightarrow>0]u' \<in> ?W'" unfolding zone_set_def by auto
    ultimately have "R' \<subseteq> Closure\<^sub>\<alpha> ?W'" using *(1) 1(1) 2(1) unfolding cla_def by auto
    with 1(2) show "v \<in> Closure\<^sub>\<alpha> ?W'" ..
  qed
  moreover have "?W' \<subseteq> ?Z'" using \<open>W \<subseteq> Z\<close> unfolding zone_set_def by auto
  ultimately show ?case by meson
qed

lemma steps_z_alt:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto> \<langle>l'',Z''\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'',Z''\<rangle>"
by (induction rule: steps_z.induct) auto

lemma steps_z_alpha_V: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<subseteq> V"
apply (induction rule: steps_z_alpha.induct) using closure_V by auto

lemma steps_z_alpha_closure_involutive':
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto> \<langle>l'',Z''\<rangle> \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V
  \<Longrightarrow> \<exists> Z'''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'',Z'''\<rangle> \<and> Closure\<^sub>\<alpha> Z'' \<subseteq> Closure\<^sub>\<alpha> Z''' \<and> Z''' \<subseteq> Z''"
proof (induction A l Z l' Z' arbitrary: Z'' l'' rule: steps_z_alpha.induct, goal_cases)
  case refl from this(1) show ?case by blast
next
  case A: (2 A l Z l' Z' l'' Z'' Z''a l''a)
  from A(3) obtain \<Z> where Z'': "Z'' = Closure\<^sub>\<alpha> \<Z>" "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto> \<langle>l'',\<Z>\<rangle>" by auto
  from A(2)[OF Z''(2) A(5,6)] obtain Z''' where Z''':
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'',Z'''\<rangle>" "Closure\<^sub>\<alpha> \<Z> \<subseteq> Closure\<^sub>\<alpha> Z'''" "Z''' \<subseteq> \<Z>"
  by auto
  from closure_subs have *:
    "Z''' \<subseteq> Closure\<^sub>\<alpha> \<Z>"
  by (metis A(1,6) Z'''(3) Z''(2) step_z_V steps_z_alpha_V subset_trans)
  from A(4) Z'' have "A \<turnstile> \<langle>l'', Closure\<^sub>\<alpha> \<Z>\<rangle> \<leadsto> \<langle>l''a,Z''a\<rangle>" by auto
  from steps_z_alpha_closure_involutive'_aux'[OF this(1) _ A(5) closure_V *] Z'''(2,3) obtain W'
    where ***: "A \<turnstile> \<langle>l'', Z'''\<rangle> \<leadsto> \<langle>l''a,W'\<rangle>" "Closure\<^sub>\<alpha> Z''a \<subseteq> Closure\<^sub>\<alpha> W'" "W' \<subseteq> Z''a"
  by (auto simp: closure_involutive)
  with Z'''(1) have "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l''a,W'\<rangle>" by (blast intro: steps_z_alt)
  with ***(2,3) show ?case by blast
qed

text \<open>Old proof using Bouyer's calculation\<close>
lemma steps_z_alpha_closure_involutive'':
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto> \<langle>l'',Z''\<rangle> \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V
  \<Longrightarrow> \<exists> Z'''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'',Z'''\<rangle> \<and> Closure\<^sub>\<alpha> Z'' \<subseteq> Closure\<^sub>\<alpha> Z'''"
proof (induction A l Z l' Z' arbitrary: Z'' l'' rule: steps_z_alpha.induct, goal_cases)
  case refl from this(1) show ?case by blast
next
  case A: (2 A l Z l' Z' l'' Z'' Z''a l''a)
  from A(3) obtain \<Z> where Z'': "Z'' = Closure\<^sub>\<alpha> \<Z>" "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto> \<langle>l'',\<Z>\<rangle>" by auto
  from A(2)[OF Z''(2) A(5,6)] obtain Z''' where Z''':
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'',Z'''\<rangle>" "Closure\<^sub>\<alpha> \<Z> \<subseteq> Closure\<^sub>\<alpha> Z'''"
  by auto
  from steps_z_alpha_V[OF A(1,6)] step_z_V[OF Z''(2)] have *: "\<Z> \<subseteq> V" by blast
  from A Z'' have "A \<turnstile> \<langle>l'', Closure\<^sub>\<alpha> \<Z>\<rangle> \<leadsto> \<langle>l''a,Z''a\<rangle>" by auto
  from calc[OF A(5) * this] obtain \<Z>' where **:
    "A \<turnstile> \<langle>l'', \<Z>\<rangle> \<leadsto> \<langle>l''a,\<Z>'\<rangle>" "Z''a \<subseteq> Closure\<^sub>\<alpha> \<Z>'"
  by auto
  from steps_z_alpha_closure_involutive'_aux[OF this(1) Z'''(2) A(5) *] obtain W' where ***:
    "A \<turnstile> \<langle>l'', Z'''\<rangle> \<leadsto> \<langle>l''a,W'\<rangle>" "Closure\<^sub>\<alpha> \<Z>' \<subseteq> Closure\<^sub>\<alpha> W'"
  by auto
  with Z'''(1) have "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l''a,W'\<rangle>" by (blast intro: steps_z_alt)
  with closure_involutive'[OF **(2)] ***(2) show ?case by blast
qed

lemma steps_z_alpha_closure_involutive:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z'\<rangle> \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V
  \<Longrightarrow> \<exists> Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z''\<rangle> \<and> Closure\<^sub>\<alpha> Z' \<subseteq> Closure\<^sub>\<alpha> Z'' \<and> Z'' \<subseteq> Z'"
proof (induction A l Z l' Z' rule: steps_z_alpha.induct)
  case refl show ?case by blast
next
  case 2: (step A l Z l' Z' l'' Z'')
  then obtain Z''a where *: "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto> \<langle>l'',Z''a\<rangle>" "Z'' = Closure\<^sub>\<alpha> Z''a" by auto
  from steps_z_alpha_closure_involutive'[OF 2(1) this(1) 2(4,5)] obtain Z''' where Z''':
    "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l'',Z'''\<rangle>" "Closure\<^sub>\<alpha> Z''a \<subseteq> Closure\<^sub>\<alpha> Z'''" "Z''' \<subseteq> Z''a" by blast
  have "Z''' \<subseteq> Z''" by (metis *(1,2) 2(1,5) Z'''(3) closure_subs step_z_V steps_z_alpha_V subset_trans)
  with * closure_involutive Z''' show ?case by auto
qed

lemma steps_z_V:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<subseteq> V"
apply (induction rule: steps_z.induct)
  apply blast
using step_z_V by metis

lemma steps_z_alpha_sound:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z'\<rangle> \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<noteq> {}
  \<Longrightarrow> \<exists> Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z''\<rangle> \<and> Z'' \<noteq> {} \<and> Z'' \<subseteq> Z'"
proof goal_cases
  case 1
  from steps_z_alpha_closure_involutive[OF 1(1-3)] obtain Z'' where
    Z'': "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z''\<rangle>" "Closure\<^sub>\<alpha> Z' \<subseteq> Closure\<^sub>\<alpha> Z''" "Z'' \<subseteq> Z'"
    by blast
  with 1(4) cla_empty_iff[OF steps_z_alpha_V[OF 1(1)], OF 1(3)]
    cla_empty_iff[OF steps_z_V, OF this(1) 1(3)] have "Z'' \<noteq> {}" by auto
  with Z'' show ?case by auto
qed

lemma step_z_mono:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> W \<Longrightarrow> \<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',W'\<rangle> \<and> Z' \<subseteq> W'"
proof (cases rule: step_z.cases, assumption, goal_cases)
  case A: 1
  let ?W' = "(W \<inter> {u. u \<turnstile> inv_of A l})\<^sup>\<up> \<inter> {u. u \<turnstile> inv_of A l}"
  from A have "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',?W'\<rangle>" by auto
  moreover have "Z' \<subseteq> ?W'"
    apply (subst A(4))
    apply (rule subset_int_mono)
    apply (rule zone_delay_mono)
    apply (rule subset_int_mono)
    apply (rule A(2))
  done
  ultimately show ?thesis by auto
next
  case A: (2 g a r)
  let ?W' = "zone_set (W \<inter> {u. u \<turnstile> g}) r \<inter> {u. u \<turnstile> inv_of A l'}"
  from A have "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',?W'\<rangle>" by auto
  moreover have "Z' \<subseteq> ?W'"
    apply (subst A(3))
    apply (rule subset_int_mono)
    apply (rule zone_set_mono)
    apply (rule subset_int_mono)
    apply (rule A(2))
  done
  ultimately show ?thesis by auto
qed

lemma step_z_alpha_mono:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> W \<Longrightarrow> W \<subseteq> V \<Longrightarrow> \<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l',W'\<rangle> \<and> Z' \<subseteq> W'"
proof goal_cases
  case 1
  then obtain Z'' where *: "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto> \<langle>l',Z''\<rangle>" "Z' = Closure\<^sub>\<alpha> Z''" by auto
  from step_z_mono[OF this(1) 1(2)] obtain W' where "A \<turnstile> \<langle>l, W\<rangle> \<leadsto> \<langle>l',W'\<rangle>" "Z'' \<subseteq> W'" by auto
  moreover with *(2) have "Z' \<subseteq> Closure\<^sub>\<alpha> W'" unfolding cla_def by auto
  ultimately show ?case by blast
qed

lemma steps_z_alpha_mono:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z'\<rangle> \<Longrightarrow> Z \<subseteq> W \<Longrightarrow> W \<subseteq> V \<Longrightarrow> \<exists> W'. A \<turnstile> \<langle>l, W\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',W'\<rangle> \<and> Z' \<subseteq> W'"
proof (induction rule: steps_z_alpha.induct, goal_cases)
  case refl then show ?case by auto
next
  case (2 A l Z l' Z' l'' Z'')
  then obtain W' where "A \<turnstile> \<langle>l, W\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',W'\<rangle>" "Z' \<subseteq> W'" by auto
  with step_z_alpha_mono[OF 2(3) this(2) steps_z_alpha_V[OF this(1) 2(5)]]
  show ?case by blast
qed

lemma steps_z_alpha_alt:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha> \<langle>l', Z'\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l'', Z''\<rangle> \<Longrightarrow> A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l'', Z''\<rangle>"
by (rotate_tac, induction rule: steps_z_alpha.induct) blast+

lemma steps_z_alpha_complete:
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z'\<rangle> \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<noteq> {}
  \<Longrightarrow> \<exists> Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z''\<rangle> \<and> Z' \<subseteq> Z''"
proof (induction rule: steps_z.induct, goal_cases)
  case refl with cla_empty_iff show ?case by blast
next
  case (2 A l Z l' Z' l'' Z'')
  with step_z_V[OF this(1,5)] obtain Z''' where "A \<turnstile> \<langle>l', Z'\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l'',Z'''\<rangle>" "Z'' \<subseteq> Z'''" by blast
  with steps_z_alpha_mono[OF this(1) closure_subs[OF step_z_V[OF 2(1,5)]] closure_V]
  obtain W' where "A \<turnstile> \<langle>l', Closure\<^sub>\<alpha> Z'\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l'',W'\<rangle>" " Z'' \<subseteq> W'" by auto
  moreover with 2(1) have "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l'',W'\<rangle>" by (auto intro: steps_z_alpha_alt)
  ultimately show ?case by auto
qed

lemma steps_z_alpha_complete':
  "A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>* \<langle>l',Z'\<rangle> \<Longrightarrow> valid_abstraction A X k \<Longrightarrow> Z \<subseteq> V \<Longrightarrow> Z' \<noteq> {}
  \<Longrightarrow> \<exists> Z''. A \<turnstile> \<langle>l, Z\<rangle> \<leadsto>\<^sub>\<alpha>* \<langle>l',Z''\<rangle> \<and> Z'' \<noteq> {}"
using steps_z_alpha_complete by fast

end

end


(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Models of Regular Algebra *}

theory Regular_Algebra_Models
  imports Regular_Algebras "../Kleene_Algebra/Kleene_Algebra_Models"
begin

subsection {* Language Model of Salomaa Algebra *}

abbreviation w_length :: "'a list \<Rightarrow> nat" ( "|_|")
  where "|x| \<equiv> length x"

definition l_ewp :: "'a lan \<Rightarrow> bool" where
  "l_ewp X \<longleftrightarrow> {[]} \<subseteq> X"

interpretation lan_kozen: K2_algebra "op +" "op \<cdot>" "1 :: 'a lan" 0 "(op \<subseteq>)" "(op \<subset>)" "star" ..

interpretation lan_boffa: B1_algebra "op +" "op \<cdot>" "1 :: 'a lan" 0 "(op \<subseteq>)" "(op \<subset>)" "star" ..

lemma length_lang_pow_lb:
  assumes "\<forall>x\<in>X. |x| \<ge> k" "x \<in> X^n"
  shows "|x| \<ge> k*n"
using assms proof (induct n arbitrary: x)
  case 0 thus ?case by auto
next
  case (Suc n)
  note hyp = this
  thus ?case
  proof -
    have "x \<in> X\<^bsup>Suc n\<^esup> \<longleftrightarrow> (\<exists> y z. x = y@z \<and> y \<in> X \<and> z \<in> X\<^bsup>n\<^esup>)"
      by (simp add:c_prod_def times_list_def)
    also from hyp have "... \<longrightarrow> (\<exists> y z. x = y@z \<and> |y| \<ge> k \<and> |z| \<ge> k*n)"
      by auto
    also have "... \<longleftrightarrow> (\<exists> y z. x = y@z \<and> |y| \<ge> k \<and> |z| \<ge> k*n \<and> ( |x| = |y| + |z| ))"
      by force
    also have "... \<longleftrightarrow> (\<exists> y z. x = y@z \<and> |y| \<ge> k \<and> |z| \<ge> k*n \<and> ( |x| \<ge> (n + 1) * k ))"
      by (auto, metis add_mono mult.commute, force)
    finally show ?thesis
      by (metis Suc_eq_plus1 hyp(3) mult.commute)
  qed
qed

lemma l_prod_elim: "w\<in>X \<cdot> Y \<longleftrightarrow> (\<exists>u v. w = u@v \<and> u\<in>X \<and> v\<in>Y)"
  by (simp add: c_prod_def times_list_def)

lemma power_minor_var:
  assumes "\<forall>w\<in>X. k\<le>|w|"
  shows "\<forall>w\<in>X\<^bsup>Suc n\<^esup>. n*k\<le>|w|"
  using assms
  by (auto simp add: l_prod_elim, metis comm_semiring_1_class.normalizing_semiring_rules(7) length_lang_pow_lb trans_le_add2)

lemma power_lb: "(\<forall>w\<in>X. k\<le>|w| ) \<longrightarrow> (\<forall>w. w\<in>X\<^bsup>Suc n\<^esup> \<longrightarrow> n*k\<le>|w| )"
  by (metis power_minor_var)

lemma prod_lb:
  "\<lbrakk> (\<forall>w\<in>X. m \<le> length w); (\<forall>w\<in>Y. n \<le> length w) \<rbrakk> \<Longrightarrow> (\<forall>w\<in>(X\<cdot>Y). (m+n) \<le> length w)"
  by (metis l_prod_elim add_le_mono length_append)

lemma suicide_aux_l:
  "\<lbrakk> (\<forall>w\<in>Y. 0\<le>length w); (\<forall>w\<in>X\<^bsup>Suc n\<^esup>. n \<le> length w) \<rbrakk> \<Longrightarrow> (\<forall>w\<in>X\<^bsup>Suc n \<^esup>\<cdot> Y. n \<le> length w)"
  apply (auto simp: l_prod_elim)
  apply (drule_tac x="ua @ va" in bspec)
  apply (auto simp add: l_prod_elim)
done

lemma suicide_aux_r:
  "\<lbrakk> (\<forall>w\<in>Y. 0\<le>length w); (\<forall>w\<in>X\<^bsup>Suc n\<^esup>. n \<le> length w) \<rbrakk> \<Longrightarrow> (\<forall>w\<in>Y \<cdot> X\<^bsup>Suc n\<^esup>. n \<le> length w)"
  by (auto, metis (full_types) le0 plus_nat.add_0 prod_lb)

lemma word_suicide_l:
  assumes "\<not> l_ewp X" "Y \<noteq> {}"
  shows "(\<forall>w\<in>Y. \<exists>n. w\<notin>X\<^bsup>Suc n \<^esup>\<cdot> Y)"
proof -
  have  "\<forall>v\<in>Y. 0\<le>length v"
    by (metis le0)
  from assms have "\<forall>v\<in>X. 1\<le>length v"
    by (simp add: l_ewp_def, metis le_0_eq length_0_conv not_less_eq_eq)
  hence "\<forall>w\<in>Y. \<exists>n. w\<notin>X\<^bsup>Suc n \<^esup>\<cdot> Y"
    by (metis nat_mult_1_right power_lb suicide_aux_l le0 Suc_n_not_le_n)
  thus ?thesis by metis
qed

lemma word_suicide_r:
  assumes "\<not> l_ewp X" "Y \<noteq> {}"
  shows "(\<forall>w\<in>Y. \<exists>n. w\<notin>Y \<cdot> X\<^bsup>Suc n\<^esup>)"
proof -
  have  "\<forall>v\<in>Y. 0\<le>length v"
    by (metis le0)
  from assms have "\<forall>v\<in>X. 1\<le>length v"
    by (simp add: l_ewp_def, metis le_0_eq length_0_conv not_less_eq_eq)
  hence "\<forall>w\<in>Y. \<exists>n. w\<notin>Y \<cdot> X\<^bsup>Suc n \<^esup>"
    by (metis nat_mult_1_right power_lb suicide_aux_r le0 Suc_n_not_le_n)
  thus ?thesis by metis
qed

lemma word_suicide_lang_l: "\<lbrakk> \<not> l_ewp X; Y \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> n. \<not> (Y \<le> X\<^bsup>Suc n \<^esup>\<cdot> Y)"
  by (metis Set.set_eqI empty_iff in_mono word_suicide_l)

lemma word_suicide_lang_r: "\<lbrakk> \<not> l_ewp X; Y \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> n. \<not> (Y \<le> Y \<cdot> X\<^bsup>Suc n\<^esup>)"
  by (metis Set.set_eqI empty_iff in_mono word_suicide_r)

text {* These duality results cannot be relocated easily *}

context K1_algebra
begin

lemma power_dual_transfer [simp]:
  "power.power (1\<Colon>'a) op \<odot> x n = x\<^bsup>n\<^esup>"
  by (induct n, simp_all, metis opp_mult_def power_commutes)

end

lemma arden_r:
  assumes "\<not> l_ewp y" "x = x \<cdot> y + z"
  shows "x = z \<cdot> y\<^sup>\<star>"
proof (rule antisym)
  show one: "z \<cdot> y\<^sup>\<star> \<le> x"
    by (metis assms(2) join_semilattice_class.add_comm kleene_algebra_class.star_inductr_eq)
  show "x \<le> z \<cdot> y\<^sup>\<star>"
  proof (cases "x = 0")
    show "x = 0 \<Longrightarrow> x \<le> z \<cdot> y\<^sup>\<star>"
      by simp
    assume assms': "x \<noteq> 0"
    have "\<And> n. x \<le> x \<cdot> y\<^bsup>Suc n\<^esup> + z \<cdot> y\<^sup>\<star>"
      by (metis assms(2) kleene_algebra_class.aarden_aux subsetI)
    moreover then have "\<And> w n. w \<in> x \<Longrightarrow> w \<in> x \<cdot> y\<^bsup>Suc n\<^esup> \<or> w \<in> z \<cdot> y\<^sup>\<star>"
      by (force simp: plus_set_def)
    ultimately show "x \<le> z \<cdot> y\<^sup>\<star>"
      by (metis (full_types) all_not_in_conv assms(1) subsetI word_suicide_r)
  qed
qed

text {* The following two facts provide counterexamples to Arden's rule if the empty word property is not considered. *}

lemma arden_l_counter: "\<exists> (x::'a lan) (y::'a lan) (z::'a lan). x = y \<cdot> x + z \<and> x \<noteq> y\<^sup>\<star> \<cdot> z"
proof -
  have one: "(0::'a lan) + 1 \<cdot> 1 = 1"
    by (metis ab_near_semiring_one_class.mult_onel kleene_algebra_class.dual.add_zerol)
  have two: "(1::'a lan) \<noteq> 1\<^sup>\<star> \<cdot> 0"
  proof -
    have "\<exists>x\<^sub>1. (0\<Colon>'a list set) \<noteq> x\<^sub>1"
      by auto
    hence "(1\<Colon>'a list set) \<noteq> 0"
      by (metis kleene_algebra_class.dual.annir kleene_algebra_class.dual.mult.right_neutral)
    thus "(1\<Colon>'a list set) \<noteq> 1\<^sup>\<star> \<cdot> 0"
      by simp
  qed
  show ?thesis using one and two
    by (metis kleene_algebra_class.dual.add_zerol kleene_algebra_class.dual.add_zeror)
qed

lemma arden_r_counter: "\<exists> (x::'a lan) (y::'a lan) (z::'a lan). x = x \<cdot> y + z \<and> x \<noteq> z \<cdot> y\<^sup>\<star>"
proof -
  have one: "(0::'a lan) + 1 \<cdot> 1 = 1"
    by (metis ab_near_semiring_one_class.mult_onel kleene_algebra_class.dual.add_zerol)
  have two: "(1::'a lan) \<noteq> 0 \<cdot> 1\<^sup>\<star>"
  proof -
    have "\<exists>x\<^sub>1. (0\<Colon>'a list set) \<noteq> x\<^sub>1"
      by auto
    hence "(1\<Colon>'a list set) \<noteq> 0"
      by (metis kleene_algebra_class.dual.annir kleene_algebra_class.dual.mult.right_neutral)
    thus "(1\<Colon>'a list set) \<noteq> 0 \<cdot> 1\<^sup>\<star>"
      by simp
  qed
  show ?thesis using one and two
    by (metis kleene_algebra_class.dual.add_zerol kleene_algebra_class.dual.add_zeror)
qed

interpretation lan_salomaa_l: Sl_algebra "op +" "op \<cdot>" "1 :: 'a lan" 0 "(op \<subseteq>)" "(op \<subset>)" "star" "l_ewp"
proof
  fix x y z :: "'a lan"
  show "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis kleene_algebra_class.dual.star2)
  show "l_ewp x = (\<exists>y. x = 1 + y \<and> \<not> l_ewp y)"
    by (simp add:l_ewp_def one_set_def one_list_def plus_set_def, metis insertCI mk_disjoint_insert)
  show "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis kleene_algebra_class.star_unfoldl_eq)
  show "\<not> l_ewp y \<Longrightarrow> x = y \<cdot> x + z \<Longrightarrow> x = y\<^sup>\<star> \<cdot> z"
    by (metis arden_l)
qed

interpretation lan_salomaa_r: Sr_algebra "op +" "op \<cdot>" "1 :: 'a lan" 0 "(op \<subseteq>)" "(op \<subset>)" "star" "l_ewp"
proof
  fix x y z :: "'a lan"
  show "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
    by (metis kleene_algebra_class.star_unfoldr_eq)
  show "\<not> l_ewp y \<Longrightarrow> x = x \<cdot> y + z \<Longrightarrow> x = z \<cdot> y\<^sup>\<star>"
    by (metis arden_r)
qed

subsection {* Regular Language Model of Salomaa Algebra *}

notation
  Atom ("\<langle>_\<rangle>") and
  Plus (infixl "+\<^sub>r" 65) and
  Times (infixl "\<cdot>\<^sub>r" 70) and
  Star ("_\<^sup>\<star>\<^sub>r" [101] 100) and
  Zero ("0\<^sub>r") and
  One ("1\<^sub>r")

fun rexp_ewp :: "'a rexp \<Rightarrow> bool" where
  "rexp_ewp 0\<^sub>r = False" |
  "rexp_ewp 1\<^sub>r = True" |
  "rexp_ewp \<langle>a\<rangle> = False" |
  "rexp_ewp (s +\<^sub>r t) = (rexp_ewp s \<or> rexp_ewp t)" |
  "rexp_ewp (s \<cdot>\<^sub>r t) = (rexp_ewp s \<and> rexp_ewp t)" |
  "rexp_ewp (s\<^sup>\<star>\<^sub>r) = True"

abbreviation "ro(s) \<equiv> (if (rexp_ewp s) then 1\<^sub>r else 0\<^sub>r)"

lift_definition r_ewp :: "'a reg_lan \<Rightarrow> bool" is "l_ewp" .

lift_definition r_lang :: "'a rexp \<Rightarrow> 'a reg_lan"  is "lang"
  by (simp)

abbreviation r_sim :: "'a rexp \<Rightarrow> 'a rexp \<Rightarrow> bool" (infix "\<sim>" 50) where
  "p \<sim> q \<equiv> r_lang p = r_lang q"

declare Rep_reg_lan [simp]
declare Rep_reg_lan_inverse [simp]
declare Abs_reg_lan_inverse [simp]

lemma rexp_ewp_l_ewp: "l_ewp (lang x) = rexp_ewp x"
proof (induct x)
  case (Star x) thus ?case
    by (simp, metis lan_salomaa_l.EWP left_near_kleene_algebra_class.star_plus_one)
qed (simp_all add:l_ewp_def zero_set_def one_set_def one_list_def plus_set_def c_prod_def times_list_def)

theorem regexp_ewp:
  defines P_def: "P(t) \<equiv> \<exists> t'. t \<sim> ro(t) +\<^sub>r t' \<and> ro(t') = 0\<^sub>r"
  shows "P t"
proof (induct t)
  show "P(0\<^sub>r)"
    by (simp add:P_def r_lang_def, rule_tac x="0\<^sub>r" in exI, simp)
next
  fix a
  show "P(\<langle>a\<rangle>)"
    by (simp add:P_def r_lang_def, rule_tac x="\<langle>a\<rangle>" in exI, simp)
next
  show "P(1\<^sub>r)"
    by (simp add:P_def r_lang_def, rule_tac x="0\<^sub>r" in exI, simp)
next
  fix t1 t2
  assume "P(t1)" "P(t2)"
  then obtain t1' t2'
    where "t1 \<sim> ro(t1) +\<^sub>r t1'" "ro(t1') = 0\<^sub>r"
          "t2 \<sim> ro(t2) +\<^sub>r t2'" "ro(t2') = 0\<^sub>r"
    by (metis assms rexp.distinct(1))
  thus "P(t1 +\<^sub>r t2)"
    apply (subst P_def, transfer)
    apply (rule_tac x="t1' +\<^sub>r t2'" in exI)
    apply auto
    done
next
  fix t1 t2
  assume "P(t1)" "P(t2)"
  then obtain t1' t2'
    where t1: "t1 \<sim> ro(t1) +\<^sub>r t1'" "ro(t1') = 0\<^sub>r" and
          t2: "t2 \<sim> ro(t2) +\<^sub>r t2'" "ro(t2') = 0\<^sub>r"
      by (metis assms rexp.distinct(1))
  thus "P(t1 \<cdot>\<^sub>r t2)"
  proof -
    let ?t' = "ro(t1) \<cdot>\<^sub>r t2' +\<^sub>r t1' \<cdot>\<^sub>r ro(t2) +\<^sub>r t1' \<cdot>\<^sub>r t2'"
    from t1 t2 have r1: "ro(?t') = 0\<^sub>r"
      by (auto)
    from t1 t2 have "t1 \<cdot>\<^sub>r t2 \<sim> (ro(t1) +\<^sub>r t1') \<cdot>\<^sub>r (ro(t2) +\<^sub>r t2')" (is "?l \<sim> ?r")
      by (transfer, simp)
    also have "?r \<sim> ro(t1) \<cdot>\<^sub>r ro(t2) +\<^sub>r ro(t1) \<cdot>\<^sub>r t2' +\<^sub>r t1' \<cdot>\<^sub>r ro(t2) +\<^sub>r t1' \<cdot>\<^sub>r t2'" (is "?l \<sim> ?r")
      apply (transfer, unfold lang.simps)
      apply (simp only: distrib_right' semiring_class.distrib_left)
      apply (metis (hide_lams, no_types) join_semilattice_class.add_comm semiring_class.combine_common_factor)
    done
    also have "?r \<sim> ro(t1 \<cdot>\<^sub>r t2) +\<^sub>r ro(t1) \<cdot>\<^sub>r t2' +\<^sub>r t1' \<cdot>\<^sub>r ro(t2) +\<^sub>r t1' \<cdot>\<^sub>r t2'" (is "?l \<sim> ?r")
      by (transfer, simp)
    also have "?r \<sim> ro(t1 \<cdot>\<^sub>r t2) +\<^sub>r ?t'"
      apply (transfer, unfold lang.simps)
      apply (metis (mono_tags) join_semilattice_class.add_assoc')
    done
    finally show ?thesis using r1
      apply (unfold P_def)
      apply (rule_tac x="?t'" in exI, simp)
    done
  qed
next
  fix s
  assume assm:"P s"
  then obtain s' where r1: "s \<sim> ro(s) +\<^sub>r s'" "ro(s') = 0\<^sub>r"
    by (metis assms rexp.distinct(1))
  thus "P (s\<^sup>\<star>\<^sub>r)"
  proof -
    let ?t' = "s' \<cdot>\<^sub>r (s')\<^sup>\<star>\<^sub>r"
    have r2: "ro(?t') = 0\<^sub>r"
      by (metis r1(2) rexp.distinct(1) rexp_ewp.simps(5))
    from assm r1 have "(ro(s) +\<^sub>r s')\<^sup>\<star>\<^sub>r \<sim> (s')\<^sup>\<star>\<^sub>r" (is "?l \<sim> ?r")
      by (transfer, auto)
    also have "?r \<sim> 1\<^sub>r +\<^sub>r s' \<cdot>\<^sub>r (s')\<^sup>\<star>\<^sub>r" (is "?l \<sim> ?r")
      by (transfer, auto)
    also have "?r \<sim> ro(s\<^sup>\<star>\<^sub>r) +\<^sub>r ?t'"
      by (metis (full_types) rexp_ewp.simps(6))
    finally show ?thesis
      by (metis assms lang.simps(6) r1(1) r2 r_lang.abs_eq r_lang.rep_eq)
  qed
qed

instantiation reg_lan :: (type) Sr_algebra
begin

lift_definition ewp_reg_lan :: "'a reg_lan \<Rightarrow> bool" is "l_ewp" .

instance proof
  fix x :: "'a reg_lan"
  show "(1 + x)\<^sup>\<star> = x\<^sup>\<star>"
    by (metis kleene_algebra_class.dual.star2)
next
  fix x :: "'a reg_lan"
  show "1 + x\<^sup>\<star> \<cdot> x = x\<^sup>\<star>"
    by (metis kleene_algebra_class.star_unfoldr_eq)
next
  fix x :: "'a reg_lan"
  show "ewp x = (\<exists>y. x = 1 + y \<and> \<not> ewp y)"
  proof -
    obtain t where "r_lang t = x"
      by (transfer, auto)
    moreover obtain t' where "t \<sim> ro(t) +\<^sub>r t'" "ro(t') = 0\<^sub>r"
      by (metis regexp_ewp)
    ultimately show ?thesis
      apply (transfer, auto)
      apply (metis (full_types) join_semilattice_class.add_comm lang.simps(2) rexp.distinct(1) rexp_ewp_l_ewp)
      apply (metis lan_salomaa_l.EWP)
    done
  qed
next
  fix x y z :: "'a reg_lan"
  show "\<lbrakk> \<not> ewp y; x = x \<cdot> y + z \<rbrakk> \<Longrightarrow> x = z \<cdot> y\<^sup>\<star>"
    by (transfer, metis lan_salomaa_r.Ar)
qed
end

instantiation reg_lan :: (type) Sl_algebra
begin

instance proof
  fix x :: "'a reg_lan"
  show "1 + x \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
    by (metis left_pre_kleene_algebra_class.star_unfoldl_eq)
next
  fix x y z :: "'a reg_lan"
  show "\<lbrakk> \<not> ewp y; x = y \<cdot> x + z \<rbrakk> \<Longrightarrow> x = y\<^sup>\<star> \<cdot> z"
    by (transfer, metis lan_salomaa_l.Al)
qed
end

instance reg_lan :: (type) S_algebra ..

theorem arden_regexp_l:
  assumes "ro(y) = 0\<^sub>r" "x \<sim> y \<cdot>\<^sub>r x +\<^sub>r z"
  shows "x \<sim> y\<^sup>\<star>\<^sub>r \<cdot>\<^sub>r z"
  using assms
  by (transfer, metis arden_l lang.simps(4) lang.simps(5) lang.simps(6) rexp.distinct(1) rexp_ewp_l_ewp)

theorem arden_regexp_r:
  assumes "ro(y) = 0\<^sub>r" "x \<sim> x \<cdot>\<^sub>r y +\<^sub>r z"
  shows "x \<sim> z \<cdot>\<^sub>r y\<^sup>\<star>\<^sub>r"
  using assms
  by transfer (metis lan_salomaa_r.Ar lang.simps(4) lang.simps(5) lang.simps(6) rexp.distinct(1) rexp_ewp_l_ewp)

end