theory PETS imports
CryptHOL.CryptHOL
begin
(*NB: the message type must have a size function avaliavle,  can make it more general than bitstrings atm but
for now we leave it like this. Do not think making it more general will effect the proofs.*)

(*Atm we are assuming the batch queries are only (r_0,r_1) where r_0 and r_1 are both batches, not tuples of batches*)

sledgehammer_params[timeout = 1000]

type_synonym ('sender', 'receiver', 'aux') communication = "'sender' \<times> 'receiver' \<times> bool list \<times> 'aux'"

type_synonym ('sender', 'receiver', 'aux') batch = "('sender', 'receiver', 'aux') communication list"

type_synonym ('sender', 'receiver', 'aux') scenerio
                = "('sender', 'receiver', 'aux') batch list"

type_synonym ('sender', 'receiver', 'aux') simple_challenge
              = "('sender', 'receiver', 'aux') batch \<times> ('sender', 'receiver', 'aux') batch"

type_synonym ('sender', 'receiver', 'aux') challenge
              = "('sender', 'receiver', 'aux') scenerio \<times> ('sender', 'receiver', 'aux') scenerio"

type_synonym ('sender', 'receiver', 'aux', 'adversary_observations') protocol_model
                = "('sender', 'receiver', 'aux') batch \<Rightarrow> 'adversary_observations'"

locale simple_game =
  fixes protocol_model :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'adversary_observations spmf"
    and checks_batch :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  assumes lossless_prot_model: "\<forall> batch. lossless_spmf (protocol_model batch)"
begin

(*the adversary outputs a r0 and r1 which are both batches. The paper is a little ambiguous as to what is outputted here,
either two batches or two scenerios --- but it is somewhat cleared up by looking at 4/5 of the simple game where it says
that the challengeer hands the batch rb to the protocol*)

primrec simple_game ::
          "((('sender, 'receiver, 'aux) batch \<times> ('sender, 'receiver, 'aux) batch) \<times> 'state) spmf
              \<times> ('adversary_observations \<Rightarrow> 'state \<Rightarrow> bool spmf) \<Rightarrow> bool spmf"
  where "simple_game (\1, \2) = do {
    b \<leftarrow> coin_spmf;
    ((r0,r1), \<sigma>) \<leftarrow> \1;
    _ :: unit \<leftarrow> assert_spmf (checks_batch r0 r1 \<and> (length r0 = length r1));
    c \<leftarrow> protocol_model (if b then r1 else r0);
    b' \<leftarrow> \2 c \<sigma>;
    return_spmf (b = b')}"

definition "advantage \ = spmf (simple_game \) True - 1/2"

end

locale reductions = simple_game protocol_model
  for protocol_model :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'adversary_observations spmf" +
  assumes lossless_prot_model: "\<forall> batch. lossless_spmf (protocol_model batch)"
begin

definition sender_in_batch :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'sender \<Rightarrow> bool"
  where "sender_in_batch batch user \<equiv> \<exists> (u,u',m,aux) \<in> List.list.set batch. user = u"

definition msg_sender_batch :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'sender \<Rightarrow> bool list \<Rightarrow> bool"
  where "msg_sender_batch batch user msg \<equiv> \<exists> (u,u',m,aux) \<in> List.list.set batch. user = u \<and> msg = m"

lemma msg_sender_batch_imp_sender_in_batch:
  assumes "msg_sender_batch batch user msg"
    shows "sender_in_batch batch user"
  using msg_sender_batch_def sender_in_batch_def assms by fast

definition receiver_in_batch :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'receiver \<Rightarrow> bool"
  where "receiver_in_batch batch receiver \<equiv> \<exists> (u,u',m,aux) \<in> List.list.set batch. receiver = u'"

definition msg_receiver_batch :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'receiver \<Rightarrow> bool list \<Rightarrow> bool"
  where "msg_receiver_batch batch receiver msg \<equiv> \<exists> (u,u',m,aux) \<in> List.list.set batch. receiver = u'"

(*inductive_set receiver_msg_set :: "('sender, 'receiver, 'aux) batch \<Rightarrow> 'receiver \<Rightarrow> bool list set"
  for batch0 :: "('sender, 'receiver, 'aux) batch"
    and u' :: 'receiver
  where "m \<in> receiver_msg_set batch0 u'" if "m "*)

lemma msg_receiver_batch_imp_receiver_in_batch:
  assumes "msg_receiver_batch batch user msg"
    shows "receiver_in_batch batch user"
  using msg_receiver_batch_def receiver_in_batch_def assms by fast

subsection\<open>Simple properties\<close>

definition M_card :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "M_card r0 r1 \<equiv> (\<forall> (s0,r0,m0,aux0) \<in> List.list.set r0. \<forall> (s1,r1,m1,aux1) \<in> List.list.set r1. size m0 = size m1)"

definition ES :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "ES r0 r1 \<equiv> (\<forall> com0 \<in> List.list.set r0. \<forall> com1 \<in> List.list.set r1.
                                fst (snd com0) = fst (snd com1) \<and> fst (snd (snd com0)) = fst (snd (snd com1))
                                  \<and> snd (snd (snd com0)) = snd (snd (snd com1)))"

definition ER :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "ER r0 r1 = (\<forall> com0 \<in> List.list.set r0. \<forall> com1 \<in> List.list.set r1.
                                fst com0 = fst com1 \<and> fst (snd (snd com0)) = fst (snd (snd com1))
                                  \<and> snd (snd (snd com0)) = snd (snd (snd com1)))"

definition EM :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "EM r0 r1 = (\<forall> com0 \<in> List.list.set r0. \<forall> com1 \<in> List.list.set r1.
                                fst com0 = fst com1 \<and> fst (snd com0) = fst (snd com1)
                                  \<and> snd (snd (snd com0)) = snd (snd (snd com1)))"

definition ESM :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "ESM r0 r1 = (\<forall> (s0,r0,m0,aux0) \<in> List.list.set r0. \<forall> (s1,r1,m1,aux1) \<in> List.list.set r1. r0 = r1 \<and> aux0 = aux1)"

definition ERM :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "ERM r0 r1 = (\<forall> com0 \<in> List.list.set r0. \<forall> com1 \<in> List.list.set r1.
                           fst com0 = fst com1 \<and> snd (snd (snd com0)) = snd (snd (snd com1)))"

definition ESR :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "ESR r0 r1 \<equiv> (\<forall> com0 \<in> List.list.set r0. \<forall> com1 \<in> List.list.set r1.
                             fst (snd (snd com0)) = fst (snd (snd com1))
                                  \<and> snd (snd (snd com0)) = snd (snd (snd com1)))"

inductive_set user_msg_link :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender \<times> bool list) set"
  for batch :: "('sender, 'receiver, 'aux) batch"
  where "\<exists> u u' m a. (u,u',m,a) \<in> List.list.set batch \<Longrightarrow> (u,m) \<in> user_msg_link batch"

inductive_set receiver_msg_link :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('receiver \<times> bool list) set"
  for batch :: "('sender, 'receiver, 'aux) batch"
  where "\<exists> u u' m a. (u,u',m,a) \<in> List.list.set batch \<Longrightarrow> (u',m) \<in> receiver_msg_link batch"

inductive_set receiver_msg_link' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('receiver \<times> bool list) set"
  for batch :: "('sender, 'receiver, 'aux) batch"
  where " (u,u',m,a) \<in> List.list.set batch \<Longrightarrow> (u',m) \<in> receiver_msg_link' batch"

thm receiver_msg_link.simps receiver_msg_link'.simps

lemma assumes "(u,m) \<in> receiver_msg_link' batch"
  shows "(\<exists>u' m'. u = u' \<and> m = m' \<and> (\<exists>u u' m a. (u, u', m, a) \<in> set batch))"
  using assms by(auto simp add:receiver_msg_link'.simps receiver_msg_link.simps)

inductive_simps receiver_msg_link_simp [simp]:
  "(u',m) \<in> receiver_msg_link batch"

definition Lb :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender \<times> bool list set) set"
  where "Lb b batch0 batch1 = {(u,M)| u M. \<forall> m \<in> M. (u,m) \<in> user_msg_link (if b then batch1 else batch0)}"

definition Lb' :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('receiver \<times> bool list set) set"
  where "Lb' b batch0 batch1 = {(u,M)| u M. \<forall> m \<in> M. (u,m) \<in> receiver_msg_link (if b then batch1 else batch0)}"

(*inductive_set Lb :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender \<times> bool list set) set"
  for b :: bool
    and batch0 :: "('sender, 'receiver, 'aux) batch"
    and batch1 :: "('sender, 'receiver, 'aux) batch"
  where "(u,M) \<in> Lb b batch0 batch1" if "(\<forall> m \<in> M. user_msg_link (if b then batch1 else batch0))"*)

(*inductive_set Lb' :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('receiver \<times> bool list set) set"
  for b :: bool
    and batch0 :: "('sender, 'receiver, 'aux) batch"
    and batch1 :: "('sender, 'receiver, 'aux) batch"
  where "(u,M) \<in> Lb' b batch0 batch1" if "(\<forall> m \<in> M. msg_receiver_batch (if b then batch1 else batch0) u m)"*)

definition Ub :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> 'sender set"
  where "Ub b batch0 batch1 = {u| u M. (u, M) \<in> Lb b batch0 batch1}"

definition Ub' :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> 'receiver set"
  where "Ub' b batch0 batch1 = {u'| u' M. (u', M) \<in> Lb' b batch0 batch1}"

