(*
   Title: Theory  Secrecy.thy
   Author:    Maria Spichkova <maria.spichkova at rmit.edu.au>, 2014
*)

section \<open>Secrecy: Definitions and properties\<close>

theory Secrecy
imports Secrecy_types inout ListExtras
begin

\<comment> \<open>Encryption, decryption, signature creation and signature verification functions\<close>
\<comment> \<open>For these functions we define only their signatures and general axioms,\<close>
\<comment> \<open>because in order to reason effectively, we view them as abstract functions and\<close>
\<comment> \<open>abstract from their implementation details\<close>
consts
  Enc  :: "Keys \<Rightarrow> Expression list \<Rightarrow> Expression list"
  Decr :: "Keys \<Rightarrow> Expression list \<Rightarrow> Expression list"
  Sign :: "Keys \<Rightarrow> Expression list \<Rightarrow> Expression list"
  Ext   :: "Keys \<Rightarrow> Expression list \<Rightarrow> Expression list"

\<comment> \<open>Axioms on relations between encription and decription keys\<close>
axiomatization
   EncrDecrKeys :: "Keys  \<Rightarrow> Keys \<Rightarrow> bool"
where
ExtSign:
 "EncrDecrKeys K1 K2 \<longrightarrow> (Ext K1 (Sign K2 E)) = E"  and
DecrEnc:
 "EncrDecrKeys K1 K2 \<longrightarrow> (Decr K2 (Enc K1 E)) = E"

\<comment> \<open>Set of private keys of a component\<close>
consts
 specKeys :: "specID \<Rightarrow> Keys set"
\<comment> \<open>Set of unguessable values used by a component\<close>
consts
 specSecrets :: "specID \<Rightarrow> Secrets set"

\<comment> \<open>Join set of private keys and unguessable values used by a component\<close>
definition
  specKeysSecrets :: "specID \<Rightarrow> KS set"
where
 "specKeysSecrets C \<equiv>
  {y .  \<exists> x. y = (kKS x)  \<and> (x \<in> (specKeys C))} \<union>
  {z .  \<exists> s. z = (sKS s)  \<and> (s \<in> (specSecrets C))}"

\<comment> \<open>Predicate defining that a list of expression items does not contain\<close>
\<comment> \<open>any private key  or unguessable value used by a component\<close>
definition
  notSpecKeysSecretsExpr :: "specID \<Rightarrow>  Expression list \<Rightarrow> bool"
where
     "notSpecKeysSecretsExpr P e \<equiv>
     (\<forall> x. (kE x) mem e \<longrightarrow> (kKS x) \<notin> specKeysSecrets P) \<and>
     (\<forall> y. (sE y) mem e \<longrightarrow> (sKS y) \<notin> specKeysSecrets P)"

\<comment> \<open>If a component is a composite one, the set of its private keys\<close>
\<comment> \<open>is a union of the subcomponents' sets of the private keys\<close>
definition
  correctCompositionKeys ::  "specID \<Rightarrow> bool"
where
  "correctCompositionKeys x \<equiv>
    subcomponents x \<noteq> {} \<longrightarrow>
    specKeys x =  \<Union> (specKeys ` (subcomponents x))"

\<comment> \<open>If a component is a composite one, the set of its unguessable values\<close>
\<comment> \<open>is a union of the subcomponents' sets of the unguessable values\<close>
definition
  correctCompositionSecrets ::  "specID \<Rightarrow> bool"
where
  "correctCompositionSecrets x \<equiv>
    subcomponents x \<noteq> {} \<longrightarrow>
    specSecrets x =  \<Union> (specSecrets ` (subcomponents x))"

\<comment> \<open>If a component is a composite one, the set of its private keys and\<close>
\<comment> \<open>unguessable values is a union of the corresponding sets of its subcomponents\<close>
definition
  correctCompositionKS ::  "specID \<Rightarrow> bool"
