theory TickTock_FL_Pri

imports
  TickTock_Max_TT1_Pri TickTock_Pri
begin

text \<open> This theory connects PriTT to PriTT1, showing PriTT is a simplification of PriTT1 \<close>
(*
"prirefTT1 pa S sa Q =
  {z. ((z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q) \<longrightarrow> (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b))
        \<and>
       ((z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick) \<longrightarrow>
          ((sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
            \<or>
           (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)))}")*)

section \<open> Preliminaries \<close>

text \<open> To understand how the definition can be simplified, we establish some auxiliary results. \<close>

lemma "{z. (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q) \<longrightarrow> (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}
        =
       {z. (z = Tock \<longrightarrow> (Q \<inter> {sa @ [[S]\<^sub>R, [Tock]\<^sub>E]}) \<subseteq> {x. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})}"
  by auto

lemma "{z. (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q) \<longrightarrow> (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}
        =
       {z. z \<noteq> Tock \<or> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q \<or> (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}"
  by auto

text \<open> Namely, assuming Q is ttWFx-healthy allows for a significant simplification of prirefTT1. \<close>

lemma prirefTT1_alt:
  assumes "ttWFx(Q)"
  shows "prirefTT1 pa S sa Q =
      {z. z \<in> S \<or> (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}"
proof -
  have
    "prirefTT1 pa S sa Q
      =
      ({z. (z \<noteq> Tock \<or> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
        \<and>
       ((z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick) \<longrightarrow>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock))} \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    unfolding prirefTT1_def by auto
  also have "... =
     ({z. (z \<noteq> Tock \<and> ((z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tick) \<longrightarrow> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)))
          \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q) \<and> (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick))} \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. (z \<noteq> Tock \<and> ((z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick) \<longrightarrow> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)))}
      \<union> {z. (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q) \<and> (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick))}
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. ((z \<noteq> Tock \<or> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)) \<and> \<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick))
          \<or> ( sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<or> (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick)))
             \<and> (z <\<^sup>*pa Tock \<or> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q) \<and> (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick)))}

      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. ((z \<noteq> Tock \<and> \<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick))
          \<or> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q \<and> \<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick)))
          \<or> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          \<or> ((\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick)) \<and> z <\<^sup>*pa Tock)}

      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick) \<or> (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock))
           \<and>
          (z \<noteq> Tock \<or> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
          }

      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick) \<and> z \<noteq> Tock)
           \<or>
          (\<not> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick) \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          }

      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. ((z \<in> S \<or> sa @ [[z]\<^sub>E] \<notin> Q \<or> z = Tick) \<and> z \<noteq> Tock)
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
  also have "... =
     ({z. ((z \<in> S \<and> z \<noteq> Tock) \<or> (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick)
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
    by auto
   also have "... =
     ({z. ((z \<in> S \<and> z \<noteq> Tock) \<or> (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick)
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
     by auto
  also have "... =
     {z. z \<in> S \<or> (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
      }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}"
    apply auto
    using ttWFx_any_cons_end_tock assms by blast+
  then show ?thesis
    using \<open>prirefTT1 pa S sa Q = {z. (z \<noteq> Tock \<or> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q) \<and> (z \<notin> S \<and> sa @ [[z]\<^sub>E] \<in> Q \<and> z \<noteq> Tock \<and> z \<noteq> Tick \<longrightarrow> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)} \<union> {z. \<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b}\<close> by auto
qed

(* TODO: Move to TickTock_Core? *)

lemma
  assumes "TTwf(Q)"
  shows "{z. z \<in> S \<or> (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
      }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}
      =
      S \<union> {z.(sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
      }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}"
proof -
   have "{z. z \<in> S \<or> (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
      }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}
      =
     (S \<union> {z. (sa @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock) \<or> z = Tick
           \<or>
          (z = Tock \<and> sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q)
           \<or>
          (sa @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock)
          }
      \<union> {z. (\<exists>b. b \<notin> S \<and> sa @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)})"
     using assms by auto
   then show ?thesis .
 qed

section \<open> PriTT \<close>

(* PriTT defined in TickTock_Pri.thy *)

(*
lemma
  fixes s :: "'a ttobs list"
  assumes "x \<lesssim>\<^sub>C t" "TT P" "priTT p x s i P" "s \<in> P"
  shows "\<exists>s. priTT1 p x s i P \<and> s \<lesssim>\<^sub>C x"
  using assms apply (induct p x s i P rule:priTT.induct, auto)

  using priTT1.simps(1) apply blast
*)

lemma rev_induct_eq_length:
  assumes "List.length x = List.length y"
          "(P [] [])"
          "(\<And>x y xs ys. P xs ys \<Longrightarrow> List.length xs = List.length ys \<Longrightarrow> P (xs @ [x]) (ys @ [y]))"
        shows "P x y"
  using assms
  apply(simplesubst rev_rev_ident[symmetric])
  apply(subst rev_rev_ident[symmetric])
  by(rule_tac xs = "List.rev x" and ys = "List.rev y" in list_induct2, simp_all)

lemma priTT_same_length [intro]:
  assumes "priTT p x s i P"
  shows "List.length x = List.length s"
  using assms by (induct p x s i P rule:priTT.induct, auto)

lemma List_length_cons_both_imp [intro]:
  assumes "List.length (xs @ [x]) = List.length (ys @ [y])"
  shows "List.length xs = List.length ys"
  using assms by (induct xs ys rule:rev_induct_eq_length, auto)

lemma priTT_imp_eq_events:
  assumes "priTT p (xs @ [[x]\<^sub>E]) (ys @ [[y]\<^sub>E]) i P"
  shows "x = y"
  using assms
  apply (induct p xs ys i P rule:priTT.induct, auto)
  apply (metis priTT.simps(12) priTT.simps(80) priTT.simps(82) priTT.simps(9) ttevent.exhaust)
  using priTT_same_length by fastforce+

lemma priTT_imp_concat_priTT:
  assumes "priTT p (xs @ [[x1]\<^sub>E]) (ys @ [[x1a]\<^sub>E]) i P"
  shows "priTT p xs ys i P"
  using assms
  apply (induct p xs ys i P rule:priTT.induct, auto)
  apply (metis (full_types) priTT.simps(12) priTT.simps(3) priTT.simps(80) priTT_imp_eq_events subsetCE ttevent.exhaust)
  using priTT_same_length by fastforce+

lemma prirefTT_imp_prirefTT1_aux:
  assumes "R \<subseteq> S \<union> {z. z <\<^sup>*pa Tock} \<union> {z. \<exists>b. b \<notin> S \<and> s @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b}"
          "ttWFx Q" "Tock \<in> R" "s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q"
        shows "\<exists>b. b \<notin> S \<and> s @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> Tock <\<^sup>*pa b"
proof -
  have "Tock \<notin> S"
    using assms ttWFx_any_cons_end_tock TT_ttWFx by blast
  then have "Tock \<in> {z. \<exists>b. b \<notin> S \<and> s @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b}"
    using assms by blast
  then show ?thesis
    by auto
qed

lemma prirefTT_imp_prirefTT1:
  assumes "R \<subseteq> prirefTT pa s Q S" "ttWFx(Q)"
  shows "R \<subseteq> prirefTT1 pa S s Q"
  using assms unfolding prirefTT_def prirefTT1_def apply auto
  using prirefTT_imp_prirefTT1_aux by blast

lemma
  assumes "Tock \<notin> prirefTT pa s Q S" "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
  shows "Tock \<notin> prirefTT1 pa S s Q"
  using assms unfolding prirefTT_def prirefTT1_def by auto

lemma
  assumes "Tock \<in> prirefTT1 pa S s Q" "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
  shows "Tock \<in> prirefTT pa s Q S"
  using assms unfolding prirefTT_def prirefTT1_def by auto

lemma prirefTT_subset_prirefTT1:
  assumes "ttWFx(Q)"
  shows "prirefTT pa s Q S \<subseteq> prirefTT1 pa S s Q"
  using assms unfolding  prirefTT1_def prirefTT_def apply auto
  using prirefTT_imp_prirefTT1_aux by blast

lemma TT2w_union_Ref_imp:
  assumes "s @ [[S]\<^sub>R] \<in> Q" "TT2w(Q)"
  shows "s @ [[S\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R] \<in> Q"
proof -
  obtain Y where Y:"Y = {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<notin> Q)}"
    by auto
  then have "Y \<inter> {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<in> Q) \<or> (e = Tock \<and> s @ [[S]\<^sub>R, [e]\<^sub>E] \<in> Q) } = {}"
    by auto
  then have "s @ [[S\<union>Y]\<^sub>R] \<in> Q"
    using assms unfolding TT2w_def by auto
  then show ?thesis using Y
    by (metis (no_types, lifting) Collect_cong)
qed

lemma TT2w_union_Ref_Tock_imp:
  assumes "s @ [[S]\<^sub>R] \<in> Q" "TT2w(Q)"
  shows "s @ [[S\<union>{e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}]\<^sub>R] \<in> Q"
proof -
  obtain Y where Y:"Y = {e::'a ttevent. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}"
    by auto
  then have "Y \<inter> {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<in> Q) \<or> (e = Tock \<and> s @ [[S]\<^sub>R, [e]\<^sub>E] \<in> Q) } = {}"
    by auto
  then have "s @ [[S\<union>Y]\<^sub>R] \<in> Q"
    using assms unfolding TT2w_def by auto
  then show ?thesis using Y
    by (metis (no_types, lifting))
qed

lemma TT2_union_Ref_Tock_imp:
  assumes "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<in> Q" "TT2(Q)"
  shows "s @ [[S\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
proof -
  obtain Y where Y:"Y = {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<notin> Q)}"
    by auto
  then have "Y \<inter> {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<in> Q) \<or> (e = Tock \<and> s @ [[S]\<^sub>R, [e]\<^sub>E] \<in> Q) } = {}"
    by auto
  then have "s @ [[S\<union>Y]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
    using assms unfolding TT2_def by auto
  then show ?thesis using Y
    by (metis (no_types, lifting) Collect_cong)
qed

lemma TT1_Ref_Tock_subset_imp:
  assumes "s @ [[S\<union>Z]\<^sub>R, [Tock]\<^sub>E] \<in> Q" "TT1(Q)"
  shows "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
  using assms
  by (meson TT1_def sup_ge1 tt_prefix_common_concat tt_prefix_subset.simps(2) tt_prefix_subset_refl)

lemma TT1_Ref_Tock_subset_imp':
  assumes "s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q" "TT1(Q)" "Z \<subseteq> S"
  shows "s @ [[Z]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
  using assms
  by (meson TT1_def sup_ge1 tt_prefix_common_concat tt_prefix_subset.simps(2) tt_prefix_subset_refl)

text \<open> We define the following auxiliary definition, and function that inserts Tick in
       refusal sets. \<close>

definition "refTickTock S s Q == (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}
                                     \<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"

fun addRefTickTock :: "'e ttobs list \<Rightarrow> 'e ttobs list \<Rightarrow> 'e ttobs list set \<Rightarrow> 'e ttobs list" where
  "addRefTickTock [] s Q = []" |
  "addRefTickTock ([e]\<^sub>E # t) s Q = [e]\<^sub>E # (addRefTickTock t (s @ [[e]\<^sub>E]) Q)" |
  "addRefTickTock ([X]\<^sub>R # t) s Q = [refTickTock X s Q]\<^sub>R # (addRefTickTock t (s @ [[X]\<^sub>R]) Q)"

text \<open> Crucially, we can then show that prirefTT1 is a subset of prirefTT when Tick
       is added to the refusal set, and furthermore such refusal set is also in Q because
       of TT3w. \<close>

lemma prirefTT1_imp_prirefTT:
  assumes "TT(Q)" "TT3w(Q)" "s @ [[S]\<^sub>R] \<in> Q" "TT2(Q)"
  shows "prirefTT1 pa S s Q \<subseteq> prirefTT pa s Q (refTickTock S s Q) \<and> s @ [[refTickTock S s Q]\<^sub>R] \<in> Q"
proof -
  obtain J where J:"J = S\<union>{Tick}
                         \<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}
                         \<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}"
    by auto
  have prirefTT1_alt:"prirefTT1 pa S s Q =
            S \<union> {z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)} \<union> {Tick}
              \<union> {e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}
              \<union> {z. s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock}
              \<union> {z. (\<exists>b. b \<notin> S \<and> s @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}"
    using assms prirefTT1_alt by (auto simp add:TT_ttWFx prirefTT1_alt)

  have a:"S \<subseteq> prirefTT pa s Q S"
    unfolding prirefTT_def by auto

  have b:"{Tick} \<subseteq> prirefTT pa s Q (S\<union>{Tick})" "s @ [[S\<union>{Tick}]\<^sub>R] \<in> Q"
    unfolding prirefTT_def apply auto
    using assms TT3w_middle_Ref_with_Tick TT_TT1 by fastforce

  have c:  "{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)} \<subseteq> prirefTT pa s Q  (S\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)})"
       and "s @ [[S\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R] \<in> Q"
       and "s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R] \<in> Q"
    unfolding prirefTT_def apply auto
    using assms apply (simp add: TT2w_union_Ref_imp TT_TT2w)
    using assms b TT2w_union_Ref_imp TT_TT2w by fastforce

  have d:  "{e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q} \<subseteq> prirefTT pa s Q (S\<union>{e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
       and "s @ [[S\<union>{e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}]\<^sub>R] \<in> Q"
       and d1:"s @ [[J]\<^sub>R] \<in> Q"
    unfolding prirefTT_def apply auto
    using assms apply (simp add: TT2w_union_Ref_Tock_imp TT_TT2w)
    using assms c TT2w_union_Ref_Tock_imp TT_TT2w
    using \<open>s @ [[S \<union> {Tick} \<union> {z. s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock}]\<^sub>R] \<in> Q\<close> J by fastforce

  have a1:"S \<subseteq> prirefTT pa s Q  (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}\<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
    unfolding prirefTT_def by auto
  have a2:"{Tick} \<subseteq> prirefTT pa s Q (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}\<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
    unfolding prirefTT_def by auto
  have a3:"{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)} \<subseteq> prirefTT pa s Q (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}\<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
    unfolding prirefTT_def by auto
  have a4:"{e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q} \<subseteq> prirefTT pa s Q (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}\<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
    unfolding prirefTT_def apply auto
    using TT_TTwf TTwf_Refusal_imp_no_Tock assms(1) assms(3) apply blast
    using assms TT_TT1 TT1_Ref_Tock_subset_imp
    by (metis (no_types, lifting) Un_insert_right)

  have "s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}\<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}]\<^sub>R] \<in> Q"
    using TT2w_union_Ref_Tock_imp TT_TT2w \<open>s @ [[S \<union> {Tick} \<union> {z. s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock}]\<^sub>R] \<in> Q\<close> assms(1) by blast
  have a5:"{z. s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock} \<subseteq> {z. s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock}"
  proof (cases "s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q")
    case True
    then have "s @ [[S\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<in> Q"
      using TT2_union_Ref_Tock_imp assms(4) by blast
    then have "s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<in> Q"
      using TT3w_TT1_add_Tick TT_TT1 assms(1) assms(2) by fastforce
    then show ?thesis
      by blast
  next
    case False
    then show ?thesis
      by blast
  qed

  have a51: "{z. s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock}
        \<subseteq>
        prirefTT pa  s Q (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}
                                  \<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
    unfolding prirefTT_def using a5 by auto

  have a6: "{z. (\<exists>b. b \<notin> S \<and> s @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}
            \<subseteq>
            prirefTT pa s Q J"
    unfolding prirefTT_def J by auto
(*
  have a5:"{z. s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock}
            \<subseteq>
            prirefTT pa (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}
                               \<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}) s Q"
    unfolding prirefTT_def apply auto
    using TT1_Ref_Tock_subset_imp' assms d1 apply auto oops*)

  have "S \<union> {z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)} \<union> {Tick}
              \<union> {e. e = Tock \<and> s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<notin> Q}
              \<union> {z. s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q \<and> z <\<^sup>*pa Tock}
              \<union> {z. (\<exists>b. b \<notin> S \<and> s @ [[b]\<^sub>E] \<in> Q \<and> b \<noteq> Tock \<and> b \<noteq> Tick \<and> z <\<^sup>*pa b)}
        \<subseteq>
        prirefTT pa s Q (S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}
                                  \<union>{e. e = Tock \<and> s @ [[S\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> Q \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> Q})"
    using a1 a2 a3 a4 a51 a6 J by auto
  then have "prirefTT1 pa S s Q
             \<subseteq>
             prirefTT pa  s Q J"
    using prirefTT1_alt J by auto
  then have "prirefTT1 pa S s Q \<subseteq> prirefTT pa s Q J \<and> s @ [[J]\<^sub>R] \<in> Q"
    using d1 by blast
  then show ?thesis unfolding refTickTock_def using J by blast
qed

lemma prirefTT1_imp_prirefTT':
  assumes "TT(Q)" "TT3w(Q)" "s @ [[S]\<^sub>R] \<in> Q" "TT2(Q)"
  shows "prirefTT1 pa S s Q \<subseteq> prirefTT pa s Q (refTickTock S s Q)"
  using assms prirefTT1_imp_prirefTT by blast

lemma prirefTT1_imp_prirefTT'' [intro]:
  assumes "TT(Q)" "TT3w(Q)" "s @ [[S]\<^sub>R] \<in> Q" "TT2(Q)"
  shows "s @ [[refTickTock S s Q]\<^sub>R] \<in> Q"
  using assms prirefTT1_imp_prirefTT by blast

lemma TT1_Ref_Tock_imp_Ref [intro]:
  assumes "s @ [[S]\<^sub>R, [Tock]\<^sub>E] \<in> Q" "TT1(Q)"
  shows "s @ [[S]\<^sub>R] \<in> Q"
  using assms
  by (meson TT1_def order_refl tt_prefix_subset.simps(1) tt_prefix_subset.simps(2) tt_prefix_subset_same_front)

lemma prirefTT1_imp_prirefTT_noassm:
  assumes "TT(Q)" "TT3w(Q)" "TT2(Q)"
  shows "prirefTT1 pa S s Q \<subseteq> prirefTT pa s Q (refTickTock S s Q)"
proof (cases "s @ [[S]\<^sub>R] \<in> Q")
  case True
  then show ?thesis
    using assms(1) assms(2) assms(3) prirefTT1_imp_prirefTT by blast
next
  case False
  then show ?thesis
     unfolding prirefTT1_def prirefTT_def refTickTock_def apply simp_all
     using TT1_Ref_Tock_subset_imp' TT_TT1 assms(1) by blast
qed

lemma priTT_extend_both_events_eq_size_maximal_ttWF:
  assumes "priTT p xs ys s P" "ttWF (ys @ [[e\<^sub>1]\<^sub>E])" "maximal(p,e\<^sub>1)" "ttWFx_trace (ys @ [[e\<^sub>1]\<^sub>E])"
  shows "priTT p (xs @ [[e\<^sub>1]\<^sub>E]) (ys @ [[e\<^sub>1]\<^sub>E]) s P"
  using assms apply (induct p xs ys s P rule:priTT.induct, auto)
     apply (cases e\<^sub>1, auto)
  using ttWFx_trace_cons_imp_cons
     apply (smt UnE mem_Collect_eq prirefTT_def some_higher_not_maximal)
  using ttWFx_trace_cons_imp_cons ttWF.elims(2) apply auto[1]
  by (metis ttWFx_trace_cons_imp_cons ttWF.simps(4) ttWF.simps(6) ttevent.exhaust)

lemma priTT_extend_both_Ref:
  assumes "priTT p xs ys s P" "ttWF (ys @ [[S]\<^sub>R])"  "ttWFx_trace (ys @ [[S]\<^sub>R])" "R \<subseteq> prirefTT p (s @ ys) P S"
  shows "priTT p (xs @ [[R]\<^sub>R]) (ys @ [[S]\<^sub>R]) s P"
  using assms apply (induct p xs ys s P rule:priTT.induct, auto)
  by (metis ttWFx_trace_cons_imp_cons append_Nil list.exhaust ttWF.simps(4) ttWF.simps(6) ttWF.simps(8) ttWF_prefix_is_ttWF ttevent.exhaust)+

lemma prirelRef_extend_both_tock_refusal_ttWF:
  assumes "priTT p xs ys s P" "ttWF (ys @ [[S]\<^sub>R,[Tock]\<^sub>E])" "R \<subseteq> prirefTT p (s @ ys) P S" "Tock \<notin> prirefTT p (s @ ys) P S"
  shows "priTT p (xs @ [[R]\<^sub>R,[Tock]\<^sub>E]) (ys @ [[S]\<^sub>R,[Tock]\<^sub>E]) s P"
  using assms apply (induct p xs ys s P rule:priTT.induct, auto)
  by (metis append_Nil list.exhaust ttWF.simps(4) ttWF.simps(6) ttWF.simps(8) ttWF_prefix_is_ttWF ttevent.exhaust)+

lemma priTT1_imp_eq_length [intro]:
  assumes "priTT1 p xs ys i P"
  shows "List.length xs = List.length ys"
  using assms by (induct p xs ys i P rule:priTT1.induct, auto)

lemma priTT1_both_imp:
  assumes "priTT1 p (xs @ x) (ys @ y) i P" "List.length xs = List.length ys"  "ttWF y"
  shows "priTT1 p x y (i @ ys) P"
  using assms apply(induct p xs ys i P rule:priTT1.induct, auto)
  apply (cases x, auto, cases y, auto)
  apply (cases y, auto, case_tac a, auto, case_tac aa, auto)
  apply (case_tac x1, auto, case_tac x1a, auto)
  apply (case_tac x1, auto)
   apply (case_tac x1a, auto)
  by (case_tac x1, auto, case_tac x1a, auto)

lemma priTT1_concat_both_imp:
  assumes "priTT1 p (xs @ x) (ys @ y) i P" "List.length xs = List.length ys"
  shows "priTT1 p xs ys i P"
  using assms apply(induct p xs ys i P rule:priTT1.induct, auto)
  apply (cases x, auto, cases y, auto, cases y, auto)
  apply (case_tac a, auto, case_tac aa, auto)
  by (case_tac x1, auto, case_tac x1a, auto)

lemma addRefTickTock_dist_concat:
  "addRefTickTock (xs @ ys) i P = (addRefTickTock xs i P) @ (addRefTickTock ys (i @ xs) P)"
  by (induct xs i P rule:addRefTickTock.induct, auto)

lemma addRefTickTock_concat_event:
  "addRefTickTock (xs @ [[x1]\<^sub>E]) i P = (addRefTickTock xs i P) @ [[x1]\<^sub>E]"
  by (induct xs i P rule:addRefTickTock.induct, auto)

lemma Tock_notin_prirefTT1_imp_notin_prirefTT:
  assumes "Tock \<notin> prirefTT1 pa S s Q" "TT(Q)" "TT2(Q)" "TT3w(Q)"
  shows "Tock \<notin> prirefTT pa s Q (refTickTock S s Q)"
  using assms unfolding prirefTT1_def prirefTT_def refTickTock_def apply auto
  using TT2_union_Ref_Tock_imp TT3w_TT1_add_Tick TT_TT1 apply fastforce
  using ttWFx_any_cons_end_tock TT_ttWFx by blast

lemma TT2w_union_Ref_ext_imp:
  assumes "TT(P)" "TT2(P)" "TT3w(P)" "s @ [[X]\<^sub>R] @ t \<in> P"
  shows "s @ [[X\<union>{z. (s @ [[z]\<^sub>E] \<notin> P \<and> z \<noteq> Tock)}]\<^sub>R] @ t \<in> P"
proof -
  obtain Y where Y:"Y = {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<notin> P)}"
    by auto
  then have "Y \<inter> {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> s @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P) } = {}"
    by auto
  then have "s @ [[X\<union>{z. (s @ [[z]\<^sub>E] \<notin> P \<and> z \<noteq> Tock)}]\<^sub>R] @ t \<in> P"
    using assms
    by (simp add: TT2_def inf_set_def)
  then show ?thesis .
qed

lemma TT2w_union_RefTock_ext_imp:
  assumes "TT(P)" "TT2(P)" "TT3w(P)" "s @ [[X]\<^sub>R] @ t \<in> P"
  shows "s @ [[X\<union>{e. e = Tock \<and> s @ [[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R] @ t \<in> P"
proof -
  obtain Y where Y:"Y = {e::'a ttevent. e = Tock \<and> s @ [[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P}"
    by auto
  then have "Y \<inter> {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> s @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P) } = {}"
    by auto
  then have "s @ [[X\<union>{e. e = Tock \<and> s @ [[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R] @ t \<in> P"
    using assms
    by (simp add: TT2_def inf_set_def)
  then show ?thesis .
qed

lemma TT2w_union_Ref_ext_imp':
  assumes "TT(P)" "TT2(P)" "TT3w(P)" "s @ [[X]\<^sub>R,[Tock]\<^sub>E] @ t \<in> P"
  shows "s @ [[X\<union>{e. e = Tock \<and> s @ [[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R,[Tock]\<^sub>E] @ t \<in> P"
proof -
  obtain Y where Y:"Y = {e::'a ttevent. e = Tock \<and> s @ [[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P}"
    by auto
  then have "Y \<inter> {e. (e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<in> P) \<or> (e = Tock \<and> s @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P) } = {}"
    by auto
  then have "s @ [[X\<union>{e. e = Tock \<and> s @ [[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R,[Tock]\<^sub>E] @ t \<in> P"
    using assms
    by (simp add: TT2_def inf_set_def)
  then show ?thesis .
qed

lemma TT2w_union_RefTock_ext_imp':
  assumes "TT(P)" "TT2(P)" "TT3w(P)" "s @ [[X]\<^sub>R] @ t \<in> P"
  shows "s @ [[X\<union>{Tick}\<union>{e. e = Tock \<and> s @ [[X\<union>{Tick}]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R] @ t \<in> P"
proof -
  obtain J where J:"J = X\<union>{Tick}" by auto
  then have "s @ [[J]\<^sub>R] @ t \<in> P"
    using TT3w_middle_Ref_with_Tick TT_TT1 assms(1) assms(3) assms(4) by blast
  then have "s @ [[J\<union>{e. e = Tock \<and> s @ [[J]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R] @ t \<in> P"
    using TT2w_union_RefTock_ext_imp assms by auto
  then show ?thesis using J by auto
qed

lemma TT2_addRefTickTock_ext_imp:
  assumes "TT(P)" "TT2(P)" "TT3w(P)" "s @ [[X]\<^sub>R] @ t \<in> P"
  shows "s @ [[refTickTock X s P]\<^sub>R] @ t \<in> P"
proof -
  have "s @ [[X\<union>{Tick}]\<^sub>R] @ t \<in> P"
    using TT3w_middle_Ref_with_Tick TT_TT1 assms(1) assms(3) assms(4) by blast
  then have "s @ [[X\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> P \<and> z \<noteq> Tock)}]\<^sub>R] @ t \<in> P"
    using TT2w_union_Ref_ext_imp assms by blast
  then have "s @ [[X\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> P \<and> z \<noteq> Tock)}\<union>{e. e = Tock \<and> s @ [[X\<union>{Tick}\<union>{z. (s @ [[z]\<^sub>E] \<notin> P \<and> z \<noteq> Tock)}]\<^sub>R, [Tock]\<^sub>E] \<notin> P}]\<^sub>R] @ t \<in> P"
    using TT2w_union_RefTock_ext_imp assms by blast
  then have "s @ [[refTickTock X s P]\<^sub>R] @ t \<in> P"
    unfolding refTickTock_def by auto
  then show ?thesis .
qed

lemma TT2_addRefTickTock_subset_imp:
  assumes "TT1(P)" "s @ [[refTickTock X s P]\<^sub>R] @ t \<in> P"
  shows "s @ [[X]\<^sub>R] @ t \<in> P"
proof -
  have "X \<subseteq> refTickTock X s P"
    unfolding refTickTock_def by auto
  then show ?thesis
    by (metis TT1_def append.left_neutral append_Cons assms(1) assms(2) tt_prefix_common_concat tt_prefix_subset.simps(2) tt_prefix_subset_refl)
qed

lemma addRefTickTock_in:
  assumes "TT(P)" "TT2(P)" "TT3w(P)" "i @ ys \<in> P"
  shows "i @ (addRefTickTock ys i P) \<in> P"
  using assms proof (induct ys i P rule:addRefTickTock.induct)
  case (1 s Q)
  then show ?case by auto
  next
    case (2 e t s Q)
    then show ?case by auto
  next
    case (3 X t s Q)
    then have "(s @ [[X]\<^sub>R]) @ t \<in> Q"
      by auto
    then have "s @ [[X]\<^sub>R] @ (addRefTickTock t (s @ [[X]\<^sub>R]) Q) \<in> Q"
      using 3 by auto
    then have "s @ [[refTickTock X s Q]\<^sub>R] @ (addRefTickTock t (s @ [[X]\<^sub>R]) Q) \<in> Q"
      using TT2_addRefTickTock_ext_imp assms 3 by auto
    then have "(s @ addRefTickTock ([X]\<^sub>R # t) s Q) \<in> Q"
      by auto
    then show ?case by auto
  qed

lemma prirefTT_imp_prirefTT_refTickTock:
  assumes "TT(Q)" "TT2(Q)" "TT3w(Q)"
  shows "prirefTT pa (s @ [[Saa]\<^sub>R] @ sa) Q Sa \<subseteq> prirefTT pa (s @ [[refTickTock Saa s Q]\<^sub>R] @ sa) Q Sa"
  using assms unfolding prirefTT_def apply auto
  using TT2_addRefTickTock_ext_imp by fastforce+

lemma prirefTT_refTickTock_imp_prirefTT:
  assumes "TT(Q)" "TT2(Q)" "TT3w(Q)"
  shows "prirefTT pa (s @ [[refTickTock Saa s Q]\<^sub>R] @ sa) Q Sa \<subseteq> prirefTT pa (s @ [[Saa]\<^sub>R] @ sa) Q Sa"
  using assms unfolding prirefTT_def apply auto
  using TT2_addRefTickTock_subset_imp TT_TT1 by fastforce+

lemma prirefTT_eq_prirefTT_refTickTock:
  assumes "TT(Q)" "TT2(Q)" "TT3w(Q)"
  shows "prirefTT pa (s @ [[Saa]\<^sub>R] @ sa) Q Sa = prirefTT pa (s @ [[refTickTock Saa s Q]\<^sub>R] @ sa) Q Sa"
  using assms prirefTT_imp_prirefTT_refTickTock prirefTT_refTickTock_imp_prirefTT by blast

lemma Tock_notin_prirefTT1_imp_notin_prirefTT_refTickTock:
  assumes "Tock \<notin> prirefTT pa (s @ [Saa]\<^sub>R # sa) Q  Sa" "TT(Q)" "TT2(Q)" "TT3w(Q)"
  shows "Tock \<notin> prirefTT pa (s @ [refTickTock Saa s Q]\<^sub>R # sa) Q Sa"
  using assms prirefTT_eq_prirefTT_refTickTock by fastforce

lemma priTT_trace_refTickTock:
  assumes "priTT p xs ys (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q" "TT(Q)" "TT2(Q)" "TT3w(Q)"
  shows "priTT p xs ys (s @ [[refTickTock S s Q]\<^sub>R, [Tock]\<^sub>E]) Q"
  using assms apply (induct p xs ys _ Q arbitrary:S rule:priTT.induct, auto)
  using prirefTT_eq_prirefTT_refTickTock apply fastforce
  using prirefTT_eq_prirefTT_refTickTock apply fastforce
  using prirefTT_eq_prirefTT_refTickTock apply fastforce
  by (metis TT2_addRefTickTock_ext_imp append_Cons append_Nil prirefTT_eq_prirefTT_refTickTock)

lemma priTT1_imp_priTT:
  assumes "priTT1 p xs ys i P" "TT(P)" "TT2(P)" "TT3w(P)"
  shows "priTT p xs (addRefTickTock ys i P) i P"
  using assms proof (induct p xs ys _ P rule:priTT.induct, auto)
  fix pa S s Q x
  fix R::"'a ttevent set"
  assume assms: "R \<subseteq> prirefTT1 pa S s Q"
         "TT Q" "TT2 Q" "TT3w Q"
         "x \<in> R"
  show "x \<in> prirefTT pa s Q (refTickTock S s Q)"
    using assms prirefTT1_imp_prirefTT_noassm by blast
next
  fix pa aa S zz s Q x
  fix R::"'a ttevent set"
  assume assms: "priTT pa aa (addRefTickTock zz (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q) (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q"
          "R \<subseteq> prirefTT1 pa S s Q"
          "Tock \<notin> prirefTT1 pa S s Q"
         "TT Q" "TT2 Q" "TT3w Q"
         "x \<in> R"
  show "x \<in> prirefTT pa s Q (refTickTock S s Q)"
    using assms prirefTT1_imp_prirefTT_noassm by blast
next
  fix pa aa S zz s Q
  fix R::"'a ttevent set"
  assume assms: "priTT pa aa (addRefTickTock zz (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q) (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q"
          "R \<subseteq> prirefTT1 pa S s Q"
          "Tock \<notin> prirefTT1 pa S s Q"
         "TT Q" "TT2 Q" "TT3w Q"
          "Tock \<in> prirefTT pa s Q (refTickTock S s Q)"
  have "Tock \<notin> prirefTT pa s Q (refTickTock S s Q)"
    using assms Tock_notin_prirefTT1_imp_notin_prirefTT by blast
  then show "False"
    using assms by auto
next
  fix pa aa S zz s Q
  fix R::"'a ttevent set"
  assume assms: "priTT pa aa (addRefTickTock zz (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q) (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q"
          "R \<subseteq> prirefTT1 pa S s Q"
          "Tock \<notin> prirefTT1 pa S s Q"
         "TT Q" "TT2 Q" "TT3w Q"
  then show "priTT pa aa (addRefTickTock zz (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q) (s @ [[refTickTock S s Q]\<^sub>R, [Tock]\<^sub>E]) Q"
    using priTT_trace_refTickTock
    by blast
next
  fix pa aa e\<^sub>2 zz s Q
  fix Z::"'a ttevent set"
  assume assms:
      "priTT pa aa (addRefTickTock zz (s @ [[e\<^sub>2]\<^sub>E]) Q) (s @ [[e\<^sub>2]\<^sub>E]) Q"
      "TT Q"
      "TT2 Q"
      "TT3w Q"
      "priTT1 pa aa zz (s @ [[e\<^sub>2]\<^sub>E]) Q"
      "s @ [[Z]\<^sub>R] \<in> Q"
      "\<forall>e. e \<notin> Z \<and> e \<noteq> Tock \<longrightarrow> s @ [[e]\<^sub>E] \<in> Q"
      "Tick \<in> Z"
      "e\<^sub>2 \<notin> Z" "\<forall>b. b \<in> Z \<or> \<not> e\<^sub>2 <\<^sup>*pa b" "Tock \<in> Z" "\<forall>Z. s @ [[Z]\<^sub>R] \<in> Q \<longrightarrow> e\<^sub>2 = Tick \<or> e\<^sub>2 \<in> prirefTT pa s Q Z"
  then have "priTT1 pa ([e\<^sub>2]\<^sub>E # aa) ([e\<^sub>2]\<^sub>E # zz) s Q"
    by auto
  then show "maximal(pa,e\<^sub>2)"
  proof (cases "s @ [[e\<^sub>2]\<^sub>E] \<in> Q")
    case True
    then show ?thesis
      proof (cases "e\<^sub>2 = Tick")
        case True
        then show ?thesis
          using assms(8) assms(9) by blast
      next
        case False
        then show ?thesis
          by (smt ttWFx_any_cons_end_tock TT_ttWFx True assms(10) assms(11) assms(12) assms(2) assms(6) assms(9) mem_Collect_eq prirefTT_subset_prirefTT1 prirefTT1_def subsetCE)
      qed
        case True
  next
    case False
    then show ?thesis
      using assms(11) assms(7) assms(9) by blast
  qed
next
  fix pa aa e\<^sub>2 zz s Q
  fix Z::"'a ttevent set"
  assume assms:
      "priTT pa aa (addRefTickTock zz (s @ [[e\<^sub>2]\<^sub>E]) Q) (s @ [[e\<^sub>2]\<^sub>E]) Q"
      "TT Q"
      "TT2 Q"
      "TT3w Q"
      "priTT1 pa aa zz (s @ [[e\<^sub>2]\<^sub>E]) Q"
      "s @ [[Z]\<^sub>R] \<in> Q"
      "\<forall>e. e \<notin> Z \<and> e \<noteq> Tock \<longrightarrow> s @ [[e]\<^sub>E] \<in> Q"
      "Tick \<in> Z"
      "e\<^sub>2 \<notin> Z" "\<forall>b. b \<in> Z \<or> \<not> e\<^sub>2 <\<^sup>*pa b" "s @ [[Z]\<^sub>R, [Tock]\<^sub>E] \<in> Q" "\<forall>Z. s @ [[Z]\<^sub>R] \<in> Q \<longrightarrow> e\<^sub>2 = Tick \<or> e\<^sub>2 \<in> prirefTT pa s Q Z"
  then show "maximal(pa,e\<^sub>2)"
    by (smt ttWFx_any_cons_end_tock TT_ttWFx Un_iff mem_Collect_eq prirefTT_def)
qed

lemma Tock_notin_prirefTT_imp_notin_prirefTT1:
  assumes "Tock \<notin> prirefTT pa s Q S" "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
  shows "Tock \<notin> prirefTT1 pa S s Q"
  using assms unfolding prirefTT1_def prirefTT_def by auto

lemma xx1:
  assumes
  "(\<exists>Z. s @ [[Z]\<^sub>R] \<in> Q
      \<and> (\<forall>e. (e \<notin> Z \<and> e \<noteq> Tock) \<longrightarrow> s @ [[e]\<^sub>E] \<in> Q)
      \<and> (Tock \<notin> Z \<longrightarrow> s @ [[Z]\<^sub>R,[Tock]\<^sub>E] \<in> Q) \<and> Tick \<in> Z
      \<and> e\<^sub>2 \<notin> Z \<and> \<not>(\<exists>b. b \<notin> Z \<and> e\<^sub>2 <\<^sup>*p b))" "ttWFx(Q)"
  shows "(\<exists>Z. s @ [[Z]\<^sub>R] \<in> Q \<and> e\<^sub>2 \<noteq> Tick \<and> e\<^sub>2 \<notin> prirefTT p s Q Z)"
  using assms apply auto
  unfolding prirefTT_def apply auto
  using ttWFx_any_cons_end_tock by blast+