inductive_set Ub'' :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> 'receiver set"
  for b :: bool
    and batch0 :: "('sender, 'receiver, 'aux) batch"
    and batch1 :: "('sender, 'receiver, 'aux) batch"
  where "u \<in> Ub'' b batch0 batch1" if "\<exists> M. (u,M) \<in> Lb' b batch0 batch1"

lemma "Ub' b b0 b1 = Ub'' b b0 b1"
  by(simp add: Ub'_def Ub''.simps Ub''_def Ub''p.simps Lb'_def)

definition U :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "U batch0 batch1 \<equiv> Ub True batch0 batch1 = Ub False batch0 batch1"

definition U' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "U' batch0 batch1 \<equiv> Ub' True batch0 batch1 = Ub' False batch0 batch1"

definition Qb :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender \<times> nat) set"
  where "Qb b batch0 batch1 = {(u, n)| u M n. (u, M) \<in> Lb b batch0 batch1 \<and> card M = n}"

definition Qb' :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('receiver \<times> nat) set"
  where "Qb' b batch0 batch1 = {(u', n)| u' M n. (u', M) \<in> Lb' b batch0 batch1 \<and> card M = n}"

inductive_set Qb'' :: "bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('receiver \<times> nat) set"
  for b :: bool
    and batch0 :: "('sender, 'receiver, 'aux) batch"
    and batch1 :: "('sender, 'receiver, 'aux) batch"
  where "(u,n) \<in> Qb'' b batch0 batch1" if "\<exists> M. (u,M) \<in> Lb' b batch0 batch1 \<and> card M = n"

definition Q' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "Q' batch0 batch1 \<equiv> Qb' True batch0 batch1 = Qb' False batch0 batch1"

definition Q'' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "Q'' batch0 batch1 \<equiv> Qb'' True batch0 batch1 = Qb'' False batch0 batch1"

definition Q :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "Q batch0 batch1 \<equiv> Qb True batch0 batch1 = Qb False batch0 batch1"

definition card_U :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "card_U batch0 batch1 \<equiv> card (Ub True batch0 batch1) = card (Ub False batch0 batch1)"

definition card_U' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "card_U' batch0 batch1 \<equiv> card (Ub' True batch0 batch1) = card (Ub' False batch0 batch1)"

text\<open>Message partitions and historgrams.\<close>

definition MbI :: "nat \<Rightarrow> bool \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool list set"
  where "MbI k b  batch0 batch1 \<equiv> \<Union>{M| u M. (u, M) \<in> Lb b batch0 batch1}"

subsection\<open>Check batches\<close>

text\<open>We consider these in the same order as PETs paper.\<close>

definition checks_batch_MO :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_MO r0 r1 = EM r0 r1"

definition checks_batch_MO_cardM :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_MO_cardM r0 r1 \<equiv> EM r0 r1 \<and> M_card r0 r1"

definition checks_batch_MOML :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_MOML r0 r1 \<equiv> Q r0 r1 \<and> Q' r0 r1"

definition checks_batch_O where "checks_batch_O r0 r1 = True"

definition checks_batch_SO :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO r0 r1 = ES r0 r1"

definition checks_batch_SO_cardU :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO_cardU r0 r1 = (ES r0 r1 \<and> card_U r0 r1)"

definition checks_batch_SFL :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SFL r0 r1 = (ES r0 r1 \<and> U r0 r1)"

definition checks_batch_SML :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SML r0 r1 = (ES r0 r1 \<and> Q r0 r1)"

definition checks_batch_RO :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RO r0 r1 = ER r0 r1"

