theory TickTock_SeqComp
  imports TickTock_Core TickTock_Basic_Ops
begin

subsection {* Sequential Composition *}

text_raw \<open>\DefineSnippet{SeqCompTT}{\<close>
definition SeqCompTT :: "'e ttprocess \<Rightarrow> 'e ttprocess \<Rightarrow> 'e ttprocess" (infixl ";\<^sub>C" 60) where
  "P ;\<^sub>C Q = {\<rho>\<in>P. \<nexists> s. \<rho> = s @ [[Tick]\<^sub>E]}
            \<union> {\<rho>. \<exists> s t. s @ [[Tick]\<^sub>E] \<in> P \<and> t \<in> Q \<and> \<rho> = s @ t}"
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{SeqComp_wf}{\<close>
lemma SeqComp_wf:
  assumes "\<forall>t\<in>P. ttWF t" "\<forall>t\<in>Q. ttWF t"
  shows "\<forall> t \<in> P ;\<^sub>C Q. ttWF t"
  unfolding SeqCompTT_def
proof auto
  fix t
  assume "t \<in> P" "\<forall>s. t \<noteq> s @ [[Tick]\<^sub>E]"
  then show "ttWF t"
    using assms(1) by auto
next
  fix s ta
  assume "s @ [[Tick]\<^sub>E] \<in> P"
  then have 1: "ttWF (s @ [[Tick]\<^sub>E])"
    using assms(1) by auto
  assume "ta \<in> Q"
  then have 2: "ttWF ta"
    using assms(2) by auto
  from 1 2 show "ttWF (s @ ta)"
    by (induct s rule:ttWF.induct, auto)
qed
text_raw \<open>}%EndSnippet\<close>

lemma TT0_SeqComp: "TT0 P \<Longrightarrow> TT0 Q \<Longrightarrow> TT0 (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT0_def by blast

lemma TT1_SeqComp:
  assumes "\<forall>t\<in>P. ttWF t" "TT1 P" "TT1 Q"
  shows "TT1 (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT1_def
proof (auto)
  fix \<rho> \<sigma> :: "'a ttobs list"
  show "\<rho> \<lesssim>\<^sub>C \<sigma> \<Longrightarrow> \<sigma> \<in> P \<Longrightarrow> \<rho> \<in> P"
    using TT1_def assms(2) by blast
next
  fix \<sigma> s :: "'a ttobs list"
  assume case_assms: "s @ [[Tick]\<^sub>E] \<lesssim>\<^sub>C \<sigma>" "\<sigma> \<in> P"
  then obtain s' t where \<sigma>_assms: "\<sigma> = s' @ t \<and> s @ [[Tick]\<^sub>E] \<subseteq>\<^sub>C s'"
    by (meson tt_prefix_split tt_prefix_subset_imp_tt_subset_tt_prefix)
  then have "\<exists> s'' x. s' = s'' @ x \<and> [[Tick]\<^sub>E] \<subseteq>\<^sub>C x"
    using tt_subset_split2 by blast
  then obtain s'' where "\<sigma> = s'' @ [[Tick]\<^sub>E] @ t"
    by (auto, case_tac x rule:ttWF.cases, auto simp add: \<sigma>_assms)
  then have "ttWF \<sigma> \<Longrightarrow> \<sigma> = s'' @ [[Tick]\<^sub>E]"
  proof auto
    show "ttWF (s'' @ [Tick]\<^sub>E # t) \<Longrightarrow> t = []"
      by (induct s'' rule:ttWF.induct, auto, cases t, auto)
  qed
  then have "\<sigma> = s'' @ [[Tick]\<^sub>E]"
    using assms(1) case_assms(2) by blast
  then show "\<forall>s. \<sigma> \<noteq> s @ [[Tick]\<^sub>E] \<Longrightarrow> False"
    by auto
next
  fix \<rho> \<sigma> s t :: "'a ttobs list"
  have assm1: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P \<longrightarrow> \<rho> \<in> P"
    using TT1_def assms(2) by blast
  have assm2: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> Q \<longrightarrow> \<rho> \<in> Q"
    using TT1_def assms(3) by blast
  assume assm3: "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> \<rho> \<noteq> s @ t)"
  assume assm4: "\<rho> \<lesssim>\<^sub>C s @ t"
  assume assm5: "s @ [[Tick]\<^sub>E] \<in> P"
  assume assm6: "t \<in> Q"
  obtain r where 1: "\<rho> \<subseteq>\<^sub>C r \<and> r \<le>\<^sub>C s @ t"
    using assm4 tt_prefix_subset_imp_tt_subset_tt_prefix by blast
  then obtain t' where 2: "(r = s @ t' \<and> t' \<le>\<^sub>C t) \<or> r \<le>\<^sub>C s"
    using tt_prefix_append_split by blast
  then show "\<rho> \<in> P"
  proof auto
    assume case_assms: "r = s @ t'" "t' \<le>\<^sub>C t"
    obtain s' t'' where \<rho>_assms: "\<rho> = s' @ t'' \<and> s' \<subseteq>\<^sub>C s \<and> t'' \<subseteq>\<^sub>C t'"
      using "1" case_assms(1) tt_subset_split by blast
    have "s' @ [[Tick]\<^sub>E] \<in> P"
      using \<rho>_assms assm1 assm5 tt_subset_end_event tt_subset_imp_prefix_subset by blast
    also have "t'' \<in> Q"
      using \<rho>_assms assm2 assm6 case_assms(2) tt_prefix_imp_prefix_subset tt_subset_imp_prefix_subset by blast
    then show "\<rho> \<in> P"
      using \<rho>_assms assm3 calculation by blast
  next
    show "r \<le>\<^sub>C s \<Longrightarrow> \<rho> \<in> P"
      by (meson "1" assm1 assm5 tt_prefix_concat tt_prefix_imp_prefix_subset tt_subset_imp_prefix_subset)
  qed
next
  fix s t sa :: "'a ttobs list"
  have assm1: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> P \<longrightarrow> \<rho> \<in> P"
    using TT1_def assms(2) by blast
  have assm2: "\<forall>\<rho> \<sigma>. \<rho> \<lesssim>\<^sub>C \<sigma> \<and> \<sigma> \<in> Q \<longrightarrow> \<rho> \<in> Q"
    using TT1_def assms(3) by blast
  assume case_assms: "sa @ [[Tick]\<^sub>E] \<lesssim>\<^sub>C s @ t" "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q"
  obtain r where 1: "sa @ [[Tick]\<^sub>E] \<subseteq>\<^sub>C r \<and> r \<le>\<^sub>C s @ t"
    using case_assms(1) tt_prefix_subset_imp_tt_subset_tt_prefix by blast
  then obtain t' where 2: "(r = s @ t' \<and> t' \<le>\<^sub>C t) \<or> r \<le>\<^sub>C s"
    using tt_prefix_append_split by blast
  then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
  proof auto
    assume case_assms2: "r = s @ t'" "t' \<le>\<^sub>C t"
    obtain s' t'' where \<rho>_assms: "sa @ [[Tick]\<^sub>E] = s' @ t'' \<and> s' \<subseteq>\<^sub>C s \<and> t'' \<subseteq>\<^sub>C t'"
      using "1" case_assms2(1) tt_subset_split by blast
    have "s' @ [[Tick]\<^sub>E] \<in> P"
      using \<rho>_assms assm1 case_assms(2) tt_subset_end_event tt_subset_imp_prefix_subset by blast
    also have "t'' \<in> Q"
      using \<rho>_assms assm2 case_assms(3) case_assms2(2) tt_prefix_imp_prefix_subset tt_subset_imp_prefix_subset by blast
    then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
      using \<rho>_assms case_assms calculation by blast
  next
    have "\<exists> r1 r2. r = r1 @ r2 \<and> sa \<subseteq>\<^sub>C r1 \<and> [[Tick]\<^sub>E] \<subseteq>\<^sub>C r2"
      by (simp add: "1" tt_subset_split2)
    then obtain r' where "r = r' @ [[Tick]\<^sub>E]"
      by (auto, case_tac r2 rule:ttWF.cases, auto)
    also assume "r \<le>\<^sub>C s"
    then obtain s' where "r' @ [[Tick]\<^sub>E] @ s' @ [[Tick]\<^sub>E] \<in> P"
      using calculation case_assms(2) tt_prefix_split by fastforce
    then have "ttWF (r' @ [[Tick]\<^sub>E] @ s' @ [[Tick]\<^sub>E])"
      using assms(1) by blast
    then show "False"
      by (induct r' rule:ttWF.induct, auto, induct s' rule:ttWF.induct, auto)
  qed
qed

lemma TT2w_SeqComp: "TT3ww P \<Longrightarrow> TT P \<Longrightarrow> TT Q \<Longrightarrow> TT2w (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT2w_def
proof auto
  fix \<rho> X Y
  assume assm1: "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
           e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))} = {}"
  assume assm2: "TT P"
  assume assm3: "\<rho> @ [[X]\<^sub>R] \<in> P"
  assume assm4: "TT3ww P"
  have "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
      e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))}
    = Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick}
      \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
        e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))})"
    by auto
  then have "Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick}
      \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
        e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
    using assm1 by auto
  then have 1: "(Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick})
      \<union> (Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
        e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
    by (simp add: Int_Un_distrib)
  have TT2w_P: "TT2w P"
    using assm2 TT_TT2w by auto
  have "{e\<in>Y. e \<noteq> Tick} \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using 1 by blast
  then have 2: "\<rho> @ [[X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R] \<in> P"
    using TT2w_P assm3 unfolding TT2w_def by auto
  show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
  proof (cases "Tick \<in> Y")
    assume case_assm: "Tick \<in> Y"
    have "\<rho> @ [[X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R] \<in> P"
      using 2 assm4 unfolding TT3ww_def by auto
    also have "X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
      using case_assm by blast
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      using calculation by auto
  next
    assume "Tick \<notin> Y"
    then have "X \<union> {e\<in>Y. e \<noteq> Tick} = X \<union> Y"
      by blast
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      using 2 by auto
  qed
next
  fix \<rho> X Y s t
  assume assm1: "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
    e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))} = {}"
  assume assm2: "TT P"
  assume assm3: "TT Q"
  assume assm4: "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> \<rho> @ [[X \<union> Y]\<^sub>R] \<noteq> s @ t)"
  assume assm5: "s @ [[Tick]\<^sub>E] \<in> P"
  assume assm6: "t \<in> Q"
  assume assm7: "\<rho> @ [[X]\<^sub>R] = s @ t"
  have "t = [] \<or> (\<exists> t'. t = t' @ [[X]\<^sub>R])"
    by (metis append_butlast_last_id assm7 last_appendR last_snoc)
  then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
  proof auto
    assume case_assm: "t = []"
    then have "s = \<rho> @ [[X]\<^sub>R]"
      by (simp add: assm7)
    then have "\<rho> @ [[X]\<^sub>R, [Tick]\<^sub>E] \<in> P"
      using assm5 by auto
    then have "ttWF (\<rho> @ [[X]\<^sub>R, [Tick]\<^sub>E])"
      using TT_wf assm2 by blast
    then have "False"
      by (induct \<rho> rule:ttWF.induct, auto)
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      by auto
  next
    fix t'
    assume case_assm: "t = t' @ [[X]\<^sub>R]"
    then have 1: "{e. e \<noteq> Tock \<and> t' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> t' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q}
      \<subseteq> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}"
      using assm5 assm7 by auto
    have "Y \<inter> {e. e \<noteq> Tock \<and> (\<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t))) \<or>
        e = Tock \<and> (\<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t)))}
      = Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P}
        \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))})"
      by auto
    then have "Y \<inter> ({e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P}
        \<union> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
      using assm1 by auto
    then have "(Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P})
        \<union> (Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))}) = {}"
      by (simp add: Int_Un_distrib)
    then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}
      \<and> Y \<inter> {e. e \<noteq> Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[e]\<^sub>E] = s @ t)) \<or>
          e = Tock \<and> (\<exists>s. s @ [[Tick]\<^sub>E] \<in> P \<and> (\<exists>t. t \<in> Q \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] = s @ t))} = {}"
      by auto
    then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}
        \<and> Y \<inter> {e. e \<noteq> Tock \<and> t' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> t' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
      by (metis (no_types, lifting) 1 Int_left_commute inf.orderE inf_bot_right)
    then have "t' @ [[X \<union> Y]\<^sub>R] \<in> Q"
      using TT2w_def TT_def assm3 assm6 case_assm by auto
    then have "\<rho> @ [[X \<union> Y]\<^sub>R] \<noteq> s @ t' @ [[X \<union> Y]\<^sub>R]"
      using assm4 assm5 by auto
    then have "False"
      using case_assm assm7 by auto
    then show "\<rho> @ [[X \<union> Y]\<^sub>R] \<in> P"
      by auto
  qed
qed

lemma TT2_SeqComp:
  assumes TT1_P: "TT1 P" and TT3w_P: "TT3w P"
  assumes TT2_P: "TT2 P" and TT2_Q: "TT2 Q"
  shows "TT2 (P ;\<^sub>C Q)"
  unfolding TT2_def
proof auto
  fix \<rho> \<sigma> X Y
  assume assm1: "\<rho> @ [X]\<^sub>R # \<sigma> \<in> P ;\<^sub>C Q"
  assume assm2: "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q} = {}"
  have "{e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} \<subseteq>
      {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q}"
    unfolding SeqCompTT_def by auto
  then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<and> e \<noteq> Tick \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using assm2 subset_iff by auto
  then have P_assm2: "{e\<in>Y. e \<noteq> Tick} \<inter> {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P} = {}"
    using assm2 subset_iff by auto
  show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P ;\<^sub>C Q"
    using assm1 unfolding SeqCompTT_def
  proof auto
    assume case_assm: "\<rho> @ [X]\<^sub>R # \<sigma> \<in> P"
    then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P"
      using TT2_P P_assm2 unfolding TT2_def by auto
    then show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
    proof (cases "Tick \<in> Y")
      have "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P \<Longrightarrow> \<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R # \<sigma> \<in> P"
        using TT1_P TT3w_TT1_add_Tick TT3w_P by blast
      also have "Tick \<in> Y \<Longrightarrow> X \<union> {e \<in> Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
        by blast
      then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P \<Longrightarrow> Tick \<in> Y \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
        using calculation by auto
    next
      assume "Tick \<notin> Y"
      then have "X \<union> {e \<in> Y. e \<noteq> Tick} = X \<union> Y"
        by auto
      then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma> \<in> P \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
        by auto
    qed
  next
    fix s t
    assume case_assms: "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "\<rho> @ [X]\<^sub>R # \<sigma> = s @ t"
    have "(\<exists> \<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t) \<or> (\<exists> \<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<and> \<rho> = s @ \<rho>')"
      using case_assms(3)
    proof auto
      have "\<And> s t. \<rho> @ [X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> \<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> \<rho> \<noteq> s @ \<rho>' \<Longrightarrow> \<exists>\<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
      proof (induct \<rho>, auto)
        fix s t
        show "[X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> s \<noteq> [] \<Longrightarrow> \<exists>\<sigma>'. s = [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
          by (metis Cons_eq_append_conv)
      next
        fix a \<rho> s t
        assume ind_hyp: "\<And>s t. \<rho> @ [X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> \<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> \<rho> \<noteq> s @ \<rho>' \<Longrightarrow> \<exists>\<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
        assume case_assms2: "a # \<rho> @ [X]\<^sub>R # \<sigma> = s @ t" "\<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> a # \<rho> \<noteq> s @ \<rho>'"
        have "s = [] \<or> (\<exists> s'. s = a # s')"
          by (metis Cons_eq_append_conv case_assms2(1))
        then show "\<exists>\<sigma>'. s = a # \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
        proof auto
          fix t'
          assume case_assm3: "s = []"
          then have "t = a # \<rho> @ [X]\<^sub>R # \<sigma>"
            by (simp add: case_assms2(1))
          then obtain t' where "t = a # t' \<and> t' = \<rho> @ [X]\<^sub>R # \<sigma>"
            by blast
          then have "\<exists>\<sigma>'. [] = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ \<rho> @ [X]\<^sub>R # \<sigma>"
            using case_assm3 case_assms2(2) by auto
          then show False
            by blast
        next
          fix s'
          assume case_assm3: "s = a # s'"
          then have "\<rho> @ [X]\<^sub>R # \<sigma> = s' @ t"
            using case_assms2(1) by auto
          then have "\<exists>\<sigma>'. s' = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
            using case_assm3 case_assms2(2) ind_hyp by auto
          then show "\<exists>\<sigma>'. s' = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
            by blast
        qed
      qed
      then show "\<rho> @ [X]\<^sub>R # \<sigma> = s @ t \<Longrightarrow> \<forall>\<rho>'. t = \<rho>' @ [X]\<^sub>R # \<sigma> \<longrightarrow> \<rho> \<noteq> s @ \<rho>' \<Longrightarrow> \<exists>\<sigma>'. s = \<rho> @ [X]\<^sub>R # \<sigma>' \<and> \<sigma> = \<sigma>' @ t"
        by auto
    qed
    then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<noteq> s @ t) \<Longrightarrow>
      \<rho> @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
    proof auto
      fix \<sigma>'
      assume case_assms2: "s = \<rho> @ [X]\<^sub>R # \<sigma>'" "\<sigma> = \<sigma>' @ t"
      then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
        using TT2_P P_assm2 case_assms case_assms2 unfolding TT2_def by auto
      then have "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
      proof (cases "Tick \<in> Y")
        assume case_assms3: "Tick \<in> Y" "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
        then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
          using TT1_P TT3w_TT1_add_Tick TT3w_P by blast
        also have "X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
          using case_assms3(1) by auto
        then show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
          using calculation by auto
      next
        assume "Tick \<notin> Y"
        then have "X \<union> {e\<in>Y. e \<noteq> Tick} = X \<union> Y"
          by auto
        then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ [[Tick]\<^sub>E] \<in> P"
          by auto
      qed
      then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>ta. ta \<in> Q \<longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ t \<noteq> s @ ta) \<Longrightarrow>
          \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>' @ t \<in> P"
        using case_assms by (erule_tac x="\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>'" in allE, auto)
    next
      fix \<rho>'
      assume case_assms2: "t = \<rho>' @ [X]\<^sub>R # \<sigma>" "\<rho> = s @ \<rho>'"

      have "{e. e \<noteq> Tock \<and> \<rho>' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} \<subseteq>
      {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q}"
        unfolding SeqCompTT_def using case_assms case_assms2 by auto
      then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho>' @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>' @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
        using assm2 subsetCE by auto
      then have "\<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> Q"
        using TT2_Q P_assm2 case_assms case_assms2 unfolding TT2_def by auto
      then show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> s @ \<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<noteq> sa @ t) \<Longrightarrow>
          s @ \<rho>' @ [X \<union> Y]\<^sub>R # \<sigma> \<in> P"
        using case_assms case_assms2 by auto
    qed
  next
    fix s :: "'a ttobs list"
    assume "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> = s @ [[Tick]\<^sub>E]"
    then obtain \<sigma>' where "\<sigma> = \<sigma>' @ [[Tick]\<^sub>E]"
      by (induct \<rho> s rule:tt_subset.induct, auto)
    then show "\<forall>s. \<rho> @ [X]\<^sub>R # \<sigma> \<noteq> s @ [[Tick]\<^sub>E] \<Longrightarrow> False"
      by simp
  next
    fix s t sa :: "'a ttobs list"
    assume case_assms: "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma> = sa @ [[Tick]\<^sub>E]" "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "\<rho> @ [X]\<^sub>R # \<sigma> = s @ t"
    obtain \<sigma>' where "\<sigma> = \<sigma>' @ [[Tick]\<^sub>E]"
      using case_assms(1) by (induct \<rho> sa rule:tt_subset.induct, auto)
    have "(\<exists> \<rho>2. \<rho> = s @ \<rho>2 \<and> t = \<rho>2 @ [X]\<^sub>R # \<sigma>) \<or> (\<exists> \<sigma>1. s = \<rho> @ [X]\<^sub>R # \<sigma>1 \<and> \<sigma> = \<sigma>1 @ t)"
      using case_assms(4) by (induct s \<rho> rule:tt_subset.induct, auto)
    then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
    proof auto
      fix \<rho>2 :: "'a ttobs list"
      assume case_assms2: "\<rho> = s @ \<rho>2" "t = \<rho>2 @ [X]\<^sub>R # \<sigma>"
      have "{e. e \<noteq> Tock \<and> \<rho>2 @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>2 @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} \<subseteq>
      {e. e \<noteq> Tock \<and> \<rho> @ [[e]\<^sub>E] \<in> P ;\<^sub>C Q \<or> e = Tock \<and> \<rho> @ [[X]\<^sub>R, [e]\<^sub>E] \<in> P ;\<^sub>C Q}"
        unfolding SeqCompTT_def using case_assms case_assms2 by auto
      then have "Y \<inter> {e. e \<noteq> Tock \<and> \<rho>2 @ [[e]\<^sub>E] \<in> Q \<or> e = Tock \<and> \<rho>2 @ [[X]\<^sub>R, [e]\<^sub>E] \<in> Q} = {}"
        using assm2 subsetCE by auto
      then have "\<rho>2 @ [X \<union> Y]\<^sub>R # \<sigma> \<in> Q"
        using TT2_Q case_assms(3) case_assms2(2) unfolding TT2_def by auto
      then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
        using case_assms by (erule_tac x="s" in allE, auto, erule_tac x="\<rho>2 @ [X \<union> Y]\<^sub>R # \<sigma>" in allE, auto simp add: case_assms2)
    next
      fix \<sigma>1 :: "'a ttobs list"
      assume case_assms2: "s = \<rho> @ [X]\<^sub>R # \<sigma>1" "\<sigma> = \<sigma>1 @ t"
      then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
        using TT2_P P_assm2 case_assms case_assms2 unfolding TT2_def by auto
      then have "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
      proof (cases "Tick \<in> Y")
        assume case_assms3: "Tick \<in> Y" "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
        then have "\<rho> @ [X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
          using TT1_P TT3w_TT1_add_Tick TT3w_P by blast
        also have "X \<union> {e\<in>Y. e \<noteq> Tick} \<union> {Tick} = X \<union> Y"
          using case_assms3(1) by auto
        then show "\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
          using calculation by auto
      next
        assume "Tick \<notin> Y"
        then have "X \<union> {e\<in>Y. e \<noteq> Tick} = X \<union> Y"
          by auto
        then show "\<rho> @ [X \<union> {e \<in> Y. e \<noteq> Tick}]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow> \<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1 @ [[Tick]\<^sub>E] \<in> P"
          by auto
      qed
      then show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
        using case_assms by (erule_tac x="\<rho> @ [X \<union> Y]\<^sub>R # \<sigma>1" in allE, auto, erule_tac x="t" in allE, auto simp add: case_assms2)
    qed
  qed