lemma priTT_imp_priTT1:
  assumes "priTT p xs ys i P" "TT(P)" "TT2(P)" "TT3w(P)" "i @ ys \<in> P"
  shows "priTT1 p xs ys i P"
  using assms proof (induct p xs ys i P rule:priTT1.induct, auto)
  fix pa S s Q x
  fix R::"'a ttevent set"
  assume "R \<subseteq> prirefTT pa s Q S"
       "TT Q"
       "TT2 Q"
       "TT3w Q" "s @ [[S]\<^sub>R] \<in> Q" "x \<in> R"
  then show "x \<in> prirefTT1 pa S s Q"
    using TT_ttWFx prirefTT_imp_prirefTT1 by blast
next
  fix pa aa S zz s Q x
  fix R::"'a ttevent set"
  assume "priTT1 pa aa zz (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q"
       "TT Q"
       "TT2 Q"
       "TT3w Q"
       "s @ [S]\<^sub>R # [Tock]\<^sub>E # zz \<in> Q"
       "R \<subseteq> prirefTT pa s Q S" "x \<in> R"
  then show "x \<in> prirefTT1 pa S s Q"
    using TT_ttWFx prirefTT_imp_prirefTT1 by blast
next
  fix pa aa zz s Q
  fix S R::"'a ttevent set"
  assume assm:"priTT1 pa aa zz (s @ [[S]\<^sub>R, [Tock]\<^sub>E]) Q"
       "TT Q"
       "TT2 Q"
       "TT3w Q"
       "s @ [S]\<^sub>R # [Tock]\<^sub>E # zz \<in> Q"
       "Tock \<notin> prirefTT pa s Q S"
       "Tock \<in> prirefTT1 pa S s Q"
  then have "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<lesssim>\<^sub>C s @ [S]\<^sub>R # [Tock]\<^sub>E # zz"
    by (metis Cons_eq_appendI append_eq_appendI self_append_conv2 tt_prefix_subset_front tt_prefix_subset_refl)
  then have "s @ [[S]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
    using assm TT1_def TT_TT1 by blast
  then have "Tock \<notin> prirefTT1 pa S s Q"
    using assm Tock_notin_prirefTT_imp_notin_prirefTT1 by blast
  then show "False"
    using assm by auto