definition checks_batch_RO_cardU' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RO_cardU' r0 r1 = (ER r0 r1 \<and> card_U' r0 r1)"

definition checks_batch_RFL :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RFL r0 r1 = (ER r0 r1 \<and> U' r0 r1)"

definition checks_batch_RML :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RML r0 r1 = (ER r0 r1 \<and> Q' r0 r1)"

definition checks_batch_SOMO :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SOMO r0 r1 \<equiv> ESM r0 r1"

definition checks_batch_ROMO :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_ROMO r0 r1 \<equiv> (ERM r0 r1)"

definition checks_batch_SOMO_M :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SOMO_M r0 r1 \<equiv> (ESM r0 r1 \<and> M_card r0 r1)"

definition checks_batch_ROMO_M :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_ROMO_M r0 r1 \<equiv> (ERM r0 r1 \<and> M_card r0 r1)"

(*section 3 from table 2 in PETs paper*)

definition checks_batch_SO_brRObr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO_brRObr r0 r1 = True"

definition checks_batch_SO_brRO_U_card'br :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO_brRO_U_card'br r0 r1 = (card_U' r0 r1)"

definition checks_batch_SO_brRFLbr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO_brRFLbr r0 r1 = (U' r0 r1)"

definition checks_batch_SO_brRMLbr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO_brRMLbr r0 r1 = (Q' r0 r1)"

definition checks_batch_SO_brRMLbr' :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_SO_brRMLbr' r0 r1 = (Q'' r0 r1)"

definition checks_batch_RO_brSObr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RO_brSObr r0 r1 = True"

definition checks_batch_RO_brSO_U_cardbr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RO_brSO_U_cardbr r0 r1 = (card_U r0 r1)"

definition checks_batch_RO_brSFLbr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RO_brSFLbr r0 r1 = (U r0 r1)"

definition checks_batch_RO_brSMLbr :: "('sender, 'receiver, 'aux) batch \<Rightarrow> ('sender, 'receiver, 'aux) batch \<Rightarrow> bool"
  where "checks_batch_RO_brSMLbr r0 r1 = (Q r0 r1)"

lemma Q_imp_U:
  assumes "Q batch0 batch1"
  shows "U batch0 batch1"
  using assms unfolding Q_def Qb_def U_def Ub_def by blast

text\<open>Construct the sublocales for the hierarchy\<close>

text\<open>Section 1 from table 2 in PETs paper\<close>

sublocale MO: simple_game protocol_model checks_batch_MO
  by(simp add: simple_game_axioms)

sublocale MO_cardM: simple_game protocol_model checks_batch_MO_cardM
  by(simp add: simple_game_axioms)

sublocale MOML: simple_game protocol_model checks_batch_MOML
  by(simp add: simple_game_axioms)

sublocale O: simple_game protocol_model checks_batch_O
  by(simp add: simple_game_axioms)

text\<open>Section 2 from table 2 in PETs paper\<close>

sublocale SO: simple_game protocol_model checks_batch_SO
  by(simp add: simple_game_axioms)

sublocale SO_cardU: simple_game protocol_model checks_batch_SO_cardU
  by(simp add: simple_game_axioms)

sublocale SFL: simple_game protocol_model checks_batch_SFL
  by(simp add: simple_game_axioms)

sublocale SML: simple_game protocol_model checks_batch_SML
  by(simp add: simple_game_axioms)

sublocale RO: simple_game protocol_model checks_batch_RO
  by(simp add: simple_game_axioms)

sublocale RO_cardU': simple_game protocol_model checks_batch_RO_cardU'
  by(simp add: simple_game_axioms)

sublocale RFL: simple_game protocol_model checks_batch_RFL
  by(simp add: simple_game_axioms)

sublocale RML: simple_game protocol_model checks_batch_RML
  by(simp add: simple_game_axioms)

text\<open>Section 3 from table 2 in PETs paper\<close>

sublocale SOMO: simple_game protocol_model checks_batch_SOMO
  by(simp add: simple_game_axioms)

sublocale SOMO_M: simple_game protocol_model checks_batch_SOMO_M
  by(simp add: simple_game_axioms)

sublocale ROMO: simple_game protocol_model checks_batch_ROMO
  by(simp add: simple_game_axioms)

sublocale ROMO_M: simple_game protocol_model checks_batch_ROMO_M
  by(simp add: simple_game_axioms)

text\<open>Section 4 from table 2 in PETs paper\<close>

sublocale SO_brRObr: simple_game protocol_model checks_batch_SO_brRObr
  by(simp add: simple_game_axioms)

sublocale SO_brRO_U_card'br: simple_game protocol_model checks_batch_SO_brRO_U_card'br
  by(simp add: simple_game_axioms)

sublocale SO_brRFLbr: simple_game protocol_model checks_batch_SO_brRFLbr
  by(simp add: simple_game_axioms)

sublocale SO_brRMLbr: simple_game protocol_model checks_batch_SO_brRMLbr
  by(simp add: simple_game_axioms)

sublocale RO_brSObr: simple_game protocol_model checks_batch_RO_brSObr
  by(simp add: simple_game_axioms)

sublocale RO_brSO_U_cardbr: simple_game protocol_model checks_batch_RO_brSO_U_cardbr
  by(simp add: simple_game_axioms)

sublocale RO_brSMLbr: simple_game protocol_model checks_batch_RO_brSMLbr
  by(simp add: simple_game_axioms)

sublocale RO_brSFLbr: simple_game protocol_model checks_batch_RO_brSFLbr
  by(simp add: simple_game_axioms)

text\<open>We now prove the hierarchy.\<close>

lemma O_imp_SO_brRO_U_card'br: shows "O.advantage \ \<ge> SO_brRO_U_card'br.advantage \"
proof-
  have "spmf (O.simple_game \) True \<ge> spmf (SO_brRO_U_card'br.simple_game \) True"
    apply(simp add: O.simple_game_def SO_brRO_U_card'br.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_O_def checks_batch_SO_brRO_U_card'br_def)
  thus ?thesis by (simp add: O.advantage_def SO_brRO_U_card'br.advantage_def)
qed

lemma O_imp_RO_brSO_U_cardbr: shows "O.advantage \ \<ge> RO_brSO_U_cardbr.advantage \"
proof-
  have "spmf (O.simple_game \) True \<ge> spmf (RO_brSO_U_cardbr.simple_game \) True"
    apply(simp add: O.simple_game_def RO_brSO_U_cardbr.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_O_def checks_batch_SO_brRO_U_card'br_def)
  thus ?thesis by (simp add: O.advantage_def RO_brSO_U_cardbr.advantage_def)
qed

lemma SO_brRO_Ucard'br_imp_SO_brRFLbr: shows "SO_brRO_U_card'br.advantage \ \<ge> SO_brRFLbr.advantage \"
proof-
  have "spmf (SO_brRO_U_card'br.simple_game \) True \<ge> spmf (SO_brRFLbr.simple_game \) True"
    apply(simp add: SO_brRFLbr.simple_game_def SO_brRO_U_card'br.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SO_brRFLbr_def checks_batch_SO_brRO_U_card'br_def U'_def card_U'_def)
  thus ?thesis by (simp add: SO_brRFLbr.advantage_def SO_brRO_U_card'br.advantage_def)
qed

lemma RO_brSO_Ucardbr_imp_RO_brSFLbr: shows "RO_brSO_U_cardbr.advantage \ \<ge> RO_brSFLbr.advantage \"
proof-
  have "spmf (RO_brSO_U_cardbr.simple_game \) True \<ge> spmf (RO_brSFLbr.simple_game \) True"
    apply(simp add: RO_brSO_U_cardbr.simple_game_def RO_brSFLbr.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_RO_brSFLbr_def checks_batch_RO_brSO_U_cardbr_def U_def card_U_def)
  thus ?thesis by (simp add: RO_brSFLbr.advantage_def RO_brSO_U_cardbr.advantage_def)
qed

lemma SO_brRFLbr_imp_SO_brRMLbr: shows "SO_brRFLbr.advantage \ \<ge> SO_brRMLbr.advantage \"
proof-
  have "spmf (SO_brRFLbr.simple_game \) True \<ge> spmf (SO_brRMLbr.simple_game \) True"
    apply(simp add: SO_brRFLbr.simple_game_def SO_brRMLbr.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SO_brRFLbr_def checks_batch_SO_brRMLbr_def Q'_def U'_def Qb'_def Ub'_def Lb'_def)
  thus ?thesis by (simp add: SO_brRFLbr.advantage_def SO_brRMLbr.advantage_def)
qed

lemma RO_brSFLbr_imp_RO_brSMLbr: shows "RO_brSFLbr.advantage \ \<ge> RO_brSMLbr.advantage \"
proof-
  have "spmf (RO_brSFLbr.simple_game \) True \<ge> spmf (RO_brSMLbr.simple_game \) True"
    apply(simp add: RO_brSFLbr.simple_game_def RO_brSMLbr.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_RO_brSFLbr_def checks_batch_RO_brSMLbr_def Q'_def U_def Qb_def Lb_def Ub_def)
  thus ?thesis by (simp add: RO_brSFLbr.advantage_def RO_brSMLbr.advantage_def)
qed

lemma SO_brRMLbr_imp_MOML: shows "MOML.advantage \ \<le> SO_brRMLbr.advantage \"
proof-
  have "spmf (MOML.simple_game \) True \<le> spmf (SO_brRMLbr.simple_game \) True"
    apply(simp add: SO_brRMLbr.simple_game_def MOML.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_MOML_def checks_batch_SO_brRMLbr_def ESM_def ES_def M_card_def)
  thus ?thesis by (simp add: SO_brRMLbr.advantage_def MOML.advantage_def)
qed

lemma RO_brSMLbr_imp_MOML: shows "MOML.advantage \ \<le> RO_brSMLbr.advantage \"
proof-
  have "spmf (MOML.simple_game \) True \<le> spmf (RO_brSMLbr.simple_game \) True"
    apply(simp add: RO_brSMLbr.simple_game_def MOML.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_MOML_def checks_batch_RO_brSMLbr_def ESM_def ES_def M_card_def)
  thus ?thesis by (simp add: RO_brSMLbr.advantage_def MOML.advantage_def)
qed

lemma SOMO_imp_MO: shows "MO.advantage \ \<le> SOMO.advantage \"
proof-
  have "spmf (MO.simple_game \) True \<le> spmf (SOMO.simple_game \) True"
    apply(simp add: SOMO.simple_game_def MO.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SOMO_def checks_batch_MO_def ESM_def ES_def EM_def)
  thus ?thesis by (simp add: MO.advantage_def SOMO.advantage_def)
qed

lemma ROMO_imp_MO: shows "MO.advantage \ \<le> ROMO.advantage \"
proof-
  have "spmf (MO.simple_game \) True \<le> spmf (ROMO.simple_game \) True"
    apply(simp add: ROMO.simple_game_def MO.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_ROMO_def checks_batch_MO_def ERM_def ES_def EM_def)
  thus ?thesis by (simp add: MO.advantage_def ROMO.advantage_def)
qed

lemma SOMO_imp_SOMO_M: shows "SOMO.advantage \ \<ge> SOMO_M.advantage \"
proof-
  have "spmf (SOMO_M.simple_game \) True \<le> spmf (SOMO.simple_game \) True"
    apply(simp add: SOMO.simple_game_def SOMO_M.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SOMO_def checks_batch_SOMO_M_def)
  thus ?thesis by (simp add: SOMO.advantage_def SOMO_M.advantage_def)
qed

lemma ROMO_imp_ROMO_M: shows "ROMO.advantage \ \<ge> ROMO_M.advantage \"
proof-
  have "spmf (ROMO_M.simple_game \) True \<le> spmf (ROMO.simple_game \) True"
    apply(simp add: ROMO.simple_game_def ROMO_M.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_ROMO_def checks_batch_ROMO_M_def)
  thus ?thesis by (simp add: ROMO.advantage_def ROMO_M.advantage_def)
qed

lemma SOMO_imp_MO_M: shows "SOMO.advantage \ \<ge> MO_cardM.advantage \"
proof-
  have "spmf (MO_cardM.simple_game \) True \<le> spmf (SOMO.simple_game \) True"
    apply(simp add: SOMO.simple_game_def MO_cardM.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SOMO_def checks_batch_MO_cardM_def EM_def M_card_def ESM_def)
  thus ?thesis by (simp add: SOMO.advantage_def MO_cardM.advantage_def)
qed

lemma ROMO_imp_MO_M: shows "ROMO.advantage \ \<ge> MO_cardM.advantage \"
proof-
  have "spmf (MO_cardM.simple_game \) True \<le> spmf (ROMO.simple_game \) True"
    apply(simp add: ROMO.simple_game_def MO_cardM.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_ROMO_def checks_batch_MO_cardM_def EM_def M_card_def ERM_def)
  thus ?thesis by (simp add: ROMO.advantage_def MO_cardM.advantage_def)
qed

lemma MO_imp_MO_cardM: shows "MO_cardM.advantage \ \<le> MO.advantage \"
proof-
  have "spmf (MO_cardM.simple_game \) True \<le> spmf (MO.simple_game \) True"
    apply(simp add: MO_cardM.simple_game_def MO.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_MO_cardM_def checks_batch_MO_def EM_def M_card_def)
  thus ?thesis by (simp add: MO.advantage_def MO_cardM.advantage_def)
qed

lemma SOMO_M_imp_SO: shows "SO.advantage \ \<le> SOMO_M.advantage \"
proof-
  have "spmf (SOMO_M.simple_game \) True \<ge> spmf (SO.simple_game \) True"
    apply(simp add: SO.simple_game_def SOMO_M.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SO_def checks_batch_SOMO_M_def ESM_def ES_def M_card_def)
  thus ?thesis by (simp add: SO.advantage_def SOMO_M.advantage_def)
qed

lemma ROMO_M_imp_RO: shows "RO.advantage \ \<le> ROMO_M.advantage \"
proof-
  have "spmf (ROMO_M.simple_game \) True \<ge> spmf (RO.simple_game \) True"
    apply(simp add: RO.simple_game_def ROMO_M.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_RO_def checks_batch_ROMO_M_def ERM_def ER_def M_card_def)
  thus ?thesis by (simp add: RO.advantage_def ROMO_M.advantage_def)
qed

lemma SO_imp_SO_cardU: shows "SO_cardU.advantage \ \<le> SO.advantage \"
proof-
  have "spmf (SO_cardU.simple_game \) True \<le> spmf (SO.simple_game \) True"
    apply(simp add: SO.simple_game_def SO_cardU.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SO_def checks_batch_SO_cardU_def ERM_def ER_def M_card_def)
  thus ?thesis by (simp add: SO.advantage_def SO_cardU.advantage_def)
qed

lemma RO_imp_RO_cardU': shows "RO_cardU'.advantage \ \<le> RO.advantage \"
proof-
  have "spmf (RO_cardU'.simple_game \) True \<le> spmf (RO.simple_game \) True"
    apply(simp add: RO.simple_game_def RO_cardU'.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_RO_def checks_batch_RO_cardU'_def ERM_def ER_def M_card_def)
  thus ?thesis by (simp add: RO.advantage_def RO_cardU'.advantage_def)
qed

lemma SO_cardU_imp_SFL: shows "SFL.advantage \ \<le> SO_cardU.advantage \"
proof-
  have "spmf (SFL.simple_game \) True \<le> spmf (SO_cardU.simple_game \) True"
    apply(simp add: SFL.simple_game_def SO_cardU.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_SFL_def checks_batch_SO_cardU_def U_def card_U_def)
  thus ?thesis by (simp add: SFL.advantage_def SO_cardU.advantage_def)
qed

lemma RO_cardU_imp_RFL: shows "RFL.advantage \ \<le> RO_cardU'.advantage \"
proof-
  have "spmf (RFL.simple_game \) True \<le> spmf (RO_cardU'.simple_game \) True"
    apply(simp add: RFL.simple_game_def RO_cardU'.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_RFL_def checks_batch_RO_cardU'_def U'_def card_U'_def)
  thus ?thesis by (simp add: RFL.advantage_def RO_cardU'.advantage_def)
qed

lemma EM_imp_ESM:
  assumes "EM b0 b1"
  shows "ESM b0  b1"
  using assms by(simp add: ESM_def EM_def split_def)

lemma EM_imp_ERM:
  assumes "EM b0 b1"
  shows "ERM b0  b1"
  using assms by(simp add: ERM_def EM_def split_def)

lemma ESM_imp_Q':
  assumes "ESM batch0 batch1"
    and "length batch0 = length batch1"
  shows "Q' batch0 batch1"
  using assms
  apply(auto simp add: ESM_def Q'_def Qb'_def Lb'_def msg_receiver_batch_def receiver_msg_link.simps split_def)
   by (metis assms(2) length_pos_if_in_set nth_mem prod_cases4)+

lemma EM_imp_Q':
  assumes "EM batch0 batch1"
    and "length batch0 = length batch1"
  shows "Q' batch0 batch1"
  using EM_imp_ESM ESM_imp_Q' assms by blast

lemma ERM_imp_Q:
  assumes "ERM batch0 batch1"
    and "length batch0 = length batch1"
  shows "Q batch0 batch1"
  using assms
  apply(auto simp add: ESM_def Q_def Qb_def Lb_def user_msg_link.simps receiver_msg_link.simps split_def)
   by (metis assms(2) length_pos_if_in_set nth_mem prod_cases4)+

lemma EM_imp_Q:
  assumes "EM batch0 batch1"
    and "length batch0 = length batch1"
  shows "Q batch0 batch1"
  using EM_imp_ERM ERM_imp_Q assms by blast

lemma MOML_imp_MO: shows "MO.advantage \ \<le> MOML.advantage \"
proof-
  have "spmf (MO.simple_game \) True \<le> spmf (MOML.simple_game \) True"
    apply(simp add: MO.simple_game_def MOML.simple_game_def split_def)
    apply(rule ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def checks_batch_MOML_def checks_batch_MO_def EM_imp_Q' EM_imp_Q)
  thus ?thesis by(simp add: MO.advantage_def MOML.advantage_def)
qed

lemma SO_brRMLbr_imp_SOMO: shows "SOMO.advantage \ \<le> SO_brRMLbr.advantage \"
proof-
  have "spmf (SOMO.simple_game \) True \<le> spmf (SO_brRMLbr.simple_game \) True"
    apply(simp add: SOMO.simple_game_def SO_brRMLbr.simple_game_def split_def)
    apply(rule  ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def ESM_imp_Q' checks_batch_SOMO_def checks_batch_SO_brRMLbr_def)
  thus ?thesis
    by(simp add: SOMO.advantage_def SO_brRMLbr.advantage_def )
qed

lemma RO_brSMLbr_imp_ROMO: shows "ROMO.advantage \ \<le> RO_brSMLbr.advantage \"
proof-
  have "spmf (ROMO.simple_game \) True \<le> spmf (RO_brSMLbr.simple_game \) True"
    apply(simp add: ROMO.simple_game_def RO_brSMLbr.simple_game_def split_def)
    apply(rule  ord_spmf_eq_leD)
    apply(rule ord_spmf_bind_reflI;clarsimp)+
    by(auto simp add: assert_spmf_def ERM_imp_Q checks_batch_ROMO_def checks_batch_RO_brSMLbr_def)
  thus ?thesis
    by(simp add: ROMO.advantage_def RO_brSMLbr.advantage_def)
qed


(*
 * Copyright 2023, Proofcraft Pty Ltd
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(* Architecture-specific lemmas constraining Kernel_Config definitions *)

theory Arch_Kernel_Config_Lemmas
imports
  Kernel_Config_Lemmas
  Platform
begin

context Arch begin global_naming RISCV64

lemma pptrBase_kernelELFBase:
  "pptrBase < kernelELFBase"
  by (simp add: pptrBase_def canonical_bit_def kernelELFBase_def kernelELFPAddrBase_def pptrTop_def
                Kernel_Config.physBase_def mask_def)

(* 12 in this lemma and below is pageBits, which is not yet defined in this theory.
   Definition will be folded and the lemmas shadowed in AInvs. *)
lemma is_page_aligned_physBase:
  "is_aligned physBase 12"
  by (simp add: Kernel_Config.physBase_def is_aligned_def)

(* 22 is kernel_window_bits, defined in Init_A. To be folded in AInvs. *)
lemma kernel_window_sufficient:
  "pptrBase + (1 << 22) \<le> kernelELFBase"
  unfolding pptrBase_def canonical_bit_def kernelELFBase_def kernelELFPAddrBase_def pptrTop_def
  by (simp add: mask_def Kernel_Config.physBase_def)

lemma kernel_elf_window_at_least_page:
  "kernelELFBase + 2 ^ 12 \<le> kdevBase"
  unfolding kernelELFBase_def kernelELFPAddrBase_def kdevBase_def pptrTop_def
  by (simp add: mask_def Kernel_Config.physBase_def)

(* This doesn't follow from alignment, because we need <, not \<le> *)
lemma kernelELFBase_no_overflow:
  "kernelELFBase < kernelELFBase + 2 ^ 12"
  unfolding kernelELFBase_def kernelELFPAddrBase_def pptrTop_def
  by (simp add: mask_def Kernel_Config.physBase_def)

end
end


(*
 * Copyright 2015, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory ProvePart
imports Main
begin

text {* Introduces a (sort-of) tactic for proving part of a goal by automatic
methods. The split between the proven and unproven part goes down into conjunction,
implication etc. The unproven parts are left in (roughly) their original form. *}

text {*
The first part is to take a goal and split it into two conjuncts,
e.g. "a \<and> (\<forall>x. b \<and> c x)
    = (((P1 \<longrightarrow> a) \<and> (\<forall>x. (P2 \<longrightarrow> b) \<and> (P3 \<longrightarrow> c x)))
        \<and> ((\<not> P1 \<longrightarrow> a) \<and> (\<forall>x. (\<not> P2 \<longrightarrow> b) \<and> (\<not> P3 \<longrightarrow> c x)))"

The first conjunct is then attacked by some automatic method.

The final part is to eliminate any goals remaining after that
automatic method by setting the Pi to False. The remaining Pi
(whose goal fragments were solved) are set to True. If the
resulting goals cannot be solved by setting to False, or if
no Pi are actually set to true, the process fails.
*}

lemma logic_to_conj_thm_workers:
  "A = (A' \<and> A'') \<Longrightarrow> B = (B' \<and> B'')
    \<Longrightarrow> (A \<and> B) = ((A' \<and> B') \<and> (A'' \<and> B''))"
  "B = (B' \<and> B'')
    \<Longrightarrow> (A \<or> B) = ((A \<or> B') \<and> (A \<or> B''))"
  "\<lbrakk> \<And>x. P x = (P' x \<and> P'' x) \<rbrakk>
    \<Longrightarrow> (\<forall>x. P x) = ((\<forall>x. P' x) \<and> (\<forall>x. P'' x))"
  "\<lbrakk> \<And>x. P x = (P' x \<and> P'' x) \<rbrakk>
    \<Longrightarrow> (\<forall>x \<in> S. P x) = ((\<forall>x \<in> S. P' x) \<and> (\<forall>x \<in> S. P'' x))"
  "B = (B' \<and> B'')
    \<Longrightarrow> (A \<longrightarrow> B) = ((A \<longrightarrow> B') \<and> (A \<longrightarrow> B''))"
  by auto

ML {*
structure Split_To_Conj = struct

fun abs_name (Abs (s, _, _)) = s
  | abs_name _ = "x"

fun all_type (Const (@{const_name "All"}, T) $ _)
    = domain_type (domain_type T)
  | all_type (Const (@{const_name "Ball"}, T) $ _ $ _)
    = domain_type (domain_type (range_type T))
  | all_type t = raise TERM ("all_type", [t])

fun split_thm prefix ctxt t = let
    val ok = not (String.isPrefix "Q" prefix orelse String.isPrefix "R" prefix)
    val _ = ok orelse error ("split_thm: prefix has prefix Q/R: " ^ prefix)
    fun params (@{term "op \<and>"} $ x $ y) Ts = params x Ts @ params y Ts
      | params (@{term "op \<or>"} $ _ $ y) Ts = (Ts, SOME @{typ bool}) :: params y Ts
      | params (all as (Const (@{const_name "All"}, _) $ t)) Ts
        = params (betapply (t, Bound 0)) (all_type all :: Ts)
      | params (ball as (Const (@{const_name "Ball"}, T) $ _ $ t)) Ts
        = (Ts, SOME (domain_type T)) :: params (betapply (t, Bound 0)) (all_type ball :: Ts)
      | params (@{term "op \<longrightarrow>"} $ _ $ t) Ts = (Ts, SOME @{typ bool}) :: params t Ts
      | params _ Ts = [(Ts, NONE)]
    val ps = params t []
    val Ps = Variable.variant_frees ctxt [t]
        (replicate (length ps) (prefix, @{typ bool}))
        |> map Free
    val Qs = Variable.variant_frees ctxt [t]
        (map (fn (ps, T) => case T of NONE => ("Q", ps ---> @{typ bool})
                | SOME T => ("R", ps ---> T)) ps)
        |> map Free
    val Qs = map (fn (Q, (ps, _)) => Term.list_comb (Q, map Bound (0 upto (length ps - 1))))
        (Qs ~~ ps)
    fun assemble_bits (@{term "op \<and>"} $ x $ y) Ps = let
        val (x, Ps) = assemble_bits x Ps
        val (y, Ps) = assemble_bits y Ps
      in (@{term "op \<and>"} $ x $ y, Ps) end
      | assemble_bits (@{term "op \<or>"} $ _ $ y) Ps = let
        val x = hd Ps
        val (y, Ps) = assemble_bits y (tl Ps)
      in (@{term "op \<or>"} $ x $ y, Ps) end
      | assemble_bits (all as (Const (@{const_name "All"}, T) $ t)) Ps = let
        val nm = abs_name t
        val (t, Ps) = assemble_bits (betapply (t, Bound 0)) Ps
      in (Const (@{const_name "All"}, T) $ Abs (nm, all_type all, t), Ps) end
      | assemble_bits (ball as (Const (@{const_name "Ball"}, T) $ _ $ t)) Ps = let
        val nm = abs_name t
        val S = hd Ps
        val (t, Ps) = assemble_bits (betapply (t, Bound 0)) (tl Ps)
      in (Const (@{const_name "Ball"}, T) $ S $ Abs (nm, all_type ball, t), Ps) end
      | assemble_bits (@{term "op \<longrightarrow>"} $ _ $ y) Ps = let
        val x = hd Ps
        val (y, Ps) = assemble_bits y (tl Ps)
      in (@{term "op \<longrightarrow>"} $ x $ y, Ps) end
      | assemble_bits _ Ps = (hd Ps, tl Ps)
    val bits_lhs = assemble_bits t Qs |> fst
    fun imp tf (P, Q) = if String.isPrefix "R" (fst (dest_Free (head_of Q))) then Q
        else HOLogic.mk_imp (if tf then P else HOLogic.mk_not P, Q)
    val bits_true = assemble_bits t (map (imp true) (Ps ~~ Qs)) |> fst
    val bits_false = assemble_bits t (map (imp false) (Ps ~~ Qs)) |> fst
    val concl = HOLogic.mk_eq (bits_lhs, HOLogic.mk_conj (bits_true, bits_false))
      |> HOLogic.mk_Trueprop
  in (Goal.prove ctxt (map (fst o dest_Free o head_of) Qs) [] concl
    (K (REPEAT_ALL_NEW (resolve_tac ctxt
        @{thms logic_to_conj_thm_workers cases_simp[symmetric]}) 1)),
        map dest_Free Ps)
  end

fun get_split_tac prefix ctxt tac = SUBGOAL (fn (t, i) =>
  let
    val concl = HOLogic.dest_Trueprop (Logic.strip_assums_concl t)
    val (thm, Ps) = split_thm prefix ctxt concl
  in (resolve0_tac [ @{thm iffD2} ] THEN' resolve0_tac [thm] THEN' tac Ps) end i)

end
*}

text {* Testing. *}

ML {*
Split_To_Conj.split_thm "P" @{context}
  @{term "x & y & (\<forall>t \<in> UNIV. \<forall>n. True \<longrightarrow> z t n)"}
*}

ML {*
structure Partial_Prove = struct

fun inst_frees_tac _ Ps ct = REPEAT_DETERM o SUBGOAL (fn (t, _) =>
  fn thm => case Term.add_frees t [] |> filter (member (op =) Ps)
  of [] => Seq.empty
  | (f :: _) => let
    val idx = Thm.maxidx_of thm + 1
    val var = ((fst f, idx), snd f)
  in thm |> Thm.generalize ([], [fst f]) idx
    |> Thm.instantiate ([], [(var, ct)])
    |> Seq.single
  end)

fun cleanup_tac ctxt Ps
    = inst_frees_tac ctxt Ps @{cterm False}
      THEN' asm_full_simp_tac ctxt

fun finish_tac ctxt Ps = inst_frees_tac ctxt Ps @{cterm True}
    THEN' CONVERSION (Conv.params_conv ~1 (fn ctxt =>
            (Conv.concl_conv ~1 (Simplifier.rewrite (put_simpset HOL_ss ctxt)))
        ) ctxt)

fun test_start_partial_prove ctxt i t = let
    val j = Thm.nprems_of t - i
  in Split_To_Conj.get_split_tac ("P_" ^ string_of_int j ^ "_") ctxt
        (K (K all_tac)) i t
  end

fun test_end_partial_prove ctxt t = let
    fun match_P (s, T) = case space_explode "_" s of
        ["P", n, _] => try (fn () => ((s, T), the (Int.fromString n))) ()
      | _ => NONE
    val Ps = Term.add_frees (Thm.concl_of t) [] |> map_filter match_P
    fun getmax ((x, n) :: xs) max maxes = if n > max then getmax xs n [x]
      else getmax xs max maxes
      | getmax [] max maxes = (max, maxes)
    val (j, Ps) = getmax Ps 0 []
    val i = Thm.nprems_of t - j
  in REPEAT_DETERM (FIRSTGOAL (fn k => if k < i then cleanup_tac ctxt Ps k else no_tac))
    THEN finish_tac ctxt Ps i end t

fun partial_prove tactic ctxt i
    = Split_To_Conj.get_split_tac ("P_" ^ string_of_int i ^ "_") ctxt
      (fn Ps => fn i => tactic i THEN finish_tac ctxt Ps i) i

fun method (ctxtg, []) = (fn ctxt => Method.SIMPLE_METHOD (test_start_partial_prove ctxt 1),
    (ctxtg, []))
  | method args = error "Partial_Prove: still working on that"

fun fin_method () = Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (test_end_partial_prove ctxt))

end
*}

method_setup partial_prove = {* Partial_Prove.method *}
  "partially prove a compound goal by some automatic method"

method_setup finish_partial_prove = {* Partial_Prove.fin_method () *}
  "partially prove a compound goal by some automatic method"

end


subsection {* Variable blocks *}

theory utp_local
imports utp_theory
begin

text {* Local variables are represented as lenses whose view type is a list of values. A variable
  therefore effectively records the stack of values that variable has had, if any. This allows
  us to denote variable scopes using assignments that push and pop this stack to add or delete
  a particular local variable. *}

type_synonym ('a, '\<alpha>) lvar = "('a list \<Longrightarrow> '\<alpha>)"

text {* Different UTP theories have different assignment operators; consequently in order to
  generically characterise variable blocks we need to abstractly characterise assignments.
  We first create two polymorphic constants that characterise the underlying program state model
  of a UTP theory. *}

consts
  pvar         :: "('\<T>, '\<alpha>) uthy \<Rightarrow> '\<beta> \<Longrightarrow> '\<alpha>" ("\<^bold>v\<index>")
  pvar_assigns :: "('\<T>, '\<alpha>) uthy \<Rightarrow> '\<beta> usubst \<Rightarrow> '\<alpha> hrel" ("\<^bold>\<langle>_\<^bold>\<rangle>\<index>")

text {* @{const pvar} is a lens from the program state, @{typ "'\<beta>"}, to the overall global state
  @{typ "'\<alpha>"}, which also contains none user-space information, such as observational variables.
  @{const pvar_assigns} takes as parameter a UTP theory and returns an assignment operator
  which maps a substitution over the program state to a homogeneous relation on the global
  state. We now set up some syntax translations for these operators. *}

syntax
  "_svid_pvar" :: "('\<T>, '\<alpha>) uthy \<Rightarrow> svid" ("\<^bold>v\<index>")
  "_thy_asgn"  :: "('\<T>, '\<alpha>) uthy \<Rightarrow> svids \<Rightarrow> uexprs \<Rightarrow> logic"  (infixr "::=\<index>" 72)

translations
  "_svid_pvar T" => "CONST pvar T"
  "_thy_asgn T xs vs" => "CONST pvar_assigns T (_mk_usubst (CONST id) xs vs)"

text {* Next, we define constants to represent the top most variable on the local variable stack,
  and the remainder after this. We define these in terms of the list lens, and so for each
  another lens is produced. *}

definition top_var :: "('a::two, '\<alpha>) lvar \<Rightarrow> ('a \<Longrightarrow> '\<alpha>)" where
[upred_defs]: "top_var x = (list_lens 0 ;\<^sub>L x)"

text {* The remainder of the local variable stack (the tail) *}

definition rest_var :: "('a::two, '\<alpha>) lvar \<Rightarrow> ('a list \<Longrightarrow> '\<alpha>)" where
[upred_defs]: "rest_var x = (tl_lens ;\<^sub>L x)"

text {* We can show that the top variable is a mainly well-behaved lense, and that the top most
  variable lens is independent of the rest of the stack. *}

lemma top_mwb_lens [simp]: "mwb_lens x \<Longrightarrow> mwb_lens (top_var x)"
  by (simp add: list_mwb_lens top_var_def)

lemma top_rest_var_indep [simp]:
  "mwb_lens x \<Longrightarrow> top_var x \<bowtie> rest_var x"
  by (simp add: lens_indep_left_comp rest_var_def top_var_def)

lemma top_var_pres_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> top_var x \<bowtie> y"
  by (simp add: lens_indep_left_ext top_var_def)

syntax
  "_top_var"             :: "svid \<Rightarrow> svid" ("@_" [999] 999)
  "_rest_var"            :: "svid \<Rightarrow> svid" ("\<down>_" [999] 999)

translations
  "_top_var x" == "CONST top_var x"
  "_rest_var x" == "CONST rest_var x"

text {* With operators to represent local variables, assignments, and stack manipulation defined,
  we can go about defining variable blocks themselves. *}

definition var_begin :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('a, '\<beta>) lvar \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "var_begin T x = x ::=\<^bsub>T\<^esub> \<langle>\<guillemotleft>undefined\<guillemotright>\<rangle> ^\<^sub>u &x"

definition var_end :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('a, '\<beta>) lvar \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "var_end T x = (x ::=\<^bsub>T\<^esub> tail\<^sub>u(&x))"

text {* @{const var_begin} takes as parameters a UTP theory and a local variable, and uses the
  theory assignment operator to push and undefined value onto the variable stack. @{const var_end}
  removes the top most variable from the stack in a similar way. *}

definition var_vlet :: "('\<T>, '\<alpha>) uthy \<Rightarrow> ('a, '\<alpha>) lvar \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "var_vlet T x = (($x \<noteq>\<^sub>u \<langle>\<rangle>) \<and> \<I>\<I>\<^bsub>T\<^esub>)"

text {* Next we set up the typical UTP variable block syntax, though with a suitable subscript index
  to represent the UTP theory parameter. *}

syntax
  "_var_begin"     :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("var\<index> _" [100] 100)
  "_var_begin_asn" :: "logic \<Rightarrow> svid \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ := _")
  "_var_end"       :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("end\<index> _" [100] 100)
  "_var_vlet"      :: "logic \<Rightarrow> svid \<Rightarrow> logic" ("vlet\<index> _" [100] 100)
  "_var_scope"           :: "logic \<Rightarrow> svid \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ \<bullet> _" [0,10] 10)
  "_var_scope_ty"        :: "logic \<Rightarrow> svid \<Rightarrow> type \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ :: _ \<bullet> _" [0,0,10] 10)
  "_var_scope_ty_assign" :: "logic \<Rightarrow> svid \<Rightarrow> type \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("var\<index> _ :: _ := _ \<bullet> _" [0,0,0,10] 10)

translations
  "_var_begin T x"       == "CONST var_begin T x"
  "_var_begin_asn T x e" => "var\<^bsub>T\<^esub> x ;; @x ::=\<^bsub>T\<^esub> e"
  "_var_end T x"         == "CONST var_end T x"
  "_var_vlet T x"        == "CONST var_vlet T x"
  "var\<^bsub>T\<^esub> x \<bullet> P" => "var\<^bsub>T\<^esub> x ;; ((\<lambda> x. P) (CONST top_var x)) ;; end\<^bsub>T\<^esub> x"
  "var\<^bsub>T\<^esub> x \<bullet> P" => "var\<^bsub>T\<^esub> x ;; ((\<lambda> x. P) (CONST top_var x)) ;; end\<^bsub>T\<^esub> x"

text {* In order to substantiate standard variable block laws, we need some underlying laws about
  assignments, which is the purpose of the following locales. *}

locale utp_prog_var = utp_theory \<T> for \<T> :: "('\<T>, '\<alpha>) uthy" (structure) +
  fixes \<V>\<T> :: "'\<beta> itself"
  assumes pvar_uvar: "vwb_lens (\<^bold>v :: '\<beta> \<Longrightarrow> '\<alpha>)"
  and Healthy_pvar_assigns [closure]: "\<^bold>\<langle>\<sigma> :: '\<beta> usubst\<^bold>\<rangle> is \<H>"
  and pvar_assigns_comp: "(\<^bold>\<langle>\<sigma>\<^bold>\<rangle> ;; \<^bold>\<langle>\<rho>\<^bold>\<rangle>) = \<^bold>\<langle>\<rho> \<circ> \<sigma>\<^bold>\<rangle>"

text {* We require that (1) the user-space variable is a very well-behaved lens, (2) that the
  assignment operator is healthy, and (3) that composing two assignments is equivalent to
  composing their substitutions. The next locale extends this with a left unit. *}

locale utp_local_var = utp_prog_var \<T> V + utp_theory_left_unital \<T> for \<T> :: "('\<T>, '\<alpha>) uthy" (structure) and V :: "'\<beta> itself" +
  assumes pvar_assign_unit: "\<^bold>\<langle>id :: '\<beta> usubst\<^bold>\<rangle> = \<I>\<I>"
begin

text {* If a left unit exists then an assignment with an identity substitution should yield the
  identity relation, as the above assumption requires. With these laws available, we can
  prove the main laws of variable blocks. *}

lemma var_begin_healthy [closure]:
  fixes x :: "('a, '\<beta>) lvar"
  shows "var x is \<H>"
  by (simp add: var_begin_def Healthy_pvar_assigns)

lemma var_end_healthy [closure]:
  fixes x :: "('a, '\<beta>) lvar"
  shows "end x is \<H>"
  by (simp add: var_end_def Healthy_pvar_assigns)

text {* The beginning and end of a variable block are both healthy theory elements. *}

lemma var_open_close:
  fixes x :: "('a, '\<beta>) lvar"
  assumes "vwb_lens x"
  shows "(var x ;; end x) = \<I>\<I>"
  by (simp add: var_begin_def var_end_def shEx_lift_seq_1 Healthy_pvar_assigns pvar_assigns_comp pvar_assign_unit usubst assms)

text {* Opening and then immediately closing a variable blocks yields a skip. *}

lemma var_open_close_commute:
  fixes x :: "('a, '\<beta>) lvar" and y :: "('b, '\<beta>) lvar"
  assumes "vwb_lens x" "vwb_lens y" "x \<bowtie> y"
  shows "(var x ;; end y) = (end y ;; var x)"
  by (simp add: var_begin_def var_end_def shEx_lift_seq_1 shEx_lift_seq_2
                Healthy_pvar_assigns pvar_assigns_comp
                assms usubst unrest  lens_indep_sym, simp add: assms usubst_upd_comm)

text {* The beginning and end of variable blocks from different variables commute. *}

lemma var_block_vacuous:
  fixes x :: "('a::two, '\<beta>) lvar"
  assumes "vwb_lens x"
  shows "(var x \<bullet> \<I>\<I>) = \<I>\<I>"
  by (simp add: Left_Unit assms var_end_healthy var_open_close)

text {* A variable block with a skip inside results in a skip. *}
end

text {* Example instantiation for the theory of relations *}

overloading
  rel_pvar == "pvar :: (REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha>"
  rel_pvar_assigns == "pvar_assigns :: (REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel"
begin
  definition rel_pvar :: "(REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> \<Longrightarrow> '\<alpha>" where
  [upred_defs]: "rel_pvar T = 1\<^sub>L"
  definition rel_pvar_assigns :: "(REL, '\<alpha>) uthy \<Rightarrow> '\<alpha> usubst \<Rightarrow> '\<alpha> hrel" where
  [upred_defs]: "rel_pvar_assigns T \<sigma> = \<langle>\<sigma>\<rangle>\<^sub>a"
end

interpretation rel_local_var: utp_local_var "UTHY(REL, '\<alpha>)" "TYPE('\<alpha>)"
proof -
  interpret vw: vwb_lens "pvar REL :: '\<alpha> \<Longrightarrow> '\<alpha>"
    by (simp add: rel_pvar_def id_vwb_lens)
  show "utp_local_var TYPE('\<alpha>) UTHY(REL, '\<alpha>)"
  proof
    show "\<And>\<sigma>::'\<alpha> \<Rightarrow> '\<alpha>. \<^bold>\<langle>\<sigma>\<^bold>\<rangle>\<^bsub>REL\<^esub> is \<H>\<^bsub>REL\<^esub>"
      by (simp add: rel_pvar_assigns_def rel_hcond_def Healthy_def)
    show "\<And>(\<sigma>::'\<alpha> \<Rightarrow> '\<alpha>) \<rho>. \<^bold>\<langle>\<sigma>\<^bold>\<rangle>\<^bsub>UTHY(REL, '\<alpha>)\<^esub> ;; \<^bold>\<langle>\<rho>\<^bold>\<rangle>\<^bsub>REL\<^esub> = \<^bold>\<langle>\<rho> \<circ> \<sigma>\<^bold>\<rangle>\<^bsub>REL\<^esub>"
      by (simp add: rel_pvar_assigns_def assigns_comp)
    show "\<^bold>\<langle>id::'\<alpha> \<Rightarrow> '\<alpha>\<^bold>\<rangle>\<^bsub>UTHY(REL, '\<alpha>)\<^esub> = \<I>\<I>\<^bsub>REL\<^esub>"
      by (simp add: rel_pvar_assigns_def rel_unit_def skip_r_def)
  qed
qed
end


theory Compose_SST_SST_Type
  imports "../Composition/Compose_SST_SST" "../Decomposition/Decompose_Update" Monoid_SST_Type
begin

definition all_shuffles where
  "all_shuffles sst2 q2 q2' =
    {m1. \<exists>w. delta_hat sst2 (q2, w) = q2' \<and>
           m1 = \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w))}"

lemma all_shuffles_member:
  "\<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w))
 \<in> all_shuffles sst2 q2 (delta_hat sst2 (q2, w))"
  unfolding all_shuffles_def by auto

lemma all_shuffles_first:
  "\<pi>\<^sub>1 (SST.eta sst2 (q2, a))
 \<in> all_shuffles sst2 q2 (delta sst2 (q2, a))"
  using all_shuffles_member[of sst2 q2 "[a]"]
  by simp

lemma all_shuffles_mult:
  "all_shuffles sst2 q0 q1 \<otimes> all_shuffles sst2 q1 q2
 \<subseteq> all_shuffles sst2 q0 q2"
  unfolding all_shuffles_def[of sst2 q0 q1] all_shuffles_def[of sst2 q1 q2] mult_shuffles_def
  by (rule subsetI,
      auto simp add: resolve_shuffle_distrib[symmetric] eta_append[symmetric]
                     all_shuffles_member delta_append[symmetric] simp del: delta_append)

fun compose_\<gamma> ::
  "('q1, 'x1, 'a, 'b) SST \<Rightarrow> ('q2, 'x2, 'b, 'c) SST \<Rightarrow>
   ('q1 \<times> ('q2 \<times> 'x1 \<Rightarrow> 'q2), 'q2 \<times> 'x1, 'x2) msst_type" where
   "compose_\<gamma> sst1 sst2 ((_, f), (q2, x)) =
      all_shuffles sst2 q2 (f (q2, x))"

lemma compose_\<gamma>_ex:
  assumes "m \<in> compose_\<gamma> sst1 sst2 ((q1, f), (q2, x))"
  shows "\<exists>w. delta_hat sst2 (q2, w) = f (q2, x) \<and>
             m = \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w))"
  using assms by (simp add: all_shuffles_def)

lemma idS_in_all_shuffles:
  "idS \<in> all_shuffles sst q2 q2"
  using all_shuffles_member[of sst q2 "[]"]
  by (simp add: resolve_idU_idS)

lemma compose_\<gamma>_subset_inner:
  "type_hom (compose_\<gamma> sst1 sst2)
     ((q1, f), Transducer.hat2 (delta2f f (delta sst2)) (eta2f (SST.eta sst2)) (q2, u))
 \<subseteq> all_shuffles sst2 q2 (hat1 (delta2f f (delta sst2)) (q2, u))"
proof (induct u rule: xa_rev_induct)
  case Nil
  then show ?case by (simp add: idS_in_all_shuffles)
next
  case (Var x xs)
  show ?case
    apply (simp add: Transducer.eta_append)
    apply (rule subset_trans)
     apply (rule mult_shuffles_subset)
      apply (rule Var)
    apply (rule subset_refl)
     apply (rule all_shuffles_mult)
    done
next
  case (Alpha a xs)
  show ?case
    apply (simp add: Transducer.eta_append)
    apply (rule subset_trans)
     apply (rule mult_shuffles_subset)
     apply (rule Alpha)
      apply simp
      apply (rule all_shuffles_first)
    apply (rule all_shuffles_mult)
    done
qed

lemma compose_\<gamma>_subset:
  "type_hom (compose_\<gamma> sst1 sst2)
     ((q1, f), H (delta sst2) (eta sst2) (f, \<theta>) (q2, x))
 \<subseteq> all_shuffles sst2 q2 (\<Delta> (delta sst2) (f, \<theta>) (q2, x))"
  by (simp add: \<Delta>_def H_def compose_\<gamma>_subset_inner)

lemma eta2f_length:
  "length (Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q, w)) = length w"
  by (induct w arbitrary: q rule: xa_induct, simp_all)

lemma eta2f_append_ex:
  assumes "u0 @ u1 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, v)"
  shows "\<exists>v1 v2. v = v1 @ v2 \<and>
                 u0 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, v1) \<and>
                 u1 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (hat1 (delta2f f (delta sst2)) (q2, v1), v2)"
proof (intro exI)
  let ?v1 = "take (length u0) v"
  let ?v2 = "drop (length u0) v"
  have len: "length (u0 @ u1) = length (Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, v))"
    using assms by (simp only: eta2f_length)
  have "u0 @ u1 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, ?v1 @ ?v2)"
    using assms by simp
  then have "u0 @ u1 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, ?v1)
                @ Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (hat1 (delta2f f (delta sst2)) (q2, ?v1), ?v2)"
    by (simp only: Transducer.eta_append)
  moreover have "length u0 = length (Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, ?v1))"
    using len by (simp add: eta2f_length)
  moreover have "length u1 = length (Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (hat1 (delta2f f (delta sst2)) (q2, ?v1), ?v2))"
    using len by (simp add: eta2f_length)
  ultimately show "v = ?v1 @ ?v2 \<and>
                  u0 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, ?v1) \<and>
                  u1 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (hat1 (delta2f f (delta sst2)) (q2, ?v1), ?v2)"
    by simp
qed

lemma tail_substring_ex:
  fixes sst1 :: "('q1, 'x, 'a, 'b) SST"
  fixes sst2 :: "('q2, 'y, 'b, 'c) SST"
  assumes "u \<in> tails (SST.eta_hat (compose_SST_SST sst1 sst2) ((q1, f), w) (q2, x))"
  shows "\<exists>v1 v2. SST.eta_hat sst1 (q1, w) x = v1 @ v2 \<and>
                 u = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2))
                               (hat1 (delta2f f (delta sst2)) (q2, v1), v2)"
proof -
  obtain u0 where "u0 @ u = eta_hat (compose_SST_SST sst1 sst2) ((q1, f), w) (q2, x)"
    using assms unfolding tails_def by auto
  then have u0: "u0 @ u = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, SST.eta_hat sst1 (q1, w) x)"
    by (simp add: compose_\<eta>_hat H_def Transducer.eta_append assms compose_SST_SST_def)
  obtain v1 v2 where "v1 @ v2 = SST.eta_hat sst1 (q1, w) x \<and>
                       u0 = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, v1) \<and>
                       u = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2))
                                                           (hat1 (delta2f f (delta sst2)) (q2, v1), v2)"
    using eta2f_append_ex[OF u0] by auto
  then have "SST.eta_hat sst1 (q1, w) x = v1 @ v2 \<and>
                 u = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2))
                               (hat1 (delta2f f (delta sst2)) (q2, v1), v2)"
    by simp
  then show ?thesis by auto
qed

lemma type_hom_eta2f_hat_ex_string:
  fixes sst1 :: "('q1, 'x, 'a, 'b) SST"
  fixes sst2 :: "('q2, 'y, 'b, 'c) SST"
  shows "\<forall>m \<in> type_hom (compose_\<gamma> sst1 sst2) ((q1, f), Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2)) (q2, v)).
         \<exists>w. delta_hat sst2 (q2, w) = hat1 (delta2f f (delta sst2)) (q2, v) \<and>
             \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w)) = m"
proof (induct v rule: xa_rev_induct)
  case Nil
  then show ?case by (simp, rule exI[where x="[]"], simp add: resolve_idU_idS)
next
  case (Var x xs)
  show ?case proof (simp add: Transducer.eta_append, rule ballI)
    let ?set1 = "type_hom (compose_\<gamma> sst1 sst2)
                  ((q1, f), Transducer.hat2 (delta2f f (delta sst2)) (eta2f (SST.eta sst2)) (q2, xs))"
    let ?q = "hat1 (delta2f f (delta sst2)) (q2, xs)"
    let ?q' = "(f (?q, x))"
    fix m
    assume "m \<in> mult_shuffles ?set1 (all_shuffles sst2 ?q ?q')"
    then obtain m1 m2 :: "'y shuffle"
      where m: "m = m1 \<odot> m2 \<and>
             m1 \<in> ?set1 \<and>
             m2 \<in> (all_shuffles sst2 ?q ?q')"
      by (auto simp add: mult_shuffles_def)
    obtain w1 where w1: "delta_hat sst2 (q2, w1) = hat1 (delta2f f (delta sst2)) (q2, xs) \<and>
                         m1 = \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w1))"
      using m Var by auto
    obtain w2 where w2: "delta_hat sst2 (?q, w2) = ?q' \<and> m2 = \<pi>\<^sub>1 (SST.eta_hat sst2 (?q, w2))"
      using m unfolding all_shuffles_def by auto
    have "delta_hat sst2 (q2, w1 @ w2) = f (hat1 (delta2f f (delta sst2)) (q2, xs), x)"
      by (simp add: w1 w2)
    moreover have "\<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w1 @ w2)) = m"
      by (simp add: SST.eta_append resolve_shuffle_distrib m w1 w2)
    ultimately show "\<exists>w. delta_hat sst2 (q2, w) = f (hat1 (delta2f f (delta sst2)) (q2, xs), x) \<and>
                         \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w)) = m"
      by (auto simp del: delta_append)
  qed
next
  case (Alpha a xs)
  show ?case proof (simp add: Transducer.eta_append, rule ballI)
    let ?q = "hat1 (delta2f f (delta sst2)) (q2, xs)"
    let ?q' = "delta sst2 (?q, a)"
    let ?set1 = "type_hom (compose_\<gamma> sst1 sst2)
                  ((q1, f), Transducer.hat2 (delta2f f (delta sst2)) (eta2f (SST.eta sst2)) (q2, xs))"
    let ?set2 = "{\<pi>\<^sub>1 (SST.eta sst2 (?q, a))}"
    fix m
    assume "m \<in> mult_shuffles ?set1 ?set2"
    then obtain m1 m2 :: "'y shuffle"
      where m: "m = m1 \<odot> m2 \<and>
             m1 \<in> ?set1 \<and>
             m2 \<in> ?set2"
      by (auto simp add: mult_shuffles_def)
    obtain w1 where w1: "delta_hat sst2 (q2, w1) = hat1 (delta2f f (delta sst2)) (q2, xs) \<and>
                         m1 = \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w1))"
      using m Alpha by auto
    have w2: "delta_hat sst2 (?q, [a]) = ?q' \<and> m2 = \<pi>\<^sub>1 (SST.eta_hat sst2 (?q, [a]))"
      using m by (simp add:)
    have "delta_hat sst2 (q2, w1 @ [a]) = delta sst2 (hat1 (delta2f f (delta sst2)) (q2, xs), a)"
      by (simp add: w1 w2)
    moreover have "\<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w1 @ [a])) = m"
      by (simp add: SST.eta_append resolve_shuffle_distrib m w1 w2)
    ultimately show "\<exists>w. delta_hat sst2 (q2, w) = delta sst2 (hat1 (delta2f f (delta sst2)) (q2, xs), a) \<and>
                         \<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w)) = m"
      by (auto simp del: delta_append)
  qed