qed

text_raw \<open>\DefineSnippet{ttWFx_SeqComp}{\<close>
lemma ttWFx_SeqComp:
  assumes "TT P" "TT Q"
  shows "ttWFx (P ;\<^sub>C Q)"
  unfolding ttWFx_def SeqCompTT_def
proof auto
  fix x
  show "x \<in> P \<Longrightarrow> ttWFx_trace x"
    using ttWFx_def TT_ttWFx assms(1) by blast
next
  fix s t
  assume "s @ [[Tick]\<^sub>E] \<in> P"
  then have 1: "ttWFx_trace s"
    by (meson TT1_def ttWFx_def TT_TT1 TT_ttWFx assms(1)
              tt_prefix_concat tt_prefix_imp_prefix_subset)
  assume "t \<in> Q"
  then have 2: "ttWFx_trace t \<and> ttWF t"
    using ttWFx_def TT_ttWFx TT_wf assms(2) by blast
  show "ttWFx_trace (s @ t)"
    using 1 2 ttWFx_append by auto
qed
text_raw \<open>}%EndSnippet\<close>

text_raw \<open>\DefineSnippet{TT3w_SeqComp}{\<close>
lemma TT3w_SeqComp:
  assumes "TT3w P" "TT3w Q"
  shows "TT3w (P ;\<^sub>C Q)"
  unfolding SeqCompTT_def TT3w_def
proof auto
  fix \<rho>
  show "\<rho> \<in> P \<Longrightarrow> add_Tick_refusal_trace \<rho> \<in> P"
    using TT3w_def assms(1) by blast
next
  fix s t
  assume "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q"
  then have "add_Tick_refusal_trace s @ [[Tick]\<^sub>E] \<in> P \<and> add_Tick_refusal_trace t \<in> Q"
    by (metis TT3w_def add_Tick_refusal_trace_end_event assms(1) assms(2))
  then show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>ta. ta \<in> Q \<longrightarrow> add_Tick_refusal_trace (s @ t) \<noteq> sa @ ta) \<Longrightarrow>
    add_Tick_refusal_trace (s @ t) \<in> P"
    using add_Tick_refusal_trace_concat by blast
