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

header {*Secrecy: Definitions and properties *}

theory Secrecy
imports Secrecy_types inout ListExtras
begin

-- "Encryption, decryption, signature creation and signature verification functions"
-- "For these functions we define only their signatures and general axioms,"
-- "because in order to reason effectively, we view them as abstract functions and"
-- "abstract from their implementation details"
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"

-- "Axioms on relations between encription and decription keys"
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"

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

-- "Join set of private keys and unguessable values used by a component"
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))}"

-- "Predicate defining that a list of expression items does not contain"
-- "any private key  or unguessable value used by a component"
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)"

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

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

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

-- "Predicate defining set of correctness properties of the component's"
-- "interface  and relations on its private keys and unguessable values"
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"

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

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

-- "Predicate eout sP E defines whether the component sP may eventually"
-- "output an expression E via subset of channels M,"
-- "which is a subset of output channels of sP,"
-- "and if there exists a time interval t of"
-- "an output channel which contains this expression E"
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))"

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

-- "Predicate ine sP E defines whether a component sP may eventually"
-- "get an expression E via subset of channels M,"
-- "which is a subset of input channels of sP,"
-- "and if there exists a time interval t of"
-- "an input stream  which contains this expression E"
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))"

-- "This predicate defines whether an input channel ch of a component sP "
-- "is the only one input channel of this component "
-- "via which it may eventually output an expression E"
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))"

-- "This predicate  yields true if only the channels from the set chSet,"
-- "which is a subset of input channels of the  component sP,"
-- "may eventually output an expression E"
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)))"

-- "This redicate defines whether"
-- "an input channel ch of a component sP is the only one input channel"
-- "of this component via which it may eventually get an expression E"
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))"

-- "This predicate yields true if the component sP may eventually"
-- "get an expression E only via the channels from the set chSet,"
-- "which is a subset of input channels of sP"
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)))"

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

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

-- "If a channel belongs to the set of input channels of a component P"
-- "and does not belong to the set of local channels of the compositon of P and Q"
-- "then it belongs to the set of input channels of this composition"
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)

-- "If a channel belongs to the set of input channels of the compositon of P and Q"
-- "then it belongs to the set of input channels either of P or of Q"
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


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

(*
 * Given a list of mappings "[(k1, v1), (k2, v2), ...]", define a function that performs the mapping.
 * If none of the keys match, the default value is returned.
 * If multiple keys match, the first one is used. (So having duplicate keys is useless.)
 *
 * Analogue of C-parser's StaticFun but without the linorder requirement.
 * Uses an assoc-list instead of binary tree. This makes the setup cost O(n^2) but
 * the lookup cost is unchanged (we prove the same equations as StaticFun does).
 *
 * TODO: move to l4v/lib (or further upstream)
 *)
theory AssocLookup imports
  Main
begin

fun assoc_lookup :: "('a \<times> 'b) list \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b" where
    "assoc_lookup [] def _ = def"
  | "assoc_lookup ((k, v) # ls) def x = (if x = k then v else assoc_lookup ls def x)"

