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

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  Payloads.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Payloads.thy 132885 2016-12-23 18:41:32Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Payload messages are messages that contain no implementation material,
  i.e. neither long-term keys nor channel tags; also:
  - auxiliary definitions: Keys_bad, broken, Enc_keys_clean
  - lemmas for moving message sets out of 'analz'

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

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

section \<open>Payloads and Support for Channel Message Implementations\<close>

text \<open>Definitions and lemmas that do not require the implementations.\<close>

theory Payloads
imports Message_derivation
begin

subsection \<open>Payload messages\<close>
(**************************************************************************************************)

text \<open>Payload messages contain no implementation material ie no long term keys or tags.\<close>

text \<open>Define set of payloads for basic messages.\<close>
inductive_set cpayload :: "cmsg set" where
  "cAgent A \<in> cpayload"
| "cNumber T \<in> cpayload"
| "cNonce N \<in> cpayload"
| "cEphK K \<in> cpayload"
| "X \<in> cpayload \<Longrightarrow> cHash X \<in> cpayload"
| "\<lbrakk> X \<in> cpayload; Y \<in> cpayload \<rbrakk> \<Longrightarrow> cPair X Y \<in> cpayload"
| "\<lbrakk> X \<in> cpayload; Y \<in> cpayload \<rbrakk> \<Longrightarrow> cEnc X Y \<in> cpayload"
| "\<lbrakk> X \<in> cpayload; Y \<in> cpayload \<rbrakk> \<Longrightarrow> cAenc X Y \<in> cpayload"
| "\<lbrakk> X \<in> cpayload; Y \<in> cpayload \<rbrakk> \<Longrightarrow> cSign X Y \<in> cpayload"
| "\<lbrakk> X \<in> cpayload; Y \<in> cpayload \<rbrakk> \<Longrightarrow> cExp X Y \<in> cpayload"

text \<open>Lift @{term cpayload} to the quotiented message type.\<close>
lift_definition payload :: "msg set" is cpayload by -

text \<open>Lemmas used to prove the intro and inversion rules for @{term payload}.\<close>
lemma eq_rep_abs: "eq x (Re (Ab x))"
by (simp add: Quotient3_msg rep_abs_rsp)

lemma eq_cpayload:
  assumes "eq x y" and "x \<in> cpayload"
  shows "y \<in> cpayload"
using assms by (induction x y rule: eq.induct, auto intro: cpayload.intros elim: cpayload.cases)

lemma abs_payload: "Ab x \<in> payload \<longleftrightarrow> x \<in> cpayload"
by (auto simp add: payload_def msg.abs_eq_iff eq_cpayload eq_sym cpayload.intros
         elim: cpayload.cases)

lemma abs_cpayload_rep: "x \<in> Ab` cpayload \<longleftrightarrow> Re x \<in> cpayload"
apply (auto elim: eq_cpayload [OF eq_rep_abs])
apply (subgoal_tac "x = Ab (Re x)", auto)
using Quotient3_abs_rep Quotient3_msg by fastforce

lemma payload_rep_cpayload: "Re x \<in> cpayload \<longleftrightarrow> x \<in> payload"
by (auto simp add: payload_def abs_cpayload_rep)

text \<open>Manual proof of payload introduction rules. Transfer does not work for these\<close>

declare cpayload.intros [intro]
lemma payload_AgentI: "Agent A \<in> payload"
  by (auto simp add: msg_defs abs_payload)
lemma payload_NonceI: "Nonce N \<in> payload"
  by (auto simp add: msg_defs abs_payload)
lemma payload_NumberI: "Number N \<in> payload"
  by (auto simp add: msg_defs abs_payload)
lemma payload_EphKI: "EphK X \<in> payload"
  by (auto simp add: msg_defs abs_payload)
lemma payload_HashI: "x \<in> payload \<Longrightarrow> Hash x \<in> payload"
  by (auto simp add: msg_defs payload_rep_cpayload abs_payload)
lemma payload_PairI: "x \<in> payload \<Longrightarrow> y \<in> payload \<Longrightarrow> Pair x y \<in> payload"
  by (auto simp add: msg_defs payload_rep_cpayload abs_payload)
lemma payload_EncI: "x \<in> payload \<Longrightarrow> y \<in> payload \<Longrightarrow> Enc x y \<in> payload"
  by (auto simp add: msg_defs payload_rep_cpayload abs_payload)
lemma payload_AencI: "x \<in> payload \<Longrightarrow> y \<in> payload \<Longrightarrow> Aenc x y \<in> payload"
  by (auto simp add: msg_defs payload_rep_cpayload abs_payload)
lemma payload_SignI: "x \<in> payload \<Longrightarrow> y \<in> payload \<Longrightarrow> Sign x y \<in> payload"
  by (auto simp add: msg_defs payload_rep_cpayload abs_payload)
lemma payload_ExpI: "x \<in> payload \<Longrightarrow> y \<in> payload \<Longrightarrow> Exp x y \<in> payload"
by (auto simp add: msg_defs payload_rep_cpayload abs_payload)

lemmas payload_intros [simp, intro] =
  payload_AgentI payload_NonceI payload_NumberI payload_EphKI payload_HashI
  payload_PairI payload_EncI payload_AencI payload_SignI payload_ExpI

text \<open>Manual proof of payload inversion rules, transfer does not work for these.\<close>

declare cpayload.cases[elim]
lemma payload_Tag: "Tag X \<in> payload \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done