next
  fix \<rho> s
  assume case_assms: "\<rho> \<in> P" "\<forall>s. \<rho> \<noteq> s @ [[Tick]\<^sub>E]" "add_Tick_refusal_trace \<rho> = s @ [[Tick]\<^sub>E]"
  have "\<exists> s'. s = add_Tick_refusal_trace s' \<and> \<rho> = s' @ [[Tick]\<^sub>E]"
    using case_assms(3) apply (induct \<rho> s rule:tt_subset.induct, auto)
    using add_Tick_refusal_trace.elims apply (rule_tac x="[]" in exI, auto)
    by (rule_tac x="[]" in exI, auto, metis list.discI list.sel(3))
  then show "\<forall>sa. sa @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> s @ [[Tick]\<^sub>E] \<noteq> sa @ t) \<Longrightarrow> False"
    using case_assms(2) by blast
next
  fix s t sa
  assume case_assms: "s @ [[Tick]\<^sub>E] \<in> P" "t \<in> Q" "add_Tick_refusal_trace (s @ t) = sa @ [[Tick]\<^sub>E]"
  have 1: "add_Tick_refusal_trace s @ [[Tick]\<^sub>E] \<in> P"
    by (metis TT3w_def add_Tick_refusal_trace_end_event assms(1) case_assms(1))
  have 2: "add_Tick_refusal_trace t \<in> Q"
    using TT3w_def assms(2) case_assms(2) by blast
  show "\<forall>s. s @ [[Tick]\<^sub>E] \<in> P \<longrightarrow> (\<forall>t. t \<in> Q \<longrightarrow> sa @ [[Tick]\<^sub>E] \<noteq> s @ t) \<Longrightarrow> False"
    using 1 2 case_assms apply (erule_tac x="add_Tick_refusal_trace s" in allE, auto)
    by (erule_tac x="add_Tick_refusal_trace t" in allE, auto simp add: add_Tick_refusal_trace_concat)