qed

theorem compose_typable:
  fixes sst2 :: "('q2::finite, 'x2::finite, 'b, 'c) SST"
  assumes "bounded_copy_SST k sst2"
  assumes "trim sst2"
  shows "bctype k (compose_SST_SST sst1 sst2) (compose_\<gamma> sst1 sst2)"
proof (auto simp add: bctype_def)
  show "bctype_idS k (compose_SST_SST sst1 sst2) (compose_\<gamma> sst1 sst2)"
    unfolding compose_SST_SST_def bctype_idS_def
    apply (auto simp add: all_shuffles_def)
    apply (rule exI[where x="[]"])
    apply (simp add: resolve_idU_idS)
    done
next
  show "bctype_step k (compose_SST_SST sst1 sst2) (compose_\<gamma> sst1 sst2)"
    unfolding bctype_step_def
    by (auto simp add: compose_SST_SST_def compose_\<delta>_def compose_\<eta>_def compose_\<gamma>_subset)
next
  show "bctype_bounded k (compose_SST_SST sst1 sst2) (compose_\<gamma> sst1 sst2)"
    unfolding bctype_bounded_def
  proof (auto simp add: all_shuffles_def)
    fix q2 w
    have q2_reach: "reachable sst2 q2"
      using assms(2) unfolding trim_def by simp
    have "bounded k (SST.eta_hat sst2 (q2, w))"
      by (rule bounded_copy_SST_simp, simp_all add: assms q2_reach)
    then show "bounded_shuffle k (\<pi>\<^sub>1 (SST.eta_hat sst2 (q2, w)))"
      by (rule resolve_bounded)
  qed