lemma payload_LtK: "LtK X \<in> payload \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done
lemma payload_Hash: "Hash X \<in> payload \<Longrightarrow> (X \<in> payload \<Longrightarrow> P) \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done
lemma payload_Pair: "Pair X Y \<in> payload \<Longrightarrow> (X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done
lemma payload_Enc: "Enc X Y \<in> payload \<Longrightarrow> (X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done
lemma payload_Aenc: "Aenc X Y \<in> payload \<Longrightarrow> (X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done
lemma payload_Sign: "Sign X Y \<in> payload \<Longrightarrow> (X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow> P"
apply (auto simp add: payload_def msg_defs msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done
lemma payload_Exp: "Exp X Y \<in> payload \<Longrightarrow> (X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow> P"
apply (auto simp add: payload_def Exp_def msg.abs_eq_iff eq_sym)
apply (auto dest!: eq_cpayload simp add: abs_cpayload_rep)
done

declare cpayload.intros[rule del]
declare cpayload.cases[rule del]

lemmas payload_inductive_cases =
  payload_Tag payload_LtK payload_Hash
  payload_Pair payload_Enc payload_Aenc payload_Sign payload_Exp

lemma eq_exhaust:
"(\<And>x. eq y (cAgent x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. eq y (cNumber x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. eq y (cNonce x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. eq y (cLtK x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. eq y (cEphK x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. eq y (cPair x x') \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. eq y (cEnc x x') \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. eq y (cAenc x x') \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. eq y (cSign x x') \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. eq y (cHash x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. eq y (cTag x) \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. eq y (cExp x x') \<Longrightarrow> P) \<Longrightarrow>
 P"
apply (cases y)
apply (meson Messages.eq_refl)+
done

lemma msg_exhaust:
"(\<And>x. y = Agent x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. y = Number x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. y = Nonce x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. y = LtK x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. y = EphK x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. y = Pair x x' \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. y = Enc x x' \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. y = Aenc x x' \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. y = Sign x x' \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. y = Hash x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x. y = Tag x \<Longrightarrow> P) \<Longrightarrow>
 (\<And>x x'. y = Exp x x' \<Longrightarrow> P) \<Longrightarrow>
 P"
apply transfer
apply (erule eq_exhaust, auto)
done

lemma payload_cases:
"a \<in> payload \<Longrightarrow>
(\<And>A. a = Agent A \<Longrightarrow> P) \<Longrightarrow>
(\<And>T. a = Number T \<Longrightarrow> P) \<Longrightarrow>
(\<And>N. a = Nonce N \<Longrightarrow> P) \<Longrightarrow>
(\<And>K. a = EphK K \<Longrightarrow> P) \<Longrightarrow>
(\<And>X. a = Hash X \<Longrightarrow> X \<in> payload \<Longrightarrow> P) \<Longrightarrow>
(\<And>X Y. a = Pair X Y \<Longrightarrow> X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow>
(\<And>X Y. a = Enc X Y \<Longrightarrow> X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow>
(\<And>X Y. a = Aenc X Y \<Longrightarrow> X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow>
(\<And>X Y. a = Sign X Y \<Longrightarrow> X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow>
(\<And>X Y. a = Exp X Y \<Longrightarrow> X \<in> payload \<Longrightarrow> Y \<in> payload \<Longrightarrow> P) \<Longrightarrow>
 P"
by (erule msg_exhaust [of a], auto elim: payload_inductive_cases)

declare payload_cases [elim]
declare payload_inductive_cases [elim]

text \<open>Properties of payload; messages constructed from payload messages are also payloads.\<close>

lemma payload_parts [simp, dest]:
  "\<lbrakk> X \<in> parts S; S \<subseteq> payload \<rbrakk> \<Longrightarrow> X \<in> payload"
by (erule parts.induct) (auto)

lemma payload_analz [simp, dest]:
  "\<lbrakk> X \<in> analz S; S \<subseteq> payload \<rbrakk> \<Longrightarrow> X \<in> payload"
by (auto dest: analz_into_parts)

lemma payload_synth_analz:
  "\<lbrakk> X \<in> synth (analz S); S \<subseteq> payload \<rbrakk> \<Longrightarrow> X \<in> payload"
by (erule synth.induct) (auto intro: payload_analz)

text \<open>Important lemma: using messages with implementation material one can only
synthesise more such messages.\<close>

lemma synth_payload:
  "Y \<inter> payload = {} \<Longrightarrow> synth (X \<union> Y) \<subseteq> synth X \<union> -payload"
by (rule, erule synth.induct) (auto)

lemma synth_payload2:
  "Y \<inter> payload = {} \<Longrightarrow> synth (Y \<union> X) \<subseteq> synth X \<union> -payload"
by (rule, erule synth.induct) (auto)

text \<open>Lemma: in the case of the previous lemma, @{term synth} can be applied on the
left with no consequence.\<close>

lemma synth_idem_payload:
  "X \<subseteq> synth Y \<union> -payload \<Longrightarrow> synth X \<subseteq> synth Y \<union> -payload"
by (auto dest: synth_mono subset_trans [OF _ synth_payload])

subsection \<open>\<open>isLtKey\<close>: is a long term key\<close>
(**************************************************************************************************)

lemma LtKeys_payload [dest]: "NI \<subseteq> payload \<Longrightarrow> NI \<inter> range LtK = {}"
by (auto)

lemma LtKeys_parts_payload [dest]: "NI \<subseteq> payload \<Longrightarrow> parts NI \<inter> range LtK = {}"
by (auto)

lemma LtKeys_parts_payload_singleton [elim]: "X \<in> payload \<Longrightarrow> LtK Y \<in> parts {X} \<Longrightarrow> False"
by (auto)

lemma parts_of_LtKeys [simp]: "K \<subseteq> range LtK \<Longrightarrow> parts K = K"
by (rule, rule, erule parts.induct, auto)

subsection\<open>\<open>keys_of\<close>: the long term keys of an agent\<close>
(**************************************************************************************************)

definition
  keys_of :: "agent \<Rightarrow> msg set"
where
  "keys_of A \<equiv> insert (priK A) {shrK B C | B C. B = A \<or> C = A}"

lemma keys_of_Ltk [intro!]: "keys_of A \<subseteq> range LtK"
by (auto simp add: keys_of_def)

lemma priK_keys_of [intro!]:
  "priK A \<in> keys_of A"
by (simp add: keys_of_def)

lemma shrK_keys_of_1 [intro!]:
  "shrK A B \<in> keys_of A"
by (simp add: keys_of_def)

lemma shrK_keys_of_2 [intro!]:
  "shrK B A \<in> keys_of A"
by (simp add: keys_of_def)
lemma priK_keys_of_eq [dest]:
  "priK B \<in> keys_of A \<Longrightarrow> A = B"
by (simp add: keys_of_def)

lemma shrK_keys_of_eq [dest]:
  "shrK A B \<in> keys_of C \<Longrightarrow> A = C \<or> B = C"
by (simp add: keys_of_def)

lemma def_keys_of [dest]:
  "K \<in> keys_of A \<Longrightarrow> K = priK A \<or> (\<exists> B. K = shrK A B \<or> K = shrK B A)"
by (auto simp add: keys_of_def)

lemma parts_keys_of [simp]: "parts (keys_of A) = keys_of A"
by (auto intro!: parts_of_LtKeys)

lemma analz_keys_of [simp]: "analz (keys_of A) = keys_of A"
by (rule, rule, erule analz.induct, auto)

subsection \<open>\<open>Keys_bad\<close>: bounds on the attacker's knowledge of long-term keys.\<close>
(**************************************************************************************************)

text \<open>A set of keys contains all public long term keys, and only the private/shared keys
of bad agents.\<close>

definition
  Keys_bad :: "msg set \<Rightarrow> agent set \<Rightarrow> bool"
where
  "Keys_bad IK Bad \<equiv>
    IK \<inter> range LtK \<subseteq> range pubK \<union> \<Union> (keys_of ` Bad)
    \<and> range pubK \<subseteq> IK"

\<comment> \<open>basic lemmas\<close>

lemma Keys_badI:
  "\<lbrakk> IK \<inter> range LtK \<subseteq> range pubK \<union> priK`Bad \<union> {shrK A B | A B. A \<in> Bad \<or> B \<in> Bad};
     range pubK \<subseteq> IK  \<rbrakk>
 \<Longrightarrow> Keys_bad IK Bad"
by (auto simp add: Keys_bad_def)

lemma Keys_badE [elim]:
  "\<lbrakk> Keys_bad IK Bad;
     \<lbrakk> range pubK \<subseteq> IK;
       IK \<inter> range LtK \<subseteq> range pubK \<union> \<Union> (keys_of ` Bad)\<rbrakk>
   \<Longrightarrow> P \<rbrakk>
 \<Longrightarrow> P"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_Ltk [simp]:
  "Keys_bad (IK \<inter> range LtK) Bad \<longleftrightarrow> Keys_bad IK Bad"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_priK_D: "\<lbrakk> priK A \<in> IK; Keys_bad IK Bad \<rbrakk> \<Longrightarrow> A \<in> Bad"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_shrK_D: "\<lbrakk> shrK A B \<in> IK; Keys_bad IK Bad \<rbrakk> \<Longrightarrow> A \<in> Bad \<or> B \<in> Bad"
by (auto simp add: Keys_bad_def)

lemmas Keys_bad_dests [dest] = Keys_bad_priK_D Keys_bad_shrK_D

text \<open>interaction with @{term insert}.\<close>

lemma Keys_bad_insert_non_LtK:
  "X \<notin> range LtK \<Longrightarrow> Keys_bad (insert X IK) Bad \<longleftrightarrow> Keys_bad IK Bad"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_insert_pubK:
  "\<lbrakk> Keys_bad IK Bad \<rbrakk> \<Longrightarrow> Keys_bad (insert (pubK A) IK) Bad"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_insert_priK_bad:
  "\<lbrakk> Keys_bad IK Bad; A \<in> Bad \<rbrakk> \<Longrightarrow> Keys_bad (insert (priK A) IK) Bad"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_insert_shrK_bad:
  "\<lbrakk> Keys_bad IK Bad; A \<in> Bad \<or> B \<in> Bad \<rbrakk> \<Longrightarrow> Keys_bad (insert (shrK A B) IK) Bad"
by (auto simp add: Keys_bad_def)

lemmas Keys_bad_insert_lemmas [simp] =
  Keys_bad_insert_non_LtK Keys_bad_insert_pubK
  Keys_bad_insert_priK_bad Keys_bad_insert_shrK_bad

lemma Keys_bad_insert_Fake:
assumes "Keys_bad IK Bad"
    and "parts IK \<inter> range LtK \<subseteq> IK"
    and "X \<in> synth (analz IK)"
shows "Keys_bad (insert X IK) Bad"
proof cases
  assume "X \<in> range LtK"
  then obtain ltk where "X = LtK ltk" by blast
  thus ?thesis using assms
    by (auto simp add: insert_absorb dest: analz_into_parts)
next
  assume "X \<notin> range LtK"
  thus ?thesis using assms(1) by simp
qed

lemma Keys_bad_insert_keys_of:
  "Keys_bad Ik Bad \<Longrightarrow>
   Keys_bad (keys_of A \<union> Ik) (insert A Bad)"
by (auto simp add: Keys_bad_def)

lemma Keys_bad_insert_payload:
  "Keys_bad Ik Bad \<Longrightarrow>
   x \<in> payload \<Longrightarrow>
   Keys_bad (insert x Ik) Bad"
by (auto simp add: Keys_bad_def)

subsection \<open>\<open>broken K\<close>: pairs of agents where at least one is compromised.\<close>
(**************************************************************************************************)

text \<open>Set of pairs (A,B) such that the priK of A or B, or their shared key, is in K\<close>

definition
  broken :: "msg set \<Rightarrow> (agent * agent) set"
where
  "broken K \<equiv> {(A,B) | A B. priK A \<in> K \<or> priK B \<in> K \<or> shrK A B \<in> K \<or> shrK B A \<in> K}"

lemma brokenD [dest!]:
  "(A, B) \<in> broken K \<Longrightarrow> priK A \<in> K \<or> priK B \<in> K \<or> shrK A B \<in> K \<or> shrK B A \<in> K"
by (simp add: broken_def)

lemma brokenI [intro!]:
  "priK A \<in> K \<or> priK B \<in> K \<or> shrK A B \<in> K \<or> shrK B A \<in> K \<Longrightarrow> (A, B) \<in> broken K"
by (auto simp add: broken_def)

subsection \<open>\<open>Enc_keys_clean S\<close>: messages with ``clean'' symmetric encryptions.\<close>
(**************************************************************************************************)

text \<open>All terms used as symmetric keys in S are either long term keys or messages without
implementation material.\<close>

definition
  Enc_keys_clean :: "msg set \<Rightarrow> bool"
where
  "Enc_keys_clean S \<equiv> \<forall>X Y. Enc X Y \<in> parts S \<longrightarrow> Y \<in> range LtK \<union> payload"

lemma Enc_keys_cleanI:
  "\<forall>X Y. Enc X Y \<in> parts S \<longrightarrow> Y \<in> range LtK \<union> payload \<Longrightarrow> Enc_keys_clean S"
by (simp add: Enc_keys_clean_def)

\<comment> \<open>general lemmas about \<open>Enc_keys_clean\<close>\<close>
lemma Enc_keys_clean_mono:
  "Enc_keys_clean H \<Longrightarrow> G \<subseteq> H \<Longrightarrow> Enc_keys_clean G"  \<comment> \<open>anti-tone\<close>
by (auto simp add: Enc_keys_clean_def dest!: parts_monotone [where G=G])

lemma Enc_keys_clean_Un [simp]:
  "Enc_keys_clean (G \<union> H) \<longleftrightarrow> Enc_keys_clean G \<and> Enc_keys_clean H"
by (auto simp add: Enc_keys_clean_def)

\<comment> \<open>from \<open>Enc_keys_clean S\<close>, the property on \<open>parts S\<close> also holds for \<open>analz S\<close>\<close>
lemma Enc_keys_clean_analz:
  "Enc X K \<in> analz S \<Longrightarrow> Enc_keys_clean S \<Longrightarrow> K \<in> range LtK \<union> payload"
by (auto simp add: Enc_keys_clean_def dest: analz_into_parts)

\<comment> \<open>\<open>Enc_keys_clean\<close> and different types of messages\<close>
lemma Enc_keys_clean_Tags [simp,intro]: "Enc_keys_clean Tags"
by (auto simp add: Enc_keys_clean_def)

lemma Enc_keys_clean_LtKeys [simp,intro]: "K \<subseteq> range LtK \<Longrightarrow> Enc_keys_clean K"
by (auto simp add: Enc_keys_clean_def)

lemma Enc_keys_clean_payload [simp,intro]: "NI \<subseteq> payload \<Longrightarrow> Enc_keys_clean NI"
by (auto simp add: Enc_keys_clean_def)

subsection \<open>Sets of messages with particular constructors\<close>
(**************************************************************************************************)

text \<open>Sets of all pairs, ciphertexts, and signatures constructed from a set of messages.\<close>
(*
 FIX: These should probably be turned into definitions, since they may create automation problems
*)
abbreviation AgentSet :: "msg set"
where "AgentSet \<equiv> range Agent"

abbreviation PairSet :: "msg set \<Rightarrow> msg set \<Rightarrow> msg set"
where "PairSet G H \<equiv> {Pair X Y | X Y. X \<in> G \<and> Y \<in> H}"

abbreviation EncSet :: "msg set \<Rightarrow> msg set \<Rightarrow> msg set"
where "EncSet G K \<equiv> {Enc X Y | X Y. X \<in> G \<and> Y \<in> K}"

abbreviation AencSet :: "msg set \<Rightarrow> msg set \<Rightarrow> msg set"
where "AencSet G K \<equiv> {Aenc X Y | X Y. X \<in> G \<and> Y \<in> K}"

abbreviation SignSet :: "msg set \<Rightarrow> msg set \<Rightarrow> msg set"
where "SignSet G K \<equiv> {Sign X Y | X Y. X \<in> G \<and> Y \<in> K}"

abbreviation HashSet :: "msg set \<Rightarrow> msg set"
where "HashSet G \<equiv> {Hash X | X. X \<in> G}"

text \<open>Move @{term Enc}, @{term Aenc}, @{term Sign}, and @{term Pair} sets out of @{term parts}.
\<close>

lemma parts_PairSet:
  "parts (PairSet G H) \<subseteq> PairSet G H \<union> parts G \<union> parts H"
by (rule, erule parts.induct, auto)

lemma parts_EncSet:
  "parts (EncSet G K) \<subseteq> EncSet G K \<union> PairSet (range Agent) G  \<union> range Agent \<union>  parts G"
by (rule, erule parts.induct, auto)

lemma parts_AencSet:
  "parts (AencSet G K) \<subseteq> AencSet G K \<union> PairSet (range Agent) G  \<union> range Agent \<union>  parts G"
by (rule, erule parts.induct, auto)

lemma parts_SignSet:
  "parts (SignSet G K) \<subseteq> SignSet G K \<union> PairSet (range Agent) G  \<union> range Agent \<union>  parts G"
by (rule, erule parts.induct, auto)

lemma parts_HashSet:
  "parts (HashSet G) \<subseteq> HashSet G"
by (rule, erule parts.induct, auto)

lemmas parts_msgSet = parts_PairSet parts_EncSet parts_AencSet parts_SignSet parts_HashSet
lemmas parts_msgSetD = parts_msgSet [THEN [2] rev_subsetD]

text \<open>
Remove the message sets from under the @{term "Enc_keys_clean"} predicate.
Only when the first part is a set of agents or tags for @{term Pair}, this is sufficient.\<close>

lemma Enc_keys_clean_PairSet_Agent_Un:
  "Enc_keys_clean (G \<union> H) \<Longrightarrow> Enc_keys_clean (PairSet (Agent`X) G \<union> H)"
by (auto simp add: Enc_keys_clean_def dest!: parts_msgSetD)

lemma Enc_keys_clean_PairSet_Tag_Un:
  "Enc_keys_clean (G \<union> H) \<Longrightarrow> Enc_keys_clean (PairSet Tags G \<union> H)"
by (auto simp add: Enc_keys_clean_def dest!: parts_msgSetD)

lemma Enc_keys_clean_AencSet_Un:
  "Enc_keys_clean (G \<union> H) \<Longrightarrow> Enc_keys_clean (AencSet G K \<union> H)"
by (auto simp add: Enc_keys_clean_def dest!: parts_msgSetD)

lemma Enc_keys_clean_EncSet_Un:
  "K \<subseteq> range LtK \<Longrightarrow> Enc_keys_clean (G \<union> H) \<Longrightarrow> Enc_keys_clean (EncSet G K \<union> H)"
by (auto simp add: Enc_keys_clean_def dest!: parts_msgSetD)

lemma Enc_keys_clean_SignSet_Un:
  "Enc_keys_clean (G \<union> H) \<Longrightarrow> Enc_keys_clean (SignSet G K \<union> H)"
by (auto simp add: Enc_keys_clean_def dest!: parts_msgSetD)

lemma Enc_keys_clean_HashSet_Un:
  "Enc_keys_clean (G \<union> H) \<Longrightarrow> Enc_keys_clean (HashSet G \<union> H)"
by (auto simp add: Enc_keys_clean_def dest!: parts_msgSetD)

lemmas Enc_keys_clean_msgSet_Un =
  Enc_keys_clean_PairSet_Tag_Un Enc_keys_clean_PairSet_Agent_Un
  Enc_keys_clean_EncSet_Un Enc_keys_clean_AencSet_Un
  Enc_keys_clean_SignSet_Un Enc_keys_clean_HashSet_Un

subsubsection \<open>Lemmas for moving message sets out of @{term "analz"}\<close>
(**************************************************************************************************)

text \<open>Pull @{term EncSet} out of @{term analz}.\<close>

lemma analz_Un_EncSet:
assumes "K \<subseteq> range LtK" and "Enc_keys_clean (G \<union> H)"
shows "analz (EncSet G K \<union> H) \<subseteq> EncSet G K \<union> analz (G \<union> H)"
proof
  fix X
  assume "X \<in> analz (EncSet G K \<union> H)"
  thus "X \<in> EncSet G K \<union> analz (G \<union> H)"
  proof (induction X rule: analz.induct)
    case (Dec Y K')
    from Dec.IH(1) show ?case
    proof
      assume "Enc Y K' \<in> analz (G \<union> H)"
      have "K' \<in> synth (analz (G \<union> H))"
      proof -
        have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz (G \<union> H)\<close> assms(2)
          by (blast dest: Enc_keys_clean_analz)
        moreover
        have "K' \<in> synth (EncSet G K \<union> analz (G \<union> H))" using Dec.IH(2)
          by (auto simp add: Collect_disj_eq dest: synth_Int2)
        moreover
        hence "K' \<in> synth (analz (G \<union> H)) \<union> -payload" using assms(1)
          by (blast dest!: synth_payload2 [THEN [2] rev_subsetD])
        ultimately show ?thesis by auto
      qed
      thus ?case using \<open>Enc Y K' \<in> analz (G \<union> H)\<close> by auto
    qed auto
  next
    case (Adec_eph Y K')
    thus ?case by (auto dest!: EpriK_synth)
  qed (auto)
qed

text \<open>Pull @{term EncSet} out of @{term analz}, 2nd case: the keys are unknown.\<close>

lemma analz_Un_EncSet2:
assumes "Enc_keys_clean H" and "K \<subseteq> range LtK" and "K \<inter> synth (analz H) = {}"
shows "analz (EncSet G K \<union> H) \<subseteq> EncSet G K \<union> analz H"
proof
  fix X
  assume "X \<in> analz (EncSet G K \<union> H)"
  thus "X \<in> EncSet G K \<union> analz H"
  proof (induction X rule: analz.induct)
    case (Dec Y K')
    from Dec.IH(1) show ?case
    proof
      assume "Enc Y K' \<in> analz H"
      moreover have "K' \<in> synth (analz H)"
      proof -
          have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz H\<close> assms(1)
            by (auto dest: Enc_keys_clean_analz)
          moreover
          from Dec.IH(2) have H: "K' \<in> synth (EncSet G K \<union> analz H)"
            by (auto simp add: Collect_disj_eq dest: synth_Int2)
          moreover
          hence "K' \<in> synth (analz H) \<union> -payload"
          proof (rule synth_payload2 [THEN [2] rev_subsetD], auto elim!: payload_Enc)
            fix X Y
            assume "Y \<in> K" "Y \<in> payload"
            with \<open>K \<subseteq> range LtK\<close> obtain KK where "Y = LtK KK" by auto
            with \<open>Y \<in> payload\<close> show False by auto
          qed
        ultimately
        show ?thesis by auto
      qed
      ultimately show ?case by auto
    next
      assume "Enc Y K' \<in> EncSet G K"
      moreover hence "K' \<in> K" by auto
      moreover with \<open>K \<subseteq> range LtK\<close> obtain KK where "K' = LtK KK" by auto
      moreover with Dec.IH(2) have "K' \<in> analz H"
        by (auto simp add: Collect_disj_eq dest: synth_Int2)
      ultimately show ?case using \<open>K \<inter> synth (analz H) = {}\<close> by auto
    qed
  next
    case (Adec_eph Y K')
    thus ?case by (auto dest!: EpriK_synth)
  qed (insert assms(2), auto)
qed

text \<open>Pull @{term AencSet} out of the @{term analz}.\<close>

lemma analz_Un_AencSet:
assumes "K \<subseteq> range LtK" and "Enc_keys_clean (G \<union> H)"
shows "analz (AencSet G K \<union> H) \<subseteq> AencSet G K \<union> analz (G \<union> H)"
proof
  fix X
  assume "X \<in> analz (AencSet G K \<union> H)"
  thus "X \<in> AencSet G K \<union> analz (G \<union> H)"
  proof (induction X rule: analz.induct)
    case (Dec Y K')
    from Dec.IH(1) have "Enc Y K' \<in> analz (G \<union> H)" by auto
    moreover have "K' \<in> synth (analz (G \<union> H))"
    proof -
      have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz (G \<union> H)\<close> assms(2)
        by (blast dest: Enc_keys_clean_analz)
      moreover
      have "K' \<in> synth (AencSet G K \<union> analz (G \<union> H))" using Dec.IH(2)
        by (auto simp add: Collect_disj_eq dest: synth_Int2)
      moreover
      hence "K' \<in> synth (analz (G \<union> H)) \<union> -payload" using assms(1)
        by (blast dest!: synth_payload2 [THEN [2] rev_subsetD])
      ultimately
      show ?thesis by auto
    qed
    ultimately show ?case by auto
  next
    case (Adec_eph Y K')
    thus ?case by (auto dest!: EpriK_synth)
  qed auto
qed

text \<open>Pull @{term AencSet} out of @{term analz}, 2nd case: the keys are unknown.\<close>

lemma analz_Un_AencSet2:
assumes "Enc_keys_clean H" and "priK`Ag \<inter> synth (analz H) = {}"
shows "analz (AencSet G (pubK`Ag) \<union> H) \<subseteq> AencSet G (pubK`Ag) \<union> analz H"
proof
  fix X
  assume "X \<in> analz (AencSet G (pubK` Ag) \<union> H)"
  thus "X \<in> AencSet G (pubK` Ag) \<union> analz H"
  proof (induction X rule: analz.induct)
    case (Dec Y K')
    from Dec.IH(1) have "Enc Y K' \<in> analz H" by auto
    moreover have "K' \<in> synth (analz H)"
    proof -
      have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz H\<close> assms(1)
      by (auto dest: Enc_keys_clean_analz)
      moreover
      from Dec.IH(2) have H: "K' \<in> synth (AencSet G (pubK`Ag) \<union> analz H)"
        by (auto simp add: Collect_disj_eq dest: synth_Int2)
      moreover
      hence "K' \<in> synth (analz H) \<union> -payload"
        by (auto dest: synth_payload2 [THEN [2] rev_subsetD])
      ultimately
      show ?thesis by auto
    qed
    ultimately show ?case by auto
  next
    case (Adec_eph Y K')
    thus ?case by (auto dest!: EpriK_synth)
  qed (insert assms(2), auto)
qed

text \<open>Pull @{term PairSet} out of @{term analz}.\<close>
lemma analz_Un_PairSet:
  "analz (PairSet G G' \<union> H) \<subseteq> PairSet G G' \<union> analz (G \<union> G' \<union> H)"
proof
  fix X
  assume "X \<in> analz (PairSet G G' \<union> H)"
  thus "X \<in> PairSet G G' \<union> analz (G \<union> G' \<union> H)"
  proof (induct X rule: analz.induct)
    case (Dec Y K)
    from Dec.hyps(2) have "Enc Y K \<in> analz (G \<union> G' \<union> H)" by auto
    moreover
    from Dec.hyps(3) have "K \<in> synth (PairSet G G' \<union> analz (G \<union> G' \<union> H))"
      by (auto simp add: Collect_disj_eq dest: synth_Int2)
    then have "K \<in> synth (analz (G \<union> G' \<union> H))"
      by (elim synth_trans) auto
    ultimately
    show ?case by auto
  next
    case (Adec_eph Y K)
    thus ?case by (auto dest!: EpriK_synth)
  qed auto
qed

\<comment> \<open>move the \<open>SignSet\<close> out of the \<open>analz\<close>\<close>
lemma analz_Un_SignSet:
assumes "K \<subseteq> range LtK" and "Enc_keys_clean (G \<union> H)"
shows "analz (SignSet G K \<union> H) \<subseteq> SignSet G K \<union> analz (G \<union> H)"
proof
  fix X
  assume "X \<in> analz (SignSet G K \<union> H)"
  thus "X \<in> SignSet G K \<union> analz (G \<union> H)"
  proof (induct X rule: analz.induct)
    case (Dec Y K')
    from Dec.hyps(2) have "Enc Y K' \<in> analz (G \<union> H)" by auto
    moreover have "K' \<in> synth (analz (G \<union> H))"
    proof -
      have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz (G \<union> H)\<close> assms(2)
        by (blast dest: Enc_keys_clean_analz)
      moreover
      from Dec.hyps(3) have "K' \<in> synth (SignSet G K \<union> analz (G \<union> H)) "
        by (auto simp add: Collect_disj_eq dest: synth_Int2)
      moreover
      hence "K' \<in> synth (analz (G \<union> H)) \<union> -payload" using assms(1)
        by (blast dest!: synth_payload2 [THEN [2] rev_subsetD])
      ultimately
      show ?thesis by auto
    qed
    ultimately show ?case by auto
  next
    case (Adec_eph Y K)
    thus ?case by (auto dest!: EpriK_synth)
  qed auto
qed

text \<open>Pull @{term Tags} out of @{term analz}.\<close>

lemma analz_Un_Tag:
assumes "Enc_keys_clean H"
shows "analz (Tags \<union> H) \<subseteq> Tags \<union> analz H"
proof
  fix X
  assume "X \<in> analz (Tags \<union> H)"
  thus "X \<in> Tags \<union> analz H"
  proof (induction X rule: analz.induct)
    case (Dec Y K')
    have "Enc Y K' \<in> analz H" using Dec.IH(1) by auto
    moreover have "K' \<in> synth (analz H)"
    proof -
      have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz H\<close> assms
        by (auto dest: Enc_keys_clean_analz)
      moreover
      from Dec.IH(2) have "K' \<in> synth (Tags \<union> analz H)"
        by (auto simp add: Collect_disj_eq dest: synth_Int2)
      moreover
      hence "K' \<in> synth (analz H) \<union> -payload"
        by (auto dest: synth_payload2 [THEN [2] rev_subsetD])
      ultimately show ?thesis by auto
    qed
    ultimately show ?case by (auto)
  next
    case (Adec_eph Y K')
    thus ?case by (auto dest!: EpriK_synth)
  qed auto
qed

text \<open>Pull the @{term AgentSet} out of the @{term analz}.\<close>

text \<open>Pull @{term HashSet} out of @{term analz}.\<close>
lemma analz_Un_HashSet:
assumes "Enc_keys_clean H" and "G \<subseteq> - payload"
shows "analz (HashSet G  \<union> H) \<subseteq> HashSet G \<union> analz H"
proof
  fix X
  assume "X \<in> analz (HashSet G \<union> H)"
  thus "X \<in> HashSet G \<union> analz H"
  proof (induction X rule: analz.induct)
    case (Dec Y K')
    from Dec.IH(1) have "Enc Y K' \<in> analz H" by auto
    moreover have "K' \<in> synth (analz H)"
    proof -
      have "K' \<in> range LtK \<union> payload" using \<open>Enc Y K' \<in> analz H\<close> assms(1)
      by (auto dest: Enc_keys_clean_analz)
      thus ?thesis
      proof
        assume "K' \<in> range LtK"
        then obtain KK where "K' = LtK KK" by auto
        moreover
        with Dec.IH(2) show ?thesis
          by (auto simp add: Collect_disj_eq dest: synth_Int2)
      next
        assume "K' \<in> payload"
        moreover
        from assms have "HashSet G \<inter> payload = {}" by auto
        moreover from Dec.IH(2) have "K' \<in> synth (HashSet G \<union> analz H)"
          by (auto simp add: Collect_disj_eq dest: synth_Int2)
        ultimately
        have "K' \<in> synth (analz H) \<union> -payload"
          by (auto dest: synth_payload2 [THEN [2] rev_subsetD])
        with \<open>K' \<in> payload\<close> show ?thesis by auto
      qed
    qed
    ultimately show ?case by auto
  next
    case (Adec_eph Y K')
    thus ?case by (auto dest!: EpriK_synth)
  qed (insert assms(2), auto)
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(* Arch specific lemmas that should be moved into theory files before CRefine *)

theory ArchMove_C
imports Move_C
begin

lemma ps_clear_is_aligned_ksPSpace_None:
  "\<lbrakk>ps_clear p n s; is_aligned p n; 0<d; d \<le> mask n\<rbrakk>
   \<Longrightarrow> ksPSpace s (p + d) = None"
  apply (simp add: ps_clear_def add_diff_eq[symmetric] mask_2pm1[symmetric])
  apply (drule equals0D[where a="p + d"])
  apply (simp add: dom_def word_gt_0)
  apply (drule mp)
   apply (rule word_plus_mono_right)
    apply simp
   apply (simp add: mask_2pm1)
   apply (erule is_aligned_no_overflow')
  apply (drule mp)
   apply (case_tac "(0::machine_word)<2^n")
    apply (frule le_m1_iff_lt[of "(2::machine_word)^n" d, THEN iffD1])
    apply (simp add: mask_2pm1[symmetric])
    apply (erule (1) is_aligned_no_wrap')
   apply (simp add: is_aligned_mask mask_2pm1 not_less word_bits_def
                    power_overflow)
  by assumption

lemma ps_clear_is_aligned_ctes_None:
  assumes "ps_clear p tcbBlockSizeBits s"
      and "is_aligned p tcbBlockSizeBits"
  shows "ksPSpace s (p + 2*2^cteSizeBits) = None"
    and "ksPSpace s (p + 3*2^cteSizeBits) = None"
    and "ksPSpace s (p + 4*2^cteSizeBits) = None"
  by (auto intro: assms ps_clear_is_aligned_ksPSpace_None
            simp: objBits_defs mask_def)+

(* FIXME X64: use earlier or replace with earlier def? *)
definition
  port_mask :: "16 word \<Rightarrow> 16 word \<Rightarrow> machine_word"
where
  "port_mask start end =
     mask (unat (end && mask wordRadix)) && ~~ mask (unat (start && mask wordRadix))"

lemma unat_ucast_prio_L1_cmask_simp:
  "unat (ucast (p::priority) && 0x3F :: machine_word) = unat (p && 0x3F)"
  using unat_ucast_prio_mask_simp[where m=6]
  by (simp add: mask_def)

lemma ucast_shiftl_6_absorb:
  fixes f l :: "16 word"
  assumes "f \<le> l"
  assumes "f >> 6 < l >> 6"
  shows "UCAST(16\<rightarrow>32 signed) ((f >> 6) + 1) << 6 = UCAST(16 \<rightarrow> 32 signed) (((f >> 6) + 1) << 6)"
  using assms
  by (word_bitwise, auto)

lemma prio_ucast_shiftr_wordRadix_helper: (* FIXME generalise *)
  "(ucast (p::priority) >> wordRadix :: machine_word) < 4"
  unfolding maxPriority_def numPriorities_def wordRadix_def
  using unat_lt2p[where x=p]
  apply (clarsimp simp add: word_less_nat_alt shiftr_div_2n' unat_ucast_upcast is_up word_le_nat_alt)
  apply arith
  done

lemma prio_ucast_shiftr_wordRadix_helper': (* FIXME generalise *)
  "(ucast (p::priority) >> wordRadix :: machine_word) \<le> 3"
  unfolding maxPriority_def numPriorities_def wordRadix_def
  using unat_lt2p[where x=p]
  apply (clarsimp simp add: word_less_nat_alt shiftr_div_2n' unat_ucast_upcast is_up word_le_nat_alt)
  apply arith
  done

lemma prio_unat_shiftr_wordRadix_helper': (* FIXME generalise *)
  "unat ((p::priority) >> wordRadix) \<le> 3"
  unfolding maxPriority_def numPriorities_def wordRadix_def
  using unat_lt2p[where x=p]
  apply (clarsimp simp add: word_less_nat_alt shiftr_div_2n' unat_ucast_upcast is_up word_le_nat_alt)
  apply arith
  done

lemma prio_ucast_shiftr_wordRadix_helper2: (* FIXME possibly unused *)
  "(ucast (p::priority) >> wordRadix :: machine_word) < 0x20"
  by (rule order_less_trans[OF prio_ucast_shiftr_wordRadix_helper]; simp)

lemma prio_ucast_shiftr_wordRadix_helper3:
  "(ucast (p::priority) >> wordRadix :: machine_word) < 0x40"
  by (rule order_less_trans[OF prio_ucast_shiftr_wordRadix_helper]; simp)

lemmas setEndpoint_obj_at_tcb' = setEndpoint_obj_at'_tcb

(* FIXME: Move to Schedule_R.thy. Make Arch_switchToThread_obj_at a specialisation of this *)
lemma Arch_switchToThread_obj_at_pre:
  "\<lbrace>obj_at' (Not \<circ> tcbQueued) t\<rbrace>
   Arch.switchToThread t
   \<lbrace>\<lambda>rv. obj_at' (Not \<circ> tcbQueued) t\<rbrace>"
  apply (simp add: X64_H.switchToThread_def)
  apply (wp asUser_obj_at_notQ doMachineOp_obj_at hoare_drop_imps|wpc)+
  done

crunch pspace_canonical'[wp]: setThreadState pspace_canonical'

lemma word_shift_by_3:
  "x * 8 = (x::'a::len word) << 3"
  by (simp add: shiftl_t2n)

definition
  user_word_at :: "machine_word \<Rightarrow> machine_word \<Rightarrow> kernel_state \<Rightarrow> bool"
where
 "user_word_at x p \<equiv> \<lambda>s. is_aligned p 3
       \<and> pointerInUserData p s
       \<and> x = word_rcat (map (underlying_memory (ksMachineState s))
                                [p + 7, p + 6, p + 5, p + 4, p + 3, p + 2, p + 1, p])"

definition
  device_word_at :: "machine_word \<Rightarrow> machine_word \<Rightarrow> kernel_state \<Rightarrow> bool"
where
 "device_word_at x p \<equiv> \<lambda>s. is_aligned p 3
       \<and> pointerInDeviceData p s
       \<and> x = word_rcat (map (underlying_memory (ksMachineState s))
                                [p + 7, p + 6, p + 5, p + 4, p + 3, p + 2, p + 1, p])"

lemma getMessageInfo_less_4:
  "\<lbrace>\<top>\<rbrace> getMessageInfo t \<lbrace>\<lambda>rv s. msgExtraCaps rv < 4\<rbrace>"
  including no_pre
  apply (simp add: getMessageInfo_def)
  apply wp
  apply (rule hoare_strengthen_post, rule hoare_vcg_prop)
  apply (simp add: messageInfoFromWord_def Let_def
                   Types_H.msgExtraCapBits_def)
  apply (rule word_leq_minus_one_le, simp)
  apply simp
  apply (rule word_and_le1)
  done

lemma getMessageInfo_msgLength':
  "\<lbrace>\<top>\<rbrace> getMessageInfo t \<lbrace>\<lambda>rv s. msgLength rv \<le> 0x78\<rbrace>"
  including no_pre
  apply (simp add: getMessageInfo_def)
  apply wp
  apply (rule hoare_strengthen_post, rule hoare_vcg_prop)
  apply (simp add: messageInfoFromWord_def Let_def msgMaxLength_def not_less
                   Types_H.msgExtraCapBits_def split: if_split )
  done

lemma ucast_le_ucast_8_32:
  "(ucast x \<le> (ucast y :: word32)) = (x \<le> (y :: word8))"
  by (simp add: word_le_nat_alt is_up_8_32 unat_ucast_upcast)

lemma asid_shiftr_low_bits_less:
  "(asid :: machine_word) \<le> mask asid_bits \<Longrightarrow> asid >> asid_low_bits < 0x8"
  apply (rule_tac y="2 ^ 3" in order_less_le_trans)
   apply (rule shiftr_less_t2n)
   apply (simp add: le_mask_iff_lt_2n[THEN iffD1] asid_bits_def asid_low_bits_def)
  apply simp
  done

lemma addToBitmap_sets_L1Bitmap_same_dom:
  "\<lbrace>\<lambda>s. p \<le> maxPriority \<and> d' = d \<rbrace> addToBitmap d' p
       \<lbrace>\<lambda>rv s. ksReadyQueuesL1Bitmap s d \<noteq> 0 \<rbrace>"
  unfolding addToBitmap_def bitmap_fun_defs
  apply wpsimp
  apply (clarsimp simp: maxPriority_def numPriorities_def word_or_zero le_def
                        prioToL1Index_max[simplified wordRadix_def, simplified])
  done

context begin interpretation Arch .

lemma vmsz_aligned_aligned_pageBits:
  "vmsz_aligned ptr sz \<Longrightarrow> is_aligned ptr pageBits"
  apply (simp add: vmsz_aligned_def)
  apply (erule is_aligned_weaken)
  apply (simp add: pageBits_def pageBitsForSize_def
            split: vmpage_size.split)
  done

lemma empty_fail_findVSpaceForASID[iff]:
  "empty_fail (findVSpaceForASID asid)"
  unfolding findVSpaceForASID_def checkPML4At_def
  by (wpsimp wp: empty_fail_getObject)

crunch inv'[wp]: archThreadGet P

(* FIXME MOVE near thm tg_sp' *)
lemma atg_sp':
  "\<lbrace>P\<rbrace> archThreadGet f p \<lbrace>\<lambda>t. obj_at' (\<lambda>t'. f (tcbArch t') = t) p and P\<rbrace>"
  including no_pre
  apply (simp add: archThreadGet_def)
  apply wp
  apply (rule hoare_strengthen_post)
   apply (rule getObject_tcb_sp)
  apply clarsimp
  apply (erule obj_at'_weakenE)
  apply simp
  done

(* FIXME: MOVE to EmptyFail *)
lemma empty_fail_archThreadGet [intro!, wp, simp]:
  "empty_fail (archThreadGet f p)"
  by (fastforce simp: archThreadGet_def getObject_def split_def)

lemma more_pageBits_inner_beauty:
  fixes x :: "9 word"
  fixes p :: machine_word
  assumes x: "x \<noteq> ucast (p && mask pageBits >> 3)"
  shows "(p && ~~ mask pageBits) + (ucast x * 8) \<noteq> p"
  apply clarsimp
  apply (simp add: word_shift_by_3)
  apply (subst (asm) word_plus_and_or_coroll)
   apply (word_eqI_solve dest: test_bit_size simp: pageBits_def)
  apply (insert x)
  apply (erule notE)
  apply word_eqI
  apply (erule_tac x="3+n" in allE)
  apply (clarsimp simp: word_size pageBits_def)
  done

(* FIXME x64: figure out where these are needed and adjust appropriately *)
lemma mask_pageBits_inner_beauty:
  "is_aligned p 3 \<Longrightarrow>
  (p && ~~ mask pageBits) + (ucast ((ucast (p && mask pageBits >> 3)):: 9 word) * 8) = (p::machine_word)"
  apply (simp add: is_aligned_nth word_shift_by_3)
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI)
   apply (clarsimp simp: word_size word_ops_nth_size nth_ucast nth_shiftr nth_shiftl)
  apply (rule word_eqI)
  apply (clarsimp simp: word_size word_ops_nth_size nth_ucast nth_shiftr nth_shiftl
                        pageBits_def)
  apply (rule iffI)
   apply (erule disjE)
    apply clarsimp
   apply clarsimp
  apply simp
  apply clarsimp
  apply (rule context_conjI)
   apply (rule leI)
   apply clarsimp
  apply simp
  apply arith
  done

(* FIXME: move to ainvs? *)
lemma sign_extend_canonical_address:
  "(x = sign_extend 47 x) = canonical_address x"
  by (fastforce simp: sign_extended_iff_sign_extend canonical_address_sign_extended)

crunches Arch.switchToThread
  for valid_queues'[wp]: valid_queues'
  (simp: crunch_simps)
crunches switchToIdleThread
  for ksCurDomain[wp]: "\<lambda>s. P (ksCurDomain s)"
crunches switchToIdleThread, switchToThread
  for valid_pspace'[wp]: valid_pspace'
  (simp: whenE_def crunch_simps)

lemma setCurrentUserCR3_valid_arch_state'[wp]:
  "\<lbrace>valid_arch_state' and K (valid_cr3' c)\<rbrace> setCurrentUserCR3 c \<lbrace>\<lambda>_. valid_arch_state'\<rbrace>"
  by (wpsimp simp: setCurrentUserCR3_def valid_arch_state'_def)

lemma setVMRoot_valid_arch_state':
  "\<lbrace>valid_arch_state'\<rbrace> setVMRoot t \<lbrace>\<lambda>_. valid_arch_state'\<rbrace>"
  apply (simp add: setVMRoot_def getThreadVSpaceRoot_def setCurrentUserVSpaceRoot_def)
  apply (wp whenE_wp getCurrentUserCR3_wp findVSpaceForASID_vs_at_wp
         | wpcw
         | clarsimp simp: if_apply_def2 asid_wf_0
         | strengthen valid_cr3'_makeCR3)+
  done

crunch valid_arch_state'[wp]: switchToThread valid_arch_state'
  (wp: crunch_wps simp: crunch_simps)

lemma mab_gt_2 [simp]:
  "2 \<le> msg_align_bits" by (simp add: msg_align_bits)

lemma loadWordUser_submonad_fn:
  "loadWordUser p = submonad_fn ksMachineState (ksMachineState_update \<circ> K)
                                (pointerInUserData p) (loadWord p)"
  by (simp add: loadWordUser_def submonad_doMachineOp.fn_is_sm submonad_fn_def)

lemma storeWordUser_submonad_fn:
  "storeWordUser p v = submonad_fn ksMachineState (ksMachineState_update \<circ> K)
                                   (pointerInUserData p) (storeWord p v)"
  by (simp add: storeWordUser_def submonad_doMachineOp.fn_is_sm submonad_fn_def)

lemma threadGet_tcbFault_loadWordUser_comm:
  "do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> loadWordUser p; n x y od =
   do y \<leftarrow> loadWordUser p; x \<leftarrow> threadGet tcbFault t; n x y od"
  apply (rule submonad_comm [OF tcbFault_submonad_args _
                                threadGet_tcbFault_submonad_fn
                                loadWordUser_submonad_fn])
       apply (simp add: submonad_args_def pointerInUserData_def)
      apply (simp add: thread_replace_def Let_def)
     apply simp
    apply (clarsimp simp: thread_replace_def Let_def typ_at'_def ko_wp_at'_def
                          ps_clear_upd ps_clear_upd_None pointerInUserData_def
                   split: option.split kernel_object.split)
   apply (simp add: get_def empty_fail_def)
  apply (simp add: ef_loadWord)
  done

lemma threadGet_tcbFault_storeWordUser_comm:
  "do x \<leftarrow> threadGet tcbFault t; y \<leftarrow> storeWordUser p v; n x y od =
   do y \<leftarrow> storeWordUser p v; x \<leftarrow> threadGet tcbFault t; n x y od"
  apply (rule submonad_comm [OF tcbFault_submonad_args _
                                threadGet_tcbFault_submonad_fn
                                storeWordUser_submonad_fn])
       apply (simp add: submonad_args_def pointerInUserData_def)
      apply (simp add: thread_replace_def Let_def)
     apply simp
    apply (clarsimp simp: thread_replace_def Let_def typ_at'_def ko_wp_at'_def
                          ps_clear_upd ps_clear_upd_None pointerInUserData_def
                   split: option.split kernel_object.split)
   apply (simp add: get_def empty_fail_def)
  apply (simp add: ef_storeWord)
  done

lemma asUser_getRegister_discarded:
  "(asUser t (getRegister r)) >>= (\<lambda>_. n) =
   stateAssert (tcb_at' t) [] >>= (\<lambda>_. n)"
  apply (rule ext)
  apply (clarsimp simp: submonad_asUser.fn_is_sm submonad_fn_def
                        submonad_asUser.args assert_def select_f_def
                        gets_def get_def modify_def put_def
                        getRegister_def bind_def split_def
                        return_def fail_def stateAssert_def)
  done

(* FIXME x64: check *)
lemma addrFromPPtr_mask:
  "n \<le> 39
    \<Longrightarrow> addrFromPPtr ptr && mask n = ptr && mask n"
  apply (simp add: addrFromPPtr_def X64.pptrBase_def)
  apply word_bitwise
  apply simp
  done

lemma asUser_get_registers:
  "\<lbrace>tcb_at' target\<rbrace>
     asUser target (mapM getRegister xs)
   \<lbrace>\<lambda>rv s. obj_at' (\<lambda>tcb. map ((user_regs o atcbContextGet o tcbArch) tcb) xs = rv) target s\<rbrace>"
  apply (induct xs)
   apply (simp add: mapM_empty asUser_return)
   apply wp
   apply simp
  apply (simp add: mapM_Cons asUser_bind_distrib asUser_return empty_fail_cond)
  apply wp
   apply simp
   apply (rule hoare_strengthen_post)
    apply (erule hoare_vcg_conj_lift)
    apply (rule asUser_inv)
    apply (simp add: getRegister_def)
    apply (wp mapM_wp')
   apply clarsimp
   apply (erule(1) obj_at_conj')
  apply (wp)
   apply (simp add: asUser_def split_def threadGet_def)
   apply (wp getObject_tcb_wp)
  apply (clarsimp simp: getRegister_def simpler_gets_def
                        obj_at'_def)
  done

(* FIXME: move to where is_aligned_ptrFromPAddr is *)
lemma is_aligned_ptrFromPAddr_pageBitsForSize:
  "is_aligned p (pageBitsForSize sz) \<Longrightarrow> is_aligned (ptrFromPAddr p) (pageBitsForSize sz)"
  by (cases sz ; simp add: is_aligned_ptrFromPAddr_n bit_simps)

lemma is_aligned_pageBitsForSize_minimum:
  "\<lbrakk> is_aligned p (pageBitsForSize sz) ; n \<le> pageBits \<rbrakk> \<Longrightarrow> is_aligned p n"
  apply (cases sz; clarsimp simp: pageBits_def)
  apply (erule is_aligned_weaken, simp)+
  done

lemma valid_objs_valid_pte': "\<lbrakk> valid_objs' s ; ko_at' (ko :: pte) p s \<rbrakk> \<Longrightarrow> valid_pte' ko s"
  by (fastforce simp add: obj_at'_def ran_def valid_obj'_def projectKOs valid_objs'_def)

lemma obj_at_kernel_mappings':
  "\<lbrakk>pspace_in_kernel_mappings' s; obj_at' P p s\<rbrakk> \<Longrightarrow>
   p \<in> kernel_mappings"
  by (clarsimp simp: pspace_in_kernel_mappings'_def obj_at'_def dom_def)

(* FIXME: move to Wellformed, turn valid_asid_pool' into an abbreviation >>>*)
primrec
  wf_asid_pool' :: "asidpool \<Rightarrow> bool"
where
  "wf_asid_pool' (ASIDPool pool) =
   (dom pool \<subseteq> {0 .. 2^asid_low_bits - 1} \<and>
    0 \<notin> ran pool \<and> (\<forall>x \<in> ran pool. is_aligned x pml4_bits))"

lemma valid_eq_wf_asid_pool'[simp]:
  "valid_asid_pool' pool = (\<lambda>s. wf_asid_pool' pool)"
  by (case_tac pool) simp

declare valid_asid_pool'.simps[simp del]
(*<<<*)

(* FIXME: change the original to be predicated! *)
crunch pred_tcb_at'2[wp]: doMachineOp "\<lambda>s. P (pred_tcb_at' a b p s)"
  (simp: crunch_simps)

lemma valid_untyped':
  notes usableUntypedRange.simps[simp del]
  assumes pspace_distinct': "pspace_distinct' s" and
           pspace_aligned': "pspace_aligned' s" and
                        al: "is_aligned ptr bits"
  shows "valid_untyped' d ptr bits idx s =
         (\<forall>p ko. ksPSpace s p = Some ko \<longrightarrow>
                 obj_range' p ko \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {} \<longrightarrow>
                 obj_range' p ko \<subseteq> {ptr..ptr + 2 ^ bits - 1} \<and>
                 obj_range' p ko \<inter>
                   usableUntypedRange (UntypedCap d ptr bits idx) = {})"
  apply (simp add: valid_untyped'_def)
  apply (simp add: ko_wp_at'_def)
  apply (rule arg_cong[where f=All])
  apply (rule ext)
  apply (rule arg_cong[where f=All])
  apply (rule ext)
  apply (case_tac "ksPSpace s ptr' = Some ko", simp_all)
  apply (frule pspace_alignedD'[OF _ pspace_aligned'])
  apply (frule pspace_distinctD'[OF _ pspace_distinct'])
  apply simp
  apply (frule aligned_ranges_subset_or_disjoint[OF al])
  apply (fold obj_range'_def)
  apply (rule iffI)
   apply auto[1]
  apply (rule conjI)
   apply (rule ccontr, simp)
   apply (simp add: Set.psubset_eq)
   apply (erule conjE)
   apply (case_tac "obj_range' ptr' ko \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {}", simp)
   apply (cut_tac is_aligned_no_overflow[OF al])
   apply (auto simp add: obj_range'_def)[1]
  apply (clarsimp simp add: usableUntypedRange.simps Int_commute)
  apply (case_tac "obj_range' ptr' ko \<inter> {ptr..ptr + 2 ^ bits - 1} \<noteq> {}", simp+)
  apply (cut_tac is_aligned_no_overflow[OF al])
  apply (clarsimp simp add: obj_range'_def)
  apply (frule is_aligned_no_overflow)
  by (metis al intvl_range_conv' le_m1_iff_lt less_is_non_zero_p1
               nat_le_linear power_overflow sub_wrap add_0
               add_0_right word_add_increasing word_less_1 word_less_sub_1)

(* We don't have access to n_msgRegisters from C here, but the number of msg registers in C should
   be equivalent to what we have in the abstract/design specs. We want a number for this definition
   that automatically updates if the number of registers changes, and we sanity check it later
   in msgRegisters_size_sanity *)
definition size_msgRegisters :: nat where
  size_msgRegisters_pre_def: "size_msgRegisters \<equiv> size (X64.msgRegisters)"

schematic_goal size_msgRegisters_def:
  "size_msgRegisters = numeral ?x"
  unfolding size_msgRegisters_pre_def X64.msgRegisters_def
  by (simp add: upto_enum_red fromEnum_def enum_register del: Suc_eq_numeral)
     (simp only: Suc_eq_plus1_left, simp del: One_nat_def)

lemma length_msgRegisters[simplified size_msgRegisters_def]:
  "length X64_H.msgRegisters = size_msgRegisters"
  by (simp add: size_msgRegisters_pre_def X64_H.msgRegisters_def)

lemma empty_fail_loadWordUser[intro!, simp]:
  "empty_fail (loadWordUser x)"
  by (fastforce simp: loadWordUser_def ef_loadWord ef_dmo')

lemma empty_fail_getMRs[iff]:
  "empty_fail (getMRs t buf mi)"
  by (auto simp add: getMRs_def split: option.split)

lemma empty_fail_getReceiveSlots:
  "empty_fail (getReceiveSlots r rbuf)"
proof -
  note
    empty_fail_resolveAddressBits[wp]
    empty_fail_rethrowFailure[wp]
    empty_fail_rethrowFailure[wp]
  show ?thesis
  unfolding getReceiveSlots_def loadCapTransfer_def lookupCap_def lookupCapAndSlot_def
  by (wpsimp simp: emptyOnFailure_def unifyFailure_def lookupSlotForThread_def
                   capTransferFromWords_def getThreadCSpaceRoot_def locateSlot_conv bindE_assoc
                   lookupSlotForCNodeOp_def lookupErrorOnFailure_def rangeCheck_def)
qed

lemma user_getreg_rv:
  "\<lbrace>obj_at' (\<lambda>tcb. P ((user_regs o atcbContextGet o tcbArch) tcb r)) t\<rbrace>
   asUser t (getRegister r)
   \<lbrace>\<lambda>rv s. P rv\<rbrace>"
  apply (simp add: asUser_def split_def)
  apply (wp threadGet_wp)
  apply (clarsimp simp: obj_at'_def getRegister_def in_monad atcbContextGet_def)
  done

crunches insertNewCap, Arch_createNewCaps, threadSet, Arch.createObject, setThreadState,
         updateFreeIndex, preemptionPoint
  for gsCNodes[wp]: "\<lambda>s. P (gsCNodes s)"
  (wp: crunch_wps setObject_ksPSpace_only
   simp: unless_def updateObject_default_def crunch_simps
   ignore_del: preemptionPoint)

lemma cap_case_isPML4Cap:
  "(case cap of ArchObjectCap (PML4Cap pm (Some asid)) \<Rightarrow> fn pm asid | _ => g)
    = (if (if isArchObjectCap cap then if isPML4Cap (capCap cap) then capPML4MappedASID (capCap cap) \<noteq> None else False else False)
          then fn (capPML4BasePtr (capCap cap)) (the (capPML4MappedASID (capCap cap))) else g)"
  apply (cases cap; simp add: isArchObjectCap_def)
  apply (rename_tac arch_capability)
  apply (case_tac arch_capability, simp_all add: isPML4Cap_def)
  apply (rename_tac option)
  apply (case_tac option; simp)
  done

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
  Example C structure instantiation and related lemmas
*)

theory CompoundCTypesEx
imports CompoundCTypes
begin

record x_struct_ex =
  x_example :: "32 word"
  y_example :: "8 word"

definition x_struct_ex_tag :: "'a x_struct_ex_scheme typ_info" where
  "x_struct_ex_tag \<equiv> (
    final_pad \<circ>
    (ti_typ_pad_combine TYPE(8 word) y_example (y_example_update \<circ> (\<lambda>x _. x)) ''y_example'') \<circ>
    (ti_typ_pad_combine TYPE(32 word) x_example (x_example_update \<circ> (\<lambda>x _. x))  ''x_example''))
    (empty_typ_info ''x_struct_ex'')"

instantiation x_struct_ex_ext :: (type) c_type
begin
instance ..
end

overloading x_struct_ex_typ_tag \<equiv> typ_info_t begin
definition
x_struct_ex_typ_tag: "x_struct_ex_typ_tag (t::'a x_struct_ex_ext itself) \<equiv>
    (x_struct_ex_tag::'a x_struct_ex_scheme typ_info)"
end

lemma aggregate_x_struct_ex_tag [simp]:
  "aggregate x_struct_ex_tag"
  by (simp add: x_struct_ex_tag_def final_pad_def Let_def)

lemma
  "upd_local (x_example_update \<circ> (\<lambda>x _. x))"
apply(auto simp: upd_local_def )
apply(tactic \<open>Record.split_tac @{context} 1\<close> )
apply simp
done

instantiation x_struct_ex_ext :: (unit_class) mem_type
begin
instance
apply intro_classes

apply(auto simp: x_struct_ex_typ_tag x_struct_ex_tag_def)

(* wf_desc *)
apply(fastforce intro: wf_desc_final_pad wf_desc_ti_typ_pad_combine)

(* wf_size_desc *)
apply(fastforce intro: wf_size_desc_ti_typ_pad_combine wf_size_desc_final_pad)

(* wf_lf *)
apply(fastforce intro: wf_lf_final_pad wf_lf_ti_typ_pad_combine
                      wf_desc_final_pad wf_desc_ti_typ_pad_combine
                      g_ind_ti_typ_pad_combine f_ind_ti_typ_pad_combine
                      fa_ind_ti_typ_pad_combine)

(* fu_eq_mask *)
apply(rule fu_eq_mask)
 apply(simp add: size_of_def  x_struct_ex_typ_tag x_struct_ex_tag_def)
apply(rule fu_eq_mask_final_pad)
apply(rule fu_eq_mask_ti_typ_pad_combine)+
apply(rule fu_eq_mask_empty_typ_info)
apply(simp add: there_is_only_one)
apply(fastforce simp: fg_cons_def intro: fc_ti_typ_pad_combine)+

(* align_of dvd size_of *)
apply(simp add: align_of_def size_of_def x_struct_ex_typ_tag
                x_struct_ex_tag_def)

(* align_field *)
apply(simp add: align_field_final_pad align_field_ti_typ_pad_combine)

(* max_size *)
apply(simp add: size_of_def x_struct_ex_typ_tag x_struct_ex_tag_def
                size_td_lt_final_pad size_td_lt_ti_typ_pad_combine
                size_td_lt_ti_typ_combine size_td_lt_ti_pad_combine padup_def
                addr_card align_of_final_pad align_of_def)
done
end

declare x_struct_ex_typ_tag [simp add]
declare x_struct_ex_tag_def [simp add]

lemma x_struct_ex_fnl [simp]:
  "field_names_list (x_struct_ex_tag::'a x_struct_ex_scheme typ_info) =
      [''x_example'',''y_example''] @
          padding_fields (x_struct_ex_tag::'a x_struct_ex_scheme typ_info)"
apply(clarsimp simp: field_names_list_def)
done

record y_struct_ex =
  x2_example :: "32 word ptr"
(*
  x3_example :: "32 word ptr"
  x4_example :: "32 word ptr"
  x5_example :: "32 word ptr"
  x6_example :: "32 word ptr"
  x7_example :: "32 word ptr"

  x12_example :: "32 word ptr"
  x13_example :: "32 word ptr"
  x14_example :: "32 word ptr"
  x15_example :: "32 word ptr"
  x16_example :: "32 word ptr"
  x17_example :: "32 word ptr"*)
  y2_example :: "x_struct_ex"

definition y_struct_ex_tag :: "'a y_struct_ex_scheme typ_info" where
  "y_struct_ex_tag \<equiv> (
    final_pad \<circ>
    (ti_typ_pad_combine TYPE(x_struct_ex) y2_example (y2_example_update \<circ> (\<lambda>x _. x)) ''y2_example'') \<circ>
    (ti_typ_pad_combine TYPE(32 word ptr) x2_example (x2_example_update \<circ> (\<lambda>x _. x))  ''x2_example'')
    )
    (empty_typ_info ''y_struct_ex'')"

instantiation y_struct_ex_ext :: (type) c_type
begin
instance ..
end

overloading y_struct_ex_typ_tag \<equiv> typ_info_t
begin
definition
y_struct_ex_typ_tag: "y_struct_ex_typ_tag (t::'a y_struct_ex_ext itself) \<equiv>
    (y_struct_ex_tag::'a y_struct_ex_scheme typ_info)"
end

instantiation y_struct_ex_ext :: (unit_class) mem_type
begin

instance
apply intro_classes

apply(auto simp: y_struct_ex_typ_tag y_struct_ex_tag_def align_of_def size_of_def)

(* wf_desc *)
apply(fastforce intro: wf_desc_final_pad wf_desc_ti_typ_pad_combine)

(* wf_size_desc *)
apply(fastforce intro: wf_size_desc_ti_typ_pad_combine wf_size_desc_final_pad)

(* wf_lf *)
apply(force intro: wf_lf_final_pad wf_lf_ti_typ_pad_combine
                      wf_desc_final_pad wf_desc_ti_typ_pad_combine
                      g_ind_ti_typ_pad_combine f_ind_ti_typ_pad_combine
                      fa_ind_ti_typ_pad_combine)

(* fu_eq_mask *)
apply(rule fu_eq_mask)
 apply(simp add: size_of_def  y_struct_ex_typ_tag y_struct_ex_tag_def)
apply(rule fu_eq_mask_final_pad)
apply(rule fu_eq_mask_ti_typ_pad_combine)+
apply(rule fu_eq_mask_empty_typ_info)
apply(simp add: there_is_only_one)
apply(fastforce simp: fg_cons_def intro: fc_ti_typ_pad_combine)+

(* align_field *)
apply(simp add: align_field_final_pad align_field_ti_typ_pad_combine)

(* max_size *)
apply(simp add: size_td_simps_1)
apply(simp add: size_td_simps_2 addr_card )
done

end

declare y_struct_ex_typ_tag [simp add]
declare y_struct_ex_tag_def [simp add]

lemma y_struct_ex_fnl [simp]:
  "field_names_list (y_struct_ex_tag::'a y_struct_ex_scheme typ_info) =
      [''x2_example'',''y2_example''] @
          padding_fields (y_struct_ex_tag::'a y_struct_ex_scheme typ_info)"
apply(clarsimp simp: field_names_list_def)
done

end