qed
text_raw \<open>}%EndSnippet\<close>

lemma TT3_SeqComp:
  assumes "\<forall>t\<in>P. ttWF t" "TT1 P" "TT1 Q" "TT3 P" "TT3 Q"
  shows "TT3 (P ;\<^sub>C Q)"
  by (meson TT1_SeqComp TT1_TT3w_equiv_TT3 TT3w_SeqComp assms)

lemma TT_SeqComp:
  assumes "TT P" "TT Q" "TT3ww P"
  shows "TT (P ;\<^sub>C Q)"
  unfolding TT_def apply auto
  apply (metis TT_def SeqComp_wf assms(1) assms(2))
  apply (simp add: TT0_SeqComp TT_TT0 assms(1) assms(2))
  using TT1_SeqComp TT_def assms(1) assms(2) apply blast
  apply (simp add: TT2w_SeqComp assms(1) assms(2) assms(3))
  apply (simp add: ttWFx_SeqComp assms(1) assms(2))
  done

lemma SeqComp_right_unit:
  assumes "TT1 P"
  shows "P ;\<^sub>C SKIP\<^sub>C = P"
  unfolding SkipTT_def SeqCompTT_def
proof auto
  fix s
  show "s @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow> s \<in> P"
    using TT1_def assms tt_prefix_concat tt_prefix_imp_prefix_subset by blast