next
  show "bctype_tails k (compose_SST_SST sst1 sst2) (compose_\<gamma> sst1 sst2)"
    unfolding bctype_tails_def
  proof (auto)
    fix q1 f q2 w x u m
    assume "reachable (compose_SST_SST sst1 sst2) (q1, f)"
    let ?eta = "SST.eta_hat (compose_SST_SST sst1 sst2) ((q1, f), w) (q2, x)"
    assume u: "u \<in> tails ?eta"
    assume m0: "m \<in> type_hom (compose_\<gamma> sst1 sst2) ((q1, f), u)"
    obtain v1 v2 where v: "u = Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2))
                                   (hat1 (delta2f f (delta sst2)) (q2, v1), v2)" using tail_substring_ex[OF u] by auto
    let ?q = "hat1 (delta2f f (delta sst2)) (q2, v1)"
    have m: "m \<in> type_hom (compose_\<gamma> sst1 sst2) ((q1, f), Transducer.hat2 (delta2f f (delta sst2)) (eta2f (eta sst2))
                                                 (?q, v2))"
      using m0 v by simp
    obtain w where w: "\<pi>\<^sub>1 (SST.eta_hat sst2 (?q, w)) = m"
      using type_hom_eta2f_hat_ex_string[rule_format, OF m] by auto
    have q2_reach: "reachable sst2 ?q"
      using assms(2) unfolding trim_def by simp
    then have "bounded k (SST.eta_hat sst2 (?q, w))"
      using assms(1) unfolding bounded_copy_SST_def by simp
    then have "bounded_shuffle k (\<pi>\<^sub>1 (SST.eta_hat sst2 (?q, w)))"
      by (simp add: resolve_bounded)
    then show "bounded_shuffle k m" using w by simp
  qed