next
  fix pa aa zz s Q
  fix e\<^sub>2::"'a ttevent"
  fix Z::"'a ttevent set"
  assume assms:
    "priTT1 pa aa zz (s @ [[e\<^sub>2]\<^sub>E]) Q"
    "TT Q"
    "TT2 Q"
    "TT3w Q"
    "s @ [e\<^sub>2]\<^sub>E # zz \<in> Q"
    "priTT pa aa zz (s @ [[e\<^sub>2]\<^sub>E]) Q"
    "s @ [[Z]\<^sub>R] \<in> Q"
    "e\<^sub>2 \<noteq> Tick" "e\<^sub>2 \<notin> prirefTT pa s Q Z"
    "\<forall>Z. Tick \<in> Z \<longrightarrow>
      s @ [[Z]\<^sub>R] \<in> Q \<longrightarrow>
        (\<exists>e. e \<notin> Z \<and> e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<notin> Q) \<or> Tock \<notin> Z \<and> s @ [[Z]\<^sub>R, [Tock]\<^sub>E] \<notin> Q \<or> e\<^sub>2 \<in> Z \<or> (\<exists>b. b \<notin> Z \<and> e\<^sub>2 <\<^sup>*pa b)"
  then have s_e2_in:"s @ [[e\<^sub>2]\<^sub>E] \<in> Q"
    by (meson TT1_def TT_TT1 tt_prefix_common_concat tt_prefix_subset.simps(1) tt_prefix_subset.simps(3))
  then show "maximal(pa,e\<^sub>2)"
  proof (cases e\<^sub>2)
    case (Event x1)
    have a:"s @ [[refTickTock Z s Q]\<^sub>R] \<in> Q"
      by (simp add: assms(2) assms(3) assms(4) assms(7) prirefTT1_imp_prirefTT'')
    have b:"Tick \<in> refTickTock Z s Q"
      unfolding refTickTock_def by auto
    have c:"\<not>(\<exists>e. e \<notin> refTickTock Z s Q \<and> e \<noteq> Tock \<and> s @ [[e]\<^sub>E] \<notin> Q)"
      using refTickTock_def by fastforce
    have d:"(Tock \<in> refTickTock Z s Q \<or> s @ [[refTickTock Z s Q]\<^sub>R, [Tock]\<^sub>E] \<in> Q)"
      by (simp add: refTickTock_def)
    have e:"Event x1 \<notin> refTickTock Z s Q"
      using s_e2_in assms
      by (simp add: Event prirefTT_def refTickTock_def)
    have f:"\<not> (\<exists>b. b \<notin> refTickTock Z s Q \<and> e\<^sub>2 <\<^sup>*pa b)" (* TODO: ugly proof steps, redo *)
      unfolding refTickTock_def apply auto
      using assms apply (smt UnCI mem_Collect_eq prirefTT_def)
      using assms apply (smt TT_TTwf TTwf_Refusal_imp_no_Tock UnCI mem_Collect_eq prirefTT_def)
      using assms by (metis (mono_tags, lifting) TT1_Ref_Tock_subset_imp TT_TT1 UnCI Un_insert_right mem_Collect_eq prirefTT_def)
    then show ?thesis using a b c d e f
      using Event assms(10) by blast
  next
    case Tock
    then show ?thesis
    using TT_TTwf TTwf_Refusal_imp_no_Tock s_e2_in assms(2) assms(7) by auto
  next
    case Tick
    then show ?thesis using assms(8) by blast
  qed