qed

lemma SeqComp_left_unit:
  assumes "TT0 P" "TT1 P"
  shows "SKIP\<^sub>C ;\<^sub>C P = P"
  unfolding SkipTT_def SeqCompTT_def
proof (safe, simp_all)
  show "[] \<in> P"
    by (simp add: TT0_TT1_empty assms(1) assms(2))
qed

lemma SeqComp_Union_dist1:
  "S \<noteq> {} \<Longrightarrow> P ;\<^sub>C (\<Union>S) = \<Union>{R. \<exists>Q. Q \<in> S \<and> R = P ;\<^sub>C Q}"
  unfolding SeqCompTT_def by auto

lemma SeqComp_Union_dist2:
  "S \<noteq> {} \<Longrightarrow> (\<Union>S) ;\<^sub>C Q = \<Union>{R. \<exists>P. P \<in> S \<and> R = P ;\<^sub>C Q}"
  unfolding SeqCompTT_def by auto

lemma SeqComp_mono1:
  "P \<sqsubseteq>\<^sub>C Q \<Longrightarrow> P ;\<^sub>C R \<sqsubseteq>\<^sub>C Q ;\<^sub>C R"
  unfolding RefinesTT_def SeqCompTT_def by auto

lemma SeqComp_mono2:
  "P \<sqsubseteq>\<^sub>C Q \<Longrightarrow> R ;\<^sub>C P \<sqsubseteq>\<^sub>C R ;\<^sub>C Q"
  unfolding RefinesTT_def SeqCompTT_def by auto

end


(*  Title:      HOL/UNITY/UNITY.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

The basic UNITY theory (revised version, based upon the "co"
operator).

From Misra, "A Logic for Concurrent Programming", 1994.
*)

section {*The Basic UNITY Theory*}

theory UNITY imports Main begin

definition
  "Program =
    {(init:: 'a set, acts :: ('a * 'a)set set,
      allowed :: ('a * 'a)set set). Id \<in> acts & Id: allowed}"

typedef 'a program = "Program :: ('a set * ('a * 'a) set set * ('a * 'a) set set) set"
  morphisms Rep_Program Abs_Program
  unfolding Program_def by blast

definition Acts :: "'a program => ('a * 'a)set set" where
    "Acts F == (%(init, acts, allowed). acts) (Rep_Program F)"

definition "constrains" :: "['a set, 'a set] => 'a program set"  (infixl "co"     60) where
    "A co B == {F. \<forall>act \<in> Acts F. act``A \<subseteq> B}"

definition unless  :: "['a set, 'a set] => 'a program set"  (infixl "unless" 60)  where
    "A unless B == (A-B) co (A \<union> B)"

definition mk_program :: "('a set * ('a * 'a)set set * ('a * 'a)set set)
                   => 'a program" where
    "mk_program == %(init, acts, allowed).
                      Abs_Program (init, insert Id acts, insert Id allowed)"

definition Init :: "'a program => 'a set" where
    "Init F == (%(init, acts, allowed). init) (Rep_Program F)"

definition AllowedActs :: "'a program => ('a * 'a)set set" where
    "AllowedActs F == (%(init, acts, allowed). allowed) (Rep_Program F)"