qed

end


(*  Title:      HOL/Auth/fifo.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The fifo Protocol Case Study*}

theory fifo imports fifo_lemma_invs_on_rules fifo_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


theory IHT_Arrays
  imports
    "../SepLogicTime/SLTC_Main"
    "../Asymptotics/Asymptotics_1D"
    Auto2_Imperative_HOL.Arrays_Ex
begin

definition acopy :: "'a::heap array \<Rightarrow> 'a array Heap" where
  "acopy a = do {
     as \<leftarrow> Array_Time.freeze a;
     Array_Time.of_list as
   }"

definition acopy_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "acopy_time n = 2 * n + 2"

lemma acopy_correct [hoare_triple]:
  "<a \<mapsto>\<^sub>a as * $(acopy_time (length as))>
   acopy a
   <\<lambda>r. a \<mapsto>\<^sub>a as * r \<mapsto>\<^sub>a as>" by auto2

lemma acopy_time_bound [asym_bound]:
  "(\<lambda>n. acopy_time n) \<in> \<Theta>(\<lambda>n. n)"
  apply (simp only: acopy_time_def) by auto2

setup \<open>del_prfstep_thm @{thm acopy_time_def}\<close>

fun array_copy :: "'a::heap array \<Rightarrow> 'a array \<Rightarrow> nat \<Rightarrow> unit Heap" where
  "array_copy a b 0 = (return ())"
