theory Tau_Sinks
imports
  Coupled_Simulation
begin

section \<open>\<open>\<tau>\<close>-sinks\<close>

subsection \<open>Weak Relations Invariant to \<open>\<tau>\<close>-sinks\<close>

lemma simulation_tau_sink_1:
  fixes
    step sink R \<tau>
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a = \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p\<close>
    \<open>lts_tau.weak_simulation step \<tau> R\<close>
  shows
    \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda> p q. p = sink \<or> R p q)\<close>
proof -
  let ?tau = \<open>(lts_tau.tau \<tau>)\<close>
  let ?tauEx = \<open>\<tau>\<close>
  show ?thesis unfolding lts_tau.weak_simulation_def
  proof safe
    fix p q p' a
    assume \<open>step2 sink a p'\<close>
    hence \<open>p' = sink\<close> \<open>a = \<tau>\<close>
      using assms(2) unfolding step2_def by auto
    thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
        \<and> lts.steps step2 pq2 ?tau q'))\<close>
      using lts_tau.step_tau_refl[of \<tau> step2 q] by auto
  next
    fix p q p' a
    assume \<open>step2 p a p'\<close> \<open>R p q\<close>
    have step_impl_step2: \<open>\<And> p1 a p2 . step p1 a p2 \<Longrightarrow> step2 p1 a p2\<close>
      unfolding step2_def by blast
    have \<open>(p \<noteq> sink \<and> a = ?tauEx \<and> p' = sink) \<or> step p a p'\<close>
      using `step2 p a p'` unfolding step2_def .
    thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
        \<and> lts.steps step2 pq2 ?tau q'))\<close>
    proof safe
      show \<open>\<exists>q'. (sink = sink \<or> R sink q') \<and>
           (?tau ?tauEx \<longrightarrow> lts.steps step2 q ?tau q') \<and>
           (\<not> ?tau ?tauEx \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1
            \<and> step2 pq1 ?tauEx pq2 \<and> lts.steps step2 pq2 ?tau q'))\<close>
        using lts.steps.refl[of step2 q ?tau] assms(1) by (meson lts_tau.tau_tau)
    next
      assume \<open>step p a p'\<close>
      then obtain q' where q'_def:
        \<open>R p' q' \<and>
        (?tau a \<longrightarrow> lts.steps step q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step q ?tau pq1 \<and> step pq1 a pq2
          \<and> lts.steps step pq2 ?tau q'))\<close>
        using assms(3) `R p q` unfolding lts_tau.weak_simulation_def by blast
      hence \<open>(p' = sink \<or> R p' q') \<and>
        (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
          \<and> lts.steps step2 pq2 ?tau q'))\<close>
        using lts_impl_steps[of step _ _ _ step2] step_impl_step2 by blast
      thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
        (?tau a \<longrightarrow> lts.steps step2 q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. lts.steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
          \<and> lts.steps step2 pq2 ?tau q'))\<close>
        by blast
    qed
  qed
qed

lemma simulation_tau_sink_2:
  fixes
    step sink R \<tau>
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a = \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p \<and> \<not> step p a sink\<close>
    \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda> p q. p = sink \<or> R p q)\<close>
    \<open>\<And> p' q' q . (p' = sink \<or> R p' q')
      \<and> lts.steps step2 q (lts_tau.tau \<tau>) q'  \<longrightarrow> (p' = sink \<or> R p' q)\<close>
  shows
    \<open>lts_tau.weak_simulation step \<tau> (\<lambda> p q. p = sink \<or> R p q)\<close>
proof -
  let ?tau = \<open>(lts_tau.tau \<tau>)\<close>
  let ?tauEx = \<open>\<tau>\<close>
  let ?steps = \<open>lts.steps\<close>
  show ?thesis
    unfolding lts_tau.weak_simulation_def
  proof safe
    fix p q p' a
    assume
      \<open>step sink a p'\<close>
    hence False using assms(2) by blast
    thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> ?steps step q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
        \<and> ?steps step pq2 ?tau q'))\<close> ..
  next
    fix p q p' a
    assume \<open>R p q\<close> \<open>step p a p'\<close>
    hence not_sink: \<open>p \<noteq> sink\<close> \<open>p' \<noteq> sink\<close>
      using assms(2)[of a p] assms(2)[of a p'] by auto
    have \<open>step2 p a p'\<close> using `step p a p'` unfolding step2_def by blast
    then obtain q' where q'_def:
      \<open>p' = sink \<or> R p' q'\<close>
      \<open>?tau a \<longrightarrow> ?steps step2 q ?tau q'\<close>
      \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step2 q ?tau pq1 \<and> step2 pq1 a pq2
        \<and> ?steps step2 pq2 ?tau q')\<close>
      using assms(3) `R p q` unfolding lts_tau.weak_simulation_def by blast
    hence outer_goal_a: \<open>R p' q'\<close> using not_sink by blast
    show \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and>
      (?tau a \<longrightarrow> ?steps step q ?tau q') \<and>
      (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
        \<and> ?steps step pq2 ?tau q'))\<close>
    proof (cases \<open>q' = sink\<close>)
      assume \<open>q' = sink\<close>
      then obtain q'' where q''_def:
        \<open>?tau a \<longrightarrow> (?steps step q ?tau q'' \<and> ?steps step2 q'' ?tau q')\<close>
        \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1. ?steps step2 q ?tau pq1 \<and> step pq1 a q''
          \<and> ?steps step2 q'' ?tau q')\<close>
        using q'_def(2,3) assms(1) step2_def lts_tau.step_tau_refl[of \<tau>]
          lts_tau.tau_tau[of \<tau>] by metis
      hence \<open>q'' = sink \<longrightarrow> q = sink\<close>
        using assms(2) unfolding step2_def by (metis lts.steps.cases)
      have \<open>?steps step2 q'' ?tau q'\<close> using q''_def by auto
      hence \<open>p' = sink \<or> R p' q''\<close> using  q'_def(1) assms(4)[of p' q' q''] by blast
      moreover have \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
        \<and> ?steps step pq2 ?tau q'')\<close>
      proof
        assume \<open>\<not> ?tau a\<close>
        hence \<open>q \<noteq> sink\<close> using q'_def by (metis assms(2) lts.steps_left step2_def)
        hence \<open>q'' \<noteq> sink\<close> using `q'' = sink \<longrightarrow> q = sink` by simp
        obtain pq1 where pq1_def:
            \<open>?steps step2 q ?tau pq1\<close> \<open>step pq1 a q''\<close> \<open>?steps step2 q'' ?tau q'\<close>
          using q''_def(2) `\<not> ?tau a` by blast
        hence \<open>pq1 \<noteq> sink\<close> using `q'' \<noteq> sink` assms(2) by blast
        hence \<open>?steps step q ?tau pq1\<close> using `q \<noteq> sink` `?steps step2 q ?tau pq1`
        proof (induct rule: lts.steps.induct[OF `?steps step2 q ?tau pq1`])
          case (1 p af)
          then show ?case using lts.steps.refl[of step p af] by blast
        next
          case (2 p af q1 a q)
          hence \<open>q1 \<noteq> sink\<close> \<open>step q1 a q\<close> using assms(2) unfolding step2_def by auto
          moreover hence \<open>?steps step p af q1\<close> using 2 by blast
          ultimately show ?case using 2(4) by (meson lts.step)
        qed
        thus
          \<open>\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2 \<and> ?steps step pq2 ?tau q''\<close>
          using pq1_def(2) lts.steps.refl[of step q'' ?tau] by blast
      qed
      ultimately show \<open>\<exists>q''. (p' = sink \<or> R p' q'') \<and>
           (?tau a \<longrightarrow> ?steps step q ?tau q'') \<and>
           (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
            \<and> ?steps step pq2 ?tau q''))\<close>
        using q''_def(1) q'_def(1) by auto
    next
      assume not_sink_q': \<open>q' \<noteq> sink\<close>
      have outer_goal_b: \<open>?tau a \<longrightarrow> ?steps step q ?tau q'\<close>
        using q'_def(2) not_sink_q' unfolding step2_def
      proof (safe)
        assume i:
          \<open>q' \<noteq> sink\<close> \<open>?tau a\<close>
          \<open>?steps (\<lambda>p1 a p2.  p1 \<noteq> sink \<and> a = ?tauEx \<and> p2 = sink \<or> step p1 a p2) q ?tau q'\<close>
        thus \<open>?steps step q ?tau q'\<close>
        proof (induct rule: lts.steps.induct[OF i(3)])
          case (1 p af)
          then show ?case using lts.steps.refl[of _ p af] by auto
        next
          case (2 p af q1 a q)
          hence \<open>step q1 a q\<close> by blast
          moreover have \<open>?steps step p af q1\<close> using 2 assms(2) by blast
          ultimately show ?case using `af a` lts.step[of step p af q1 a q] by blast
        qed
      qed
      have outer_goal_c:
          \<open>\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
          \<and> ?steps step pq2 ?tau q')\<close>
        using q'_def(3)
      proof safe
        fix pq1 pq2
        assume subassms:
          \<open>\<not> ?tau a\<close>
          \<open>?steps step2 q ?tau pq1\<close>
          \<open>step2 pq1 a pq2\<close>
          \<open>?steps step2 pq2 ?tau q'\<close>
        have \<open>pq2 \<noteq> sink\<close>
          using subassms(4) assms(2) not_sink_q' lts.steps_loop
          unfolding step2_def by (metis (mono_tags, lifting))
        have  goal_c: \<open>?steps step pq2 ?tau q'\<close>
          using subassms(4) not_sink_q' unfolding step2_def
        proof (induct rule:lts.steps.induct[OF subassms(4)])
          case (1 p af) show ?case using lts.steps.refl by assumption
        next
          case (2 p af q1 a q)
          hence \<open>step q1 a q\<close> unfolding step2_def by simp
          moreover hence \<open>q1 \<noteq> sink\<close> using assms(2) by blast
          ultimately have \<open>?steps step p af q1\<close> using 2 unfolding step2_def by auto
          thus ?case using `step q1 a q` 2(4) lts.step[of step p af q1 a q] by blast
        qed
        have goal_b: \<open>step pq1 a pq2\<close>
          using `pq2 \<noteq> sink` subassms(3) unfolding step2_def by blast
        hence \<open>pq1 \<noteq> sink\<close> using assms(2) by blast
        hence goal_a: \<open>?steps step q ?tau pq1\<close>
          using subassms(4) unfolding step2_def
        proof (induct rule:lts.steps.induct[OF subassms(2)])
          case (1 p af) show ?case using lts.steps.refl by assumption
        next
          case (2 p af q1 a q)
          hence \<open>step q1 a q\<close> unfolding step2_def by simp
          moreover hence \<open>q1 \<noteq> sink\<close> using assms(2) by blast
          ultimately have \<open>?steps step p af q1\<close> using 2 unfolding step2_def by auto
          thus ?case using `step q1 a q` 2(4) lts.step[of step p af q1 a q] by blast
        qed
        thus
          \<open>\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2 \<and> ?steps step pq2 ?tau q'\<close>
          using goal_b goal_c by auto
      qed
      thus \<open>\<exists>q'. (p' = sink \<or> R p' q') \<and> (?tau a \<longrightarrow> ?steps step q ?tau q') \<and>
        (\<not> ?tau a \<longrightarrow> (\<exists>pq1 pq2. ?steps step q ?tau pq1 \<and> step pq1 a pq2
          \<and> ?steps step pq2 ?tau q'))\<close>
        using outer_goal_a outer_goal_b by auto
    qed
  qed
qed

lemma simulation_sink_invariant:
  fixes
    step sink R \<tau>
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a =  \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p \<and> \<not> step p a sink\<close>
  shows \<open>lts_tau.weakly_simulated_by step2 \<tau> p q = lts_tau.weakly_simulated_by step \<tau> p q\<close>
proof (rule)
  have sink_sim_min: \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda> p q. p = sink)\<close>
    unfolding lts_tau.weak_simulation_def step2_def using assms(2)
    by (meson lts.steps.simps)
  define R where \<open>R \<equiv> lts_tau.weakly_simulated_by step2 \<tau>\<close>
  have weak_sim_R: \<open>lts_tau.weak_simulation step2 \<tau> R\<close>
    using lts_tau.weaksim_greatest[of step2 \<tau>] unfolding R_def by blast
  have R_contains_inv_tau_closure:
    \<open>R = (\<lambda>p1 q1. R p1 q1 \<or> lts.steps step2 q1 (lts_tau.tau \<tau>) p1)\<close> unfolding R_def
  proof (rule, rule, rule, simp)
    fix p q
    assume
      \<open>(\<exists>R. lts_tau.weak_simulation step2 \<tau>  R \<and> R p q) \<or>
       (lts.steps step2 q (lts_tau.tau \<tau>) p)\<close>
    thus \<open>\<exists>R. lts_tau.weak_simulation step2 \<tau> R \<and> R p q\<close>
      using weak_sim_R
            lts_tau.weak_sim_tau_step[of step2 \<open>\<tau>\<close>]
            lts_tau.weak_sim_union_cl[of step2 \<open>\<tau>\<close>] by blast
  qed
  assume Rpq: \<open>R p q\<close>
  have \<open>\<And> p' q' q . R p' q' \<and> lts.steps step2 q (lts_tau.tau \<tau>) q'  \<longrightarrow> R p' q\<close>
    using R_contains_inv_tau_closure lts_tau.weak_sim_trans[of step2 \<open>\<tau>\<close> _ _ _] R_def assms(2)
    by meson
  hence closed_R:
      \<open>\<And> p' q' q . (p' = sink \<or> R p' q') \<and> lts.steps step2 q (lts_tau.tau \<tau>) q'
         \<longrightarrow> (p' = sink \<or> R p' q)\<close>
    using weak_sim_R sink_sim_min lts_tau.weak_sim_union_cl by blast
  have \<open>lts_tau.weak_simulation step2 \<tau> (\<lambda>p q. p = sink \<or> R p q)\<close>
    using weak_sim_R sink_sim_min lts_tau.weak_sim_union_cl[of step2 \<tau>] by blast
  hence \<open>lts_tau.weak_simulation step \<tau> (\<lambda>p q. p = sink \<or> R p q)\<close>
    using  simulation_tau_sink_2[of step sink \<tau> R] assms(2) closed_R
    unfolding step2_def by blast
  thus \<open>\<exists>R. lts_tau.weak_simulation step \<tau> R \<and> R p q\<close>
    using Rpq weak_sim_R by blast
next
  show \<open>\<exists>R. lts_tau.weak_simulation step \<tau> R \<and> R p q \<Longrightarrow>
        \<exists>R. lts_tau.weak_simulation step2 \<tau> R \<and> R p q\<close>
  proof clarify
    fix R
    assume
      \<open>lts_tau.weak_simulation step \<tau> R\<close>
      \<open>R p q\<close>
    hence \<open>lts_tau.weak_simulation
      (\<lambda>p1 a p2. p1 \<noteq> sink \<and> a = \<tau> \<and> p2 = sink \<or> step p1 a p2) \<tau> (\<lambda>p q. p = sink \<or> R p q)\<close>
      using simulation_tau_sink_1[of step sink \<tau> R] assms(2) unfolding step2_def by auto
    thus \<open>\<exists>R. lts_tau.weak_simulation step2 \<tau> R \<and> R p q\<close>
      using `R p q` unfolding step2_def by blast
  qed
qed

lemma trace_inclusion_sink_invariant:
  fixes
    step sink R \<tau>
  defines
    \<open>step2 \<equiv> \<lambda> p1 a p2 . (p1 \<noteq> sink \<and> a =  \<tau> \<and> p2 = sink) \<or> step p1 a p2\<close>
  assumes
    \<open>\<And> a p . \<not> step sink a p \<and> \<not> step p a sink\<close>
  shows \<open>lts_tau.weakly_trace_included_by step2 \<tau> p q = lts_tau.weakly_trace_included_by step \<tau> p q\<close>
proof -
  let ?tau = \<open>(lts_tau.tau \<tau>)\<close>
  let ?steps = \<open>lts.steps\<close>
  let ?seq = \<open>lts_tau.weak_step_seq\<close>
  {
    fix A
    have \<open>\<forall>p p'. (\<forall> a \<in> set(A). a \<noteq> \<tau>)
    \<and> lts_tau.weak_step_seq step2 \<tau> p A p'
    \<longrightarrow> (\<exists>p''. ?seq step \<tau> p A p''
    \<and> lts_tau.weak_step_tau step2 \<tau> p'' \<tau> p')\<close>
    proof(clarify, induct A rule: rev_induct)
      case Nil
      hence \<open>lts_tau.weak_step_tau step \<tau> p \<tau> p\<close>
        using lts_tau.step_tau_refl by fastforce
      thus ?case
        by (metis Nil.prems(2) lts_tau.tau_tau lts_tau.weak_step_seq.simps(1))
    next
      case (snoc a A)
      hence not_in_set: \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close> by force
      then obtain p01 where
        \<open>?seq step2 \<tau> p A p01\<close> and
        p01_def2: \<open>lts_tau.weak_step_tau step2 \<tau> p01 a p'\<close>
        using snoc by (metis lts_tau.rev_seq_split)
      then obtain p02 where p02_def:
        \<open>?seq step \<tau> p A p02\<close>
        \<open>lts_tau.weak_step_tau step2 \<tau> p02 \<tau> p01\<close>
        using snoc.hyps[of p p01] snoc.prems(1) not_in_set by auto
      hence \<open>lts_tau.weak_step_tau step2 \<tau> p02 a p'\<close>
        using p01_def2 lts_tau.step_tau_concat lts_tau.tau_tau
        by (smt (verit, del_insts))
      then obtain p03 p04 where
        tau1: \<open>lts_tau.weak_step_tau step2 \<tau> p02 \<tau> p03\<close> and
        a_step2: \<open>lts.step step2 p03 a p04\<close> and
        tau2: \<open>lts_tau.weak_step_tau step2 \<tau> p04 \<tau> p'\<close>
        using snoc.prems(1) lts_tau.tau_def
        by (metis last_in_set snoc_eq_iff_butlast)
      hence \<open>p04 \<noteq> sink\<close> using assms snoc.prems(1) by force
      hence a_step: \<open>lts.step step p03 a p04\<close> using a_step2 assms by auto
      have notsinkp03: \<open>p03 \<noteq> sink\<close> using a_step2 assms snoc.prems(1) by force
      have \<open>?steps step2 p02 ?tau p03\<close> using tau1 by (simp add: lts_tau.tau_tau)
      hence \<open>?steps step p02 ?tau p03\<close> using notsinkp03
      proof (induct rule: lts.steps.induct[OF `?steps step2 p02 ?tau  p03`])
        case (1 p A)
        thus ?case by (simp add: lts.refl)
      next
        case (2 p A q1 a q)
        hence \<open>q1 \<noteq> sink\<close> using assms(2) step2_def by blast
        thus ?case using 2 lts.step step2_def by metis
      qed
      hence \<open>lts_tau.weak_step_tau step \<tau> p02 \<tau> p03\<close> by (simp add: lts_tau.tau_tau)
      hence \<open>lts_tau.weak_step_tau step \<tau> p02 a p04\<close> using a_step
        by (metis lts.step lts_tau.step_tau_refl lts_tau.tau_tau)
      hence \<open>?seq step \<tau> p (A@[a]) p04\<close>
        using lts_tau.rev_seq_step_concat p02_def(1) by fastforce
      thus ?case using tau2 by auto
    qed
  }
  hence step2_to_step: \<open>\<forall>A p p'. (\<forall> a \<in> set(A). a \<noteq> \<tau>)
    \<and> ?seq step2 \<tau> p A p'
    \<longrightarrow> (\<exists>p''. ?seq step \<tau> p A p'')\<close>
    by fastforce

  have step_to_step2:  \<open>\<forall>A p p'. (\<forall> a \<in> set(A). a \<noteq> \<tau>)
    \<and> ?seq step \<tau> p A p'
    \<longrightarrow> ?seq step2 \<tau> p A p'\<close>
  proof
    fix A
    show \<open>\<forall>p p'. (\<forall> a \<in> set(A). a \<noteq> \<tau>)
    \<and> ?seq step \<tau> p A p'
    \<longrightarrow> ?seq step2 \<tau> p A p'\<close>
    proof(clarify, induct A rule: list.induct)
      case Nil
      assume \<open>?seq step \<tau> p [] p'\<close>
      hence tau_step: \<open>lts_tau.weak_step_tau step \<tau> p \<tau> p'\<close>
        by (simp add: lts_tau.weak_step_seq.simps(1) lts_tau.tau_tau)
      hence \<open>lts_tau.weak_step_tau step2 \<tau> p \<tau> p'\<close>
        using lts_impl_steps step2_def lts_tau.tau_tau  by force
      thus ?case by (simp add: lts_tau.weak_step_seq.simps(1) lts_tau.tau_tau)
    next
      case (Cons x xs)
      then obtain p1 where p1_def: \<open>lts_tau.weak_step_tau step \<tau> p x p1\<close>
      \<open>?seq step \<tau> p1 xs p'\<close>
        by (metis (mono_tags, lifting) lts_tau.weak_step_seq.simps(2))
      hence IH: \<open>?seq step2 \<tau> p1 xs p'\<close> using Cons by auto
      then obtain p01 p02 where \<open>lts_tau.weak_step_tau step \<tau> p \<tau> p01\<close> and
        strong: \<open>lts.step step p01 x p02\<close> and
        p02_weak: \<open>lts_tau.weak_step_tau step \<tau> p02 \<tau> p1\<close>
        using Cons.prems(1) p1_def lts_tau.tau_def by (metis list.set_intros(1))
      hence tau1: \<open>lts_tau.weak_step_tau step2 \<tau> p \<tau> p01\<close>
        using lts_impl_steps step2_def
        by (smt (verit, best))
      have \<open>lts_tau.weak_step_tau step2 \<tau> p02 \<tau> p1\<close>
        using p02_weak lts_impl_steps step2_def by (smt (verit, best))
      hence \<open>lts_tau.weak_step_tau step2 \<tau> p x p1\<close>
        using tau1 strong step2_def Cons.prems(1) lts_tau.tau_def
        by (metis list.set_intros(1))
      thus \<open>?seq step2 \<tau> p (x#xs) p'\<close>
        using IH lts_tau.weak_step_seq_def[of step2 \<tau>] by auto
    qed
  qed
  show ?thesis
  proof (rule)
    assume \<open>\<exists>R. lts_tau.trace_inclusion step2 \<tau> R \<and> R p q\<close>
    then obtain R where weak_sim_R: \<open>lts_tau.trace_inclusion step2 \<tau> R\<close>
      and Rpq: \<open>R p q\<close>
      by blast
    have \<open>lts_tau.trace_inclusion step \<tau> R\<close>
      unfolding lts_tau.trace_inclusion_def
    proof clarify
      fix p q p' A
      assume subassms:
        \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
        \<open>R p q\<close>
        \<open>?seq step \<tau> p A p'\<close>
      hence \<open>(\<forall>a\<in>set A. a \<noteq> \<tau>) \<and>
       ?seq step2 \<tau> p A p' \<longrightarrow>
       (\<exists>q'. ?seq step2 \<tau> q A q')\<close>
        using weak_sim_R
        unfolding lts_tau.trace_inclusion_def by simp
      hence \<open>(\<forall>a\<in>set A. a \<noteq> \<tau>) \<and>
       ?seq step \<tau> p A p' \<longrightarrow>
       (\<exists>q'. ?seq step \<tau> q A q')\<close>
        using step2_to_step step_to_step2
        by auto
      thus "\<exists>q'. ?seq step \<tau> q A q'"
        by (simp add: subassms)
    qed
    thus \<open>\<exists>R. lts_tau.trace_inclusion step \<tau> R \<and> R p q\<close>
      using Rpq by auto
  next
    assume \<open>\<exists>R. lts_tau.trace_inclusion step \<tau> R \<and> R p q\<close>
    then obtain R where weak_sim_R: \<open>lts_tau.trace_inclusion step \<tau> R\<close>
      and Rpq: \<open>R p q\<close>
      by blast
    have \<open>lts_tau.trace_inclusion step2 \<tau> R\<close>
      unfolding lts_tau.trace_inclusion_def
    proof clarify
      fix p q p' A
      assume subassms:
        \<open>\<forall>a\<in>set A. a \<noteq> \<tau>\<close>
        \<open>R p q\<close>
        \<open>?seq step2 \<tau> p A p'\<close>
      thus \<open>\<exists>q'. ?seq step2 \<tau> q A q'\<close>
        using step2_to_step step_to_step2
        by (metis (full_types) lts_tau.trace_inclusion_def weak_sim_R)
    qed
    thus \<open>\<exists>R. lts_tau.trace_inclusion step2 \<tau> R \<and> R p q\<close> using Rpq by auto
  qed
qed

subsection \<open>\<open>\<tau>\<close>-sink Properties\<close>

context lts_tau
begin

definition tau_sink ::
  \<open>'s \<Rightarrow> bool\<close>
where
  \<open>tau_sink p  \<equiv> \<forall>a. a = \<tau> \<or> (\<nexists>p'. p \<Rightarrow>a p')\<close>

lemma sink_has_no_weak_transitions:
  assumes
    \<open>tau_sink sink\<close>
  shows \<open>\<nexists>s'. s' \<noteq> sink \<and> sink \<Rightarrow>^a s' \<and> a \<noteq> \<tau>\<close>
proof -
  have  \<open>\<nexists>s' . sink \<Rightarrow>a s' \<and> a \<noteq> \<tau>\<close> using tau_sink_def assms(1) by auto
  thus ?thesis using tau_def by blast
qed

lemma sink_has_no_word_transitions:
  assumes
    \<open>tau_sink sink\<close>
    \<open>A \<noteq> []\<close>
    \<open>\<forall> a \<in> set(A). a \<noteq> \<tau>\<close>
  shows \<open>\<nexists>s'. sink \<Rightarrow>$A s'\<close>
proof -
  obtain a where \<open>\<exists>B. A = a#B\<close> using assms(2) list.exhaust_sel by auto
  hence \<open>\<nexists>s' . sink \<Rightarrow>^a s'\<close> by (metis assms(1,3) list.set_intros(1) lts_tau.tau_def tau_sink_def)
  thus ?thesis using \<open>\<exists>B. A = a#B\<close> by fastforce
qed

lemma sink_contrasimulates_all_states:
fixes A :: " 'a list"
  assumes
    \<open>tau_sink sink\<close>
    \<open>\<And> p . (p \<longmapsto>* tau sink)\<close>
  shows
    \<open>\<forall> p. sink \<sqsubseteq>c p\<close>
proof (cases A)
  case Nil
  hence empty_word: \<open>sink \<Rightarrow>$A sink\<close> by (simp add: steps.refl)
  have \<open>\<forall>p. p \<Rightarrow>$A sink\<close> using assms(2) Nil by auto
  have \<open>sink \<sqsubseteq>c sink\<close> using contrasim_tau_step empty_word Nil by auto
  show ?thesis using assms(2) contrasim_tau_step by auto
next
  case Cons
  hence \<open>\<nexists>s'. (\<forall> a \<in> set(A). a \<noteq> \<tau>) \<and> sink \<Rightarrow>$A s'\<close>
    using assms(1) sink_has_no_word_transitions by fastforce
  show ?thesis using assms(2) contrasim_tau_step by auto
qed

lemma sink_coupled_simulates_all_states:
  assumes
    \<open>tau_sink sink\<close>
    \<open>\<And> p . (p \<longmapsto>* tau sink)\<close>
  shows
    \<open>sink \<sqsubseteq>cs p\<close>
  by (simp add: assms(1, 2) coupledsim_refl tau_sink_def coupledsim_step)

lemma sink_trace_includes_all_states:
  assumes
    \<open>tau_sink sink\<close>
    \<open>\<And> p . (p \<longmapsto>* tau sink)\<close>
  shows
    \<open>sink \<sqsubseteq>T p\<close>
  by (metis assms(2) contrasim_tau_step lts_tau.contrasim_implies_trace_incl)

lemma trace_incl_with_sink_is_contrasim:
  assumes
    \<open>\<And> p . (p \<longmapsto>* tau sink)\<close>
    \<open>\<And> p . R sink p\<close>
    \<open>trace_inclusion R\<close>
  shows
    \<open>contrasimulation R\<close>
 unfolding contrasimulation_def
proof clarify
  fix p q p' A
  assume \<open>R p q\<close> \<open>p \<Rightarrow>$A  p'\<close> \<open>\<forall> a \<in> set(A). a \<noteq> \<tau>\<close>
  hence \<open>\<exists>q'. q \<Rightarrow>$A  q'\<close>
    using assms(3) unfolding trace_inclusion_def by blast
  hence \<open>q \<Rightarrow>$A  sink\<close>
    using assms(1) tau_tau word_tau_concat by blast
  thus \<open>\<exists>q'. q \<Rightarrow>$ A  q' \<and> R q' p'\<close>
    using assms(2) by auto
qed

lemma contrasim_trace_incl_equiv_on_sink_expansion:
  assumes
    \<open>\<And> p . (p \<longmapsto>* tau sink)\<close>
    \<open>\<And> p . R sink p\<close>
  shows
    \<open>contrasimulation R = trace_inclusion R\<close>
proof
  assume \<open>contrasimulation R\<close>
  thus \<open>trace_inclusion R\<close> by (simp add: contrasim_implies_trace_incl)
next
  assume \<open>trace_inclusion R\<close>
  thus \<open>contrasimulation R\<close>  by (meson assms lts_tau.trace_incl_with_sink_is_contrasim)
qed

end
end


(*  Title:      HOL/Imperative_HOL/ex/Subarray.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section \<open>Theorems about sub arrays\<close>

theory Subarray
imports "~~/src/HOL/Imperative_HOL/Array" List_Sublist
begin

definition subarray :: "nat \<Rightarrow> nat \<Rightarrow> ('a::heap) array \<Rightarrow> heap \<Rightarrow> 'a list" where
  "subarray n m a h \<equiv> sublist' n m (Array.get h a)"

lemma subarray_upd: "i \<ge> m \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h"
apply (simp add: subarray_def Array.update_def)
apply (simp add: sublist'_update1)
done

lemma subarray_upd2: " i < n  \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h"
apply (simp add: subarray_def Array.update_def)
apply (subst sublist'_update2)
apply fastforce
apply simp
done

lemma subarray_upd3: "\<lbrakk> n \<le> i; i < m\<rbrakk> \<Longrightarrow> subarray n m a (Array.update a i v h) = subarray n m a h[i - n := v]"
unfolding subarray_def Array.update_def
by (simp add: sublist'_update3)

lemma subarray_Nil: "n \<ge> m \<Longrightarrow> subarray n m a h = []"
by (simp add: subarray_def sublist'_Nil')

lemma subarray_single: "\<lbrakk> n < Array.length h a \<rbrakk> \<Longrightarrow> subarray n (Suc n) a h = [Array.get h a ! n]"
by (simp add: subarray_def length_def sublist'_single)

lemma length_subarray: "m \<le> Array.length h a \<Longrightarrow> List.length (subarray n m a h) = m - n"
by (simp add: subarray_def length_def length_sublist')

lemma length_subarray_0: "m \<le> Array.length h a \<Longrightarrow> List.length (subarray 0 m a h) = m"
by (simp add: length_subarray)

lemma subarray_nth_array_Cons: "\<lbrakk> i < Array.length h a; i < j \<rbrakk> \<Longrightarrow> (Array.get h a ! i) # subarray (Suc i) j a h = subarray i j a h"
unfolding Array.length_def subarray_def
by (simp add: sublist'_front)

lemma subarray_nth_array_back: "\<lbrakk> i < j; j \<le> Array.length h a\<rbrakk> \<Longrightarrow> subarray i j a h = subarray i (j - 1) a h @ [Array.get h a ! (j - 1)]"
unfolding Array.length_def subarray_def
by (simp add: sublist'_back)

lemma subarray_append: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow> subarray i j a h @ subarray j k a h = subarray i k a h"
unfolding subarray_def
by (simp add: sublist'_append)

lemma subarray_all: "subarray 0 (Array.length h a) a h = Array.get h a"
unfolding Array.length_def subarray_def
by (simp add: sublist'_all)

lemma nth_subarray: "\<lbrakk> k < j - i; j \<le> Array.length h a \<rbrakk> \<Longrightarrow> subarray i j a h ! k = Array.get h a ! (i + k)"
unfolding Array.length_def subarray_def
by (simp add: nth_sublist')

lemma subarray_eq_samelength_iff: "Array.length h a = Array.length h' a \<Longrightarrow> (subarray i j a h = subarray i j a h') = (\<forall>i'. i \<le> i' \<and> i' < j \<longrightarrow> Array.get h a ! i' = Array.get h' a ! i')"
unfolding Array.length_def subarray_def by (rule sublist'_eq_samelength_iff)

lemma all_in_set_subarray_conv: "(\<forall>j. j \<in> set (subarray l r a h) \<longrightarrow> P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < Array.length h a \<longrightarrow> P (Array.get h a ! k))"
unfolding subarray_def Array.length_def by (rule all_in_set_sublist'_conv)

lemma ball_in_set_subarray_conv: "(\<forall>j \<in> set (subarray l r a h). P j) = (\<forall>k. l \<le> k \<and> k < r \<and> k < Array.length h a \<longrightarrow> P (Array.get h a ! k))"
unfolding subarray_def Array.length_def by (rule ball_in_set_sublist'_conv)

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Language_Composition
imports WHATWHERE_Secure_Skip_Assign
begin

context WHATWHERE_Secure_Programs
begin

theorem Compositionality_Seq:
  assumes WWs_part1: "WHATWHERE_Secure [c1]"
  assumes WWs_part2: "WHATWHERE_Secure [c2]"
  assumes uniPPc1c2: "unique_PPc (c1;c2)"
  shows "WHATWHERE_Secure [c1;c2]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP

  from uniPPc1c2 have nocommonPP: "set (PPc c1) \<inter> set (PPc c2) = {}"
    by (simp add: unique_PPV_def unique_PPc_def)

  from WWs_part1 obtain R1' where R1'assump:
    "SdlHPPB d PP R1' \<and> ([c1],[c1]) \<in> R1'"
    by (simp add: WHATWHERE_Secure_def, auto)

  define R1 where "R1 = {(V,V'). (V,V') \<in> R1' \<and> set (PPV V) \<subseteq> set (PPc c1)
    \<and> set (PPV V') \<subseteq> set (PPc c1)}"

  from R1'assump R1_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR1: "SdlHPPB d PP R1"
    by force

  from WWs_part2 obtain R2' where R2'assump:
    "SdlHPPB d PP R2' \<and> ([c2],[c2]) \<in> R2'"
    by (simp add: WHATWHERE_Secure_def, auto)

  define R2 where "R2 = {(V,V'). (V,V') \<in> R2' \<and> set (PPV V) \<subseteq> set (PPc c2)
    \<and> set (PPV V') \<subseteq> set (PPc c2)}"

  from R2'assump R2_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR2: "SdlHPPB d PP R2"
    by force

  from nocommonPP have nocommonDomain: "Domain R1 \<inter> Domain R2 \<subseteq> {[]}"
    by (simp add: R1_def R2_def, auto,
      metis inf_greatest inf_idem le_bot unique_V_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump1: "Arefl R1 \<inter> Arefl R2 \<subseteq> {[]}"
    by force

  define R0 where "R0 = {(s1,s2). \<exists>c1 c1' c2 c2'. s1 = [c1;c2] \<and> s2 = [c1';c2'] \<and>
    ([c1],[c1']) \<in> R1 \<and> ([c2],[c2']) \<in> R2}"

  with R1_def R1'assump R2_def R2'assump
  have inR0: "([c1;c2],[c1;c2]) \<in> R0"
    by auto

  have "Domain R0 \<inter> Domain (R1 \<union> R2) = {}"
    by (simp add: R0_def R1_def R2_def, auto, metis Int_absorb1 Int_assoc Int_empty_left
      nocommonPP unique_c_uneq, metis Int_absorb Int_absorb1
      Int_assoc Int_empty_left nocommonPP unique_c_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump2: "Arefl R0 \<inter> Arefl (R1 \<union> R2) \<subseteq> {[]}"
    by force

  have disjuptoR0:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP (R1 \<union> R2) R0"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
        from Areflassump1 SdlHPPR1 SdlHPPR2 Union_Strong_dlHPP_Bisim
        show "SdlHPPB d PP (R1 \<union> R2)"
          by metis
      next
        from SdlHPPR1 have symR1: "sym R1"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPR2 have symR2: "sym R2"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        with symR1 R0_def show "sym R0"
          by (simp add: sym_def, auto)
      next
        from SdlHPPR1 have transR1: "trans R1"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        from SdlHPPR2 have transR2: "trans R2"
          by (simp add: Strong_dlHPP_Bisimulation_def)
        show "trans R0"
          proof -
            {
            fix V V' V''
            assume p1: "(V,V') \<in> R0"
            assume p2: "(V',V'') \<in> R0"
            have "(V,V'') \<in> R0"
              proof -
                from p1 R0_def obtain c1 c2 c1' c2' where p1assump:
                  "V = [c1;c2] \<and> V' = [c1';c2'] \<and>
                  ([c1],[c1']) \<in> R1 \<and> ([c2],[c2']) \<in> R2"
                  by auto
                with p2 R0_def obtain c1'' c2'' where p2assump:
                  "V'' = [c1'';c2''] \<and>
                  ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2"
                  by auto
                with p1assump transR1 transR2 have
                  trans_assump: "([c1],[c1'']) \<in> R1 \<and> ([c2],[c2'']) \<in> R2"
                  by (simp add: trans_def, blast)
                with p1assump p2assump R0_def show ?thesis
                  by auto
              qed
             }
            thus ?thesis unfolding trans_def by blast
          qed
      next
        fix V V'
        assume "(V,V') \<in> R0"
        with R0_def show "length V = length V'"
          by auto
      next
        fix V V' i
        assume inR0: "(V,V') \<in> R0"
        assume irange: "i < length V"
        assume notIDC: "\<not> IDC d (V!i) (htchLoc (pp (V!i)))"
        from inR0 R0_def obtain c1 c2 c1' c2' where VV'assump:
          "V = [c1;c2] \<and> V' = [c1';c2'] \<and>
          ([c1],[c1']) \<in> R1 \<and> ([c2],[c2']) \<in> R2"
          by auto
        have eqnextmem: "\<And>m. \<lbrakk>c1;c2\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
          proof -
            fix m
            from nextmem_exists_and_unique obtain m' where c1nextmem:
              "\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
              by force

            hence eqdir1: "\<lbrakk>c1\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            from c1nextmem obtain p \<alpha> where "\<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
              by auto

            with c1nextmem have "\<exists>p \<alpha>. \<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1;c2,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
              by (auto, metis MWLsSteps_det.seq1 MWLsSteps_det.seq2
                option.exhaust, metis MWLsSteps_det_cases(3))

            hence eqdir2: "\<lbrakk>c1;c2\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            with eqdir1 show "\<lbrakk>c1;c2\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
              by auto
          qed

        have eqpp: "pp (c1;c2) = pp c1"
          by simp
        from VV'assump SdlHPPR1 have "IDC d c1 (htchLoc (pp c1))
          \<or> NDC d c1"
          by (simp add: Strong_dlHPP_Bisimulation_def, auto)
        with eqnextmem eqpp have "IDC d (c1;c2)
          (htchLoc (pp (c1;c2))) \<or> NDC d (c1;c2)"
          by (simp add: IDC_def NDC_def)
        with inR0 irange notIDC VV'assump
        show "NDC d (V!i)"
          by (simp add: IDC_def, auto)
      next
        fix V V' m1 m1' m2 \<alpha> p i
        assume inR0: "(V,V') \<in> R0"
        assume irange: "i < length V"
        assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
        assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

        from inR0 R0_def obtain c1 c1' c2 c2' where R0pair:
          "V = [c1;c2] \<and> V' = [c1';c2'] \<and> ([c1],[c1']) \<in> R1
          \<and> ([c2],[c2']) \<in> R2"
          by auto

       from R0pair irange have i0: "i = 0" by simp

       have eqpp: "pp (c1;c2) = pp c1"
         by simp

        \<comment> \<open>get the two different cases:\<close>
        from R0pair step i0 obtain c3 where case_distinction:
          "(p = Some c2 \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>)
          \<or> (p = Some (c3;c2) \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>)"
          by (simp, insert MWLsSteps_det.simps[of "c1;c2" "m1"],
            auto)
        moreover
        \<comment> \<open>Case 1: first command terminates\<close>
        {
          assume passump: "p = Some c2"
          assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>"
          hence Vstep_case1:
            "\<langle>c1;c2,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c2,m2\<rangle>"
            by (simp add: MWLsSteps_det.seq1)

          from SdlHPPR1 StepAssump R0pair dhequal
            strongdlHPPB_aux[of "d" "PP"
            "R1" "0" "[c1]" "[c1']" "m1" "\<alpha>" "None" "m2" "m1'"]
          obtain p' \<alpha>' m2' where c1c1'reason:
            "p' = None \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and> (\<alpha>,\<alpha>') \<in> R1 \<and>
            dhequality_alternative d PP (pp c1) m2 m2'"
            by (simp add: stepResultsinR_def, fastforce)

          with eqpp c1c1'reason have conclpart:
            "\<langle>c1';c2',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some c2',m2'\<rangle> \<and>
            dhequality_alternative d PP (pp (c1;c2)) m2 m2'"
            by (auto, simp add: MWLsSteps_det.seq1)

          with passump R0pair c1c1'reason i0
          have case1_concl:
          "\<exists>p' \<alpha>' m2'.
             \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
             stepResultsinR p p' (R0 \<union> (R1 \<union> R2)) \<and>
             ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R1 \<or> (\<alpha>,\<alpha>') \<in> R2) \<and>
             dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by (simp add: stepResultsinR_def, auto)
        }
        moreover
        \<comment> \<open>Case 2: first command does not terminate\<close>
        {
          assume passump: "p = Some (c3;c2)"
          assume StepAssump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>"

          hence Vstep_case2:  "\<langle>c1;c2,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some (c3;c2),m2\<rangle>"
            by (simp add: MWLsSteps_det.seq2)

          from SdlHPPR1 StepAssump R0pair dhequal
            strongdlHPPB_aux[of "d" "PP"
            "R1" "0" "[c1]" "[c1']" "m1" "\<alpha>" "Some c3" "m2" "m1'"]
          obtain p' c3' \<alpha>' m2' where c1c1'reason:
            "p' = Some c3' \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            ([c3],[c3']) \<in> R1 \<and> (\<alpha>,\<alpha>') \<in> R1 \<and>
            dhequality_alternative d PP (pp c1) m2 m2'"
            by (simp add: stepResultsinR_def, fastforce)

          with eqpp c1c1'reason have conclpart:
            "\<langle>c1';c2',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some (c3';c2'),m2'\<rangle> \<and>
            dhequality_alternative d PP (pp (c1;c2)) m2 m2'"
            by (auto, simp add: MWLsSteps_det.seq2)

          from c1c1'reason R0pair R0_def have
            "([c3;c2],[c3';c2']) \<in> R0"
            by auto

          with R0pair conclpart passump c1c1'reason i0
          have case1_concl:
            "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> (R1 \<union> R2)) \<and>
            ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R1 \<or> (\<alpha>,\<alpha>') \<in> R2) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
            by (simp add: stepResultsinR_def, auto)
        }
        ultimately
        show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
             stepResultsinR p p' (R0 \<union> (R1 \<union> R2)) \<and>
             ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R1 \<or> (\<alpha>,\<alpha>') \<in> R2) \<and>
             dhequality_alternative d PP (pp (V!i)) m2 m2'"
          by blast
      qed

  with inR0 Areflassump2 Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> (R1 \<union> R2))"
    by auto

  with inR0 show "\<exists>R. SdlHPPB d PP R \<and> ([c1;c2],[c1;c2]) \<in> R"
    by auto

qed

theorem Compositionality_Spawn:
  assumes WWs_threads: "WHATWHERE_Secure V"
  assumes uniPPspawn: "unique_PPc (spawn\<^bsub>\<iota>\<^esub> V)"
  shows "WHATWHERE_Secure [spawn\<^bsub>\<iota>\<^esub> V]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP

  from uniPPspawn have pp_difference: "\<iota> \<notin> set (PPV V)"
    by (simp add: unique_PPc_def)

  \<comment> \<open>Step 1\<close>
  from WWs_threads obtain R' where R'assump:
    "SdlHPPB d PP R' \<and> (V,V) \<in> R'"
    by (simp add: WHATWHERE_Secure_def, auto)

  define R where "R = {(V',V''). (V',V'') \<in> R' \<and> set (PPV V') \<subseteq> set (PPV V)
    \<and> set (PPV V'') \<subseteq> set (PPV V)}"

  from R'assump R_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR: "SdlHPPB d PP R"
    by force

  \<comment> \<open>Step 2\<close>
  define R0 where "R0 = {(sp1,sp2). \<exists>\<iota>' \<iota>'' V' V''.
    sp1 = [spawn\<^bsub>\<iota>'\<^esub> V'] \<and> sp2 = [spawn\<^bsub>\<iota>''\<^esub> V'']
    \<and> \<iota>' \<notin> set (PPV V) \<and> \<iota>'' \<notin> set (PPV V) \<and> (V',V'') \<in> R}"

  with R_def R'assump pp_difference have inR0:
    "([spawn\<^bsub>\<iota>\<^esub> V],[spawn\<^bsub>\<iota>\<^esub> V]) \<in> R0"
    by auto

  \<comment> \<open>Step 3\<close>
  from R0_def R_def R'assump have "Domain R0 \<inter> Domain R = {}"
    by auto

  with commonArefl_subset_commonDomain
  have Areflassump: "Arefl R0 \<inter> Arefl R \<subseteq> {[]}"
    by force

  \<comment> \<open>Step 4\<close>
  have disjuptoR0:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP R R0"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
      from SdlHPPR show "SdlHPPB d PP R"
        by auto
    next
      from SdlHPPR have symR: "sym R"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      with R0_def show "sym R0"
        by (simp add: sym_def, auto)
    next
      from SdlHPPR have transR: "trans R"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      with R0_def show "trans R0"
        proof -
          {
          fix V1 V2 V3
          assume inR1: "(V1,V2) \<in> R0"
          assume inR2: "(V2,V3) \<in> R0"
          from inR1 R0_def obtain W W' \<iota> \<iota>' where p1: "V1 = [spawn\<^bsub>\<iota>\<^esub> W]
            \<and> V2 = [spawn\<^bsub>\<iota>'\<^esub> W'] \<and> \<iota> \<notin> set (PPV V) \<and> \<iota>' \<notin> set (PPV V)
            \<and> (W,W') \<in> R"
            by auto
          with inR2 R0_def obtain W'' \<iota>'' where p2: "V3 = [spawn\<^bsub>\<iota>''\<^esub> W'']
            \<and> \<iota>'' \<notin> set (PPV V) \<and> (W',W'') \<in> R"
            by auto
          from p1 p2 transR have "(W,W'') \<in> R"
            by (simp add: trans_def, auto)
          with p1 p2 R0_def have "(V1,V3) \<in> R0"
            by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed
    next
      fix V' V''
      from SdlHPPR have eqlenR: "(V',V'') \<in> R \<Longrightarrow> length V' = length V''"
        by (simp add: Strong_dlHPP_Bisimulation_def, auto)
      with R0_def show "(V',V'') \<in> R0 \<Longrightarrow> length V' = length V''"
        by auto
    next
      fix V' V'' i
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      from inR0 R0_def obtain \<iota>' \<iota>'' W' W''
        where R0pair: "V' = [spawn\<^bsub>\<iota>'\<^esub> W'] \<and> V'' = [spawn\<^bsub>\<iota>''\<^esub> W'']"
        by auto
      {
        fix m
        from nextmem_exists_and_unique obtain m' where spawnnextmem:
          "\<exists>p \<alpha>. \<langle>spawn\<^bsub>\<iota>'\<^esub> W',m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
          \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>spawn\<^bsub>\<iota>'\<^esub> W',m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
          by force

        hence "m = m'"
          by (metis MWLsSteps_det.spawn)

        with spawnnextmem have eqnextmem:
          "\<lbrakk>spawn\<^bsub>\<iota>'\<^esub> W'\<rbrakk>(m) = m"
          by (simp add: NextMem_def, auto)
      }

      with R0pair irange show "NDC d (V'!i)"
        by (simp add: NDC_def)
    next
      fix V' V'' i m1 m1' m2 \<alpha> p
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      assume step: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from inR0 R0_def obtain \<iota>' \<iota>'' W' W''
        where R0pair: "V' = [spawn\<^bsub>\<iota>'\<^esub> W']
        \<and> V'' = [spawn\<^bsub>\<iota>''\<^esub> W''] \<and> (W',W'') \<in> R"
        by auto

      with step irange
      have conc_step1: "\<alpha> = W' \<and> p = None \<and> m2 = m1"
        by (simp, metis MWLsSteps_det_cases(6))

      from R0pair irange
      obtain p' \<alpha>' m2' where conc_step2: "\<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle>
        \<and> p' = None \<and> \<alpha>' = W'' \<and> m2' = m1'"
        by (simp, metis MWLsSteps_det.spawn)

      with R0pair conc_step1 dhequal irange
      show "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
        by (simp add: stepResultsinR_def
          dhequality_alternative_def, auto)
    qed
  \<comment> \<open>Step 5\<close>
  with Areflassump Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> R)"
    by auto

  with inR0 show "\<exists>R. SdlHPPB d PP R \<and>
    ([spawn\<^bsub>\<iota>\<^esub> V],[spawn\<^bsub>\<iota>\<^esub> V]) \<in> R"
    by auto
qed

theorem Compositionality_If:
  assumes dind: "\<forall>d. b \<equiv>\<^bsub>d\<^esub> b"
  assumes WWs_branch1: "WHATWHERE_Secure [c1]"
  assumes WWs_branch2: "WHATWHERE_Secure [c2]"
  assumes uniPPif: "unique_PPc (if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi)"
  shows "WHATWHERE_Secure [if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP
  from uniPPif have nocommonPP: "set (PPc c1) \<inter> set (PPc c2) = {}"
    by (simp add: unique_PPc_def)

  from uniPPif have pp_difference: "\<iota> \<notin> set (PPc c1) \<union> set (PPc c2)"
    by (simp add: unique_PPc_def)

  from WWs_branch1 obtain R1' where R1'assump:
    "SdlHPPB d PP R1' \<and> ([c1],[c1]) \<in> R1'"
    by (simp add: WHATWHERE_Secure_def, auto)

  define R1 where "R1 = {(V,V'). (V,V') \<in> R1' \<and> set (PPV V) \<subseteq> set (PPc c1)
    \<and> set (PPV V') \<subseteq> set (PPc c1)}"

  from R1'assump R1_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR1: "SdlHPPB d PP R1"
    by force

  from WWs_branch2 obtain R2' where R2'assump:
    "SdlHPPB d PP R2' \<and> ([c2],[c2]) \<in> R2'"
    by (simp add: WHATWHERE_Secure_def, auto)

  define R2 where "R2 = {(V,V'). (V,V') \<in> R2' \<and> set (PPV V) \<subseteq> set (PPc c2)
    \<and> set (PPV V') \<subseteq> set (PPc c2)}"

  from R2'assump R2_def SdlHPPB_restricted_on_PP_is_SdlHPPB
  have SdlHPPR2: "SdlHPPB d PP R2"
    by force

  from nocommonPP have "Domain R1 \<inter> Domain R2 \<subseteq> {[]}"

    by (simp add: R1_def R2_def, auto,
      metis empty_subsetI inf_idem inf_mono set_eq_subset unique_V_uneq)

  with commonArefl_subset_commonDomain
  have Areflassump1: "Arefl R1 \<inter> Arefl R2 \<subseteq> {[]}"
    by force

  with SdlHPPR1 SdlHPPR2 Union_Strong_dlHPP_Bisim have SdlHPPR1R2:
    "SdlHPPB d PP (R1 \<union> R2)"
    by force

  define R where "R = (R1 \<union> R2) \<union> {([],[])}"

  define R0 where "R0 = {(i1,i2). \<exists>\<iota>' \<iota>'' b' b'' c1' c1'' c2' c2''.
    i1 = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
    \<and> i2 = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
    \<and> \<iota>' \<notin> (set (PPc c1) \<union> set (PPc c2))
    \<and> \<iota>'' \<notin> (set (PPc c1) \<union> set (PPc c2)) \<and> ([c1'],[c1'']) \<in> R1
    \<and> ([c2'],[c2'']) \<in> R2 \<and> b' \<equiv>\<^bsub>d\<^esub> b''}"

  with R_def R1_def R1'assump R2_def R2'assump pp_difference dind
  have inR0: "([if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi],[if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi]) \<in> R0"
    by auto

  from R0_def R_def R1_def R2_def
  have "Domain R0 \<inter> Domain R = {}"
    by auto

  with commonArefl_subset_commonDomain
  have Areflassump2: "Arefl R0 \<inter> Arefl R \<subseteq> {[]}"
    by force

  have disjuptoR0:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP R R0"
    proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
      from SdlHPPR1R2 adding_emptypair_keeps_SdlHPPB
      show "SdlHPPB d PP R"
        by (simp add: R_def)
    next
      from SdlHPPR1 have symR1: "sym R1"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from SdlHPPR2 have symR2: "sym R2"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from symR1 symR2 d_indistinguishable_sym R0_def show "sym R0"
        by (simp add: sym_def, fastforce)
    next
      from SdlHPPR1 have transR1: "trans R1"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from SdlHPPR2 have transR2: "trans R2"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      show "trans R0"
        proof  -
          {
            fix V' V'' V'''
            assume p1: "(V',V'') \<in> R0"
            assume p2: "(V'',V''') \<in> R0"

            from p1 R0_def obtain \<iota>' \<iota>'' b' b'' c1' c1'' c2' c2'' where
              passump1: "V' = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
              \<and> V'' = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
              \<and> \<iota>' \<notin> (set (PPc c1) \<union> set (PPc c2))
              \<and> \<iota>'' \<notin> (set (PPc c1) \<union> set (PPc c2))
              \<and> ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2
              \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
              by force

            with p2 R0_def obtain \<iota>''' b''' c1''' c2''' where
              passump2: "V''' = [if\<^bsub>\<iota>'''\<^esub> b''' then c1''' else c2''' fi]
              \<and> \<iota>''' \<notin> (set (PPc c1) \<union> set (PPc c2))
              \<and> ([c1''],[c1''']) \<in> R1 \<and> ([c2''],[c2''']) \<in> R2
              \<and> b'' \<equiv>\<^bsub>d\<^esub> b'''"
              by force

            with passump1 transR1 transR2 d_indistinguishable_trans
            have "([c1'],[c1''']) \<in> R1 \<and> ([c2'],[c2''']) \<in> R2
              \<and> b' \<equiv>\<^bsub>d\<^esub> b'''"
              by (metis transD)

            with passump1 passump2 R0_def have "(V',V''') \<in> R0"
              by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed
    next
      fix V V'
      assume inR0: "(V,V') \<in> R0"
      with R0_def show "length V = length V'" by auto
    next
      fix V' V'' i
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      assume notIDC: "\<not> IDC d (V'!i) (htchLoc (pp (V'!i)))"

      from inR0 R0_def obtain \<iota>' \<iota>'' b' b'' c1' c1'' c2' c2''
        where R0pair: "V' = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
        \<and> V'' = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
        \<and> \<iota>' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> \<iota>'' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2
        \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
        by force

      have "NDC d (if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi)"
        proof -
          {
            fix m
            from nextmem_exists_and_unique obtain m' p \<alpha> where ifnextmem:
              "\<langle>if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''.(\<exists>p \<alpha>.\<langle>if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>)
              \<longrightarrow> m'' = m')"
              by blast

            hence "m = m'"
              by (metis MWLsSteps_det.iffalse MWLsSteps_det.iftrue)

            with ifnextmem have eqnextmem:
              "\<lbrakk>if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi\<rbrakk>(m) = m"
              by (simp add: NextMem_def, auto)
          }
          thus ?thesis
            by (simp add: NDC_def)
        qed

      with R0pair irange show "NDC d (V'!i)"
        by simp
    next
      fix V' V'' i m1 m1' m2 \<alpha> p
      assume inR0: "(V',V'') \<in> R0"
      assume irange: "i < length V'"
      assume step: "\<langle>V'!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from inR0 R0_def obtain \<iota>' \<iota>'' b' b'' c1' c1'' c2' c2''
        where R0pair: "V' = [if\<^bsub>\<iota>'\<^esub> b' then c1' else c2' fi]
        \<and> V'' = [if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi]
        \<and> \<iota>' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> \<iota>'' \<notin> set (PPc c1) \<union> set (PPc c2)
        \<and> ([c1'],[c1'']) \<in> R1 \<and> ([c2'],[c2'']) \<in> R2
        \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
        by force

      with R0pair irange step have case_distinction:
        "(p = Some c1' \<and> BMap (E b' m1) = True)
        \<or> (p = Some c2' \<and> BMap (E b' m1) = False)"
        by (simp, metis MWLsSteps_det_cases(4))
      moreover
      \<comment> \<open>Case 1: b evaluates to True\<close>
      {
        assume passump: "p = Some c1'"
        assume eval: "BMap (E b' m1) = True"

        from R0pair step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
          by (simp, metis MWLs_semantics.MWLsSteps_det_cases(4))

        from eval R0pair dhequal have eval': "BMap (E b'' m1') = True"
          by (simp add: d_indistinguishable_def dH_equal_def, auto)

        hence step': "\<langle>if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd>
          \<langle>Some c1'',m1'\<rangle>"
          by (simp add: MWLsSteps_det.iftrue)

        with passump R0pair R_def dhequal stepconcl irange
        have "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
          by (simp add: stepResultsinR_def dhequality_alternative_def,
            auto)
      }
      moreover
      \<comment> \<open>Case 2: b evaluates to False\<close>
      {
        assume passump: "p = Some c2'"
        assume eval: "BMap (E b' m1) = False"

        from R0pair step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
          by (simp, metis MWLs_semantics.MWLsSteps_det_cases(4))

        from eval R0pair dhequal have eval': "BMap (E b'' m1') = False"
          by (simp add: d_indistinguishable_def dH_equal_def, auto)

        hence step': "\<langle>if\<^bsub>\<iota>''\<^esub> b'' then c1'' else c2'' fi,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd>
          \<langle>Some c2'',m1'\<rangle>"
          by (simp add: MWLsSteps_det.iffalse)

        with passump R0pair R_def dhequal stepconcl irange
        have "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
          by (simp add: stepResultsinR_def dhequality_alternative_def,
            auto)
      }
      ultimately
      show "\<exists>p' \<alpha>' m2'. \<langle>V''!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and>
        ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V'!i)) m2 m2'"
        by auto
    qed

  with Areflassump2 Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> R)"
    by auto

  with inR0 show "\<exists>R. SdlHPPB d PP R
    \<and> ([if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi],[if\<^bsub>\<iota>\<^esub> b then c1 else c2 fi]) \<in> R"
    by auto

qed

theorem Compositionality_While:
  assumes dind: "\<forall>d. b \<equiv>\<^bsub>d\<^esub> b"
  assumes WWs_body: "WHATWHERE_Secure [c]"
  assumes uniPPwhile: "unique_PPc (while\<^bsub>\<iota>\<^esub> b do c od)"
  shows "WHATWHERE_Secure [while\<^bsub>\<iota>\<^esub> b do c od]"
proof (simp add: WHATWHERE_Secure_def, auto)
  fix d PP

  from uniPPwhile have pp_difference: "\<iota> \<notin> set (PPc c)"
    by (simp add: unique_PPc_def)

  from WWs_body obtain R' where R'assump:
    "SdlHPPB d PP R' \<and> ([c],[c]) \<in> R'"
    by (simp add: WHATWHERE_Secure_def, auto)

  \<comment> \<open>add the empty pair because it is needed later in the proof\<close>
  define R where "R = {(V,V'). (V,V') \<in> R' \<and> set (PPV V) \<subseteq> set (PPc c) \<and>
    set (PPV V') \<subseteq> set (PPc c)} \<union> {([],[])}"

  with R'assump SdlHPPB_restricted_on_PP_is_SdlHPPB
    adding_emptypair_keeps_SdlHPPB
  have SdlHPPR: "SdlHPPB d PP R"
    proof -
      from R'assump SdlHPPB_restricted_on_PP_is_SdlHPPB have
        "SdlHPPB d PP
          {(V,V'). (V,V') \<in> R' \<and> set (PPV V) \<subseteq> set (PPc c) \<and>
          set (PPV V') \<subseteq> set (PPc c)}"
        by force

      with adding_emptypair_keeps_SdlHPPB have
        "SdlHPPB d PP
          ({(V,V'). (V,V') \<in> R' \<and> set (PPV V) \<subseteq> set (PPc c) \<and>
          set (PPV V') \<subseteq> set (PPc c)} \<union> {([],[])})"
        by auto

      with R_def show ?thesis
        by auto
    qed

  define R1 where "R1 = {(w1,w2). \<exists>\<iota> \<iota>' b b' c1 c1' c2 c2'.
    w1 = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
    \<and> w2 = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)]
    \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
    \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
    \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  define R2 where "R2 = {(w1,w2). \<exists>\<iota> \<iota>' b b' c1 c1'.
    w1 = [while\<^bsub>\<iota>\<^esub> b do c1 od]
    \<and> w2 = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]
    \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c) \<and>
    ([c1],[c1']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b'}"

  define R0 where "R0 = R1 \<union> R2"

  from R2_def R_def R'assump pp_difference dind
  have inR2: "([while\<^bsub>\<iota>\<^esub> b do c od],[while\<^bsub>\<iota>\<^esub> b do c od]) \<in> R2"
    by auto

  from R0_def R1_def R2_def R_def R'assump have
    "Domain R0 \<inter> Domain R = {}"
    by auto

  with commonArefl_subset_commonDomain
  have Areflassump: "Arefl R0 \<inter> Arefl R \<subseteq> {[]}"
    by force

  \<comment> \<open>show some facts about R1 and R2 needed later in the proof at several positions\<close>
  from SdlHPPR have symR: "sym R"
    by (simp add: Strong_dlHPP_Bisimulation_def)
  from symR R1_def d_indistinguishable_sym have symR1: "sym R1"
    by (simp add: sym_def, fastforce)
  from symR R2_def d_indistinguishable_sym have symR2: "sym R2"
    by (simp add: sym_def, fastforce)

  have disjuptoR1R2:
    "disj_dlHPP_Bisimulation_Up_To_R' d PP R R0"
  proof (simp add: disj_dlHPP_Bisimulation_Up_To_R'_def, auto)
      from SdlHPPR show "SdlHPPB d PP R"
        by auto
    next
      from symR1 symR2 R0_def show "sym R0"
        by (simp add: sym_def)
    next
      from SdlHPPR have transR: "trans R"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      have transR1: "trans R1"
        proof -
          {
            fix V V' V''
            assume p1: "(V,V') \<in> R1"
            assume p2: "(V',V'') \<in> R1"

            from p1 R1_def obtain \<iota> \<iota>' b b' c1 c1' c2 c2' where passump1:
              "V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
              \<and> V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)]
              \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
              \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
              \<and> b \<equiv>\<^bsub>d\<^esub> b'"
              by force

            with p2 R1_def obtain \<iota>'' b'' c1'' c2'' where passump2:
              "V'' = [c1'';(while\<^bsub>\<iota>''\<^esub> b'' do c2'' od)] \<and> \<iota>'' \<notin> set (PPc c)
              \<and> ([c1'],[c1'']) \<in> R \<and> ([c2'],[c2'']) \<in> R
              \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
              by force

            with passump1 transR d_indistinguishable_trans
            have "([c1],[c1'']) \<in> R \<and> ([c2],[c2'']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b''"
              by (metis trans_def)

            with passump1 passump2 R1_def have "(V,V'') \<in> R1"
              by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed

        have transR2: "trans R2"
         proof -
          {
            fix V V' V''
            assume p1: "(V,V') \<in> R2"
            assume p2: "(V',V'') \<in> R2"

            from p1 R2_def obtain \<iota> \<iota>' b b' c1 c1' where passump1:
              "V = [while\<^bsub>\<iota>\<^esub> b do c1 od]
              \<and> V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]
              \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
              \<and> ([c1],[c1']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b'"
              by force

            with p2 R2_def obtain \<iota>'' b'' c1'' where passump2:
              "V'' = [while\<^bsub>\<iota>''\<^esub> b'' do c1'' od] \<and> \<iota>'' \<notin> set (PPc c)
              \<and> ([c1'],[c1'']) \<in> R \<and> b' \<equiv>\<^bsub>d\<^esub> b''"
              by force

            with passump1 transR d_indistinguishable_trans
            have "([c1],[c1'']) \<in> R \<and> b \<equiv>\<^bsub>d\<^esub> b''"
              by (metis trans_def)

            with passump1 passump2 R2_def have "(V,V'') \<in> R2"
              by auto
          }
          thus ?thesis unfolding trans_def by blast
        qed

      from SdlHPPR have eqlenR: "\<forall>(V,V')\<in>R. length V = length V'"
        by (simp add: Strong_dlHPP_Bisimulation_def)
      from R1_def eqlenR have eqlenR1: "\<forall>(V,V')\<in>R1. length V = length V'"
        by auto
      from R2_def eqlenR have eqlenR2: "\<forall>(V,V')\<in>R2. length V = length V'"
        by auto

      from R1_def R2_def have "Domain R1 \<inter> Domain R2 = {}"
        by auto

      with commonArefl_subset_commonDomain have Arefl_a:
        "Arefl R1 \<inter> Arefl R2 = {}"
        by force

      with symR1 symR2 transR1 transR2 eqlenR1 eqlenR2 trans_RuR'
      have "trans (R1 \<union> R2)"
        by force
      with R0_def show "trans R0" by auto
    next
      fix V V'
      assume inR0: "(V,V') \<in> R0"
      with R0_def R1_def R2_def show "length V = length V'" by auto
    next
      fix V V' i
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume notIDC: "\<not> IDC d (V!i)
        (htchLoc (pp (V!i)))"

      from inR0 R0_def R1_def R2_def obtain \<iota> \<iota>' b b' c1 c1' c2 c2'
        where R0pair: "((V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
        \<and> V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)])
        \<or> (V = [while\<^bsub>\<iota>\<^esub> b do c1 od] \<and> V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]))
        \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
        \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
        \<and> b \<equiv>\<^bsub>d\<^esub> b'"
        by force

      with irange SdlHPPR strongdlHPPB_NDCIDCaux
      [of "d" "PP" "R" "[c1]" "[c1']" "i"]
      have c1NDCIDC:
        "NDC d c1 \<or> IDC d c1 (htchLoc (pp c1))"
        by auto

      \<comment> \<open>first alternative for V and V'\<close>
      have case1: "NDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) \<or>
        IDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))
        (htchLoc (pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))))"
        proof -
          have eqnextmem: "\<And>m. \<lbrakk>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
          proof -
            fix m
            from nextmem_exists_and_unique obtain m' where c1nextmem:
              "\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m')"
              by force

            hence eqdir1: "\<lbrakk>c1\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            from c1nextmem obtain p \<alpha> where "\<langle>c1,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>"
              by auto

            with c1nextmem have
              "\<exists>p \<alpha>. \<langle>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od),m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od),m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>)
              \<longrightarrow> m'' = m')"
              by (auto, metis MWLsSteps_det.seq1 MWLsSteps_det.seq2
                option.exhaust, metis MWLsSteps_det_cases(3))

            hence eqdir2: "\<lbrakk>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)\<rbrakk>(m) = m'"
              by (simp add: NextMem_def, auto)

            with eqdir1 show "\<lbrakk>c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)\<rbrakk>(m) = \<lbrakk>c1\<rbrakk>(m)"
              by auto
          qed

          have eqpp: "pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) = pp c1"
            by simp

          with c1NDCIDC eqnextmem show
            "NDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) \<or>
            IDC d (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))
            (htchLoc (pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od))))"
            by (simp add: IDC_def NDC_def)
        qed

      \<comment> \<open>second alternative for V V'\<close>
      have case2: "NDC d (while\<^bsub>\<iota>\<^esub> b do c1 od)"
        proof -
          {
            fix m
            from nextmem_exists_and_unique obtain m' p \<alpha>
              where whilenextmem: "\<langle>while\<^bsub>\<iota>\<^esub> b do c1 od,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m'\<rangle>
              \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>while\<^bsub>\<iota>\<^esub> b do c1 od,m\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>)
              \<longrightarrow> m'' = m')"
              by blast

            hence "m = m'"
              by (metis MWLsSteps_det.whilefalse MWLsSteps_det.whiletrue)

            with whilenextmem have eqnextmem:
              "\<lbrakk>while\<^bsub>\<iota>\<^esub> b do c1 od\<rbrakk>(m) = m"
              by (simp add: NextMem_def, auto)
          }
          thus "NDC d (while\<^bsub>\<iota>\<^esub> b do c1 od)"
            by (simp add: NDC_def)
        qed

      from R0pair case1 case2 irange notIDC
      show "NDC d (V!i)"
        by force
    next
      fix V V' i m1 m1' m2 \<alpha> p
      assume inR0: "(V,V') \<in> R0"
      assume irange: "i < length V"
      assume step: "\<langle>V!i,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>"
      assume dhequal: "m1 \<sim>\<^bsub>d,htchLocSet PP\<^esub> m1'"

      from inR0 R0_def R1_def R2_def obtain \<iota> \<iota>' b b' c1 c1' c2 c2'
        where R0pair: "((V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]
        \<and> V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)])
        \<or> (V = [while\<^bsub>\<iota>\<^esub> b do c1 od] \<and> V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]))
        \<and> \<iota> \<notin> set (PPc c) \<and> \<iota>' \<notin> set (PPc c)
        \<and> ([c1],[c1']) \<in> R \<and> ([c2],[c2']) \<in> R
        \<and> b \<equiv>\<^bsub>d\<^esub> b'"
        by force

      \<comment> \<open>Case 1: V and V' are sequential commands\<close>
      have case1: "\<lbrakk> V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)];
        V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)] \<rbrakk>
        \<Longrightarrow> \<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V!i)) m2 m2'"
        proof -
          assume Vassump: "V = [c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)]"
          assume V'assump: "V' = [c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od)]"

          have eqpp: "pp (c1;(while\<^bsub>\<iota>\<^esub> b do c2 od)) = pp c1"
            by simp

          from Vassump irange step irange obtain c3
            where case_distinction:
            "(p = Some (while\<^bsub>\<iota>\<^esub> b do c2 od) \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>)
            \<or> (p = Some (c3;(while\<^bsub>\<iota>\<^esub> b do c2 od))
            \<and> \<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>)"
            by (simp, metis MWLsSteps_det_cases(3))
          moreover
          \<comment> \<open>Case 1a: first command terminates\<close>
          {
            assume passump: "p = Some (while\<^bsub>\<iota>\<^esub> b do c2 od)"
            assume stepassump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>None,m2\<rangle>"

            with R0pair SdlHPPR dhequal
            strongdlHPPB_aux[of "d" "PP" "R"
            _ "[c1]" "[c1']" "m1" "\<alpha>" "None" "m2" "m1'"]
            obtain p' \<alpha>' m2' where c1c1'reason:
              "p' = None \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and> (\<alpha>,\<alpha>') \<in> R \<and>
              dhequality_alternative d PP (pp c1) m2 m2'"
              by (simp add: stepResultsinR_def, fastforce)

            hence conclpart:
            "\<langle>c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od),m1'\<rangle>
              \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>Some (while\<^bsub>\<iota>'\<^esub> b' do c2' od),m2'\<rangle>"
              by (auto, simp add: MWLsSteps_det.seq1)

            from R0pair R0_def R2_def have
              "([while\<^bsub>\<iota>\<^esub> b do c2 od],[while\<^bsub>\<iota>'\<^esub> b' do c2' od]) \<in> R0"
              by simp

            with passump V'assump Vassump eqpp conclpart
              c1c1'reason irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or>
              (\<alpha>,\<alpha>') \<in> R) \<and>
              dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def, auto)
          }
          moreover
          \<comment> \<open>Case 1b: first command does not terminate\<close>
          {
            assume passump: "p = Some (c3;(while\<^bsub>\<iota>\<^esub> b do c2 od))"
            assume stepassump: "\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>Some c3,m2\<rangle>"

            with R0pair SdlHPPR dhequal
            strongdlHPPB_aux[of "d" "PP" "R"
            _ "[c1]" "[c1']" "m1" "\<alpha>" "Some c3" "m2" "m1'"]
            obtain p' c3' \<alpha>' m2' where c1c1'reason:
              "p' = Some c3' \<and> \<langle>c1',m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              ([c3],[c3']) \<in> R \<and> (\<alpha>,\<alpha>') \<in> R \<and>
              dhequality_alternative d PP (pp c1) m2 m2'"
              by (simp add: stepResultsinR_def, fastforce)

            hence conclpart:
            "\<langle>c1';(while\<^bsub>\<iota>'\<^esub> b' do c2' od),m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd>
              \<langle>Some (c3';while\<^bsub>\<iota>'\<^esub> b' do c2' od),m2'\<rangle>"
              by (auto, simp add: MWLsSteps_det.seq2)

            from c1c1'reason R0pair R0_def R1_def have
              "([c3;while\<^bsub>\<iota>\<^esub> b do c2 od],[c3';while\<^bsub>\<iota>'\<^esub> b' do c2' od]) \<in> R0"
              by simp

            with passump V'assump Vassump eqpp conclpart c1c1'reason irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              stepResultsinR p p' (R0 \<union> R) \<and>
              ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
              dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def, auto)
          }
          ultimately show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
              stepResultsinR p p' (R0 \<union> R) \<and>
            ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
              dhequality_alternative d PP (pp (V!i)) m2 m2'"
            by auto
        qed

      \<comment> \<open>Case 2: V and V' are while commands\<close>
      have case2: "\<lbrakk> V = [while\<^bsub>\<iota>\<^esub> b do c1 od]; V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od] \<rbrakk>
        \<Longrightarrow> \<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V!i)) m2 m2'"
        proof -
          assume Vassump: "V = [while\<^bsub>\<iota>\<^esub> b do c1 od]"
          assume V'assump: "V' = [while\<^bsub>\<iota>'\<^esub> b' do c1' od]"

          from Vassump irange step have case_distinction:
            "(p = None \<and> BMap (E b m1) = False)
            \<or> p = (Some (c1;while\<^bsub>\<iota>\<^esub> b do c1 od)) \<and> BMap (E b m1) = True"
            by (simp, metis MWLsSteps_det_cases(5) option.simps(2))
          moreover
          \<comment> \<open>Case 2a: b evaluates to False\<close>
          {
            assume passump: "p = None"
            assume eval: "BMap (E b m1) = False"

            with Vassump step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
              by (simp, metis (no_types) MWLsSteps_det_cases(5))

            from eval R0pair dhequal have eval': "BMap (E b' m1') = False"
              by (simp add: d_indistinguishable_def dH_equal_def, auto)

            hence "\<langle>while\<^bsub>\<iota>'\<^esub> b' do c1' od,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd> \<langle>None,m1'\<rangle>"
              by (simp add: MWLsSteps_det.whilefalse)

            with passump R_def Vassump V'assump stepconcl dhequal irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def dhequality_alternative_def,
                auto)
          }
          moreover
          \<comment> \<open>Case 2b: b evaluates to True\<close>
          {
            assume passump: "p = (Some (c1;while\<^bsub>\<iota>\<^esub> b do c1 od))"
            assume eval: "BMap (E b m1) = True"

            with Vassump step irange have stepconcl: "\<alpha> = [] \<and> m2 = m1"
              by (simp, metis (no_types) MWLsSteps_det_cases(5))

            from eval R0pair dhequal have eval':
              "BMap (E b' m1') = True"
              by (simp add: d_indistinguishable_def dH_equal_def, auto)

            hence step': "\<langle>while\<^bsub>\<iota>'\<^esub> b' do c1' od,m1'\<rangle> \<rightarrow>\<lhd>[]\<rhd>
              \<langle>Some (c1';while\<^bsub>\<iota>'\<^esub> b' do c1' od),m1'\<rangle>"
              by (simp add: MWLsSteps_det.whiletrue)

            from R1_def R0pair have inR1:
              "([c1;while\<^bsub>\<iota>\<^esub> b do c1 od],[c1';while\<^bsub>\<iota>'\<^esub> b' do c1' od]) \<in> R1"
              by auto

            with step' R0_def passump R_def Vassump V'assump
              stepconcl dhequal irange
            have "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
              by (simp add: stepResultsinR_def dhequality_alternative_def,
                auto)
          }
          ultimately
          show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
            stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
            dhequality_alternative d PP (pp (V!i)) m2 m2'"
            by auto
        qed

      with case1 R0pair show "\<exists>p' \<alpha>' m2'. \<langle>V'!i,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>'\<rhd> \<langle>p',m2'\<rangle> \<and>
        stepResultsinR p p' (R0 \<union> R) \<and> ((\<alpha>,\<alpha>') \<in> R0 \<or> (\<alpha>,\<alpha>') \<in> R) \<and>
        dhequality_alternative d PP (pp (V!i)) m2 m2'"
        by auto
    qed

  with Areflassump Up_To_Technique
  have "SdlHPPB d PP (R0 \<union> R)"
    by auto

  with inR2 R0_def show "\<exists>R. SdlHPPB d PP R \<and>
    ([while\<^bsub>\<iota>\<^esub> b do c od], [while\<^bsub>\<iota>\<^esub> b do c od]) \<in> R"
    by auto
qed

end

end