definition Allowed :: "'a program => 'a program set" where
    "Allowed F == {G. Acts G \<subseteq> AllowedActs F}"

definition stable     :: "'a set => 'a program set" where
    "stable A == A co A"

definition strongest_rhs :: "['a program, 'a set] => 'a set" where
    "strongest_rhs F A == Inter {B. F \<in> A co B}"

definition invariant :: "'a set => 'a program set" where
    "invariant A == {F. Init F \<subseteq> A} \<inter> stable A"

definition increasing :: "['a => 'b::{order}] => 'a program set" where
    --{*Polymorphic in both states and the meaning of @{text "\<le>"}*}
    "increasing f == \<Inter>z. stable {s. z \<le> f s}"

subsubsection{*The abstract type of programs*}

lemmas program_typedef =
     Rep_Program Rep_Program_inverse Abs_Program_inverse
     Program_def Init_def Acts_def AllowedActs_def mk_program_def

lemma Id_in_Acts [iff]: "Id \<in> Acts F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
done

lemma insert_Id_Acts [iff]: "insert Id (Acts F) = Acts F"
by (simp add: insert_absorb)

lemma Acts_nonempty [simp]: "Acts F \<noteq> {}"
by auto

lemma Id_in_AllowedActs [iff]: "Id \<in> AllowedActs F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
done

lemma insert_Id_AllowedActs [iff]: "insert Id (AllowedActs F) = AllowedActs F"
by (simp add: insert_absorb)

subsubsection{*Inspectors for type "program"*}

lemma Init_eq [simp]: "Init (mk_program (init,acts,allowed)) = init"
by (simp add: program_typedef)

lemma Acts_eq [simp]: "Acts (mk_program (init,acts,allowed)) = insert Id acts"
by (simp add: program_typedef)

lemma AllowedActs_eq [simp]:
     "AllowedActs (mk_program (init,acts,allowed)) = insert Id allowed"
by (simp add: program_typedef)

subsubsection{*Equality for UNITY programs*}

lemma surjective_mk_program [simp]:
     "mk_program (Init F, Acts F, AllowedActs F) = F"
apply (cut_tac x = F in Rep_Program)
apply (auto simp add: program_typedef)
apply (drule_tac f = Abs_Program in arg_cong)+
apply (simp add: program_typedef insert_absorb)
done

lemma program_equalityI:
     "[| Init F = Init G; Acts F = Acts G; AllowedActs F = AllowedActs G |]
      ==> F = G"
apply (rule_tac t = F in surjective_mk_program [THEN subst])
apply (rule_tac t = G in surjective_mk_program [THEN subst], simp)
done

lemma program_equalityE:
     "[| F = G;
         [| Init F = Init G; Acts F = Acts G; AllowedActs F = AllowedActs G |]
         ==> P |] ==> P"
by simp

lemma program_equality_iff:
     "(F=G) =
      (Init F = Init G & Acts F = Acts G &AllowedActs F = AllowedActs G)"
by (blast intro: program_equalityI program_equalityE)

subsubsection{*co*}

lemma constrainsI:
    "(!!act s s'. [| act: Acts F;  (s,s') \<in> act;  s \<in> A |] ==> s': A')
     ==> F \<in> A co A'"
by (simp add: constrains_def, blast)

lemma constrainsD:
    "[| F \<in> A co A'; act: Acts F;  (s,s'): act;  s \<in> A |] ==> s': A'"
by (unfold constrains_def, blast)

lemma constrains_empty [iff]: "F \<in> {} co B"
by (unfold constrains_def, blast)

lemma constrains_empty2 [iff]: "(F \<in> A co {}) = (A={})"
by (unfold constrains_def, blast)

lemma constrains_UNIV [iff]: "(F \<in> UNIV co B) = (B = UNIV)"
by (unfold constrains_def, blast)

lemma constrains_UNIV2 [iff]: "F \<in> A co UNIV"
by (unfold constrains_def, blast)

text{*monotonic in 2nd argument*}
lemma constrains_weaken_R:
    "[| F \<in> A co A'; A'<=B' |] ==> F \<in> A co B'"
by (unfold constrains_def, blast)

text{*anti-monotonic in 1st argument*}
lemma constrains_weaken_L:
    "[| F \<in> A co A'; B \<subseteq> A |] ==> F \<in> B co A'"
by (unfold constrains_def, blast)

lemma constrains_weaken:
   "[| F \<in> A co A'; B \<subseteq> A; A'<=B' |] ==> F \<in> B co B'"
by (unfold constrains_def, blast)

subsubsection{*Union*}

lemma constrains_Un:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<union> B) co (A' \<union> B')"
by (unfold constrains_def, blast)