| "array_copy a b (Suc n) = do {
      array_copy a b n;
      x \<leftarrow> Array_Time.nth a n;
      Array_Time.upd n x b;
      return () }"

lemma array_copy_rule [hoare_triple]:
  "n \<le> length as \<Longrightarrow> n \<le> length bs \<Longrightarrow>
   <a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a bs * $(3*n+1)>
    array_copy a b n
   <\<lambda>_. a \<mapsto>\<^sub>a as * b \<mapsto>\<^sub>a Arrays_Ex.array_copy as bs n>"
@proof @induct n @qed

definition atake :: "nat \<Rightarrow> 'a::heap array \<Rightarrow> 'a array Heap" where
  "atake n xs = do {
     XS \<leftarrow> Array_Time.freeze xs;
     Array_Time.of_list (take n XS)
   }"

definition atake_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "atake_time n = 2*n + 2"

lemma atake_copies [hoare_triple]:
  "n \<le> length as \<Longrightarrow>
   <xs \<mapsto>\<^sub>a as * $(atake_time (length as))>
    atake n xs
   <\<lambda>r. r \<mapsto>\<^sub>a take n as * xs \<mapsto>\<^sub>a as>\<^sub>t"
@proof
  @have "length as + 1 \<ge>\<^sub>t n + 1"  (* TODO: why is this needed *)
