theory Independent_Posts_Network
  imports
    "Independent_DYNAMIC_Post_Network"
    "BD_Security_Compositional.Independent_Secrets"
begin

subsubsection \<open>Composition of confidentiality guarantees for different posts\<close>

text \<open>We combine \<^emph>\<open>two\<close> confidentiality guarantees for two different posts in arbitrary nodes of
the network.

For this purpose, we have strengthened the observation power of the security property for
individual posts to make all transitions that update \<^emph>\<open>other\<close> posts observable, as well as all
transitions that contribute to the state of the trigger (see the observation setup
theories).  This guarantees that the confidentiality of one post is independent of actions
affecting other posts, which will allow us to combine security guarantees for different posts.

We now prove a few helper lemmas establishing that now the observable transitions indeed
fully determine the state of the trigger.\<close>

fun obsEffect :: "state \<Rightarrow> obs \<Rightarrow> state" where
  "obsEffect s (Uact (uPost uid p pid pst), ou) = updatePost s uid p pid pst"
| "obsEffect s (Uact (uVisPost uid p pid v), ou) = updateVisPost s uid p pid v"
| "obsEffect s (Sact (sSys uid p), ou) = startSys s uid p"
| "obsEffect s (Cact (cUser uid p uid' p'), ou) = createUser s uid p uid' p'"
| "obsEffect s (Cact (cPost uid p pid), ou) = createPost s uid p pid"
| "obsEffect s (Cact (cFriend uid p uid'), ou) = createFriend s uid p uid'"
| "obsEffect s (Dact (dFriend uid p uid'), ou) = deleteFriend s uid p uid'"
| "obsEffect s (COMact (comSendPost uid p aid pid), ou) = snd (sendPost s uid p aid pid)"
| "obsEffect s (COMact (comReceivePost aid p pid pst uid v), ou) = receivePost s aid p pid pst uid v"
| "obsEffect s (COMact (comReceiveCreateOFriend aid p uid uid'), ou) = receiveCreateOFriend s aid p uid uid'"
| "obsEffect s (COMact (comReceiveDeleteOFriend aid p uid uid'), ou) = receiveDeleteOFriend s aid p uid uid'"
| "obsEffect s _ = s"

fun obsStep :: "state \<Rightarrow> obs \<Rightarrow> state" where
  "obsStep s (a,ou) = (if ou \<noteq> outErr then obsEffect s (a,ou) else s)"

fun obsSteps :: "state \<Rightarrow> obs list \<Rightarrow> state" where
  "obsSteps s obsl = foldl obsStep s obsl"

definition triggerEq :: "state \<Rightarrow> state \<Rightarrow> bool" where
  "triggerEq s s' \<longleftrightarrow> userIDs s = userIDs s' \<and> postIDs s = postIDs s' \<and> admin s = admin s' \<and>
                      owner s = owner s' \<and> friendIDs s = friendIDs s' \<and> vis s = vis s' \<and>
                      outerPostIDs s = outerPostIDs s' \<and> outerOwner s = outerOwner s' \<and>
                      recvOuterFriendIDs s = recvOuterFriendIDs s' \<and> outerVis s = outerVis s'"

lemma triggerEq_refl[simp]: "triggerEq s s"
and triggerEq_sym: "triggerEq s s' \<Longrightarrow> triggerEq s' s"
and triggerEq_trans: "triggerEq s s' \<Longrightarrow> triggerEq s' s'' \<Longrightarrow> triggerEq s s''"
unfolding triggerEq_def by auto

no_notation relcomp (infixr "O" 75)

context Post
begin

lemma triggerEq_open:
assumes "triggerEq s s'"
shows "open s \<longleftrightarrow> open s'"
using assms unfolding triggerEq_def open_def by auto