lemma constrains_UN:
    "(!!i. i \<in> I ==> F \<in> (A i) co (A' i))
     ==> F \<in> (\<Union>i \<in> I. A i) co (\<Union>i \<in> I. A' i)"
by (unfold constrains_def, blast)

lemma constrains_Un_distrib: "(A \<union> B) co C = (A co C) \<inter> (B co C)"
by (unfold constrains_def, blast)

lemma constrains_UN_distrib: "(\<Union>i \<in> I. A i) co B = (\<Inter>i \<in> I. A i co B)"
by (unfold constrains_def, blast)

lemma constrains_Int_distrib: "C co (A \<inter> B) = (C co A) \<inter> (C co B)"
by (unfold constrains_def, blast)

lemma constrains_INT_distrib: "A co (\<Inter>i \<in> I. B i) = (\<Inter>i \<in> I. A co B i)"
by (unfold constrains_def, blast)

subsubsection{*Intersection*}

lemma constrains_Int:
    "[| F \<in> A co A'; F \<in> B co B' |] ==> F \<in> (A \<inter> B) co (A' \<inter> B')"
by (unfold constrains_def, blast)

lemma constrains_INT:
    "(!!i. i \<in> I ==> F \<in> (A i) co (A' i))
     ==> F \<in> (\<Inter>i \<in> I. A i) co (\<Inter>i \<in> I. A' i)"
by (unfold constrains_def, blast)

lemma constrains_imp_subset: "F \<in> A co A' ==> A \<subseteq> A'"
by (unfold constrains_def, auto)

text{*The reasoning is by subsets since "co" refers to single actions
  only.  So this rule isn't that useful.*}
lemma constrains_trans:
    "[| F \<in> A co B; F \<in> B co C |] ==> F \<in> A co C"
by (unfold constrains_def, blast)

lemma constrains_cancel:
   "[| F \<in> A co (A' \<union> B); F \<in> B co B' |] ==> F \<in> A co (A' \<union> B')"
by (unfold constrains_def, clarify, blast)

subsubsection{*unless*}

lemma unlessI: "F \<in> (A-B) co (A \<union> B) ==> F \<in> A unless B"
by (unfold unless_def, assumption)

lemma unlessD: "F \<in> A unless B ==> F \<in> (A-B) co (A \<union> B)"
by (unfold unless_def, assumption)

subsubsection{*stable*}

lemma stableI: "F \<in> A co A ==> F \<in> stable A"
by (unfold stable_def, assumption)

lemma stableD: "F \<in> stable A ==> F \<in> A co A"
by (unfold stable_def, assumption)

lemma stable_UNIV [simp]: "stable UNIV = UNIV"
by (unfold stable_def constrains_def, auto)

subsubsection{*Union*}

lemma stable_Un:
    "[| F \<in> stable A; F \<in> stable A' |] ==> F \<in> stable (A \<union> A')"

apply (unfold stable_def)
apply (blast intro: constrains_Un)
done

lemma stable_UN:
    "(!!i. i \<in> I ==> F \<in> stable (A i)) ==> F \<in> stable (\<Union>i \<in> I. A i)"
apply (unfold stable_def)
apply (blast intro: constrains_UN)
done

lemma stable_Union:
    "(!!A. A \<in> X ==> F \<in> stable A) ==> F \<in> stable (\<Union>X)"
by (unfold stable_def constrains_def, blast)

subsubsection{*Intersection*}

lemma stable_Int:
    "[| F \<in> stable A;  F \<in> stable A' |] ==> F \<in> stable (A \<inter> A')"
apply (unfold stable_def)
apply (blast intro: constrains_Int)
done

lemma stable_INT:
    "(!!i. i \<in> I ==> F \<in> stable (A i)) ==> F \<in> stable (\<Inter>i \<in> I. A i)"
apply (unfold stable_def)
apply (blast intro: constrains_INT)
done

lemma stable_Inter:
    "(!!A. A \<in> X ==> F \<in> stable A) ==> F \<in> stable (\<Inter>X)"
by (unfold stable_def constrains_def, blast)

lemma stable_constrains_Un:
    "[| F \<in> stable C; F \<in> A co (C \<union> A') |] ==> F \<in> (C \<union> A) co (C \<union> A')"
by (unfold stable_def constrains_def, blast)

lemma stable_constrains_Int:
  "[| F \<in> stable C; F \<in>  (C \<inter> A) co A' |] ==> F \<in> (C \<inter> A) co (C \<inter> A')"
by (unfold stable_def constrains_def, blast)

(*[| F \<in> stable C; F \<in>  (C \<inter> A) co A |] ==> F \<in> stable (C \<inter> A) *)
lemmas stable_constrains_stable = stable_constrains_Int[THEN stableI]

subsubsection{*invariant*}

lemma invariantI: "[| Init F \<subseteq> A;  F \<in> stable A |] ==> F \<in> invariant A"
by (simp add: invariant_def)

text{*Could also say @{term "invariant A \<inter> invariant B \<subseteq> invariant(A \<inter> B)"}*}
lemma invariant_Int:
     "[| F \<in> invariant A;  F \<in> invariant B |] ==> F \<in> invariant (A \<inter> B)"
by (auto simp add: invariant_def stable_Int)

subsubsection{*increasing*}

lemma increasingD:
     "F \<in> increasing f ==> F \<in> stable {s. z \<subseteq> f s}"
by (unfold increasing_def, blast)

lemma increasing_constant [iff]: "F \<in> increasing (%s. c)"
by (unfold increasing_def stable_def, auto)

lemma mono_increasing_o:
     "mono g ==> increasing f \<subseteq> increasing (g o f)"
apply (unfold increasing_def stable_def constrains_def, auto)
apply (blast intro: monoD order_trans)
done

(*Holds by the theorem (Suc m \<subseteq> n) = (m < n) *)
lemma strict_increasingD:
     "!!z::nat. F \<in> increasing f ==> F \<in> stable {s. z < f s}"
by (simp add: increasing_def Suc_le_eq [symmetric])

(** The Elimination Theorem.  The "free" m has become universally quantified!
    Should the premise be !!m instead of \<forall>m ?  Would make it harder to use
    in forward proof. **)

lemma elimination:
    "[| \<forall>m \<in> M. F \<in> {s. s x = m} co (B m) |]
     ==> F \<in> {s. s x \<in> M} co (\<Union>m \<in> M. B m)"
by (unfold constrains_def, blast)

text{*As above, but for the trivial case of a one-variable state, in which the
  state is identified with its one variable.*}
lemma elimination_sing:
    "(\<forall>m \<in> M. F \<in> {m} co (B m)) ==> F \<in> M co (\<Union>m \<in> M. B m)"
by (unfold constrains_def, blast)

subsubsection{*Theoretical Results from Section 6*}

lemma constrains_strongest_rhs:
    "F \<in> A co (strongest_rhs F A )"
by (unfold constrains_def strongest_rhs_def, blast)

lemma strongest_rhs_is_strongest:
    "F \<in> A co B ==> strongest_rhs F A \<subseteq> B"
by (unfold constrains_def strongest_rhs_def, blast)

subsubsection{*Ad-hoc set-theory rules*}

lemma Un_Diff_Diff [simp]: "A \<union> B - (A - B) = B"
by blast

lemma Int_Union_Union: "Union(B) \<inter> A = Union((%C. C \<inter> A)`B)"
by blast

text{*Needed for WF reasoning in WFair.thy*}

lemma Image_less_than [simp]: "less_than `` {k} = greaterThan k"
by blast

lemma Image_inverse_less_than [simp]: "less_than^-1 `` {k} = lessThan k"
by blast

subsection{*Partial versus Total Transitions*}

definition totalize_act :: "('a * 'a)set => ('a * 'a)set" where
    "totalize_act act == act \<union> Id_on (-(Domain act))"

definition totalize :: "'a program => 'a program" where
    "totalize F == mk_program (Init F,
                               totalize_act ` Acts F,
                               AllowedActs F)"

definition mk_total_program :: "('a set * ('a * 'a)set set * ('a * 'a)set set)
                   => 'a program" where
    "mk_total_program args == totalize (mk_program args)"

definition all_total :: "'a program => bool" where
    "all_total F == \<forall>act \<in> Acts F. Domain act = UNIV"

lemma insert_Id_image_Acts: "f Id = Id ==> insert Id (f`Acts F) = f ` Acts F"
by (blast intro: sym [THEN image_eqI])

subsubsection{*Basic properties*}

lemma totalize_act_Id [simp]: "totalize_act Id = Id"
by (simp add: totalize_act_def)

lemma Domain_totalize_act [simp]: "Domain (totalize_act act) = UNIV"
by (auto simp add: totalize_act_def)

lemma Init_totalize [simp]: "Init (totalize F) = Init F"
by (unfold totalize_def, auto)

lemma Acts_totalize [simp]: "Acts (totalize F) = (totalize_act ` Acts F)"
by (simp add: totalize_def insert_Id_image_Acts)

lemma AllowedActs_totalize [simp]: "AllowedActs (totalize F) = AllowedActs F"
by (simp add: totalize_def)

lemma totalize_constrains_iff [simp]: "(totalize F \<in> A co B) = (F \<in> A co B)"
by (simp add: totalize_def totalize_act_def constrains_def, blast)

lemma totalize_stable_iff [simp]: "(totalize F \<in> stable A) = (F \<in> stable A)"
by (simp add: stable_def)

lemma totalize_invariant_iff [simp]:
     "(totalize F \<in> invariant A) = (F \<in> invariant A)"
by (simp add: invariant_def)

lemma all_total_totalize: "all_total (totalize F)"
by (simp add: totalize_def all_total_def)

lemma Domain_iff_totalize_act: "(Domain act = UNIV) = (totalize_act act = act)"
by (force simp add: totalize_act_def)

lemma all_total_imp_totalize: "all_total F ==> (totalize F = F)"
apply (simp add: all_total_def totalize_def)
apply (rule program_equalityI)
  apply (simp_all add: Domain_iff_totalize_act image_def)
done

lemma all_total_iff_totalize: "all_total F = (totalize F = F)"
apply (rule iffI)
 apply (erule all_total_imp_totalize)
apply (erule subst)
apply (rule all_total_totalize)
done

lemma mk_total_program_constrains_iff [simp]:
     "(mk_total_program args \<in> A co B) = (mk_program args \<in> A co B)"
by (simp add: mk_total_program_def)

subsection{*Rules for Lazy Definition Expansion*}

text{*They avoid expanding the full program, which is a large expression*}

lemma def_prg_Init:
     "F = mk_total_program (init,acts,allowed) ==> Init F = init"
by (simp add: mk_total_program_def)

lemma def_prg_Acts:
     "F = mk_total_program (init,acts,allowed)
      ==> Acts F = insert Id (totalize_act ` acts)"
by (simp add: mk_total_program_def)

lemma def_prg_AllowedActs:
     "F = mk_total_program (init,acts,allowed)
      ==> AllowedActs F = insert Id allowed"
by (simp add: mk_total_program_def)

text{*An action is expanded if a pair of states is being tested against it*}
lemma def_act_simp:
     "act = {(s,s'). P s s'} ==> ((s,s') \<in> act) = P s s'"
by (simp add: mk_total_program_def)

text{*A set is expanded only if an element is being tested against it*}
lemma def_set_simp: "A = B ==> (x \<in> A) = (x \<in> B)"
by (simp add: mk_total_program_def)

subsubsection{*Inspectors for type "program"*}

lemma Init_total_eq [simp]:
     "Init (mk_total_program (init,acts,allowed)) = init"
by (simp add: mk_total_program_def)

lemma Acts_total_eq [simp]:
    "Acts(mk_total_program(init,acts,allowed)) = insert Id (totalize_act`acts)"
by (simp add: mk_total_program_def)

lemma AllowedActs_total_eq [simp]:
     "AllowedActs (mk_total_program (init,acts,allowed)) = insert Id allowed"
by (auto simp add: mk_total_program_def)

end


theory Scratch
  imports Main Observation
begin

text \<open>So, you can't have a typeclass return a type parameter. Let's see if we can define a type with
no properties, then later, assert some properties *of* that type and use them in a proof. So... some
`foo` exists. We don't know what it is.\<close>

typedecl foo

text \<open>We can make a container for foo\<close>

datatype box = Box "foo"

text \<open>We can use foo for equality...\<close>

lemma "(x :: foo) \<noteq> (y :: foo) \<longrightarrow> (Box x) \<noteq> (Box y)"
  apply auto
  done

lemma "(x :: foo) = (y :: foo) \<longrightarrow> (Box x) = (Box y)"
  apply auto
  done

text \<open>We can define a typeclass which returns foos...\<close>

class openable =
  fixes open1 :: "'a \<Rightarrow> foo"

instantiation box :: openable
begin
primrec open1 :: "box \<Rightarrow> foo" where
"open1 (Box f) = f"
instance ..
end

text \<open>Now it'd be nice if we could show something trivial, like... if foo is, say, a nat, then open1
returns a nat. If we were using type parameters, I'd make a "box nat", but since we're NOT using
type parameters... I want to write, like, (foo = nat) \<Rightarrow> is_nat (openable x)" but I have no idea how\<close>

text \<open>I think what I want here is maybe... a locale? Let's try that...\<close>

locale partial_order =
  fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes refl [intro, simp]: "le x x"
    and anti_sym [intro]: "\<lbrakk>le x y; le y x\<rbrakk> \<Longrightarrow> x = y"
    and trans [trans]: "\<lbrakk>le x y; le y z\<rbrakk> \<Longrightarrow> le x z"

text \<open>So... what we've done here is assert a le function exists, and it obeys these laws, but we
haven't actually said what le is. le could operate over cats or cargo ships. It could be < or >. Can
I define a locale that returns a type parameter?\<close>

locale openable2 =
  fixes open2 :: "'a \<Rightarrow> 'b"

text \<open>Huh. So... all I've said here is that a binary function exists. What about... making a box for
a type parameter? That's something we can't do with typeclasses...\<close>

datatype 'a abstract_box = AbstractBox "'a"
locale boxable =
  fixes box :: "'a \<Rightarrow> ('b abstract_box)"

text \<open>Okay, so I can define a boxable function which returns something with type parameters. Note
that our box is over a different type, so we could, I dunno, take strings and constantly return
AbstractBox 2 or something.\<close>