where
  "correctCompositionKS x \<equiv>
    subcomponents x \<noteq> {} \<longrightarrow>
    specKeysSecrets x =  \<Union> (specKeysSecrets ` (subcomponents x))"

\<comment> \<open>Predicate defining set of correctness properties of the component's\<close>
\<comment> \<open>interface  and relations on its private keys and unguessable values\<close>
definition
  correctComponentSecrecy  ::  "specID \<Rightarrow> bool"
where
  "correctComponentSecrecy x \<equiv>
    correctCompositionKS x \<and>
    correctCompositionSecrets x \<and>
    correctCompositionKeys x \<and>
    correctCompositionLoc x \<and>
    correctCompositionIn x \<and>
    correctCompositionOut x \<and>
    correctInOutLoc x"

\<comment> \<open>Predicate exprChannel I E defines whether the expression item E can be sent via the channel I\<close>
consts
 exprChannel :: "chanID \<Rightarrow> Expression \<Rightarrow> bool"

\<comment> \<open>Predicate eoutM sP M E defines whether the component sP may eventually\<close>
\<comment> \<open>output an expression E if there exists a time interval t of\<close>
\<comment> \<open>an output channel which contains this expression E\<close>
definition
  eout :: "specID  \<Rightarrow> Expression \<Rightarrow> bool"
where
 "eout sP E \<equiv>
  \<exists> (ch :: chanID). ((ch \<in> (out sP)) \<and> (exprChannel ch E))"

\<comment> \<open>Predicate eout sP E defines whether the component sP may eventually\<close>
\<comment> \<open>output an expression E via subset of channels M,\<close>
\<comment> \<open>which is a subset of output channels of sP,\<close>
\<comment> \<open>and if there exists a time interval t of\<close>
\<comment> \<open>an output channel which contains this expression E\<close>
definition
  eoutM :: "specID  \<Rightarrow> chanID set \<Rightarrow> Expression \<Rightarrow> bool"
where
 "eoutM sP M E \<equiv>
  \<exists> (ch :: chanID). ((ch \<in> (out sP)) \<and> (ch \<in> M) \<and> (exprChannel ch E))"

\<comment> \<open>Predicate ineM sP M E defines whether a component sP may eventually\<close>
\<comment> \<open>get an expression E  if there exists a time interval t of\<close>
\<comment> \<open>an input stream  which contains this expression E\<close>
definition
  ine :: "specID  \<Rightarrow> Expression \<Rightarrow> bool"
where
 "ine sP E \<equiv>
  \<exists> (ch :: chanID). ((ch \<in> (ins sP)) \<and> (exprChannel ch E))"

\<comment> \<open>Predicate ine sP E defines whether a component sP may eventually\<close>
\<comment> \<open>get an expression E via subset of channels M,\<close>
\<comment> \<open>which is a subset of input channels of sP,\<close>
\<comment> \<open>and if there exists a time interval t of\<close>
\<comment> \<open>an input stream  which contains this expression E\<close>
definition
  ineM :: "specID  \<Rightarrow> chanID set \<Rightarrow> Expression \<Rightarrow> bool"
where
 "ineM sP M E \<equiv>
  \<exists> (ch :: chanID). ((ch \<in> (ins sP)) \<and> (ch \<in> M) \<and> (exprChannel ch E))"

\<comment> \<open>This predicate defines whether an input channel ch of a component sP\<close>
\<comment> \<open>is the only one input channel of this component\<close>
\<comment> \<open>via which it may eventually output an expression E\<close>
definition
  out_exprChannelSingle :: "specID  \<Rightarrow> chanID \<Rightarrow> Expression \<Rightarrow> bool"
where
 "out_exprChannelSingle sP ch E \<equiv>
  (ch \<in> (out sP)) \<and>
  (exprChannel ch E)  \<and>
  (\<forall> (x :: chanID) (t :: nat). ((x \<in> (out sP)) \<and> (x \<noteq> ch) \<longrightarrow> \<not> exprChannel x E))"

\<comment> \<open>This predicate  yields true if only the channels from the set chSet,\<close>
\<comment> \<open>which is a subset of input channels of the  component sP,\<close>
\<comment> \<open>may eventually output an expression E\<close>
definition
 out_exprChannelSet :: "specID  \<Rightarrow> chanID set \<Rightarrow> Expression \<Rightarrow> bool"
where
 "out_exprChannelSet sP chSet E \<equiv>
   ((\<forall> (x ::chanID). ((x \<in> chSet) \<longrightarrow> ((x \<in> (out sP)) \<and> (exprChannel x E))))
   \<and>
   (\<forall> (x :: chanID). ((x \<notin> chSet) \<and> (x \<in> (out sP)) \<longrightarrow> \<not> exprChannel x E)))"

\<comment> \<open>This redicate defines whether\<close>
\<comment> \<open>an input channel ch of a component sP is the only one input channel\<close>
\<comment> \<open>of this component via which it may eventually get an expression E\<close>
definition
 ine_exprChannelSingle :: "specID  \<Rightarrow> chanID \<Rightarrow> Expression \<Rightarrow> bool"
where
 "ine_exprChannelSingle sP ch E \<equiv>
  (ch \<in> (ins sP)) \<and>
  (exprChannel ch E)  \<and>
  (\<forall> (x :: chanID) (t :: nat). (( x \<in> (ins sP)) \<and> (x \<noteq> ch) \<longrightarrow> \<not> exprChannel x E))"

\<comment> \<open>This predicate yields true if the component sP may eventually\<close>
\<comment> \<open>get an expression E only via the channels from the set chSet,\<close>
\<comment> \<open>which is a subset of input channels of sP\<close>
definition
 ine_exprChannelSet :: "specID  \<Rightarrow> chanID set \<Rightarrow> Expression \<Rightarrow> bool"
where
 "ine_exprChannelSet sP chSet E \<equiv>
   ((\<forall> (x ::chanID). ((x \<in> chSet) \<longrightarrow> ((x \<in> (ins sP)) \<and> (exprChannel x E))))
   \<and>
   (\<forall> (x :: chanID). ((x \<notin> chSet) \<and> ( x \<in> (ins sP)) \<longrightarrow> \<not> exprChannel x E)))"

\<comment> \<open>If a list of expression items does not contain any private key\<close>
\<comment> \<open>or unguessable value of a component P, then the first element\<close>
\<comment> \<open>of the list is neither a private key nor unguessable value of P\<close>
lemma notSpecKeysSecretsExpr_L1:
assumes "notSpecKeysSecretsExpr P (a # l)"
shows    "notSpecKeysSecretsExpr P [a]"
using assms by (simp add: notSpecKeysSecretsExpr_def)

\<comment> \<open>If a list of expression items does not contain any private key\<close>
\<comment> \<open>or unguessable value of a component P, then this list without its first\<close>
\<comment> \<open>element does not contain them too\<close>
lemma notSpecKeysSecretsExpr_L2:
assumes "notSpecKeysSecretsExpr P (a # l)"
shows    "notSpecKeysSecretsExpr P l"
using assms by (simp add: notSpecKeysSecretsExpr_def)

\<comment> \<open>If a channel belongs to the set of input channels of a component P\<close>
\<comment> \<open>and does not belong to the set of local channels of the compositon of P and Q\<close>
\<comment> \<open>then it belongs to the set of input channels of this composition\<close>
lemma correctCompositionIn_L1:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "ch \<notin> loc PQ"
       and "ch \<in> ins P"
shows    "ch \<in> ins PQ"
using assms by (simp add: correctCompositionIn_def)

\<comment> \<open>If a channel belongs to the set of input channels of the compositon of P and Q\<close>
\<comment> \<open>then it belongs to the set of input channels either of P or of Q\<close>
lemma correctCompositionIn_L2:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "ch \<in> ins PQ"
shows    "(ch \<in> ins P) \<or> (ch \<in> ins Q)"
using assms by (simp add: correctCompositionIn_def)

lemma ineM_L1:
assumes "ch \<in> M"
       and "ch \<in> ins P"
       and "exprChannel ch E"
shows    "ineM P M E"
using assms by (simp add: ineM_def, blast)

lemma ineM_ine:
assumes "ineM P M E"
shows    "ine P E"
using assms by (simp add: ineM_def ine_def, blast)

lemma not_ine_ineM:
assumes "\<not> ine P E"
shows    "\<not> ineM P M E"
using assms by (simp add: ineM_def ine_def)

lemma eoutM_eout:
assumes "eoutM P M E"
shows    "eout P E"
using assms by (simp add: eoutM_def eout_def, blast)

lemma not_eout_eoutM:
assumes "\<not> eout P E"
shows    "\<not> eoutM P M E"
using assms by (simp add: eoutM_def eout_def)

lemma correctCompositionKeys_subcomp1:
assumes "correctCompositionKeys C"
        and "x \<in> subcomponents C"
        and "xb \<in> specKeys C"
shows "\<exists> x \<in> subcomponents C. (xb \<in> specKeys x)"
using assms by (simp add: correctCompositionKeys_def, auto)

lemma correctCompositionSecrets_subcomp1:
assumes "correctCompositionSecrets C"
        and "x \<in> subcomponents C"
        and "s \<in> specSecrets C"
shows  "\<exists> x \<in> subcomponents C. (s \<in> specSecrets x)"
using assms by (simp add: correctCompositionSecrets_def, auto)

lemma correctCompositionKeys_subcomp2:
assumes "correctCompositionKeys C"
       and "xb \<in> subcomponents C"
       and "xc \<in> specKeys xb"
shows "xc \<in> specKeys C"
using assms by (simp add: correctCompositionKeys_def, auto)

lemma correctCompositionSecrets_subcomp2:
assumes "correctCompositionSecrets C"
        and "xb \<in> subcomponents C"
        and "xc \<in> specSecrets xb"
shows     "xc \<in> specSecrets C"
using assms by (simp add: correctCompositionSecrets_def, auto)

lemma correctCompKS_Keys:
assumes "correctCompositionKS C"
shows    "correctCompositionKeys C"
proof (cases "subcomponents C = {}")
  assume "subcomponents C = {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKeys_def)
next
  assume "subcomponents C \<noteq> {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKS_def
                correctCompositionKeys_def
                specKeysSecrets_def, blast)
qed

lemma correctCompKS_Secrets:
assumes "correctCompositionKS C"
shows    "correctCompositionSecrets C"
proof (cases "subcomponents C = {}")
  assume "subcomponents C = {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionSecrets_def)
next
  assume "subcomponents C \<noteq> {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKS_def
                correctCompositionSecrets_def
                specKeysSecrets_def, blast)
qed

lemma correctCompKS_KeysSecrets:
assumes "correctCompositionKeys C"
        and "correctCompositionSecrets C"
shows    "correctCompositionKS C"
proof (cases "subcomponents C = {}")
  assume "subcomponents C = {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKS_def)
next
  assume "subcomponents C \<noteq> {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKS_def
                correctCompositionKeys_def
                correctCompositionSecrets_def
                specKeysSecrets_def, blast)
qed

lemma correctCompositionKS_subcomp1:
assumes "correctCompositionKS C"
       and h1:"x \<in> subcomponents C"
       and "xa \<in> specKeys C"
shows    "\<exists> y \<in> subcomponents C. (xa \<in> specKeys y)"
proof (cases "subcomponents C = {}")
  assume "subcomponents C = {}"
  from this and h1 show ?thesis by simp
next
  assume "subcomponents C \<noteq> {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKS_def specKeysSecrets_def, blast)
qed

lemma correctCompositionKS_subcomp2:
assumes "correctCompositionKS C"
        and h1:"x \<in> subcomponents C"
        and "xa \<in> specSecrets C"
shows    "\<exists> y \<in> subcomponents C. xa \<in> specSecrets y"
proof (cases "subcomponents C = {}")
  assume "subcomponents C = {}"
  from this and h1 show ?thesis by simp
next
  assume "subcomponents C \<noteq> {}"
  from this and assms show ?thesis
  by (simp add: correctCompositionKS_def specKeysSecrets_def, blast)
qed

lemma correctCompositionKS_subcomp3:
assumes "correctCompositionKS C"
       and "x \<in> subcomponents C"
       and "xa \<in> specKeys x"
shows    "xa \<in> specKeys C"
using assms
by (simp add: correctCompositionKS_def specKeysSecrets_def, auto)

lemma correctCompositionKS_subcomp4:
assumes "correctCompositionKS C"
        and "x \<in> subcomponents C"
        and "xa \<in> specSecrets x"
shows     "xa \<in> specSecrets C"
using assms
by (simp add: correctCompositionKS_def specKeysSecrets_def, auto)

lemma correctCompositionKS_PQ:
assumes "subcomponents PQ = {P, Q}"
       and "correctCompositionKS PQ"
       and "ks \<in> specKeysSecrets PQ"
shows    "ks \<in> specKeysSecrets P \<or> ks \<in> specKeysSecrets Q"
using assms by (simp add: correctCompositionKS_def)

lemma correctCompositionKS_neg1:
assumes "subcomponents PQ = {P, Q}"
       and "correctCompositionKS PQ"
       and "ks \<notin> specKeysSecrets P"
       and "ks \<notin> specKeysSecrets Q"
shows    "ks \<notin> specKeysSecrets PQ"
using assms by (simp add: correctCompositionKS_def)

lemma correctCompositionKS_negP:
assumes "subcomponents PQ = {P, Q}"
        and "correctCompositionKS PQ"
        and "ks \<notin> specKeysSecrets PQ"
shows     "ks \<notin> specKeysSecrets P"
using assms by (simp add: correctCompositionKS_def)

lemma correctCompositionKS_negQ:
assumes "subcomponents PQ = {P, Q}"
        and "correctCompositionKS PQ"
        and "ks \<notin> specKeysSecrets PQ"
shows     "ks \<notin> specKeysSecrets Q"
using assms by (simp add: correctCompositionKS_def)

lemma out_exprChannelSingle_Set:
assumes "out_exprChannelSingle P ch E"
shows    "out_exprChannelSet P {ch} E"
using assms
by (simp add: out_exprChannelSingle_def out_exprChannelSet_def)

lemma out_exprChannelSet_Single:
assumes "out_exprChannelSet P {ch} E"
shows    "out_exprChannelSingle P ch E"
using assms
by (simp add: out_exprChannelSingle_def out_exprChannelSet_def)

lemma ine_exprChannelSingle_Set:
assumes "ine_exprChannelSingle P ch E"
  shows "ine_exprChannelSet P {ch} E"
using assms
by (simp add: ine_exprChannelSingle_def ine_exprChannelSet_def)

lemma ine_exprChannelSet_Single:
assumes "ine_exprChannelSet P {ch} E"
shows    "ine_exprChannelSingle P ch E"
using assms
by (simp add: ine_exprChannelSingle_def ine_exprChannelSet_def)

lemma ine_ins_neg1:
assumes "\<not> ine P m"
       and "exprChannel x m"
shows    "x \<notin> ins P"
using assms by (simp add: ine_def, auto)

theorem TBtheorem1a:
assumes "ine PQ E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
shows "ine P E  \<or> ine Q E"
using assms
by (simp add: ine_def correctCompositionIn_def, auto)

theorem TBtheorem1b:
assumes "ineM PQ M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
shows    "ineM P M E \<or> ineM Q M E"
using assms by (simp add: ineM_def correctCompositionIn_def, auto)

theorem TBtheorem2a:
assumes "eout PQ E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
shows    "eout P E \<or> eout Q E"
using assms by (simp add: eout_def correctCompositionOut_def, auto)

theorem TBtheorem2b:
assumes "eoutM PQ M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
shows    "eoutM P M E \<or> eoutM Q M E"
using assms by (simp add: eoutM_def correctCompositionOut_def, auto)

lemma correctCompositionIn_prop1:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "x \<in> (ins PQ)"
shows   "(x \<in> (ins P)) \<or> (x \<in> (ins Q))"
using assms by (simp add: correctCompositionIn_def)

lemma correctCompositionOut_prop1:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "x \<in> (out PQ)"
shows    "(x \<in> (out P)) \<or> (x \<in> (out Q))"
using assms by (simp add: correctCompositionOut_def)

theorem TBtheorem3a:
assumes "\<not> (ine P E)"
       and "\<not> (ine Q E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
shows    "\<not> (ine PQ E)"
using assms by (simp add: ine_def correctCompositionIn_def, auto )

theorem TBlemma3b:
assumes h1:"\<not> (ineM P M E)"
       and h2:"\<not> (ineM Q M E)"
       and subPQ:"subcomponents PQ = {P,Q}"
       and cCompI:"correctCompositionIn PQ"
       and chM:"ch \<in> M"
       and chPQ:"ch \<in> ins PQ"
       and eCh:"exprChannel ch E"
shows "False"
proof (cases "ch \<in> ins P")
  assume a1:"ch \<in> ins P"
  from a1 and chM and eCh have "ineM P M E" by (simp add: ineM_L1)
  from this and h1 show ?thesis by simp
next
  assume a2:"ch \<notin> ins P"
  from subPQ and cCompI and chPQ have "(ch \<in> ins P) \<or> (ch \<in> ins Q)"
    by (simp add: correctCompositionIn_L2)
  from this and a2 have "ch \<in> ins Q" by simp
  from this and chM and eCh have "ineM Q M E" by (simp add: ineM_L1)
  from this and h2 show ?thesis by simp
qed

theorem TBtheorem3b:
assumes "\<not> (ineM P M E)"
       and "\<not> (ineM Q M E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
shows    "\<not> (ineM PQ M E)"
using assms by (metis TBtheorem1b)

theorem TBtheorem4a_empty:
assumes "(ine P E) \<or> (ine Q E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "loc PQ = {}"
shows    "ine PQ E"
using assms by (simp add: ine_def correctCompositionIn_def, auto)

theorem TBtheorem4a_P:
assumes "ine P E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "\<exists> ch. (ch \<in> (ins P) \<and> exprChannel ch E \<and> ch \<notin> (loc PQ))"
shows    "ine PQ E"
using assms by (simp add: ine_def correctCompositionIn_def, auto)

theorem TBtheorem4b_P:
assumes "ineM P M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "\<exists> ch. ((ch \<in> (ins Q)) \<and> (exprChannel ch E) \<and>
                        (ch \<notin> (loc PQ)) \<and> (ch \<in> M))"
shows    "ineM PQ M E"
using assms by (simp add: ineM_def correctCompositionIn_def, auto)

theorem TBtheorem4a_PQ:
assumes "(ine P E) \<or> (ine Q E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "\<exists> ch. (((ch \<in> (ins P)) \<or> (ch \<in> (ins Q) )) \<and>
                         (exprChannel ch E) \<and>  (ch \<notin> (loc PQ)))"
shows    "ine PQ E"
using assms by (simp add: ine_def correctCompositionIn_def, auto)

theorem TBtheorem4b_PQ:
assumes "(ineM P M E) \<or> (ineM Q M E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "\<exists> ch. (((ch \<in> (ins P)) \<or> (ch \<in> (ins Q) )) \<and>
                         (ch \<in> M) \<and> (exprChannel ch E) \<and>  (ch \<notin> (loc PQ)))"
shows     "ineM PQ M E"
using assms by (simp add: ineM_def correctCompositionIn_def, auto)

theorem TBtheorem4a_notP1:
assumes "ine P E"
       and "\<not> ine Q E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "\<exists> ch. ((ine_exprChannelSingle P ch E) \<and> (ch \<in> (loc PQ)))"
shows    "\<not> ine PQ E"
using assms
by (simp add: ine_def correctCompositionIn_def
                     ine_exprChannelSingle_def, auto)

theorem TBtheorem4b_notP1:
assumes "ineM P M E"
       and "\<not> ineM Q M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "\<exists> ch. ((ine_exprChannelSingle P ch E) \<and> (ch \<in> M)
                     \<and> (ch \<in> (loc PQ)))"
shows    "\<not> ineM PQ M E"
using assms
by (simp add: ineM_def correctCompositionIn_def
                     ine_exprChannelSingle_def, auto)

theorem TBtheorem4a_notP2:
assumes "\<not> ine Q E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "ine_exprChannelSet P ChSet E"
       and "\<forall> (x ::chanID). ((x \<in> ChSet) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> ine PQ E"
using assms
by (simp add: ine_def correctCompositionIn_def
                     ine_exprChannelSet_def, auto)

theorem TBtheorem4b_notP2:
assumes "\<not> ineM Q M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "ine_exprChannelSet P ChSet E"
       and "\<forall> (x ::chanID). ((x \<in> ChSet) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> ineM PQ M E"
using assms
by (simp add: ineM_def correctCompositionIn_def
                     ine_exprChannelSet_def, auto)

theorem TBtheorem4a_notPQ:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionIn PQ"
       and "ine_exprChannelSet P ChSetP E"
       and "ine_exprChannelSet Q ChSetQ E"
       and "\<forall> (x ::chanID). ((x \<in> ChSetP) \<longrightarrow> (x \<in> (loc PQ)))"
       and "\<forall> (x ::chanID). ((x \<in> ChSetQ) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> ine PQ E"
using assms
by (simp add: ine_def correctCompositionIn_def
                     ine_exprChannelSet_def, auto)

lemma ineM_Un1:
assumes "ineM P A E"
shows    "ineM P (A Un B) E"
using assms by (simp add: ineM_def, auto)

lemma ine_nonempty_exprChannelSet:
assumes "ine_exprChannelSet P ChSet E"
       and "ChSet \<noteq> {}"
shows    "ine P E "
using assms by (simp add: ine_def ine_exprChannelSet_def, auto)

lemma ine_empty_exprChannelSet:
assumes "ine_exprChannelSet P ChSet E"
       and "ChSet = {}"
shows    "\<not> ine P E"
using assms by (simp add: ine_def ine_exprChannelSet_def)

theorem TBtheorem5a_empty:
assumes "(eout P E) \<or> (eout Q E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "loc PQ = {}"
shows    "eout PQ E"
using assms by (simp add: eout_def correctCompositionOut_def, auto)

theorem TBtheorem45a_P:
assumes "eout P E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "\<exists> ch. ((ch \<in> (out P)) \<and> (exprChannel ch E) \<and>
                        (ch \<notin> (loc PQ)))"
shows    "eout PQ E"
using assms by (simp add: eout_def correctCompositionOut_def, auto)

theorem TBtheore54b_P:
assumes "eoutM P M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "\<exists> ch. ((ch \<in> (out Q)) \<and> (exprChannel ch E) \<and>
                        (ch \<notin> (loc PQ)) \<and> (ch \<in> M) )"
shows    "eoutM PQ M E"
using assms by (simp add: eoutM_def correctCompositionOut_def, auto)

theorem TBtheorem5a_PQ:
assumes "(eout P E) \<or> (eout Q E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "\<exists> ch. (((ch \<in> (out P)) \<or> (ch \<in> (out Q) )) \<and>
                        (exprChannel ch E) \<and>  (ch \<notin> (loc PQ)))"
shows    "eout PQ E"
using assms by (simp add: eout_def correctCompositionOut_def, auto)

theorem TBtheorem5b_PQ:
assumes "(eoutM P M E) \<or> (eoutM Q M E)"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "\<exists> ch. (((ch \<in> (out P)) \<or> (ch \<in> (out Q) )) \<and> (ch \<in> M)
                      \<and> (exprChannel ch E) \<and>  (ch \<notin> (loc PQ)))"
shows    "eoutM PQ M E"
using assms by (simp add: eoutM_def correctCompositionOut_def, auto)

theorem TBtheorem5a_notP1:
assumes "eout P E"
       and "\<not> eout Q E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "\<exists> ch. ((out_exprChannelSingle P ch E) \<and> (ch \<in> (loc PQ)))"
shows    "\<not> eout PQ E"
using assms
by (simp add: eout_def correctCompositionOut_def
                      out_exprChannelSingle_def, auto)

theorem TBtheorem5b_notP1:
assumes "eoutM P M E"
       and "\<not> eoutM Q M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "\<exists> ch. ((out_exprChannelSingle P ch E) \<and> (ch \<in> M)
                   \<and> (ch \<in> (loc PQ)))"
shows    "\<not> eoutM PQ M E"
using assms
by (simp add: eoutM_def correctCompositionOut_def
                     out_exprChannelSingle_def, auto)

theorem TBtheorem5a_notP2:
assumes "\<not> eout Q E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "out_exprChannelSet P ChSet E"
       and "\<forall> (x ::chanID). ((x \<in> ChSet) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> eout PQ E"
using assms
by (simp add: eout_def correctCompositionOut_def
                     out_exprChannelSet_def, auto)

theorem TBtheorem5b_notP2:
assumes "\<not> eoutM Q M E"
       and "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "out_exprChannelSet P ChSet E"
       and "\<forall> (x ::chanID). ((x \<in> ChSet) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> eoutM PQ M E"
using assms
by (simp add: eoutM_def correctCompositionOut_def
                     out_exprChannelSet_def, auto)

theorem TBtheorem5a_notPQ:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "out_exprChannelSet P ChSetP E"
       and "out_exprChannelSet Q ChSetQ E"
       and "\<forall> (x ::chanID). ((x \<in> ChSetP) \<longrightarrow> (x \<in> (loc PQ)))"
       and "\<forall> (x ::chanID). ((x \<in> ChSetQ) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> eout PQ E"
using assms
by (simp add: eout_def correctCompositionOut_def
                     out_exprChannelSet_def, auto)

theorem TBtheorem5b_notPQ:
assumes "subcomponents PQ = {P,Q}"
       and "correctCompositionOut PQ"
       and "out_exprChannelSet P ChSetP E"
       and "out_exprChannelSet Q ChSetQ E"
       and "M = ChSetP \<union> ChSetQ"
       and "\<forall> (x ::chanID). ((x \<in> ChSetP) \<longrightarrow> (x \<in> (loc PQ)))"
       and "\<forall> (x ::chanID). ((x \<in> ChSetQ) \<longrightarrow> (x \<in> (loc PQ)))"
shows    "\<not> eoutM PQ M E"
using assms
by (simp add: eoutM_def correctCompositionOut_def
                     out_exprChannelSet_def, auto)

end


(*  Title:      Mapping_Exts.thy
    Author:     Denis Lohner, Sebastian Ullrich
*)

subsection "Mapping Extensions"

text {* Some lifted definition on mapping and efficient implementations. *}

theory Mapping_Exts
imports "~~/src/HOL/Library/Mapping" FormalSSA_Misc
begin

lift_definition mapping_delete_all :: "('a \<Rightarrow> bool) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
  is "\<lambda>P m x. if (P x) then None else m x" .
lift_definition map_keys :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a,'c) mapping \<Rightarrow> ('b,'c) mapping"
  is "\<lambda>f m x. if f -` {x} \<noteq> {} then m (THE k. f -` {x} = {k}) else None" .
lift_definition map_values :: "('a \<Rightarrow> 'b \<Rightarrow> 'c option) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'c) mapping"
  is "\<lambda>f m x. Option.bind (m x) (f x)" .
lift_definition restrict_mapping :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>f. restrict_map (Some \<circ> f)" .
lift_definition mapping_add :: "('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
  is "op ++" .

definition "mmap = Mapping.map id"

lemma lookup_map_keys: "Mapping.lookup (map_keys f m) x = (if f -` {x} \<noteq> {} then Mapping.lookup m (THE k. f -` {x} = {k}) else None)"
apply transfer ..

lemma Mapping_Mapping_lookup [simp, code_unfold]: "Mapping.Mapping (Mapping.lookup m) = m" by transfer simp
declare Mapping.lookup.abs_eq[simp]

lemma Mapping_eq_lookup: "m = m' \<longleftrightarrow> Mapping.lookup m = Mapping.lookup m'" by transfer simp

lemma map_of_map_if_conv:
  "map_of (map (\<lambda>k. (k, f k)) xs) x = (if (x \<in> set xs) then Some (f x) else None)"
  by (clarsimp simp: map_of_map_restrict)

lemma Mapping_lookup_map: "Mapping.lookup (Mapping.map f g m) a = map_option g (Mapping.lookup m (f a))"
  by transfer simp

lemma Mapping_lookup_map_default: "Mapping.lookup (Mapping.map_default k d f m) k' = (if k = k'
  then (Some \<circ> f) (case Mapping.lookup m k of None \<Rightarrow> d | Some x \<Rightarrow> x)
  else Mapping.lookup m k')"
  unfolding Mapping.map_default_def Mapping.default_def
  by transfer auto

lemma Mapping_lookup_mapping_add: "Mapping.lookup (mapping_add m1 m2) k =
  case_option (Mapping.lookup m1 k) Some (Mapping.lookup m2 k)"
  by transfer (simp add: map_add_def)

lemma Mapping_lookup_map_values: "Mapping.lookup (map_values f m) k =
  Option.bind (Mapping.lookup m k) (f k)"
  by transfer simp

lemma lookup_fold_update [simp]: "Mapping.lookup (fold (\<lambda>n. Mapping.update n (g n)) xs m) x
  = (if (x \<in> set xs) then Some (g x) else Mapping.lookup m x)"
  by transfer (rule fold_update_conv)

lemma mapping_eq_iff: "m1 = m2 \<longleftrightarrow> (\<forall>k. Mapping.lookup m1 k = Mapping.lookup m2 k)"
  by transfer auto

lemma lookup_delete: "Mapping.lookup (Mapping.delete k m) k' = (if k = k' then None else Mapping.lookup m k')"
  by transfer auto

lemma keys_map_values: "Mapping.keys (map_values f m) = Mapping.keys m - {k\<in>Mapping.keys m. f k (the (Mapping.lookup m k)) = None}"
  by transfer (auto simp: Option.bind_def split: option.splits)

lemma map_default_eq: "Mapping.map_default k v f m = m \<longleftrightarrow> (\<exists>v. Mapping.lookup m k = Some v \<and> f v = v)"
  apply (clarsimp simp: Mapping.map_default_def Mapping.default_def)
  by transfer' (auto simp: fun_eq_iff split: if_splits)

lemma lookup_update_cases: "Mapping.lookup (Mapping.update k v m) k' = (if k=k' then Some v else Mapping.lookup m k')"
by (cases "k=k'", simp_all add: Mapping.lookup_update Mapping.lookup_update_neq)

end


section \<open>Verification Condition Testing\<close>

theory utp_hoare_total
  imports algebraic_laws_designs
begin
named_theorems hoare_total

subsection {*Hoare triple definition*}

definition hoare_rd :: "'\<alpha> cond \<Rightarrow> ('f,'\<alpha>) hrel_cp \<Rightarrow> '\<alpha> cond \<Rightarrow> bool" ("\<lbrace>_\<rbrace>_\<lbrace>_\<rbrace>\<^sub>D") where
[upred_defs]:"\<lbrace>p\<rbrace>Q\<lbrace>r\<rbrace>\<^sub>D =
  ((\<lceil>p\<rceil>\<^sub>C\<^sub>< \<and> $ok \<and> \<not>$abrupt \<and> \<not>$stuck \<and> \<not>$fault \<and> $fault_tr =\<^sub>u \<guillemotleft>None\<guillemotright> \<Rightarrow>
    \<lceil>r\<rceil>\<^sub>C\<^sub>> \<and> $ok\<acute> \<and> \<not>$abrupt\<acute> \<and> \<not>$stuck\<acute> \<and> \<not>$fault\<acute> \<and> $fault_tr\<acute> =\<^sub>u \<guillemotleft>None\<guillemotright>) \<sqsubseteq> Q)"

lemma hoare_true_t [hoare_total]:
  assumes "$ok \<sharp> C" "$abrupt \<sharp> C" "$stuck \<sharp> C" "$fault \<sharp> C" "$fault_tr \<sharp> C"
          "$ok\<acute> \<sharp> C" "$abrupt\<acute> \<sharp> C" "$stuck\<acute> \<sharp> C" "$fault\<acute> \<sharp> C" "$fault_tr\<acute> \<sharp> C"
  shows "\<lbrace>p\<rbrace>C\<lbrace>true\<rbrace>\<^sub>D"
 oops

lemma hoare_false_t [hoare_total]: "\<lbrace>false\<rbrace>C\<lbrace>q\<rbrace>\<^sub>D"
  by rel_auto

subsection {*Precondition strengthening*}

lemma hoare_pre_str_t[hoare_total]:
  assumes "`p\<^sub>1 \<Rightarrow> p\<^sub>2`" and "\<lbrace>p\<^sub>2\<rbrace>C\<lbrace>q\<rbrace>\<^sub>D"
  shows "\<lbrace>p\<^sub>1\<rbrace>C\<lbrace>q\<rbrace>\<^sub>D"
  by (insert assms) rel_auto

subsection {*Post-condition weakening*}

lemma hoare_post_weak_t[hoare_total]:
  assumes "\<lbrace>p\<rbrace>C\<lbrace>q\<^sub>2\<rbrace>\<^sub>D" and "`q\<^sub>2 \<Rightarrow> q\<^sub>1`"
  shows "\<lbrace>p\<rbrace>C\<lbrace>q\<^sub>1\<rbrace>\<^sub>D"
 by (insert assms) rel_auto

subsection {*Hoare and assertion logic*}

lemma hoare_r_conj_t [hoare_total]:
  assumes"\<lbrace>p\<rbrace>C\<lbrace>r\<rbrace>\<^sub>D" and "\<lbrace>p\<rbrace>C\<lbrace>s\<rbrace>\<^sub>D"
  shows "\<lbrace>p\<rbrace>C\<lbrace>r \<and> s\<rbrace>\<^sub>D"
  by (insert assms) rel_auto

subsection {*Hoare SKIP*}

lemma skip_hoare_r_t [hoare_total]: "\<lbrace>p\<rbrace>SKIP\<lbrace>p\<rbrace>\<^sub>D"
  by rel_auto

subsection {*Hoare for assignment*}

lemma assigns_hoare_r_t [hoare_total]:
  assumes"`p \<Rightarrow> \<sigma> \<dagger> q`"
  shows  "\<lbrace>p\<rbrace>\<langle>\<sigma>\<rangle>\<^sub>C\<lbrace>q\<rbrace>\<^sub>D"
  by (insert assms) rel_auto

lemma assigns_hoare_r'_t [hoare_total]: "\<lbrace>\<sigma> \<dagger> p\<rbrace>\<langle>\<sigma>\<rangle>\<^sub>C\<lbrace>p\<rbrace>\<^sub>D"
  by rel_auto

subsection {*Hoare for Sequential Composition*}

lemma seq_hoare_r_t [hoare_total]:
  assumes"\<lbrace>p\<rbrace>C\<^sub>1\<lbrace>s\<rbrace>\<^sub>D" and "\<lbrace>s\<rbrace>C\<^sub>2\<lbrace>r\<rbrace>\<^sub>D"
  shows"\<lbrace>p\<rbrace>C\<^sub>1 ;; C\<^sub>2\<lbrace>r\<rbrace>\<^sub>D"
  by (insert assms, rel_auto) metis+

subsection {*Hoare for Conditional*}

lemma cond_hoare_r_t [hoare_total]:
  assumes "\<lbrace>b \<and> p\<rbrace>C\<^sub>1\<lbrace>q\<rbrace>\<^sub>D" and "\<lbrace>\<not>b \<and> p\<rbrace>C\<^sub>2\<lbrace>q\<rbrace>\<^sub>D"
  shows "\<lbrace>p\<rbrace>C\<^sub>1 \<triangleleft> \<lceil>b\<rceil>\<^sub>C\<^sub>< \<triangleright> C\<^sub>2\<lbrace>q\<rbrace>\<^sub>D"
  by (insert assms, rel_auto) metis+

subsection {*Hoare for assert*}

lemma assert_hoare_r_t [hoare_total]:
  assumes "\<lbrace>c \<and> p\<rbrace>SKIP\<lbrace>q\<rbrace>\<^sub>D" and "\<lbrace>\<not>c \<and> p\<rbrace>\<bottom>\<^sub>D\<lbrace>q\<rbrace>\<^sub>D"
  shows "\<lbrace>p\<rbrace> c\<^sub>\<bottom>\<^sub>C \<lbrace>q\<rbrace>\<^sub>D"
  by (insert assms) rel_blast

subsection {*Hoare for assume*}

lemma assume_hoare_r_t [hoare_total]:
  assumes "\<lbrace>c \<and> p\<rbrace>SKIP\<lbrace>q\<rbrace>\<^sub>D" and "\<lbrace>\<not>c \<and> p\<rbrace>\<top>\<^sub>D\<lbrace>q\<rbrace>\<^sub>D"
  shows "\<lbrace>p\<rbrace>c\<^sup>\<top>\<^sup>C\<lbrace>q\<rbrace>\<^sub>D"
  by (insert assms) rel_blast

subsection {*Hoare for While-loop*}

lemma while_hoare_r_t [hoare_total]:
  assumes "\<lbrace>p \<and> b \<rbrace> C\<lbrace>p\<rbrace>\<^sub>D"
  shows "\<lbrace>p\<rbrace>while b do C od\<lbrace>\<not>b \<and> p\<rbrace>\<^sub>D"
  using assms
  by (simp add: While_def hoare_rd_def, rule_tac lfp_lowerbound)(rel_blast)

lemma while_hoare_r'_t [hoare_total]:
  assumes "\<lbrace>p \<and> b\<rbrace>C\<lbrace>p\<rbrace>\<^sub>D" and "`p \<and> \<not>b \<Rightarrow> q`"
  shows "\<lbrace>p\<rbrace>while b do C od\<lbrace>q\<rbrace>\<^sub>D"
  using assms
  by (metis hoare_post_weak_t while_hoare_r_t inf_commute)

lemma while_invr_hoare_r_t [hoare_total]:
  assumes "\<lbrace>p \<and> b\<rbrace>C\<lbrace>p\<rbrace>\<^sub>D" and "`pre \<Rightarrow> p`" and "`(\<not>b \<and> p) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while b invr p do C od\<lbrace>post\<rbrace>\<^sub>D"
  by (metis assms hoare_pre_str_t while_hoare_r'_t While_inv_def inf_commute)

end


theory MDEAK_examples_completeness
imports Main MDEAK_Core_SE MDEAK_SE MDEAK_examples
begin

lemma c1_f: "\<turnstile>d (a \<triangle>\<^sub>0 ((p)\<^sub>F) )\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F ((p)\<^sub>F))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: Atom)
  then have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S I\<^sub>S \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: Fdiam0_R Id_fa Top_R)
  then have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (I\<^sub>S ;\<^sub>S ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M) \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F ((p)\<^sub>F))\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: And_R Mon_fdiam0 \<open>\<turnstile>d a \<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S p \<^sub>F \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M p \<^sub>F \<^sub>S\<^sub>F\<^sub>M\<close>)
  then have "\<turnstile>d ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a)\<^sub>S\<^sub>F\<^sub>A \<unrhd>\<^sub>0\<^sub>S ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F ((p)\<^sub>F))\<^sub>S\<^sub>F\<^sub>M"
    using DH_fdiam0_f D_IL1_f I_1L_b by blast
  then show ?thesis
    by (simp add: DH_fdiam0_b Fdiam0_L)
qed

lemma c1_b: "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (((a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M) ;\<^sub>S (\<top>)\<^sub>S\<^sub>F\<^sub>M ) \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: Atom D_IR1_b Fdiam0_R Id_fa W_2L)
  then show ?thesis
    using And_L Conj_fdiam0 D_IR1_b D_IR1_f E_L Fdiam0_L by blast
qed

lemma c2_f: "\<turnstile>d (a \<rhd>\<^sub>0 (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (a \<rhd>\<^sub>0 (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a)\<^sub>S\<^sub>F\<^sub>A \<unrhd>\<^sub>0\<^sub>S ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: Atom DH_bdiam0_b Fbox0_L Id_fa)
  then show ?thesis
    by (simp add: DH_fdiam0_b D_IR1_b D_IR1_f E_L FS_bbox0 Fdiam0_L ImpR_R W_2L)
qed

lemma c2_b: "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M"
sledgehammer
proof -
  have "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F (p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a)\<^sub>S\<^sub>F\<^sub>A \<rhd>\<^sub>0\<^sub>S (I\<^sub>S \<rightarrow>\<^sub>S ((p)\<^sub>F)\<^sub>S\<^sub>F\<^sub>M)"
    by (simp add: Atom FS_fbox0 Fdiam0_R Id_fa ImpR_L Top_R)
  then show ?thesis
    using DH_bdiam0_b DH_bdiam0_f D_IL1_f D_IR1_b Fbox0_R I_1L_b by blast
qed

lemma c3: "\<turnstile>d (a \<triangle>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M"
by (simp add: AderivesA)

lemma c4_f: "\<turnstile>d (a \<rhd>\<^sub>0 \<bottom>)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F \<bottom>)\<^sub>S\<^sub>F\<^sub>M"
proof -
  have f1: "\<forall>f fa. \<not> \<turnstile>d f \<turnstile>\<^sub>F\<^sub>M I\<^sub>S \<or> \<turnstile>d f \<turnstile>\<^sub>F\<^sub>M fa"
    by (metis IW_R)
  have f2: "\<forall>f fa fb. \<not> \<turnstile>d f \<turnstile>\<^sub>F\<^sub>M fa \<rightarrow>\<^sub>S fb \<or> \<turnstile>d fa ;\<^sub>S f \<turnstile>\<^sub>F\<^sub>M fb"
    by (metis D_IR1_b)
  have f3: "\<forall>f fa fb. \<not> \<turnstile>d f ;\<^sub>S fa \<turnstile>\<^sub>F\<^sub>M fb \<or> \<turnstile>d fa ;\<^sub>S f \<turnstile>\<^sub>F\<^sub>M fb"
    by (metis E_L)
  have f4: "\<forall>f fa fb. \<not> \<turnstile>d f ;\<^sub>S fa \<turnstile>\<^sub>F\<^sub>M fb \<or> \<turnstile>d fa \<turnstile>\<^sub>F\<^sub>M f \<rightarrow>\<^sub>S fb"
    by (metis D_IR1_f)
  have "\<turnstile>d (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M a \<^sub>S\<^sub>F\<^sub>A \<rhd>\<^sub>0\<^sub>S I\<^sub>S"
    by (meson Bot_L Fbox0_L Id_fa)
  then have "\<turnstile>d a \<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M I\<^sub>S"
    by (metis DH_bdiam0_b)
  then have "\<turnstile>d \<top> \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M a \<^sub>S\<^sub>F\<^sub>A \<unrhd>\<^sub>0\<^sub>S ((a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<rightarrow>\<^sub>S \<bottom> \<^sub>S\<^sub>F\<^sub>M)"
    using f4 f3 f2 f1 by (meson FS_bbox0)
  then have "\<turnstile>d a \<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S \<top> \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<rightarrow>\<^sub>S \<bottom> \<^sub>S\<^sub>F\<^sub>M"
    by (metis DH_fdiam0_b)
  then have "\<turnstile>d (a \<triangle>\<^sub>0 \<top>) \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<rightarrow>\<^sub>S \<bottom> \<^sub>S\<^sub>F\<^sub>M"
    by (metis Fdiam0_L)
  then have "\<turnstile>d (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M ;\<^sub>S (a \<triangle>\<^sub>0 \<top>) \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M \<bottom> \<^sub>S\<^sub>F\<^sub>M"
    using f2 by metis
  then have "\<turnstile>d (a \<triangle>\<^sub>0 \<top>) \<^sub>S\<^sub>F\<^sub>M ;\<^sub>S (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M \<bottom> \<^sub>S\<^sub>F\<^sub>M"
    using f3 by meson
  then have "\<turnstile>d (a \<rhd>\<^sub>0 \<bottom>) \<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 \<top>) \<^sub>S\<^sub>F\<^sub>M \<rightarrow>\<^sub>S \<bottom> \<^sub>S\<^sub>F\<^sub>M"
    using f4 by metis
  then show ?thesis
    by (metis ImpR_R)
qed
(*by (meson Bot_L DH_bdiam2_b DH_fdiam2_b D_IR1_b D_IR1_f E_L FS_bbox2 Fbox2_L Fdiam2_L IW_R Id_ag ImpR_R)*)

lemma c4_b: "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F \<bottom>)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 \<bottom>)\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F \<bottom>)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a)\<^sub>S\<^sub>F\<^sub>A \<rhd>\<^sub>0\<^sub>S (I\<^sub>S \<rightarrow>\<^sub>S (\<bottom>)\<^sub>S\<^sub>F\<^sub>M)"
    using Bot_L FS_fbox0 Fdiam0_R IW_R Id_fa ImpR_L Top_R by blast
  then show ?thesis
    using DH_bdiam0_b DH_bdiam0_f D_IL1_f D_IR1_b Fbox0_R I_1L_b by blast
qed

lemma c5_f: "\<turnstile>d (a \<triangle>\<^sub>0 \<bottom>)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (\<bottom>)\<^sub>S\<^sub>F\<^sub>M"
using Bot_L DH_fdiam0_b Fdiam0_L IW_R by blast

lemma c5_b: "\<turnstile>d (\<bottom>)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 \<bottom>)\<^sub>S\<^sub>F\<^sub>M"
using [[simp_trace_new mode=full]]
by (simp add: Bot_L IW_R)

lemma c6_f: "\<turnstile>d (a \<rhd>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (\<top>)\<^sub>S\<^sub>F\<^sub>M"
using [[simp_trace_new mode=full]]
by (simp add: IW_L Top_R)

lemma c6_b: "\<turnstile>d (\<top>)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M"
using [[simp_trace_new mode=full]]
by (simp add: DH_bdiam0_f Fbox0_R IW_L Top_R)

lemma c7_f: "\<turnstile>d (a \<rhd>\<^sub>0 (A \<and>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<rhd>\<^sub>0 A) \<and>\<^sub>F (a \<rhd>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have f1:  "\<turnstile>d (a \<rhd>\<^sub>0 (A \<and>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 A)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA And_L D_IR1_b Fbox0_L Fbox0_R Id_fa W_2L)
  have f2: "\<turnstile>d (a \<rhd>\<^sub>0 (A \<and>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 B)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA And_L D_IL1_b Fbox0_L Fbox0_R Id_fa W_1L)
  show ?thesis
    using And_R C_L f1 f2 by blast
qed

lemma c7_b: "\<turnstile>d ((a \<rhd>\<^sub>0 A) \<and>\<^sub>F (a \<rhd>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 (A \<and>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (a \<rhd>\<^sub>0 A)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (A)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA DH_bdiam0_b Fbox0_L Id_fa)
  then show ?thesis
    by (simp add: AderivesA And_L And_R DH_bdiam0_b DH_bdiam0_f Fbox0_L Fbox0_R Id_fa Mon_bdiam0)
qed

lemma c8_f: "\<turnstile>d (a \<triangle>\<^sub>0 (A \<and>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 A) \<and>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M"
by (metis And_L And_R C_L D_IL1_b D_IR1_b Fdiam0_L Fdiam0_R Id_fa W_1L W_2L AderivesA)

(*lemma c8_f_simple: "\<turnstile>d (a \<triangle>\<^sub>2 ((A)\<^sub>F \<and>\<^sub>F (B)\<^sub>F))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>2 (A)\<^sub>F) \<and>\<^sub>F (a \<triangle>\<^sub>2 (B)\<^sub>F) )\<^sub>S\<^sub>F\<^sub>M"
by (metis And_L And_R C_L D_IL1_b D_IR1_b Fdiam2_L Fdiam2_R Id_ag Id_fm W_1L W_2L)*)

lemma c8_b: "\<turnstile>d ((a \<triangle>\<^sub>0 A) \<and>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (A \<and>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (A)\<^sub>S\<^sub>F\<^sub>M) ;\<^sub>S ((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (B)\<^sub>S\<^sub>F\<^sub>M)) \<turnstile>\<^sub>F\<^sub>M (A \<and>\<^sub>F B)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA And_R Balance Conj_fdiam0 DH_bdiam0_b)
  then show ?thesis
    by (simp add: And_L Conj_bdiam0 Conj_fdiam0 D_IL1_b D_IL1_f E_L Fdiam0_L Fdiam0_R Id_fa)
qed

lemma c9_f: "\<turnstile>d (a \<triangle>\<^sub>0 (A \<or>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 A) \<or>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (A)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a)\<^sub>S\<^sub>F\<^sub>A \<unrhd>\<^sub>0\<^sub>S (a \<triangle>\<^sub>0 A)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA DH_fdiam0_f Fdiam0_R Id_fa)
  then show ?thesis
    by (simp add: AderivesA DH_fdiam0_b DH_fdiam0_f Fdiam0_L Fdiam0_R Id_fa Mon_bbox0 Or_L Or_R)
qed

lemma c9_b: "\<turnstile>d ((a \<triangle>\<^sub>0 A) \<or>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (A \<or>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have f1: "\<turnstile>d (a \<triangle>\<^sub>0 A)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (A \<or>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M "
    by (simp add: AderivesA D_IR2_b Fdiam0_L Fdiam0_R Id_fa Or_R W_2R)
  have f2: "\<turnstile>d (a \<triangle>\<^sub>0 B)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (A \<or>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M "
    by (simp add: AderivesA D_IL2_b Fdiam0_L Fdiam0_R Id_fa Or_R W_1R)
  show ?thesis
    using C_R Or_L f1 f2 by blast
qed

lemma c10_f: "\<turnstile>d (a \<rhd>\<^sub>0 (A \<or>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M \<rightarrow>\<^sub>S ((a \<triangle>\<^sub>0 A) \<or>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M"
sledgehammer
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (A \<or>\<^sub>F B)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 A) \<or>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M "
    by (simp add: AderivesA DH_fdiam0_b DH_fdiam0_f Fdiam0_R Id_fa Mon_bbox0 Or_L Or_R)
  then show ?thesis
    by (simp add: DH_bdiam0_b DH_fdiam0_b DH_fdiam0_f D_IR1_b D_IR1_f E_L FS_bbox0 Fbox0_L Fdiam0_L W_2L derivable.intros(3))
qed

lemma c10_b: "\<turnstile>d (a \<triangle>\<^sub>0 \<top>)\<^sub>S\<^sub>F\<^sub>M \<rightarrow>\<^sub>S ((a \<triangle>\<^sub>0 A) \<or>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 (A \<or>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
by (meson DH_bdiam0_f DH_fdiam0_f FS_bdiam0 Fbox0_R Fdiam0_R IW_L Id_fa Top_R W_2R)

lemma c11_f: "\<turnstile>d (a \<triangle>\<^sub>0 (A \<rightarrow>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F ((a \<triangle>\<^sub>0 A)  \<rightarrow>\<^sub>F (a \<triangle>\<^sub>0 B)))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (A \<rightarrow>\<^sub>F B)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (((a \<triangle>\<^sub>0 A)  \<rightarrow>\<^sub>F (a \<triangle>\<^sub>0 B)))\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA Balance Conj_fdiam0 DH_bdiam0_b D_IR1_b D_IR1_f Fdiam0_L Fdiam0_R Id_fa ImpR_L ImpR_R)
  then show ?thesis
    by (meson And_R C_L Fdiam0_L Fdiam0_R IW_L Id_fa Top_R)
qed

lemma c11_b: "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F ((a \<triangle>\<^sub>0 A) \<rightarrow>\<^sub>F (a \<triangle>\<^sub>0 B)))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (A \<rightarrow>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S ((a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S ((a \<triangle>\<^sub>0 A) \<rightarrow>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M) \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (A \<rightarrow>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA Balance DH_bdiam0_b FS_fbox0 Fdiam0_L Fdiam0_R Id_fa ImpR_L ImpR_R)
  then show ?thesis
    by (simp add: And_L DH_fdiam0_b DH_fdiam0_f D_IR1_b E_L FS_bbox0 Fdiam0_L W_2L)
qed

lemma c12_f: "\<turnstile>d (a \<rhd>\<^sub>0 (A \<rightarrow>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 A) \<rightarrow>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (a \<rhd>\<^sub>0 (A \<rightarrow>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a)\<^sub>S\<^sub>F\<^sub>A \<unrhd>\<^sub>0\<^sub>S (((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (A)\<^sub>S\<^sub>F\<^sub>M) \<rightarrow>\<^sub>S (a \<triangle>\<^sub>0 B)\<^sub>S\<^sub>F\<^sub>M)"
    by (simp add: AderivesA Balance DH_bdiam0_b DH_fdiam0_f FS_bbox0 Fbox0_L Fdiam0_R Id_fa ImpR_L)
  then show ?thesis
    by (simp add: Conj_fdiam0 DH_fdiam0_b D_IR1_b D_IR1_f E_L Fdiam0_L ImpR_R Mon_fdiam0)
qed

lemma c12_b: "\<turnstile>d ((a \<triangle>\<^sub>0 A) \<rightarrow>\<^sub>F (a \<triangle>\<^sub>0 B))\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (a \<rhd>\<^sub>0 (A \<rightarrow>\<^sub>F B))\<^sub>S\<^sub>F\<^sub>M"
by (simp add: AderivesA Balance DH_bdiam0_b DH_bdiam0_f FS_fbox0 Fbox0_R Fdiam0_L Fdiam0_R Id_fa ImpR_L ImpR_R)

lemma c13: "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F (ag \<triangle>\<^sub>2 ((ag \<triangleq>\<^sub>3 a) \<triangle>\<^sub>1 A)))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (ag \<triangle>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M "
proof -
  have "\<turnstile>d (A)\<^sub>S\<^sub>F\<^sub>M  \<turnstile>\<^sub>F\<^sub>M (ag)\<^sub>S\<^sub>A\<^sub>G \<unrhd>\<^sub>2\<^sub>S ((a)\<^sub>S\<^sub>F\<^sub>A \<unrhd>\<^sub>0\<^sub>S (a \<triangle>\<^sub>0 ( ag \<triangle>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M)"
    by (simp add: AderivesA DH_fdiam0_f DH_fdiam2_f Fdiam0_R Fdiam2_R Id_ag Id_fa)
  then have "\<turnstile>d ((ag \<triangleq>\<^sub>3 a) \<triangle>\<^sub>1 A)\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (ag)\<^sub>S\<^sub>A\<^sub>G \<unrhd>\<^sub>2\<^sub>S (((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S I\<^sub>S) \<rightarrow>\<^sub>S (a \<triangle>\<^sub>0 (ag \<triangle>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M)"
    using Bdiam3_L DH_bla1_b DH_bla1_f DH_fdiam1_b Fdiam1_L Swapin_R by blast
  then show ?thesis
    by (meson And_L DH_fdiam0_b DH_fdiam0_f DH_fdiam2_b D_IL1_b D_IL1_f D_IR1_b Fdiam0_L Fdiam2_L IW_L)
qed

lemma c14: "\<turnstile>d (a \<rhd>\<^sub>0 (ag \<rhd>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<rightarrow>\<^sub>F (ag \<rhd>\<^sub>2 ((ag \<triangleq>\<^sub>3  a) \<rhd>\<^sub>1 A )))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d ((ag)\<^sub>S\<^sub>A\<^sub>G \<triangleq>\<^sub>3\<^sub>S (a)\<^sub>S\<^sub>F\<^sub>A) \<triangleq>\<^sub>1\<^sub>S ((ag)\<^sub>S\<^sub>A\<^sub>G \<triangleq>\<^sub>2\<^sub>S (((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S I\<^sub>S) ;\<^sub>S (a \<rhd>\<^sub>0 (ag \<rhd>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M)) \<turnstile>\<^sub>F\<^sub>M (A)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA DH_bdiam0_b DH_bdiam2_b Fbox0_L Fbox2_L Id_ag Id_fa Swapin_L)
  then show ?thesis
    by (meson Bdiam3_L DH_bdiam1_f DH_bdiam2_f DH_fdiam0_b DH_fdiam0_f DH_wla1_b DH_wla1_f D_IL1_b D_IL1_f D_IR1_f Fbox1_R Fbox2_R Fdiam0_L IW_L ImpR_R)
qed

lemma c15: "\<turnstile>d (a \<triangle>\<^sub>0 (ag \<rhd>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F (ag \<rhd>\<^sub>2 ((ag \<triangleq>\<^sub>3 a) \<rhd>\<^sub>1 A )))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (ag)\<^sub>S\<^sub>A\<^sub>G \<triangleq>\<^sub>2\<^sub>S ((a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S ((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (ag \<rhd>\<^sub>2 A)\<^sub>S\<^sub>F\<^sub>M)) \<turnstile>\<^sub>F\<^sub>M (A)\<^sub>S\<^sub>F\<^sub>M"
    by (simp add: AderivesA Balance DH_bdiam0_b DH_bdiam2_b Fbox2_L Id_ag)
  then have "\<turnstile>d (ag \<triangleq>\<^sub>3 a)\<^sub>S\<^sub>A\<^sub>C \<triangleq>\<^sub>1\<^sub>S ((ag)\<^sub>S\<^sub>A\<^sub>G \<triangleq>\<^sub>2\<^sub>S (((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S I\<^sub>S) ;\<^sub>S ((a)\<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (ag \<rhd>\<^sub>2 A)\<^sub>S\<^sub>F\<^sub>M))) \<turnstile>\<^sub>F\<^sub>M (A)\<^sub>S\<^sub>F\<^sub>M"
    using Bdiam3_L DH_wla1_b DH_wla1_f Swapin_L \<open>\<turnstile>d ag \<^sub>S\<^sub>A\<^sub>G \<triangleq>\<^sub>2\<^sub>S (a \<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (a \<^sub>S\<^sub>F\<^sub>A \<triangle>\<^sub>0\<^sub>S (ag \<rhd>\<^sub>2 A) \<^sub>S\<^sub>F\<^sub>M)) \<turnstile>\<^sub>F\<^sub>M A \<^sub>S\<^sub>F\<^sub>M\<close> by blast
  then show ?thesis
    by (metis And_R DH_bdiam1_f DH_bdiam2_f DH_fdiam0_b DH_fdiam0_f D_IL1_f Fbox1_R Fbox2_R Fdiam0_L Fdiam0_R I_1L_b Id_fa Mon_fdiam0 Top_R)
qed

lemma c16: "\<turnstile>d ((a \<triangle>\<^sub>0 \<top>) \<and>\<^sub>F (ag \<rhd>\<^sub>2 ((ag \<triangleq>\<^sub>3 a) \<rhd>\<^sub>1 A)))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (a \<triangle>\<^sub>0 (ag \<rhd>\<^sub>2 A))\<^sub>S\<^sub>F\<^sub>M"
proof -
  have "\<turnstile>d (a)\<^sub>S\<^sub>F\<^sub>A \<triangleq>\<^sub>0\<^sub>S (ag \<rhd>\<^sub>2 ((ag \<triangleq>\<^sub>3 a) \<rhd>\<^sub>1 A ))\<^sub>S\<^sub>F\<^sub>M \<turnstile>\<^sub>F\<^sub>M (ag \<rhd>\<^sub>2 A)\<^sub>S\<^sub>F\<^sub>M"
    by (meson AderivesA Bdiam3_R DH_bdiam1_b DH_bdiam2_b DH_bdiam2_f Fbox1_L Fbox2_L Fbox2_R Id_ag Id_fa Swapout_L)
  then show ?thesis
    by (simp add: And_L DH_fdiam0_b DH_fdiam0_f D_IR1_b E_L FS_bbox0 Fdiam0_L Fdiam0_R Id_fa W_2L)
qed


(*  Title:      ZF/UNITY/ClientImpl.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2002  University of Cambridge

Distributed Resource Management System:  Client Implementation.
*)

theory ClientImpl imports AllocBase Guar begin

abbreviation "ask \<equiv> Var(Nil)" (* input history:  tokens requested *)
abbreviation "giv \<equiv> Var([0])" (* output history: tokens granted *)
abbreviation "rel \<equiv> Var([1])" (* input history: tokens released *)
abbreviation "tok \<equiv> Var([2])" (* the number of available tokens *)

axiomatization where
  type_assumes:
  "type_of(ask) = list(tokbag) \<and> type_of(giv) = list(tokbag) \<and>
   type_of(rel) = list(tokbag) \<and> type_of(tok) = nat" and
  default_val_assumes:
  "default_val(ask) = Nil \<and> default_val(giv) = Nil \<and>
   default_val(rel) = Nil \<and> default_val(tok) = 0"

(*Array indexing is translated to list indexing as A[n] \<equiv> nth(n-1,A). *)

definition
 (** Release some client_tokens **)
    "client_rel_act \<equiv>
     {\<langle>s,t\<rangle> \<in> state*state.
      \<exists>nrel \<in> nat. nrel = length(s`rel) \<and>
                   t = s(rel:=(s`rel)@[nth(nrel, s`giv)]) \<and>
                   nrel < length(s`giv) \<and>
                   nth(nrel, s`ask) \<le> nth(nrel, s`giv)}"

  (** Choose a new token requirement **)
  (** Including t=s suppresses fairness, allowing the non-trivial part
      of the action to be ignored **)
definition
  "client_tok_act \<equiv> {\<langle>s,t\<rangle> \<in> state*state. t=s |
                     t = s(tok:=succ(s`tok mod NbT))}"

definition
  "client_ask_act \<equiv> {\<langle>s,t\<rangle> \<in> state*state. t=s | (t=s(ask:=s`ask@[s`tok]))}"

definition
  "client_prog \<equiv>
   mk_program({s \<in> state. s`tok \<le> NbT \<and> s`giv = Nil \<and>
                       s`ask = Nil \<and> s`rel = Nil},
                    {client_rel_act, client_tok_act, client_ask_act},
                   \<Union>G \<in> preserves(lift(rel)) Int
                         preserves(lift(ask)) Int
                         preserves(lift(tok)).  Acts(G))"

declare type_assumes [simp] default_val_assumes [simp]
(* This part should be automated *)

lemma ask_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`ask \<in> list(nat)"
  unfolding state_def
apply (drule_tac a = ask in apply_type, auto)
done

lemma giv_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`giv \<in> list(nat)"
  unfolding state_def
apply (drule_tac a = giv in apply_type, auto)
done

lemma rel_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`rel \<in> list(nat)"
  unfolding state_def
apply (drule_tac a = rel in apply_type, auto)
done

lemma tok_value_type [simp,TC]: "s \<in> state \<Longrightarrow> s`tok \<in> nat"
  unfolding state_def
apply (drule_tac a = tok in apply_type, auto)
done

(** The Client Program **)

lemma client_type [simp,TC]: "client_prog \<in> program"
  unfolding client_prog_def
apply (simp (no_asm))
done

declare client_prog_def [THEN def_prg_Init, simp]
declare client_prog_def [THEN def_prg_AllowedActs, simp]
declare client_prog_def [program]

declare  client_rel_act_def [THEN def_act_simp, simp]
declare  client_tok_act_def [THEN def_act_simp, simp]
declare  client_ask_act_def [THEN def_act_simp, simp]

lemma client_prog_ok_iff:
  "\<forall>G \<in> program. (client_prog ok G) \<longleftrightarrow>
   (G \<in> preserves(lift(rel)) \<and> G \<in> preserves(lift(ask)) \<and>
    G \<in> preserves(lift(tok)) \<and>  client_prog \<in> Allowed(G))"
by (auto simp add: ok_iff_Allowed client_prog_def [THEN def_prg_Allowed])

lemma client_prog_preserves:
    "client_prog:(\<Inter>x \<in> var-{ask, rel, tok}. preserves(lift(x)))"
apply (rule Inter_var_DiffI, force)
apply (rule ballI)
apply (rule preservesI, safety, auto)
done

lemma preserves_lift_imp_stable:
     "G \<in> preserves(lift(ff)) \<Longrightarrow> G \<in> stable({s \<in> state. P(s`ff)})"
apply (drule preserves_imp_stable)
apply (simp add: lift_def)
done

lemma preserves_imp_prefix:
     "G \<in> preserves(lift(ff))
      \<Longrightarrow> G \<in> stable({s \<in> state. \<langle>k, s`ff\<rangle> \<in> prefix(nat)})"
by (erule preserves_lift_imp_stable)

(*Safety property 1 \<in> ask, rel are increasing: (24) *)
lemma client_prog_Increasing_ask_rel:
"client_prog: program guarantees Incr(lift(ask)) \<inter> Incr(lift(rel))"
  unfolding guar_def
apply (auto intro!: increasing_imp_Increasing
            simp add: client_prog_ok_iff Increasing.increasing_def preserves_imp_prefix)
apply (safety, force, force)+
done

declare nth_append [simp] append_one_prefix [simp]

lemma NbT_pos2: "0<NbT"
apply (cut_tac NbT_pos)
apply (rule Ord_0_lt, auto)
done

(*Safety property 2 \<in> the client never requests too many tokens.
With no Substitution Axiom, we must prove the two invariants simultaneously. *)

lemma ask_Bounded_lemma:
"\<lbrakk>client_prog ok G; G \<in> program\<rbrakk>
      \<Longrightarrow> client_prog \<squnion> G \<in>
              Always({s \<in> state. s`tok \<le> NbT}  \<inter>
                      {s \<in> state. \<forall>elt \<in> set_of_list(s`ask). elt \<le> NbT})"
apply (rotate_tac -1)
apply (auto simp add: client_prog_ok_iff)
apply (rule invariantI [THEN stable_Join_Always2], force)
 prefer 2
 apply (fast intro: stable_Int preserves_lift_imp_stable, safety)
apply (auto dest: ActsD)
apply (cut_tac NbT_pos)
apply (rule NbT_pos2 [THEN mod_less_divisor])
apply (auto dest: ActsD preserves_imp_eq simp add: set_of_list_append)
done

(* Export version, with no mention of tok in the postcondition, but
  unfortunately tok must be declared local.*)
lemma client_prog_ask_Bounded:
    "client_prog \<in> program guarantees
                   Always({s \<in> state. \<forall>elt \<in> set_of_list(s`ask). elt \<le> NbT})"
apply (rule guaranteesI)
apply (erule ask_Bounded_lemma [THEN Always_weaken], auto)
done

(*** Towards proving the liveness property ***)

lemma client_prog_stable_rel_le_giv:
    "client_prog \<in> stable({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
by (safety, auto)

lemma client_prog_Join_Stable_rel_le_giv:
"\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); G \<in> preserves(lift(rel))\<rbrakk>
    \<Longrightarrow> client_prog \<squnion> G \<in> Stable({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
apply (rule client_prog_stable_rel_le_giv [THEN Increasing_preserves_Stable])
apply (auto simp add: lift_def)
done

lemma client_prog_Join_Always_rel_le_giv:
     "\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); G \<in> preserves(lift(rel))\<rbrakk>
    \<Longrightarrow> client_prog \<squnion> G  \<in> Always({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
by (force intro!: AlwaysI client_prog_Join_Stable_rel_le_giv)

lemma def_act_eq:
     "A \<equiv> {\<langle>s, t\<rangle> \<in> state*state. P(s, t)} \<Longrightarrow> A={\<langle>s, t\<rangle> \<in> state*state. P(s, t)}"
by auto

lemma act_subset: "A={\<langle>s,t\<rangle> \<in> state*state. P(s, t)} \<Longrightarrow> A<=state*state"
by auto

lemma transient_lemma:
"client_prog \<in>
  transient({s \<in> state. s`rel = k \<and> \<langle>k, h\<rangle> \<in> strict_prefix(nat)
   \<and> <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask})"
apply (rule_tac act = client_rel_act in transientI)
apply (simp (no_asm) add: client_prog_def [THEN def_prg_Acts])
apply (simp (no_asm) add: client_rel_act_def [THEN def_act_eq, THEN act_subset])
apply (auto simp add: client_prog_def [THEN def_prg_Acts] domain_def)
apply (rule ReplaceI)
apply (rule_tac x = "x (rel:= x`rel @ [nth (length (x`rel), x`giv) ]) " in exI)
apply (auto intro!: state_update_type app_type length_type nth_type, auto)
apply (blast intro: lt_trans2 prefix_length_le strict_prefix_length_lt)
apply (blast intro: lt_trans2 prefix_length_le strict_prefix_length_lt)
apply (simp (no_asm_use) add: gen_prefix_iff_nth)
apply (subgoal_tac "h \<in> list(nat)")
 apply (simp_all (no_asm_simp) add: prefix_type [THEN subsetD, THEN SigmaD1])
apply (auto simp add: prefix_def Ge_def)
apply (drule strict_prefix_length_lt)
apply (drule_tac x = "length (x`rel) " in spec)
apply auto
apply (simp (no_asm_use) add: gen_prefix_iff_nth)
apply (auto simp add: id_def lam_def)
done

lemma strict_prefix_is_prefix:
    "\<langle>xs, ys\<rangle> \<in> strict_prefix(A) \<longleftrightarrow>  \<langle>xs, ys\<rangle> \<in> prefix(A) \<and> xs\<noteq>ys"
  unfolding strict_prefix_def id_def lam_def
apply (auto dest: prefix_type [THEN subsetD])
done

lemma induct_lemma:
"\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); client_prog ok G; G \<in> program\<rbrakk>
  \<Longrightarrow> client_prog \<squnion> G \<in>
  {s \<in> state. s`rel = k \<and> \<langle>k,h\<rangle> \<in> strict_prefix(nat)
   \<and> <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask}
        \<longmapsto>w {s \<in> state. <k, s`rel> \<in> strict_prefix(nat)
                          \<and> <s`rel, s`giv> \<in> prefix(nat) \<and>
                                  <h, s`giv> \<in> prefix(nat) \<and>
                h pfixGe s`ask}"
apply (rule single_LeadsTo_I)
 prefer 2 apply simp
apply (frule client_prog_Increasing_ask_rel [THEN guaranteesD])
apply (rotate_tac [3] 2)
apply (auto simp add: client_prog_ok_iff)
apply (rule transient_lemma [THEN Join_transient_I1, THEN transient_imp_leadsTo, THEN leadsTo_imp_LeadsTo, THEN PSP_Stable, THEN LeadsTo_weaken])
apply (rule Stable_Int [THEN Stable_Int, THEN Stable_Int])
apply (erule_tac f = "lift (giv) " and a = "s`giv" in Increasing_imp_Stable)
apply (simp (no_asm_simp))
apply (erule_tac f = "lift (ask) " and a = "s`ask" in Increasing_imp_Stable)
apply (simp (no_asm_simp))
apply (erule_tac f = "lift (rel) " and a = "s`rel" in Increasing_imp_Stable)
apply (simp (no_asm_simp))
apply (erule client_prog_Join_Stable_rel_le_giv, blast, simp_all)
 prefer 2
 apply (blast intro: sym strict_prefix_is_prefix [THEN iffD2] prefix_trans prefix_imp_pfixGe pfixGe_trans)
apply (auto intro: strict_prefix_is_prefix [THEN iffD1, THEN conjunct1]
                   prefix_trans)
done

lemma rel_progress_lemma:
"\<lbrakk>client_prog \<squnion> G  \<in> Incr(lift(giv)); client_prog ok G; G \<in> program\<rbrakk>
  \<Longrightarrow> client_prog \<squnion> G  \<in>
     {s \<in> state. <s`rel, h> \<in> strict_prefix(nat)
           \<and> <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask}
                      \<longmapsto>w {s \<in> state. <h, s`rel> \<in> prefix(nat)}"
apply (rule_tac f = "\<lambda>x \<in> state. length(h) #- length(x`rel)"
       in LessThan_induct)
apply (auto simp add: vimage_def)
 prefer 2 apply (force simp add: lam_def)
apply (rule single_LeadsTo_I)
 prefer 2 apply simp
apply (subgoal_tac "h \<in> list(nat)")
 prefer 2 apply (blast dest: prefix_type [THEN subsetD])
apply (rule induct_lemma [THEN LeadsTo_weaken])
    apply (simp add: length_type lam_def)
apply (auto intro: strict_prefix_is_prefix [THEN iffD2]
            dest: common_prefix_linear  prefix_type [THEN subsetD])
apply (erule swap)
apply (rule imageI)
 apply (force dest!: simp add: lam_def)
apply (simp add: length_type lam_def, clarify)
apply (drule strict_prefix_length_lt)+
apply (drule less_imp_succ_add, simp)+
apply clarify
apply simp
apply (erule diff_le_self [THEN ltD])
done

lemma progress_lemma:
"\<lbrakk>client_prog \<squnion> G \<in> Incr(lift(giv)); client_prog ok G; G \<in> program\<rbrakk>
 \<Longrightarrow> client_prog \<squnion> G
       \<in> {s \<in> state. <h, s`giv> \<in> prefix(nat) \<and> h pfixGe s`ask}
         \<longmapsto>w  {s \<in> state. <h, s`rel> \<in> prefix(nat)}"
apply (rule client_prog_Join_Always_rel_le_giv [THEN Always_LeadsToI],
       assumption)
apply (force simp add: client_prog_ok_iff)
apply (rule LeadsTo_weaken_L)
apply (rule LeadsTo_Un [OF rel_progress_lemma
                           subset_refl [THEN subset_imp_LeadsTo]])
apply (auto intro: strict_prefix_is_prefix [THEN iffD2]
            dest: common_prefix_linear prefix_type [THEN subsetD])
done

(*Progress property: all tokens that are given will be released*)
lemma client_prog_progress:
"client_prog \<in> Incr(lift(giv))  guarantees
      (\<Inter>h \<in> list(nat). {s \<in> state. <h, s`giv> \<in> prefix(nat) \<and>
              h pfixGe s`ask} \<longmapsto>w {s \<in> state. <h, s`rel> \<in> prefix(nat)})"
apply (rule guaranteesI)
apply (blast intro: progress_lemma, auto)
done

lemma client_prog_Allowed:
     "Allowed(client_prog) =
      preserves(lift(rel)) \<inter> preserves(lift(ask)) \<inter> preserves(lift(tok))"
apply (cut_tac v = "lift (ask)" in preserves_type)
apply (auto simp add: Allowed_def client_prog_def [THEN def_prg_Allowed]
                      cons_Int_distrib safety_prop_Acts_iff)
done

end


section{*HBD Translation Algorithms that use Feedback Composition*}

(* Was: AlgorithmFeedback.thy *)

theory HBDTranslationsUsingFeedback imports HBDTranslationProperties "Refinement"
begin

context BaseOperationVars
begin

  (*The nondeterministic Algorithm that uses the feedback, serial, and parallel operations*)
  definition "TranslateHBD =
    while_stm (\<lambda> As . length As > 1)(
      [:As \<leadsto> As' . \<exists> Bs Cs . 1 < length Bs \<and> perm As (Bs @ Cs) \<and> As' = FB (Parallel_list Bs) # Cs:]
      \<sqinter>
      [:As \<leadsto> As' . \<exists> A B Bs . perm As (A # B # Bs) \<and> As' = (FB (FB A ;; FB B)) # Bs:]
     )
   o [-(\<lambda> As . FB(As ! 0))-]"

  definition "invariant As_init n As = (length As = n \<and> io_distinct As \<and>  in_out_equiv (FB (Parallel_list As)) (FB (Parallel_list As_init)) \<and> n \<ge> 1)"

  lemma io_diagram_Parallel_list: "\<forall> A \<in> set As . io_diagram A \<Longrightarrow> distinct (concat (map Out As)) \<Longrightarrow> io_diagram (Parallel_list As)"
    proof (induction As)
    case Nil
    from Nil show ?case by simp
    next
    case (Cons A As)
    show ?case
      apply (simp)
      apply (rule io_diagram_Parallel)
      using Cons(2) apply simp
      using Cons apply simp
      using Cons(3) apply auto
      by (simp add: Out_Parallel)
    qed

  lemma io_diagram_Parallel_list_a: "io_distinct As \<Longrightarrow> io_diagram (Parallel_list As)"
    apply (rule_tac io_diagram_Parallel_list)
    by (simp_all add: io_distinct_def)

  thm Parallel_list_cons

  thm Parallel_assoc_gen

  thm ParallelId_left
  thm io_diagram_Parallel_list

lemma Parallel_list_append: "\<forall> A \<in> set As . io_diagram A \<Longrightarrow> distinct (concat (map Out As)) \<Longrightarrow> \<forall> A \<in> set Bs . io_diagram A
      \<Longrightarrow> distinct (concat (map Out Bs))\<Longrightarrow>
      Parallel_list (As @ Bs) = Parallel_list As ||| Parallel_list Bs"
    proof (induction As)
      case Nil
      from Nil show ?case
        apply (simp )
        apply (subst ParallelId_left, simp_all)
        by (rule io_diagram_Parallel_list, simp_all)
      next
      case (Cons A As)
      from Cons show ?case
        apply simp
        apply (subst Parallel_assoc_gen, simp_all)
        apply (rule io_diagram_Parallel_list, simp_all)
        by (rule io_diagram_Parallel_list, simp_all)
    qed

  primrec sequence :: "nat \<Rightarrow> nat list" where
    "sequence 0 = []" |
    "sequence (Suc n) = sequence n @ [n]"

  lemma "sequence (Suc (Suc 0)) = [0,1]"
    by auto

  lemma in_out_equiv_io_diagram[simp]: "in_out_equiv A B \<Longrightarrow> io_diagram B \<Longrightarrow> io_diagram A"
    apply (unfold io_diagram_def)
    apply (simp add:  in_out_equiv_def, safe)
    using dist_perm perm_sym apply blast
    using dist_perm perm_sym by blast

  thm comp_parallel_distrib

  lemma in_out_equiv_Parallel_cong_right: "io_diagram A \<Longrightarrow> io_diagram C \<Longrightarrow> set (Out A) \<inter> set (Out B) = {} \<Longrightarrow> in_out_equiv B C
    \<Longrightarrow> in_out_equiv (A ||| B) (A ||| C)"
    proof -
      assume "io_diagram A"
      from this have [simp]: "TVs (In A) = TI (Trs A)" and [simp]: " TVs (Out A) = TO (Trs A)" and [simp]: "distinct (In A)" and [simp]: "distinct (Out A)"
        by (unfold io_diagram_def, simp_all)
      assume A: "io_diagram C"
      from this have [simp]: "TVs (In C) = TI (Trs C)" and [simp]: " TVs (Out C) = TO (Trs C)" and [simp]: "distinct (In C)" and [simp]: "distinct (Out C)"
        by (unfold io_diagram_def, simp_all)
      assume "set (Out A) \<inter> set (Out B) = {}"
      assume B: "in_out_equiv B C"
      from this have [simp]: "perm (In B) (In C)" and [simp]: "perm (Out B) (Out C)" and [simp]: "Trs B = [In B \<leadsto> In C] oo Trs C oo [Out C \<leadsto> Out B]"
        by (simp_all add: in_out_equiv_def)

      from A and B have "io_diagram B"
        by simp
      from this have [simp]: "TVs (In B) = TI (Trs B)" and [simp]: " TVs (Out B) = TO (Trs B)" and [simp]: "distinct (In B)" and [simp]: "distinct (Out B)"
        by (unfold io_diagram_def, simp_all)

      have [simp]: "[In A \<oplus> In B \<leadsto> In A \<oplus> In C] oo ([In A \<oplus> In C \<leadsto> In A @ In C] oo (parallel (Trs A) (Trs C))) oo [Out A @ Out C \<leadsto> Out A @ Out B] =
        [In A \<oplus> In B \<leadsto> In A \<oplus> In C] oo [In A \<oplus> In C \<leadsto> In A @ In C] oo parallel (Trs A) (Trs C) oo [Out A @ Out C \<leadsto> Out A @ Out B]"
        by (simp add: comp_assoc)
      have [simp]: "... = [In A \<oplus> In B \<leadsto> In A @ In C] oo parallel (Trs A) (Trs C) oo [Out A @ Out C \<leadsto> Out A @ Out B]"
         by (subst switch_comp, simp_all)
      have "[In A \<oplus> In B \<leadsto> In A @ In B] oo parallel (Trs A) ([In B \<leadsto> In C] oo Trs C oo [Out C \<leadsto> Out B])
          = [In A \<oplus> In B \<leadsto> In A @ In B] oo parallel ([In A \<leadsto> In A] oo Trs A oo [Out A \<leadsto> Out A]) ([In B \<leadsto> In C] oo Trs C oo [Out C \<leadsto> Out B])"
        by simp
      also have "... = [In A \<oplus> In B \<leadsto> In A @ In B] oo (
                    parallel [In A \<leadsto> In A] [In B \<leadsto> In C] oo parallel (Trs A) (Trs C) oo parallel [Out A \<leadsto> Out A] [Out C \<leadsto> Out B])"
        apply (subst comp_parallel_distrib [THEN sym])
        apply simp_all [2]
        apply (subst comp_parallel_distrib [THEN sym])
        by simp_all
      also have " ... =  [In A \<oplus> In B \<leadsto> In A @ In B] oo (
                   parallel [In A \<leadsto> In A] [In B \<leadsto> In C] oo parallel (Trs A) (Trs C) oo[Out A @ Out C \<leadsto> Out A @ Out B])"
        by (metis \<open>distinct (Out A)\<close> \<open>distinct (Out C)\<close> \<open>perm (Out B) (Out C)\<close> \<open>set (Out A) \<inter> set (Out B) = {}\<close> distinct_append order_refl par_switch perm_set_eq)
      also have "... = [In A \<oplus> In B \<leadsto> In A @ In B] oo parallel [In A \<leadsto> In A] [In B \<leadsto> In C]
        oo parallel (Trs A) (Trs C) oo[Out A @ Out C \<leadsto> Out A @ Out B]"
        apply (subst comp_assoc, simp_all)
        apply (subst comp_assoc)
        apply (subst TI_par)
        using TI_switch TO_switch TVs_append apply presburger
        apply simp
        apply (subst comp_assoc)
        using TI_comp TI_par TI_switch TO_par TO_switch TVs_append \<open>TVs (In A) = TI (Trs A)\<close> \<open>TVs (In C) = TI (Trs C)\<close> apply presburger
        apply simp
        by (subst comp_assoc, simp_all)

     also have "... = [In A \<oplus> In B \<leadsto> In A @ In C] oo parallel (Trs A) (Trs C) oo[Out A @ Out C \<leadsto> Out A @ Out B]"
      by (simp add: Trs_Parallel_list_aux_b)

      finally show "in_out_equiv (A ||| B) (A ||| C)"
        by (simp add: in_out_equiv_def Parallel_def)
    qed

  lemma perm_map: "perm x y \<Longrightarrow> perm (map f x) (map f y)"
    by (simp add: perm_mset)

  lemma distinct_concat_perm: "\<And> Y . distinct (concat X) \<Longrightarrow> perm X Y \<Longrightarrow> distinct (concat Y)"
    proof (induction X)
      case Nil
      from Nil show ?case by simp
      next
      case (Cons a X)
      from Cons(3) obtain A B where [simp]: "Y = A @ a #B" and [simp]: "perm X (A @ B)"
        by (simp add: split_perm, blast)
      from Cons(1) have "distinct (concat X) \<Longrightarrow> perm X (A @ B) \<Longrightarrow> distinct (concat (A @ B)) "
        by blast
      from this and Cons(2) have A: "distinct (concat (A @ B))" by simp
      from Cons(2) have "distinct (concat X)" by simp
      from Cons(2) have [simp]: "distinct a" by simp
      have "set (X) = set (A @ B)"
        using \<open>perm X (A @ B)\<close> perm_set_eq by blast
      from this and Cons(2) show ?case
        using A apply simp
        by auto
    qed

  lemma distinct_Par_equiv_a: "\<And> Bs . \<forall> A \<in> set As . io_diagram A \<Longrightarrow> distinct (concat (map Out As)) \<Longrightarrow> perm As Bs \<Longrightarrow>
      in_out_equiv (Parallel_list As) (Parallel_list Bs)"

    proof (induction As)
      case Nil
      from  \<open>perm [] Bs\<close> show ?case
      apply (simp)
      by (rule in_out_equiv_refl, simp)
      next
      case (Cons A As)
      have "A \<in> set Bs"
        using Cons.prems(3) perm_set_eq by fastforce
      from this obtain Cs Ds where A: "Bs = Cs @ A # Ds"
        by (metis split_list)

      have [simp]: " perm As (Ds @ Cs)"
        using Cons(4) and A
          by (simp add: perm_mset)

        have [simp]: "\<forall> A \<in> set Cs . io_diagram A"
          using A Cons.prems(1) Cons.prems(3) perm_set_eq by fastforce
      have [simp]: "\<forall> A \<in> set Ds . io_diagram A"
          using A Cons.prems(1) Cons.prems(3) perm_set_eq by fastforce
      have B: "distinct (concat (map Out Bs))"
        apply (rule distinct_concat_perm)
        apply (rule  Cons(3))
        apply (rule perm_map)
        using Cons(4) by simp
      from this and A have [simp]: "distinct (concat (map Out Cs))"
        by simp
      from B and A have [simp]: "distinct (concat (map Out Ds))"
        by simp
      have [simp]: "io_diagram A"
        using Cons(2) by simp
      from this have [simp]: "distinct (Out A)"
        by (unfold io_diagram_def, simp)
      have [simp]: " io_diagram (Parallel_list Ds)"
        by (rule io_diagram_Parallel_list, simp_all)
      have [simp]: "io_diagram (Parallel_list Cs)"
        by (rule io_diagram_Parallel_list, simp_all)
      have [simp]: "set (Out A) \<inter> set (Out (Parallel_list As)) = {}"
        using Cons(3) by (simp add: Out_Parallel)
      have [simp]: "\<forall> A \<in> set As . io_diagram A"
        using Cons(2) by simp
      have [simp]:"distinct (concat (map Out As))"
        using Cons(3) by simp

      from B and A have [simp]: "set (Out A) \<inter> (\<Union>a\<in>set Ds. set (Out a)) = {}"
        by simp
      have [simp]: "set (Out A) \<inter> set (Out (Parallel_list Ds)) = {}"
        by (simp add: Out_Parallel)

      from B and A have [simp]: "set (Out (Parallel_list Ds)) \<inter> set (Out (Parallel_list Cs)) = {}"
        by (simp add: Out_Parallel, auto)

      from B and A have [simp]: "set (Out (Parallel_list Cs)) \<inter> set (Out A) = {}"
        by (simp add: Out_Parallel)

     from B and A have [simp]: "set (Out (Parallel_list Cs)) \<inter> set (Out (Parallel_list Ds)) = {}"
        by (simp add: Out_Parallel)

     from B and A have [simp]:"(set (Out A) \<union> set (Out (Parallel_list Ds))) \<inter> set (Out (Parallel_list Cs)) = {}"
        by (simp add: Out_Parallel, auto)
      have [simp]:"io_diagram (A ||| Parallel_list Ds)"
        by (rule io_diagram_Parallel, simp_all)
      from Cons(1)
        have "in_out_equiv (Parallel_list As) (Parallel_list (Ds @ Cs))"
        by simp
      from this have [simp]: "in_out_equiv (Parallel_list As) (Parallel_list Ds ||| (Parallel_list Cs))"
        by (simp add: Parallel_list_append)
      have [simp]:"io_diagram (Parallel_list Ds ||| Parallel_list Cs)"
        by (rule io_diagram_Parallel, simp_all)
      have [simp]: "io_diagram (Parallel_list As)"
        by (rule io_diagram_Parallel_list, simp_all)
      have [simp]: "io_diagram (A ||| Parallel_list As)"
        by (rule io_diagram_Parallel, simp_all)
      have [simp]: "io_diagram (A ||| Parallel_list Ds ||| Parallel_list Cs)"
        by (rule io_diagram_Parallel, simp_all)
      have [simp]: "io_diagram (Parallel_list Cs ||| (A ||| Parallel_list Ds))"
        by (rule io_diagram_Parallel, simp_all)

       from A show ?case
        apply (simp_all add: Parallel_list_append)
        apply (rule_tac B = "(A ||| Parallel_list Ds) ||| Parallel_list Cs" in in_out_equiv_tran, simp_all)
        apply (subst Parallel_assoc_gen, simp_all)
        apply (rule in_out_equiv_Parallel_cong_right, simp_all)
        by (rule in_out_equiv_Parallel, simp_all)
    qed

  thm distinct_concat_perm
  thm perm_map

  lemma distinct_FB: "distinct (In A) \<Longrightarrow> distinct (In (FB A))"
    by (simp add: FB_def Let_def)

  lemma io_distinct_FB_cat: "io_distinct (A # Cs) \<Longrightarrow> io_distinct (FB A # Cs)"
    apply (simp add: io_distinct_def)
    apply safe
    apply (simp_all add: FB_def Let_def set_diff) [4]
    apply auto [2]
    by (rule Type_ok_FB, simp)

  lemma io_distinct_perm: "io_distinct As \<Longrightarrow> perm As Bs \<Longrightarrow> io_distinct Bs"
    apply (simp add: io_distinct_def)
    apply safe
    apply (rule distinct_concat_perm)
    apply (simp_all)
    apply (rule perm_map, simp)
    apply (rule_tac X = "map Out As" in distinct_concat_perm, simp_all)
     apply (rule perm_map, simp)
      using perm_set_eq by blast

  lemma [simp]: "distinct (concat X) \<Longrightarrow> op_list [] (\<oplus>) (X) = concat X"
    apply (induction X, simp_all)
    by (simp add: addvars_distinct)

  lemma [simp]: "io_distinct As \<Longrightarrow> perm As (Bs @ Cs) \<Longrightarrow> io_distinct (FB (Parallel_list Bs) # Cs)"
    apply (rule io_distinct_FB_cat)
    apply (drule_tac Bs = "Bs @ Cs" in io_distinct_perm, simp_all)
    apply (simp add: io_distinct_def In_Parallel Out_Parallel)
    apply safe
    by (rule io_diagram_Parallel_list, simp_all)

  lemma io_distinct_append_a: "io_distinct As \<Longrightarrow> perm As (Bs @ Cs) \<Longrightarrow> io_distinct Bs"
    apply (drule_tac Bs = "Bs @ Cs" in io_distinct_perm, simp_all)
    by (simp add: io_distinct_def)

  lemma io_distinct_append_b: "io_distinct As \<Longrightarrow> perm As (Bs @ Cs) \<Longrightarrow> io_distinct Cs"
    apply (drule_tac Bs = "Bs @ Cs" in io_distinct_perm, simp_all)
    by (simp add: io_distinct_def)

  lemma [simp]: "io_distinct As \<Longrightarrow> perm As (Bs @ Cs) \<Longrightarrow> io_diagram (FB (FB (Parallel_list Bs) ||| Parallel_list Cs))"
    apply (rule Type_ok_FB)
    apply (rule io_diagram_Parallel)
    apply (rule Type_ok_FB)
    apply (drule io_distinct_append_a, simp_all)
    apply (simp add: io_diagram_Parallel_list_a)
    apply (drule io_distinct_append_b, simp_all)
    apply (simp add: io_diagram_Parallel_list_a)
    apply (subgoal_tac " set (Out ((Parallel_list Bs))) \<inter> set (Out (Parallel_list Cs)) = {}")
    apply (subgoal_tac "set (Out (FB (Parallel_list Bs))) \<subseteq> set (Out ((Parallel_list Bs)))")
    apply auto [1]
    apply (simp add: FB_def Let_def)
    apply (simp add: Out_Parallel)
    apply (drule io_distinct_perm, simp_all)
    by (simp add: io_distinct_def)

  lemma [simp]: "io_distinct As \<Longrightarrow> io_diagram (FB (Parallel_list As))"
    apply (rule Type_ok_FB)
    by (simp add: io_diagram_Parallel_list_a)

  lemma io_distinct_set_In[simp]: " io_distinct x \<Longrightarrow>  perm x (A # B # Bs) \<Longrightarrow> set (In A) \<inter> set (In B) = {}"
    apply (drule io_distinct_perm, simp_all)
    by (simp add: io_distinct_def)

  lemma io_distinct_set_Out[simp]: " io_distinct x \<Longrightarrow>  perm x (A # B # Bs) \<Longrightarrow> set (Out A) \<inter> set (Out B) = {}"
    apply (drule io_distinct_perm, simp_all)
    by (simp add: io_distinct_def)

  lemma distinct_Par_equiv_b: "io_distinct As  \<Longrightarrow> perm As (Bs @ Cs) \<Longrightarrow> in_out_equiv (FB (FB (Parallel_list Bs) ||| Parallel_list Cs)) (FB (Parallel_list As))"
    proof -
      assume [simp]: "io_distinct As"
      assume [simp]: "perm As (Bs @ Cs)"
      have [simp]: "io_diagram (Parallel_list Bs)"
        apply (rule io_diagram_Parallel_list_a)
        by (rule_tac As = As and Cs = Cs in io_distinct_append_a, simp_all)
      have [simp]: "io_diagram (FB (Parallel_list Bs))"
        by (rule Type_ok_FB, simp)
      have [simp]: "io_diagram (Parallel_list Cs)"
        apply (rule io_diagram_Parallel_list_a)
        by (rule_tac As = As and Bs = Bs in io_distinct_append_b, simp_all)
      have [simp]: "(\<Union>a\<in>set Bs. set (Out a)) \<inter> (\<Union>a\<in>set Cs. set (Out a)) = {}"
        apply (cut_tac As = As and Bs = "Bs @ Cs" in io_distinct_perm, simp_all)
        by (simp add: io_distinct_def)
      have Aa[simp]: "set (In (Parallel_list Bs)) \<inter> set (In (Parallel_list Cs)) = {}"
        apply (simp add: In_Parallel)
        apply (cut_tac As = As and Bs = "Bs @ Cs" in io_distinct_perm, simp_all)
        by (simp add: io_distinct_def)
      have Ab[simp]: "set (Out (Parallel_list Bs)) \<inter> set (Out (Parallel_list Cs)) = {}"
        by (simp add: Out_Parallel)
      have [simp]: "set (In (FB (Parallel_list Bs))) \<inter> set (In (Parallel_list Cs)) = {}"
        apply (subgoal_tac "set (In ((Parallel_list Bs))) \<inter> set (In (Parallel_list Cs)) = {}")
        apply (subgoal_tac "set (In (FB (Parallel_list Bs))) \<subseteq> set (In ((Parallel_list Bs)))")
        apply (auto simp del: Aa) [1]
        by (auto simp add: FB_def Let_def set_diff)

      have [simp]: "set (Out (FB (Parallel_list Bs))) \<inter> set (Out (Parallel_list Cs)) = {}"
        apply (subgoal_tac "set (Out ((Parallel_list Bs))) \<inter> set (Out (Parallel_list Cs)) = {}")
        apply (subgoal_tac "set (Out (FB (Parallel_list Bs))) \<subseteq> set (Out ((Parallel_list Bs)))")
        apply (auto simp del: Ab) [1]
        by (auto simp add: FB_def Let_def set_diff)

      have [simp]:"Ball (set Bs) io_diagram"
        apply (cut_tac As = As and Bs = Bs and Cs = Cs in io_distinct_append_a, simp_all)
        by (simp add: io_distinct_def)
      have [simp]:"Ball (set Cs) io_diagram"
        apply (cut_tac As = As and Bs = Bs and Cs = Cs in io_distinct_append_b, simp_all)
        by (simp add: io_distinct_def)
      have [simp]:" distinct (concat (map Out Bs))"
        apply (cut_tac As = As and Bs = Bs and Cs = Cs in io_distinct_append_a, simp_all)
        by (simp add: io_distinct_def)
      have [simp]:"distinct (concat (map Out Cs))"
        apply (cut_tac As = As and Bs = Bs and Cs = Cs in io_distinct_append_b, simp_all)
        by (simp add: io_distinct_def)
      have [simp]:"io_diagram (Parallel_list As)"
        by (simp add: io_diagram_Parallel_list_a)
      have A: "FB (FB (Parallel_list Bs) ;; FB (Parallel_list Cs)) = FB (Parallel_list Bs ||| Parallel_list Cs)"
        by (subst FeedbackSerial, simp_all)
      show ?thesis
        apply (subst FeedbackSerial, simp_all)
        apply (subst FB_idemp, simp_all)
        apply (simp add:  A)
        apply (subst Parallel_list_append [THEN sym], simp_all)
        apply (rule in_out_equiv_FB, simp_all)
        apply (rule distinct_Par_equiv_a, simp_all)
        apply auto [1]
        by (simp add: perm_sym)
   qed

  lemma distinct_Par_equiv: "io_distinct As_init \<Longrightarrow> Suc 0 \<le> length As_init \<Longrightarrow>
    length As = w \<Longrightarrow> io_distinct As \<Longrightarrow> in_out_equiv (FB (Parallel_list As)) (FB (Parallel_list As_init)) \<Longrightarrow>
    Suc 0 < w \<Longrightarrow> Suc 0 < length Bs \<Longrightarrow> perm As (Bs @ Cs) \<Longrightarrow>
      io_distinct (FB (Parallel_list Bs) # Cs) \<and> in_out_equiv (FB (FB (Parallel_list Bs) ||| Parallel_list Cs)) (FB (Parallel_list As_init))"
    apply simp
    apply (rule_tac B = "FB (Parallel_list As)" in in_out_equiv_tran, simp_all)
    by (rule distinct_Par_equiv_b, simp_all)

lemma AAAA_x[simp]: "io_distinct As_init \<Longrightarrow> Suc 0 \<le> length As_init \<Longrightarrow> invariant As_init w x \<Longrightarrow> Suc 0 < length x \<Longrightarrow> Suc 0 < length Bs
        \<Longrightarrow> perm x (Bs @ Cs)
        \<Longrightarrow> invariant As_init (Suc (length Cs)) (FB (Parallel_list Bs) # Cs)"
    by (simp add: invariant_def, safe, simp_all add: distinct_Par_equiv)

  term "{1,2,3} - {2,3}"

  thm ParallelId_right

  lemma [simp]: "io_distinct As_init \<Longrightarrow>
                Suc 0 \<le> length As_init \<Longrightarrow> invariant As_init w x \<Longrightarrow> Suc 0 < length x \<Longrightarrow> perm x (A # B # Bs)
                \<Longrightarrow> invariant As_init (Suc (length Bs)) (FB (FB A ;; FB B) # Bs)"
     apply (subst FeedbackSerial [THEN sym])
     apply (simp_all add: invariant_def)
     apply (drule perm_set_eq, simp add: io_distinct_def)
     apply (drule perm_set_eq, simp add: io_distinct_def)
     apply (rule io_distinct_set_In, simp_all)
     apply (rule io_distinct_set_Out, simp_all)
     apply (cut_tac Bs = "[A,B]" and Cs = Bs and w = w in AAAA_x, simp_all)
     apply (simp add: invariant_def)
     apply (simp add: invariant_def)
     apply (subst (asm) ParallelId_right, simp_all)
     apply (drule perm_set_eq, simp add: io_distinct_def)
     apply (subst (asm) ParallelId_right, simp_all)
     by (drule perm_set_eq, simp add: io_distinct_def)

  lemma [simp]: "io_distinct As_init \<Longrightarrow> Suc 0 \<le> length As_init \<Longrightarrow>
         Hoare (invariant As_init w \<sqinter> (\<lambda>As. Suc 0 < length As))
          [:As\<leadsto>As'.\<exists>Bs. Suc 0 < length Bs \<and> (\<exists>Cs. perm As (Bs @ Cs) \<and> As' = FB (Parallel_list Bs) # Cs):] (Sup_less (invariant As_init) w)"
     apply (rule hoare_demonic, safe)
     apply (simp add: Sup_less_def)
     apply (rule_tac x = "invariant As_init (Suc (length Cs))" in exI, safe)
     apply (rule_tac x = "(Suc (length Cs))" in exI, simp_all)
     apply (simp add: invariant_def, safe)
     by (drule perm_length, simp)

  lemma [simp]: "io_distinct As_init \<Longrightarrow> Suc 0 \<le> length As_init \<Longrightarrow>
         Hoare (invariant As_init w \<sqinter> (\<lambda>As. Suc 0 < length As))
          [:As\<leadsto>As'.\<exists>A B Bs. perm As (A # B # Bs) \<and> As' = FB (FB A ;; FB B) # Bs:] (Sup_less (invariant As_init) w)"
     apply (rule hoare_demonic, safe)
     apply (simp add: Sup_less_def)
     apply (rule_tac x = "invariant As_init (Suc (length Bs))" in exI, safe)
     apply (rule_tac x = "(Suc (length Bs))" in exI, simp_all)
     apply (simp add: invariant_def, safe)
     apply (drule perm_length, simp)
     done

  theorem CorrectnessTranslateHBD: "io_distinct As_init \<Longrightarrow> length As_init \<ge> 1 \<Longrightarrow>
    Hoare (io_distinct \<sqinter> (\<lambda> As . As = As_init)) TranslateHBD (\<lambda> S . in_out_equiv S (FB (Parallel_list As_init)))"
    apply (simp add: TranslateHBD_def)
    apply (simp add: hoare_sequential)
    apply (rule_tac x = "\<lambda> As . in_out_equiv (FB (As ! 0)) (FB (Parallel_list As_init))" in exI)
    apply simp
    apply (rule_tac p = "invariant As_init" in hoare_while_a, simp_all)
    apply (simp add: hoare_choice, safe)
    apply (simp_all add: invariant_def, safe)
    apply (rule in_out_equiv_refl)
    apply (rule Type_ok_FB)
    apply (rule io_diagram_Parallel_list_a, simp)
    apply (case_tac x, simp)
    apply clarify
    proof -
      fix a list
      assume B: "in_out_equiv (FB (Parallel_list (a # list))) (FB (Parallel_list As_init))"
      assume A: "io_distinct (a # list)"
      assume "Suc 0 = length (a # list)"
      from this have [simp]: "list = []"
        by simp
      from A have [simp]: "io_diagram a"
        by (simp add: io_distinct_def)
      have [simp]: "FB (Parallel_list (a # list)) = FB a"
        by simp
      from B show "in_out_equiv (FB ((a # list) ! 0)) (FB (Parallel_list As_init))"
        by simp
    qed
 end

end