qed

lemma PriTT_eq_priTT:
  assumes "TT(P)" "TT2(P)" "TT3w(P)"
  shows "PriTT p P = PriTT1 p P"
  using assms unfolding PriTT_def PriTT1_def apply auto
  using priTT_imp_priTT1 apply fastforce
  by (metis addRefTickTock_in append_Nil priTT1_imp_priTT)

lemma TT1_PriTT:
  assumes "TT(P)" "TT2(P)" "TT3w(P)"
  shows "TT1(PriTT p P)"
  using assms
  by (metis PriTT_eq_priTT TT1_mkTT1 TT3w_TT1_imp_TT3ww TT_TT1 TT_ttWFx mkTT1_PriMax_unTT1_priTT)

lemma TT_priTT1_closure:
  assumes "TT P" "TT2 P" "TT3w P"
  shows "TTwf(PriTT1 p P)"
        "TT0(PriTT1 p P)"
        "TT1(PriTT1 p P)"
        "TT2(PriTT1 p P)"
        "ttWFx(PriTT1 p P)"
        "TT3w(PriTT1 p P)"
proof -
  have TTMax:
       "TT0 (unTT1 P)"
       "TTwf (unTT1 P)"
       "TT1w (unTT1 P)"
       "TT2 (unTT1 P)"
       "ttWFx (unTT1 P)"
       "TT3w (unTT1 P)"
       "TTM1 (unTT1 P)"
       "TTM2 (unTT1 P)"
       "TTM3 (unTT1 P)"
    using assms unTT1_TT_closure by blast+

  have PriTT1_eq:"PriTT1 p P = mkTT1 (PriMax p (unTT1 P))"
    by (simp add: TT3w_TT1_imp_TT3ww TT_TT1 TT_ttWFx assms mkTT1_PriMax_unTT1_priTT)

  show "TTwf(PriTT1 p P)"
    using PriTT1_eq TTMax unTT1_TT_closure
    by (simp add: TTMax_PriMax_closure(1) TTwf_mkTT1)

  show "TT0(PriTT1 p P)"
    using PriTT1_eq TTMax_PriMax_closure unTT1_TT_closure
    by (metis TT0_mkTT1 assms(1) assms(2) assms(3))

  show "TT1(PriTT1 p P)"
    using PriTT1_eq TTMax unTT1_TT_closure
    by (simp add: TT1_mkTT1)

  show "TT2(PriTT1 p P)"
    using PriTT1_eq TTMax unTT1_TT_closure
    by (simp add: TT2_mkTT1 TTMax_PriMax_closure(3) TTMax_PriMax_closure(4) TTMax_PriMax_closure(7) TTMax_PriMax_closure(8))

  show "ttWFx(PriTT1 p P)"
    using PriTT1_eq TTMax unTT1_TT_closure
    by (simp add: ttWFx_mkTT1 TTMax_PriMax_closure(5))

  show "TT3w(PriTT1 p P)"
    using PriTT1_eq TTMax unTT1_TT_closure
    by (simp add: TT3w_mkTT1 TTMax_PriMax_closure(6))
qed

lemma TT_priTT_closure:
  assumes "TT P" "TT2 P" "TT3w P"
  shows "TTwf(PriTT p P)"
        "TT0(PriTT p P)"
        "TT1(PriTT p P)"
        "TT2(PriTT p P)"
        "ttWFx(PriTT p P)"
        "TT3w(PriTT p P)"
proof -
  have "PriTT p P = PriTT1 p P"
    using assms PriTT_eq_priTT by blast
  then show
        "TTwf(PriTT p P)"
        "TT0(PriTT p P)"
        "TT1(PriTT p P)"
        "TT2(PriTT p P)"
        "ttWFx(PriTT p P)"
        "TT3w(PriTT p P)"
  using assms TT_priTT1_closure
  by (simp_all add: TT_priTT1_closure)
qed

lemma not_Tock_notin_refTickTock_imp_possible [elim]:
  assumes "s @ [[Z]\<^sub>R] \<in> Q" "TT2(Q)" "TT3w(Q)" "e \<noteq> Tock"
          "e \<notin> refTickTock Z s Q"
    shows "s @ [[e]\<^sub>E] \<in> Q"
  using assms unfolding refTickTock_def by auto

