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

(* Total correctness Hoare logic for the NonDetMonad (= valid + no_fail) *)

theory NonDetMonad_Total
  imports No_Fail
begin

section \<open>Total correctness for NonDetMonad and NonDetMonad with exceptions\<close>

subsection Definitions

text \<open>
  It is often desired to prove non-failure and a Hoare triple simultaneously, as the reasoning
  is often similar. The following definitions allow such reasoning to take place.\<close>

definition validNF ::
  "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool" ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>! \<equiv> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<and> no_fail P f"

lemma validNF_alt_def:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>! = (\<forall>s. P s \<longrightarrow> ((\<forall>(r', s') \<in> fst (f s). Q r' s') \<and> \<not> snd (f s)))"
  by (fastforce simp: validNF_def valid_def no_fail_def)

definition validE_NF ::
  "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) nondet_monad \<Rightarrow> ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>!)") where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>! \<equiv> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace> \<and> no_fail P f"

lemma validE_NF_alt_def:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>! = \<lbrace>P\<rbrace> f \<lbrace>\<lambda>v s. case v of Inl e \<Rightarrow> E e s | Inr r \<Rightarrow> Q r s\<rbrace>!"
  by (clarsimp simp: validE_NF_def validE_def validNF_def)

subsection \<open>@{method wpc} setup\<close>

lemma wpc_helper_validNF:
  "\<lbrace>Q\<rbrace> g \<lbrace>S\<rbrace>! \<Longrightarrow> wpc_helper (P, P') (Q, Q') \<lbrace>P\<rbrace> g \<lbrace>S\<rbrace>!"
  unfolding wpc_helper_def
  by clarsimp (metis hoare_vcg_precond_imp no_fail_pre validNF_def)

wpc_setup "\<lambda>m. \<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>!" wpc_helper_validNF

subsection \<open>Basic @{const validNF} theorems\<close>

lemma validNF_make_schematic_post:
  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>!) \<Longrightarrow>
   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>!"
  by (auto simp add: valid_def validNF_def no_fail_def split: prod.splits)

lemma validE_NF_make_schematic_post:
  "(\<forall>s0. \<lbrace> \<lambda>s. P s0 s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 rv s \<rbrace>, \<lbrace> \<lambda>rv s. E s0 rv s \<rbrace>!) \<Longrightarrow>
   \<lbrace> \<lambda>s. \<exists>s0. P s0 s \<and> (\<forall>rv s'. Q s0 rv s' \<longrightarrow> Q' rv s')
        \<and> (\<forall>rv s'. E s0 rv s' \<longrightarrow> E' rv s') \<rbrace> f \<lbrace> Q' \<rbrace>, \<lbrace> E' \<rbrace>!"
  by (auto simp add: validE_NF_def validE_def valid_def no_fail_def split: prod.splits sum.splits)

lemma validNF_conjD1:
  "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv s. Q rv s \<and> Q' rv s \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!"
  by (fastforce simp: validNF_def valid_def no_fail_def)

lemma validNF_conjD2:
  "\<lbrace> P \<rbrace> f \<lbrace> \<lambda>rv s. Q rv s \<and> Q' rv s \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q' \<rbrace>!"
  by (fastforce simp: validNF_def valid_def no_fail_def)

lemma validNF[intro?]: (* FIXME lib: should be validNFI *)
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!"
  by (clarsimp simp: validNF_def)

lemma validNFE:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!; \<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (clarsimp simp: validNF_def)

lemma validNF_valid:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  by (erule validNFE)

lemma validNF_no_fail:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>! \<rbrakk> \<Longrightarrow> no_fail P f"
  by (erule validNFE)

lemma snd_validNF:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!; P s \<rbrakk> \<Longrightarrow> \<not> snd (f s)"
  by (clarsimp simp: validNF_def no_fail_def)

lemma use_validNF:
  "\<lbrakk> (r', s') \<in> fst (f s); \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>!; P s \<rbrakk> \<Longrightarrow> Q r' s'"
  by (fastforce simp: validNF_def valid_def)

subsection \<open>@{const validNF} weakest precondition rules\<close>

lemma validNF_return[wp]:
  "\<lbrace> P x \<rbrace> return x \<lbrace> P \<rbrace>!"
  by (wp validNF)+

lemma validNF_get[wp]:
  "\<lbrace> \<lambda>s. P s s  \<rbrace> get \<lbrace> P \<rbrace>!"
  by (wp validNF)+

lemma validNF_put[wp]:
  "\<lbrace> \<lambda>s. P () x  \<rbrace> put x \<lbrace> P \<rbrace>!"
  by (wp validNF)+

lemma validNF_K_bind[wp]:
  "\<lbrace> P \<rbrace> x \<lbrace> Q \<rbrace>! \<Longrightarrow> \<lbrace> P \<rbrace> K_bind x f \<lbrace> Q \<rbrace>!"
  by simp

lemma validNF_fail[wp]:
  "\<lbrace> \<lambda>s. False \<rbrace> fail \<lbrace> Q \<rbrace>!"
  by (clarsimp simp: validNF_def fail_def no_fail_def)

lemma validNF_prop[wp_unsafe]:
  "\<lbrakk> no_fail (\<lambda>s. P) f \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s. P \<rbrace> f \<lbrace> \<lambda>rv s. P \<rbrace>!"
  by (wp validNF)+