(* These versions are better for simp performance *)
lemma assoc_lookup_simps[simp]:
  "assoc_lookup [] def x = def"
  "assoc_lookup ((k, v) # ls) def k = v"
  (* make_assoc_fun shouldn't need this one *)
  (*"x = k \<Longrightarrow> assoc_lookup ((k, v) # ls) def x = v"*)
  "x \<noteq> k \<Longrightarrow> assoc_lookup ((k, v) # ls) def x = assoc_lookup ls def x"
  by simp_all
declare assoc_lookup.simps[simp del]

(*
 * Main interface.
 * Note that all types in "assocs" and "default" need to match,
 * this procedure doesn't do type unification. *)
ML {*
structure AssocLookup = struct

fun make_assoc_fun
        (assocs: (term*term) list) (default: term)
        (name: string) (eqn_names: string list)
        ctxt = let
  (* define lookup function *)
  val [key_typ, val_typ] = case assocs of ((k, v) :: _) => map type_of [k, v]
                                        | _ => error "make_assoc_fun: empty list"
  val alist_term = HOLogic.mk_list (HOLogic.mk_prodT (key_typ, val_typ)) (map HOLogic.mk_prod assocs)
  val assoc_lookupT = HOLogic.listT (HOLogic.mk_prodT (key_typ, val_typ)) --> val_typ --> key_typ --> val_typ
  val defn = Const (@{const_name assoc_lookup}, assoc_lookupT) $ alist_term $ default
  val ((f_term, (_, f_def)), ctxt) =
          Local_Theory.define ((Binding.name name, NoSyn),
                              ((Thm.def_binding (Binding.name name), []), defn)) ctxt
  val proof_ctxt = ctxt addsimps [f_def]
  (* generate lookup equations for function *)
  val eqns = eqn_names ~~ assocs
        |> Par_List.map (fn (name, (k, v)) => let
            val prop = HOLogic.mk_Trueprop (HOLogic.mk_eq (betapply (f_term, k), v))
            val thm = Goal.prove ctxt [] [] prop (K (
                        simp_tac proof_ctxt 1))
            in (name, thm)
            end)
  (* store the equations by eqn_names *)
  val grouped_eqns = eqns
        |> sort_wrt fst
        |> partition_eq (fn (e1, e2) => fst e1 = fst e2)
  val (_, ctxt) = Local_Theory.notes (map (fn eqns =>
        ((Binding.name (fst (hd eqns)), []), [(map snd eqns, [])])) grouped_eqns) ctxt
  in ctxt end

end
*}

(* Test: *)
(*
local_setup {*
AssocLookup.make_assoc_fun
  [(@{term "(''S'', 1::nat)"}, @{term "2::nat"}),
   (@{term "(''P'', 2::nat)"}, @{term "1::nat"}),
   (@{term "(''S'', 3::nat)"}, @{term "2+2::nat"})]
  @{term "42::nat"}
  "foo" ("foo1_simp" :: replicate 2 "foo23_simps")
*}
print_theorems
*)

end


theory Array_Iterator
imports Iterator "../Lib/Diff_Array"
begin

lemma idx_iteratei_aux_array_get_Array_conv_nth:
  "idx_iteratei_aux array_get sz i (Array xs) c f \<sigma> =
   idx_iteratei_aux (!) sz i xs c f \<sigma>"
apply(induct get\<equiv>"(!) :: 'b list \<Rightarrow> nat \<Rightarrow> 'b" sz i xs c f \<sigma> rule: idx_iteratei_aux.induct)
apply(subst (1 2) idx_iteratei_aux.simps)
apply simp
done

lemma idx_iteratei_array_get_Array_conv_nth:
  "idx_iteratei array_get array_length (Array xs) = idx_iteratei nth length xs"
by(simp add: idx_iteratei_def fun_eq_iff idx_iteratei_aux_array_get_Array_conv_nth)

end


(*  Title:      HOL/HOLCF/IOA/ABP/Correctness.thy
    Author:     Olaf Müller
*)

section \<open>The main correctness proof: System_fin implements System\<close>

theory Correctness
imports "../IOA" Env Impl Impl_finite
begin

ML_file "Check.ML"

primrec reduce :: "'a list => 'a list"
where
  reduce_Nil:  "reduce [] = []"
| reduce_Cons: "reduce(x#xs) =
                 (case xs of
                     [] => [x]
               |   y#ys => (if (x=y)
                              then reduce xs
                              else (x#(reduce xs))))"

definition
  abs where
    "abs  =
      (%p.(fst(p),(fst(snd(p)),(fst(snd(snd(p))),
       (reduce(fst(snd(snd(snd(p))))),reduce(snd(snd(snd(snd(p))))))))))"

definition
  system_ioa :: "('m action, bool * 'm impl_state)ioa" where
  "system_ioa = (env_ioa \<parallel> impl_ioa)"

definition
  system_fin_ioa :: "('m action, bool * 'm impl_state)ioa" where
  "system_fin_ioa = (env_ioa \<parallel> impl_fin_ioa)"

axiomatization where
  sys_IOA: "IOA system_ioa" and
  sys_fin_IOA: "IOA system_fin_ioa"

declare split_paired_All [simp del] Collect_empty_eq [simp del]

lemmas [simp] =
  srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
  ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
  actions_def exis_elim srch_trans_def rsch_trans_def ch_trans_def
  trans_of_def asig_projections set_lemmas

lemmas abschannel_fin [simp] =
  srch_fin_asig_def rsch_fin_asig_def
  rsch_fin_ioa_def srch_fin_ioa_def
  ch_fin_ioa_def ch_fin_trans_def ch_fin_asig_def

lemmas impl_ioas = sender_ioa_def receiver_ioa_def
  and impl_trans = sender_trans_def receiver_trans_def
  and impl_asigs = sender_asig_def receiver_asig_def

declare let_weak_cong [cong]
declare ioa_triple_proj [simp] starts_of_par [simp]

lemmas env_ioas = env_ioa_def env_asig_def env_trans_def
lemmas hom_ioas =
  env_ioas [simp] impl_ioas [simp] impl_trans [simp] impl_asigs [simp]
  asig_projections set_lemmas

subsection \<open>lemmas about reduce\<close>

lemma l_iff_red_nil: "(reduce l = []) = (l = [])"
  by (induct l) (auto split: list.split)

lemma hd_is_reduce_hd: "s ~= [] --> hd s = hd (reduce s)"
  by (induct s) (auto split: list.split)

text \<open>to be used in the following Lemma\<close>
lemma rev_red_not_nil [rule_format]:
    "l ~= [] --> reverse (reduce l) ~= []"
  by (induct l) (auto split: list.split)

text \<open>shows applicability of the induction hypothesis of the following Lemma 1\<close>
lemma last_ind_on_first:
    "l ~= [] ==> hd (reverse (reduce (a # l))) = hd (reverse (reduce l))"
  apply simp
  apply (tactic \<open>auto_tac (put_simpset HOL_ss @{context}
    addsimps (@{thms reverse.simps} @ [@{thm hd_append}, @{thm rev_red_not_nil}])
    |> Splitter.add_split @{thm list.split})\<close>)
  done

text \<open>Main Lemma 1 for \<open>S_pkt\<close> in showing that reduce is refinement.\<close>
lemma reduce_hd:
   "if x=hd(reverse(reduce(l))) & reduce(l)~=[] then
       reduce(l@[x])=reduce(l) else
       reduce(l@[x])=reduce(l)@[x]"
apply (simplesubst if_split)
apply (rule conjI)
txt \<open>\<open>-->\<close>\<close>
apply (induct_tac "l")
apply (simp (no_asm))
apply (case_tac "list=[]")
 apply simp
 apply (rule impI)
apply (simp (no_asm))
apply (cut_tac l = "list" in cons_not_nil)
 apply (simp del: reduce_Cons)
 apply (erule exE)+
 apply hypsubst
apply (simp del: reduce_Cons add: last_ind_on_first l_iff_red_nil)
txt \<open>\<open><--\<close>\<close>
apply (simp (no_asm) add: and_de_morgan_and_absorbe l_iff_red_nil)
apply (induct_tac "l")
apply (simp (no_asm))
apply (case_tac "list=[]")
apply (cut_tac [2] l = "list" in cons_not_nil)
apply simp
apply (auto simp del: reduce_Cons simp add: last_ind_on_first l_iff_red_nil split: if_split)
apply simp
done

text \<open>Main Lemma 2 for R_pkt in showing that reduce is refinement.\<close>
lemma reduce_tl: "s~=[] ==>
     if hd(s)=hd(tl(s)) & tl(s)~=[] then
       reduce(tl(s))=reduce(s) else
       reduce(tl(s))=tl(reduce(s))"
apply (cut_tac l = "s" in cons_not_nil)
apply simp
apply (erule exE)+
apply (auto split: list.split)
done

subsection \<open>Channel Abstraction\<close>

declare if_split [split del]

lemma channel_abstraction: "is_weak_ref_map reduce ch_ioa ch_fin_ioa"
apply (simp (no_asm) add: is_weak_ref_map_def)
txt \<open>main-part\<close>
apply (rule allI)+
apply (rule imp_conj_lemma)
apply (induct_tac "a")
txt \<open>2 cases\<close>
apply (simp_all (no_asm) cong del: if_weak_cong add: externals_def)
txt \<open>fst case\<close>
 apply (rule impI)
 apply (rule disjI2)
apply (rule reduce_hd)
txt \<open>snd case\<close>
 apply (rule impI)
 apply (erule conjE)+
 apply (erule disjE)
apply (simp add: l_iff_red_nil)
apply (erule hd_is_reduce_hd [THEN mp])
apply (simp add: l_iff_red_nil)
apply (rule conjI)
apply (erule hd_is_reduce_hd [THEN mp])
apply (rule bool_if_impl_or [THEN mp])
apply (erule reduce_tl)
done

declare if_split [split]

lemma sender_abstraction: "is_weak_ref_map reduce srch_ioa srch_fin_ioa"
apply (tactic \<open>
  simp_tac (put_simpset HOL_ss @{context}
    addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
      @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
      @{thm channel_abstraction}]) 1\<close>)
done

lemma receiver_abstraction: "is_weak_ref_map reduce rsch_ioa rsch_fin_ioa"
apply (tactic \<open>
  simp_tac (put_simpset HOL_ss @{context}
    addsimps [@{thm srch_fin_ioa_def}, @{thm rsch_fin_ioa_def},
      @{thm srch_ioa_def}, @{thm rsch_ioa_def}, @{thm rename_through_pmap},
      @{thm channel_abstraction}]) 1\<close>)
done

text \<open>3 thms that do not hold generally! The lucky restriction here is
   the absence of internal actions.\<close>
lemma sender_unchanged: "is_weak_ref_map (%id. id) sender_ioa sender_ioa"
apply (simp (no_asm) add: is_weak_ref_map_def)
txt \<open>main-part\<close>
apply (rule allI)+
apply (induct_tac a)
txt \<open>7 cases\<close>
apply (simp_all (no_asm) add: externals_def)
done

text \<open>2 copies of before\<close>
lemma receiver_unchanged: "is_weak_ref_map (%id. id) receiver_ioa receiver_ioa"
apply (simp (no_asm) add: is_weak_ref_map_def)
txt \<open>main-part\<close>
apply (rule allI)+
apply (induct_tac a)
txt \<open>7 cases\<close>
apply (simp_all (no_asm) add: externals_def)
done

lemma env_unchanged: "is_weak_ref_map (%id. id) env_ioa env_ioa"
apply (simp (no_asm) add: is_weak_ref_map_def)
txt \<open>main-part\<close>
apply (rule allI)+
apply (induct_tac a)
txt \<open>7 cases\<close>
apply (simp_all (no_asm) add: externals_def)
done

lemma compat_single_ch: "compatible srch_ioa rsch_ioa"
apply (simp add: compatible_def Int_def)
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

text \<open>totally the same as before\<close>
lemma compat_single_fin_ch: "compatible srch_fin_ioa rsch_fin_ioa"
apply (simp add: compatible_def Int_def)
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

lemmas del_simps = trans_of_def srch_asig_def rsch_asig_def
  asig_of_def actions_def srch_trans_def rsch_trans_def srch_ioa_def
  srch_fin_ioa_def rsch_fin_ioa_def rsch_ioa_def sender_trans_def
  receiver_trans_def set_lemmas

lemma compat_rec: "compatible receiver_ioa (srch_ioa \<parallel> rsch_ioa)"
apply (simp del: del_simps
  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
apply simp
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

text \<open>5 proofs totally the same as before\<close>
lemma compat_rec_fin: "compatible receiver_ioa (srch_fin_ioa \<parallel> rsch_fin_ioa)"
apply (simp del: del_simps
  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
apply simp
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

lemma compat_sen: "compatible sender_ioa
       (receiver_ioa \<parallel> srch_ioa \<parallel> rsch_ioa)"
apply (simp del: del_simps
  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
apply simp
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

lemma compat_sen_fin: "compatible sender_ioa
       (receiver_ioa \<parallel> srch_fin_ioa \<parallel> rsch_fin_ioa)"
apply (simp del: del_simps
  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
apply simp
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

lemma compat_env: "compatible env_ioa
       (sender_ioa \<parallel> receiver_ioa \<parallel> srch_ioa \<parallel> rsch_ioa)"
apply (simp del: del_simps
  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
apply simp
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

lemma compat_env_fin: "compatible env_ioa
       (sender_ioa \<parallel> receiver_ioa \<parallel> srch_fin_ioa \<parallel> rsch_fin_ioa)"
apply (simp del: del_simps
  add: compatible_def asig_of_par asig_comp_def actions_def Int_def)
apply simp
apply (rule set_eqI)
apply (induct_tac x)
apply simp_all
done

text \<open>lemmata about externals of channels\<close>
lemma ext_single_ch: "externals(asig_of(srch_fin_ioa)) = externals(asig_of(srch_ioa)) &
    externals(asig_of(rsch_fin_ioa)) = externals(asig_of(rsch_ioa))"
  by (simp add: externals_def)

subsection \<open>Soundness of Abstraction\<close>

lemmas ext_simps = externals_of_par ext_single_ch
  and compat_simps = compat_single_ch compat_single_fin_ch compat_rec
    compat_rec_fin compat_sen compat_sen_fin compat_env compat_env_fin
  and abstractions = env_unchanged sender_unchanged
    receiver_unchanged sender_abstraction receiver_abstraction

(* FIX: this proof should be done with compositionality on trace level, not on
        weak_ref_map level, as done here with fxg_is_weak_ref_map_of_product_IOA

Goal "is_weak_ref_map  abs  system_ioa  system_fin_ioa"

by (simp_tac (impl_ss delsimps ([srch_ioa_def, rsch_ioa_def, srch_fin_ioa_def,
                                 rsch_fin_ioa_def] @ env_ioas @ impl_ioas)
                      addsimps [system_def, system_fin_def, abs_def,
                                impl_ioa_def, impl_fin_ioa_def, sys_IOA,
                                sys_fin_IOA]) 1);

by (REPEAT (EVERY[rtac fxg_is_weak_ref_map_of_product_IOA 1,
                  simp_tac (ss addsimps abstractions) 1,
                  rtac conjI 1]));

by (ALLGOALS (simp_tac (ss addsimps ext_ss @ compat_ss)));

qed "system_refinement";
*)

end


(*<*)
(*
 * Knowledge-based programs.
 * (C)opyright 2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory KBPs
imports Kripke Traces
begin
(*>*)

section{* Knowledge-based Programs *}

text {*

\label{sec:kbps-theory-kbps-semantics}

A knowledge-based programs (KBPs) encodes the dependency of action on
knowledge by a sequence of guarded commands, and a \emph{joint
knowledge-based program} (JKBP) assigns a KBP to each agent:

*}

record ('a, 'p, 'aAct) GC =
  guard  :: "('a, 'p) Kform"
  action :: "'aAct"

type_synonym ('a, 'p, 'aAct) KBP = "('a, 'p, 'aAct) GC list"
type_synonym ('a, 'p, 'aAct) JKBP = "'a \<Rightarrow> ('a, 'p, 'aAct) KBP"

text{*

We use a list of guarded commands just so we can reuse this definition
and others in algorithmic contexts; we would otherwise use a set as
there is no problem with infinite programs or actions, and we always
ignore the sequential structure.

Intuitively a KBP for an agent cannot directly evaluate the truth of
an arbitrary formula as it may depend on propositions that the agent
has no certainty about. For example, a card-playing agent cannot
determine which cards are in the deck, despite being sure that those
in her hand are not. Conversely agent $a$ can evaluate formulas of the
form @{term "\<^bold>K\<^sub>a \<phi>"} as these depend only on the worlds the agent thinks
is possible.

Thus we restrict the guards of the JKBP to be boolean combinations of
\emph{subjective} formulas:

*}

fun subjective :: "'a \<Rightarrow> ('a, 'p) Kform \<Rightarrow> bool" where
  "subjective a (Kprop p)      = False"
| "subjective a (Knot f)       = subjective a f"
| "subjective a (Kand f g)     = (subjective a f \<and> subjective a g)"
| "subjective a (Kknows a' f)  = (a = a')"
| "subjective a (Kcknows as f) = (a \<in> set as)"

text{*

All JKBPs in the following sections are assumed to be subjective.

This syntactic restriction implies the desired semantic property, that
we can evaluate a guard at an arbitrary world that is compatible with
a given observation \citep[\S3]{DBLP:journals/dc/FaginHMV97}.

*}

lemma S5n_subjective_eq:
  assumes S5n: "S5n M"
  assumes subj: "subjective a \<phi>"
  assumes ww': "(w, w') \<in> relations M a"
  shows "M, w \<Turnstile> \<phi> \<longleftrightarrow> M, w' \<Turnstile> \<phi>"
(*<*)
using subj ww'
proof(induct \<phi> rule: subjective.induct[case_names Kprop Knot Kand Kknows Kcknows])
  case (Kcknows a as \<phi>)
  hence "(w, w') \<in> (\<Union>a\<in>set as. relations M a)\<^sup>+" by auto
  with Kcknows S5n show ?case by (auto dest: S5n_tc_rels_eq)
qed (auto dest: S5n_rels_eq[OF S5n])

(*>*)
text{*

The proof is by induction over the formula @{term "\<phi>"}, using the
properties of $S5_n$ Kripke structures in the knowledge cases.

We capture the fixed but arbitrary JKBP using a locale, and work in
this context for the rest of this section.

*}

locale JKBP =
  fixes jkbp :: "('a, 'p, 'aAct) JKBP"
  assumes subj: "\<forall>a gc. gc \<in> set (jkbp a) \<longrightarrow> subjective a (guard gc)"

context JKBP
begin

text{*

The action of the JKBP at a world is the list of all actions that are
enabled at that world:

*}

definition jAction :: "('a, 'p, 'w) KripkeStructure \<Rightarrow> 'w \<Rightarrow> 'a \<Rightarrow> 'aAct list"
where "jAction \<equiv> \<lambda>M w a. [ action gc. gc \<leftarrow> jkbp a, M, w \<Turnstile> guard gc ]"

text{*

All of our machinery on Kripke structures lifts from the models
relation of \S\ref{sec:kbps-logic-of-knowledge} through @{term
"jAction"}, due to the subjectivity requirement. In particular, the
KBP for agent $a$ behaves the same at worlds that $a$ cannot
distinguish amongst:

*}

lemma S5n_jAction_eq:
  assumes S5n: "S5n M"
  assumes ww': "(w, w') \<in> relations M a"
  shows "jAction M w a = jAction M w' a"
(*<*)
proof -
  { fix gc assume "gc \<in> set (jkbp a)"
    with subj have "subjective a (guard gc)" by auto
    with S5n ww' have "M, w \<Turnstile> guard gc = M, w' \<Turnstile> guard gc"
      by - (rule S5n_subjective_eq, simp_all) }
  thus ?thesis
    unfolding jAction_def
    by - (rule arg_cong[where f=concat], simp)
qed
(*>*)

text{*

Also the JKBP behaves the same on relevant generated models for all
agents:

*}

lemma gen_model_jAction_eq:
  assumes S: "gen_model M w = gen_model M' w"
  assumes w': "w' \<in> worlds (gen_model M' w)"
  assumes M: "kripke M"
  assumes M': "kripke M'"
  shows "jAction M w' = jAction M' w'"
(*<*)
  unfolding jAction_def
  by (auto iff: gen_model_eq[OF M M' S w'])
(*>*)

text{*

Finally, @{term "jAction"} is invariant under simulations:

*}

lemma simulation_jAction_eq:
  assumes M: "kripke M"
  assumes sim: "sim M M' f"
  assumes w: "w \<in> worlds M"
  shows "jAction M w = jAction M' (f w)"
(*<*)
  unfolding jAction_def
  using assms by (auto iff: sim_semantic_equivalence)
(*>*)

end

section{* Environments and Views *}

text{*

\label{sec:kbps-theory-environments}

The previous section showed how a JKBP can be interpreted statically,
with respect to a fixed Kripke structure. As we also wish to capture
how agents interact, we adopt the \emph{interpreted systems} and
\emph{contexts} of \cite{FHMV:1995}, which we term \emph{environments}
following \cite{Ron:1996}.

A \emph{pre-environment} consists of the following:
\begin{itemize}

\item @{term "envInit"}, an arbitrary set of initial states;

\item The protocol of the environment @{term "envAction"}, which
  depends on the current state;

\item A transition function @{term "envTrans"}, which incorporates the
  environment's action and agents' behaviour into a state change; and

\item A propositional evaluation function @{term "envVal"}.

\end{itemize}
We extend the @{term "JKBP"} locale with these constants:

*}

locale PreEnvironment = JKBP jkbp for jkbp :: "('a, 'p, 'aAct) JKBP"
+ fixes envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"

text{*

\label{sec:kbps-views}

We represent the possible evolutions of the system as finite sequences
of states, represented by a left-recursive type @{typ "'s Trace"} with
constructors @{term "tInit s"} and @{term "t \<leadsto> s"}, equipped with
@{term "tFirst"}, @{term "tLast"}, @{term "tLength"} and @{term
"tMap"} functions.

Constructing these traces requires us to determine the agents' actions
at a given state. To do so we need to find an appropriate S$5_n$
structure for interpreting @{term "jkbp"}.

Given that we want the agents to make optimal use of the information
they have access to, we allow these structures to depend on the entire
history of the system, suitably conditioned by what the agents can
observe. We capture this notion of observation with a \emph{view}
\citep{Ron:1996}, which is an arbitrary function of a trace:

*}

type_synonym ('s, 'tview) View = "'s Trace \<Rightarrow> 'tview"
type_synonym ('a, 's, 'tview) JointView = "'a \<Rightarrow> 's Trace \<Rightarrow> 'tview"

text{*

\label{sec:kbps-synchrony}

We require views to be \emph{synchronous}, i.e. that agents be able to
tell the time using their view by distinguishing two traces of
different lengths. As we will see in the next section, this guarantees
that the JKBP has an essentially unique implementation.

We extend the @{term "PreEnvironment"} locale with a view:

*}

locale PreEnvironmentJView =
  PreEnvironment jkbp envInit envAction envTrans envVal
    for jkbp :: "('a, 'p, 'aAct) JKBP"
    and envInit :: "'s list"
    and envAction :: "'s \<Rightarrow> 'eAct list"
    and envTrans :: "'eAct \<Rightarrow> ('a \<Rightarrow> 'aAct) \<Rightarrow> 's \<Rightarrow> 's"
    and envVal :: "'s \<Rightarrow> 'p \<Rightarrow> bool"
+ fixes jview :: "('a, 's, 'tview) JointView"
  assumes sync: "\<forall>a t t'. jview a t = jview a t' \<longrightarrow> tLength t = tLength t'"

text{*

The two principle synchronous views are the clock view and the
perfect-recall view which we discuss further in
\S\ref{sec:kbps-theory-views}. We will later derive an agent's
concrete view from an instantaneous observation of the global state in
\S\ref{sec:kbps-environments}.

We build a Kripke structure from a set of traces by relating traces
that yield the same view. To obtain an S$5_n$ structure we also need a
way to evaluate propositions: we apply @{term "envVal"} to the final
state of a trace:

*}

definition (in PreEnvironmentJView)
  mkM :: "'s Trace set \<Rightarrow> ('a, 'p, 's Trace) KripkeStructure"
where
  "mkM T \<equiv>
      \<lparr> worlds = T,
        relations = \<lambda>a. { (t, t') . {t, t'} \<subseteq> T \<and> jview a t = jview a t' },
        valuation = envVal \<circ> tLast \<rparr>"
(*<*)

context PreEnvironmentJView
begin

lemma mkM_kripke[intro, simp]: "kripke (mkM T)"
  unfolding mkM_def by (rule kripkeI) fastforce

lemma mkM_S5n[intro, simp]: "S5n (mkM T)"
  unfolding mkM_def
  by (intro S5nI equivI)
     (bestsimp intro: equivI refl_onI symI transI)+

lemma mkM_simps[simp]:
  "worlds (mkM T) = T"
  "\<lbrakk> (t, t') \<in> relations (mkM T) a \<rbrakk> \<Longrightarrow> jview a t = jview a t'"
  "\<lbrakk> (t, t') \<in> relations (mkM T) a \<rbrakk> \<Longrightarrow> t \<in> T"
  "\<lbrakk> (t, t') \<in> relations (mkM T) a \<rbrakk> \<Longrightarrow> t' \<in> T"
  "valuation (mkM T) = envVal \<circ> tLast"
  unfolding mkM_def by simp_all

lemma mkM_rel_length[simp]:
  assumes tt': "(t, t') \<in> relations (mkM T) a"
  shows "tLength t' = tLength t"
proof -
  from tt' have "jview a t = jview a t'" by simp
  thus ?thesis by (bestsimp dest: sync[rule_format])
qed

(*>*)
text{*

This construction supplants the role of the \emph{local states} of
\citet{FHMV:1995}.

The following section shows how we can canonically interpret the JKBP
with respect to this structure.

*}

section{* Canonical Structures *}

text{*

\label{sec:kbps-canonical-kripke}

Our goal in this section is to find the canonical set of traces for a
given JKBP in a particular environment. As we will see, this always
exists with respect to synchronous views.

We inductively define an \emph{interpretation} of a JKBP with respect
to an arbitrary set of traces @{term "T"} by constructing a sequence
of sets of traces of increasing length:

*}

fun jkbpTn :: "nat \<Rightarrow> 's Trace set \<Rightarrow> 's Trace set"(*<*)("jkbpT\<^bsub>_\<^esub>")(*>*) where
  "jkbpT\<^bsub>0\<^esub> T     = { tInit s |s. s \<in> set envInit }"
| "jkbpT\<^bsub>Suc n\<^esub> T = { t \<leadsto> envTrans eact aact (tLast t) |t eact aact.
                             t \<in> jkbpT\<^bsub>n\<^esub> T \<and> eact \<in> set (envAction (tLast t))
                          \<and> (\<forall>a. aact a \<in> set (jAction (mkM T) t a)) }"

text{*

This model reflects the failure of any agent to provide an action as
failure of the entire system. In general @{term "envTrans"} may
incorporate a scheduler and communication failure models.

The union of this sequence gives us a closure property:

*}

definition jkbpT :: "'s Trace set \<Rightarrow> 's Trace set" where
  "jkbpT T \<equiv> \<Union>n. jkbpT\<^bsub>n\<^esub> T"
(*<*)

lemma jkbpTn_length:
  "t \<in> jkbpTn n T \<Longrightarrow> tLength t = n"
  by (induct n arbitrary: t, auto)

lemma jkbpT_tLength_inv:
  "\<lbrakk> t \<in> jkbpT T; tLength t = n \<rbrakk> \<Longrightarrow> t \<in> jkbpTn n T"
  unfolding jkbpT_def
  by (induct n arbitrary: t) (fastforce simp: jkbpTn_length)+

lemma jkbpT_traces_of_length:
   "{ t \<in> jkbpT T . tLength t = n } = jkbpTn n T"
  using jkbpT_tLength_inv
  unfolding jkbpT_def by (bestsimp simp: jkbpTn_length)

(*>*)
text{*

We say that a set of traces @{term "T"} \emph{represents} a JKBP if it
is closed under @{term "jkbpT"}:

*}

definition represents :: "'s Trace set \<Rightarrow> bool" where
  "represents T \<equiv> jkbpT T = T"
(*<*)

lemma representsI:
  "jkbpT T = T \<Longrightarrow> represents T"
  unfolding represents_def by simp

lemma representsD:
  "represents T \<Longrightarrow> jkbpT T = T"
  unfolding represents_def by simp

(*>*)
text{*

This is the vicious cycle that we break using our assumption that the
view is synchronous. The key property of such views is that the
satisfaction of an epistemic formula is determined by the set of
traces in the model that have the same length. Lifted to @{term
"jAction"}, we have:

*}

(*<*)
lemma sync_tLength_eq_trc:
  assumes "(t, t') \<in> (\<Union>a\<in>as. relations (mkM T) a)\<^sup>*"
  shows "tLength t = tLength t'"
  using assms by (induct rule: rtrancl_induct) auto

lemma sync_gen_model_tLength:
  assumes traces: "{ t \<in> T . tLength t = n } = { t \<in> T' . tLength t = n }"
      and tT: "t \<in> { t \<in> T . tLength t = n }"
  shows "gen_model (mkM T) t = gen_model (mkM T') t"
  apply(rule gen_model_subset[where T="{ t \<in> T . tLength t = n }"])
  apply simp_all

  (* t \<in> T and t \<in> T' *)
  prefer 4
  using tT
  apply simp
  prefer 4
  using tT traces
  apply simp

  apply (unfold mkM_def)[1]
  using tT traces
  apply (auto)[1]

  using tT
  apply (auto dest: sync_tLength_eq_trc[where as=UNIV] kripke_rels_trc_worlds)[1]

  using tT traces
  apply (auto dest: sync_tLength_eq_trc[where as=UNIV] kripke_rels_trc_worlds)[1]

  done

(*>*)
lemma sync_jview_jAction_eq:
  assumes traces: "{ t \<in> T . tLength t = n } = { t \<in> T' . tLength t = n }"
  assumes tT: "t \<in> { t \<in> T . tLength t = n }"
  shows "jAction (mkM T) t = jAction (mkM T') t"
(*<*)
  apply (rule gen_model_jAction_eq[where w=t])
  apply (rule sync_gen_model_tLength)
  using assms
  apply (auto intro: gen_model_world_refl)
  done

(*>*)
text{*

This implies that for a synchronous view we can inductively define the
\emph{canonical traces} of a JKBP. These are the traces that a JKBP
generates when it is interpreted with respect to those very same
traces. We do this by constructing the sequence @{text "jkbpC\<^sub>n"} of
\emph{(canonical) temporal slices} similarly to @{term "jkbpT\<^bsub>n\<^esub>"}:

*}

fun jkbpCn :: "nat \<Rightarrow> 's Trace set"(*<*)("jkbpC\<^bsub>_\<^esub>")(*>*) where
  "jkbpC\<^bsub>0\<^esub>      = { tInit s |s. s \<in> set envInit }"
| "jkbpC\<^bsub>Suc n\<^esub> = { t \<leadsto> envTrans eact aact (tLast t) |t eact aact.
                             t \<in> jkbpC\<^bsub>n\<^esub> \<and> eact \<in> set (envAction (tLast t))
                          \<and> (\<forall>a. aact a \<in> set (jAction (mkM jkbpC\<^bsub>n\<^esub>) t a)) }"

abbreviation MCn :: "nat \<Rightarrow> ('a, 'p, 's Trace) KripkeStructure"(*<*)("MC\<^bsub>_\<^esub>")(*>*) where
  "MC\<^bsub>n\<^esub> \<equiv> mkM jkbpC\<^bsub>n\<^esub>"
(*<*)

lemma jkbpCn_step_inv:
  "t \<leadsto> s \<in> jkbpCn (Suc n) \<Longrightarrow> t \<in> jkbpCn n"
  by (induct n arbitrary: t, (fastforce simp add: Let_def)+)

lemma jkbpCn_length[simp]:
  "t \<in> jkbpCn n \<Longrightarrow> tLength t = n"
  by (induct n arbitrary: t, (fastforce simp add: Let_def)+)

lemma jkbpCn_init_inv[intro]:
  "tInit s \<in> jkbpCn n \<Longrightarrow> s \<in> set envInit"
   by (frule jkbpCn_length) auto

lemma jkbpCn_tFirst_init_inv[intro]:
 "t \<in> jkbpCn n \<Longrightarrow> tFirst t \<in> set envInit"
  by (induct n arbitrary: t) (auto iff: Let_def)

(*>*)
text{*

The canonical set of traces for a JKBP with respect to a joint view is
the set of canonical traces of all lengths.

*}

definition jkbpC :: "'s Trace set" where
  "jkbpC \<equiv> \<Union>n. jkbpC\<^bsub>n\<^esub>"

abbreviation MC :: "('a, 'p, 's Trace) KripkeStructure" where
  "MC \<equiv> mkM jkbpC"
(*<*)

lemma jkbpCn_jkbpC_subset:
  "jkbpCn n \<subseteq> jkbpC"
  unfolding jkbpC_def by blast

lemma jkbpCn_jkbpC_inc[intro]:
  "t \<in> jkbpCn n \<Longrightarrow> t \<in> jkbpC"
  unfolding jkbpC_def by best

lemma jkbpC_tLength_inv[intro]:
  "\<lbrakk> t \<in> jkbpC; tLength t = n \<rbrakk> \<Longrightarrow> t \<in> jkbpCn n"
  unfolding jkbpC_def
  by (induct n arbitrary: t, (fastforce simp add: Let_def)+)

lemma jkbpC_traces_of_length:
   "{ t \<in> jkbpC . tLength t = n } = jkbpCn n"
  unfolding jkbpC_def by bestsimp

lemma jkbpC_prefix_closed[dest]:
  "t \<leadsto> s \<in> jkbpC \<Longrightarrow> t \<in> jkbpC"
  apply (drule jkbpC_tLength_inv)
   apply simp
  apply (auto iff: Let_def jkbpC_def)
  done

lemma jkbpC_init[iff]:
  "tInit s \<in> jkbpC \<longleftrightarrow> s \<in> set envInit"
  unfolding jkbpC_def
  apply rule
   apply fast
  apply (subgoal_tac "tInit s \<in> jkbpCn 0")
   apply simp
  apply (rule_tac x=0 in exI)
  apply simp_all
  done

lemma jkbpC_jkbpCn_rels:
  "\<lbrakk> (u, v) \<in> relations MC a; tLength u = n \<rbrakk>
    \<Longrightarrow> (u, v) \<in> relations (MC\<^bsub>n\<^esub>) a"
  unfolding mkM_def by (fastforce dest: sync[rule_format])

lemma jkbpC_tFirst_init_inv[intro]:
  "t \<in> jkbpC \<Longrightarrow> tFirst t \<in> set envInit"
  unfolding jkbpC_def by blast

(*>*)
text{*

We can show that @{term "jkbpC"} represents the joint knowledge-based
program @{term "jkbp"} with respect to @{term "jview"}:

*}

lemma jkbpC_jkbpCn_jAction_eq:
  assumes tCn: "t \<in> jkbpC\<^bsub>n\<^esub>"
  shows "jAction MC t = jAction MC\<^bsub>n\<^esub> t"
(*<*)
  using assms
  by - (rule sync_jview_jAction_eq, auto iff: jkbpC_traces_of_length)

(*>*)
text{**}

text{**}

theorem jkbpC_represents: "represents jkbpC"
(*<*)
  using jkbpTn_jkbpCn_represents
  by (simp add: representsI jkbpC_def jkbpT_def)

(*>*)
text{*

We can show uniqueness too, by a similar argument:

*}

theorem jkbpC_represents_uniquely:
  assumes repT: "represents T"
  shows "T = jkbpC"
(*<*)
proof -
  { fix n
    have "{ t \<in> T . tLength t = n } = { t \<in> jkbpC . tLength t = n }"
    proof(induct n)
      case 0
      from repT have F: "{t \<in> T. tLength t = 0} = jkbpTn 0 T"
        by - (subst jkbpT_traces_of_length[symmetric], simp add: representsD)
      thus ?case by (simp add: jkbpC_traces_of_length)
    next
      case (Suc n)
      hence indhyp: "{t \<in> T. tLength t = n} = jkbpCn n"
        by (simp add: jkbpC_traces_of_length)

        (* F and H are very similar. *)
      from repT have F: "\<And>n. jkbpTn n T = {t \<in> T. tLength t = n}"
        by - (subst jkbpT_traces_of_length[symmetric], simp add: representsD)
      from indhyp F have G: "jkbpTn n T = jkbpCn n"
        by simp
      from repT have H: "\<And>n. {t \<in> T. tLength t = n} = {t \<in> jkbpTn n T. tLength t = n}"
        by (subst representsD[OF repT, symmetric], auto iff: jkbpT_traces_of_length jkbpTn_length)
      from F indhyp have ACTS:
        "\<And>t. t \<in> jkbpTn n T
          \<Longrightarrow> jAction (mkM T) t = jAction (MCn n) t"
        by - (rule sync_jview_jAction_eq[where n="n"], auto)
      show ?case
        apply (auto iff: Let_def ACTS G H jkbpC_traces_of_length)
        apply blast+
        done
    qed }
  thus ?thesis by auto
qed
(*>*)

end (* context PreEnvironmentJView *)

text{*

Thus, at least with synchronous views, we are justified in talking
about \emph{the} representation of a JKBP in a given environment. More
generally these results are also valid for the more general notion of
\emph{provides witnesses} as shown by \citet[Lemma 7.2.4]{FHMV:1995}
and \citet{DBLP:journals/dc/FaginHMV97}: it requires only that if a
subjective knowledge formula is false on a trace then there is a trace
of the same length or less that bears witness to that effect. This is
a useful generalisation in asynchronous settings.

The next section shows how we can construct canonical representations
of JKBPs using automata.

*}

(*<*)
end
(*>*)


theory TheoremD6
imports TheoremD5
begin

context LocalLexing begin

definition inc_dot :: "nat \<Rightarrow> item \<Rightarrow> item"
where
  "inc_dot d x = Item (item_rule x) (item_dot x + d) (item_origin x) (item_end x)"

lemma inc_dot_0[simp]: "inc_dot 0 x = x"
  by (simp add: inc_dot_def)

lemma Predict_mk_regular1:
  "\<exists> (P :: rule \<Rightarrow> item \<Rightarrow> bool) F. Predict k = mk_regular1 P F"
proof -
  let ?P = "\<lambda> r x::item. r \<in> \<RR> \<and> item_end x = k \<and> next_symbol x = Some(fst r)"
  let ?F = "\<lambda> r (x::item). init_item r k"
  show ?thesis
    apply (rule_tac x="?P" in exI)
    apply (rule_tac x="?F" in exI)
    apply (rule_tac ext)
    by (auto simp add: mk_regular1_def bin_def Predict_def)
qed

lemma Complete_mk_regular2:
  "\<exists> (P :: dummy \<Rightarrow> item \<Rightarrow> item \<Rightarrow> bool) F. Complete k = mk_regular2 P F"
proof -
  let ?P = "\<lambda> (r::dummy) x y. item_end x = item_origin y \<and> item_end y = k \<and> is_complete y \<and>
     next_symbol x = Some (item_nonterminal y)"
  let ?F = "\<lambda> (r::dummy) x y. inc_item x k"
  show ?thesis
    apply (rule_tac x="?P" in exI)
    apply (rule_tac x="?F" in exI)
    apply (rule_tac ext)
    by (auto simp add: mk_regular2_def bin_def Complete_def)
qed

lemma Scan_mk_regular1:
  "\<exists> (P :: token \<Rightarrow> item \<Rightarrow> bool) F. Scan T k = mk_regular1 P F"
proof -
  let ?P = "\<lambda> (tok::token) (x::item). item_end x = k \<and> tok \<in> T \<and> next_symbol x = Some (fst tok)"
  let ?F = "\<lambda> (tok::token) (x::item). inc_item x (k + length (snd tok))"
  show ?thesis
    apply (rule_tac x="?P" in exI)
    apply (rule_tac x="?F" in exI)
    apply (rule_tac ext)
    by (auto simp add: mk_regular1_def bin_def Scan_def)
qed

lemma Predict_regular: "regular (Predict k)"
  by (metis Predict_mk_regular1 regular1)

lemma Complete_regular: "regular (Complete k)"
  by (metis Complete_mk_regular2 regular2)

lemma Scan_regular: "regular (Scan T k)"
  by (metis Scan_mk_regular1 regular1)

lemma \<pi>_functional: "\<pi> k T = limit ((Scan T k) o (Complete k) o (Predict k))"
proof -
  have "\<pi> k T = limit (\<lambda> I. Scan T k (Complete k (Predict k I)))"
    using \<pi>_def by blast
  moreover have "(\<lambda> I. Scan T k (Complete k (Predict k I))) =
     (Scan T k) o (Complete k) o (Predict k)"
     apply (rule ext)
     by simp
  ultimately show ?thesis by simp
qed

lemma \<pi>_step_regular: "regular ((Scan T k) o (Complete k) o (Predict k))"
  by (simp add: Complete_regular Predict_regular Scan_regular regular_comp)

lemma \<pi>_regular: "regular (\<pi> k T)"
  by (simp add: \<pi>_functional \<pi>_step_regular regular_limit)

lemma \<pi>_fix: "Scan T k (Complete k (Predict k (\<pi> k T I))) = \<pi> k T I"
  using \<pi>_functional \<pi>_step_regular regular_fixpoint by fastforce

lemma \<pi>_fix': "((Scan T k) o (Complete k) o (Predict k)) (\<pi> k T I) = \<pi> k T I"
  using \<pi>_functional \<pi>_step_regular regular_fixpoint by fastforce

lemma setmonotone_cases:
  assumes "setmonotone f"
  shows "f X = X \<or> X \<subset> f X"
using assms elem_setmonotone by fastforce

lemma distribute_fixpoint_over_setmonotone_comp:
  assumes f: "setmonotone f"
  assumes g: "setmonotone g"
  assumes fixpoint: "(f o g) I = I"
  shows "f I = I \<and> g I = I"
proof -
  from setmonotone_cases[OF g, where X=I] show ?thesis
  proof(induct rule: disjCases2)
    case 1
      thus ?case using fixpoint by simp
  next
    case 2
      with f have "I \<subset> (f o g) I"
        by (metis comp_apply fixpoint less_asym' setmonotone_cases)
      with fixpoint have "False" by simp
      then show ?case by blast
  qed
qed

lemma distribute_fixpoint_over_setmonotone_comp_3:
  assumes f: "setmonotone f"
  assumes g: "setmonotone g"
  assumes h: "setmonotone h"
  assumes fixpoint: "(f o g o h) I = I"
  shows "f I = I \<and> g I = I \<and> h I = I"
by (meson distribute_fixpoint_over_setmonotone_comp f fixpoint g h setmonotone_comp)

lemma Predict_\<pi>_fix: "Predict k (\<pi> k T I) = \<pi> k T I"
by (meson Complete_regular Predict_regular Scan_regular \<pi>_fix'
  distribute_fixpoint_over_setmonotone_comp_3 regular_implies_setmonotone)

lemma Scan_\<pi>_fix: "Scan T k (\<pi> k T I) = \<pi> k T I"
by (meson Complete_regular Predict_regular Scan_regular \<pi>_fix'
  distribute_fixpoint_over_setmonotone_comp_3 regular_implies_setmonotone)

lemma Complete_\<pi>_fix: "Complete k (\<pi> k T I) = \<pi> k T I"
by (meson Complete_regular Predict_regular Scan_regular \<pi>_fix'
  distribute_fixpoint_over_setmonotone_comp_3 regular_implies_setmonotone)

lemma \<pi>_idempotent: "\<pi> k T (\<pi> k T I) = \<pi> k T I"
  by (simp add: \<pi>_functional \<pi>_step_regular limit_is_idempotent)

lemma derivation_shift_identity[simp]: "derivation_shift D 0 0 = D"
  by (simp add: derivation_shift_def)

lemma Derivation_skip_prefix: "Derivation (u@v) D w \<Longrightarrow> derivation_ge D (length u) \<Longrightarrow>
  Derivation v (derivation_shift D (length u) 0) (drop (length u) w)"
proof (induct D arbitrary: u v w)
  case Nil
    thus ?case by (simp add: append_eq_conv_conj)
next
  case (Cons d D)
    from Cons have "\<exists>x. Derives1 (u@v) (fst d) (snd d) x \<and> Derivation x D w" by auto
    then obtain x where x: "Derives1 (u@v) (fst d) (snd d) x \<and> Derivation x D w" by blast
    from Cons have d: "fst d \<ge> length u" and D: "derivation_ge D (length u)"
      using derivation_ge_cons apply blast
      using Cons.prems(2) derivation_ge_cons by blast
    have "\<exists> x'. x = u@x'" by (metis append_eq_conv_conj d le_Derives1_take x)
    then obtain x' where x': "x = u@x'" by blast
    show ?case
      apply simp
      apply (rule_tac x="x'" in exI)
      using Cons.hyps D Derives1_skip_prefix d x x' by blast
qed

lemma leftmost_skip_prefix: "leftmost i (u@v) \<Longrightarrow> i \<ge> length u \<Longrightarrow> leftmost (i - length u) v"
by (simp add: leftmost_def less_diff_conv2 nth_append)

lemma LeftDerivation_skip_prefix: "LeftDerivation (u@v) D w \<Longrightarrow> derivation_ge D (length u) \<Longrightarrow>
  LeftDerivation v (derivation_shift D (length u) 0) (drop (length u) w)"
proof (induct D arbitrary: u v w)
  case Nil
    thus ?case by (simp add: append_eq_conv_conj)
next
  case (Cons d D)
    from Cons have "\<exists>x. LeftDerives1 (u@v) (fst d) (snd d) x \<and> LeftDerivation x D w" by auto
    then obtain x where x: "LeftDerives1 (u@v) (fst d) (snd d) x \<and> LeftDerivation x D w" by blast
    from Cons have d: "fst d \<ge> length u" and D: "derivation_ge D (length u)"
      using derivation_ge_cons apply blast
      using Cons.prems(2) derivation_ge_cons by blast
    have "\<exists> x'. x = u@x'"
      by (metis LeftDerives1_implies_Derives1 append_eq_conv_conj d le_Derives1_take x)
    then obtain x' where x': "x = u@x'" by blast
    have leftmost: "leftmost (fst d) (u@v)" using LeftDerives1_def x by blast
    have 1: "LeftDerives1 v (fst d - length u) (snd d) x'"
      apply (auto simp add: LeftDerives1_def)
      apply (simp add: leftmost d leftmost_skip_prefix)
      using Derives1_skip_prefix LeftDerives1_implies_Derives1 d x x' by blast
    have 2: "LeftDerivation x' (derivation_shift D (length u) 0) (drop (length u) w)"
      using Cons.hyps D x x' by blast
    show ?case
      apply simp
      apply (rule_tac x="x'" in exI)
      using 1 2 by blast
qed

lemma splits_at_append: "splits_at u i u1 N u2 \<Longrightarrow> splits_at (u@v) i u1 N (u2@v)"
by (auto simp add: splits_at_def)

lemma LeftDerives1_append_leftmost_unique: "LeftDerives1 (a@b) i r c \<Longrightarrow> leftmost j a \<Longrightarrow> i = j"
  by (meson LeftDerives1_def leftmost_cons_less leftmost_def leftmost_unique)

lemma drop_derivation_shift:
  "drop n (derivation_shift D left right) = derivation_shift (drop n D) left right"
by (auto simp add: derivation_shift_def drop_map)

lemma take_derivation_shift:
  "take n (derivation_shift D left right) = derivation_shift (take n D) left right"
by (auto simp add: derivation_shift_def take_map)

lemma derivation_shift_0_shift: "derivation_shift (derivation_shift D left1 0) left2 right2 =
  derivation_shift D (left1 + left2) right2"
by (auto simp add: derivation_shift_def)

lemma splits_at_append_prefix:
  "splits_at v i \<alpha> N \<beta> \<Longrightarrow> splits_at (u@v) (i + length u) (u@\<alpha>) N \<beta>"
  apply (auto simp add: splits_at_def)
  by (simp add: nth_append)

lemma splits_at_implies_Derives1: "splits_at \<delta> i \<alpha> N \<beta> \<Longrightarrow> is_sentence \<delta> \<Longrightarrow> r\<in> \<RR> \<Longrightarrow> fst r = N
 \<Longrightarrow> Derives1 \<delta> i r (\<alpha>@(snd r)@\<beta>)"
by (metis (no_types, lifting) Derives1_def is_sentence_concat length_take
  less_or_eq_imp_le min.absorb2 prod.collapse splits_at_combine splits_at_def)

lemma Derives1_append_prefix:
  assumes Derives1: "Derives1 v i r w"
  assumes u: "is_sentence u"
  shows "Derives1 (u@v) (i + length u) r (u@w)"
proof -
  have "\<exists> \<alpha> N \<beta>. splits_at v i \<alpha> N \<beta>" using assms splits_at_ex by auto
  then obtain \<alpha> N \<beta> where split_v: "splits_at v i \<alpha> N \<beta>" by blast
  have split_w: "w = \<alpha>@(snd r)@\<beta>" using assms split_v splits_at_combine_dest by blast
  have split_uv: "splits_at (u@v) (i + length u) (u@\<alpha>) N \<beta>"
    by (simp add: split_v splits_at_append_prefix)
  have is_sentence_uv: "is_sentence (u@v)"
    using Derives1 Derives1_sentence1 is_sentence_concat u by blast
  show ?thesis
    by (metis Derives1 Derives1_nonterminal Derives1_rule append_assoc is_sentence_uv
        split_uv split_v split_w splits_at_implies_Derives1)
qed

lemma leftmost_prepend_word: "leftmost i v \<Longrightarrow> is_word u \<Longrightarrow> leftmost (i + length u) (u@v)"
by (simp add: leftmost_def nth_append)

lemma LeftDerives1_append_prefix:
  assumes Derives1: "LeftDerives1 v i r w"
  assumes u: "is_word u"
  shows "LeftDerives1 (u@v) (i + length u) r (u@w)"
proof -
  have 1: "Derives1 v i r w"
    by (simp add: Derives1 LeftDerives1_implies_Derives1)
  have 2: "leftmost i v"
    using Derives1 LeftDerives1_def by blast
  have 3: "is_sentence u" using u by fastforce
  have 4: "Derives1 (u@v) (i + length u) r (u@w)"
    by (simp add: "1" "3" Derives1_append_prefix)
  have 5: "leftmost (i + length u) (u@v)"
    by (simp add: "2" leftmost_prepend_word u)
  show ?thesis
    by (simp add: "4" "5" LeftDerives1_def)
qed

lemma Derivation_append_prefix: "Derivation v D w \<Longrightarrow> is_sentence u \<Longrightarrow>
  Derivation (u@v) (derivation_shift D 0 (length u)) (u@w)"
proof (induct D arbitrary: u v w)
  case Nil thus ?case by auto
next
  case (Cons d D)
    then have "\<exists> x. Derives1 v (fst d) (snd d) x \<and> Derivation x D w" by auto
    then obtain x where x: "Derives1 v (fst d) (snd d) x \<and> Derivation x D w" by blast
    with Cons have induct: "Derivation (u@x) (derivation_shift D 0 (length u)) (u@w)" by auto
    have Derives1: "Derives1 (u@v) ((fst d) + length u) (snd d) (u@x)"
      by (simp add: Cons.prems(2) Derives1_append_prefix x)
    show ?case
      apply simp
      apply (rule_tac x="u@x" in exI)
      by (simp add: Cons.hyps Cons.prems(2) Derives1 x)
qed

lemma LeftDerivation_append_prefix: "LeftDerivation v D w \<Longrightarrow> is_word u \<Longrightarrow>
  LeftDerivation (u@v) (derivation_shift D 0 (length u)) (u@w)"
proof (induct D arbitrary: u v w)
  case Nil thus ?case by auto
next
  case (Cons d D)
    then have "\<exists> x. LeftDerives1 v (fst d) (snd d) x \<and> LeftDerivation x D w" by auto
    then obtain x where x: "LeftDerives1 v (fst d) (snd d) x \<and> LeftDerivation x D w" by blast
    with Cons have induct: "LeftDerivation (u@x) (derivation_shift D 0 (length u)) (u@w)" by auto
    have Derives1: "LeftDerives1 (u@v) ((fst d) + length u) (snd d) (u@x)"
      by (simp add: Cons.prems(2) LeftDerives1_append_prefix x)
    show ?case
      apply simp
      apply (rule_tac x="u@x" in exI)
      by (simp add: Cons.hyps Cons.prems(2) Derives1 x)
qed

lemma derivation_ge_shift_simp: "derivation_ge D i \<Longrightarrow> i \<ge> l \<Longrightarrow> r \<ge> l \<Longrightarrow>
   derivation_shift D l r = derivation_shift D 0 (r - l)"
proof (induct D)
  case Nil thus ?case by auto
next
  case (Cons d D)
  have fst_d: "fst d \<ge> l"
    using Cons.prems(1) Cons.prems(2) derivation_ge_cons le_trans by blast
  show ?case
    apply auto
    using Cons fst_d apply arith
    using Cons derivation_ge_cons apply auto
    done
qed

lemma append_dropped_prefix: "is_prefix u v \<Longrightarrow> drop (length u) v = w \<Longrightarrow> u@w = v"
using is_prefix_unsplit by blast

lemma derivation_ge_shift_plus:
  assumes "derivation_ge D u"
  assumes "derivation_ge (derivation_shift D u 0) v"
  shows "derivation_ge D (u + v)"
proof -
  from assms show ?thesis
    apply (auto simp add: derivation_ge_def derivation_shift_def)
    by fastforce
qed

lemma LeftDerivation_breakdown:
  "LeftDerivation (u@v) D w \<Longrightarrow> \<exists> n w1 w2. w = w1 @ w2 \<and>
     LeftDerivation u (take n D) w1 \<and>
     derivation_ge (drop n D) (length w1) \<and>
     LeftDerivation v (derivation_shift (drop n D) (length w1) 0) w2"
proof (induct "length D" arbitrary: u v D w)
  case 0
    then have D: "D = []" by auto
    with 0 have "u@v = w" by auto
    with D show ?case
      apply (rule_tac x=0 in exI)
      apply (rule_tac x="u" in exI)
      apply (rule_tac x="v" in exI)
      by auto
next
  case (Suc l)
    then have "\<exists> d D'. D = d#D'"
      by (metis LeftDerivation.elims(2) length_0_conv nat.simps(3))
    then obtain d D' where D_split: "D = d#D'" by blast
    from Suc have is_sentence_uv: "is_sentence (u@v)"
      by (metis D_split Derives1_sentence1 LeftDerivation.simps(2) LeftDerives1_implies_Derives1)
    then have is_sentence_u: "is_sentence u" and is_sentence_v: "is_sentence v"
      by (simp add: is_sentence_concat)+
    have "is_word u \<or> (\<not> is_word u)" by blast
    then show ?case
      proof(induct rule: disjCases2)
        case 1
          then have derivation_ge_u: "derivation_ge D (length u)"
            using LeftDerivation_implies_Derivation Suc.prems is_word_Derivation_derivation_ge by blast
          have is_prefix: "is_prefix u w"
            using "1.hyps" LeftDerivation_implies_leftderives Suc.prems
              derives_word_is_prefix leftderives_implies_derives by blast
          have u_w: "w = u @ (drop (length u) w)"
            by (metis "1.hyps" LeftDerivation_implies_leftderives Suc.prems
              derives_word_is_prefix is_prefix_unsplit leftderives_implies_derives)
          show ?case
            apply (rule_tac x="0" in exI)
            apply (rule_tac x="u" in exI)
            apply (rule_tac x="drop (length u) w" in exI)
            apply (auto)
            apply (rule u_w)
            apply (rule derivation_ge_u)
            by (simp add: LeftDerivation_skip_prefix Suc.prems derivation_ge_u)
      next
        case 2
          with is_sentence_u have "\<exists> i u1 N u2. splits_at u i u1 N u2 \<and> leftmost i u"
            using leftmost_def nonword_leftmost_exists splits_at_def by auto
          then obtain i u1 N u2 where split_u: "splits_at u i u1 N u2 \<and> leftmost i u" by blast
          have is_word_u1: "is_word u1" by (metis leftmost_def split_u splits_at_def)
          have "LeftDerivation (u@v) (d#D') w"  using D_split Suc.prems by blast
          then have "\<exists> x. LeftDerives1 (u@v) (fst d) (snd d) x \<and> LeftDerivation x D' w"
            by simp
          then obtain x where x: "LeftDerives1 (u@v) (fst d) (snd d) x \<and> LeftDerivation x D' w"
            by blast
          then have fst_d_eq_i: "fst d = i" using
            splits_at_combine LeftDerives1_append_leftmost_unique split_u
            by metis
          have split_uv: "splits_at (u@v) i u1 N (u2@v)" by (simp add: split_u splits_at_append)
          have split_x: "x = u1 @ ((snd (snd d)) @ u2 @ v)"
            using LeftDerives1_implies_Derives1 fst_d_eq_i split_uv
              splits_at_combine_dest x by blast
          have derivation_ge_D': "derivation_ge D' (length u1)"
            using LeftDerivation_implies_Derivation is_word_Derivation_derivation_ge
              leftmost_def split_u split_x splits_at_def x by fastforce
          have D1: "LeftDerivation ((snd (snd d)) @ u2 @ v) (derivation_shift D' (length u1) 0)
            (drop (length u1) w)"
            using LeftDerivation_skip_prefix derivation_ge_D' split_x x by blast
          then have D2: "LeftDerivation (((snd (snd d)) @ u2) @ v) (derivation_shift D' (length u1) 0)
            (drop (length u1) w)" by auto
          have "l = length (derivation_shift D' (length u1) 0)"
            using D_split Suc.hyps(2) by auto
          from Suc(1)[OF this D2] obtain n w1 w2 where induct:
            "drop (length u1) w = w1 @ w2 \<and>
             LeftDerivation (snd (snd d) @ u2)
               (take n (derivation_shift D' (length u1) 0)) w1 \<and>
             derivation_ge (drop n (derivation_shift D' (length u1) 0)) (length w1) \<and>
             LeftDerivation v (derivation_shift (drop n (derivation_shift D' (length u1) 0))
               (length w1) 0) w2" by blast
          have derivation_ge_D'_u1_w1: "derivation_ge (drop n D') (length u1 + length w1)"
          proof -
            from induct have 1: "derivation_ge (derivation_shift (drop n D') (length u1) 0) (length w1)"
              apply (subst drop_derivation_shift[symmetric])
              by blast
            have 2: "derivation_ge (drop n D') (length u1)"
              by (metis append_take_drop_id derivation_ge_D' derivation_ge_append)
            show ?thesis using 1 2 derivation_ge_shift_plus by blast
          qed
          have "LeftDerivation (u1@(snd (snd d) @ u2)) (derivation_shift
                (take n (derivation_shift D' (length u1) 0)) 0 (length u1)) (u1@w1)"
          using induct LeftDerivation_append_prefix is_word_u1 by blast
          then have der1: "LeftDerivation (u1@(snd (snd d) @ u2))
              (derivation_shift (take n D') (length u1) (length u1)) (u1@w1)"
            using take_derivation_shift derivation_shift_0_shift by auto
          have eq1: "derivation_shift (take n D') (length u1) (length u1) = take n D'"
            apply (subst derivation_ge_shift_simp[where i = "length u1"])
            apply auto
            by (metis append_take_drop_id derivation_ge_D' derivation_ge_append)
          from der1 eq1 have der2: "LeftDerivation (u1@(snd (snd d) @ u2)) (take n D') (u1@w1)"
            by auto
          have eq2: "take (Suc n) D = d#(take n D')"
            by (simp add: D_split)
          have der3: "LeftDerivation u (take (Suc n) D) (u1@w1)"
            apply (simp add: eq2)
            apply (rule_tac x="u1@(snd (snd d) @ u2)" in exI)
            by (metis Derives1_skip_suffix LeftDerives1_def append_assoc der2 fst_d_eq_i
              split_u split_x splits_at_def x)
          have "is_prefix u1 w"
            using LeftDerivation_implies_leftderives derives_word_is_prefix is_word_u1
              leftderives_implies_derives split_x x by blast
          then have eq3: "u1 @ (w1@w2) = w"
            apply (rule_tac append_dropped_prefix)
            apply (auto simp add: induct)
            done
          show ?case
            apply (rule_tac x="Suc n" in exI)
            apply (rule_tac x="u1@w1" in exI)
            apply (rule_tac x="w2" in exI)
            apply auto
            apply (simp add: eq3)
            apply (simp add: der3)
            apply (simp add: D_split)
            apply (rule derivation_ge_D'_u1_w1)
            apply (simp add: D_split)
            using induct derivation_shift_0_shift drop_derivation_shift apply auto
            done
      qed
qed

lemma Derives1_terminals_stay:
  assumes Derives1: "Derives1 u i r v"
  assumes t_dom: "t \<in> set u"
  assumes terminal: "is_terminal t"
  shows "t \<in> set v"
proof -
  have "\<exists> \<alpha> \<beta> N. splits_at u i \<alpha> N \<beta>" using Derives1 splits_at_ex by blast
  then obtain \<alpha> \<beta> N where split_u: "splits_at u i \<alpha> N \<beta>" by blast
  then have "t \<in> set (\<alpha> @ [N] @ \<beta>)" using splits_at_combine t_dom by auto
  then have t_possible_locations: "t \<in> set \<alpha> \<or> t = N \<or> t \<in> set \<beta>" by auto
  have is_nonterminal: "is_nonterminal N" using Derives1 Derives1_nonterminal split_u by auto
  with t_possible_locations terminal have t_locations: "t \<in> set \<alpha> \<or> t \<in> set \<beta>"
    using is_terminal_nonterminal by blast
  from Derives1 split_u have "v = \<alpha> @ (snd r) @ \<beta>" by (simp add: splits_at_combine_dest)
  with t_locations show ?thesis by auto
qed

lemma Derivation_terminals_stay: "Derivation u D v \<Longrightarrow> t \<in> set u \<Longrightarrow> is_terminal t \<Longrightarrow> t \<in> set v"
proof (induct D arbitrary: u v)
  case Nil thus ?case by auto
next
  case (Cons d D)
  then have "\<exists> x. Derives1 u (fst d) (snd d) x \<and> Derivation x D v" by auto
  then obtain x where x: "Derives1 u (fst d) (snd d) x \<and> Derivation x D v" by auto
  show ?case using Cons Derives1_terminals_stay x by blast
qed

lemma Derivation_empty_no_terminals: "Derivation u D [] \<Longrightarrow> t \<in> set u \<Longrightarrow> is_nonterminal t"
  by (metis Ball_set Derivation_implies_derives Derivation_terminals_stay
    derives_is_sentence is_sentence_def is_symbol_distinct list.pred_inject(1))

lemma mono_subset_elem: "mono f \<Longrightarrow> A \<subseteq> B \<Longrightarrow> x \<in> f A \<Longrightarrow> x \<in> f B" using mono_def by blast

lemma wellformed_inc_dot: "wellformed_item x \<Longrightarrow> item_dot x + d \<le> length (item_rhs x) \<Longrightarrow>
  wellformed_item(inc_dot d x)"
by (simp add: inc_dot_def item_rhs_def wellformed_item_def)

lemma init_item_dot[simp]: "item_dot (init_item r k) = 0"
  by (simp add: init_item_def)

lemma init_item_rhs[simp]: "item_rhs (init_item r k) = snd r"
  by (simp add: init_item_def item_rhs_def)

lemma init_item_\<beta>[simp]: "item_\<beta> (init_item r k) = snd r"
  by (simp add: item_\<beta>_def)

lemma mono_\<pi>: "mono (\<pi> k T)"
  by (simp add: \<pi>_regular regular_implies_mono)

lemma \<pi>_subset_elem_trans:
  assumes Y: "Y \<subseteq> \<pi> k T X"
  assumes z: "z \<in> \<pi> k T Y"
  shows "z \<in>  \<pi> k T X"
proof -
  from Y have "\<pi> k T Y \<subseteq> \<pi> k T (\<pi> k T X)" by (simp add: monoD mono_\<pi>)
  then have "\<pi> k T Y \<subseteq> \<pi> k T X" using \<pi>_idempotent by blast
  with z show ?thesis using contra_subsetD by blast
qed

lemma inc_dot_end[simp]: "item_end (inc_dot d x) = item_end x"
  by (simp add: inc_dot_def)

lemma inc_dot_rhs[simp]: "item_rhs (inc_dot d x) = item_rhs x"
  by (simp add: inc_dot_def item_rhs_def)

lemma inc_dot_dot[simp]: "item_dot (inc_dot d x) = item_dot x + d"
  by (simp add: inc_dot_def)

lemma inc_dot_nonterminal[simp]: "item_nonterminal (inc_dot d x) = item_nonterminal x"
  by (simp add: inc_dot_def item_nonterminal_def)

lemma Predict_subset_\<pi>: "Predict k X \<subseteq> \<pi> k T X"
proof -
  have "setmonotone (\<pi> k T)"
    by (simp add: \<pi>_regular regular_implies_setmonotone)
  then have s: "X \<subseteq> \<pi> k T X" by (simp add: subset_setmonotone)
  have "mono (Predict k)" by (simp add: Predict_regular regular_implies_mono)
  with s have "Predict k X \<subseteq> Predict k (\<pi> k T X)" by (simp add: monoD)
  then show "Predict k X \<subseteq> \<pi> k T X" by (simp add: Predict_\<pi>_fix)
qed

lemma Complete_subset_\<pi>: "Complete k X \<subseteq> \<pi> k T X"
proof -
  have "setmonotone (\<pi> k T)"
    by (simp add: \<pi>_regular regular_implies_setmonotone)
  then have s: "X \<subseteq> \<pi> k T X" by (simp add: subset_setmonotone)
  have "mono (Complete k)" by (simp add: Complete_regular regular_implies_mono)
  with s have "Complete k X \<subseteq> Complete k (\<pi> k T X)" by (simp add: monoD)
  then show "Complete k X \<subseteq> \<pi> k T X" by (simp add: Complete_\<pi>_fix)
qed

lemma inc_inc_dot[simp]: "inc_dot a (inc_dot b x) = inc_dot (a + b) x"
  by (simp add: inc_dot_def)

lemma thmD6_Left: "wellformed_item x \<Longrightarrow> item_\<beta> x = \<delta> @ \<omega> \<Longrightarrow> item_end x = k \<Longrightarrow>
  LeftDerivation \<delta> D [] \<Longrightarrow> inc_dot (length \<delta>) x \<in> \<pi> k {} {x}"
proof (induct "length D" arbitrary: x \<delta> \<omega> D rule: less_induct)
  case less
    have "length \<delta> = 0 \<or> length \<delta> = 1 \<or> length \<delta> \<ge> 2" by arith
    then show ?case
    proof (induct rule: disjCases3)
      case 1
        then have "\<delta> = []" by auto
        then show ?case by (simp add: \<pi>_regular elem_setmonotone regular_implies_setmonotone)
    next
      case 2
        then have "\<exists> N. \<delta> = [N]"
          by (metis One_nat_def append_self_conv2 drop_all id_take_nth_drop
            le_numeral_extra(4) lessI take_0)
        then obtain N where N: "\<delta> = [N]" by blast
        then have "N \<in> set \<delta>" by auto
        then have is_nonterminal_N: "is_nonterminal N" using Derivation_empty_no_terminals
          LeftDerivation_implies_Derivation less.prems(4) by blast
        have "D \<noteq> []" using LeftDerivation.elims(2) N less.prems(4) by blast
        then have "\<exists> e E. D = e#E" using LeftDerivation.elims(2) less.prems(4) by blast
        then obtain e E where eE: "D = e#E" by blast
        then have "\<exists> \<gamma>. LeftDerives1 \<delta> (fst e) (snd e) \<gamma> \<and>
          LeftDerivation \<gamma> E []" using LeftDerivation.simps(2) less.prems(4) by blast
        then obtain \<gamma> where \<gamma>: "LeftDerives1 \<delta> (fst e) (snd e) \<gamma> \<and> LeftDerivation \<gamma> E []" by blast
        with N have \<gamma>_def: "\<gamma> = snd (snd e)"
          by (metis "2.hyps" Derives1_split LeftDerives1_def One_nat_def append_Cons
            append_Nil append_Nil2 leftmost_def length_0_conv less_nat_zero_code linorder_neqE_nat
            list.inject not_less_eq)
        have next_symbol_x: "next_symbol x = Some N"
          using N less.prems(1) less.prems(2) next_symbol_def next_symbol_starts_item_\<beta>
            wellformed_complete_item_\<beta> by fastforce
        have x_subset: "{x} \<subseteq> \<pi> k {} {x}"
          using \<pi>_regular regular_implies_setmonotone subset_setmonotone by blast
        let ?y = "init_item (snd e) k"
        have "?y \<in> Predict k {x}"
          apply (simp add: Predict_def)
          apply (rule disjI2)
          apply (rule_tac x="fst (snd e)" in exI)
          apply (rule_tac x="snd (snd e)" in exI)
          apply auto
          using Derives1_rule LeftDerives1_implies_Derives1 \<gamma> apply blast
          apply (rule_tac x=x in exI)
          by (metis (mono_tags, lifting) Derives1_split LeftDerives1_def N \<gamma>
              append.simps(1) append.simps(2) bin_def is_nonterminal_N leftmost_cons_nonterminal
              leftmost_unique length_greater_0_conv less.prems(3) less_nat_zero_code
              list.inject mem_Collect_eq next_symbol_x singletonI)
       then have y_dom: "?y \<in> \<pi> k {} {x}" using Predict_subset_\<pi> by blast
       let ?z = "inc_dot (length \<gamma>) ?y"
       have "item_dot ?y = 0" and "item_rhs ?y = \<gamma>" by (auto simp add: \<gamma>_def)
       note y_props = this
       then have wellformed_y: "wellformed_item ?y"
        using Derives1_rule LeftDerives1_implies_Derives1 \<gamma> less.prems(1) less.prems(3)
          wellformed_init_item wellformed_item_def by blast
       with y_props have wellformed_z: "wellformed_item ?z" by (simp add: wellformed_inc_dot)
       have item_\<beta>_y: "item_\<beta> ?y = \<gamma> @ []" using item_rhs_split y_props(2) by auto
       have is_complete_z: "is_complete ?z" by (simp add: is_complete_def \<gamma>_def)
       have "?z \<in> \<pi> k {} {?y}"
         apply (rule less(1)[where D="E"])
         apply (auto simp add: eE wellformed_y \<gamma>)
         apply (simp add: \<gamma>_def)
         done
       with y_dom have z_dom: "?z \<in> \<pi> k {} {x}"
         using \<pi>_subset_elem_trans empty_subsetI insert_subset by blast
       let ?w = "inc_dot (length \<delta>) x"
       have "?w \<in> Complete k {x, ?z}"
        apply (simp add: Complete_def)
        apply (rule_tac disjI2)+
        apply (rule_tac x=x in exI)
        apply (auto simp add: 2)
        apply (simp add: inc_dot_def inc_item_def less)
        apply (rule_tac x="?z" in exI)
        apply (auto simp add: bin_def less is_complete_z next_symbol_x)
        by (metis Derives1_split LeftDerives1_def N \<gamma> append_Cons append_self_conv2
          is_nonterminal_N leftmost_cons_nonterminal leftmost_unique length_0_conv list.inject)
       then have "?w \<in> \<pi> k {} {x, ?z}" using Complete_subset_\<pi> by blast
       then show ?case by (meson \<pi>_subset_elem_trans insert_subset x_subset z_dom)
    next
      case 3
       then have "\<exists> N \<alpha>. \<delta> = [N] @ \<alpha>"
         by (metis append_Cons append_Nil count_terminals.cases le0 le_0_eq list.size(3)
           numeral_le_iff semiring_norm(69))
       then obtain N \<alpha> where \<delta>_split: "\<delta> = [N] @ \<alpha>" by blast
       with 3 have \<alpha>_nonempty: "\<alpha> \<noteq> []"
         by (metis (full_types) One_nat_def Suc_eq_plus1 append_Nil2 impossible_Cons length_Cons
          list.size(3) nat_1_add_1)
       have "LeftDerivation ([N] @ \<alpha>) D []" using \<delta>_split less.prems(4) by blast
       from LeftDerivation_breakdown[OF this, simplified]
       obtain n where n: "LeftDerivation [N] (take n D) [] \<and> LeftDerivation \<alpha> (drop n D) []" by blast
       let ?E = "take n D"
       from n have E: "LeftDerivation [N] ?E []" by auto
       let ?F = "drop n D"
       from n have F: "LeftDerivation \<alpha> ?F []" by auto
       have length_add: "length ?E + length ?F = length D" by simp
       have "?E \<noteq> []" using E by force
       then have length_E_0: "length ?E > 0" by auto
       have "?F \<noteq> []" using F \<alpha>_nonempty by force
       then have length_F_0: "length ?F > 0" by auto
       from length_add length_E_0 length_F_0
       have "length ?E < length D \<and> length ?F < length D"
         using add.commute nat_add_left_cancel_less nat_neq_iff not_add_less2 by linarith
       then have length_E: "length ?E < length D" and length_F: "length ?F < length D" by auto
       let ?y = "inc_dot (length [N]) x"
       have y_dom: "?y \<in> \<pi> k {} {x}"
        apply (rule_tac less(1)[where D="?E" and \<omega>="\<alpha>@\<omega>"])
        apply (rule length_E)
        by (auto simp add: less \<delta>_split E)
      let ?z = "inc_dot (length \<alpha>) ?y"
      have wellformed_y: "wellformed_item ?y"
        using \<delta>_split is_complete_def less.prems(1) less.prems(2) wellformed_complete_item_\<beta>
          wellformed_inc_dot by fastforce
      have "?z \<in> \<pi> k {} {?y}"
        apply (rule_tac less(1)[where D="?F" and \<omega>="\<omega>"])
        apply (rule length_F)
        apply (rule wellformed_y)
        apply (auto simp add: F less)
        by (metis \<delta>_split add.commute append_assoc append_eq_conv_conj drop_drop inc_dot_dot
          inc_dot_rhs item_\<beta>_def length_Cons less.prems(2) list.size(3))
      then have z_dom: "?z \<in> \<pi> k {} {x}" using \<pi>_subset_elem_trans y_dom by blast
      have "?z = inc_dot (length \<delta>) x" by (simp add: \<delta>_split)
      with z_dom show ?case by auto
    qed
qed

lemma derives_empty_implies_LeftDerivation: "derives \<delta> [] \<Longrightarrow> \<exists> D. LeftDerivation \<delta> D []"
  using derives_implies_leftderives is_word_def leftderives_implies_LeftDerivation
    list.pred_inject(1) by blast

lemma thmD6: "wellformed_item x \<Longrightarrow> item_\<beta> x = \<delta> @ \<omega> \<Longrightarrow> item_end x = k \<Longrightarrow>
  derives \<delta> [] \<Longrightarrow> inc_dot (length \<delta>) x \<in> \<pi> k {} {x}"
using derives_empty_implies_LeftDerivation thmD6_Left by blast

end

end