@qed

lemma atake_time_bound [asym_bound]:
  "(\<lambda>n. atake_time n) \<in> \<Theta>(\<lambda>n. n)"
  by (simp only: atake_time_def) auto2

setup \<open>del_prfstep_thm @{thm atake_time_def}\<close>

definition adrop :: "nat \<Rightarrow> 'a::heap array \<Rightarrow> 'a array Heap" where
  "adrop n xs = do {
     XS \<leftarrow> Array_Time.freeze xs;
     Array_Time.of_list (drop n XS)
   }"

definition adrop_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "adrop_time n = 2*n + 2"

lemma adrop_copies [hoare_triple]:
  "n \<le> length as \<Longrightarrow>
   <xs \<mapsto>\<^sub>a as * $(adrop_time (length as))>
    adrop n xs
   <\<lambda>r. r \<mapsto>\<^sub>a drop n as * xs \<mapsto>\<^sub>a as>\<^sub>t"
@proof
  @have "length as + 1 \<ge>\<^sub>t (length as - n) + 1"
  @qed

lemma adrop_time_bound [asym_bound]:
  "(\<lambda>n. adrop_time n) \<in> \<Theta>(\<lambda>n. n)"
  by (simp only: adrop_time_def) auto2

setup \<open>del_prfstep_thm @{thm adrop_time_def}\<close>

definition asplit :: "'a::heap array \<Rightarrow> nat \<Rightarrow> ('a array \<times> 'a array) Heap" where
  "asplit a n = do {
     b \<leftarrow> atake n a;
     c \<leftarrow> adrop n a;
     return (b, c)
   }"

definition asplit_time :: "nat \<Rightarrow> nat" where [rewrite]:
  "asplit_time la = atake_time la + adrop_time la + 1"

lemma asplit_correct [hoare_triple]:
  "n \<le> length as \<Longrightarrow>
   <a \<mapsto>\<^sub>a as * $(asplit_time (length as))>
   asplit a n
   <\<lambda>(p,q). a \<mapsto>\<^sub>a as * p \<mapsto>\<^sub>a take n as * q \<mapsto>\<^sub>a drop n as>\<^sub>t"
@proof
  @have "length as \<ge>\<^sub>t n + (length as - n)"
@qed

lemma asplit_time_bound [asym_bound]:
  "(\<lambda>n. asplit_time n) \<in> \<Theta>(\<lambda>n. n)"
  by (simp only: asplit_time_def) auto2

setup \<open>del_prfstep_thm @{thm asplit_time_def}\<close>

end