lemma Tock_notin_refTickTock_imp_possible [elim]:
  assumes "s @ [[Z]\<^sub>R] \<in> Q" "TT(Q)" "TT2(Q)" "TT3w(Q)"
          "Tock \<notin> refTickTock Z s Q"
    shows "s @ [[Z]\<^sub>R,[Tock]\<^sub>E] \<in> Q"
  using assms unfolding refTickTock_def apply auto
  using TT1_Ref_Tock_subset_imp' TT_TT1 by blast

lemma
  assumes "(\<exists>Z. s @ [[Z]\<^sub>R] \<in> Q \<and> e\<^sub>2 \<noteq> Tick \<and> e\<^sub>2 \<notin> prirefTT p s Q Z)" "TT(Q)" "ttWFx(Q)" "TT2(Q)" "TT3w(Q)" "s @ [[e\<^sub>2]\<^sub>E] \<in> Q"
  shows   "(\<exists>Z. s @ [[Z]\<^sub>R] \<in> Q
      \<and> (\<forall>e. (e \<notin> Z \<and> e \<noteq> Tock) \<longrightarrow> s @ [[e]\<^sub>E] \<in> Q)
      \<and> (Tock \<notin> Z \<longrightarrow> s @ [[Z]\<^sub>R,[Tock]\<^sub>E] \<in> Q) \<and> Tick \<in> Z
      \<and> e\<^sub>2 \<notin> Z \<and> \<not>(\<exists>b. b \<notin> Z \<and> e\<^sub>2 <\<^sup>*p b))"
  using assms apply auto
  apply (rule_tac x="refTickTock Z s Q" in exI, auto)
     apply (simp add: refTickTock_def)
    apply (simp add: refTickTock_def)
    unfolding refTickTock_def prirefTT_def apply auto
    using TT_TTwf TTwf_Refusal_imp_no_Tock apply blast
  using TT_TTwf TTwf_Refusal_imp_no_Tock apply blast
  using TT1_Ref_Tock_subset_imp' TT_TT1 by blast+

lemma
  assumes "(\<exists>Z. s @ [[Z]\<^sub>R] \<in> Q \<and> e\<^sub>2 \<noteq> Tick \<and> e\<^sub>2 \<notin> prirefTT p s Q Z)" "TT(Q)" "ttWFx(Q)" "TT2(Q)" "TT3w(Q)" "s @ [[e\<^sub>2]\<^sub>E] \<in> Q"
  shows "(\<exists>Z. s @ [[Z]\<^sub>R] \<in> Q \<and> Tick \<in> Z \<and> e\<^sub>2 \<notin> prirefTT p s Q Z)"
  using assms apply auto
  apply (rule_tac x="Z \<union> {Tick}" in exI, auto)
  using TT3w_TT1_add_Tick TT_TT1 apply fastforce
  unfolding refTickTock_def prirefTT_def apply auto
  using TT1_Ref_Tock_subset_imp' TT_TT1 by blast

end


theory Classes
imports Main Setup
begin

section \<open>Introduction\<close>

text \<open>
  Type classes were introduced by Wadler and Blott \<^cite>\<open>wadler89how\<close>
  into the Haskell language to allow for a reasonable implementation
  of overloading\footnote{throughout this tutorial, we are referring
  to classical Haskell 1.0 type classes, not considering later
  additions in expressiveness}.  As a canonical example, a polymorphic
  equality function \<open>eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close> which is overloaded on
  different types for \<open>\<alpha>\<close>, which is achieved by splitting
  introduction of the \<open>eq\<close> function from its overloaded
  definitions by means of \<open>class\<close> and \<open>instance\<close>
  declarations: \footnote{syntax here is a kind of isabellized
  Haskell}

  \begin{quote}

  \<^noindent> \<open>class eq where\<close> \\
  \hspace*{2ex}\<open>eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close>

  \<^medskip>\<^noindent> \<open>instance nat :: eq where\<close> \\
  \hspace*{2ex}\<open>eq 0 0 = True\<close> \\
  \hspace*{2ex}\<open>eq 0 _ = False\<close> \\
  \hspace*{2ex}\<open>eq _ 0 = False\<close> \\
  \hspace*{2ex}\<open>eq (Suc n) (Suc m) = eq n m\<close>

  \<^medskip>\<^noindent> \<open>instance (\<alpha>::eq, \<beta>::eq) pair :: eq where\<close> \\
  \hspace*{2ex}\<open>eq (x1, y1) (x2, y2) = eq x1 x2 \<and> eq y1 y2\<close>

  \<^medskip>\<^noindent> \<open>class ord extends eq where\<close> \\
  \hspace*{2ex}\<open>less_eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close> \\
  \hspace*{2ex}\<open>less :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close>

  \end{quote}

  \<^noindent> Type variables are annotated with (finitely many) classes;
  these annotations are assertions that a particular polymorphic type
  provides definitions for overloaded functions.

  Indeed, type classes not only allow for simple overloading but form
  a generic calculus, an instance of order-sorted algebra
  \<^cite>\<open>"nipkow-sorts93" and "Nipkow-Prehofer:1993" and "Wenzel:1997:TPHOL"\<close>.

  From a software engineering point of view, type classes roughly
  correspond to interfaces in object-oriented languages like Java; so,
  it is naturally desirable that type classes do not only provide
  functions (class parameters) but also state specifications
  implementations must obey.  For example, the \<open>class eq\<close>
  above could be given the following specification, demanding that
  \<open>class eq\<close> is an equivalence relation obeying reflexivity,
  symmetry and transitivity:

  \begin{quote}

  \<^noindent> \<open>class eq where\<close> \\
  \hspace*{2ex}\<open>eq :: \<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool\<close> \\
  \<open>satisfying\<close> \\
  \hspace*{2ex}\<open>refl: eq x x\<close> \\
  \hspace*{2ex}\<open>sym: eq x y \<longleftrightarrow> eq x y\<close> \\
  \hspace*{2ex}\<open>trans: eq x y \<and> eq y z \<longrightarrow> eq x z\<close>

  \end{quote}

  \<^noindent> From a theoretical point of view, type classes are
  lightweight modules; Haskell type classes may be emulated by SML
  functors \<^cite>\<open>classes_modules\<close>.  Isabelle/Isar offers a discipline
  of type classes which brings all those aspects together:

  \begin{enumerate}
    \item specifying abstract parameters together with
       corresponding specifications,
    \item instantiating those abstract parameters by a particular
       type
    \item in connection with a ``less ad-hoc'' approach to overloading,
    \item with a direct link to the Isabelle module system:
      locales \<^cite>\<open>"kammueller-locales"\<close>.
  \end{enumerate}

  \<^noindent> Isar type classes also directly support code generation in
  a Haskell like fashion. Internally, they are mapped to more
  primitive Isabelle concepts \<^cite>\<open>"Haftmann-Wenzel:2006:classes"\<close>.

  This tutorial demonstrates common elements of structured
  specifications and abstract reasoning with type classes by the
  algebraic hierarchy of semigroups, monoids and groups.  Our
  background theory is that of Isabelle/HOL \<^cite>\<open>"isa-tutorial"\<close>, for
  which some familiarity is assumed.
\<close>

section \<open>A simple algebra example \label{sec:example}\<close>

subsection \<open>Class definition\<close>

text \<open>
  Depending on an arbitrary type \<open>\<alpha>\<close>, class \<open>semigroup\<close> introduces a binary operator \<open>(\<otimes>)\<close> that is
  assumed to be associative:
\<close>