lemma triggerEq_not_\<gamma>:
assumes "validTrans (Trans s a ou s')" and "\<not>\<gamma> (Trans s a ou s')"
shows "triggerEq s s'"
proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: triggerEq_def s_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def c_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: triggerEq_def d_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: triggerEq_def u_defs) next
  case (Ract ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (Lact ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def com_defs)
qed

lemma triggerEq_obsStep:
assumes "validTrans (Trans s a ou s')" and "\<gamma> (Trans s a ou s')" and "triggerEq s s1"
shows "triggerEq s' (obsStep s1 (g (Trans s a ou s')))"
proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: triggerEq_def s_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def c_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: triggerEq_def d_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: triggerEq_def u_defs) next
  case (Ract ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (Lact ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def com_defs)
qed

lemma triggerEq_obsSteps:
assumes "validFrom s tr" and "triggerEq s s'"
shows "triggerEq (tgtOfTrFrom s tr) (obsSteps s' (O tr))"
using assms proof (induction tr arbitrary: s s')
  case (Nil s s')
  then show ?case by auto
next
  case (Cons trn tr s s')
  then obtain a ou s'' where trn: "trn = Trans s a ou s''" and step: "step s a = (ou, s'')"
    by (cases trn) (auto simp: validFrom_Cons)
  show ?case proof cases
    assume \<gamma>: "\<gamma> trn"
    then have "triggerEq s'' (obsStep s' (g trn))" unfolding trn using step Cons(3) by (auto intro: triggerEq_obsStep)
    with Cons.IH[OF _ this] Cons(2) \<gamma> trn show ?thesis by (auto simp: validFrom_Cons)
  next
    assume n\<gamma>: "\<not> \<gamma> trn"
    then have "triggerEq s s''" using Cons(2) unfolding trn by (intro triggerEq_not_\<gamma>) (auto simp: validFrom_Cons)
    with Cons(3) have "triggerEq s'' s'" by (auto intro: triggerEq_sym triggerEq_trans)
    with Cons.IH[OF _ this] Cons(2) n\<gamma> trn show ?thesis by (auto simp: validFrom_Cons)
  qed
qed

end

context Post_RECEIVER
begin

lemma sPurge_simp[simp]: "sPurge sa = sSys (sUserOfA sa) emptyPass" by (cases sa) auto

definition "T_state s' \<equiv>
(\<exists> uid \<in> UIDs.
   uid \<in>\<in> userIDs s' \<and> PID \<in>\<in> outerPostIDs s' AID \<and>
   (uid = admin s' \<or>
    (AID,outerOwner s' AID PID) \<in>\<in> recvOuterFriendIDs s' uid \<or>
    outerVis s' AID PID = PublicV))"

lemma T_T_state: "T trn \<longleftrightarrow> T_state (tgtOf trn)"
by (cases trn) (auto simp: T_state_def)

lemma triggerEq_T:
assumes "triggerEq s s'"
shows "T_state s \<longleftrightarrow> T_state s'"
using assms unfolding triggerEq_def T_state_def by auto

lemma never_T_not_T_state:
assumes "validFrom s tr" and "never T tr" and "\<not>T_state s"
shows "\<not>T_state (tgtOfTrFrom s tr)"
using assms by (induction tr arbitrary: s rule: rev_induct) (auto simp: T_T_state)

lemma triggerEq_not_\<gamma>:
assumes "validTrans (Trans s a ou s')" and "\<not>\<gamma> (Trans s a ou s')"
shows "triggerEq s s'"
proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: triggerEq_def s_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def c_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: triggerEq_def d_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: triggerEq_def u_defs) next
  case (Ract ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (Lact ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def com_defs)
qed

lemma triggerEq_obsStep:
assumes "validTrans (Trans s a ou s')" and "\<gamma> (Trans s a ou s')" and "triggerEq s s1"
shows "triggerEq s' (obsStep s1 (g (Trans s a ou s')))"
proof (cases a)
  case (Sact sa) then show ?thesis using assms by (cases sa) (auto simp: triggerEq_def s_defs) next
  case (Cact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def c_defs) next
  case (Dact da) then show ?thesis using assms by (cases da) (auto simp: triggerEq_def d_defs) next
  case (Uact ua) then show ?thesis using assms by (cases ua) (auto simp: triggerEq_def u_defs) next
  case (Ract ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (Lact ra) then show ?thesis using assms by (auto simp: triggerEq_def) next
  case (COMact ca) then show ?thesis using assms by (cases ca) (auto simp: triggerEq_def com_defs)
qed

lemma triggerEq_obsSteps:
assumes "validFrom s tr" and "triggerEq s s'"
shows "triggerEq (tgtOfTrFrom s tr) (obsSteps s' (O tr))"
using assms proof (induction tr arbitrary: s s')
  case (Nil s s')
  then show ?case by auto
next
  case (Cons trn tr s s')
  then obtain a ou s'' where trn: "trn = Trans s a ou s''" and step: "step s a = (ou, s'')"
    by (cases trn) (auto simp: validFrom_Cons)
  show ?case proof cases
    assume \<gamma>: "\<gamma> trn"
    then have "triggerEq s'' (obsStep s' (g trn))" unfolding trn using step Cons(3) by (auto intro: triggerEq_obsStep)
    with Cons.IH[OF _ this] Cons(2) \<gamma> trn show ?thesis by (auto simp: validFrom_Cons)
  next
    assume n\<gamma>: "\<not> \<gamma> trn"
    then have "triggerEq s s''" using Cons(2) unfolding trn by (intro triggerEq_not_\<gamma>) (auto simp: validFrom_Cons)
    with Cons(3) have "triggerEq s'' s'" by (auto intro: triggerEq_sym triggerEq_trans)
    with Cons.IH[OF _ this] Cons(2) n\<gamma> trn show ?thesis by (auto simp: validFrom_Cons)
  qed
qed

end

context Post_Network
begin

fun nObsStep :: "(apiID \<Rightarrow> state) \<Rightarrow> (apiID, act \<times> out) nobs \<Rightarrow> (apiID \<Rightarrow> state)" where
  "nObsStep s (LObs aid obs) = s(aid := obsStep (s aid) obs)"
| "nObsStep s (CObs aid1 obs1 aid2 obs2) = s(aid1 := obsStep (s aid1) obs1, aid2 := obsStep (s aid2) obs2)"

fun nObsSteps :: "(apiID \<Rightarrow> state) \<Rightarrow> (apiID, act \<times> out) nobs list \<Rightarrow> (apiID \<Rightarrow> state)" where
  "nObsSteps s obsl = foldl nObsStep s obsl"

definition nTriggerEq :: "(apiID \<Rightarrow> state) \<Rightarrow> (apiID \<Rightarrow> state) \<Rightarrow> bool" where
  "nTriggerEq s s' \<longleftrightarrow> (\<forall>aid. triggerEq (s aid) (s' aid))"

lemma nTriggerEq_refl[simp]: "nTriggerEq s s"
and nTriggerEq_sym: "nTriggerEq s s' \<Longrightarrow> nTriggerEq s' s"
and nTriggerEq_trans: "nTriggerEq s s' \<Longrightarrow> nTriggerEq s' s'' \<Longrightarrow> nTriggerEq s s''"
unfolding nTriggerEq_def by (auto intro: triggerEq_sym triggerEq_trans)

lemma nTriggerEq_open:
assumes "nTriggerEq s s'"
shows "\<forall>aid. Iss.open (s aid) \<longleftrightarrow> Iss.open (s' aid)"
using assms unfolding nTriggerEq_def by (auto intro!: Iss.triggerEq_open)

lemma nTriggerEq_not_\<gamma>:
assumes "nValidTrans trn" and "\<not>Net.n\<gamma> trn"
shows "nTriggerEq (nSrcOf trn) (nTgtOf trn)"
proof (cases trn)
  case (LTrans s aid1 trn1)
  with assms show ?thesis using Iss.triggerEq_not_\<gamma> Post_RECEIVER.triggerEq_not_\<gamma>
    by (cases trn1) (auto simp: nTriggerEq_def)
next
  case (CTrans s aid1 trn1 aid2 trn2)
  with assms show ?thesis
    by (auto elim: sync_cases simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps Strong_ObservationSetup_ISSUER.\<gamma>.simps)
qed

lemma nTriggerEq_obsStep:
assumes "nValidTrans trn" and "Net.n\<gamma> trn" and "nTriggerEq (nSrcOf trn) s1"
shows "nTriggerEq (nTgtOf trn) (nObsStep s1 (Net.ng trn))"
unfolding nTriggerEq_def proof
  fix aid
  show "triggerEq (nTgtOf trn aid) (nObsStep s1 (Net.ng trn) aid)"
  proof (cases trn)
    case (LTrans s aid1 trn1)
    with assms show ?thesis unfolding nTriggerEq_def
      by (cases trn1) (auto intro: Iss.triggerEq_obsStep Post_RECEIVER.triggerEq_obsStep)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then have "sync aid1 trn1 aid2 trn2" using assms by auto
    moreover obtain a1 ou1 s1' a2 ou2 s2'
    where "trn1 = Trans (s aid1) a1 ou1 s1'" and "trn2 = Trans (s aid2) a2 ou2 s2'"
      using CTrans assms by (cases trn1, cases trn2) auto
    ultimately show ?thesis using CTrans assms unfolding nTriggerEq_def
      using Iss.triggerEq_obsStep[of "s aid1" a1 ou1 s1' "s1 aid1"]
      using Iss.triggerEq_obsStep[of "s aid2" a2 ou2 s2' "s1 aid2"]
      using Post_RECEIVER.triggerEq_obsStep[of "s aid1" a1 ou1 s1' "UIDs aid1" "s1 aid1"]
      using Post_RECEIVER.triggerEq_obsStep[of "s aid2" a2 ou2 s2' "UIDs aid2" "s1 aid2"]
      by (elim sync_cases) (auto simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
  qed
qed

lemma triggerEq_obsSteps:
assumes "validFrom s tr" and "nTriggerEq s s'"
shows "nTriggerEq (nTgtOfTrFrom s tr) (nObsSteps s' (O tr))"
using assms proof (induction tr arbitrary: s s')
  case (Nil s s')
  then show ?case by auto
next
  case (Cons trn tr s s')
  have tr: "local.validFrom (nTgtOf trn) tr" "nTgtOfTrFrom s (trn # tr) = nTgtOfTrFrom (nTgtOf trn) tr"
    using Cons(2) by auto
  show ?case proof cases
    assume \<gamma>: "Net.n\<gamma> trn"
    then have O: "nObsSteps s' (O (trn # tr)) = nObsSteps (nObsStep s' (Net.ng trn)) (O tr)" by auto
    have "nTriggerEq (nTgtOf trn) (nObsStep s' (Net.ng trn))" using Cons(2,3) \<gamma>
      by (intro nTriggerEq_obsStep) auto
    from Cons.IH[OF tr(1) this] show ?thesis unfolding O tr(2) .
  next
    assume n\<gamma>: "\<not> Net.n\<gamma> trn"
    then have O: "O (trn # tr) = O tr" by auto
    have "nTriggerEq (nSrcOf trn) (nTgtOf trn)" using n\<gamma> Cons(2) by (intro nTriggerEq_not_\<gamma>) auto
    with Cons(3) have "nTriggerEq (nTgtOf trn) s'" using Cons(2) by (auto intro: nTriggerEq_sym nTriggerEq_trans)
    from Cons.IH[OF tr(1) this] show ?thesis unfolding O tr(2) .
  qed
qed

lemma O_eq_nTriggerEq:
assumes O: "O tr = O tr'" and tr: "validFrom s (tr ## trn)" and tr': "validFrom s' (tr' ## trn')"
and \<gamma>: "Net.n\<gamma> trn" and \<gamma>': "Net.n\<gamma> trn'" and g: "Net.ng trn = Net.ng trn'"
and s_s': "nTriggerEq s s'"
shows "nTriggerEq (nSrcOf trn) (nSrcOf trn')" and "nTriggerEq (nTgtOf trn) (nTgtOf trn')"
proof -
  have *: "nTriggerEq (nTgtOfTrFrom s tr) (nObsSteps s' (O tr))" using tr s_s'
    by (intro triggerEq_obsSteps) auto
  have **: "nTriggerEq (nTgtOfTrFrom s' tr') (nObsSteps s' (O tr'))" using tr'
    by (intro triggerEq_obsSteps) auto
  from nTriggerEq_trans[OF *[unfolded O] **[THEN nTriggerEq_sym]]
  show src: "nTriggerEq (nSrcOf trn) (nSrcOf trn')" using tr tr'
    by (auto simp: nTgtOfTrFrom_nTgtOf_last)
  have "nTriggerEq (nTgtOf trn) (nObsStep (nSrcOf trn') (Net.ng trn))" using tr \<gamma> src
    by (intro nTriggerEq_obsStep) auto
  moreover have "nTriggerEq (nTgtOf trn') (nObsStep (nSrcOf trn') (Net.ng trn'))" using tr' \<gamma>'
    by (intro nTriggerEq_obsStep) auto
  ultimately show "nTriggerEq (nTgtOf trn) (nTgtOf trn')" unfolding g
    by (auto intro: nTriggerEq_sym nTriggerEq_trans)
qed

end

text \<open>We are now ready to combine two confidentiality properties for different posts in different
nodes.\<close>

locale Posts_Network =
  Post1: Post_Network AIDs UIDs AID1 PID1
+ Post2: Post_Network AIDs UIDs AID2 PID2
for AIDs :: "apiID set"
and UIDs :: "apiID \<Rightarrow> userID set"
and AID1 :: "apiID" and AID2 :: "apiID"
and PID1 :: "postID" and PID2 :: "postID"
+
assumes AID1_neq_AID2: "AID1 \<noteq> AID2"
begin

text \<open>The combined observations consist of the local actions of observing users and their outputs,
as usual. We do not consider communication actions here for simplicity, because this would require
us to combine the \<^emph>\<open>purgings\<close> of observations of the two properties. This is straightforward, but
tedious.\<close>

fun n\<gamma> :: "(apiID, state, (state, act, out) trans) ntrans \<Rightarrow> bool" where
  "n\<gamma> (LTrans s aid (Trans _ a _ _)) = (\<exists> uid. userOfA a = Some uid \<and> uid \<in> UIDs aid \<and> (\<not>isCOMact a))"
| "n\<gamma> (CTrans s aid1 trn1 aid2 trn2) = False"

fun g :: "(state,act,out) trans \<Rightarrow> obs" where
  "g (Trans _ (Sact sa) ou _) = (Sact (Post1.Iss.sPurge sa), ou)"
| "g (Trans _ a ou _) = (a,ou)"

fun ng :: "(apiID, state, (state, act, out) trans) ntrans \<Rightarrow> (apiID, act \<times> out) nobs" where
  "ng (LTrans s aid trn) = LObs aid (g trn)"
| "ng (CTrans s aid1 trn1 aid2 trn2) = undefined"

abbreviation "validSystemTrace \<equiv> Post1.validFrom (\<lambda>_. istate)"

text \<open>We now instantiate the generic technique for combining security properties with
independent secret sources.\<close>

sublocale BD_Security_TS_Two_Secrets "\<lambda>_. istate" Post1.nValidTrans Post1.nSrcOf Post1.nTgtOf
  Post1.Net.n\<phi> Post1.nf' Post1.Net.n\<gamma> Post1.Net.ng Post1.Net.nT "Post1.B AID1"
  Post2.Net.n\<phi> Post2.nf' Post2.Net.n\<gamma> Post2.Net.ng Post2.Net.nT "Post2.B AID2"
  n\<gamma> ng
proof
  fix tr trn
  assume "n\<gamma> trn"
  then show "Post1.Net.n\<gamma> trn \<and> Post2.Net.n\<gamma> trn"
    by (cases trn rule: n\<gamma>.cases) (auto simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
next
  fix tr tr' trn trn'
  assume tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and \<gamma>: "Post1.Net.n\<gamma> trn" and \<gamma>': "Post1.Net.n\<gamma> trn'" and g: "Post1.Net.ng trn = Post1.Net.ng trn'"
  from tr tr' have trn: "Post1.nValidTrans trn" "Post1.nValidTrans trn'" by auto
  show "n\<gamma> trn = n\<gamma> trn'" proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where trn': "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    then show ?thesis using LTrans g
      by (cases trn1 rule: Strong_ObservationSetup_ISSUER.g.cases;
          cases trn1' rule: Strong_ObservationSetup_ISSUER.g.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Post_RECEIVER.sPurge_simp)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then show ?thesis using g by (cases trn') auto
  qed
next
  fix tr tr' trn trn'
  assume O: "Post1.O tr = Post1.O tr'" and \<gamma>: "Post1.Net.n\<gamma> trn" "Post1.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post1.Net.ng trn = Post1.Net.ng trn'" and \<gamma>: "n\<gamma> trn" and \<gamma>': "n\<gamma> trn'"
  then have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" by auto
  show "ng trn = ng trn'" proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    then show ?thesis using LTrans \<gamma> \<gamma>' g trn trn'
      by (cases "(aid1,trn1)" rule: Post1.tgtNodeOf.cases;
          cases "(aid1,trn1')" rule: Post1.tgtNodeOf.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Post_RECEIVER.sPurge_simp
               simp: Post1.Iss.sStep_unfold split: sActt.splits)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    with \<gamma> show ?thesis by auto
  qed
next
  fix tr tr' trn trn'
  assume tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and \<gamma>: "Post2.Net.n\<gamma> trn" and \<gamma>': "Post2.Net.n\<gamma> trn'" and g: "Post2.Net.ng trn = Post2.Net.ng trn'"
  from tr tr' have trn: "Post1.nValidTrans trn" "Post1.nValidTrans trn'" by auto
  show "n\<gamma> trn = n\<gamma> trn'" proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where trn': "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    then show ?thesis using LTrans g
      by (cases trn1 rule: Strong_ObservationSetup_ISSUER.g.cases;
          cases trn1' rule: Strong_ObservationSetup_ISSUER.g.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Post_RECEIVER.sPurge_simp)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then show ?thesis using g by (cases trn') auto
  qed
next
  fix tr tr' trn trn'
  assume O: "Post2.O tr = Post2.O tr'" and \<gamma>: "Post2.Net.n\<gamma> trn" "Post2.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post2.Net.ng trn = Post2.Net.ng trn'" and \<gamma>: "n\<gamma> trn" and \<gamma>': "n\<gamma> trn'"
  then have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" by auto
  show "ng trn = ng trn'" proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    then show ?thesis using LTrans \<gamma> \<gamma>' g trn trn'
      by (cases "(aid1,trn1)" rule: Post1.tgtNodeOf.cases;
          cases "(aid1,trn1')" rule: Post1.tgtNodeOf.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Post_RECEIVER.sPurge_simp
               simp: Post1.Iss.sStep_unfold split: sActt.splits)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    with \<gamma> show ?thesis by auto
  qed
next
  fix tr trn
  assume "validSystemTrace (tr ## trn)" and n\<phi>: "Post2.Net.n\<phi> trn"
  then have trn: "Post1.nValidTrans trn" by auto
  show "Post1.Net.n\<gamma> trn" proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain a ou s1' where trn1: "trn1 = Trans (s aid1) a ou s1'" using trn by (cases trn1) auto
    then show ?thesis using n\<phi> trn LTrans AID1_neq_AID2
      using Post2.Iss.triggerEq_not_\<gamma>[THEN Post2.Iss.triggerEq_open]
      by (cases "Post2.Iss.\<gamma> trn1") (auto simp: Post2.\<phi>_defs Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    with trn have "Post1.sync aid1 trn1 aid2 trn2" by auto
    then show ?thesis using trn CTrans
      by (elim Post1.sync_cases) (auto simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
  qed
next
  fix tr tr' trn trn'
  assume O: "Post1.O tr = Post1.O tr'" and \<gamma>: "Post1.Net.n\<gamma> trn" "Post1.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post1.Net.ng trn = Post1.Net.ng trn'"
  have op: "\<forall>aid. Post2.Iss.open (Post1.nSrcOf trn aid) \<longleftrightarrow> Post2.Iss.open (Post1.nSrcOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post2.nTriggerEq_open Post1.O_eq_nTriggerEq) auto
  have op': "\<forall>aid. Post2.Iss.open (Post1.nTgtOf trn aid) \<longleftrightarrow> Post2.Iss.open (Post1.nTgtOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post2.nTriggerEq_open Post1.O_eq_nTriggerEq) auto
  have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" using tr tr' by auto
  show "Post2.Net.n\<phi> trn = Post2.Net.n\<phi> trn'"
  proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where s': "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    moreover then have "srcOf trn1 = s aid1" "srcOf trn1' = s' aid1"
                       "tgtOf trn1 = Post1.nTgtOf trn aid1" "tgtOf trn1' = Post1.nTgtOf trn' aid1"
      using LTrans trn trn' by auto
    ultimately show ?thesis using LTrans op op' g AID1_neq_AID2
      by (cases trn1 rule: Post.\<phi>.cases; cases trn1' rule: Post.\<phi>.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Strong_ObservationSetup_RECEIVER.comPurge.simps
                     Post.\<phi>.simps Post_RECEIVER.\<phi>.simps)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then obtain s' trn1' trn2' where CTrans': "trn' = CTrans s' aid1 trn1' aid2 trn2'"
      using g by (cases trn') auto
    have "Post1.sync aid1 trn1 aid2 trn2" "Post1.sync aid1 trn1' aid2 trn2'"
      using CTrans CTrans' trn trn' by auto
    then show ?thesis using CTrans CTrans' trn trn' op op' g
      by (elim Post1.sync_cases)
         (auto simp: Post_RECEIVER.\<phi>.simps Strong_ObservationSetup_RECEIVER.g.simps
                     Strong_ObservationSetup_RECEIVER.comPurge.simps)
  qed
next
  fix tr tr' trn trn'
  assume O: "Post1.O tr = Post1.O tr'" and \<gamma>: "Post1.Net.n\<gamma> trn" "Post1.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post1.Net.ng trn = Post1.Net.ng trn'"
     and \<phi>: "Post2.Net.n\<phi> trn" and \<phi>': "Post2.Net.n\<phi> trn'"
  have op: "\<forall>aid. Post2.Iss.open (Post1.nSrcOf trn aid) \<longleftrightarrow> Post2.Iss.open (Post1.nSrcOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post2.nTriggerEq_open Post1.O_eq_nTriggerEq) auto
  have op': "\<forall>aid. Post2.Iss.open (Post1.nTgtOf trn aid) \<longleftrightarrow> Post2.Iss.open (Post1.nTgtOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post2.nTriggerEq_open Post1.O_eq_nTriggerEq) auto
  have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" using tr tr' by auto
  show "Post2.nf' trn = Post2.nf' trn'"
  proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where s': "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    moreover then have "srcOf trn1 = s aid1" "srcOf trn1' = s' aid1"
                       "tgtOf trn1 = Post1.nTgtOf trn aid1" "tgtOf trn1' = Post1.nTgtOf trn' aid1"
      using LTrans trn trn' by auto
    ultimately show ?thesis using LTrans \<phi> \<phi>' op' g AID1_neq_AID2
      by (cases trn1 rule: Post.\<phi>.cases; cases trn1' rule: Post.f.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Strong_ObservationSetup_RECEIVER.comPurge.simps
                     Post.\<phi>.simps Post_RECEIVER.\<phi>.simps)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then obtain s' trn1' trn2' where CTrans': "trn' = CTrans s' aid1 trn1' aid2 trn2'"
      using g by (cases trn') auto
    then have trn1: "validTrans trn1" and trn1': "validTrans trn1'" using trn trn' CTrans by auto
    have states: "tgtOf trn1 = Post1.nTgtOf trn aid1" "tgtOf trn2 = Post1.nTgtOf trn aid2"
                 "tgtOf trn1' = Post1.nTgtOf trn' aid1" "tgtOf trn2' = Post1.nTgtOf trn' aid2"
      using trn trn' CTrans CTrans' by auto
    have "Post1.sync aid1 trn1 aid2 trn2" "Post1.sync aid1 trn1' aid2 trn2'"
      using CTrans CTrans' trn trn' by auto
    then show ?thesis using CTrans CTrans' op' g states AID1_neq_AID2
      by (elim Post1.sync_cases[OF _ trn1] Post1.sync_cases[OF _ trn1'])
         (auto simp: Post_RECEIVER.\<phi>.simps Strong_ObservationSetup_RECEIVER.g.simps
                     Strong_ObservationSetup_RECEIVER.comPurge.simps)
  qed
next
  fix tr trn
  assume "validSystemTrace (tr ## trn)" and n\<phi>: "Post1.Net.n\<phi> trn"
  then have trn: "Post1.nValidTrans trn" by auto
  show "Post2.Net.n\<gamma> trn" proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain a ou s1' where trn1: "trn1 = Trans (s aid1) a ou s1'" using trn by (cases trn1) auto
    then show ?thesis using n\<phi> trn LTrans AID1_neq_AID2
      using Post1.Iss.triggerEq_not_\<gamma>[THEN Post1.Iss.triggerEq_open]
      by (cases "Post1.Iss.\<gamma> trn1") (auto simp: Post1.\<phi>_defs Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    with trn have "Post1.sync aid1 trn1 aid2 trn2" by auto
    then show ?thesis
      using trn CTrans
      by (elim Post1.sync_cases) (auto simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
  qed
next
  fix tr tr' trn trn'
  assume O: "Post2.O tr = Post2.O tr'" and \<gamma>: "Post2.Net.n\<gamma> trn" "Post2.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post2.Net.ng trn = Post2.Net.ng trn'"
  have op: "\<forall>aid. Post1.Iss.open (Post1.nSrcOf trn aid) \<longleftrightarrow> Post1.Iss.open (Post1.nSrcOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post1.nTriggerEq_open Post2.O_eq_nTriggerEq) auto
  have op': "\<forall>aid. Post1.Iss.open (Post1.nTgtOf trn aid) \<longleftrightarrow> Post1.Iss.open (Post1.nTgtOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post1.nTriggerEq_open Post2.O_eq_nTriggerEq) auto
  have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" using tr tr' by auto
  show "Post1.Net.n\<phi> trn = Post1.Net.n\<phi> trn'"
  proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where s': "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    moreover then have "srcOf trn1 = s aid1" "srcOf trn1' = s' aid1"
                       "tgtOf trn1 = Post1.nTgtOf trn aid1" "tgtOf trn1' = Post1.nTgtOf trn' aid1"
      using LTrans trn trn' by auto
    ultimately show ?thesis using LTrans op op' g AID1_neq_AID2
      by (cases trn1 rule: Post.\<phi>.cases; cases trn1' rule: Post.\<phi>.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Strong_ObservationSetup_RECEIVER.comPurge.simps
                     Post.\<phi>.simps Post_RECEIVER.\<phi>.simps)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then obtain s' trn1' trn2' where CTrans': "trn' = CTrans s' aid1 trn1' aid2 trn2'"
      using g by (cases trn') auto
    have "Post1.sync aid1 trn1 aid2 trn2" "Post1.sync aid1 trn1' aid2 trn2'"
      using CTrans CTrans' trn trn' by auto
    then show ?thesis using CTrans CTrans' trn trn' op op' g
      by (elim Post1.sync_cases)
         (auto simp: Post_RECEIVER.\<phi>.simps Strong_ObservationSetup_RECEIVER.g.simps
                     Strong_ObservationSetup_RECEIVER.comPurge.simps)
  qed
next
  fix tr tr' trn trn'
  assume O: "Post2.O tr = Post2.O tr'" and \<gamma>: "Post2.Net.n\<gamma> trn" "Post2.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post2.Net.ng trn = Post2.Net.ng trn'"
     and \<phi>: "Post1.Net.n\<phi> trn" and \<phi>': "Post1.Net.n\<phi> trn'"
  have op: "\<forall>aid. Post1.Iss.open (Post1.nSrcOf trn aid) \<longleftrightarrow> Post1.Iss.open (Post1.nSrcOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post1.nTriggerEq_open Post2.O_eq_nTriggerEq) auto
  have op': "\<forall>aid. Post1.Iss.open (Post1.nTgtOf trn aid) \<longleftrightarrow> Post1.Iss.open (Post1.nTgtOf trn' aid)"
    using O \<gamma> tr tr' g by (intro Post1.nTriggerEq_open Post2.O_eq_nTriggerEq) auto
  have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" using tr tr' by auto
  show "Post1.nf' trn = Post1.nf' trn'"
  proof (cases trn)
    case (LTrans s aid1 trn1)
    then obtain s' trn1' where s': "trn' = LTrans s' aid1 trn1'" using g by (cases trn') auto
    moreover then have "srcOf trn1 = s aid1" "srcOf trn1' = s' aid1"
                       "tgtOf trn1 = Post1.nTgtOf trn aid1" "tgtOf trn1' = Post1.nTgtOf trn' aid1"
      using LTrans trn trn' by auto
    ultimately show ?thesis using LTrans \<phi> \<phi>' op' g AID1_neq_AID2
      by (cases trn1 rule: Post.\<phi>.cases; cases trn1' rule: Post.f.cases)
         (auto simp: Strong_ObservationSetup_RECEIVER.g.simps Strong_ObservationSetup_RECEIVER.comPurge.simps
                     Post.\<phi>.simps Post_RECEIVER.\<phi>.simps)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    then obtain s' trn1' trn2' where CTrans': "trn' = CTrans s' aid1 trn1' aid2 trn2'"
      using g by (cases trn') auto
    then have trn1: "validTrans trn1" and trn1': "validTrans trn1'" using trn trn' CTrans by auto
    have states: "tgtOf trn1 = Post1.nTgtOf trn aid1" "tgtOf trn2 = Post1.nTgtOf trn aid2"
                 "tgtOf trn1' = Post1.nTgtOf trn' aid1" "tgtOf trn2' = Post1.nTgtOf trn' aid2"
      using trn trn' CTrans CTrans' by auto
    have "Post1.sync aid1 trn1 aid2 trn2" "Post1.sync aid1 trn1' aid2 trn2'"
      using CTrans CTrans' trn trn' by auto
    then show ?thesis using CTrans CTrans' op' g states AID1_neq_AID2
      by (elim Post1.sync_cases[OF _ trn1] Post1.sync_cases[OF _ trn1'])
         (auto simp: Post_RECEIVER.\<phi>.simps Strong_ObservationSetup_RECEIVER.g.simps
                     Strong_ObservationSetup_RECEIVER.comPurge.simps)
  qed
next
  fix tr trn
  assume nT_trn: "Post2.Net.nT trn" and tr: "validSystemTrace (tr ## trn)"
     and nT_tr: "never Post2.Net.nT tr"
  show "Post1.Net.n\<gamma> trn" proof (cases trn)
    case (CTrans s aid1 trn1 aid2 trn2)
    then have "Post1.sync aid1 trn1 aid2 trn2" using tr by auto
    then show ?thesis using tr CTrans
      by (elim Post1.sync_cases) (auto simp: Strong_ObservationSetup_RECEIVER.\<gamma>.simps)
  next
    case (LTrans s aid1 trn1)
    then obtain a ou s1' where trn1: "trn1 = Trans (s aid1) a ou s1'" using tr by (cases trn1) auto
    interpret R: Post_RECEIVER "UIDs aid1" PID2 AID2 .
    interpret R': Post_RECEIVER "UIDs aid1" PID1 AID1 .
    from nT_trn have aid1: "aid1 \<noteq> AID2" and Ttgt: "R.T_state s1'"
      using LTrans R.T_T_state trn1 by auto
    have decomp_tr: "Post1.Iss.validFrom istate (Post1.decomp (tr ## trn) aid1)"
      using LTrans tr Post1.validFrom_lValidFrom[of "\<lambda>_. istate"] by auto
    then have s_aid1: "s aid1 = tgtOfTrFrom istate (Post1.decomp tr aid1)"
      using LTrans trn1 unfolding Post1.decomp_append
      by (auto simp: Post1.Iss.validFrom_Cons Post1.Iss.validFrom_append)
    have "\<not>R.T_state (s aid1)" unfolding s_aid1 proof (intro R.never_T_not_T_state)
      show "Post1.Iss.validFrom istate (Post1.decomp tr aid1)" using decomp_tr
        unfolding Post1.decomp_append by (auto simp: Post1.Iss.validFrom_append)
      show "never R.T (Post1.decomp tr aid1)" using aid1 Post2.Net.nTT_TT[OF nT_tr, of aid1] by auto
      show "\<not> R.T_state istate" unfolding istate_def R.T_state_def by auto
    qed
    then have s_s1': "\<not>triggerEq (s aid1) s1'" using Ttgt by (auto simp: triggerEq_def R.T_state_def)
    show ?thesis proof (cases "aid1 = AID1")
      case True
      then show ?thesis using s_s1' Post1.Iss.triggerEq_not_\<gamma> tr unfolding trn1 LTrans
        by (cases "Post1.Iss.\<gamma> (Trans (s aid1) a ou s1')") auto
    next
      case False
      then show ?thesis using s_s1' R'.triggerEq_not_\<gamma> tr unfolding trn1 LTrans
        by (cases "R'.\<gamma> (Trans (s aid1) a ou s1')") auto
    qed
  qed
next
  fix tr tr' trn trn'
  assume O: "Post1.O tr = Post1.O tr'" and \<gamma>: "Post1.Net.n\<gamma> trn" "Post1.Net.n\<gamma> trn'"
     and tr: "validSystemTrace (tr ## trn)" and tr': "validSystemTrace (tr' ## trn')"
     and g: "Post1.Net.ng trn = Post1.Net.ng trn'"
  have op': "Post1.nTriggerEq (Post1.nTgtOf trn) (Post1.nTgtOf trn')"
    using O \<gamma> tr tr' g by (intro Post1.O_eq_nTriggerEq) auto
  have trn: "Post1.nValidTrans trn" and trn': "Post1.nValidTrans trn'" using tr tr' by auto
  show "Post2.Net.nT trn = Post2.Net.nT trn'" proof (cases trn)
    case (LTrans s aid1 trn1)
    moreover then obtain s' trn1' where LTrans': "trn' = LTrans s' aid1 trn1'"
      using g by (cases trn') auto
    ultimately have t: "triggerEq (tgtOf trn1) (tgtOf trn1')" using op' unfolding Post1.nTriggerEq_def
      by auto
    interpret R: Post_RECEIVER "UIDs aid1" PID2 AID2 .
    from t have "R.T_state (tgtOf trn1) \<longleftrightarrow> R.T_state (tgtOf trn1')" by (intro R.triggerEq_T)
    then show ?thesis using LTrans LTrans' by (auto simp: R.T_T_state)
  next
    case (CTrans s aid1 trn1 aid2 trn2)
    moreover then obtain s' trn1' trn2' where CTrans': "trn' = CTrans s' aid1 trn1' aid2 trn2'"
      using g by (cases trn') auto
    moreover then have "aid1 \<noteq> aid2" using trn' by auto
    ultimately have t: "triggerEq (tgtOf trn1) (tgtOf trn1')" "triggerEq (tgtOf trn2) (tgtOf trn2')"
      using op' unfolding Post1.nTriggerEq_def by auto
    interpret R1: Post_RECEIVER "UIDs aid1" PID2 AID2 .
    interpret R2: Post_RECEIVER "UIDs aid2" PID2 AID2 .
    from t have "R1.T_state (tgtOf trn1) \<longleftrightarrow> R1.T_state (tgtOf trn1')"
                "R2.T_state (tgtOf trn2) \<longleftrightarrow> R2.T_state (tgtOf trn2')"
      by (auto intro!: R1.triggerEq_T R2.triggerEq_T)
    then show ?thesis using CTrans CTrans' by (auto simp: R1.T_T_state R2.T_T_state)
  qed
qed

theorem two_posts_secure:
  "secure"
  using Post1.secure Post2.secure
  by (rule two_secure)

end

end


chapter \<open>Generic Boolean\<close>

theory PhiSem_Generic_Boolean
  imports Phi_System.PhiSem_Formalization_Tools
begin

section \<open>Semantic\<close>

consts bool :: TY

debt_axiomatization V_bool :: \<open>bool value_entry\<close>
  where V_bool_ax: \<open>VDT_field V_bool\<close>

interpretation V_bool: VDT_field V_bool using V_bool_ax .

debt_axiomatization
      can_eq_bool: \<open>Can_EqCompare res (V_bool.mk x1) (V_bool.mk x2)\<close>
  and eq_bool:     \<open>EqCompare (V_bool.mk x1) (V_bool.mk x2) = (x1 = x2)\<close>
  and zero_bool:   \<open>Zero bool = Some (V_bool.mk False)\<close>
  and WT_bool:     \<open>Well_Type bool = { V_bool.mk x |x. True }\<close>

section \<open>Instructions\<close>

definition op_const_bool :: "bool \<Rightarrow> VAL proc"
  where "op_const_bool b = Return (\<phi>arg (V_bool.mk b))"

definition op_not :: "(VAL, VAL) proc'"
  where "op_not v =
    \<phi>M_getV bool V_bool.dest v (\<lambda>v.
    Return (\<phi>arg (V_bool.mk (\<not> v)))
  )"

definition op_and :: "(VAL \<times> VAL, VAL) proc'"
  where "op_and =
    \<phi>M_caseV (\<lambda>va vb.
    \<phi>M_getV bool V_bool.dest va (\<lambda>v.
    \<phi>M_getV bool V_bool.dest vb (\<lambda>u.
    Return (\<phi>arg (V_bool.mk (v \<and> u)))
  )))"

definition op_or :: "(VAL \<times> VAL, VAL) proc'"
  where "op_or =
    \<phi>M_caseV (\<lambda>va vb.
    \<phi>M_getV bool V_bool.dest va (\<lambda>v.
    \<phi>M_getV bool V_bool.dest vb (\<lambda>u.
    Return (\<phi>arg (V_bool.mk (v \<or> u)))
  )))"

definition op_equal :: "TY \<Rightarrow> (VAL \<times> VAL, VAL) proc'"
  where "op_equal TY =
    \<phi>M_caseV (\<lambda>va vb.
    \<phi>M_getV TY id va (\<lambda>v.
    \<phi>M_getV TY id vb (\<lambda>u.
    (\<lambda>res. \<phi>M_assert (Can_EqCompare res u v) res) \<ggreater>
    Return (\<phi>arg (V_bool.mk (EqCompare u v)))
)))"

section \<open>\<phi>-Type\<close>

definition \<phi>Bool :: "(VAL, bool) \<phi>" ("\<bool>")
  where "\<bool> x = { V_bool.mk x }"

lemma \<phi>Bool_expn[\<phi>expns]:
  " p \<in> (x \<Ztypecolon> \<bool>) \<longleftrightarrow> p = V_bool.mk x"
  unfolding \<phi>Type_def \<phi>Bool_def by simp

lemma \<phi>Bool_inhabited[\<phi>inhabitance_rule, elim!]:
  \<open>Inhabited (x \<Ztypecolon> \<bool>) \<Longrightarrow> C \<Longrightarrow> C\<close> .

lemma \<phi>Bool_eqcmp[\<phi>reason 2000]:
  "\<phi>Equal \<bool> (\<lambda>x y. True) (=)"
  unfolding \<phi>Equal_def by (simp add: \<phi>expns can_eq_bool eq_bool)

lemma \<phi>Bool_zero[\<phi>reason 2000]:
  "\<p>\<r>\<e>\<m>\<i>\<s>\<e> TY = bool \<Longrightarrow> \<phi>Zero TY \<bool> False"
  unfolding \<phi>Zero_def by (simp add: \<phi>expns zero_bool)

lemma \<phi>Bool_semty[\<phi>reason 2000]:
  \<open>\<phi>SemType (x \<Ztypecolon> \<bool>) bool\<close>
  unfolding \<phi>SemType_def subset_iff
  by (simp add: \<phi>expns WT_bool)

lemma [\<phi>reason 2000]:
  \<open>is_singleton (x \<Ztypecolon> \<bool>)\<close>
  by (rule is_singletonI''; simp add: \<phi>expns)

abbreviation \<open>Predicate_About x \<equiv> (\<bool> <func-over> x)\<close>

section \<open>Abstractions of Boolean Arithmetic\<close>

\<phi>overloads "=" and "\<not>" and "\<and>" and "\<or>"

subsection \<open>Constant\<close>

declare [[\<phi>trace_reasoning = 1]]

lemma op_const_bool[\<phi>synthesis for \<open>\<lambda>v. True \<Ztypecolon> ?T v\<close> (1200) and \<open>\<lambda>v. False \<Ztypecolon> ?T v\<close> (1200)]:
  \<open> Check_Literal b
\<Longrightarrow> \<p>\<r>\<o>\<c> op_const_bool b \<lbrace> Void \<longmapsto> \<v>\<a>\<l> b \<Ztypecolon> \<bool> \<rbrace>\<close>
  unfolding op_const_bool_def
  by (rule, simp add: \<phi>Bool_expn)

print_\<phi>reasoners \<open>\<p>\<r>\<o>\<c> ?f4 \<lbrace> XXX \<longmapsto> \<lambda>v. True \<Ztypecolon> ?X v \<r>\<e>\<m>\<a>\<i>\<n>\<s> ?S \<rbrace> \<t>\<h>\<r>\<o>\<w>\<s> ?E4  @action synthesis\<close>

subsection \<open>Not\<close>

lemma op_not[\<phi>overload \<not>, \<phi>synthesis 100]:
  \<open>\<p>\<r>\<o>\<c> op_not raw \<lbrace> x \<Ztypecolon> \<v>\<a>\<l>[raw] \<bool> \<longmapsto> \<v>\<a>\<l> \<not> x \<Ztypecolon> \<bool> \<rbrace>\<close>
  unfolding op_not_def
  by (cases raw, simp, rule, simp add: \<phi>expns WT_bool, rule, simp add: \<phi>expns)

subsection \<open>And\<close>

lemma op_and[\<phi>overload \<and>, \<phi>synthesis add]:
  \<open>\<p>\<r>\<o>\<c> op_and (\<phi>V_pair vb va) \<lbrace> a \<Ztypecolon> \<v>\<a>\<l>[va] \<bool>\<heavy_comma> b \<Ztypecolon> \<v>\<a>\<l>[vb] \<bool> \<longmapsto> \<v>\<a>\<l> (a \<and> b) \<Ztypecolon> \<bool> \<rbrace>\<close>
  unfolding op_and_def
  by (cases va; cases vb; simp, rule, rule, simp add: \<phi>expns WT_bool, rule,
      simp add: \<phi>expns WT_bool, rule, simp add: \<phi>expns, blast)

subsection \<open>Or\<close>

lemma op_or[\<phi>overload \<or>, \<phi>synthesis 100]:
  \<open>\<p>\<r>\<o>\<c> op_or (\<phi>V_pair vb va) \<lbrace> a \<Ztypecolon> \<v>\<a>\<l>[va] \<bool>\<heavy_comma> b \<Ztypecolon> \<v>\<a>\<l>[vb] \<bool> \<longmapsto> \<v>\<a>\<l> (a \<or> b) \<Ztypecolon> \<bool> \<rbrace>\<close>
  unfolding op_or_def
  by(cases va; cases vb, simp, rule, rule, simp add: \<phi>expns WT_bool, rule,
      simp add: \<phi>expns WT_bool, rule, simp add: \<phi>expns, blast)

subsection \<open>Equal\<close>

declare [[
    overloaded_operator_in_synthesis \<open>\<lambda>v. x \<Ztypecolon> T v\<close> \<open>\<lambda>v. y \<Ztypecolon> U v\<close> \<Rightarrow> \<open>\<lambda>v. x = y \<Ztypecolon> \<v>\<a>\<l>[v] \<bool>\<close>,
    overloaded_operator_in_synthesis
        \<open>\<lambda>v. x mod N \<Ztypecolon> T v\<close> \<open>\<lambda>v. y mod N \<Ztypecolon> U v\<close> \<Rightarrow> \<open>\<lambda>v. x mod N = y mod N \<Ztypecolon> \<v>\<a>\<l>[v] \<bool>\<close>
]]

lemma op_equal_\<phi>app[\<phi>overload =]:
  \<open> \<phi>Equal T can_eq eq
\<Longrightarrow> \<phi>SemType (a \<Ztypecolon> T) TY
\<Longrightarrow> \<phi>SemType (b \<Ztypecolon> T) TY
\<Longrightarrow> \<p>\<r>\<e>\<m>\<i>\<s>\<e> can_eq a b
\<Longrightarrow> \<p>\<r>\<o>\<c> op_equal TY (\<phi>V_pair rawb rawa) \<lbrace> a \<Ztypecolon> \<v>\<a>\<l>[rawa] T\<heavy_comma> b \<Ztypecolon> \<v>\<a>\<l>[rawb] T \<longmapsto> eq a b \<Ztypecolon> \<v>\<a>\<l> \<bool> \<rbrace>\<close>
  unfolding op_equal_def
  apply (cases rawa; cases rawb; simp, rule, rule)
    apply (simp add: \<phi>SemType_def subset_iff Premise_def, rule)
    apply (simp add: \<phi>SemType_def subset_iff Premise_def, rule)
   apply (unfold \<phi>Equal_def Premise_def, simp)
  by (rule \<phi>M_Success', rule, simp add: \<phi>expns)

declare op_equal_\<phi>app[where eq=\<open>(=)\<close>, \<phi>synthesis 100]
declare op_equal_\<phi>app[where eq=\<open>(\<lambda>x y. x mod N = y mod N)\<close> for N, \<phi>synthesis 100]

end


(*  Title:       OPnet.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke
*)

header "Lemmas for open partial networks"

theory OPnet
imports OAWN_SOS OInvariants
begin

text \<open>
  These lemmas mostly concern the preservation of node structure by @{term opnet_sos} transitions.
\<close>

lemma opnet_maintains_dom:
  assumes "((\<sigma>, ns), a, (\<sigma>', ns')) \<in> trans (opnet np p)"
    shows "net_ips ns = net_ips ns'"
  using assms proof (induction p arbitrary: \<sigma> ns a \<sigma>' ns')
    fix i R \<sigma> ns a \<sigma>' ns'
    assume "((\<sigma>, ns), a, (\<sigma>', ns')) \<in> trans (opnet np \<langle>i; R\<rangle>)"
    hence "((\<sigma>, ns), a, (\<sigma>', ns')) \<in> onode_sos (trans (np i))" ..
    thus "net_ips ns = net_ips ns'"
      by (simp add: net_ips_is_dom_netmap)
         (erule onode_sos.cases, simp_all)
  next
    fix p1 p2 \<sigma> ns a \<sigma>' ns'
    assume "\<And>\<sigma> ns a \<sigma>' ns'. ((\<sigma>, ns), a, (\<sigma>', ns')) \<in> trans (opnet np p1) \<Longrightarrow> net_ips ns = net_ips ns'"
       and "\<And>\<sigma> ns a \<sigma>' ns'. ((\<sigma>, ns), a, (\<sigma>', ns')) \<in> trans (opnet np p2) \<Longrightarrow> net_ips ns = net_ips ns'"
       and "((\<sigma>, ns), a, (\<sigma>', ns')) \<in> trans (opnet np (p1 \<parallel> p2))"
    thus "net_ips ns = net_ips ns'"
      by simp (erule opnet_sos.cases, simp_all)
  qed

lemma opnet_net_ips_net_tree_ips:
  assumes "(\<sigma>, ns) \<in> oreachable (opnet np p) S U"
    shows "net_ips ns = net_tree_ips p"
  using assms proof (induction rule: oreachable_pair_induct)
    fix \<sigma> s
    assume "(\<sigma>, s) \<in> init (opnet np p)"
    thus "net_ips s = net_tree_ips p"
    proof (induction p arbitrary: \<sigma> s)
      fix p1 p2 \<sigma> s
      assume IH1: "(\<And>\<sigma> s. (\<sigma>, s) \<in> init (opnet np p1) \<Longrightarrow> net_ips s = net_tree_ips p1)"
         and IH2: "(\<And>\<sigma> s. (\<sigma>, s) \<in> init (opnet np p2) \<Longrightarrow> net_ips s = net_tree_ips p2)"
         and "(\<sigma>, s) \<in> init (opnet np (p1 \<parallel> p2))"
      thus "net_ips s = net_tree_ips (p1 \<parallel> p2)"
        by (clarsimp simp add: net_ips_is_dom_netmap)
           (metis Un_commute)
    qed (clarsimp simp add: onode_comps)
  next
    fix \<sigma> s \<sigma>' s' a
    assume "(\<sigma>, s) \<in> oreachable (opnet np p) S U"
       and "net_ips s = net_tree_ips p"
       and "((\<sigma>, s), a, (\<sigma>', s')) \<in> trans (opnet np p)"
       and "S \<sigma> \<sigma>' a"
    thus "net_ips s' = net_tree_ips p"
      by (simp add: net_ips_is_dom_netmap)
         (metis net_ips_is_dom_netmap opnet_maintains_dom)
  qed simp

lemma opnet_net_ips_net_tree_ips_init:
  assumes "(\<sigma>, ns) \<in> init (opnet np p)"
    shows "net_ips ns = net_tree_ips p"
  using assms(1) by (rule oreachable_init [THEN opnet_net_ips_net_tree_ips])

lemma opartial_net_preserves_subnets:
  assumes "((\<sigma>, SubnetS s t), a, (\<sigma>', st')) \<in> opnet_sos (trans (opnet np p1)) (trans (opnet np p2))"
    shows "\<exists>s' t'. st' = SubnetS s' t'"
  using assms by cases simp_all

lemma net_par_oreachable_is_subnet:
  assumes "(\<sigma>, st) \<in> oreachable (opnet np (p1 \<parallel> p2)) S U"
    shows "\<exists>s t. st = SubnetS s t"
  proof -
    def p \<equiv> "(\<sigma>, st)"
    with assms have "p \<in> oreachable (opnet np (p1 \<parallel> p2)) S U" by simp
    hence "\<exists>\<sigma> s t. p = (\<sigma>, SubnetS s t)"
      by induct (auto dest!: opartial_net_preserves_subnets)
    with p_def show ?thesis by simp
  qed

end


section \<open>Coinductive Lists\<close>

theory Coinductive_List_Extensions
imports
  Coinductive.Coinductive_List
  Coinductive.Coinductive_List_Prefix
  Coinductive.Coinductive_Stream
  "../Extensions/List_Extensions"
  "../Extensions/ESet_Extensions"
begin

  hide_const (open) Sublist.prefix
  hide_const (open) Sublist.suffix

  declare list_of_lappend[simp]
  declare lnth_lappend1[simp]
  declare lnth_lappend2[simp]
  declare lprefix_llength_le[dest]
  declare Sup_llist_def[simp]
  declare length_list_of[simp]
  declare llast_linfinite[simp]
  declare lnth_ltake[simp]
  declare lappend_assoc[simp]
  declare lprefix_lappend[simp]

  lemma lprefix_lSup_revert: "lSup = Sup" "lprefix = less_eq" by auto
  lemma admissible_lprefixI[cont_intro]:
    assumes "mcont lub ord lSup lprefix f"
    assumes "mcont lub ord lSup lprefix g"
    shows "ccpo.admissible lub ord (\<lambda> x. lprefix (f x) (g x))"
    using ccpo_class.admissible_leI assms unfolding lprefix_lSup_revert by this
  lemma llist_lift_admissible:
    assumes "ccpo.admissible lSup lprefix P"
    assumes "\<And> u. u \<le> v \<Longrightarrow> lfinite u \<Longrightarrow> P u"
    shows "P v"
    using assms by (metis LNil_lprefix le_llist_conv_lprefix lfinite.simps llist_gen_induct)

  abbreviation "linfinite w \<equiv> \<not> lfinite w"

  notation LNil ("<>")
  notation LCons (infixr "%" 65)
  notation lzip (infixr "\<bar>\<bar>" 51)
  notation lappend (infixr "$" 65)
  notation lnth (infixl "?!" 100)

  syntax "_llist" :: "args \<Rightarrow> 'a llist" ("<_>")
  translations
    "<a, x>" \<rightleftharpoons> "a % <x>"
    "<a>" \<rightleftharpoons> "a % <>"

  lemma eq_LNil_conv_lnull[simp]: "w = <> \<longleftrightarrow> lnull w" by auto
  lemma Collect_lnull[simp]: "{w. lnull w} = {<>}" by auto

  lemma inj_on_ltake: "inj_on (\<lambda> k. ltake k w) {.. llength w}"
    by (rule inj_onI, auto, metis llength_ltake min_def)

  lemma lnth_inf_llist'[simp]: "lnth (inf_llist f) = f" by auto

  lemma not_lnull_lappend_startE[elim]:
    assumes "\<not> lnull w"
    obtains a v
    where "w = <a> $ v"
    using not_lnull_conv assms by (simp, metis)
  lemma not_lnull_lappend_endE[elim]:
    assumes "\<not> lnull w"
    obtains a v
    where "w = v $ <a>"
  proof (cases "lfinite w")
    case False
    show ?thesis
    proof
      show "w = w $ <a>" using lappend_inf False by force
    qed
  next
    case True
    show ?thesis
    using True assms that
    proof (induct arbitrary: thesis)
      case (lfinite_LNil)
      show ?case using lfinite_LNil by auto
    next
      case (lfinite_LConsI w a)
      show ?case
      proof (cases "lnull w")
        case False
        obtain b v where 1: "w = v $ <b>" using lfinite_LConsI(2) False by this
        show ?thesis
        proof (rule lfinite_LConsI(4))
          show "a % w = (a % v) $ <b>" unfolding 1 by simp
        qed
      next
        case True
        show ?thesis
        proof (rule lfinite_LConsI(4))
          show "a % w = <> $ <a>" using True by simp
        qed
      qed
    qed
  qed

  lemma llength_lappend_startE[elim]:
    assumes "llength w \<ge> eSuc n"
    obtains a v
    where "w = <a> $ v" "llength v \<ge> n"
  proof -
    have 1: "\<not> lnull w" using assms by auto
    show ?thesis using assms 1 that by auto
  qed
  lemma llength_lappend_endE[elim]:
    assumes "llength w \<ge> eSuc n"
    obtains a v
    where "w = v $ <a>" "llength v \<ge> n"
  proof -
    have 1: "\<not> lnull w" using assms by auto
    show ?thesis using assms 1 that by auto
  qed

  lemma llength_lappend_start'E[elim]:
    assumes "llength w = enat (Suc n)"
    obtains a v
    where "w = <a> $ v" "llength v = enat n"
  proof -
    have 1: "llength w \<ge> eSuc (enat n)" using assms by simp
    obtain a v where 2: "w = <a> $ v" using 1 by blast
    show ?thesis
    proof
      show "w = <a> $ v" using 2(1) by this
      show "llength v = enat n" using assms unfolding 2(1) by (simp, metis eSuc_enat eSuc_inject)
    qed
  qed
  lemma llength_lappend_end'E[elim]:
    assumes "llength w = enat (Suc n)"
    obtains a v
    where "w = v $ <a>" "llength v = enat n"
  proof -
    have 1: "llength w \<ge> eSuc (enat n)" using assms by simp
    obtain a v where 2: "w = v $ <a>" using 1 by blast
    show ?thesis
    proof
      show "w = v $ <a>" using 2(1) by this
      show "llength v = enat n" using assms unfolding 2(1) by (simp, metis eSuc_enat eSuc_inject)
    qed
  qed

  lemma ltake_llast[simp]:
    assumes "enat k < llength w"
    shows "llast (ltake (enat (Suc k)) w) = w ?! k"
  proof -
    have 1: "llength (ltake (enat (Suc k)) w) = eSuc (enat k)"using min.absorb_iff1 assms by auto
    have "llast (ltake (enat (Suc k)) w) = ltake (enat (Suc k)) w ?! k"
      using llast_conv_lnth 1 by this
    also have "\<dots> = w ?! k" by (rule lnth_ltake, simp)
    finally show ?thesis by this
  qed

  lemma linfinite_llength[dest, simp]:
    assumes "linfinite w"
    shows "enat k < llength w"
    using assms not_lfinite_llength by force

  lemma llist_nth_eqI[intro]:
    assumes "llength u = llength v"
    assumes "\<And> i. enat i < llength u \<Longrightarrow> enat i < llength v \<Longrightarrow> u ?! i = v ?! i"
    shows "u = v"
  using assms
  proof (coinduction arbitrary: u v)
    case Eq_llist
    have 10: "llength u = llength v" using Eq_llist by auto
    have 11: "\<And> i. enat i < llength u \<Longrightarrow>  enat i < llength v \<Longrightarrow> u ?! i = v ?! i"
      using Eq_llist by auto
    show ?case
    proof (intro conjI impI exI allI)
      show "lnull u \<longleftrightarrow> lnull v" using 10 by auto
    next
      assume 20: "\<not> lnull u" "\<not> lnull v"
      show "lhd u = lhd v" using lhd_conv_lnth enat_0 11 20 by force
    next
      show "ltl u = ltl u" by rule
    next
      show "ltl v = ltl v" by rule
    next
      assume 30: "\<not> lnull u" "\<not> lnull v"
      show "llength (ltl u) = llength (ltl v)" using 10 30 by force
    next
      fix i
      assume 40: "\<not> lnull u" "\<not> lnull v" "enat i < llength (ltl u)" "enat i < llength (ltl v)"
      have 41: "u ?! Suc i = v ?! Suc i"
      proof (rule 11)
        show "enat (Suc i) < llength u" using Suc_ile_eq 40(1) 40(3) by auto
        show "enat (Suc i) < llength v" using Suc_ile_eq 40(2) 40(4) by auto
      qed
      show "ltl u ?! i = ltl v ?! i" using lnth_ltl 40(1-2) 41 by metis
    qed
  qed

  primcorec lscan :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a llist \<Rightarrow> 'b \<Rightarrow> 'b llist"
    where "lscan f w a = (case w of <> \<Rightarrow> <a> | x % xs \<Rightarrow> a % lscan f xs (f x a))"

  lemma lscan_simps[simp]:
    "lscan f <> a = <a>"
    "lscan f (x % xs) a = a % lscan f xs (f x a)"
    by (metis llist.simps(4) lscan.code, metis llist.simps(5) lscan.code)

  lemma lscan_lfinite[iff]: "lfinite (lscan f w a) \<longleftrightarrow> lfinite w"
  proof
    assume "lfinite (lscan f w a)"
    thus "lfinite w"
    proof (induct "lscan f w a" arbitrary: w a rule: lfinite_induct)
      case LNil
      show ?case using LNil by simp
    next
      case LCons
      show ?case by (cases w, simp, simp add: LCons(3))
    qed
  next
    assume "lfinite w"
    thus "lfinite (lscan f w a)" by (induct arbitrary: a, auto)
  qed
  lemma lscan_llength[simp]: "llength (lscan f w a) = eSuc (llength w)"
  proof (cases "lfinite w")
    case False
    have 1: "llength (lscan f w a) = \<infinity>" using not_lfinite_llength False by auto
    have 2: "llength w = \<infinity>" using not_lfinite_llength False by auto
    show ?thesis using 1 2 by simp
  next
    case True
    show ?thesis using True by (induct arbitrary: a, auto)
  qed

  function lfold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a llist \<Rightarrow> 'b \<Rightarrow> 'b"
    where "lfinite w \<Longrightarrow> lfold f w = fold f (list_of w)" | "linfinite w \<Longrightarrow> lfold f w = id"
    by (auto, metis) termination by lexicographic_order

  lemma lfold_llist_of[simp]: "lfold f (llist_of xs) = fold f xs" by simp

  lemma finite_UNIV_llength_eq:
    assumes "finite (UNIV :: 'a set)"
    shows "finite {w :: 'a llist. llength w = enat n}"
  proof (induct n)
    case (0)
    show ?case by simp
  next
    case (Suc n)
    have 1: "finite ({v. llength v = enat n} \<times> UNIV :: ('a llist \<times> 'a) set)"
      using Suc assms by simp
    have 2: "finite ((\<lambda> (v, a). v $ <a> :: 'a llist ) ` ({v. llength v = enat n} \<times> UNIV))"
      using 1 by auto
    have 3: "finite {v $ <a> :: 'a llist |v a. llength v = enat n}"
    proof -
      have 0: "{v $ <a> :: 'a llist  |v a. llength v = enat n} =
        (\<lambda> (v, a). v $ <a> :: 'a llist ) ` ({v. llength v = enat n} \<times> UNIV)" by auto
      show ?thesis using 2 unfolding 0 by this
    qed
    have 4: "finite {w :: 'a llist . llength w = enat (Suc n)}"
    proof -
      have 0: "{w :: 'a llist . llength w = enat (Suc n)} =
        {v $ <a> :: 'a llist  |v a. llength v = enat n}" by force
      show ?thesis using 3 unfolding 0 by this
    qed
    show ?case using 4 by this
  qed
  lemma finite_UNIV_llength_le:
    assumes "finite (UNIV :: 'a set)"
    shows "finite {w :: 'a llist. llength w \<le> enat n}"
  proof -
    have 1: "{w. llength w \<le> enat n} = (\<Union> k \<le> n. {w. llength w = enat k})"
      by (auto, metis atMost_iff enat_ile enat_ord_simps(1))
    show ?thesis unfolding 1 using finite_UNIV_llength_eq assms by auto
  qed

  lemma lprefix_ltake[dest]: "u \<le> v \<Longrightarrow> u = ltake (llength u) v"
    by (metis le_llist_conv_lprefix lprefix_conv_lappend ltake_all ltake_lappend1 order_refl)
  lemma prefixes_set: "{v. v \<le> w} = {ltake k w |k. k \<le> llength w}" by fastforce
  lemma esize_prefixes[simp]: "esize {v. v \<le> w} = eSuc (llength w)"
  proof -
    have "esize {v. v \<le> w} = esize {ltake k w |k. k \<le> llength w}" unfolding prefixes_set by rule
    also have "\<dots> = esize ((\<lambda> k. ltake k w) ` {.. llength w})"
      unfolding atMost_def image_Collect by rule
    also have "\<dots> = esize {.. llength w}" using inj_on_ltake esize_image by blast
    also have "\<dots> = eSuc (llength w)" by simp
    finally show ?thesis by this
  qed
  lemma prefix_subsume: "v \<le> w \<Longrightarrow> u \<le> w \<Longrightarrow> llength v \<le> llength u \<Longrightarrow> v \<le> u"
    by (metis le_llist_conv_lprefix lprefix_conv_lappend
      lprefix_ltake ltake_is_lprefix ltake_lappend1)

  lemma ltake_infinite[simp]: "ltake \<infinity> w = w" by (metis enat_ord_code(3) ltake_all)

  lemma lprefix_infinite:
    assumes "u \<le> v" "linfinite u"
    shows "u = v"
  proof -
    have 1: "llength u = \<infinity>" using not_lfinite_llength assms(2) by this
    have "u = ltake (llength u) v" using lprefix_ltake assms(1) by this
    also have "\<dots> = v" using 1 by simp
    finally show ?thesis by this
  qed

  instantiation llist :: (type) esize_order
  begin

    definition [simp]: "esize \<equiv> llength"

    instance
    proof
      fix w :: "'a llist"
      assume 1: "esize w \<noteq> \<infinity>"
      show "finite {v. v \<le> w}"
        using esize_prefixes 1 by (metis eSuc_eq_infinity_iff esize_set.simps(2) esize_llist_def)
    next
      fix u v :: "'a llist"
      assume 1: "u \<le> v"
      show "esize u \<le> esize v" using lprefix_llength_le 1 by auto
    next
      fix u v :: "'a llist"
      assume 1: "u < v"
      show "esize u < esize v" using lstrict_prefix_llength_less 1 by auto
    qed

  end

  subsection \<open>Index Sets\<close>

    definition liset :: "'a set \<Rightarrow> 'a llist \<Rightarrow> nat set"
      where "liset A w \<equiv> {i. enat i < llength w \<and> w ?! i \<in> A}"

    lemma lisetI[intro]:
      assumes "enat i < llength w" "w ?! i \<in> A"
      shows "i \<in> liset A w"
      using assms unfolding liset_def by auto
    lemma lisetD[dest]:
      assumes "i \<in> liset A w"
      shows "enat i < llength w" "w ?! i \<in> A"
      using assms unfolding liset_def by auto

    lemma liset_finite:
      assumes "lfinite w"
      shows "finite (liset A w)"
    proof
      show "liset A w \<subseteq> {i. enat i < llength w}" by auto
      show "finite {i. enat i < llength w}" using lfinite_finite_index assms by this
    qed

    lemma liset_nil[simp]: "liset A <> = {}" by auto
    lemma liset_cons_not_member[simp]:
      assumes "a \<notin> A"
      shows "liset A (a % w) = Suc ` liset A w"
    proof -
      have "liset A (a % w) = {i. enat i < llength (a % w) \<and> (a % w) ?! i \<in> A}" by auto
      also have "\<dots> = Suc ` {i. enat (Suc i) < llength (a % w) \<and> (a % w) ?! Suc i \<in> A}"
        using Collect_split_Suc(1) assms by simp
      also have "\<dots> = Suc ` {i. enat i < llength w \<and> w ?! i \<in> A}" using Suc_ile_eq by simp
      also have "\<dots> = Suc ` liset A w" by auto
      finally show ?thesis by this
    qed
    lemma liset_cons_member[simp]:
      assumes "a \<in> A"
      shows "liset A (a % w) = {0} \<union> Suc ` liset A w"
    proof -
      have "liset A (a % w) = {i. enat i < llength (a % w) \<and> (a % w) ?! i \<in> A}" by auto
      also have "\<dots> = {0} \<union> Suc ` {i. enat (Suc i) < llength (a % w) \<and> (a % w) ?! Suc i \<in> A}"
        using Collect_split_Suc(2) assms by simp
      also have "\<dots> = {0} \<union> Suc ` {i. enat i < llength w \<and> w ?! i \<in> A}" using Suc_ile_eq by simp
      also have "\<dots> = {0} \<union> Suc ` liset A w" by auto
      finally show ?thesis by this
    qed

    lemma liset_prefix:
      assumes "i \<in> liset A v" "u \<le> v" "enat i < llength u"
      shows "i \<in> liset A u"
    unfolding liset_def
    proof (intro CollectI conjI)
      have 1: "v ?! i \<in> A" using assms(1) by auto
      show "enat i < llength u" using assms(3) by this
      show "u ?! i \<in> A" using lprefix_lnthD assms(2, 3) 1 by force
    qed
    lemma liset_suffix:
      assumes "i \<in> liset A u" "u \<le> v"
      shows "i \<in> liset A v"
    unfolding liset_def
    proof (intro CollectI conjI)
      have 1: "enat i < llength u" "u ?! i \<in> A" using assms(1) by auto
      show "enat i < llength v" using lprefix_llength_le 1(1) assms(2) by fastforce
      show "v ?! i \<in> A" using lprefix_lnthD assms(2) 1 by force
    qed

    lemma liset_ltake[simp]: "liset A (ltake (enat k) w) = liset A w \<inter> {..< k}"
    proof (intro equalityI subsetI)
      fix i
      assume 1: "i \<in> liset A (ltake (enat k) w)"
      have 2: "enat i < enat k" using 1 by auto
      have 3: "ltake (enat k) w ?! i = w ?! i" using lnth_ltake 2 by this
      show "i \<in> liset A w \<inter> {..< k}" using 1 3 by fastforce
    next
      fix i
      assume 1: "i \<in> liset A w \<inter> {..< k}"
      have 2: "enat i < enat k" using 1 by auto
      have 3: "ltake (enat k) w ?! i = w ?! i" using lnth_ltake 2 by this
      show "i \<in> liset A (ltake (enat k) w)" using 1 3 by fastforce
    qed

    lemma liset_mono[dest]: "u \<le> v \<Longrightarrow> liset A u \<subseteq> liset A v"
      unfolding liset_def using lprefix_lnthD by fastforce
    lemma liset_cont[dest]:
      assumes "Complete_Partial_Order.chain less_eq C" "C \<noteq> {}"
      shows "liset A (\<Squnion> C) = (\<Union> w \<in> C. liset A w)"
    proof safe
      fix i
      assume 1: "i \<in> liset A (\<Squnion> C)"
      show "i \<in> (\<Union> w \<in> C. liset A w)"
      proof (cases "finite C")
        case False
        obtain w where 2: "w \<in> C" "enat i < llength w"
          using esize_llist_def infinite_chain_arbitrary_esize assms(1) False Suc_ile_eq by metis
        have 3: "w \<le> \<Squnion> C" using chain_lprefix_lSup assms(1) 2(1) by simp
        have 4: "i \<in> liset A w" using liset_prefix 1 3 2(2) by this
        show ?thesis using 2(1) 4 by auto
      next
        case True
        have 2: "\<Squnion> C \<in> C" using in_chain_finite assms(1) True assms(2) by this
        show ?thesis using 1 2 by auto
      qed
    next
      fix w i
      assume 1: "w \<in> C" "i \<in> liset A w"
      have 2: "w \<le> \<Squnion> C" using chain_lprefix_lSup assms(1) 1(1) by simp
      show "i \<in> liset A (\<Squnion> C)" using liset_suffix 1(2) 2 by this
    qed

    lemma liset_mcont: "Complete_Partial_Order2.mcont lSup lprefix Sup less_eq (liset A)"
      unfolding lprefix_lSup_revert by (blast intro: mcontI monotoneI contI)

    lemmas mcont2mcont_liset = liset_mcont[THEN lfp.mcont2mcont, simp, cont_intro]

  subsection \<open>Selections\<close>

    (* TODO: thm lfitler_K_False *)

    abbreviation "lproject A \<equiv> lfilter (\<lambda> a. a \<in> A)"
    abbreviation "lselect s w \<equiv> lnths w s"

    lemma lselect_to_lproject: "lselect s w = lmap fst (lproject (UNIV \<times> s) (w \<bar>\<bar> iterates Suc 0))"
    proof -
      have 1: "{(x, y). y \<in> s} = UNIV \<times> s" by auto
      have "lselect s w = lmap fst (lproject {(x, y). y \<in> s} (w \<bar>\<bar> iterates Suc 0))"
        unfolding lnths_def by simp
      also have "\<dots> = lmap fst (lproject (UNIV \<times> s) (w \<bar>\<bar> iterates Suc 0))" unfolding 1 by rule
      finally show ?thesis by this
    qed
    lemma lproject_to_lselect: "lproject A w = lselect (liset A w) w"
      unfolding lfilter_conv_lnths liset_def by rule

    lemma lproject_llength[simp]: "llength (lproject A w) = esize (liset A w)"
      by (induct rule: llist_induct) (auto)
    lemma lproject_lfinite[simp]: "lfinite (lproject A w) \<longleftrightarrow> finite (liset A w)"
      using lproject_llength esize_iff_infinite llength_eq_infty_conv_lfinite by metis

    lemma lselect_restrict_indices[simp]: "lselect {i \<in> s. enat i < llength w} w = lselect s w"
    proof (rule lnths_cong)
      show "w = w" by rule
    next
      fix n
      assume 1: "enat n < llength w"
      show "n \<in> {i \<in> s. enat i < llength w} \<longleftrightarrow> n \<in> s" using 1 by blast
    qed

    lemma lselect_llength: "llength (lselect s w) = esize {i \<in> s. enat i < llength w}"
    proof -
      have 1: "\<And> i. enat i < llength w \<Longrightarrow> (w \<bar>\<bar> iterates Suc 0) ?! i = (w ?! i, i)"
        by (metis Suc_funpow enat.distinct(1) enat_ord_simps(4) llength_iterates lnth_iterates
          lnth_lzip monoid_add_class.add.right_neutral)
      have 2: "{i. enat i < llength w \<and> (w \<bar>\<bar> iterates Suc 0) ?! i \<in> UNIV \<times> s} =
        {i \<in> s. enat i < llength w}" using 1 by auto
      have "llength (lselect s w) = esize (liset (UNIV \<times> s) (w \<bar>\<bar> iterates Suc 0))"
        unfolding lselect_to_lproject by simp
      also have "\<dots> = esize {i. enat i < llength w \<and> (w \<bar>\<bar> iterates Suc 0) ?! i \<in> UNIV \<times> s}"
        unfolding liset_def by simp
      also have "\<dots> = esize {i \<in> s. enat i < llength w}" unfolding 2 by rule
      finally show ?thesis by this
    qed

    lemma lselect_discard_start:
      assumes "\<And> i. i \<in> s \<Longrightarrow> k \<le> i"
      shows "lselect {i. k + i \<in> s} (ldropn k w) = lselect s w"
    proof -
      have 1: "lselect s (ltake (enat k) w) = <>"
        using assms by (fastforce simp add: lselect_lnull min_le_iff_disj)
      have "lselect {m. k + m \<in> s} (ldropn k w) =
        lselect s (ltake (enat k) w) $ lselect {m. k + m \<in> s} (ldropn k w)" unfolding 1 by simp
      also have "\<dots> = lselect s w" using lnths_split by rule
      finally show ?thesis by this
    qed
    lemma lselect_discard_end:
      assumes "\<And> i. i \<in> s \<Longrightarrow> i < k"
      shows "lselect s (ltake (enat k) w) = lselect s w"
    proof -
      have 1: "lselect {m. k + m \<in> s} (ldropn k w) = <>"
        using assms by (fastforce simp add: lselect_lnull min_le_iff_disj)
      have "lselect s (ltake (enat k) w) =
        lselect s (ltake (enat k) w) $ lselect {m. k + m \<in> s} (ldropn k w)" unfolding 1 by simp
      also have "\<dots> = lselect s w" using lnths_split by rule
      finally show ?thesis by this
    qed

    lemma lselect_least:
      assumes "\<not> lnull (lselect s w)"
      shows "lselect s w = w ?! least s % lselect (s - {least s}) w"
    proof -
      have 0: "s \<noteq> {}" using assms by auto
      have 1: "least s \<in> s" using LeastI 0 by fast
      have 2: "\<And> i. i \<in> s \<Longrightarrow> least s \<le> i" using Least_le 0 by fast
      have 3: "\<And> i. i \<in> s - {least s} \<Longrightarrow> Suc (least s) \<le> i" using least_unique 2 by force
      have 4: "insert (least s) (s - {least s}) = s" using 1 by auto
      have 5: "enat (least s) < llength w" using least_lselect_llength assms by this
      have 6: "lselect (s - {least s}) (ltake (enat (least s)) w) = <>"
        by (rule, auto simp: lselect_llength dest: least_not_less)
      have 7: "lselect {i. Suc (least s) + i \<in> s - {least s}} (ldropn (Suc (least s)) w) =
        lselect (s - {least s}) w" using lselect_discard_start 3 by this
      have "lselect s w = lselect (insert (least s) (s - {least s})) w" unfolding 4 by simp
      also have "\<dots> = lselect (s - {least s}) (ltake (enat (least s)) w) $ <w ?! least s> $
        lselect {m. Suc (least s) + m \<in> s - {least s}} (ldropn (Suc (least s)) w)"
        unfolding lnths_insert[OF 5] by simp
      also have "\<dots> = <w ?! least s> $
        lselect {m. Suc (least s) + m \<in> s - {least s}} (ldropn (Suc (least s)) w)"
        unfolding 6 by simp
      also have "\<dots> = w ?! (least s) % lselect (s - {least s}) w" unfolding 7 by simp
      finally show ?thesis by this
    qed

    lemma lselect_lnth[simp]:
      assumes "enat i < llength (lselect s w)"
      shows "lselect s w ?! i = w ?! nth_least s i"
    using assms
    proof (induct i arbitrary: s)
      case 0
      have 1: "\<not> lnull (lselect s w)" using 0 by auto
      show ?case using lselect_least 1 by force
    next
      case (Suc i)
      have 1: "\<not> lnull (lselect s w)" using Suc(2) by auto
      have 2: "lselect s w = w ?! least s % lselect (s - {least s}) w" using lselect_least 1 by this
      have 3: "llength (lselect s w) = eSuc (llength (lselect (s - {least s}) w))" using 2 by simp
      have 4: "enat i < llength (lselect (s - {least s}) w)" using 3 Suc(2) by simp
      have "lselect s w ?! Suc i = (w ?! least s % lselect (s - {least s}) w) ?! Suc i" using 2 by simp
      also have "\<dots> = lselect (s - {least s}) w ?! i" by simp
      also have "\<dots> = w ?! nth_least (s - {least s}) i" using Suc(1) 4 by simp
      also have "\<dots> = w ?! nth_least s (Suc i)" by simp
      finally show ?case by this
    qed
    lemma lproject_lnth[simp]:
      assumes "enat i < llength (lproject A w)"
      shows "lproject A w ?! i = w ?! nth_least (liset A w) i"
      using assms unfolding lproject_to_lselect by simp

    lemma lproject_ltake[simp]:
      assumes "enat k \<le> llength (lproject A w)"
      shows "lproject A (ltake (enat (nth_least (lift (liset A w)) k)) w) =
        ltake (enat k) (lproject A w)"
    proof
      have "llength (lproject A (ltake (enat (nth_least (lift (liset A w)) k)) w)) =
        enat (card (liset A w \<inter> {..< nth_least (lift (liset A w)) k}))" by simp
      also have "\<dots> = enat (card {i \<in> liset A w. i < nth_least (lift (liset A w)) k})"
        unfolding lessThan_def Collect_conj_eq by simp
      also have "\<dots> = enat k" using assms by simp
      also have "\<dots> = llength (ltake (enat k) (lproject A w))" using min_absorb1 assms by force
      finally show "llength (lproject A (ltake (enat (nth_least (lift (liset A w)) k)) w)) =
        llength (ltake (enat k) (lproject A w))" by this
    next
      fix i
      assume 1: "enat i < llength (lproject A (ltake (enat (nth_least (lift (liset A w)) k)) w))"
      assume 2: "enat i < llength (ltake (enat k) (lproject A w))"
      obtain k' where 3: "k = Suc k'" using 2 nat.exhaust by auto
      have 4: "enat k' < llength (lproject A w)" using assms 3 by simp
      have 5: "i \<le> k'" using 2 3 by simp
      have 6: "nth_least (lift (liset A w)) k = Suc (nth_least (liset A w) k')"
        using 3 4 by (simp del: nth_least.simps)
      have 7: "nth_least (liset A w) i < Suc (nth_least (liset A w) k')"
      proof -
        have "nth_least (liset A w) i \<le> nth_least (liset A w) k'" using 4 5 by simp
        also have "\<dots> < Suc (nth_least (liset A w) k')" by simp
        finally show ?thesis by this
      qed
      have 8: "nth_least (liset A w \<inter> {..< Suc (nth_least (liset A w) k')}) i =
        nth_least (liset A w) i"
      proof (rule nth_least_eq)
        show "enat i < esize (liset A w \<inter> {..< Suc (nth_least (liset A w) k')})" using 1 6 by simp
        have "enat i \<le> enat k'" using 5 by simp
        also have "enat k' < esize (liset A w)" using 4 by simp
        finally show "enat i < esize (liset A w)" by this
      next
        fix j
        assume 1: "j \<le> nth_least (liset A w) i"
        show "j \<in> liset A w \<inter> {..< Suc (nth_least (liset A w) k')} \<longleftrightarrow> j \<in> liset A w"
          using 1 7 by simp
      qed
      have "lproject A (ltake (enat (nth_least (lift (liset A w)) k)) w) ?! i =
        ltake (enat (Suc (nth_least (liset A w) k'))) w ?!
        nth_least (liset A w \<inter> {..< Suc (nth_least (liset A w) k')}) i"
        using 1 6 by simp
      also have "\<dots> = ltake (enat (Suc (nth_least (liset A w) k'))) w ?! nth_least (liset A w) i"
        using 8 by simp
      also have "\<dots> = w ?! nth_least (liset A w) i" using 7 by simp
      also have "\<dots> = lproject A w ?! i" using 2 by simp
      also have "\<dots> = ltake (enat k) (lproject A w) ?! i" using 2 by simp
      finally show "lproject A (ltake (enat (nth_least (lift (liset A w)) k)) w) ?! i =
        ltake (enat k) (lproject A w) ?! i" by this
    qed

    lemma llength_less_llength_lselect_less:
      "enat i < esize s \<and> enat (nth_least s i) < llength w \<longleftrightarrow> enat i < llength (lselect s w)"
      using nth_least_less_esize_less unfolding lselect_llength by this

    lemma lselect_lselect'':
      assumes "\<And> i. i \<in> s \<Longrightarrow> enat i < llength w"
      assumes "\<And> i. i \<in> t \<Longrightarrow> enat i < llength (lselect s w)"
      shows "lselect t (lselect s w) = lselect (nth_least s ` t) w"
    proof
      note lselect_llength[simp]
      have 1: "\<And> i. i \<in> nth_least s ` t \<Longrightarrow> enat i < llength w" using assms by auto
      have 2: "t \<subseteq> {i. enat i < esize s}"
        using assms(2) lselect_llength_le less_le_trans by blast
      have 3: "inj_on (nth_least s) t" using subset_inj_on nth_least.inj_on 2 by this
      have "llength (lselect t (lselect s w)) = esize t" using assms(2) by simp
      also have "\<dots> = esize (nth_least s ` t)" using 3 by auto
      also have "\<dots> = llength (lselect (nth_least s ` t) w)" using 1 by simp
      finally show "llength (lselect t (lselect s w)) = llength (lselect (nth_least s ` t) w)"
        by this
    next
      fix i
      assume 1: "enat i < llength (lselect t (lselect s w))"
      assume 2: "enat i < llength (lselect (nth_least s ` t) w)"
      have 3: "enat i < esize t" using less_le_trans 1 lselect_llength_le by this
      have 4: "\<And> i. i \<in> t \<Longrightarrow> enat i < esize s"
        using assms(2) lselect_llength_le less_le_trans by blast
      have "lselect t (lselect s w) ?! i = lselect s w ?! nth_least t i" using 1 by simp
      also have "\<dots> = w ?! nth_least s (nth_least t i)" using assms(2) 3 by simp
      also have "\<dots> = w ?! nth_least (nth_least s ` t) i" using 3 4 by simp
      also have "\<dots> = lselect (nth_least s ` t) w ?! i" using 2 by simp
      finally show "lselect t (lselect s w) ?! i = lselect (nth_least s ` t) w ?! i" by this
    qed

    lemma lselect_lselect'[simp]:
      assumes "\<And> i. i \<in> t \<Longrightarrow> enat i < esize s"
      shows "lselect t (lselect s w) = lselect (nth_least s ` t) w"
    proof -
      have 1: "nth_least {i \<in> s. enat i < llength w} ` {i \<in> t. enat i < llength (lselect s w)} =
        {i \<in> nth_least s ` t. enat i < llength w}"
      unfolding Compr_image_eq
      proof (rule image_cong)
        show "{i \<in> t. enat i < llength (lselect s w)} = {i \<in> t. enat (nth_least s i) < llength w}"
          using llength_less_llength_lselect_less assms by blast
      next
        fix i
        assume 1: "i \<in> {i \<in> t. enat (nth_least s i) < llength w}"
        have 2: "enat i < esize {i \<in> s. enat i < llength w}"
          using nth_least_less_esize_less assms 1 by blast
        show "nth_least {i \<in> s. enat i < llength w} i = nth_least s i" using 2 by simp
      qed
      have "lselect t (lselect s w) =
        lselect {i \<in> t. enat i < llength (lselect s w)} (lselect {i \<in> s. enat i < llength w} w)"
        by simp
      also have "\<dots> = lselect (nth_least {i \<in> s. enat i < llength w} `
        {i \<in> t. enat i < llength (lselect s w)}) w"
        by (rule lselect_lselect'', auto simp: lselect_llength)
      also have "\<dots> = lselect {i \<in> nth_least s ` t. enat i < llength w} w" unfolding 1 by rule
      also have "\<dots> = lselect (nth_least s ` t) w" by simp
      finally show ?thesis by this
    qed

    lemma lselect_lselect:
      "lselect t (lselect s w) = lselect (nth_least s ` {i \<in> t. enat i < esize s}) w"
    proof -
      have "lselect t (lselect s w) = lselect {i \<in> t. enat i < llength (lselect s w)} (lselect s w)"
        by simp
      also have "\<dots> = lselect (nth_least s ` {i \<in> t. enat i < llength (lselect s w)}) w"
        using lselect_llength_le less_le_trans by (blast intro: lselect_lselect')
      also have "\<dots> = lselect (nth_least s ` {i \<in> t. enat i < esize s}) w"
        using llength_less_llength_lselect_less by (auto intro!: lnths_cong)
      finally show ?thesis by this
    qed

    lemma lselect_lproject':
      assumes "\<And> i. i \<in> s \<Longrightarrow> enat i < llength w"
      shows "lproject A (lselect s w) = lselect (s \<inter> liset A w) w"
    proof -
      have 1: "\<And> i. i \<in> liset A (lselect s w) \<Longrightarrow> enat i < esize s" using less_le_trans by force
      have 2: "{i \<in> liset A (lselect s w). enat i < esize s} = liset A (lselect s w)"
        using 1 by auto
      have 3: "nth_least s ` liset A (lselect s w) = s \<inter> liset A w"
      proof safe
        fix k
        assume 4: "k \<in> liset A (lselect s w)"
        show "nth_least s k \<in> s" using 1 4 by simp
        show "nth_least s k \<in> liset A w"
          using llength_less_llength_lselect_less 4 unfolding liset_def by auto
      next
        fix k
        assume 1: "k \<in> s" "k \<in> liset A w"
        have 2: "nth_least s (card {i \<in> s. i < k}) = k" using nth_least_card 1(1) by this
        have 3: "enat (card {i \<in> s. i < k}) < llength (lselect s w)"
          unfolding lselect_llength using assms 1(1) by simp
        show "k \<in> nth_least s ` liset A (lselect s w)"
        proof
          show "k = nth_least s (card {i \<in> s. i < k})" using 2 by simp
          show "card {i \<in> s. i < k} \<in> liset A (lselect s w)" using 1(2) 2 3 by fastforce
        qed
      qed
      have "lproject A (lselect s w) = lselect (liset A (lselect s w)) (lselect s w)"
        unfolding lproject_to_lselect by rule
      also have "\<dots> = lselect (nth_least s ` {i \<in> liset A (lselect s w). enat i < esize s}) w"
        unfolding lselect_lselect by rule
      also have "\<dots> = lselect (nth_least s ` liset A (lselect s w)) w" unfolding 2 by rule
      also have "\<dots> = lselect (s \<inter> liset A w) w" unfolding 3 by rule
      finally show ?thesis by this
    qed

    lemma lselect_lproject[simp]: "lproject A (lselect s w) = lselect (s \<inter> liset A w) w"
    proof -
      have 1: "{i \<in> s. enat i < llength w} \<inter> liset A w = s \<inter> liset A w" by auto
      have "lproject A (lselect s w) = lproject A (lselect {i \<in> s. enat i < llength w} w)" by simp
      also have "\<dots> = lselect ({i \<in> s. enat i < llength w} \<inter> liset A w) w"
        by (rule lselect_lproject', simp)
      also have "\<dots> = lselect (s \<inter> liset A w) w" unfolding 1 by rule
      finally show ?thesis by this
    qed

    lemma lproject_lselect_subset[simp]:
      assumes "liset A w \<subseteq> s"
      shows "lproject A (lselect s w) = lproject A w"
    proof -
      have 1: "s \<inter> liset A w = liset A w" using assms by auto
      have "lproject A (lselect s w) = lselect (s \<inter> liset A w) w" by simp
      also have "\<dots> = lselect (liset A w) w" unfolding 1 by rule
      also have "\<dots> = lproject A w" unfolding lproject_to_lselect by rule
      finally show ?thesis by this
    qed

    lemma lselect_prefix[intro]:
      assumes "u \<le> v"
      shows "lselect s u \<le> lselect s v"
    proof (cases "lfinite u")
      case False
      show ?thesis using lprefix_infinite assms False by auto
    next
      case True
      obtain k where 1: "llength u = enat k" using True length_list_of by metis
      obtain w where 2: "v = u $ w" using lprefix_conv_lappend assms by auto
      have "lselect s u \<le> lselect s u $ lselect {n. n + k \<in> s} w" by simp
      also have "\<dots> = lselect s (u $ w)" using lnths_lappend_lfinite[symmetric] 1 by this
      also have "\<dots> = lselect s v" unfolding 2 by rule
      finally show ?thesis by this
    qed
    lemma lproject_prefix[intro]:
      assumes "u \<le> v"
      shows "lproject A u \<le> lproject A v"
      using lprefix_lfilterI assms by auto

    lemma lproject_prefix_limit[intro?]:
      assumes "\<And> v. v \<le> w \<Longrightarrow> lfinite v \<Longrightarrow> lproject A v \<le> x"
      shows "lproject A w \<le> x"
    proof -
      have 1: "ccpo.admissible lSup lprefix (\<lambda> v. lproject A v \<le> x)" by simp
      show ?thesis using llist_lift_admissible 1 assms(1) by this
    qed
    lemma lproject_prefix_limit':
      assumes "\<And> k. \<exists> v. v \<le> w \<and> enat k < llength v \<and> lproject A v \<le> x"
      shows "lproject A w \<le> x"
    proof (rule lproject_prefix_limit)
      fix u
      assume 1: "u \<le> w" "lfinite u"
      obtain k where 2: "llength u = enat k" using 1(2) by (metis length_list_of)
      obtain v where 3: "v \<le> w" "llength u < llength v" "lproject A v \<le> x"
        unfolding 2 using assms(1) by auto
      have 4: "llength u \<le> llength v" using 3(2) by simp
      have 5: "u \<le> v" using prefix_subsume 1(1) 3(1) 4 by this
      have "lproject A u \<le> lproject A v" using 5 by rule
      also have "\<dots> \<le> x" using 3(3) by this
      finally show "lproject A u \<le> x" by this
    qed

end


(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Slicing_Hoare_Typed
  imports VHDL_Hoare_Typed
begin

datatype sig = IN | OUT

definition slicer :: "sig conc_stmt" where
  "slicer = process {IN} : Bassign_trans OUT (Bslice IN 3 2) 1"

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bassign_trans OUT (Bslice IN 3 2) 1)"
  shows "\<exists>ki len. 3 < len \<and> \<Gamma> IN = Lty ki len \<and> \<Gamma> OUT = Lty ki 2"
proof (rule seq_wt_cases(4)[OF assms])
  assume "bexp_wt \<Gamma> (Bslice IN 3 2) (\<Gamma> OUT)"
  then obtain ki len where "bexp_wt \<Gamma> (Bsig IN) (Lty ki len) \<and> 3 < len \<and> \<Gamma> OUT = Lty ki 2"
    by (metis add_2_eq_Suc add_Suc add_Suc_right add_diff_cancel_right' bexp_wt_cases_slice(1)
    numeral_2_eq_2 numeral_3_eq_3)
  hence "bexp_wt \<Gamma> (Bsig IN) (Lty ki len)" and "3 < len" and "\<Gamma> OUT = Lty ki 2"
    by auto
  hence "\<Gamma> IN = Lty ki len"
    using bexp_wt_cases_slice(2)[OF \<open>bexp_wt \<Gamma> (Bsig IN) (Lty ki len)\<close>] by metis
  thus ?thesis
    using \<open>3 < len\<close> \<open>\<Gamma> OUT = Lty ki 2\<close> by blast
qed

abbreviation "lof_wline tw sig i \<equiv> lval_of (wline_of tw sig i)"

locale slicer_typed =
  fixes \<Gamma> :: "sig tyenv" and len :: nat and ki :: "signedness"
  assumes tyin: "\<Gamma> IN = Lty ki len" and tyout: "\<Gamma> OUT = Lty ki 2" and len3: "3 < len"
begin

definition inv :: "sig assn2" where
  "inv tw = (let ins = lof_wline tw IN (fst tw - 1); idx = length ins - 1 in
                                          lof_wline tw OUT (fst tw) = nths ins {idx - 3 .. idx - 2})"

definition inv2 :: "sig assn2" where
  "inv2 tw = (disjnt {IN} (event_of tw) \<longrightarrow> (\<forall>i > fst tw. lof_wline tw OUT i = lof_wline tw OUT (fst tw)))"

text \<open>Note that we need the assumption that @{term "type_of x = Lty ki 2"} as there is no
guarantee that @{term "beval_world_raw2 tw (Bslice IN 3 2) x"} would result in a list
of length 2.\<close>

lemma inv_next_time:
  fixes tw
  defines "v \<equiv> eval_world_raw2 tw (Bslice IN 3 2)"
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  assumes "wityping \<Gamma> (snd tw)"
  shows   "inv (fst tw' + 1, snd tw')"
proof -
  have bexpIN: "bexp_wt \<Gamma> (Bsig IN) (Lty ki len)"
    using slicer_typed_axioms unfolding slicer_typed_def by (metis bexp_wt.intros(3))+
  obtain bsIN where evalIN: "eval_world_raw (fst tw) (snd tw) (Bsig IN) = Lv ki bsIN" and" length bsIN = len "
      using eval_world_raw_lv[OF bexpIN `wityping \<Gamma> (snd tw)`] by blast
  have "lof_wline tw' OUT (fst tw + 1) = lval_of v"
    unfolding tw'_def worldline_upd2_def worldline_upd_def by auto
  also have "... = (let ins = lof_wline tw IN (fst tw); idx = length ins - 1 in nths ins {idx - 3 .. idx - 2})"
    using evalIN `length bsIN = len` len3 unfolding v_def eval_world_raw.simps eval_arith.simps Let_def
    by (metis comp_def diff_commute val.sel(3) val.simps(6))
  finally show ?thesis
    unfolding inv_def Let_def tw'_def worldline_upd2_def worldline_upd_def by auto
qed

lemma inv2_next_time:
  fixes tw v
  defines "tw' \<equiv> tw[OUT, 1 :=\<^sub>2 v]"
  shows   "inv2 (fst tw' + 1, snd tw')"
  unfolding inv2_def tw'_def worldline_upd2_def worldline_upd_def by auto

lemma conc_hoare:
  "\<And>tw. inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> inv (fst tw + 1, snd tw)"
proof -
  fix tw
  assume "inv tw \<and> inv2 tw \<and> disjnt {IN} (event_of tw)"
  hence "inv tw" and "inv2 tw" and "disjnt {IN} (event_of tw)"
    by auto
  have "lof_wline tw OUT (fst tw + 1) = lof_wline tw OUT (fst tw)"
    using `inv2 tw` `disjnt {IN} (event_of tw)` unfolding inv2_def by auto
  also have "... = (let ins = lof_wline tw IN (get_time tw - 1); idx = length ins - 1 in nths ins {idx - 3..idx - 2})"
    using `inv tw` unfolding inv_def Let_def by auto
  also have "... = (let ins = lof_wline tw IN (get_time tw); idx = length ins - 1 in nths ins {idx - 3..idx - 2})"
    using `disjnt {IN} (event_of tw)`  unfolding event_of_alt_def   by (smt diff_0_eq_0 disjnt_insert1 mem_Collect_eq)
  finally show "inv (fst tw + 1, snd tw)"
    unfolding inv_def by auto
qed

lemma conc_hoare2:
  "\<And>tw. inv2 tw \<and> disjnt {IN} (event_of tw) \<Longrightarrow> inv2 (fst tw + 1, snd tw)"
  unfolding inv2_def by auto

lemma conc_stmt_wf:
  "conc_stmt_wf (slicer)"
  unfolding slicer_def conc_stmt_wf_def by auto

lemma nonneg_delay_conc:
  "nonneg_delay_conc (slicer)"
  unfolding slicer_def by auto

lemma nonneg_delay_conc':
  "nonneg_delay_conc ( process {IN} : Bassign_trans OUT (Bslice IN 3 2) 1)"
  using nonneg_delay_conc unfolding slicer_def by auto

lemma well_typed:
  "seq_wt \<Gamma> (Bassign_trans OUT (Bslice IN 3 2) 1)"
proof (intro seq_wt.intros)
  have 0: "bexp_wt \<Gamma> (Bsig IN) (Lty ki len)"
    by (simp add: bexp_wt.intros(3) tyin)
  have 1: "(2 :: nat) = 3 - 2 + 1" and 2: "2 \<le> (3 :: nat)"
    by auto
  have "bexp_wt \<Gamma> (Bslice IN 3 2) (Lty ki 2)"
    using  bexp_wt.intros(13)[OF 0 1 2]  using len3 by linarith
  thus "bexp_wt \<Gamma> (Bslice IN 3 2) (\<Gamma> OUT) "
    by (simp add: tyout)
qed

lemma conc_wt:
  "conc_wt \<Gamma> (slicer)"
  unfolding slicer_def  by (meson conc_wt.intros(1) well_typed)

lemma conc_wt':
  "conc_wt \<Gamma> ( process {IN} : Bassign_trans OUT (Bslice IN 3 2) 1)"
  using conc_wt unfolding slicer_def by auto

lemma conc_sim2':
  "\<Gamma> \<turnstile>\<^sub>s \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace> slicer \<lbrace>\<lambda>tw. inv tw \<and> inv2 tw\<rbrace>"
  apply (rule While_Suc)
  apply (rule Conseq'[where P="wp3_conc \<Gamma> slicer (\<lambda>tw. inv  (fst tw + 1, snd tw) \<and>
                                                       inv2 (fst tw + 1, snd tw))", rotated])
  apply (rule wp3_conc_is_pre, rule conc_stmt_wf, rule nonneg_delay_conc, rule conc_wt, simp)
  unfolding slicer_def wp3_conc_single'[OF conc_wt' nonneg_delay_conc'] wp3_fun.simps
  using inv_next_time inv2_next_time conc_hoare conc_hoare2 by presburger

lemma nonneg_delay_add:
  " nonneg_delay (Bassign_trans OUT (Bslice IN 3 2) 1)"
  using nonneg_delay_conc' by auto

lemma init_sat_nand_inv_comb:
  "init_sim2_hoare_wt \<Gamma> (\<lambda>tw. fst tw = 0) (slicer) (\<lambda>tw. inv tw \<and> inv2 tw)"
  unfolding slicer_def
  apply (rule AssignI_suc, rule SingleI)
  apply (rule Conseq3[where Q="\<lambda>tw. inv (fst tw + 1, snd tw) \<and> inv2 (fst tw + 1, snd tw)", rotated])
  apply (rule wp3_fun_is_pre[OF well_typed nonneg_delay_add], simp)
  unfolding wp3_fun.simps using inv_next_time inv2_next_time by blast

lemma correctness:
  assumes "sim_fin2 w (i + 1) (slicer) tw'" and "wityping \<Gamma> w"
  shows "let ins = lof_wline tw' IN i; idx = length ins - 1 in
                                          lof_wline tw' OUT (i + 1) = nths ins {idx - 3 .. idx - 2}"
  using grand_correctness[OF assms conc_stmt_wf conc_wt nonneg_delay_conc conc_sim2' init_sat_nand_inv_comb]
  unfolding slicer_def inv_def  by (metis (no_types, lifting) add_diff_cancel_right' assms(1)
  sim_fin2.cases world_maxtime_lt_fst_tres)

end