lemma validNF_post_conj[intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> Q \<rbrace>!; \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> a \<lbrace> Q and R \<rbrace>!"
  by (auto simp: validNF_def)

lemma validNF_pre_disj[intro!]:
  "\<lbrakk> \<lbrace> P \<rbrace> a \<lbrace> R \<rbrace>!; \<lbrace> Q \<rbrace> a \<lbrace> R \<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace> P or Q \<rbrace> a \<lbrace> R \<rbrace>!"
  by (rule validNF) (auto dest: validNF_valid validNF_no_fail intro: no_fail_or)

text \<open>
  Set up combination rules for @{method wp}, which also requires a @{text wp_trip} rule for
  @{const validNF}.\<close>
definition validNF_property :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> ('s,'a) nondet_monad \<Rightarrow> bool" where
  "validNF_property Q s b \<equiv> \<not> snd (b s) \<and> (\<forall>(r', s') \<in> fst (b s). Q r' s')"

lemma validNF_is_triple[wp_trip]:
  "validNF P f Q = triple_judgement P f (validNF_property Q)"
  by (auto simp: validNF_def triple_judgement_def validNF_property_def no_fail_def valid_def)

lemma validNF_weaken_pre[wp_pre]:
  "\<lbrakk>\<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>!; \<And>s. P s \<Longrightarrow> Q s\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>!"
  by (metis hoare_pre_imp no_fail_pre validNF_def)

lemma validNF_post_comb_imp_conj:
  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>!; \<And>s. P s \<Longrightarrow> P' s \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>!"
  by (fastforce simp: validNF_def valid_def)

lemma validNF_post_comb_conj_L:
  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' s \<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>!"
  by (fastforce simp: validNF_def valid_def no_fail_def)

lemma validNF_post_comb_conj_R:
  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' s \<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>!"
  by (fastforce simp: validNF_def valid_def no_fail_def)

lemma validNF_post_comb_conj:
  "\<lbrakk> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q'\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' s \<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>!"
  by (fastforce simp: validNF_def valid_def no_fail_def)

lemma validNF_if_split[wp_split]:
  "\<lbrakk>P \<Longrightarrow> \<lbrace>Q\<rbrace> f \<lbrace>S\<rbrace>!; \<not> P \<Longrightarrow> \<lbrace>R\<rbrace> g \<lbrace>S\<rbrace>!\<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. (P \<longrightarrow> Q s) \<and> (\<not> P \<longrightarrow> R s)\<rbrace> if P then f else g \<lbrace>S\<rbrace>!"
  by simp

lemma validNF_vcg_conj_lift:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>!"
  by (fastforce intro!: validNF_post_conj[unfolded pred_conj_def] intro: validNF_weaken_pre)

lemma validNF_vcg_disj_lift:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<or> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<or> Q' rv s\<rbrace>!"
  by (auto  simp: validNF_def no_fail_def intro!: hoare_vcg_disj_lift)

lemma validNF_vcg_all_lift[wp]:
  "\<lbrakk> \<And>x. \<lbrace>P x\<rbrace> f \<lbrace>Q x\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> f \<lbrace>\<lambda>rv s. \<forall>x. Q x rv s\<rbrace>!"
  by (auto simp: validNF_def no_fail_def intro!: hoare_vcg_all_lift)

lemma validNF_bind[wp_split]:
  "\<lbrakk> \<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>!; \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> do x \<leftarrow> f; g x od \<lbrace>C\<rbrace>!"
  unfolding validNF_def
  by (auto intro: hoare_seq_ext no_fail_bind[where P=Q and Q=Q for Q, simplified])

lemmas validNF_seq_ext = validNF_bind

subsection "validNF compound rules"

lemma validNF_state_assert[wp]:
  "\<lbrace> \<lambda>s. P () s \<and> G s  \<rbrace> state_assert G \<lbrace> P \<rbrace>!"
  by (rule validNF; wpsimp)

lemma validNF_modify[wp]:
  "\<lbrace> \<lambda>s. P () (f s) \<rbrace> modify f \<lbrace> P \<rbrace>!"
  by (rule validNF; wpsimp)

lemma validNF_gets[wp]:
  "\<lbrace>\<lambda>s. P (f s) s\<rbrace> gets f \<lbrace>P\<rbrace>!"
  by (rule validNF; wpsimp)

lemma validNF_condition[wp]:
  "\<lbrakk> \<lbrace> Q \<rbrace> A \<lbrace>P\<rbrace>!; \<lbrace> R \<rbrace> B \<lbrace>P\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. if C s then Q s else R s\<rbrace> condition C A B \<lbrace>P\<rbrace>!"
  by (erule validNFE)+
     (rule validNF; wpsimp wp: no_fail_condition)

lemma validNF_assert[wp]:
  "\<lbrace> (\<lambda>s. P) and (R ()) \<rbrace> assert P \<lbrace> R \<rbrace>!"
  by (rule validNF; wpsimp)

lemma validNF_false_pre:
  "\<lbrace> \<lambda>_. False \<rbrace> P \<lbrace> Q \<rbrace>!"
  by (rule validNF; wpsimp)

lemma validNF_chain:
   "\<lbrakk>\<lbrace>P'\<rbrace> a \<lbrace>R'\<rbrace>!; \<And>s. P s \<Longrightarrow> P' s; \<And>r s. R' r s \<Longrightarrow> R r s\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>!"
  by (fastforce simp: validNF_def valid_def no_fail_def Ball_def)

lemma validNF_case_prod[wp]:
  "(\<And>x y. \<lbrace>P x y\<rbrace> B x y \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>case v of (x, y) \<Rightarrow> P x y\<rbrace> case v of (x, y) \<Rightarrow> B x y \<lbrace>Q\<rbrace>!"
  by (metis prod.exhaust split_conv)

lemma validE_NF_case_prod[wp]:
  "\<lbrakk> \<And>a b. \<lbrace>P a b\<rbrace> f a b \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow>
   \<lbrace>case x of (a, b) \<Rightarrow> P a b\<rbrace> case x of (a, b) \<Rightarrow> f a b \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!"
  unfolding validE_NF_alt_def
  by (erule validNF_case_prod)

lemma no_fail_is_validNF_True:
  "no_fail P s = (\<lbrace> P \<rbrace> s \<lbrace> \<lambda>_ _. True \<rbrace>!)"
  by (clarsimp simp: no_fail_def validNF_def valid_def)

subsection \<open>@{const validNF} reasoning in the exception monad\<close>

lemma validE_NF[intro?]: (* FIXME lib: should be validE_NFI *)
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!"
  by (clarsimp simp: validE_NF_def)

lemma validE_NFE:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!; \<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>; no_fail P f \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (clarsimp simp: validE_NF_def)

lemma validE_NF_valid:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  by (rule validE_NFE)

lemma validE_NF_no_fail:
  "\<lbrakk> \<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! \<rbrakk> \<Longrightarrow> no_fail P f"
  by (rule validE_NFE)

lemma validE_NF_weaken_pre[wp_pre]:
  "\<lbrakk>\<lbrace>Q\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>E\<rbrace>!; \<And>s. P s \<Longrightarrow> Q s\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> a \<lbrace>R\<rbrace>,\<lbrace>E\<rbrace>!"
  by (simp add: validE_NF_alt_def validNF_weaken_pre)

lemma validE_NF_post_comb_conj_L:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, \<lbrace>\<lambda>_ _. True\<rbrace> \<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. P s \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, \<lbrace>E\<rbrace>!"
  unfolding validE_NF_alt_def
  by (fastforce simp: validE_def validNF_def valid_def no_fail_def split: sum.splits)

lemma validE_NF_post_comb_conj_R:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>\<lambda>_ _. True\<rbrace>; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, \<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. P s \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, \<lbrace>E\<rbrace>!"
  unfolding validE_NF_alt_def validE_def validNF_def valid_def no_fail_def
  by (fastforce split: sum.splits)

lemma validE_NF_post_comb_conj:
  "\<lbrakk> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!; \<lbrace>P'\<rbrace> f \<lbrace>Q'\<rbrace>, \<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>\<lambda>s. P s \<and> P' s\<rbrace> f \<lbrace>\<lambda>rv s. Q rv s \<and> Q' rv s\<rbrace>, \<lbrace>E\<rbrace>!"
  unfolding validE_NF_alt_def validE_def validNF_def valid_def no_fail_def
  by (fastforce split: sum.splits)

lemma validE_NF_chain:
  "\<lbrakk> \<lbrace>P'\<rbrace> a \<lbrace>R'\<rbrace>,\<lbrace>E'\<rbrace>!; \<And>s. P s \<Longrightarrow> P' s; \<And>r' s'. R' r' s' \<Longrightarrow> R r' s';
     \<And>r'' s''. E' r'' s'' \<Longrightarrow> E r'' s''\<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. P s \<rbrace> a \<lbrace>\<lambda>r' s'. R r' s'\<rbrace>,\<lbrace>\<lambda>r'' s''. E r'' s''\<rbrace>!"
  by (fastforce simp: validE_NF_def validE_def2 no_fail_def Ball_def split: sum.splits)

lemma validE_NF_bind_wp[wp]:
  "\<lbrakk>\<And>x. \<lbrace>B x\<rbrace> g x \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>!; \<lbrace>A\<rbrace> f \<lbrace>B\<rbrace>, \<lbrace>E\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> f >>=E (\<lambda>x. g x) \<lbrace>C\<rbrace>, \<lbrace>E\<rbrace>!"
  by (blast intro: validE_NF hoare_vcg_seqE no_fail_pre no_fail_bindE validE_validE_R validE_weaken
            elim!: validE_NFE)

lemma validNF_catch[wp]:
  "\<lbrakk>\<And>x. \<lbrace>E x\<rbrace> handler x \<lbrace>Q\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!\<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> f <catch> (\<lambda>x. handler x) \<lbrace>Q\<rbrace>!"
  unfolding validE_NF_alt_def catch_def lift_def throwError_def
  by (clarsimp simp: validNF_return split: sum.splits elim!: validNF_bind[rotated])

lemma validNF_throwError[wp]:
  "\<lbrace>E e\<rbrace> throwError e \<lbrace>P\<rbrace>, \<lbrace>E\<rbrace>!"
  by (unfold validE_NF_alt_def throwError_def o_def) wpsimp

lemma validNF_returnOk[wp]:
  "\<lbrace>P e\<rbrace> returnOk e \<lbrace>P\<rbrace>, \<lbrace>E\<rbrace>!"
  by (clarsimp simp: validE_NF_alt_def returnOk_def) wpsimp

lemma validNF_whenE[wp]:
  "(P \<Longrightarrow> \<lbrace>Q\<rbrace> f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>!) \<Longrightarrow> \<lbrace>if P then Q else R ()\<rbrace> whenE P f \<lbrace>R\<rbrace>, \<lbrace>E\<rbrace>!"
  unfolding whenE_def by wpsimp

lemma validNF_nobindE[wp]:
  "\<lbrakk> \<lbrace>B\<rbrace> g \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>!; \<lbrace>A\<rbrace> f \<lbrace>\<lambda>r s. B s\<rbrace>,\<lbrace>E\<rbrace>! \<rbrakk> \<Longrightarrow> \<lbrace>A\<rbrace> doE f; g odE \<lbrace>C\<rbrace>,\<lbrace>E\<rbrace>!"
  by wpsimp

text \<open>
  Set up triple rules for @{term validE_NF} so that we can use @{method wp} combinator rules.\<close>
definition validE_NF_property ::
  "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> ('s, 'c+'a) nondet_monad \<Rightarrow> bool" where
  "validE_NF_property Q E s b \<equiv>
   \<not> snd (b s) \<and> (\<forall>(r', s') \<in> fst (b s). case r' of Inl x \<Rightarrow> E x s' | Inr x \<Rightarrow> Q x s')"

lemma validE_NF_is_triple[wp_trip]:
  "validE_NF P f Q E = triple_judgement P f (validE_NF_property Q E)"
  by (fastforce simp: validE_NF_def validE_def2 no_fail_def triple_judgement_def
                      validE_NF_property_def
                split: sum.splits)

lemma validNF_cong:
  "\<lbrakk> \<And>s. P s = P' s; \<And>s. P s \<Longrightarrow> m s = m' s;
     \<And>r' s' s. \<lbrakk> P s; (r', s') \<in> fst (m s) \<rbrakk> \<Longrightarrow> Q r' s' = Q' r' s' \<rbrakk> \<Longrightarrow>
   (\<lbrace>P\<rbrace> m \<lbrace>Q\<rbrace>!) = (\<lbrace>P'\<rbrace> m' \<lbrace>Q'\<rbrace>!)"
  by (fastforce simp: validNF_alt_def)

lemma validE_NF_liftE[wp]:
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>! \<Longrightarrow> \<lbrace>P\<rbrace> liftE f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  by (wpsimp simp: validE_NF_alt_def liftE_def)

lemma validE_NF_handleE'[wp]:
  "\<lbrakk> \<And>x. \<lbrace>F x\<rbrace> handler x \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>F\<rbrace>! \<rbrakk> \<Longrightarrow>
   \<lbrace>P\<rbrace> f <handle2> (\<lambda>x. handler x) \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  unfolding validE_NF_alt_def handleE'_def
  apply (erule validNF_bind[rotated])
  apply (clarsimp split: sum.splits)
  apply wpsimp
  done

lemma validE_NF_handleE[wp]:
  "\<lbrakk> \<And>x. \<lbrace>F x\<rbrace> handler x \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!; \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>F\<rbrace>! \<rbrakk> \<Longrightarrow>
   \<lbrace>P\<rbrace> f <handle> handler \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  unfolding handleE_def
  by (metis validE_NF_handleE')

lemma validE_NF_condition[wp]:
  "\<lbrakk> \<lbrace> Q \<rbrace> A \<lbrace>P\<rbrace>,\<lbrace> E \<rbrace>!; \<lbrace> R \<rbrace> B \<lbrace>P\<rbrace>,\<lbrace> E \<rbrace>! \<rbrakk> \<Longrightarrow>
   \<lbrace>\<lambda>s. if C s then Q s else R s\<rbrace> condition C A B \<lbrace>P\<rbrace>,\<lbrace> E \<rbrace>!"
  by (erule validE_NFE)+ (wpsimp wp: no_fail_condition validE_NF)

lemma hoare_assume_preNF:
  "(\<And>s. P s \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>!"
  by (metis validNF_alt_def)

end


theory "Lowe_fixed_Needham_Schroeder_Public_Key_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Needham-Schroeder-Lowe Public-Key Protocol  *)

(* text:
  Modelled after SPORE.

  Notable differences:
    1. We use explicit global constants instead of implicit typing to discern
       the different messages.

    2. We model a single certificate-authority (CA) server role, which is used
       to answer the certificate requests from both A and B.

    2. We prove non-injective synchronization, which is stronger than the
       entity authentication property stated in SPORE as the requirement on
       this protocol.

 *)

role I
where "I =
  [ Send ''ca1'' <| sAV ''I'', sAV ''R'' |>
  , Recv ''ca2'' <| sMV ''S'',
                    PSign <| sC ''ca2'', sMV ''pkR'', sAV ''R'' |> ( PAsymPK ( sMV ''S'' ) )
                 |>
  , Send ''1'' <| sAV ''I'',
                  PEnc <| sC ''1'', sN ''ni'', sAV ''I'' |> ( sMV ''pkR'' )
               |>
  , Recv ''2'' ( PEnc <| sC ''2'', sN ''ni'', sMV ''nr'', sAV ''R'' |>
                      ( sPK ''I'' )
               )
  , Send ''3'' ( PEnc <| sC ''3'', sMV ''nr'' |> ( sMV ''pkR'' ) )
  ]"

role R
where "R =
  [ Recv ''1'' <| sMV ''I'',
                  PEnc <| sC ''1'', sMV ''ni'', sMV ''I'' |> ( sPK ''R'' )
               |>
  , Send ''ca1'' <| sAV ''R'', sMV ''I'' |>
  , Recv ''ca2'' <| sMV ''S'',
                    PSign <| sC ''ca2'', sMV ''pkI'', sMV ''I'' |> ( PAsymPK ( sMV ''S'' ) )
                 |>
  , Send ''2'' ( PEnc <| sC ''2'', sMV ''ni'', sN ''nr'', sAV ''R'' |>
                      ( sMV ''pkI'' )
               )
  , Recv ''3'' ( PEnc <| sC ''3'', sN ''nr'' |> ( sPK ''R'' ) )
  ]"

role S
where "S =
  [ Recv ''ca1'' <| sMV ''A'', sMV ''B'' |>
  , Send ''ca2'' <| sAV ''S'',
                    PSign <| sC ''ca2'', PAsymPK ( sMV ''B'' ), sMV ''B'' |> ( sPK ''S'' )
                 |>
  ]"

protocol NSLPK
where "NSLPK = { I, R, S }"

locale restricted_NSLPK_state = NSLPK_state +
  assumes I_uncompromised_S:
    "!! tid1.
       [| roleMap r tid1 = Some I |] ==> RLKR(s(MV ''S'' tid1)) ~: reveals t"
  assumes R_uncompromised_S:
    "!! tid1.
       [| roleMap r tid1 = Some R |] ==> RLKR(s(MV ''S'' tid1)) ~: reveals t"

type_invariant NSLPK_msc_typing for NSLPK
where "NSLPK_msc_typing = mk_typing
  [ ((S, ''A''), (KnownT S_ca1))
  , ((S, ''B''), (KnownT S_ca1))
  , ((R, ''I''), (KnownT R_1))
  , ((I, ''S''), (KnownT I_ca2))
  , ((R, ''S''), (KnownT R_ca2))
  , ((R, ''ni''), (SumT (KnownT R_1) (NonceT I ''ni'')))
  , ((I, ''nr''), (SumT (KnownT I_2) (NonceT R ''nr'')))
  , ((R, ''pkI''), (KnownT R_ca2))
  , ((I, ''pkR''), (KnownT I_ca2))
  ]"

sublocale NSLPK_state < NSLPK_msc_typing_state
proof -
  have "(t,r,s) : approx NSLPK_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF NSLPK_msc_typing.monoTyp, completeness_cases_rule])
    case (I_ca2_S t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_ca2_S
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (I_ca2_pkR t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_ca2_pkR
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (I_2_nr t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = I_2_nr
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', LN ''ni'' tid0, s(MV ''nr'' tid0), s(AV ''R'' tid0) |}
            ( PK ( s(AV ''I'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (R_1_I t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_1_I
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (R_1_ni t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_1_ni
    thus ?case
    proof(sources! "
        Enc {| LC ''1'', s(MV ''ni'' tid0), s(MV ''I'' tid0) |}
            ( PK ( s(AV ''R'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (R_ca2_S t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_ca2_S
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (R_ca2_pkI t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = R_ca2_pkI
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_ca1_A t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_ca1_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (S_ca1_B t r s tid0)
    then interpret state: NSLPK_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = S_ca1_B
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  qed
  thus "NSLPK_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context NSLPK_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Assumptions  *)

(* text:
  Initiators as well as responders talk to an uncompromised server.
 *)

(* subsection:  Security Properties  *)

lemma (in restricted_NSLPK_state) I_pkR_auth:
  assumes facts:
    "roleMap r tid1 = Some I"
    "( tid1, I_ca2 ) : steps t"
  shows "s(MV ''pkR'' tid1) = PK ( s(AV ''R'' tid1) )"
proof -
  note_prefix_closed facts = facts
  have f1: "roleMap r tid1 = Some I" using facts by (auto intro: event_predOrdI)
  note facts = facts I_uncompromised_S[OF f1, simplified]
  thus ?thesis proof(sources! "
                   Enc {| LC ''ca2'', s(MV ''pkR'' tid1), s(AV ''R'' tid1) |}
                       ( SK ( s(MV ''S'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_ca2_enc tid2) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_NSLPK_state) R_pkI_auth:
  assumes facts:
    "roleMap r tid1 = Some R"
    "( tid1, R_ca2 ) : steps t"
  shows "s(MV ''pkI'' tid1) = PK ( s(MV ''I'' tid1) )"
proof -
  note_prefix_closed facts = facts
  have f1: "roleMap r tid1 = Some R" using facts by (auto intro: event_predOrdI)
  note facts = facts R_uncompromised_S[OF f1, simplified]
  thus ?thesis proof(sources! "
                   Enc {| LC ''ca2'', s(MV ''pkI'' tid1), s(MV ''I'' tid1) |}
                       ( SK ( s(MV ''S'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (S_ca2_enc tid2) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_NSLPK_state) I_ni_secrecy:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "LN ''ni'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''ni'' tid0 ")
  case I_1_ni note_unified facts = this facts
  have f1: "roleMap r tid0 = Some I" using facts by (auto intro: event_predOrdI)
  have f2: "( tid0, I_ca2
            ) : steps t" using facts by (auto intro: event_predOrdI)
  note facts = facts I_pkR_auth[OF f1 f2, simplified]
  thus ?thesis by (auto dest!: ltk_secrecy)
next
  case (R_2_ni tid1) note_unified facts = this facts
  have f1: "roleMap r tid1 = Some R" using facts by (auto intro: event_predOrdI)
  have f2: "( tid1, R_ca2
            ) : steps t" using facts by (auto intro: event_predOrdI)
  note facts = facts R_pkI_auth[OF f1 f2, simplified]
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', LN ''ni'' tid0, s(MV ''I'' tid1) |}
                       ( PK ( s(AV ''R'' tid1) ) ) ")
    case (I_1_enc tid2) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_NSLPK_state) R_nr_secrecy:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "LN ''nr'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''nr'' tid0 ")
  case (I_3_nr tid1) note_unified facts = this facts
  have f1: "roleMap r tid1 = Some I" using facts by (auto intro: event_predOrdI)
  have f2: "( tid1, I_ca2
            ) : steps t" using facts by (auto intro: event_predOrdI)
  note facts = facts I_pkR_auth[OF f1 f2, simplified]
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid1, LN ''nr'' tid0, s(AV ''R'' tid1) |}
                       ( PK ( s(AV ''I'' tid1) ) ) ")
    case (R_2_enc tid2) note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  qed (safe?, simp_all?, insert facts, ((((clarsimp, order?) | order | fast))+)?)
next
  case R_2_nr note_unified facts = this facts
  have f1: "roleMap r tid0 = Some R" using facts by (auto intro: event_predOrdI)
  have f2: "( tid0, R_ca2
            ) : steps t" using facts by (auto intro: event_predOrdI)
  note facts = facts R_pkI_auth[OF f1 f2, simplified]
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_NSLPK_state) I_nr_secrecy:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "( tid0, I_2 ) : steps t"
    "s(MV ''nr'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid0, s(MV ''nr'' tid0), s(AV ''R'' tid0) |}
                       ( PK ( s(AV ''I'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
  next
    case (R_2_enc tid1) note_unified facts = this facts
    have f1: "roleMap r tid1 = Some R" using facts by (auto intro: event_predOrdI)
    have f2: "( tid1, R_ca2
              ) : steps t" using facts by (auto intro: event_predOrdI)
    note facts = facts R_pkI_auth[OF f1 f2, simplified]
    thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_NSLPK_state) R_ni_secrecy:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "( tid0, R_3 ) : steps t"
    "s(MV ''ni'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  have f1: "roleMap r tid0 = Some R" using facts by (auto intro: event_predOrdI)
  have f2: "( tid0, R_ca2
            ) : steps t" using facts by (auto intro: event_predOrdI)
  note facts = facts R_pkI_auth[OF f1 f2, simplified]
  thus ?thesis proof(sources! "
                   Enc {| LC ''3'', LN ''nr'' tid0 |} ( PK ( s(AV ''R'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
  next
    case (I_3_enc tid1) note_unified facts = this facts
    have f1: "roleMap r tid1 = Some I" using facts by (auto intro: event_predOrdI)
    have f2: "( tid1, I_ca2
              ) : steps t" using facts by (auto intro: event_predOrdI)
    note facts = facts I_pkR_auth[OF f1 f2, simplified]
    thus ?thesis proof(sources! "
                     Enc {| LC ''2'', LN ''ni'' tid1, LN ''nr'' tid0, s(AV ''R'' tid0) |}
                         ( PK ( s(AV ''I'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
    next
      case (R_2_enc tid2) note_unified facts = this facts
      thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_NSLPK_state) I_noninjective_synch:
  assumes facts:
    "roleMap r tid1 = Some I"
    "RLKR(s(AV ''I'' tid1)) ~: reveals t"
    "RLKR(s(AV ''R'' tid1)) ~: reveals t"
    "( tid1, I_2 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some R &
        s(AV ''I'' tid1) = s(MV ''I'' tid2) &
        s(AV ''R'' tid1) = s(AV ''R'' tid2) &
        LN ''ni'' tid1 = s(MV ''ni'' tid2) &
        s(MV ''nr'' tid1) = LN ''nr'' tid2 &
        predOrd t (St( tid1, I_1 )) (St( tid2, R_1 )) &
        predOrd t (St( tid2, R_2 )) (St( tid1, I_2 )) &
        predOrd t (St( tid1, I_1 )) (St( tid1, I_2 )) &
        predOrd t (St( tid2, R_1 )) (St( tid2, R_2 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''ni'' tid1, s(MV ''nr'' tid1), s(AV ''R'' tid1) |}
                       ( PK ( s(AV ''I'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
  next
    case (R_2_enc tid2) note_unified facts = this facts
    have f1: "roleMap r tid2 = Some R" using facts by (auto intro: event_predOrdI)
    have f2: "( tid2, R_ca2
              ) : steps t" using facts by (auto intro: event_predOrdI)
    note facts = facts R_pkI_auth[OF f1 f2, simplified]
    thus ?thesis proof(sources! "
                     Enc {| LC ''1'', LN ''ni'' tid1, s(AV ''I'' tid1) |}
                         ( PK ( s(AV ''R'' tid1) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: I_ni_secrecy intro: event_predOrdI)
    next
      case (I_1_enc tid3) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_NSLPK_state) R_noninjective_synch:
  assumes facts:
    "roleMap r tid2 = Some R"
    "RLKR(s(AV ''R'' tid2)) ~: reveals t"
    "RLKR(s(MV ''I'' tid2)) ~: reveals t"
    "( tid2, R_3 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some I &
        s(AV ''I'' tid1) = s(MV ''I'' tid2) &
        s(AV ''R'' tid1) = s(AV ''R'' tid2) &
        LN ''ni'' tid1 = s(MV ''ni'' tid2) &
        s(MV ''nr'' tid1) = LN ''nr'' tid2 &
        predOrd t (St( tid1, I_1 )) (St( tid2, R_1 )) &
        predOrd t (St( tid2, R_2 )) (St( tid1, I_2 )) &
        predOrd t (St( tid1, I_3 )) (St( tid2, R_3 )) &
        predOrd t (St( tid1, I_1 )) (St( tid1, I_2 )) &
        predOrd t (St( tid1, I_2 )) (St( tid1, I_3 )) &
        predOrd t (St( tid2, R_1 )) (St( tid2, R_2 )) &
        predOrd t (St( tid2, R_2 )) (St( tid2, R_3 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''1'', s(MV ''ni'' tid2), s(MV ''I'' tid2) |}
                       ( PK ( s(AV ''R'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: R_ni_secrecy intro: event_predOrdI)
  next
    case (I_1_enc tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''3'', LN ''nr'' tid2 |} ( PK ( s(AV ''R'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
    next
      case (I_3_enc tid4) note_unified facts = this facts
      have f1: "roleMap r tid4 = Some I" using facts by (auto intro: event_predOrdI)
      have f2: "( tid4, I_ca2
                ) : steps t" using facts by (auto intro: event_predOrdI)
      note facts = facts I_pkR_auth[OF f1 f2, simplified]
      thus ?thesis proof(sources! "
                       Enc {| LC ''2'', LN ''ni'' tid4, LN ''nr'' tid2, s(AV ''R'' tid2) |}
                           ( PK ( s(AV ''I'' tid4) ) ) ")
        case fake note_unified facts = this facts
        thus ?thesis by (fastforce dest: R_nr_secrecy intro: event_predOrdI)
      next
        case (R_2_enc tid5) note_unified facts = this facts
        thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
      qed (safe?, simp_all?, insert facts, (fastforce+)?)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end


section \<open>During-execution security\<close>

theory During_Execution
imports Bisim Language_Semantics begin

subsection \<open>Basic setting\<close>

locale PL_Indis = PL tval aval
  for
    tval :: "'test \<Rightarrow> 'state \<Rightarrow> bool" and
    aval :: "'atom \<Rightarrow> 'state \<Rightarrow> 'state"
  +
  fixes
    indis :: "'state rel"
  assumes
    equiv_indis: "equiv UNIV indis"

(*******************************************)
context PL_Indis
begin

abbreviation indisAbbrev (infix "\<approx>" 50)
where "s1 \<approx> s2 \<equiv> (s1,s2) \<in> indis"

definition indisE (infix "\<approx>e" 50) where
"se1 \<approx>e se2 \<equiv>
 case (se1,se2) of
   (Inl s1, Inl s2) \<Rightarrow> s1 \<approx> s2
  |(Inr err1, Inr err2) \<Rightarrow> err1 = err2"

lemma refl_indis: "refl indis"
and trans_indis: "trans indis"
and sym_indis: "sym indis"
using equiv_indis unfolding equiv_def by auto

lemma indis_refl[intro]: "s \<approx> s"
using refl_indis unfolding refl_on_def by simp

lemma indis_trans: "\<lbrakk>s \<approx> s'; s' \<approx> s''\<rbrakk> \<Longrightarrow> s \<approx> s''"
using trans_indis unfolding trans_def by blast

lemma indis_sym: "s \<approx> s' \<Longrightarrow> s' \<approx> s"
using sym_indis unfolding sym_def by blast

subsection\<open>Compatibility and discreetness\<close>

definition compatTst where
"compatTst tst \<equiv>
 \<forall> s t. s \<approx> t \<longrightarrow> tval tst s = tval tst t"

definition compatAtm where
"compatAtm atm \<equiv>
 \<forall> s t. s \<approx> t \<longrightarrow> aval atm s \<approx> aval atm t"

(* \<approx>-preservation: *)
definition presAtm where
"presAtm atm \<equiv>
 \<forall> s. s \<approx> aval atm s"

coinductive discr where
intro:
"\<lbrakk>\<And> s c' s'. (c,s) \<rightarrow>c (c',s') \<Longrightarrow> s \<approx> s' \<and> discr c';
  \<And> s s'. (c,s) \<rightarrow>t s' \<Longrightarrow> s \<approx> s'\<rbrakk>
  \<Longrightarrow> discr c"

lemma presAtm_compatAtm[simp]:
assumes "presAtm atm"
shows "compatAtm atm"
using assms unfolding compatAtm_def
by (metis presAtm_def indis_sym indis_trans)

text\<open>Coinduction for discreetness:\<close>

lemma discr_coind:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>phi c; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> s \<approx> s' \<and> (phi c' \<or> discr c')" and
***: "\<And> c s s'. \<lbrakk>phi c; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> s \<approx> s'"
shows "discr c"
using * apply - apply(erule discr.coinduct) using ** *** by auto

lemma discr_raw_coind:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>phi c; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> s \<approx> s' \<and> phi c'" and
***: "\<And> c s s'. \<lbrakk>phi c; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> s \<approx> s'"
shows "discr c"
using * apply - apply(erule discr_coind) using ** *** by blast+

text\<open>Discreetness versus transition:\<close>

lemma discr_transC:
assumes *: "discr c" and **: "(c,s) \<rightarrow>c (c',s')"
shows "discr c'"
using * apply - apply(erule discr.cases) using ** by blast

lemma discr_MtransC:
assumes "discr c" and "(c,s) \<rightarrow>*c (c',s')"
shows "discr c'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> discr c \<longrightarrow> discr c'"
  apply(erule MtransC_induct2) using discr_transC by blast+
  thus ?thesis using assms by blast
qed

lemma discr_transC_indis:
assumes *: "discr c" and **: "(c,s) \<rightarrow>c (c',s')"
shows "s \<approx> s'"
using * apply - apply(erule discr.cases) using ** by blast

lemma discr_MtransC_indis:
assumes "discr c" and "(c,s) \<rightarrow>*c (c',s')"
shows "s \<approx> s'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> discr c \<longrightarrow> s \<approx> s'"
  apply(erule MtransC_induct2)
  apply (metis indis_refl)
  by (metis discr.cases discr_MtransC indis_trans)
  thus ?thesis using assms by blast
qed

lemma discr_transT:
assumes *: "discr c" and **: "(c,s) \<rightarrow>t s'"
shows "s \<approx> s'"
using * apply - apply(erule discr.cases) using ** by blast

lemma discr_MtransT:
assumes *: "discr c" and **: "(c,s) \<rightarrow>*t s'"
shows "s \<approx> s'"
proof-
  obtain d' t' where
  cs: "(c,s) \<rightarrow>*c (d',t')" and d't': "(d',t') \<rightarrow>t s'"
  using ** by(rule MtransT_invert2)
  hence "s \<approx> t'" using * discr_MtransC_indis by blast
  moreover
  {have "discr d'" using cs * discr_MtransC by blast
   hence "t' \<approx> s'" using d't' discr_transT by blast
  }
  ultimately show ?thesis using indis_trans by blast
qed

subsection\<open>Terminating-interctive discreetness\<close>

coinductive discr0 where
intro:
"\<lbrakk>\<And> s c' s'. \<lbrakk>mustT c s; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> s \<approx> s' \<and> discr0 c';
  \<And> s s'. \<lbrakk>mustT c s; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> s \<approx> s'\<rbrakk>
  \<Longrightarrow> discr0 c"

text\<open>Coinduction for 0-discreetness:\<close>

lemma discr0_coind[consumes 1, case_names Cont Term, induct pred: discr0]:
assumes *: "phi c" and
**: "\<And> c s c' s'.
       \<lbrakk>mustT c s; phi c; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow>
       s \<approx> s' \<and> (phi c' \<or> discr0 c')" and
***: "\<And> c s s'. \<lbrakk>mustT c s; phi c; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> s \<approx> s'"
shows "discr0 c"
using * apply - apply(erule discr0.coinduct) using ** *** by auto

lemma discr0_raw_coind[consumes 1, case_names Cont Term]:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>mustT c s; phi c; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> s \<approx> s' \<and> phi c'" and
***: "\<And> c s s'. \<lbrakk>mustT c s; phi c; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> s \<approx> s'"
shows "discr0 c"
using * apply - apply(erule discr0_coind) using ** *** by blast+

text\<open>0-Discreetness versus transition:\<close>

lemma discr0_transC:
assumes *: "discr0 c" and **: "mustT c s" "(c,s) \<rightarrow>c (c',s')"
shows "discr0 c'"
using * apply - apply(erule discr0.cases) using ** by blast

lemma discr0_MtransC:
assumes "discr0 c" and "mustT c s" "(c,s) \<rightarrow>*c (c',s')"
shows "discr0 c'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> mustT c s \<and> discr0 c \<longrightarrow> discr0 c'"
  apply(erule MtransC_induct2) using discr0_transC mustT_MtransC
  by blast+
  thus ?thesis using assms by blast
qed

lemma discr0_transC_indis:
assumes *: "discr0 c" and **: "mustT c s" "(c,s) \<rightarrow>c (c',s')"
shows "s \<approx> s'"
using * apply - apply(erule discr0.cases) using ** by blast

lemma discr0_MtransC_indis:
assumes "discr0 c" and "mustT c s" "(c,s) \<rightarrow>*c (c',s')"
shows "s \<approx> s'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> mustT c s \<and> discr0 c \<longrightarrow> s \<approx> s'"
  apply(erule MtransC_induct2)
  apply (metis indis_refl)
  by (metis discr0_MtransC discr0_transC_indis indis_trans mustT_MtransC)
  thus ?thesis using assms by blast
qed

lemma discr0_transT:
assumes *: "discr0 c" and **: "mustT c s" "(c,s) \<rightarrow>t s'"
shows "s \<approx> s'"
using * apply - apply(erule discr0.cases) using ** by blast

lemma discr0_MtransT:
assumes *: "discr0 c" and ***: "mustT c s" and **: "(c,s) \<rightarrow>*t s'"
shows "s \<approx> s'"
proof-
  obtain d' t' where
  cs: "(c,s) \<rightarrow>*c (d',t')" and d't': "(d',t') \<rightarrow>t s'"
  using ** by(rule MtransT_invert2)
  hence "s \<approx> t'" using * discr0_MtransC_indis *** by blast
  moreover
  {have "discr0 d'" using cs * discr0_MtransC *** by blast
   hence "t' \<approx> s'"
   using *** by (metis mustT_MtransC cs d't' discr0_transT)
  }
  ultimately show ?thesis using indis_trans by blast
qed

lemma discr_discr0[simp]: "discr c \<Longrightarrow> discr0 c"
  by (induct rule: discr0_coind)
     (metis discr_transC discr_transC_indis discr_transT)+

subsection\<open>Self-isomorphism\<close>

coinductive siso where
intro:
"\<lbrakk>\<And> s c' s'. (c,s) \<rightarrow>c (c',s') \<Longrightarrow> siso c';
  \<And> s t c' s'. \<lbrakk>s \<approx> t; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t');
  \<And> s t s'. \<lbrakk>s \<approx> t; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'\<rbrakk>
  \<Longrightarrow> siso c"

text\<open>Coinduction for self-isomorphism:\<close>

lemma siso_coind:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>phi c; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> phi c' \<or> siso c'" and
***: "\<And> c s t c' s'. \<lbrakk>phi c; s \<approx> t; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t')" and
****: "\<And> c s t s'. \<lbrakk>phi c; s \<approx> t; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'"
shows "siso c"
using * apply - apply(erule siso.coinduct) using ** *** **** by auto

lemma siso_raw_coind:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>phi c; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> phi c'" and
***: "\<And> c s t c' s'. \<lbrakk>phi c; s \<approx> t; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t')" and
****: "\<And> c s t s'. \<lbrakk>phi c; s \<approx> t; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow> \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'"
shows "siso c"
using * apply - apply(erule siso_coind) using ** *** **** by blast+

text\<open>Self-Isomorphism versus transition:\<close>

lemma siso_transC:
assumes *: "siso c" and **: "(c,s) \<rightarrow>c (c',s')"
shows "siso c'"
using * apply - apply(erule siso.cases) using ** by blast

lemma siso_MtransC:
assumes "siso c" and "(c,s) \<rightarrow>*c (c',s')"
shows "siso c'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> siso c \<longrightarrow> siso c'"
  apply(erule MtransC_induct2) using siso_transC by blast+
  thus ?thesis using assms by blast
qed

lemma siso_transC_indis:
assumes *: "siso c" and **: "(c,s) \<rightarrow>c (c',s')" and ***: "s \<approx> t"
shows "\<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t')"
using * apply - apply(erule siso.cases) using ** *** by blast

lemma siso_transT:
assumes *: "siso c" and **: "(c,s) \<rightarrow>t s'" and ***: "s \<approx> t"
shows "\<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'"
using * apply - apply(erule siso.cases) using ** *** by blast

subsection\<open>MustT-interactive self-isomorphism\<close>

coinductive siso0 where
intro:
"\<lbrakk>\<And> s c' s'. \<lbrakk>mustT c s; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> siso0 c';
  \<And> s t c' s'.
    \<lbrakk>mustT c s; mustT c t; s \<approx> t; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow>
    \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t');
  \<And> s t s'.
    \<lbrakk>mustT c s; mustT c t; s \<approx> t; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow>
    \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'\<rbrakk>
  \<Longrightarrow> siso0 c"

text\<open>Coinduction for self-isomorphism:\<close>

lemma siso0_coind[consumes 1, case_names Indef Cont Term, induct pred: discr0]:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>phi c; mustT c s; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> phi c' \<or> siso0 c'" and
***: "\<And> c s t c' s'.
        \<lbrakk>phi c; mustT c s; mustT c t; s \<approx> t; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow>
        \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t')" and
****: "\<And> c s t s'.
         \<lbrakk>mustT c s; mustT c t; phi c; s \<approx> t; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow>
         \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'"
shows "siso0 c"
using * apply - apply(erule siso0.coinduct) using ** *** **** by auto

lemma siso0_raw_coind[consumes 1, case_names Indef Cont Term]:
assumes *: "phi c" and
**: "\<And> c s c' s'. \<lbrakk>phi c; mustT c s; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow> phi c'" and
***: "\<And> c s t c' s'.
        \<lbrakk>phi c; mustT c s; mustT c t; s \<approx> t; (c,s) \<rightarrow>c (c',s')\<rbrakk> \<Longrightarrow>
        \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t')" and
****: "\<And> c s t s'.
         \<lbrakk>phi c; mustT c s; mustT c t; s \<approx> t; (c,s) \<rightarrow>t s'\<rbrakk> \<Longrightarrow>
         \<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'"
shows "siso0 c"
using * apply - apply(erule siso0_coind) using ** *** **** by blast+

text\<open>Self-Isomorphism versus transition:\<close>

lemma siso0_transC:
assumes *: "siso0 c" and **: "mustT c s" "(c,s) \<rightarrow>c (c',s')"
shows "siso0 c'"
using * apply - apply(erule siso0.cases) using ** by blast

lemma siso0_MtransC:
assumes "siso0 c" and "mustT c s" and "(c,s) \<rightarrow>*c (c',s')"
shows "siso0 c'"
proof-
  have "(c,s) \<rightarrow>*c (c',s') \<Longrightarrow> mustT c s \<and> siso0 c \<longrightarrow> siso0 c'"
  apply(erule MtransC_induct2) using siso0_transC mustT_MtransC siso0_transC
  by blast+
  thus ?thesis using assms by blast
qed

lemma siso0_transC_indis:
assumes *: "siso0 c"
and **: "mustT c s" "mustT c t" "(c,s) \<rightarrow>c (c',s')"
and ***: "s \<approx> t"
shows "\<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>c (c',t')"
using * apply - apply(erule siso0.cases) using ** *** by blast

lemma siso0_transT:
assumes *: "siso0 c"
and **: "mustT c s" "mustT c t" "(c,s) \<rightarrow>t s'"
and ***: "s \<approx> t"
shows "\<exists> t'. s' \<approx> t' \<and> (c,t) \<rightarrow>t t'"
using * apply - apply(erule siso0.cases) using ** *** by blast

subsection\<open>Notions of bisimilarity\<close>

text\<open>Matchers:\<close>

(* Notations and conventions:
\\- ``<u>_<v>" means: ``match u by v", where u, v can be:
C (one continuation step), MC (multiple continuation steps),
ZOC (zero or one continuation steps),
T (termination step), MT (multiple steps leading to termination).   *)

definition matchC_C where
"matchC_C theta c d \<equiv>
 \<forall> s t c' s'.
   s \<approx> t \<and> (c,s) \<rightarrow>c (c',s')
   \<longrightarrow>
   (\<exists> d' t'. (d,t) \<rightarrow>c (d',t') \<and> s' \<approx> t' \<and> (c',d') \<in> theta)"

definition matchC_ZOC where
"matchC_ZOC theta c d \<equiv>
 \<forall> s t c' s'.
   s \<approx> t \<and> (c,s) \<rightarrow>c (c',s')
   \<longrightarrow>
   (s' \<approx> t \<and> (c',d) \<in> theta)
   \<or>
   (\<exists> d' t'. (d,t) \<rightarrow>c (d',t') \<and> s' \<approx> t' \<and> (c',d') \<in> theta)"

definition matchC_ZO where
"matchC_ZO theta c d \<equiv>
 \<forall> s t c' s'.
   s \<approx> t \<and> (c,s) \<rightarrow>c (c',s')
   \<longrightarrow>
   (s' \<approx> t \<and> (c',d) \<in> theta)
   \<or>
   (\<exists> d' t'. (d,t) \<rightarrow>c (d',t') \<and> s' \<approx> t' \<and> (c',d') \<in> theta)
   \<or>
   (\<exists> t'. (d,t) \<rightarrow>t t' \<and> s' \<approx> t' \<and> discr c')"

definition matchT_T where
"matchT_T c d \<equiv>
 \<forall> s t s'.
   s \<approx> t \<and> (c,s) \<rightarrow>t s'
   \<longrightarrow>
   (\<exists> t'. (d,t) \<rightarrow>t t' \<and> s' \<approx> t')"

definition matchT_ZO where
"matchT_ZO c d \<equiv>
 \<forall> s t s'.
   s \<approx> t \<and> (c,s) \<rightarrow>t s'
   \<longrightarrow>
   (s' \<approx> t \<and> discr d)
   \<or>
   (\<exists> d' t'. (d,t) \<rightarrow>c (d',t') \<and> s' \<approx> t' \<and> discr d')
   \<or>
   (\<exists> t'. (d,t) \<rightarrow>t t' \<and> s' \<approx> t')"

(*  *)

definition matchC_MC where
"matchC_MC theta c d \<equiv>
 \<forall> s t c' s'.
   s \<approx> t \<and> (c,s) \<rightarrow>c (c',s')
   \<longrightarrow>
   (\<exists> d' t'. (d,t) \<rightarrow>*c (d',t') \<and> s' \<approx> t' \<and> (c',d') \<in> theta)"

definition matchC_TMC where
"matchC_TMC theta c d \<equiv>
 \<forall> s t c' s'.
   mustT c s \<and> mustT d t \<and> s \<approx> t \<and> (c,s) \<rightarrow>c (c',s')
   \<longrightarrow>
   (\<exists> d' t'. (d,t) \<rightarrow>*c (d',t') \<and> s' \<approx> t' \<and> (c',d') \<in> theta)"

definition matchC_M where
"matchC_M theta c d \<equiv>
 \<forall> s t c' s'.
   s \<approx> t \<and> (c,s) \<rightarrow>c (c',s')
   \<longrightarrow>
   (\<exists> d' t'. (d,t) \<rightarrow>*c (d',t') \<and> s' \<approx> t' \<and> (c',d') \<in> theta)
   \<or>
   (\<exists> t'. (d,t) \<rightarrow>*t t' \<and> s' \<approx> t' \<and> discr c')"

definition matchT_MT where
"matchT_MT c d \<equiv>
 \<forall> s t s'.
   s \<approx> t \<and> (c,s) \<rightarrow>t s'
   \<longrightarrow>
   (\<exists> t'. (d,t) \<rightarrow>*t t' \<and> s' \<approx> t')"

definition matchT_TMT where
"matchT_TMT c d \<equiv>
 \<forall> s t s'.
   mustT c s \<and> mustT d t \<and> s \<approx> t \<and> (c,s) \<rightarrow>t s'
   \<longrightarrow>
   (\<exists> t'. (d,t) \<rightarrow>*t t' \<and> s' \<approx> t')"

definition matchT_M where
"matchT_M c d \<equiv>
 \<forall> s t s'.
   s \<approx> t \<and> (c,s) \<rightarrow>t s'
   \<longrightarrow>
   (\<exists> d' t'. (d,t) \<rightarrow>*c (d',t') \<and> s' \<approx> t' \<and> discr d')
   \<or>
   (\<exists> t'. (d,t) \<rightarrow>*t t' \<and> s' \<approx> t')"

lemmas match_defs =
matchC_C_def
matchC_ZOC_def matchC_ZO_def
matchT_T_def matchT_ZO_def
matchC_MC_def matchC_M_def
matchT_MT_def matchT_M_def
matchC_TMC_def matchT_TMT_def

(* For convenience, indis-symmetric variations of the above definitions: *)

lemma matchC_C_def2:
"matchC_C theta d c =
 (\<forall> s t d' t'.
   s \<approx> t \<and> (d,t) \<rightarrow>c (d',t')
   \<longrightarrow>
   (\<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> s' \<approx> t' \<and> (d',c') \<in> theta))"
unfolding matchC_C_def using indis_sym by blast

lemma matchC_ZOC_def2:
"matchC_ZOC theta d c=
 (\<forall> s t d' t'.
   s \<approx> t \<and> (d,t) \<rightarrow>c (d',t')
   \<longrightarrow>
   (s \<approx> t' \<and> (d',c) \<in> theta)
   \<or>
   (\<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> s' \<approx> t' \<and> (d',c') \<in> theta))"
unfolding matchC_ZOC_def using indis_sym by blast

lemma matchC_ZO_def2:
"matchC_ZO theta d c =
 (\<forall> s t d' t'.
   s \<approx> t \<and> (d,t) \<rightarrow>c (d',t')
   \<longrightarrow>
   (s \<approx> t' \<and> (d',c) \<in> theta)
   \<or>
   (\<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> s' \<approx> t' \<and> (d',c') \<in> theta)
   \<or>
   (\<exists> s'. (c,s) \<rightarrow>t s' \<and> s' \<approx> t' \<and> discr d'))"
unfolding matchC_ZO_def using indis_sym by blast

lemma matchT_T_def2:
"matchT_T d c =
 (\<forall> s t t'.
   s \<approx> t \<and> (d,t) \<rightarrow>t t'
   \<longrightarrow>
   (\<exists> s'. (c,s) \<rightarrow>t s' \<and> s' \<approx> t'))"
unfolding matchT_T_def using indis_sym by blast

lemma matchT_ZO_def2:
"matchT_ZO d c =
 (\<forall> s t t'.
   s \<approx> t \<and> (d,t) \<rightarrow>t t'
   \<longrightarrow>
   (s \<approx> t' \<and> discr c)
   \<or>
   (\<exists> c' s'. (c,s) \<rightarrow>c (c',s') \<and> s' \<approx> t' \<and> discr c')
   \<or>
   (\<exists> s'. (c,s) \<rightarrow>t s' \<and> s' \<approx> t'))"
unfolding matchT_ZO_def using indis_sym by blast

(*  *)

lemma matchC_MC_def2:
"matchC_MC theta d c=
 (\<forall> s t d' t'.
   s \<approx> t \<and> (d,t) \<rightarrow>c (d',t')
   \<longrightarrow>
   (\<exists> c' s'. (c,s) \<rightarrow>*c (c',s') \<and> s' \<approx> t' \<and> (d',c') \<in> theta))"
unfolding matchC_MC_def using indis_sym by blast

lemma matchC_TMC_def2:
"matchC_TMC theta d c=
 (\<forall> s t d' t'.
   mustT c s \<and> mustT d t \<and> s \<approx> t \<and> (d,t) \<rightarrow>c (d',t')
   \<longrightarrow>
   (\<exists> c' s'. (c,s) \<rightarrow>*c (c',s') \<and> s' \<approx> t' \<and> (d',c') \<in> theta))"
unfolding matchC_TMC_def using indis_sym by blast

lemma matchC_M_def2:
"matchC_M theta d c =
 (\<forall> s t d' t'.
   s \<approx> t \<and> (d,t) \<rightarrow>c (d',t')
   \<longrightarrow>
   (\<exists> c' s'. (c,s) \<rightarrow>*c (c',s') \<and> s' \<approx> t' \<and> (d',c') \<in> theta)
   \<or>
   (\<exists> s'. (c,s) \<rightarrow>*t s' \<and> s' \<approx> t' \<and> discr d'))"
unfolding matchC_M_def using indis_sym by blast

lemma matchT_MT_def2:
"matchT_MT d c =
 (\<forall> s t t'.
   s \<approx> t \<and> (d,t) \<rightarrow>t t'
   \<longrightarrow>
   (\<exists> s'. (c,s) \<rightarrow>*t s' \<and> s' \<approx> t'))"
unfolding matchT_MT_def using indis_sym by blast

lemma matchT_TMT_def2:
"matchT_TMT d c =
 (\<forall> s t t'.
   mustT c s \<and> mustT d t \<and> s \<approx> t \<and> (d,t) \<rightarrow>t t'
   \<longrightarrow>
   (\<exists> s'. (c,s) \<rightarrow>*t s' \<and> s' \<approx> t'))"
unfolding matchT_TMT_def using indis_sym by blast

lemma matchT_M_def2:
"matchT_M d c =
 (\<forall> s t t'.
   s \<approx> t \<and> (d,t) \<rightarrow>t t'
   \<longrightarrow>
   (\<exists> c' s'. (c,s) \<rightarrow>*c (c',s') \<and> s' \<approx> t' \<and> discr c')
   \<or>
   (\<exists> s'. (c,s) \<rightarrow>*t s' \<and> s' \<approx> t'))"
unfolding matchT_M_def using indis_sym by blast

text\<open>Retracts:\<close>

(* Strong retract: *)
definition Sretr where
"Sretr theta \<equiv>
 {(c,d).
    matchC_C theta c d \<and>
    matchT_T c d}"

(* Zero-one retract: *)
definition ZOretr where
"ZOretr theta \<equiv>
 {(c,d).
    matchC_ZO theta c d \<and>
    matchT_ZO c d}"

(* Zero-one termination-sensitive retract: *)
definition ZOretrT where
"ZOretrT theta \<equiv>
 {(c,d).
    matchC_ZOC theta c d \<and>
    matchT_T c d}"

(* Weak retract: *)
definition Wretr where
"Wretr theta \<equiv>
 {(c,d).
    matchC_M theta c d \<and>
    matchT_M c d }"

(* Weak termination-sensitive retract: *)
definition WretrT where
"WretrT theta \<equiv>
 {(c,d).
    matchC_MC theta c d \<and>
    matchT_MT c d}"

(* Weak terminating-interactive termination-sensitive retract: *)
definition RetrT where
"RetrT theta \<equiv>
 {(c,d).
    matchC_TMC theta c d \<and>
    matchT_TMT c d}"

lemmas Retr_defs =
Sretr_def
ZOretr_def ZOretrT_def
Wretr_def WretrT_def
RetrT_def

text\<open>The associated bisimilarity relations:\<close>

definition Sbis where "Sbis \<equiv> bis Sretr"
definition ZObis where "ZObis \<equiv> bis ZOretr"
definition ZObisT where "ZObisT \<equiv> bis ZOretrT"
definition Wbis where "Wbis \<equiv> bis Wretr"
definition WbisT where "WbisT \<equiv> bis WretrT"
definition BisT where "BisT \<equiv> bis RetrT"

lemmas bis_defs =
Sbis_def
ZObis_def ZObisT_def
Wbis_def WbisT_def
BisT_def

abbreviation Sbis_abbrev (infix "\<approx>s" 55) where "c1 \<approx>s c2 \<equiv> (c1,c2) \<in> Sbis"
abbreviation ZObis_abbrev (infix "\<approx>01" 55) where "c1 \<approx>01 c2 \<equiv> (c1,c2) \<in> ZObis"
abbreviation ZObisT_abbrev (infix "\<approx>01T" 55) where "c1 \<approx>01T c2 \<equiv> (c1,c2) \<in> ZObisT"
abbreviation Wbis_abbrev (infix "\<approx>w" 55) where "c1 \<approx>w c2 \<equiv> (c1,c2) \<in> Wbis"
abbreviation WbisT_abbrev (infix "\<approx>wT" 55) where "c1 \<approx>wT c2 \<equiv> (c1,c2) \<in> WbisT"
abbreviation BisT_abbrev (infix "\<approx>T" 55) where "c1 \<approx>T c2 \<equiv> (c1,c2) \<in> BisT"

lemma mono_Retr:
"mono Sretr"
"mono ZOretr"  "mono ZOretrT"
"mono Wretr"  "mono WretrT"
"mono RetrT"
unfolding mono_def Retr_defs match_defs by blast+

(* Sbis: *)
lemma Sbis_prefix:
"Sbis \<subseteq> Sretr Sbis"
unfolding Sbis_def using mono_Retr bis_prefix by blast

lemma Sbis_sym: "sym Sbis"
unfolding Sbis_def using mono_Retr sym_bis by blast

lemma Sbis_Sym: "c \<approx>s d \<Longrightarrow> d \<approx>s c"
using Sbis_sym unfolding sym_def by blast

lemma Sbis_converse:
"((c,d) \<in> theta^-1 \<union> Sbis) = ((d,c) \<in> theta \<union> Sbis)"
by (metis Sbis_sym converseI converse_Un converse_converse sym_conv_converse_eq)

lemma
Sbis_matchC_C: "\<And> s t. c \<approx>s d \<Longrightarrow> matchC_C Sbis c d"
and
Sbis_matchT_T: "\<And> c d. c \<approx>s d \<Longrightarrow> matchT_T c d"
using Sbis_prefix unfolding Sretr_def by auto

lemmas Sbis_step = Sbis_matchC_C Sbis_matchT_T

lemma
Sbis_matchC_C_rev: "\<And> s t. s \<approx>s t \<Longrightarrow> matchC_C Sbis t s"
and
Sbis_matchT_T_rev: "\<And> s t. s \<approx>s t \<Longrightarrow> matchT_T t s"
using Sbis_step Sbis_sym unfolding sym_def by blast+

lemmas Sbis_step_rev = Sbis_matchC_C_rev Sbis_matchT_T_rev

lemma Sbis_coind:
assumes "sym theta" and "theta \<subseteq> Sretr (theta \<union> Sbis)"
shows "theta \<subseteq> Sbis"
using assms mono_Retr bis_coind
unfolding Sbis_def by blast

lemma Sbis_raw_coind:
assumes "sym theta" and "theta \<subseteq> Sretr theta"
shows "theta \<subseteq> Sbis"
using assms mono_Retr bis_raw_coind
unfolding Sbis_def by blast

lemma Sbis_coind2:
assumes "theta \<subseteq> Sretr (theta \<union> Sbis)" and
"theta ^-1 \<subseteq> Sretr ((theta ^-1) \<union> Sbis)"
shows "theta \<subseteq> Sbis"
using assms mono_Retr bis_coind2
unfolding Sbis_def by blast

lemma Sbis_raw_coind2:
assumes "theta \<subseteq> Sretr theta" and
"theta ^-1 \<subseteq> Sretr (theta ^-1)"
shows "theta \<subseteq> Sbis"
using assms mono_Retr bis_raw_coind2
unfolding Sbis_def by blast

(* ZObis: *)
lemma ZObis_prefix:
"ZObis \<subseteq> ZOretr ZObis"
unfolding ZObis_def using mono_Retr bis_prefix by blast

lemma ZObis_sym: "sym ZObis"
unfolding ZObis_def using mono_Retr sym_bis by blast

lemma ZObis_converse:
"((c,d) \<in> theta^-1 \<union> ZObis) = ((d,c) \<in> theta \<union> ZObis)"
by (metis ZObis_sym converseI converse_Un converse_converse sym_conv_converse_eq)

lemma ZObis_Sym: "s \<approx>01 t \<Longrightarrow> t \<approx>01 s"
using ZObis_sym unfolding sym_def by blast

lemma
ZObis_matchC_ZO: "\<And> s t. s \<approx>01 t \<Longrightarrow> matchC_ZO ZObis s t"
and
ZObis_matchT_ZO: "\<And> s t. s \<approx>01 t \<Longrightarrow> matchT_ZO s t"
using ZObis_prefix unfolding ZOretr_def by auto

lemmas ZObis_step = ZObis_matchC_ZO ZObis_matchT_ZO

lemma
ZObis_matchC_ZO_rev: "\<And> s t. s \<approx>01 t \<Longrightarrow> matchC_ZO ZObis t s"
and
ZObis_matchT_ZO_rev: "\<And> s t. s \<approx>01 t \<Longrightarrow> matchT_ZO t s"
using ZObis_step ZObis_sym unfolding sym_def by blast+

lemmas ZObis_step_rev = ZObis_matchC_ZO_rev ZObis_matchT_ZO_rev

lemma ZObis_coind:
assumes "sym theta" and "theta \<subseteq> ZOretr (theta \<union> ZObis)"
shows "theta \<subseteq> ZObis"
using assms mono_Retr bis_coind
unfolding ZObis_def by blast

lemma ZObis_raw_coind:
assumes "sym theta" and "theta \<subseteq> ZOretr theta"
shows "theta \<subseteq> ZObis"
using assms mono_Retr bis_raw_coind
unfolding ZObis_def by blast

lemma ZObis_coind2:
assumes "theta \<subseteq> ZOretr (theta \<union> ZObis)" and
"theta ^-1 \<subseteq> ZOretr ((theta ^-1) \<union> ZObis)"
shows "theta \<subseteq> ZObis"
using assms mono_Retr bis_coind2
unfolding ZObis_def by blast

lemma ZObis_raw_coind2:
assumes "theta \<subseteq> ZOretr theta" and
"theta ^-1 \<subseteq> ZOretr (theta ^-1)"
shows "theta \<subseteq> ZObis"
using assms mono_Retr bis_raw_coind2
unfolding ZObis_def by blast

(* ZObisT: *)
lemma ZObisT_prefix:
"ZObisT \<subseteq> ZOretrT ZObisT"
unfolding ZObisT_def using mono_Retr bis_prefix by blast

lemma ZObisT_sym: "sym ZObisT"
unfolding ZObisT_def using mono_Retr sym_bis by blast

lemma ZObisT_Sym: "s \<approx>01T t \<Longrightarrow> t \<approx>01T s"
using ZObisT_sym unfolding sym_def by blast

lemma ZObisT_converse:
"((c,d) \<in> theta^-1 \<union> ZObisT) = ((d,c) \<in> theta \<union> ZObisT)"
by (metis ZObisT_sym converseI converse_Un converse_converse sym_conv_converse_eq)

lemma
ZObisT_matchC_ZOC: "\<And> s t. s \<approx>01T t \<Longrightarrow> matchC_ZOC ZObisT s t"
and
ZObisT_matchT_T: "\<And> s t. s \<approx>01T t \<Longrightarrow> matchT_T s t"
using ZObisT_prefix unfolding ZOretrT_def by auto

lemmas ZObisT_step = ZObisT_matchC_ZOC ZObisT_matchT_T

lemma
ZObisT_matchC_ZOC_rev: "\<And> s t. s \<approx>01T t \<Longrightarrow> matchC_ZOC ZObisT t s"
and
ZObisT_matchT_T_rev: "\<And> s t. s \<approx>01T t \<Longrightarrow> matchT_T t s"
using ZObisT_step ZObisT_sym unfolding sym_def by blast+

lemmas ZObisT_step_rev = ZObisT_matchC_ZOC_rev ZObisT_matchT_T_rev

lemma ZObisT_coind:
assumes "sym theta" and "theta \<subseteq> ZOretrT (theta \<union> ZObisT)"
shows "theta \<subseteq> ZObisT"
using assms mono_Retr bis_coind
unfolding ZObisT_def by blast

lemma ZObisT_raw_coind:
assumes "sym theta" and "theta \<subseteq> ZOretrT theta"
shows "theta \<subseteq> ZObisT"
using assms mono_Retr bis_raw_coind
unfolding ZObisT_def by blast

lemma ZObisT_coind2:
assumes "theta \<subseteq> ZOretrT (theta \<union> ZObisT)" and
"theta ^-1 \<subseteq> ZOretrT ((theta ^-1) \<union> ZObisT)"
shows "theta \<subseteq> ZObisT"
using assms mono_Retr bis_coind2
unfolding ZObisT_def by blast

lemma ZObisT_raw_coind2:
assumes "theta \<subseteq> ZOretrT theta" and
"theta ^-1 \<subseteq> ZOretrT (theta ^-1)"
shows "theta \<subseteq> ZObisT"
using assms mono_Retr bis_raw_coind2
unfolding ZObisT_def by blast

(* Wbis: *)
lemma Wbis_prefix:
"Wbis \<subseteq> Wretr Wbis"
unfolding Wbis_def using mono_Retr bis_prefix by blast

lemma Wbis_sym: "sym Wbis"
unfolding Wbis_def using mono_Retr sym_bis by blast

lemma Wbis_converse:
"((c,d) \<in> theta^-1 \<union> Wbis) = ((d,c) \<in> theta \<union> Wbis)"
by (metis Wbis_sym converseI converse_Un converse_converse sym_conv_converse_eq)

lemma Wbis_Sym: "c \<approx>w d \<Longrightarrow> d \<approx>w c"
using Wbis_sym unfolding sym_def by blast

lemma
Wbis_matchC_M: "\<And> c d. c \<approx>w d \<Longrightarrow> matchC_M Wbis c d"
and
Wbis_matchT_M: "\<And> c d. c \<approx>w d \<Longrightarrow> matchT_M c d"
using Wbis_prefix unfolding Wretr_def by auto

lemmas Wbis_step = Wbis_matchC_M Wbis_matchT_M

lemma
Wbis_matchC_M_rev: "\<And> s t. s \<approx>w t \<Longrightarrow> matchC_M Wbis t s"
and
Wbis_matchT_M_rev: "\<And> s t. s \<approx>w t \<Longrightarrow> matchT_M t s"
using Wbis_step Wbis_sym unfolding sym_def by blast+

lemmas Wbis_step_rev = Wbis_matchC_M_rev Wbis_matchT_M_rev

lemma Wbis_coind:
assumes "sym theta" and "theta \<subseteq> Wretr (theta \<union> Wbis)"
shows "theta \<subseteq> Wbis"
using assms mono_Retr bis_coind
unfolding Wbis_def by blast

lemma Wbis_raw_coind:
assumes "sym theta" and "theta \<subseteq> Wretr theta"
shows "theta \<subseteq> Wbis"
using assms mono_Retr bis_raw_coind
unfolding Wbis_def by blast

lemma Wbis_coind2:
assumes "theta \<subseteq> Wretr (theta \<union> Wbis)" and
"theta ^-1 \<subseteq> Wretr ((theta ^-1) \<union> Wbis)"
shows "theta \<subseteq> Wbis"
using assms mono_Retr bis_coind2
unfolding Wbis_def by blast

lemma Wbis_raw_coind2:
assumes "theta \<subseteq> Wretr theta" and
"theta ^-1 \<subseteq> Wretr (theta ^-1)"
shows "theta \<subseteq> Wbis"
using assms mono_Retr bis_raw_coind2
unfolding Wbis_def by blast

(* WbisT: *)
lemma WbisT_prefix:
"WbisT \<subseteq> WretrT WbisT"
unfolding WbisT_def using mono_Retr bis_prefix by blast

lemma WbisT_sym: "sym WbisT"
unfolding WbisT_def using mono_Retr sym_bis by blast

lemma WbisT_Sym: "c \<approx>wT d \<Longrightarrow> d \<approx>wT c"
using WbisT_sym unfolding sym_def by blast

lemma WbisT_converse:
"((c,d) \<in> theta^-1 \<union> WbisT) = ((d,c) \<in> theta \<union> WbisT)"
by (metis WbisT_sym converseI converse_Un converse_converse sym_conv_converse_eq)

lemma
WbisT_matchC_MC: "\<And> c d. c \<approx>wT d \<Longrightarrow> matchC_MC WbisT c d"
and
WbisT_matchT_MT: "\<And> c d. c \<approx>wT d \<Longrightarrow> matchT_MT c d"
using WbisT_prefix unfolding WretrT_def by auto

lemmas WbisT_step = WbisT_matchC_MC WbisT_matchT_MT

lemma
WbisT_matchC_MC_rev: "\<And> s t. s \<approx>wT t \<Longrightarrow> matchC_MC WbisT t s"
and
WbisT_matchT_MT_rev: "\<And> s t. s \<approx>wT t \<Longrightarrow> matchT_MT t s"
using WbisT_step WbisT_sym unfolding sym_def by blast+

lemmas WbisT_step_rev = WbisT_matchC_MC_rev WbisT_matchT_MT_rev

lemma WbisT_coind:
assumes "sym theta" and "theta \<subseteq> WretrT (theta \<union> WbisT)"
shows "theta \<subseteq> WbisT"
using assms mono_Retr bis_coind
unfolding WbisT_def by blast

lemma WbisT_raw_coind:
assumes "sym theta" and "theta \<subseteq> WretrT theta"
shows "theta \<subseteq> WbisT"
using assms mono_Retr bis_raw_coind
unfolding WbisT_def by blast

lemma WbisT_coind2:
assumes "theta \<subseteq> WretrT (theta \<union> WbisT)" and
"theta ^-1 \<subseteq> WretrT ((theta ^-1) \<union> WbisT)"
shows "theta \<subseteq> WbisT"
using assms mono_Retr bis_coind2
unfolding WbisT_def by blast

lemma WbisT_raw_coind2:
assumes "theta \<subseteq> WretrT theta" and
"theta ^-1 \<subseteq> WretrT (theta ^-1)"
shows "theta \<subseteq> WbisT"
using assms mono_Retr bis_raw_coind2
unfolding WbisT_def by blast

lemma WbisT_coinduct[consumes 1, case_names sym cont termi]:
  assumes \<phi>: "\<phi> c d"
  assumes S: "\<And>c d. \<phi> c d \<Longrightarrow> \<phi> d c"
  assumes C: "\<And>c s d t c' s'.
    \<lbrakk> \<phi> c d ; s \<approx> t ; (c, s) \<rightarrow>c (c', s') \<rbrakk> \<Longrightarrow> \<exists>d' t'. (d, t) \<rightarrow>*c (d', t') \<and> s' \<approx> t' \<and> (\<phi> c' d' \<or> c' \<approx>wT d')"
  assumes T: "\<And>c s d t s'.
    \<lbrakk> \<phi> c d ; s \<approx> t ; (c, s) \<rightarrow>t s' \<rbrakk> \<Longrightarrow> \<exists>t'. (d, t) \<rightarrow>*t t' \<and> s' \<approx> t'"
  shows "c \<approx>wT d"
proof -
  let ?\<theta> = "{(c, d). \<phi> c d}"
  have "sym ?\<theta>" by (auto intro!: symI S)
  moreover
  have "?\<theta> \<subseteq> WretrT (?\<theta> \<union> WbisT)"
    using C T by (auto simp: WretrT_def matchC_MC_def matchT_MT_def)
  ultimately have "?\<theta> \<subseteq> WbisT"
    using WbisT_coind by auto
  with \<phi> show ?thesis
    by auto
qed

(* BisT: *)
lemma BisT_prefix:
"BisT \<subseteq> RetrT BisT"
unfolding BisT_def using mono_Retr bis_prefix by blast

lemma BisT_sym: "sym BisT"
unfolding BisT_def using mono_Retr sym_bis by blast

lemma BisT_Sym: "c \<approx>T d \<Longrightarrow> d \<approx>T c"
using BisT_sym unfolding sym_def by blast

lemma BisT_converse:
"((c,d) \<in> theta^-1 \<union> BisT) = ((d,c) \<in> theta \<union> BisT)"
by (metis BisT_sym converseI converse_Un converse_converse sym_conv_converse_eq)

lemma
BisT_matchC_TMC: "\<And> c d. c \<approx>T d \<Longrightarrow> matchC_TMC BisT c d"
and
BisT_matchT_TMT: "\<And> c d. c \<approx>T d \<Longrightarrow> matchT_TMT c d"
using BisT_prefix unfolding RetrT_def by auto

lemmas BisT_step = BisT_matchC_TMC BisT_matchT_TMT

lemma
BisT_matchC_TMC_rev: "\<And> c d. c \<approx>T d \<Longrightarrow> matchC_TMC BisT d c"
and
BisT_matchT_TMT_rev: "\<And> c d. c \<approx>T d \<Longrightarrow> matchT_TMT d c"
using BisT_step BisT_sym unfolding sym_def by blast+

lemmas BisT_step_rev = BisT_matchC_TMC_rev BisT_matchT_TMT_rev

lemma BisT_coind:
assumes "sym theta" and "theta \<subseteq> RetrT (theta \<union> BisT)"
shows "theta \<subseteq> BisT"
using assms mono_Retr bis_coind
unfolding BisT_def by blast

lemma BisT_raw_coind:
assumes "sym theta" and "theta \<subseteq> RetrT theta"
shows "theta \<subseteq> BisT"
using assms mono_Retr bis_raw_coind
unfolding BisT_def by blast

lemma BisT_coind2:
assumes "theta \<subseteq> RetrT (theta \<union> BisT)" and
"theta ^-1 \<subseteq> RetrT ((theta ^-1) \<union> BisT)"
shows "theta \<subseteq> BisT"
using assms mono_Retr bis_coind2
unfolding BisT_def by blast

lemma BisT_raw_coind2:
assumes "theta \<subseteq> RetrT theta" and
"theta ^-1 \<subseteq> RetrT (theta ^-1)"
shows "theta \<subseteq> BisT"
using assms mono_Retr bis_raw_coind2
unfolding BisT_def by blast

text\<open>Inclusions between bisimilarities:\<close>

lemma match_imp[simp]:
"\<And> theta c1 c2. matchC_C theta c1 c2 \<Longrightarrow> matchC_ZOC theta c1 c2"
(*  *)
"\<And> theta c1 c2. matchC_ZOC theta c1 c2 \<Longrightarrow> matchC_ZO theta c1 c2"
(*  *)
"\<And> theta c1 c2. matchC_ZOC theta c1 c2 \<Longrightarrow> matchC_MC theta c1 c2"
(*  *)
"\<And> theta c1 c2. matchC_ZO theta c1 c2 \<Longrightarrow> matchC_M theta c1 c2"
(*  *)
"\<And> theta c1 c2. matchC_MC theta c1 c2 \<Longrightarrow> matchC_M theta c1 c2"
(*  *)
(*  *)
"\<And> c1 c2. matchT_T c1 c2 \<Longrightarrow> matchT_ZO c1 c2"
(*  *)
"\<And> c1 c2. matchT_T c1 c2 \<Longrightarrow> matchT_MT c1 c2"
(*  *)
"\<And> c1 c2. matchT_ZO c1 c2 \<Longrightarrow> matchT_M c1 c2"
(*  *)
"\<And> c1 c2. matchT_MT c1 c2 \<Longrightarrow> matchT_M c1 c2"
(*  *)
"\<And> theta c1 c2. matchC_MC theta c1 c2 \<Longrightarrow> matchC_TMC theta c1 c2"
(*  *)
"\<And> theta c1 c2. matchT_MT c1 c2 \<Longrightarrow> matchT_TMT c1 c2"
unfolding match_defs apply(tactic \<open>mauto_no_simp_tac @{context}\<close>)
apply fastforce apply fastforce
apply (metis MtransC_Refl transC_MtransC)
by force+

lemma Retr_incl:
"\<And>theta. Sretr theta \<subseteq> ZOretrT theta"
(*  *)
"\<And>theta. ZOretrT theta \<subseteq> ZOretr theta"
(*  *)
"\<And>theta. ZOretrT theta \<subseteq> WretrT theta"
(*  *)
"\<And>theta. ZOretr theta \<subseteq> Wretr theta"
(*  *)
"\<And>theta. WretrT theta \<subseteq> Wretr theta"
(*  *)
"\<And>theta. WretrT theta \<subseteq> RetrT theta"
unfolding Retr_defs by auto

lemma bis_incl:
"Sbis \<subseteq> ZObisT"
(*  *)
"ZObisT \<subseteq> ZObis"
(*  *)
"ZObisT \<subseteq> WbisT"
(*  *)
"ZObis \<subseteq> Wbis"
(*  *)
"WbisT \<subseteq> Wbis"
(*  *)
"WbisT \<subseteq> BisT"
unfolding bis_defs
using Retr_incl mono_bis mono_Retr by blast+

lemma bis_imp[simp]:
"\<And> c1 c2. c1 \<approx>s c2 \<Longrightarrow> c1 \<approx>01T c2"
(*  *)
"\<And> c1 c2. c1 \<approx>01T c2 \<Longrightarrow> c1 \<approx>01 c2"
(*  *)
"\<And> c1 c2. c1 \<approx>01T c2 \<Longrightarrow> c1 \<approx>wT c2"
(*  *)
"\<And> c1 c2. c1 \<approx>01 c2 \<Longrightarrow> c1 \<approx>w c2"
(*  *)
"\<And> c1 c2. c1 \<approx>wT c2 \<Longrightarrow> c1 \<approx>w c2"
(*  *)
"\<And> c1 c2. c1 \<approx>wT c2 \<Longrightarrow> c1 \<approx>T c2"
using bis_incl rev_subsetD by auto

text\<open>Self-isomorphism implies strong bisimilarity:\<close>

text\<open>0-Self-isomorphism implies weak T 0-bisimilarity:\<close>

lemma siso0_Sbis[simp]:
assumes "siso0 c"
shows "c \<approx>T c"
proof-
  let ?theta = "{(c,c) | c . siso0 c}"
  have "?theta \<subseteq> BisT"
  proof(rule BisT_raw_coind)
    show "sym ?theta" unfolding sym_def by blast
  next
    show "?theta \<subseteq> RetrT ?theta"
    proof clarify
      fix c assume c: "siso0 c"
      show "(c, c) \<in> RetrT ?theta"
      unfolding RetrT_def proof (clarify, intro conjI)
        show "matchC_TMC ?theta c c"
        unfolding matchC_TMC_def apply simp
        by (metis c siso0_transC siso0_transC_indis transC_MtransC)
      next
        show "matchT_TMT c c"
        unfolding matchC_TMC_def
        by (metis c matchT_TMT_def siso0_transT transT_MtransT)
      qed
    qed
  qed
  thus ?thesis using assms by blast
qed

end
(* context PL_Indis *)

end


section "Invariants for Promela data structures"
theory PromelaInvariants
imports PromelaDatastructures
begin

text \<open>
  The different data structures used in the Promela implementation require different invariants,
  which are specified in this file. As there is no (useful) way of specifying \emph{correctness} of the implementation,
those invariants are tailored towards proving the finitness of the generated state-space.
\<close>

(*<*)
(*subsection {* Auxiliary lemmas *}*)
lemma foldli_set:
  "set (foldli list (\<lambda>_. True) (#) xs) = set xs \<union> set list"
  by (induct list arbitrary: xs) simp_all

lemma foldli_conj:
  "foldli list id (\<lambda>kv \<sigma>. P kv) b \<longleftrightarrow> b \<and> (\<forall>x \<in> set list. P x)"
  by (induct list arbitrary: b) simp_all

(* Destroy the evil border of abstraction... *)
lemma lm_ball_Assoc_List_set:
  "lm.ball m P \<longleftrightarrow> (\<forall>x \<in> Assoc_List.set m. P x)"
  unfolding Assoc_List.set_def
  by (simp add: icf_rec_unf lm_basic.g_ball_def
    poly_map_iteratei_defs.iteratei_def it_to_it_def Assoc_List.iteratei_def
    foldli_conj)

lemma lm_to_list_Assoc_List_set:
  "set (lm.to_list l) = Assoc_List.set l"
  unfolding Assoc_List.set_def
  by (simp add: icf_rec_unf lm_basic.g_to_list_def
    poly_map_iteratei_defs.iteratei_def it_to_it_def Assoc_List.iteratei_def
    foldli_set)

lemma dom_lm_\<alpha>_Assoc_List_set:
  "dom (lm.\<alpha> v) = fst ` (Assoc_List.set v)"
  by (simp add: icf_rec_unf Assoc_List.lookup_def Assoc_List.set_def
    dom_map_of_conv_image_fst)

lemma ran_lm_\<alpha>_Assoc_List_set:
  "ran (lm.\<alpha> v) = snd ` (Assoc_List.set v)"
  by (simp add: icf_rec_unf Assoc_List.lookup_def Assoc_List.set_def
    ran_distinct)

lemma lm_ball_eq_ran:
  "lm.ball v (\<lambda>(k,v). P v) \<longleftrightarrow> ran (lm.\<alpha> v) \<subseteq> Collect P"
  by (auto simp add: ran_lm_\<alpha>_Assoc_List_set lm_ball_Assoc_List_set)

lemma lm_ball_lm_to_map_map_weaken:
  "\<forall>x \<in> f ` set xs. P x \<Longrightarrow> lm.ball (lm.to_map (map f xs)) P"
  by (induct xs) (simp_all add: lm.correct)

lemma Assoc_List_set_eq_lookup:
  "(k,v) \<in> Assoc_List.set vs \<longleftrightarrow> Assoc_List.lookup vs k = Some v"
  by (simp add: Assoc_List.lookup_def Assoc_List.set_def)

(*>*)

subsection \<open>Bounds\<close>

text \<open>
  Finiteness requires that possible variable ranges are finite, as is the maximium number of processes.
  Currently, they are supplied here as constants. In a perfect world, they should be able to be set dynamically.
\<close>

(* NB! Make sure those values coincide with the bounds definied in @{const ppVarType} *)
definition min_var_value :: "integer" where
  "min_var_value = -(2^31)"
definition max_var_value :: "integer" where
  "max_var_value = (2^31) - 1"

lemma min_max_var_value_simps [simp, intro!]:
  "min_var_value < max_var_value"
  "min_var_value < 0"
  "min_var_value \<le> 0"
  "max_var_value > 0"
  "max_var_value \<ge> 0"
by (simp_all add: min_var_value_def max_var_value_def)

definition "max_procs \<equiv> 255"
definition "max_channels \<equiv> 65535"
definition "max_array_size = 65535"

subsection \<open>Variables and similar\<close>

fun varType_inv :: "varType \<Rightarrow> bool" where
  "varType_inv (VTBounded l h)
  \<longleftrightarrow> l \<ge> min_var_value \<and> h \<le> max_var_value \<and> l < h"
| "varType_inv VTChan \<longleftrightarrow> True"

fun variable_inv :: "variable \<Rightarrow> bool" where
  "variable_inv (Var t val)
  \<longleftrightarrow> varType_inv t \<and> val \<in> {min_var_value..max_var_value}"
| "variable_inv (VArray t sz ar)
  \<longleftrightarrow> varType_inv t
    \<and> sz \<le> max_array_size
    \<and> IArray.length ar = sz
    \<and> set (IArray.list_of ar) \<subseteq> {min_var_value..max_var_value}"

fun channel_inv :: "channel \<Rightarrow> bool" where
  "channel_inv (Channel cap ts q)
  \<longleftrightarrow> cap \<le> max_array_size
    \<and> cap \<ge> 0
    \<and> set ts \<subseteq> Collect varType_inv
    \<and> length ts \<le> max_array_size
    \<and> length q \<le> max_array_size
    \<and> (\<forall>x \<in> set q. length x = length ts
    \<and> set x \<subseteq> {min_var_value..max_var_value})"
| "channel_inv (HSChannel ts)
  \<longleftrightarrow> set ts \<subseteq> Collect varType_inv \<and> length ts \<le> max_array_size"
| "channel_inv InvChannel \<longleftrightarrow> True"

lemma varTypes_finite:
  "finite (Collect varType_inv)"
proof (rule finite_subset)
  show "Collect (varType_inv) \<subseteq>
      {VTChan}
    \<union> (\<lambda>(l,h). VTBounded l h)
      ` ({min_var_value..max_var_value} \<times> {min_var_value..max_var_value})"
    apply (rule subsetI)
    apply (case_tac x)
      apply auto
    done

  show "finite ..." by auto
qed

lemma variables_finite:
  "finite (Collect variable_inv)"
proof (rule finite_subset)
  let ?mm = "{min_var_value..max_var_value}"
  let ?V1 = "(\<lambda>(t,val). Var t val) ` ({vt. varType_inv vt} \<times> ?mm)"
  let ?V2 = "(\<lambda>(t,sz,ar). VArray t sz ar)
    ` ({vt. varType_inv vt}
      \<times> {0..max_array_size}
      \<times> {ar. IArray.length ar \<le> max_array_size
           \<and> set (IArray.list_of ar) \<subseteq> ?mm})"

  {
    fix A :: "'a set"
    let ?LS = "{xs. set xs \<subseteq> A \<and> length xs \<le> max_array_size }"
    let ?AS = "{ar. IArray.length ar \<le> max_array_size
      \<and> set (IArray.list_of ar) \<subseteq> A}"

    assume "finite A"
    hence "finite ?LS" by (simp add: finite_lists_length_le)
    moreover have "?AS \<subseteq> IArray ` ?LS"
      apply (auto simp: image_def)
      apply (rule_tac x = "IArray.list_of x" in exI)
      apply auto
      apply (metis iarray.exhaust list_of.simps)
      done
    ultimately have "finite ?AS" by (auto simp add: finite_subset)
  } note finite_arr = this

  show "Collect variable_inv \<subseteq> (?V1 \<union> ?V2)"
    apply (rule subsetI)
    apply (case_tac x)
      apply (auto simp add: image_def)
    done

  show "finite ..." by (blast intro: varTypes_finite finite_arr)
qed

lemma channels_finite:
  "finite (Collect channel_inv)"
proof (rule finite_subset)
  let ?C1 =
    "(\<lambda>(cap,ts,q). Channel cap ts q)
     ` ({0..max_array_size}
      \<times> {ts. set ts \<subseteq> Collect varType_inv \<and> length ts \<le> max_array_size}
      \<times> {q. set q \<subseteq> {x. set x \<subseteq> {min_var_value..max_var_value}
                        \<and> length x \<le> max_array_size}
            \<and> length q \<le> max_array_size})"
  let ?C2 =
    "HSChannel ` {ts. set ts \<subseteq> Collect varType_inv \<and> length ts \<le> max_array_size}"
  let ?C3 = "{InvChannel}"

  show "(Collect channel_inv) \<subseteq> ?C1 \<union> ?C2 \<union> ?C3"
    apply (rule subsetI)
    apply (case_tac x)
      apply (auto simp add: image_def)
    done

  show "finite ..." by (blast intro: finite_lists_length_le varTypes_finite)+
qed

text \<open>To give an upper bound of variable names, we need a way to calculate it.\<close>

primrec procArgName :: "procArg \<Rightarrow> String.literal" where
  "procArgName (ProcArg _ name) = name"

primrec varDeclName :: "varDecl \<Rightarrow> String.literal" where
  "varDeclName (VarDeclNum _ _ name _ _) = name"
| "varDeclName (VarDeclChan name _ _) = name"

primrec procVarDeclName :: "procVarDecl \<Rightarrow> String.literal" where
  "procVarDeclName (ProcVarDeclNum _ _ name _ _) = name"
| "procVarDeclName (ProcVarDeclChan name _) = name"

definition edgeDecls :: "edge \<Rightarrow> procVarDecl set" where
  "edgeDecls e = (
     case effect e of
      EEDecl p \<Rightarrow> {p}
    |  _ \<Rightarrow> {})"

lemma edgeDecls_finite:
  "finite (edgeDecls e)"
by (simp add: edgeDecls_def split: edgeEffect.split)

definition edgeSet :: "states \<Rightarrow> edge set" where
  "edgeSet s = set (concat (map snd (IArray.list_of s)))"

lemma edgeSet_finite:
  "finite (edgeSet s)"
by (simp add: edgeSet_def)

definition statesDecls :: "states \<Rightarrow> procVarDecl set" where
  "statesDecls s = \<Union>(edgeDecls ` (edgeSet s))"

definition statesNames :: "states \<Rightarrow> String.literal set" where
  "statesNames s = procVarDeclName ` statesDecls s"

lemma statesNames_finite:
  "finite (statesNames s)"
by (simp add: edgeSet_finite edgeDecls_finite statesNames_def statesDecls_def)

fun process_names :: "states \<Rightarrow> process \<Rightarrow> String.literal set" where
  "process_names ss (_, _, args, decls) =
      statesNames ss
    \<union> procArgName ` set args
    \<union> varDeclName ` set decls
    \<union> {STR ''_'', STR ''__assert__'', STR ''_pid''}" (* dunno if this is ok as a fixed set ... *)

lemma process_names_finite:
  "finite (process_names ss p)"
by (cases p) (simp add: statesNames_finite)

definition vardict_inv :: "states \<Rightarrow> process \<Rightarrow> var_dict \<Rightarrow> bool" where
  "vardict_inv ss p vs
   \<longleftrightarrow> lm.ball vs (\<lambda>(k,v). k \<in> process_names ss p \<and> variable_inv v)"

lemma vardicts_finite:
  "finite (Collect (vardict_inv ss p))"
proof -
  have "Assoc_List.set ` Collect (vardict_inv ss p) \<subseteq>
           Pow (process_names ss p \<times> {v. variable_inv v})"
    by (auto simp add: lm_ball_Assoc_List_set vardict_inv_def)

  moreover have "finite ..."
    using process_names_finite variables_finite
    by simp
  ultimately show ?thesis by (metis finite_Assoc_List_set_image finite_subset)
qed

lemma lm_to_map_vardict_inv:
  assumes "\<forall>(k,v) \<in> set xs. k \<in> process_names ss proc \<and> variable_inv v"
  shows "vardict_inv ss proc (lm.to_map xs)"
using assms
unfolding vardict_inv_def
by (auto simp add: lm.correct dest: map_of_SomeD)

subsection \<open>Invariants of a process\<close>

(* The definition of a channel to be between -1 and max_channels definitly lacks the necessary abstraction ... *)
definition pState_inv :: "program \<Rightarrow> pState \<Rightarrow> bool" where
  "pState_inv prog p
  \<longleftrightarrow> pid p \<le> max_procs
    \<and> pState.idx p < IArray.length (states prog)
    \<and> IArray.length (states prog) = IArray.length (processes prog)
    \<and> pc p < IArray.length ((states prog) !! pState.idx p)
    \<and> set (pState.channels p) \<subseteq> {-1..<integer_of_nat max_channels}
    \<and> length (pState.channels p) \<le> max_channels
    \<and> vardict_inv ((states prog) !! pState.idx p)
                  ((processes prog) !! pState.idx p)
                  (pState.vars p)"

lemma pStates_finite:
  "finite (Collect (pState_inv prog))"
proof -
  let ?P1 = "{..max_procs::nat}"
  let ?P2 = "{..IArray.length (states prog)}"
  let ?P3 = "{..Max (IArray.length ` (set (IArray.list_of (states prog))))}"
  let ?P4 = "{cs. set cs \<subseteq> {-1..<integer_of_nat max_channels}
                  \<and> length cs \<le> max_channels}"
  let ?P5 = "\<Union>x\<in>{..IArray.length (states prog)}.
                Collect (vardict_inv (states prog !! x) (processes prog !! x))"
  let ?P = "?P1 \<times> ?P2 \<times> ?P3 \<times> ?P4 \<times> ?P5"

  have "{p. pState_inv prog p} \<subseteq>
    (\<lambda>(pid,idx,pc,channels,vars). pState.make pid vars pc channels idx) ` ?P"
    unfolding pState_inv_def image_def [of _ ?P]
    apply (clarsimp simp add: pState.defs)
    apply (tactic \<open>Record.split_simp_tac @{context} [] (K ~1) 1\<close>)
    apply auto
    apply (rule order_trans [OF less_imp_le])
    apply (auto intro!: Max_ge)
    done
  moreover
  have "finite ?P4" by (fastforce intro: finite_lists_length_le)
  hence "finite ?P" by (auto intro: finite_cartesian_product simp: vardicts_finite)

  ultimately show ?thesis by (elim finite_subset) (rule finite_imageI)
qed

text \<open>
  Throughout the calculation of the semantic engine, a modified process is not necessarily part of @{term "procs g"}.
  Hence we need to establish an additional constraint for the relation between a global and a process state.\<close>

definition cl_inv :: "('a gState_scheme * pState) \<Rightarrow> bool" where
  "cl_inv gp = (case gp of (g,p) \<Rightarrow>
      length (pState.channels p) \<le> length (gState.channels g))"

lemma cl_inv_lengthD:
  "cl_inv (g,p) \<Longrightarrow> length (pState.channels p) \<le> length (gState.channels g)"
unfolding cl_inv_def
by auto

lemma cl_invI:
  "length (pState.channels p) \<le> length (gState.channels g) \<Longrightarrow> cl_inv (g,p)"
unfolding cl_inv_def by auto

lemma cl_inv_trans:
  "length (channels g) \<le> length (channels g') \<Longrightarrow> cl_inv (g,p) \<Longrightarrow> cl_inv (g',p)"
by (simp add: cl_inv_def)

lemma cl_inv_vars_update[intro!]:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (g, pState.vars_update vs p)"
  "cl_inv (g,p) \<Longrightarrow> cl_inv (gState.vars_update vs g, p)"
by (simp_all add: cl_inv_def)

lemma cl_inv_handshake_update[intro!]:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (g\<lparr>handshake := h\<rparr>,p)"
by (simp add: cl_inv_def)

lemma cl_inv_procs_update[intro!]:
  "cl_inv (g,p) \<Longrightarrow> cl_inv (g\<lparr>procs := ps\<rparr>,p)"
by (simp add: cl_inv_def)

lemma cl_inv_channels_update:
  assumes "cl_inv (g,p)"
  shows "cl_inv (gState.channels_update (\<lambda>cs. cs[i:=c]) g, p)"
using assms unfolding cl_inv_def
by simp

subsection \<open>Invariants of the global state\<close>

text \<open>Note that @{term gState_inv} must be defined in a way to be applicable to both @{typ gState} and @{typ gState\<^sub>I}.\<close>

definition gState_inv :: "program \<Rightarrow> 'a gState_scheme \<Rightarrow> bool" where
  "gState_inv prog g
  \<longleftrightarrow> length (procs g) \<le> max_procs
    \<and> (\<forall>p \<in> set (procs g). pState_inv prog p \<and> cl_inv (g,p))
    \<and> length (channels g) \<le> max_channels
    \<and> set (channels g) \<subseteq> Collect channel_inv
    \<and> lm.ball (vars g) (\<lambda>(k,v). variable_inv v)"

text \<open>The set of global states adhering to the terms of @{const gState_inv} is not finite.
But the set of all global states that can be constructed by the semantic engine from one starting state is.
Thus we establish a progress relation, \ie all successors of a state @{term g} relate to @{term g} under this specification.\<close>

definition gState_progress_rel :: "program \<Rightarrow> ('a gState_scheme) rel" where
  "gState_progress_rel p = {(g,g'). gState_inv p g \<and> gState_inv p g'
                                  \<and> length (channels g) \<le> length (channels g')
                                  \<and> dom (lm.\<alpha> (vars g)) = dom (lm.\<alpha> (vars g'))}"

lemma gState_progress_rel_gState_invI1[intro]:
  "(g,g') \<in> gState_progress_rel prog \<Longrightarrow> gState_inv prog g"
by (simp add: gState_progress_rel_def)

lemma gState_progress_rel_gState_invI2[intro]:
  "(g,g') \<in> gState_progress_rel prog \<Longrightarrow> gState_inv prog g'"
by (simp add: gState_progress_rel_def)

lemma gState_progress_relI:
  assumes "gState_inv prog g"
  and "gState_inv prog g'"
  and "length (channels g) \<le> length (channels g')"
  and "dom (lm.\<alpha> (vars g)) = dom (lm.\<alpha> (vars g'))"
  shows "(g,g') \<in> gState_progress_rel prog"
unfolding gState_progress_rel_def
using assms
by auto

lemma gState_progress_refl[simp,intro!]:
  "gState_inv prog g \<Longrightarrow> (g,g) \<in> (gState_progress_rel prog)"
unfolding gState_progress_rel_def
by auto

lemma refl_on_gState_progress_rel:
  "refl_on (Collect (gState_inv prog)) (gState_progress_rel prog)"
by (auto intro!: refl_onI)

lemma trans_gState_progress_rel[simp]:
  "trans (gState_progress_rel prog)"
by (intro transI) (simp add: gState_progress_rel_def)

lemmas gState_progress_rel_trans [trans] = trans_gState_progress_rel[THEN transD]

lemma gState_progress_rel_trancl_id[simp]:
  "(gState_progress_rel prog)\<^sup>+ = gState_progress_rel prog"
by simp

lemma gState_progress_rel_rtrancl_absorb:
  assumes "gState_inv prog g"
  shows "(gState_progress_rel prog)\<^sup>* `` {g} = gState_progress_rel prog `` {g}"
using assms refl_on_gState_progress_rel
by (intro Image_absorb_rtrancl) auto

text \<open>
  The main theorem: The set of all global states reachable from an initial state, is finite.
\<close>
lemma gStates_finite:
  fixes g :: "gState"
  shows "finite ((gState_progress_rel prog)\<^sup>* `` {g})"
proof (cases "gState_inv prog g")
  case False hence "(gState_progress_rel prog)\<^sup>* `` {g} = {g}"
    by (intro Image_empty_rtrancl_Image_id)
       (auto simp add: gState_progress_rel_def)
  thus ?thesis by simp
next
  case True
  let ?G1 = "{m. dom (lm.\<alpha> m) = dom (lm.\<alpha> (vars g))
                 \<and> ran (lm.\<alpha> m) \<subseteq> Collect variable_inv }"
  let ?G2 = "{cs. set cs \<subseteq> Collect channel_inv
                  \<and> length cs \<le> max_channels}"
  let ?G3 = "{True, False}"
  let ?G4 = "{ps. set ps \<subseteq> Collect (pState_inv prog)
                  \<and> length ps \<le> max_procs}"

  let ?G = "?G1 \<times> ?G2 \<times> ?G3 \<times> ?G4"
  let ?G' = "(\<lambda>(vars,chans,t,ps). gState.make vars chans t ps) ` ?G"

  have G1: "finite ?G1"
  proof (rule finite_subset)
    show "?G1 \<subseteq> {v'. fst ` Assoc_List.set v' = fst ` Assoc_List.set (vars g)
                     \<and> snd ` Assoc_List.set v' \<subseteq> Collect variable_inv}"
      by (simp add: dom_lm_\<alpha>_Assoc_List_set ran_lm_\<alpha>_Assoc_List_set)
    show "finite ..." (is "finite ?X")
    proof (rule finite_Assoc_List_set_image, rule finite_subset)
      show "Assoc_List.set ` ?X \<subseteq>
             Pow (fst ` Assoc_List.set (vars g) \<times> Collect variable_inv)"
        by auto
      show "finite ..." by (auto simp add: variables_finite dom_lm_\<alpha>_Assoc_List_set[symmetric])
    qed
  qed

  have "finite ((gState_progress_rel prog) `` {g})"
  proof (rule finite_subset)
    show "(gState_progress_rel prog) `` {g} \<subseteq>
           (\<lambda>(vars,chans,t,ps). gState.make vars chans t ps) ` ?G"
      apply (clarsimp simp add: image_def gState_inv_def gState.defs gState_progress_rel_def)
      apply (rule_tac x = "vars x" in exI)
      apply (simp add: lm_ball_eq_ran)
      apply (rule_tac x = "channels x" in exI)
      apply (case_tac "timeout x")
        apply clarsimp
        apply (rule_tac x="procs x" in exI)
        apply auto
      done
    show "finite ..." using G1
      by (blast intro: finite_lists_length_le channels_finite pStates_finite)
  qed
  with gState_progress_rel_rtrancl_absorb[OF True] show ?thesis by simp
qed

lemma gState_progress_rel_channels_update:
  assumes "gState_inv prog g"
  and "channel_inv c"
  and "i < length (channels g)"
  shows "(g,gState.channels_update (\<lambda>cs. cs[i:=c]) g) \<in> gState_progress_rel prog"
using assms
by (auto intro!: gState_progress_relI
         simp add: gState_inv_def cl_inv_def
         dest!: subsetD[OF set_update_subset_insert])

lemma gState_progress_rel_channels_update_step:
  assumes "gState_inv prog g"
  and step: "(g,g') \<in> gState_progress_rel prog"
  and "channel_inv c"
  and "i < length (channels g')"
  shows "(g,gState.channels_update (\<lambda>cs. cs[i:=c]) g') \<in> gState_progress_rel prog"
proof -
  note step
  also hence "gState_inv prog g'" by blast
  note gState_progress_rel_channels_update[OF this assms(3,4)]
  finally show ?thesis .
qed

subsection \<open>Invariants of the program\<close>

text \<open>
  Naturally, we need our program to also adhere to certain invariants. Else we can't show, that
  the generated states are correct according to the invariants above.
\<close>

definition program_inv where
  "program_inv prog
  \<longleftrightarrow> IArray.length (states prog) > 0
    \<and> IArray.length (states prog) = IArray.length (processes prog)
    \<and> (\<forall>s \<in> set (IArray.list_of (states prog)). IArray.length s > 0)
    \<and> lm.ball (proc_data prog)
              (\<lambda>(_,sidx).
                    sidx < IArray.length (processes prog)
                  \<and> fst (processes prog !! sidx) = sidx)
    \<and> (\<forall>(sidx,start,procArgs,args) \<in> set (IArray.list_of (processes prog)).
        (\<exists>s. start = Index s \<and> s < IArray.length (states prog !! sidx)))"

lemma program_inv_length_states:
  assumes "program_inv prog"
  and "n < IArray.length (states prog)"
  shows "IArray.length (states prog !! n) > 0"
using assms by (simp add: program_inv_def)

lemma program_invI:
  assumes "0 < IArray.length (states prog)"
  and "IArray.length (states prog) = IArray.length (processes prog)"
  and "\<And>s. s \<in> set (IArray.list_of (states prog))
           \<Longrightarrow> 0 < IArray.length s"
  and "\<And>sidx. sidx \<in> ran (lm.\<alpha> (proc_data prog))
               \<Longrightarrow> sidx < IArray.length (processes prog)
                  \<and> fst (processes prog !! sidx) = sidx"
  and "\<And>sidx start procArgs args.
         (sidx,start,procArgs,args) \<in> set (IArray.list_of (processes prog))
         \<Longrightarrow> \<exists>s. start = Index s \<and> s < IArray.length (states prog !! sidx)"
  shows "program_inv prog"
unfolding program_inv_def
using assms
by (auto simp add: lm_ball_eq_ran)

end