class %quote semigroup =
  fixes mult :: "\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>"    (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

text \<open>
  \<^noindent> This @{command class} specification consists of two parts:
  the \qn{operational} part names the class parameter (@{element
  "fixes"}), the \qn{logical} part specifies properties on them
  (@{element "assumes"}).  The local @{element "fixes"} and @{element
  "assumes"} are lifted to the theory toplevel, yielding the global
  parameter @{term [source] "mult :: \<alpha>::semigroup \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>"} and the
  global theorem @{fact "semigroup.assoc:"}~@{prop [source] "\<And>x y z ::
  \<alpha>::semigroup. (x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"}.
\<close>

subsection \<open>Class instantiation \label{sec:class_inst}\<close>

text \<open>
  The concrete type \<^typ>\<open>int\<close> is made a \<^class>\<open>semigroup\<close> instance
  by providing a suitable definition for the class parameter \<open>(\<otimes>)\<close> and a proof for the specification of @{fact assoc}.  This is
  accomplished by the @{command instantiation} target:
\<close>

instantiation %quote int :: semigroup
begin

definition %quote
  mult_int_def: "i \<otimes> j = i + (j::int)"

instance %quote proof
  fix i j k :: int have "(i + j) + k = i + (j + k)" by simp
  then show "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
    unfolding mult_int_def .
qed

end %quote

text \<open>
  \<^noindent> @{command instantiation} defines class parameters at a
  particular instance using common specification tools (here,
  @{command definition}).  The concluding @{command instance} opens a
  proof that the given parameters actually conform to the class
  specification.  Note that the first proof step is the @{method
  standard} method, which for such instance proofs maps to the @{method
  intro_classes} method.  This reduces an instance judgement to the
  relevant primitive proof goals; typically it is the first method
  applied in an instantiation proof.

  From now on, the type-checker will consider \<^typ>\<open>int\<close> as a \<^class>\<open>semigroup\<close> automatically, i.e.\ any general results are immediately
  available on concrete instances.

  \<^medskip> Another instance of \<^class>\<open>semigroup\<close> yields the natural
  numbers:
\<close>

instantiation %quote nat :: semigroup
begin

primrec %quote mult_nat where
  "(0::nat) \<otimes> n = n"
  | "Suc m \<otimes> n = Suc (m \<otimes> n)"

instance %quote proof
  fix m n q :: nat
  show "m \<otimes> n \<otimes> q = m \<otimes> (n \<otimes> q)"
    by (induct m) auto
qed

end %quote

text \<open>
  \<^noindent> Note the occurrence of the name \<open>mult_nat\<close> in the
  primrec declaration; by default, the local name of a class operation
  \<open>f\<close> to be instantiated on type constructor \<open>\<kappa>\<close> is
  mangled as \<open>f_\<kappa>\<close>.  In case of uncertainty, these names may be
  inspected using the @{command "print_context"} command.
\<close>

subsection \<open>Lifting and parametric types\<close>

text \<open>
  Overloaded definitions given at a class instantiation may include
  recursion over the syntactic structure of types.  As a canonical
  example, we model product semigroups using our simple algebra:
\<close>

instantiation %quote prod :: (semigroup, semigroup) semigroup
begin

definition %quote
  mult_prod_def: "p\<^sub>1 \<otimes> p\<^sub>2 = (fst p\<^sub>1 \<otimes> fst p\<^sub>2, snd p\<^sub>1 \<otimes> snd p\<^sub>2)"

instance %quote proof
  fix p\<^sub>1 p\<^sub>2 p\<^sub>3 :: "\<alpha>::semigroup \<times> \<beta>::semigroup"
  show "p\<^sub>1 \<otimes> p\<^sub>2 \<otimes> p\<^sub>3 = p\<^sub>1 \<otimes> (p\<^sub>2 \<otimes> p\<^sub>3)"
    unfolding mult_prod_def by (simp add: assoc)
qed

end %quote

text \<open>
  \<^noindent> Associativity of product semigroups is established using
  the definition of \<open>(\<otimes>)\<close> on products and the hypothetical
  associativity of the type components; these hypotheses are
  legitimate due to the \<^class>\<open>semigroup\<close> constraints imposed on the
  type components by the @{command instance} proposition.  Indeed,
  this pattern often occurs with parametric types and type classes.
\<close>

subsection \<open>Subclassing\<close>

text \<open>
  We define a subclass \<open>monoidl\<close> (a semigroup with a left-hand
  neutral) by extending \<^class>\<open>semigroup\<close> with one additional
  parameter \<open>neutral\<close> together with its characteristic property:
\<close>

class %quote monoidl = semigroup +
  fixes neutral :: "\<alpha>" ("\<one>")
  assumes neutl: "\<one> \<otimes> x = x"

text \<open>
  \<^noindent> Again, we prove some instances, by providing suitable
  parameter definitions and proofs for the additional specifications.
  Observe that instantiations for types with the same arity may be
  simultaneous:
\<close>

instantiation %quote nat and int :: monoidl
begin

definition %quote
  neutral_nat_def: "\<one> = (0::nat)"

definition %quote
  neutral_int_def: "\<one> = (0::int)"

instance %quote proof
  fix n :: nat
  show "\<one> \<otimes> n = n"
    unfolding neutral_nat_def by simp
next
  fix k :: int
  show "\<one> \<otimes> k = k"
    unfolding neutral_int_def mult_int_def by simp
qed

end %quote

instantiation %quote prod :: (monoidl, monoidl) monoidl
begin

definition %quote
  neutral_prod_def: "\<one> = (\<one>, \<one>)"

instance %quote proof
  fix p :: "\<alpha>::monoidl \<times> \<beta>::monoidl"
  show "\<one> \<otimes> p = p"
    unfolding neutral_prod_def mult_prod_def by (simp add: neutl)
qed

end %quote

text \<open>
  \<^noindent> Fully-fledged monoids are modelled by another subclass,
  which does not add new parameters but tightens the specification:
\<close>

class %quote monoid = monoidl +
  assumes neutr: "x \<otimes> \<one> = x"

instantiation %quote nat and int :: monoid
begin

instance %quote proof
  fix n :: nat
  show "n \<otimes> \<one> = n"
    unfolding neutral_nat_def by (induct n) simp_all
next
  fix k :: int
  show "k \<otimes> \<one> = k"
    unfolding neutral_int_def mult_int_def by simp
qed

end %quote

instantiation %quote prod :: (monoid, monoid) monoid
begin

instance %quote proof
  fix p :: "\<alpha>::monoid \<times> \<beta>::monoid"
  show "p \<otimes> \<one> = p"
    unfolding neutral_prod_def mult_prod_def by (simp add: neutr)
qed

end %quote

text \<open>
  \<^noindent> To finish our small algebra example, we add a \<open>group\<close> class with a corresponding instance:
\<close>

class %quote group = monoidl +
  fixes inverse :: "\<alpha> \<Rightarrow> \<alpha>"    ("(_\<div>)" [1000] 999)
  assumes invl: "x\<div> \<otimes> x = \<one>"

instantiation %quote int :: group
begin

definition %quote
  inverse_int_def: "i\<div> = - (i::int)"

instance %quote proof
  fix i :: int
  have "-i + i = 0" by simp
  then show "i\<div> \<otimes> i = \<one>"
    unfolding mult_int_def neutral_int_def inverse_int_def .
qed

end %quote

section \<open>Type classes as locales\<close>

subsection \<open>A look behind the scenes\<close>

text \<open>
  The example above gives an impression how Isar type classes work in
  practice.  As stated in the introduction, classes also provide a
  link to Isar's locale system.  Indeed, the logical core of a class
  is nothing other than a locale:
\<close>

class %quote idem =
  fixes f :: "\<alpha> \<Rightarrow> \<alpha>"
  assumes idem: "f (f x) = f x"

text \<open>
  \<^noindent> essentially introduces the locale
\<close> (*<*)setup %invisible \<open>Sign.add_path "foo"\<close>
(*>*)
locale %quote idem =
  fixes f :: "\<alpha> \<Rightarrow> \<alpha>"
  assumes idem: "f (f x) = f x"

text \<open>\<^noindent> together with corresponding constant(s):\<close>

consts %quote f :: "\<alpha> \<Rightarrow> \<alpha>"

text \<open>
  \<^noindent> The connection to the type system is done by means of a
  primitive type class \<open>idem\<close>, together with a corresponding
  interpretation:
\<close>

interpretation %quote idem_class:
  idem "f :: (\<alpha>::idem) \<Rightarrow> \<alpha>"
(*<*)sorry(*>*)

text \<open>
  \<^noindent> This gives you the full power of the Isabelle module system;
  conclusions in locale \<open>idem\<close> are implicitly propagated
  to class \<open>idem\<close>.
\<close> (*<*)setup %invisible \<open>Sign.parent_path\<close>
(*>*)
subsection \<open>Abstract reasoning\<close>

text \<open>
  Isabelle locales enable reasoning at a general level, while results
  are implicitly transferred to all instances.  For example, we can
  now establish the \<open>left_cancel\<close> lemma for groups, which
  states that the function \<open>(x \<otimes>)\<close> is injective:
\<close>

lemma %quote (in group) left_cancel: "x \<otimes> y = x \<otimes> z \<longleftrightarrow> y = z"
proof
  assume "x \<otimes> y = x \<otimes> z"
  then have "x\<div> \<otimes> (x \<otimes> y) = x\<div> \<otimes> (x \<otimes> z)" by simp
  then have "(x\<div> \<otimes> x) \<otimes> y = (x\<div> \<otimes> x) \<otimes> z" using assoc by simp
  then show "y = z" using neutl and invl by simp
next
  assume "y = z"
  then show "x \<otimes> y = x \<otimes> z" by simp
qed

text \<open>
  \<^noindent> Here the \qt{@{keyword "in"} \<^class>\<open>group\<close>} target
  specification indicates that the result is recorded within that
  context for later use.  This local theorem is also lifted to the
  global one @{fact "group.left_cancel:"} @{prop [source] "\<And>x y z ::
  \<alpha>::group. x \<otimes> y = x \<otimes> z \<longleftrightarrow> y = z"}.  Since type \<open>int\<close> has been
  made an instance of \<open>group\<close> before, we may refer to that
  fact as well: @{prop [source] "\<And>x y z :: int. x \<otimes> y = x \<otimes> z \<longleftrightarrow> y =
  z"}.
\<close>

subsection \<open>Derived definitions\<close>

text \<open>
  Isabelle locales are targets which support local definitions:
\<close>

primrec %quote (in monoid) pow_nat :: "nat \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" where
  "pow_nat 0 x = \<one>"
  | "pow_nat (Suc n) x = x \<otimes> pow_nat n x"

text \<open>
  \<^noindent> If the locale \<open>group\<close> is also a class, this local
  definition is propagated onto a global definition of @{term [source]
  "pow_nat :: nat \<Rightarrow> \<alpha>::monoid \<Rightarrow> \<alpha>::monoid"} with corresponding theorems

  @{thm pow_nat.simps [no_vars]}.

  \<^noindent> As you can see from this example, for local definitions
  you may use any specification tool which works together with
  locales, such as Krauss's recursive function package
  \<^cite>\<open>krauss2006\<close>.
\<close>

subsection \<open>A functor analogy\<close>

text \<open>
  We introduced Isar classes by analogy to type classes in functional
  programming; if we reconsider this in the context of what has been
  said about type classes and locales, we can drive this analogy
  further by stating that type classes essentially correspond to
  functors that have a canonical interpretation as type classes.
  There is also the possibility of other interpretations.  For
  example, \<open>list\<close>s also form a monoid with \<open>append\<close> and
  \<^term>\<open>[]\<close> as operations, but it seems inappropriate to apply to
  lists the same operations as for genuinely algebraic types.  In such
  a case, we can simply make a particular interpretation of monoids
  for lists:
\<close>

interpretation %quote list_monoid: monoid append "[]"
  proof qed auto

text \<open>
  \<^noindent> This enables us to apply facts on monoids
  to lists, e.g. @{thm list_monoid.neutl [no_vars]}.

  When using this interpretation pattern, it may also
  be appropriate to map derived definitions accordingly:
\<close>

primrec %quote replicate :: "nat \<Rightarrow> \<alpha> list \<Rightarrow> \<alpha> list" where
  "replicate 0 _ = []"
  | "replicate (Suc n) xs = xs @ replicate n xs"

interpretation %quote list_monoid: monoid append "[]" rewrites
  "monoid.pow_nat append [] = replicate"
proof -
  interpret monoid append "[]" ..
  show "monoid.pow_nat append [] = replicate"
  proof
    fix n
    show "monoid.pow_nat append [] n = replicate n"
      by (induct n) auto
  qed
qed intro_locales

text \<open>
  \<^noindent> This pattern is also helpful to reuse abstract
  specifications on the \emph{same} type.  For example, think of a
  class \<open>preorder\<close>; for type \<^typ>\<open>nat\<close>, there are at least two
  possible instances: the natural order or the order induced by the
  divides relation.  But only one of these instances can be used for
  @{command instantiation}; using the locale behind the class \<open>preorder\<close>, it is still possible to utilise the same abstract
  specification again using @{command interpretation}.
\<close>

subsection \<open>Additional subclass relations\<close>

text \<open>
  Any \<open>group\<close> is also a \<open>monoid\<close>; this can be made
  explicit by claiming an additional subclass relation, together with
  a proof of the logical difference:
\<close>

subclass %quote (in group) monoid
proof
  fix x
  from invl have "x\<div> \<otimes> x = \<one>" by simp
  with assoc [symmetric] neutl invl have "x\<div> \<otimes> (x \<otimes> \<one>) = x\<div> \<otimes> x" by simp
  with left_cancel show "x \<otimes> \<one> = x" by simp
qed

text \<open>
  The logical proof is carried out on the locale level.  Afterwards it
  is propagated to the type system, making \<open>group\<close> an instance
  of \<open>monoid\<close> by adding an additional edge to the graph of
  subclass relations (\figref{fig:subclass}).

  \begin{figure}[htbp]
   \begin{center}
     \small
     \unitlength 0.6mm
     \begin{picture}(40,60)(0,0)
       \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
       \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
       \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
       \put(40,00){\makebox(0,0){\<open>group\<close>}}
       \put(20,55){\vector(0,-1){10}}
       \put(15,35){\vector(-1,-1){10}}
       \put(25,35){\vector(1,-3){10}}
     \end{picture}
     \hspace{8em}
     \begin{picture}(40,60)(0,0)
       \put(20,60){\makebox(0,0){\<open>semigroup\<close>}}
       \put(20,40){\makebox(0,0){\<open>monoidl\<close>}}
       \put(00,20){\makebox(0,0){\<open>monoid\<close>}}
       \put(40,00){\makebox(0,0){\<open>group\<close>}}
       \put(20,55){\vector(0,-1){10}}
       \put(15,35){\vector(-1,-1){10}}
       \put(05,15){\vector(3,-1){30}}
     \end{picture}
     \caption{Subclass relationship of monoids and groups:
        before and after establishing the relationship
        \<open>group \<subseteq> monoid\<close>;  transitive edges are left out.}
     \label{fig:subclass}
   \end{center}
  \end{figure}

  For illustration, a derived definition in \<open>group\<close> using \<open>pow_nat\<close>
\<close>

definition %quote (in group) pow_int :: "int \<Rightarrow> \<alpha> \<Rightarrow> \<alpha>" where
  "pow_int k x = (if k >= 0
    then pow_nat (nat k) x
    else (pow_nat (nat (- k)) x)\<div>)"

text \<open>
  \<^noindent> yields the global definition of @{term [source] "pow_int ::
  int \<Rightarrow> \<alpha>::group \<Rightarrow> \<alpha>::group"} with the corresponding theorem @{thm
  pow_int_def [no_vars]}.
\<close>

subsection \<open>A note on syntax\<close>

text \<open>
  As a convenience, class context syntax allows references to local
  class operations and their global counterparts uniformly; type
  inference resolves ambiguities.  For example:
\<close>

context %quote semigroup
begin

term %quote "x \<otimes> y" \<comment> \<open>example 1\<close>
term %quote "(x::nat) \<otimes> y" \<comment> \<open>example 2\<close>

end  %quote

term %quote "x \<otimes> y" \<comment> \<open>example 3\<close>

text \<open>
  \<^noindent> Here in example 1, the term refers to the local class
  operation \<open>mult [\<alpha>]\<close>, whereas in example 2 the type
  constraint enforces the global class operation \<open>mult [nat]\<close>.
  In the global context in example 3, the reference is to the
  polymorphic global class operation \<open>mult [?\<alpha> :: semigroup]\<close>.
\<close>

section \<open>Further issues\<close>

subsection \<open>Type classes and code generation\<close>

text \<open>
  Turning back to the first motivation for type classes, namely
  overloading, it is obvious that overloading stemming from @{command
  class} statements and @{command instantiation} targets naturally
  maps to Haskell type classes.  The code generator framework
  \<^cite>\<open>"isabelle-codegen"\<close> takes this into account.  If the target
  language (e.g.~SML) lacks type classes, then they are implemented by
  an explicit dictionary construction.  As example, let's go back to
  the power function:
\<close>

definition %quote example :: int where
  "example = pow_int 10 (-2)"

text \<open>
  \<^noindent> This maps to Haskell as follows:
\<close>
text %quote \<open>
  @{code_stmts example (Haskell)}
\<close>

text \<open>
  \<^noindent> The code in SML has explicit dictionary passing:
\<close>
text %quote \<open>
  @{code_stmts example (SML)}
\<close>

text \<open>
  \<^noindent> In Scala, implicits are used as dictionaries:
\<close>
text %quote \<open>
  @{code_stmts example (Scala)}
\<close>

subsection \<open>Inspecting the type class universe\<close>

text \<open>
  To facilitate orientation in complex subclass structures, two
  diagnostics commands are provided:

  \begin{description}

    \item[@{command "print_classes"}] print a list of all classes
      together with associated operations etc.

    \item[@{command "class_deps"}] visualizes the subclass relation
      between all classes as a Hasse diagram.  An optional first sort argument
      constrains the set of classes to all subclasses of this sort,
      an optional second sort argument to all superclasses of this sort.

  \end{description}
\<close>

end


theory Interface_Replace
imports
  No_Spoof
  Common_Primitive_toString
  Output_Interface_Replace
begin

section\<open>Trying to connect inbound interfaces by their IP ranges\<close>
subsection\<open>Constraining Interfaces\<close>

text\<open>We keep the match on the interface but add the corresponding IP address range.\<close>

definition ipassmt_iface_constrain_srcip_mexpr
  :: "'i::len ipassignment \<Rightarrow> iface \<Rightarrow> 'i common_primitive match_expr"
where
  "ipassmt_iface_constrain_srcip_mexpr ipassmt ifce = (case ipassmt ifce of
          None \<Rightarrow> Match (IIface ifce)
        | Some ips \<Rightarrow> MatchAnd
            (Match (IIface ifce))
            (match_list_to_match_expr (map (Match \<circ> Src) (map (uncurry IpAddrNetmask) ips)))
        )"

lemma matches_ipassmt_iface_constrain_srcip_mexpr:
    "matches (common_matcher, \<alpha>) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p \<longleftrightarrow>
      (case ipassmt ifce of
            None \<Rightarrow> match_iface ifce (p_iiface p)
          | Some ips \<Rightarrow> match_iface ifce (p_iiface p) \<and> p_src p \<in> ipcidr_union_set (set ips)
          )"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_constrain_srcip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher]; fail)
next
case (Some ips)
  have "matches (common_matcher, \<alpha>) (match_list_to_match_expr (map (Match \<circ> Src \<circ> (uncurry IpAddrNetmask)) ips)) a p \<longleftrightarrow>
       (\<exists>m\<in>set ips. p_src p \<in> uncurry ipset_from_cidr m)"
       apply(simp add: match_list_to_match_expr_disjunction[symmetric]
                       match_list_matches match_simplematcher_SrcDst)
       by(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
  with Some show ?thesis
    apply(simp add: ipcidr_union_set_uncurry)
    apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def bunch_of_lemmata_about_matches)
    apply(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
    done
qed

fun iiface_constrain :: "'i::len ipassignment \<Rightarrow> 'i common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "iiface_constrain _       MatchAny = MatchAny" |
  "iiface_constrain ipassmt (Match (IIface ifce)) = ipassmt_iface_constrain_srcip_mexpr ipassmt ifce" |
  "iiface_constrain ipassmt (Match a) = Match a" |
  "iiface_constrain ipassmt (MatchNot m) = MatchNot (iiface_constrain ipassmt m)" |
  "iiface_constrain ipassmt (MatchAnd m1 m2) = MatchAnd (iiface_constrain ipassmt m1) (iiface_constrain ipassmt m2)"

context
begin
  (*helper1: used in induction case MatchNot*)
  private lemma iiface_constrain_matches_Primitive:
          "matches (common_matcher, \<alpha>) (MatchNot (iiface_constrain ipassmt (Match x))) a p = matches (common_matcher, \<alpha>) (MatchNot (Match x)) a p \<longleftrightarrow>
           matches (common_matcher, \<alpha>) (iiface_constrain ipassmt (Match x)) a p = matches (common_matcher, \<alpha>) (Match x) a p"
  proof(cases x)
  case (IIface ifce)
    have "(matches (common_matcher, \<alpha>) (MatchNot (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce)) a p = (\<not> match_iface ifce (p_iiface p))) \<longleftrightarrow>
      (matches (common_matcher, \<alpha>) (ipassmt_iface_constrain_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p))"
    proof(cases "ipassmt ifce")
    case None thus ?thesis
       apply(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
       apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def
              primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
       done
     next
     case (Some ips)
       {  fix ips
          have "matches (common_matcher, \<alpha>)
                 (MatchNot (match_list_to_match_expr (map (Match \<circ> Src \<circ> (uncurry IpAddrNetmask)) ips))) a p \<longleftrightarrow>
                 (p_src p \<notin> ipcidr_union_set (set ips))"
        apply(induction ips)
         apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry; fail)
        apply(simp add: MatchOr_MatchNot)
        apply(simp add: ipcidr_union_set_uncurry)
        apply(simp add: match_simplematcher_SrcDst_not)
        apply(thin_tac _)
        by (simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
       } note helper=this
       from Some show ?thesis
         apply(simp add: matches_ipassmt_iface_constrain_srcip_mexpr)
         apply(simp add: ipassmt_iface_constrain_srcip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
         apply(simp add: matches_DeMorgan)
         apply(simp add: helper)
         apply(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
         by blast
     qed
     with IIface show ?thesis
      by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
                   primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed(simp_all)

  (*helper2: used in induction base case*)
  private

  lemma matches_iiface_constrain:
       "normalized_nnf_match m \<Longrightarrow> ipassmt_sanity_nowildcards ipassmt \<Longrightarrow>
        (\<And>ips. ipassmt (Iface (p_iiface p)) = Some ips \<Longrightarrow> p_src p \<in> ipcidr_union_set (set ips)) \<Longrightarrow>
        matches (common_matcher, \<alpha>) (iiface_constrain ipassmt m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
    proof(induction m)
    case MatchAny thus ?case by simp
    next
    case (MatchNot m)
      hence IH: "normalized_nnf_match m \<Longrightarrow> matches (common_matcher, \<alpha>) (iiface_constrain ipassmt m) a p = matches (common_matcher, \<alpha>) m a p" by blast
      with MatchNot.prems IH show ?case by(induction m) (simp_all add: iiface_constrain_matches_Primitive)
    next
    case(Match x) thus ?case
      proof(cases x)
        case (IIface ifce) with Match show ?thesis
        using matches_ipassmt_iface_constrain_srcip_mexpr_case_Iface by fastforce
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
    qed
end

subsection\<open>Sanity checking the assumption\<close>
(* we need a good formulation of the assumption. the case stuff is so undefined for the None case \<dots>
   EX-quantor is too strong
  Also holds if EX replaced by ALL*)
lemma "(\<exists>ips. ipassmt (Iface (p_iiface p)) = Some ips \<and> p_src p \<in> ipcidr_union_set (set ips)) \<Longrightarrow>
       (case ipassmt (Iface (p_iiface p)) of Some ips \<Rightarrow> p_src p \<in> ipcidr_union_set (set ips))"
      "(case ipassmt (Iface (p_iiface p)) of Some ips \<Rightarrow> p_src p \<in> ipcidr_union_set (set ips)) \<Longrightarrow>
      (\<And>ips. ipassmt (Iface (p_iiface p)) = Some ips \<Longrightarrow> p_src p \<in> ipcidr_union_set (set ips))"
  by(cases "ipassmt (Iface (p_iiface p))",simp_all)+

text\<open>Sanity check:
      If we assume that there are no spoofed packets, spoofing protection is trivially fulfilled.\<close>
lemma "\<forall> p:: ('i::len,'pkt_ext) tagged_packet_scheme.
        Iface (p_iiface p) \<in> dom ipassmt \<longrightarrow> p_src p \<in> ipcidr_union_set (set (the (ipassmt (Iface (p_iiface p))))) \<Longrightarrow>
       no_spoofing TYPE('pkt_ext) ipassmt rs"
  apply(simp add: no_spoofing_def)
  apply(clarify)
  apply(rename_tac iface ips p)
  apply(thin_tac "_,_\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow") (*not needed*)
  apply(erule_tac x="p\<lparr>p_iiface := iface_sel iface\<rparr>" in allE)
  apply(auto)
  done

text\<open>Sanity check:
      If the firewall features spoofing protection and we look at a packet which was allowed by the firewall.
      Then the packet's src ip must be according to ipassmt. (case Some)
      We don't case about packets from an interface which are not defined in ipassmt. (case None)\<close>
lemma
  fixes p :: "('i::len,'pkt_ext) tagged_packet_scheme"
  shows "no_spoofing TYPE('pkt_ext) ipassmt rs \<Longrightarrow>
      (common_matcher, in_doubt_allow),p\<turnstile> \<langle>rs, Undecided\<rangle> \<Rightarrow>\<^sub>\<alpha> Decision FinalAllow \<Longrightarrow>
       case ipassmt (Iface (p_iiface p)) of Some ips \<Rightarrow> p_src p \<in> ipcidr_union_set (set ips) | None \<Rightarrow> True"
  apply(simp add: no_spoofing_def)
  apply(case_tac "Iface (p_iiface p) \<in> dom ipassmt")
   apply(erule_tac x="Iface (p_iiface p)" in ballE)
    apply(simp_all)
   apply(erule_tac x="p" in allE)
   apply(simp)
   apply fastforce
  by (simp add: domIff)

subsection\<open>Replacing Interfaces Completely\<close>

text\<open>This is a stricter, true rewriting since it removes the interface match completely.
      However, it requires @{const ipassmt_sanity_disjoint}\<close>

thm ipassmt_sanity_disjoint_def

definition ipassmt_iface_replace_srcip_mexpr
  :: "'i::len ipassignment \<Rightarrow> iface \<Rightarrow> 'i common_primitive match_expr" where
  "ipassmt_iface_replace_srcip_mexpr ipassmt ifce \<equiv> case ipassmt ifce of
          None \<Rightarrow> Match (IIface ifce)
        | Some ips \<Rightarrow> (match_list_to_match_expr (map (Match \<circ> Src) (map (uncurry IpAddrNetmask) ips)))"

lemma matches_ipassmt_iface_replace_srcip_mexpr:
    "matches (common_matcher, \<alpha>) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p \<longleftrightarrow> (case ipassmt ifce of
            None \<Rightarrow> match_iface ifce (p_iiface p)
          | Some ips \<Rightarrow> p_src p \<in> ipcidr_union_set (set ips)
          )"
proof(cases "ipassmt ifce")
case None thus ?thesis by(simp add: ipassmt_iface_replace_srcip_mexpr_def primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
next
case (Some ips)
  have "matches (common_matcher, \<alpha>) (match_list_to_match_expr (map (Match \<circ> Src \<circ> (uncurry IpAddrNetmask)) ips)) a p \<longleftrightarrow>
       (\<exists>m\<in>set ips. p_src p \<in> (uncurry ipset_from_cidr m))"
       by(simp add: match_list_to_match_expr_disjunction[symmetric]
                    match_list_matches match_simplematcher_SrcDst ipt_iprange_to_set_uncurry_IpAddrNetmask)
  with Some show ?thesis
    apply(simp add: ipassmt_iface_replace_srcip_mexpr_def bunch_of_lemmata_about_matches)
    apply(simp add: ipcidr_union_set_uncurry)
    done
qed

fun iiface_rewrite
  :: "'i::len ipassignment \<Rightarrow> 'i common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr"
where
  "iiface_rewrite _       MatchAny = MatchAny" |
  "iiface_rewrite ipassmt (Match (IIface ifce)) = ipassmt_iface_replace_srcip_mexpr ipassmt ifce" |
  "iiface_rewrite ipassmt (Match a) = Match a" |
  "iiface_rewrite ipassmt (MatchNot m) = MatchNot (iiface_rewrite ipassmt m)" |
  "iiface_rewrite ipassmt (MatchAnd m1 m2) = MatchAnd (iiface_rewrite ipassmt m1) (iiface_rewrite ipassmt m2)"

context
begin
  (*helper1: used in induction case MatchNot*)
  private lemma iiface_rewrite_matches_Primitive:
          "matches (common_matcher, \<alpha>) (MatchNot (iiface_rewrite ipassmt (Match x))) a p = matches (common_matcher, \<alpha>) (MatchNot (Match x)) a p \<longleftrightarrow>
           matches (common_matcher, \<alpha>) (iiface_rewrite ipassmt (Match x)) a p = matches (common_matcher, \<alpha>) (Match x) a p"
  proof(cases x)
  case (IIface ifce)
    have "(matches (common_matcher, \<alpha>) (MatchNot (ipassmt_iface_replace_srcip_mexpr ipassmt ifce)) a p = (\<not> match_iface ifce (p_iiface p))) \<longleftrightarrow>
      (matches (common_matcher, \<alpha>) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p))"
    proof(cases "ipassmt ifce")
    case None thus ?thesis
       apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
       apply(simp add: ipassmt_iface_replace_srcip_mexpr_def primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher])
       done
     next
     case (Some ips)
       {  fix ips
          have "matches (common_matcher, \<alpha>)
                 (MatchNot (match_list_to_match_expr (map (Match \<circ> Src \<circ> (uncurry IpAddrNetmask)) ips))) a p \<longleftrightarrow>
                 (p_src p \<notin> ipcidr_union_set (set ips))"
        apply(induction ips)
         apply(simp add: bunch_of_lemmata_about_matches ipcidr_union_set_uncurry)
        apply(simp add: MatchOr_MatchNot)
        apply(simp add: ipcidr_union_set_uncurry)
        apply(simp add: match_simplematcher_SrcDst_not)
        apply(thin_tac _)
        apply(simp add: ipt_iprange_to_set_uncurry_IpAddrNetmask)
        done
       } note helper=this
       from Some show ?thesis
         apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
         apply(simp add: ipassmt_iface_replace_srcip_mexpr_def)
         apply(simp add: helper)
         done
     qed
     with IIface show ?thesis
      by(simp add: primitive_matcher_generic.Iface_single_not[OF primitive_matcher_generic_common_matcher]
            primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed(simp_all)

  (*helper2: used in induction base case*)
  private lemma matches_ipassmt_iface_replace_srcip_mexpr_case_Iface:
        fixes ifce::iface
        assumes "ipassmt_sanity_nowildcards ipassmt"
            and "ipassmt_sanity_disjoint ipassmt"
            and "ipassmt (Iface (p_iiface p)) = Some p_ips \<and> p_src p \<in> ipcidr_union_set (set p_ips)"
        shows   "matches (common_matcher, \<alpha>) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p \<longleftrightarrow>
                 matches (common_matcher, \<alpha>) (Match (IIface ifce)) a p"
  proof -
    have "matches (common_matcher, \<alpha>) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p = match_iface ifce (p_iiface p)"
      proof -
        show ?thesis
        proof(cases "ipassmt ifce")
          case None thus ?thesis by(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
          next
          case (Some y) with assms(2) have "p_src p \<in> ipcidr_union_set (set y) = match_iface ifce (p_iiface p)"
            using assms(1) assms(3) ipassmt_disjoint_matcheq_iifce_srcip by blast
            with Some show ?thesis by(simp add: matches_ipassmt_iface_replace_srcip_mexpr)
        qed
    qed
    thus ?thesis by(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher])
  qed

  lemma matches_iiface_rewrite:
       "normalized_nnf_match m \<Longrightarrow> ipassmt_sanity_nowildcards ipassmt \<Longrightarrow> ipassmt_sanity_disjoint ipassmt \<Longrightarrow>
        (\<exists>p_ips. ipassmt (Iface (p_iiface p)) = Some p_ips \<and> p_src p \<in> ipcidr_union_set (set p_ips)) \<Longrightarrow>
        matches (common_matcher, \<alpha>) (iiface_rewrite ipassmt m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
    proof(induction m)
    case MatchAny thus ?case by simp
    next
    case (MatchNot m)
      hence IH: "normalized_nnf_match m \<Longrightarrow>
        matches (common_matcher, \<alpha>) (iiface_rewrite ipassmt m) a p =matches (common_matcher, \<alpha>) m a p" by blast
      with MatchNot.prems IH show ?case by(induction m) (simp_all add: iiface_rewrite_matches_Primitive)
    next
    case(Match x) thus ?case
      proof(cases x)
        case (IIface ifce) with Match show ?thesis
        apply(cases "ipassmt (Iface (p_iiface p))")
         prefer 2
          apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr_case_Iface; fail)
        by auto
      qed(simp_all)
    next
    case (MatchAnd m1 m2) thus ?case by(simp add: bunch_of_lemmata_about_matches)
    qed

end

  text\<open>Finally, we show that @{const ipassmt_sanity_disjoint} is really needed.\<close>
  lemma iface_replace_needs_ipassmt_disjoint:
    assumes "ipassmt_sanity_nowildcards ipassmt"
    and iface_replace: "\<And> ifce p:: 'i::len tagged_packet.
          (matches (common_matcher, \<alpha>) (ipassmt_iface_replace_srcip_mexpr ipassmt ifce) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) (Match (IIface ifce)) a p)"
    shows "ipassmt_sanity_disjoint ipassmt"
  unfolding ipassmt_sanity_disjoint_def
  proof(intro ballI impI)
    fix i1 i2
    assume "i1 \<in> dom ipassmt" and "i2 \<in> dom ipassmt" and "i1 \<noteq> i2"
    from \<open>i1 \<in> dom ipassmt\<close> obtain i1_ips where i1_ips: "ipassmt i1 = Some i1_ips" by blast
    from \<open>i2 \<in> dom ipassmt\<close> obtain i2_ips where i2_ips: "ipassmt i2 = Some i2_ips" by blast

    { fix p :: "'i tagged_packet"
      from iface_replace[of  i1 "p\<lparr> p_iiface := iface_sel i2\<rparr>"] have
        "(p_src p \<in> ipcidr_union_set (set i2_ips) \<Longrightarrow> (p_src p \<in> ipcidr_union_set (set i1_ips)) = match_iface i1 (iface_sel i2))"
      apply(simp add: primitive_matcher_generic.Iface_single[OF primitive_matcher_generic_common_matcher] \<open>i1 \<in> dom ipassmt\<close>)
      apply(simp add: matches_ipassmt_iface_replace_srcip_mexpr i1_ips)
      done
      with \<open>i1 \<noteq> i2\<close> have "\<not> (p_src p \<in> ipcidr_union_set (set i2_ips) \<and> (p_src p \<in> ipcidr_union_set (set i1_ips)))"
        by (metis \<open>i1 \<in> dom ipassmt\<close> assms(1) iface.exhaust_sel iface_is_wildcard_def ipassmt_sanity_nowildcards_def match_iface_case_nowildcard)
    }
    hence "\<not> (src \<in> ipcidr_union_set (set i2_ips) \<and> (src \<in> ipcidr_union_set (set i1_ips)))"
      for src
      apply(simp)
      by (metis simple_packet.select_convs(3))

    thus "ipcidr_union_set (set (the (ipassmt i1))) \<inter> ipcidr_union_set (set (the (ipassmt i2))) = {}"
      apply(simp add: i1_ips i2_ips)
      by blast
  qed

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Late_Cong_Subst_SC
  imports Weak_Late_Cong_Subst Strong_Late_Bisim_Subst_SC
begin

(******** Structural Congruence **********)

(******** The \<nu>-operator *****************)

lemma resComm:
  fixes P :: pi

  shows "<\<nu>a><\<nu>b>P \<simeq>\<^sup>s <\<nu>b><\<nu>a>P"
proof -
  have "<\<nu>a><\<nu>b>P \<sim>\<^sup>s <\<nu>b><\<nu>a>P"
    by(rule Strong_Late_Bisim_Subst_SC.resComm)
  thus ?thesis by(rule strongEqWeakCong)
qed

(******** Match *********)

lemma matchId:
  fixes a :: name
  and   P :: pi

  shows "[a\<frown>a]P \<simeq>\<^sup>s P"
proof -
  have "[a\<frown>a]P \<sim>\<^sup>s P" by(rule Strong_Late_Bisim_Subst_SC.matchId)
  thus ?thesis by(rule strongEqWeakCong)
qed

(******** Mismatch *********)

lemma matchNil:
  fixes a :: name
  and   P :: pi

  shows "[a\<noteq>a]P \<simeq>\<^sup>s \<zero>"
proof -
  have "[a\<noteq>a]P \<sim>\<^sup>s \<zero>" by(rule Strong_Late_Bisim_Subst_SC.mismatchNil)
  thus ?thesis by(rule strongEqWeakCong)
qed

(******** The +-operator *********)

lemma sumSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<oplus> Q \<simeq>\<^sup>s Q \<oplus> P"
proof -
  have "P \<oplus> Q \<sim>\<^sup>s Q \<oplus> P" by(rule Strong_Late_Bisim_Subst_SC.sumSym)
  thus ?thesis by(rule strongEqWeakCong)
qed

(******** The |-operator *********)

lemma parZero:
  fixes P :: pi

  shows "P \<parallel> \<zero> \<simeq>\<^sup>s P"
proof -
  have "P \<parallel> \<zero> \<sim>\<^sup>s P" by(rule Strong_Late_Bisim_Subst_SC.parZero)
  thus ?thesis by(rule strongEqWeakCong)
qed

lemma parSym:
  fixes P :: pi
  and   Q :: pi

  shows "P \<parallel> Q \<simeq>\<^sup>s Q \<parallel> P"
proof -
  have "P \<parallel> Q \<sim>\<^sup>s Q \<parallel> P" by(rule Strong_Late_Bisim_Subst_SC.parSym)
  thus ?thesis by(rule strongEqWeakCong)
qed

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<parallel> Q) \<simeq>\<^sup>s P \<parallel> <\<nu>x>Q"
proof -
  from assms have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sup>s P \<parallel> <\<nu>x>Q" by(rule Strong_Late_Bisim_Subst_SC.scopeExtPar)
  thus ?thesis by(rule strongEqWeakCong)
qed

lemma scopeExtPar':
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes xFreshQ: "x \<sharp> Q"

  shows "<\<nu>x>(P \<parallel> Q) \<simeq>\<^sup>s (<\<nu>x>P) \<parallel> Q"
proof -
  from assms have "<\<nu>x>(P \<parallel> Q) \<sim>\<^sup>s (<\<nu>x>P) \<parallel> Q" by(rule Strong_Late_Bisim_Subst_SC.scopeExtPar')
  thus ?thesis by(rule strongEqWeakCong)
qed

  shows "(P \<parallel> Q) \<parallel> R \<simeq>\<^sup>s P \<parallel> (Q \<parallel> R)"
proof -
  have "(P \<parallel> Q) \<parallel> R \<sim>\<^sup>s P \<parallel> (Q \<parallel> R)" by(rule Strong_Late_Bisim_Subst_SC.parAssoc)
  thus ?thesis by(rule strongEqWeakCong)
qed

  assumes aFreshP: "a \<sharp> P"

  shows "<\<nu>a>P \<simeq>\<^sup>s P"
proof -
  from assms have "<\<nu>a>P \<sim>\<^sup>s P" by(rule Strong_Late_Bisim_Subst_SC.scopeFresh)
  thus ?thesis by(rule strongEqWeakCong)
qed

lemma scopeExtSum:
  fixes P :: pi
  and   Q :: pi
  and   x :: name

  assumes "x \<sharp> P"

  shows "<\<nu>x>(P \<oplus> Q) \<simeq>\<^sup>s P \<oplus> <\<nu>x>Q"
proof -
  from assms have "<\<nu>x>(P \<oplus> Q) \<sim>\<^sup>s P \<oplus> <\<nu>x>Q" by(rule Strong_Late_Bisim_Subst_SC.scopeExtSum)
  thus ?thesis by(rule strongEqWeakCong)
qed

lemma bangSC:
  fixes P

  shows "!P \<simeq>\<^sup>s P \<parallel> !P"
proof -
  have "!P \<sim>\<^sup>s P \<parallel> !P" by(rule Strong_Late_Bisim_Subst_SC.bangSC)
  thus ?thesis by(rule strongEqWeakCong)
qed

end