theory ValueOntologyTestLong (** Benzmüller, Fuenmayor & Lomfeld, 2020 **)
  imports ValueOntology
begin
lemma "True" nitpick[satisfy,show_all,card i=10] oops
lemma "\<lfloor>INCONS\<^sup>p\<rfloor>" nitpick[satisfy,card i=4] nitpick oops (*contingent*)
(*ext/int operators satisfy main properties of Galois connections*)
lemma G:      "B \<^bold>\<sqsubseteq> A\<up> \<longleftrightarrow> A \<^bold>\<sqsubseteq> B\<down>" by blast
lemma G1:     "A \<^bold>\<sqsubseteq> A\<up>\<down>" by simp
lemma G2:     "B \<^bold>\<sqsubseteq> B\<down>\<up>" by simp
lemma G3:     "A\<^sub>1 \<^bold>\<sqsubseteq> A\<^sub>2 \<longrightarrow> A\<^sub>2\<up> \<^bold>\<sqsubseteq> A\<^sub>1\<up>" by simp
lemma G4:     "B\<^sub>1 \<^bold>\<sqsubseteq> B\<^sub>2 \<longrightarrow> B\<^sub>2\<down> \<^bold>\<sqsubseteq> B\<^sub>1\<down>" by simp
lemma cl1:    "A\<up> = A\<up>\<down>\<up>" by blast
lemma cl2:    "B\<down> = B\<down>\<up>\<down>" by blast
lemma dual1a: "(A\<^sub>1 \<^bold>\<squnion> A\<^sub>2)\<up> = (A\<^sub>1\<up> \<^bold>\<sqinter> A\<^sub>2\<up>)" by blast
lemma dual1b: "(B\<^sub>1 \<^bold>\<squnion> B\<^sub>2)\<down> = (B\<^sub>1\<down> \<^bold>\<sqinter> B\<^sub>2\<down>)" by blast
lemma         "(A\<^sub>1 \<^bold>\<sqinter> A\<^sub>2)\<up> \<^bold>\<sqsubseteq> (A\<^sub>1\<up> \<^bold>\<squnion> A\<^sub>2\<up>)" nitpick oops
lemma         "(B\<^sub>1 \<^bold>\<sqinter> B\<^sub>2)\<down> \<^bold>\<sqsubseteq> (B\<^sub>1\<down> \<^bold>\<squnion> B\<^sub>2\<down>)" nitpick oops
lemma dual2a: "(A\<^sub>1\<up> \<^bold>\<squnion> A\<^sub>2\<up>) \<^bold>\<sqsubseteq>  (A\<^sub>1 \<^bold>\<sqinter> A\<^sub>2)\<up>" by blast
lemma dual2b: "(B\<^sub>1\<down> \<^bold>\<squnion> B\<^sub>2\<down>) \<^bold>\<sqsubseteq>  (B\<^sub>1 \<^bold>\<sqinter> B\<^sub>2)\<down>" by blast
(*Note: two different but logically equivalent notations*)
lemma "[WILL\<^sup>x] \<equiv> WILL\<^sup>x\<down>" by simp
lemma "[WILL\<^sup>x\<oplus>STAB\<^sup>x] \<equiv> (WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x)\<down>" by simp
(********* value ontology tests *****************)
lemma "\<lfloor>[RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p] \<^bold>\<rightarrow> INCONS\<^sup>p\<rfloor>" by simp
lemma "\<lfloor>INCONS\<^sup>p \<^bold>\<rightarrow> [RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>" by simp
lemma "\<lfloor>[RELI\<^sup>p] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>[FAIR\<^sup>d] \<^bold>\<and> [EFFI\<^sup>d]\<rfloor>" nitpick[satisfy] nitpick oops (*contingent*)
lemma "\<lfloor>(\<^bold>\<not>INCONS\<^sup>p) \<^bold>\<and> [FAIR\<^sup>d] \<^bold>\<and> [EFFI\<^sup>d]\<rfloor>"
 nitpick[satisfy,show_all] nitpick oops (*contingent: p & d independent*)
lemma "\<lfloor>(\<^bold>\<not>INCONS\<^sup>d) \<^bold>\<and> (\<^bold>\<not>INCONS\<^sup>p) \<^bold>\<and> [RELI\<^sup>d] \<^bold>\<and> [WILL\<^sup>p]\<rfloor>"
 nitpick[satisfy,show_all] nitpick oops (*contingent: p & d independent*)
(*** more tests ***)
(*values in two non-opposed quadrants (noq): consistent*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops (*countermodel found*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [GAIN\<^sup>x] \<^bold>\<and> [EFFI\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" nitpick oops
(*values in two opposed quadrants: inconsistent*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp
(*values in three quadrants: inconsistent*)
lemma "\<lfloor>[WILL\<^sup>x] \<^bold>\<and> [EFFI\<^sup>x] \<^bold>\<and> [RELI\<^sup>x] \<^bold>\<rightarrow> INCONS\<^sup>x\<rfloor>" by simp
(*values in opposed quadrants for different parties: consistent*)
lemma "\<lfloor>[EQUI\<^sup>x] \<^bold>\<and> [GAIN\<^sup>y] \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*cntmdl*)
lemma "\<lfloor>[RESP\<^sup>x] \<^bold>\<and> [STAB\<^sup>y] \<^bold>\<rightarrow> (INCONS\<^sup>x \<^bold>\<or> INCONS\<^sup>y)\<rfloor>" nitpick oops (*cntmdl*)
(*value preferences tests*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>" by blast
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor>" by blast
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x \<^bold>\<prec>\<^sub>v STAB\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<not>\<lfloor>WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" using rBR by auto
lemma "\<lfloor>WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" by auto
lemma "\<lfloor>RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>" by auto
lemma "\<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>WILL\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
lemma "\<lfloor>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor> \<longrightarrow> \<lfloor>RELI\<^sup>x\<^bold>\<oplus>STAB\<^sup>x \<^bold>\<prec>\<^sub>v WILL\<^sup>x\<rfloor>"
  nitpick nitpick[satisfy] oops (*contingent*)
(*basic properties*)
lemma "\<lfloor>\<^bold>\<not>(X \<^bold>\<prec>\<^sub>v X)\<rfloor>" using rBR by auto (*irreflexive*)
lemma "\<lfloor>X \<^bold>\<prec>\<^sub>v Y \<^bold>\<rightarrow> \<^bold>\<not>(Y \<^bold>\<prec>\<^sub>v X)\<rfloor>" nitpick oops (*not asymmetric*)
lemma "\<lfloor>(X \<^bold>\<prec>\<^sub>v Y \<^bold>\<and> Y \<^bold>\<prec>\<^sub>v Z) \<^bold>\<rightarrow> X \<^bold>\<prec>\<^sub>v Z\<rfloor>" nitpick oops (*not transitive*)
end


theory Failures_TickTock_BasicOps

imports
  Failures_TickTock
begin

lemma ttproc2F_DivC_eq_DivF:
  "ttproc2F div\<^sub>C = div\<^sub>F"
  unfolding DivTT_def DivF_def ttproc2F_def by auto

lemma ttproc2F_SkipC_SkipUF:
  "ttproc2F SKIP\<^sub>C = Skip\<^sub>U\<^sub>F"
  unfolding SkipTT_def ttproc2F_def SkipUF_def apply auto
  by force+

lemma ttproc2F_StopC_eq_StopF:
  "ttproc2F STOP\<^sub>C = Stop\<^sub>F"
proof -
  text \<open> Untimed traces \<close>

  have traces:"snd Stop\<^sub>F = snd (ttproc2F STOP\<^sub>C)"
    unfolding StopTT_def ttproc2F_def StopF_def apply auto
      apply (rule exI[where x="[]"], auto)
      apply (simp add: tocks.empty_in_tocks)
    using tocks.cases tt2T.simps(3) tt2T.simps(5) apply blast
    by (metis append.simps(1) append.simps(2) tocks.simps tt2T.simps(5))

  text \<open> Untimed failures \<close>
  have failures:"fst Stop\<^sub>F = fst (ttproc2F STOP\<^sub>C)"
    unfolding StopTT_def ttproc2F_def StopF_def
  proof (auto)
    fix b
    obtain X where X:"Some ([],b) = tt2F [[X]\<^sub>R] \<and> Tock \<notin> X"
      using Some_tt2F_set tt2F_refusal_without_Tock
      by (metis (no_types, lifting) Diff_iff singletonI tt2F_refusal_without_Tock)
    then show "\<exists>y. Some ([], b) = tt2F y \<and> (\<exists>s\<in>tocks {x. x \<noteq> Tock}. y = s \<or> (\<exists>X. y = s @ [[X]\<^sub>R] \<and> Tock \<notin> X))"
      using tocks.empty_in_tocks by fastforce
  next
    fix a b s
    assume a1:"Some (a, b) = tt2F s"
      and a2:"s \<in> tocks {x. x \<noteq> Tock}"
    show "a = []"
      by (metis a1 a2 option.simps(3) tocks.cases tt2F.simps(3) tt2F.simps(8))
  next
    fix a b s X
    assume a1:"Some (a, b) = tt2F (s @ [[X]\<^sub>R])"
     and a2:"s \<in> tocks {x. x \<noteq> Tock}"
     and a3:"Tock \<notin> X"
    show "a = []"
      using a1 apply (cases s, auto)
      by (metis a2 append_Cons list.distinct(1) option.simps(3) tocks.cases tt2F.simps(8))
  qed

  show ?thesis by (simp add: failures traces prod_eq_iff)
qed

lemma ttproc2F_PrefixTT_eq_PrefixF:
  "ttproc2F (PrefixTT e P) = PrefixF e (ttproc2F P)"
  unfolding ttproc2F_def PrefixTT_def PrefixF_def
proof (auto)
  fix a b s
  assume assm1:"Some (a, b) = tt2F s"
    and  assm2:"s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    and  assm3: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
  show "a = []"
    using assm1 assm2 by (metis (mono_tags, lifting) option.simps(3) tocks.cases tt2F.simps(3) tt2F.simps(8))
next
  fix a b s
  assume assm1: "Some (a, b) = tt2F s"
    and  assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    and  assm3: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
    and  assm4: "evt e \<in> b"
  show "False"
    using assm1 assm2 assm3 assm4 by (metis (mono_tags, lifting) option.simps(3) tocks.cases tt2F.simps(3) tt2F.simps(8))
next
  fix a b s X
  assume assm1: "Some (a, b) = tt2F (s @ [[X]\<^sub>R])"
   and   assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3: "Tock \<notin> X"
   and   assm4: "Event e \<notin> X"
   and   assm5: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
  show "a = []"
    using assm1 assm2 by (cases s, auto, metis (mono_tags, lifting) append_Cons list.distinct(1) option.simps(3) tocks.cases tt2F.simps(8))
next
  fix a b s X
  assume assm1: "Some (a, b) = tt2F (s @ [[X]\<^sub>R])"
   and   assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3: "Tock \<notin> X"
   and   assm4: "Event e \<notin> X"
   and   assm5: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
   and   assm6: "evt e \<in> b"
  show "False"
    using assm1 assm2 assm3 assm4 assm6 by (cases s, auto, metis (mono_tags, lifting) append_Cons list.distinct(1) option.simps(3) tocks.cases tt2F.simps(8))
next
  fix a b s
  assume assm1: "Some (a, b) = tt2F s"
   and   assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
  show "a = []"
    using assm1 assm2 by (cases s, auto, metis (mono_tags, lifting) list.distinct(1) option.simps(3) tocks.cases tt2F.simps(8))
next
  fix a b s
  assume assm1: "Some (a, b) = tt2F s"
   and   assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
   and   assm4: "evt e \<in> b"
  show "False"
    using assm1 assm2 by (cases s, auto, metis (mono_tags, lifting) list.distinct(1) option.simps(3) tocks.cases tt2F.simps(8))
next
  fix a b s \<sigma>
  assume assm1: "Some (a, b) = tt2F (s @ [Event e]\<^sub>E # \<sigma>)"
   and   assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3: "\<sigma> \<in> P"
   and   assm4: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
  show "a = []"
  proof (cases s)
    case Nil
    then have "Some (a, b) = tt2F ([Event e]\<^sub>E # \<sigma>)"
      using assm1 by auto
    then obtain fl where fl:"Some (fst fl, b) = Some (evt e # fst fl,snd fl)"
      apply auto
      by (smt assm3 assm4 fst_conv not_Some_eq old.prod.exhaust option.inject option.simps(4) option.simps(5) prod.inject snd_conv)
    then have "a = evt e # fst fl"
      by auto
    then have "\<sigma> \<notin> P"
      using assm4 fl by auto
    then show ?thesis
      using assm3 by auto
  next
    case (Cons z list)
    then show ?thesis using assm1 assm2 apply auto
      by (metis (mono_tags, lifting) append_Cons list.simps(3) option.simps(3) tocks.cases tt2F.simps(8))
  qed
next
  fix a b s \<sigma>
  assume assm1: "Some (a, b) = tt2F (s @ [Event e]\<^sub>E # \<sigma>)"
   and   assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3: "\<sigma> \<in> P"
   and   assm4: "\<forall>s. a = evt e # s \<longrightarrow> (\<forall>y. Some (s, b) = tt2F y \<longrightarrow> y \<notin> P)"
   and   assm5: "evt e \<in> b"
  show "False"
  proof (cases s)
    case Nil
    then have "Some (a, b) = tt2F ([Event e]\<^sub>E # \<sigma>)"
      using assm1 by auto
    then obtain fl where fl:"Some (fst fl, b) = Some (evt e # fst fl,snd fl)"
      apply auto
      by (smt assm3 assm4 fst_conv not_Some_eq old.prod.exhaust option.inject option.simps(4) option.simps(5) prod.inject snd_conv)
    then have "a = evt e # fst fl"
      by auto
    then have "\<sigma> \<notin> P"
      using assm4 fl by auto
    then show ?thesis
      using assm3 by auto
  next
    case (Cons z list)
    then show ?thesis using assm1 assm2 apply auto
      by (metis (mono_tags, lifting) append_Cons list.simps(3) option.simps(3) tocks.cases tt2F.simps(8))
  qed
next
  fix b
  assume assm1:"evt e \<notin> b"
  obtain X where X:"Some ([], b) = tt2F [[X]\<^sub>R]"
    using Some_tt2F_set by auto
  then have "Event e \<notin> X"
    using assm1 by auto
  then show "\<exists>y. Some ([], b) = tt2F y \<and>
             ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. y = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> y = s @ [[X]\<^sub>R])) \<or>
              (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. y = s \<or> (\<exists>\<sigma>\<in>P. y = s @ [Event e]\<^sub>E # \<sigma>)))"
    by (metis (no_types) Diff_iff X \<open>Event e \<notin> X\<close> append.left_neutral singletonI tocks.empty_in_tocks tt2F_refusal_without_Tock)
next
  fix b s y
  assume assm1: "Some (s, b) = tt2F y"
    and  assm2: "y \<in> P"
  obtain z where z:"Some (evt e # s, b) = tt2F (z @ [Event e]\<^sub>E # y) \<and> z = []"
    using assm1
    by (smt append.left_neutral fst_conv option.simps(5) snd_conv tt2F.simps(2))
  then have "\<exists>y. Some (evt e # s, b) = tt2F y \<and> (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. (\<exists>\<sigma>\<in>P. y = s @ [Event e]\<^sub>E # \<sigma>))"
    using assm2 tocks.empty_in_tocks by blast
  then show "\<exists>y. Some (evt e # s, b) = tt2F y \<and>
           ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. y = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> y = s @ [[X]\<^sub>R])) \<or>
            (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. y = s \<or> (\<exists>\<sigma>\<in>P. y = s @ [Event e]\<^sub>E # \<sigma>)))"
    by blast
next
  fix s
  assume assm1: "tt2T s \<noteq> []"
    and  assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  have "tt2T s = []"
    using assm2 tocks.cases tt2T.simps(3) tt2T.simps(5) by blast
  then have "False"
    using assm1 by auto
  then show "\<exists>sa. tt2T s = evt e # sa \<and> (\<exists>y. sa = tt2T y \<and> y \<in> P)"
    by auto
next
  fix s X
  assume assm1:"tt2T (s @ [[X]\<^sub>R]) \<noteq> []"
    and  assm2:"s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    and  assm3:"Tock \<notin> X"
    and  assm4:"Event e \<notin> X"
  have "tt2T s = []"
    using assm2 tocks.cases tt2T.simps(3) tt2T.simps(5) by blast
  then have "tt2T (s @ [[X]\<^sub>R]) = []"
    by (metis (no_types, lifting) append_Cons append_eq_Cons_conv assm2 tocks.simps tt2T.simps(5))
  then have "False"
    using assm1 by auto
  then show "\<exists>sa. tt2T (s @ [[X]\<^sub>R]) = evt e # sa \<and> (\<exists>y. sa = tt2T y \<and> y \<in> P)"
    by auto
next
  fix s
  assume assm1: "tt2T s \<noteq> []"
    and  assm2: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  have "tt2T s = []"
    using assm2 tocks.cases tt2T.simps(3) tt2T.simps(5) by blast
  then have "False"
    using assm1 by auto
  then show "\<exists>sa. tt2T s = evt e # sa \<and> (\<exists>y. sa = tt2T y \<and> y \<in> P)"
    by auto
next
  fix s \<sigma>
  assume assm1:"tt2T (s @ [Event e]\<^sub>E # \<sigma>) \<noteq> []"
   and   assm2:"s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
   and   assm3:"\<sigma> \<in> P"
  have "tt2T s = []"
    using assm2 tocks.cases tt2T.simps(3) tt2T.simps(5) by blast
  then have "tt2T (s @ [Event e]\<^sub>E # \<sigma>) = evt e # tt2T \<sigma>"
    by (metis (mono_tags, lifting) append_Cons append_self_conv2 assm1 assm2 mem_Collect_eq tocks_def tocksp.cases tt2T.simps(2) tt2T.simps(5))
  then show "\<exists>sa. tt2T (s @ [Event e]\<^sub>E # \<sigma>) = evt e # sa \<and> (\<exists>y. sa = tt2T y \<and> y \<in> P)"
    using assm3 by auto
next
  show "\<exists>y. [] = tt2T y \<and>
        ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. y = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> y = s @ [[X]\<^sub>R])) \<or>
         (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. y = s \<or> (\<exists>\<sigma>\<in>P. y = s @ [Event e]\<^sub>E # \<sigma>)))"
    using tocks.empty_in_tocks by force
next
  fix y
  assume assm1: "y \<in> P"
  then show "\<exists>ya. evt e # tt2T y = tt2T ya \<and>
              ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. ya = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> ya = s @ [[X]\<^sub>R])) \<or>
               (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. ya = s \<or> (\<exists>\<sigma>\<in>P. ya = s @ [Event e]\<^sub>E # \<sigma>)))"
    using tocks.empty_in_tocks by force
qed

end


(******************************************************************************
 * Orca: A Functional Correctness Verifier for Imperative Programs
 *       Based on Isabelle/UTP
 *
 * Copyright (c) 2016-2018 Virginia Tech, USA
 *               2016-2018 Technische Universität München, Germany
 *               2016-2018 University of York, UK
 *               2016-2018 Université Paris-Saclay, Univ. Paris-Sud, France
 *
 * This software may be distributed and modified according to the terms of
 * the GNU Lesser General Public License version 3.0 or any later version.
 * Note that NO WARRANTY is provided.
 *
 * See CONTRIBUTORS, LICENSE and CITATION files for details.
 ******************************************************************************)

section \<open>Verification Condition Testing\<close>

theory utp_hoare_rel_total
  imports "../PartialCorrectness/utp_hoare"
begin

definition while_invT :: "'\<alpha> cond \<Rightarrow> '\<alpha> cond \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("while\<^sub>\<bottom> _ invr _ do _ od" 71) where
"while\<^sub>\<bottom> b invr p do S od = while\<^sub>\<bottom> b do S od"

lemma while_wf_hoare_r:
  assumes WF: "wf R"
  assumes I0: "`pre \<Rightarrow> I`"
  assumes induct_step:"\<And> st. \<lbrace>b \<and> I \<and> e =\<^sub>u \<guillemotleft>st\<guillemotright>\<rbrace>Q\<lbrace>I \<and> (e, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright>\<rbrace>\<^sub>u"
  assumes PHI:"`(\<not>b \<and> I) \<Rightarrow> post`"
  shows "\<lbrace>pre\<rbrace>while\<^sub>\<bottom> b invr I do Q od\<lbrace>post\<rbrace>\<^sub>u"
unfolding hoare_r_def while_invT_def while_bot_def
proof (rule pre_weak_rel[of _ "\<lceil>I\<rceil>\<^sub><" ])
  from I0 show "`\<lceil>pre\<rceil>\<^sub>< \<Rightarrow> \<lceil>I\<rceil>\<^sub><`"
    by rel_auto
  show "(\<lceil>I\<rceil>\<^sub>< \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<sqsubseteq> (\<mu> X \<bullet> Q ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
  proof (rule rec_total_utp_rule[where E=e, OF WF])
    show "mono (\<lambda>X. Q ;; X \<triangleleft> b \<triangleright>\<^sub>r II)"
      by (simp add: cond_mono monoI seqr_mono)
    have induct_step': "\<And> st. (\<lceil>b \<and> I \<and>  e =\<^sub>u \<guillemotleft>st\<guillemotright> \<rceil>\<^sub>< \<Rightarrow> (\<lceil>I \<and> (e,\<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<rceil>\<^sub>> )) \<sqsubseteq> Q"
      using induct_step by rel_auto
    with PHI
    show "\<And>st. (\<lceil>I\<rceil>\<^sub>< \<and> \<lceil>e\<rceil>\<^sub>< =\<^sub>u \<guillemotleft>st\<guillemotright> \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<sqsubseteq> Q ;; (\<lceil>I\<rceil>\<^sub>< \<and> (\<lceil>e\<rceil>\<^sub><, \<guillemotleft>st\<guillemotright>)\<^sub>u \<in>\<^sub>u \<guillemotleft>R\<guillemotright> \<Rightarrow> \<lceil>post\<rceil>\<^sub>>) \<triangleleft> b \<triangleright>\<^sub>r II"
      by (rel_auto)
  qed
qed

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005  (modified)   |
            |              September 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_law
imports CSP_T_law_SKIP     CSP_T_law_ref
        CSP_T_law_dist     CSP_T_law_alpha_par
        CSP_T_law_step     CSP_T_law_rep_par
        CSP_T_law_fix
        CSP_T_law_DIV      CSP_T_law_SKIP_DIV
        CSP_T_law_step_ext CSP_T_law_norm
begin

(*-----------------------------------------------------------*
 |                                                           |
 |                 Ext_choice_Int_choice                     |
 |                                                           |
 |  These rules show the difference between models T and F.  |
 |                                                           |
 *-----------------------------------------------------------*)

lemma cspT_Ext_choice_Int_choice:
  "P1 [+] P2 =T[M,M] P1 |~| P2"
apply (simp add: cspT_semantics)
apply (rule order_antisym)
apply (rule, simp add: in_traces)+
done

lemma cspT_Ext_pre_choice_Rep_int_choice:
  "? :X -> Pf =T[M,M] ! x:X .. x -> Pf x"
apply (simp add: cspT_semantics)
apply (rule order_antisym)
apply (rule, simp add: in_traces)
apply (force)
apply (rule, simp add: in_traces)
apply (force)
done

lemmas cspT_Ext_Int = cspT_Ext_choice_Int_choice
                      cspT_Ext_pre_choice_Rep_int_choice

(*********************************************************
            SKIP , DIV  and Internal choice
 *********************************************************)

(*** |~| ***)

lemma cspT_SKIP_DIV_Int_choice:
  "[| P = SKIP | P = DIV ; Q = SKIP | Q = DIV |] ==>
   (P |~| Q) =T[M1,M2] (if (P = SKIP | Q = SKIP) then SKIP else DIV)"
apply (elim disjE)
apply (simp_all)
apply (rule cspT_rw_left)
apply (rule cspT_idem)
apply (rule cspT_reflex)
apply (rule cspT_rw_left)
apply (rule cspT_unit)
apply (rule cspT_reflex)
apply (rule cspT_rw_left)
apply (rule cspT_unit)
apply (rule cspT_reflex)
apply (rule cspT_rw_left)
apply (rule cspT_idem)
apply (rule cspT_reflex)
done

(*** !! ***)

lemma cspT_SKIP_DIV_Rep_int_choice_sum:
  "[| ALL c: sumset C. (Qf c = SKIP | Qf c = DIV) |] ==>
   (!! c:C .. Qf c) =T[M1,M2]
   (if (EX c: sumset C. Qf c = SKIP) then SKIP else DIV)"
apply (case_tac " sumset C={}")
apply (simp add: cspT_Rep_int_choice_empty)
apply (case_tac "ALL c: sumset C. Qf c = DIV")
 apply (simp)
 apply (rule cspT_rw_left)
 apply (rule cspT_Rep_int_choice_const)
 apply (simp)
 apply (force)
 apply (simp)

 apply (simp)
 apply (elim bexE)
 apply (frule_tac x="c" in bspec)
 apply (simp_all)
 apply (intro conjI impI)

  apply (rule cspT_rw_left)
  apply (subgoal_tac
  "!! :C .. Qf =T[M1,M1]
   !! :({c:C. Qf c = SKIP}s Uns {c:C. Qf c ~= SKIP}s) .. Qf")
  apply (simp (no_asm))
  apply (rule cspT_decompo)
   apply (simp)
   apply (simp)

  apply (rule cspT_rw_left)
  apply (rule cspT_Rep_int_choice_union_Int)
  apply (simp)

  apply (rule cspT_rw_left)
  apply (rule cspT_decompo)
  apply (rule cspT_Rep_int_choice_const)
  apply (force)
  apply (rule ballI)
  apply (simp)
  apply (case_tac " sumset ({c:C. Qf c ~= SKIP}s) ={}")
   apply (rule cspT_Rep_int_choice_DIV)
   apply (simp)

   apply (rule cspT_rw_left)
   apply (rule cspT_Rep_int_choice_const)
   apply (simp_all)
   apply (intro allI impI)
   apply (subgoal_tac "Qf ca = DIV")
   apply (simp)
   apply (force)
   apply (simp)

  apply (rule cspT_rw_left)
  apply (rule cspT_unit)
  apply (simp)
done

lemma cspT_SKIP_DIV_Rep_int_choice_nat:
  "[| ALL n:N. (Qf n = SKIP | Qf n = DIV) |] ==>
   (!nat n:N .. Qf n) =T[M1,M2]
   (if (EX n:N. Qf n = SKIP) then SKIP else DIV)"
apply (unfold Rep_int_choice_ss_def)
apply (rule cspT_rw_left)
apply (rule cspT_SKIP_DIV_Rep_int_choice_sum)
apply (auto)
done

lemma cspT_SKIP_DIV_Rep_int_choice_set:
  "[| ALL X:Xs. (Qf X = SKIP | Qf X = DIV) |] ==>
   (!set X:Xs .. Qf X) =T[M1,M2]
   (if (EX X:Xs. Qf X = SKIP) then SKIP else DIV)"
apply (unfold Rep_int_choice_ss_def)
apply (rule cspT_rw_left)
apply (rule cspT_SKIP_DIV_Rep_int_choice_sum)
apply (auto)
done

lemmas cspT_SKIP_DIV_Rep_int_choice =
       cspT_SKIP_DIV_Rep_int_choice_sum
       cspT_SKIP_DIV_Rep_int_choice_nat
       cspT_SKIP_DIV_Rep_int_choice_set

end


(*  Title:      Jinja/Compiler/WellType1.thy

    Author:     Tobias Nipkow
    Copyright   2003 Technische Universitaet Muenchen
*)

section \<open>Well-Formedness of Intermediate Language\<close>

theory J1WellForm
imports "../J/JWellForm" J1
begin

subsection "Well-Typedness"

type_synonym
  env\<^sub>1  = "ty list"   \<comment> \<open>type environment indexed by variable number\<close>

inductive
  WT\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1, expr\<^sub>1     , ty     ] \<Rightarrow> bool"
         ("(_,_ \<turnstile>\<^sub>1/ _ :: _)"   [51,51,51]50)
  and WTs\<^sub>1 :: "[J\<^sub>1_prog,env\<^sub>1, expr\<^sub>1 list, ty list] \<Rightarrow> bool"
         ("(_,_ \<turnstile>\<^sub>1/ _ [::] _)" [51,51,51]50)
  for P :: J\<^sub>1_prog
where

  WTNew\<^sub>1:
  "is_class P C  \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 new C :: Class C"

| WTCast\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class D;  is_class P C;  P \<turnstile> C \<preceq>\<^sup>* D \<or> P \<turnstile> D \<preceq>\<^sup>* C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 Cast C e :: Class C"

| WTVal\<^sub>1:
  "typeof v = Some T \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 Val v :: T"

| WTVar\<^sub>1:
  "\<lbrakk> E!i = T; i < size E \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 Var i :: T"

| WTBinOp\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T\<^sub>2;
     case bop of Eq \<Rightarrow> (P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1) \<and> T = Boolean
               | Add \<Rightarrow> T\<^sub>1 = Integer \<and> T\<^sub>2 = Integer \<and> T = Integer \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"

| WTLAss\<^sub>1:
  "\<lbrakk> E!i = T;  i < size E; P,E \<turnstile>\<^sub>1 e :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 i:=e :: Void"

| WTFAcc\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class C;  P \<turnstile> C sees F:T in D \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<bullet>F{D} :: T"

| WTFAss\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: Class C;  P \<turnstile> C sees F:T in D;  P,E \<turnstile>\<^sub>1 e\<^sub>2 :: T';  P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D} := e\<^sub>2 :: Void"

| WTCall\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Class C; P \<turnstile> C sees M:Ts' \<rightarrow> T = m in D;
    P,E \<turnstile>\<^sub>1 es [::] Ts;  P \<turnstile> Ts [\<le>] Ts' \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 e\<bullet>M(es) :: T"

| WTBlock\<^sub>1:
  "\<lbrakk> is_type P T; P,E@[T] \<turnstile>\<^sub>1 e::T' \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 {i:T; e} :: T'"

| WTSeq\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1::T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2::T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"

| WTCond\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Boolean;  P,E \<turnstile>\<^sub>1 e\<^sub>1::T\<^sub>1;  P,E \<turnstile>\<^sub>1 e\<^sub>2::T\<^sub>2;
    P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<or> P \<turnstile> T\<^sub>2 \<le> T\<^sub>1;  P \<turnstile> T\<^sub>1 \<le> T\<^sub>2 \<longrightarrow> T = T\<^sub>2; P \<turnstile> T\<^sub>2 \<le> T\<^sub>1 \<longrightarrow> T = T\<^sub>1 \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 :: T"

| WTWhile\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: Boolean;  P,E \<turnstile>\<^sub>1 c::T \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 while (e) c :: Void"

| WTThrow\<^sub>1:
  "P,E \<turnstile>\<^sub>1 e :: Class C  \<Longrightarrow>
  P,E \<turnstile>\<^sub>1 throw e :: Void"

| WTTry\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e\<^sub>1 :: T;  P,E@[Class C] \<turnstile>\<^sub>1 e\<^sub>2 :: T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 :: T"

| WTNil\<^sub>1:
  "P,E \<turnstile>\<^sub>1 [] [::] []"

| WTCons\<^sub>1:
  "\<lbrakk> P,E \<turnstile>\<^sub>1 e :: T;  P,E \<turnstile>\<^sub>1 es [::] Ts \<rbrakk>
  \<Longrightarrow>  P,E \<turnstile>\<^sub>1 e#es [::] T#Ts"

(*<*)
declare  WT\<^sub>1_WTs\<^sub>1.intros[intro!]
declare WTNil\<^sub>1[iff]

lemmas WT\<^sub>1_WTs\<^sub>1_induct = WT\<^sub>1_WTs\<^sub>1.induct [split_format (complete)]
  and WT\<^sub>1_WTs\<^sub>1_inducts = WT\<^sub>1_WTs\<^sub>1.inducts [split_format (complete)]

inductive_cases eee[elim!]:
  "P,E \<turnstile>\<^sub>1 Val v :: T"
  "P,E \<turnstile>\<^sub>1 Var i :: T"
  "P,E \<turnstile>\<^sub>1 Cast D e :: T"
  "P,E \<turnstile>\<^sub>1 i:=e :: T"
  "P,E \<turnstile>\<^sub>1 {i:U; e} :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1;;e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 if (e) e\<^sub>1 else e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 while (e) c :: T"
  "P,E \<turnstile>\<^sub>1 throw e :: T"
  "P,E \<turnstile>\<^sub>1 try e\<^sub>1 catch(C i) e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 e\<bullet>F{D} :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
  "P,E \<turnstile>\<^sub>1 new C :: T"
  "P,E \<turnstile>\<^sub>1 e\<bullet>M(es) :: T"
  "P,E \<turnstile>\<^sub>1 [] [::] Ts"
  "P,E \<turnstile>\<^sub>1 e#es [::] Ts"
(*>*)

lemma WTs\<^sub>1_same_size: "\<And>Ts. P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> size es = size Ts"
(*<*)by (induct es type:list) auto(*>*)

lemma WT\<^sub>1_unique:
  "P,E \<turnstile>\<^sub>1 e :: T\<^sub>1 \<Longrightarrow> (\<And>T\<^sub>2. P,E \<turnstile>\<^sub>1 e :: T\<^sub>2 \<Longrightarrow> T\<^sub>1 = T\<^sub>2)" and
  "P,E \<turnstile>\<^sub>1 es [::] Ts\<^sub>1 \<Longrightarrow> (\<And>Ts\<^sub>2. P,E \<turnstile>\<^sub>1 es [::] Ts\<^sub>2 \<Longrightarrow> Ts\<^sub>1 = Ts\<^sub>2)"
(*<*)
apply(induct rule:WT\<^sub>1_WTs\<^sub>1.inducts)
apply blast
apply blast
apply clarsimp
apply blast
apply clarsimp
apply(case_tac bop)
apply clarsimp
apply clarsimp
apply blast
apply (blast dest:sees_field_idemp sees_field_fun)
apply blast
apply (blast dest:sees_method_idemp sees_method_fun)
apply blast
apply blast
apply blast
apply blast
apply clarify
apply blast
apply blast
apply blast
done
(*>*)

lemma assumes wf: "wf_prog p P"
shows WT\<^sub>1_is_type: "P,E \<turnstile>\<^sub>1 e :: T \<Longrightarrow> set E \<subseteq> types P \<Longrightarrow> is_type P T"
and "P,E \<turnstile>\<^sub>1 es [::] Ts \<Longrightarrow> True"
(*<*)
apply(induct rule:WT\<^sub>1_WTs\<^sub>1.inducts)
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (blast intro:nth_mem)
apply(simp split:bop.splits)
apply simp
apply (simp add:sees_field_is_type[OF _ wf])
apply simp
apply(fastforce dest!: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply simp
apply simp
apply blast
apply simp
apply simp
apply simp
apply simp
apply simp
done
(*>*)

subsection\<open>Well-formedness\<close>

\<comment> \<open>Indices in blocks increase by 1\<close>

primrec \<B> :: "expr\<^sub>1 \<Rightarrow> nat \<Rightarrow> bool"
  and \<B>s :: "expr\<^sub>1 list \<Rightarrow> nat \<Rightarrow> bool" where
"\<B> (new C) i = True" |
"\<B> (Cast C e) i = \<B> e i" |
"\<B> (Val v) i = True" |
"\<B> (e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (Var j) i = True" |
"\<B> (e\<bullet>F{D}) i = \<B> e i" |
"\<B> (j:=e) i = \<B> e i" |
"\<B> (e\<^sub>1\<bullet>F{D} := e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (e\<bullet>M(es)) i = (\<B> e i \<and> \<B>s es i)" |
"\<B> ({j:T ; e}) i = (i = j \<and> \<B> e (i+1))" |
"\<B> (e\<^sub>1;;e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (if (e) e\<^sub>1 else e\<^sub>2) i = (\<B> e i \<and> \<B> e\<^sub>1 i \<and> \<B> e\<^sub>2 i)" |
"\<B> (throw e) i = \<B> e i" |
"\<B> (while (e) c) i = (\<B> e i \<and> \<B> c i)" |
"\<B> (try e\<^sub>1 catch(C j) e\<^sub>2) i = (\<B> e\<^sub>1 i \<and> i=j \<and> \<B> e\<^sub>2 (i+1))" |

"\<B>s [] i = True" |
"\<B>s (e#es) i = (\<B> e i \<and> \<B>s es i)"

definition wf_J\<^sub>1_mdecl :: "J\<^sub>1_prog \<Rightarrow> cname \<Rightarrow> expr\<^sub>1 mdecl \<Rightarrow> bool"
where
  "wf_J\<^sub>1_mdecl P C  \<equiv>  \<lambda>(M,Ts,T,body).
    (\<exists>T'. P,Class C#Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
    \<D> body \<lfloor>{..size Ts}\<rfloor> \<and> \<B> body (size Ts + 1)"

lemma wf_J\<^sub>1_mdecl[simp]:
  "wf_J\<^sub>1_mdecl P C (M,Ts,T,body) \<equiv>
    ((\<exists>T'. P,Class C#Ts \<turnstile>\<^sub>1 body :: T' \<and> P \<turnstile> T' \<le> T) \<and>
     \<D> body \<lfloor>{..size Ts}\<rfloor> \<and> \<B> body (size Ts + 1))"
(*<*)by (simp add:wf_J\<^sub>1_mdecl_def)(*>*)

abbreviation "wf_J\<^sub>1_prog == wf_prog wf_J\<^sub>1_mdecl"

end


(*  Title:      HOL/Auth/Yahalom_Bad.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Yahalom Protocol: A Flawed Version\<close>

theory Yahalom_Bad imports Public begin

text\<open>
Demonstrates of why Oops is necessary.  This protocol can be attacked because
it doesn't keep NB secret, but without Oops it can be "verified" anyway.
The issues are discussed in lcp's LICS 2000 invited lecture.
\<close>

inductive_set yahalom :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> yahalom"

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "[| evsf \<in> yahalom;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> yahalom"

         (*A message that has been sent can be received by the
           intended recipient.*)
 | Reception: "[| evsr \<in> yahalom;  Says A B X \<in> set evsr |]
               ==> Gets B X # evsr \<in> yahalom"

         (*Alice initiates a protocol run*)
 | YM1:  "[| evs1 \<in> yahalom;  Nonce NA \<notin> used evs1 |]
          ==> Says A B \<lbrace>Agent A, Nonce NA\<rbrace> # evs1 \<in> yahalom"

         (*Bob's response to Alice's message.*)
 | YM2:  "[| evs2 \<in> yahalom;  Nonce NB \<notin> used evs2;
             Gets B \<lbrace>Agent A, Nonce NA\<rbrace> \<in> set evs2 |]
          ==> Says B Server
                  \<lbrace>Agent B, Nonce NB, Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
                # evs2 \<in> yahalom"

         (*The Server receives Bob's message.  He responds by sending a
            new session key to Alice, with a packet for forwarding to Bob.*)
 | YM3:  "[| evs3 \<in> yahalom;  Key KAB \<notin> used evs3;  KAB \<in> symKeys;
             Gets Server
                  \<lbrace>Agent B, Nonce NB, Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
               \<in> set evs3 |]
          ==> Says Server A
                   \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key KAB, Nonce NA, Nonce NB\<rbrace>,
                     Crypt (shrK B) \<lbrace>Agent A, Key KAB\<rbrace>\<rbrace>
                # evs3 \<in> yahalom"

         (*Alice receives the Server's (?) message, checks her Nonce, and
           uses the new session key to send Bob his Nonce.  The premise
           A \<noteq> Server is needed to prove Says_Server_not_range.*)
 | YM4:  "[| evs4 \<in> yahalom;  A \<noteq> Server;  K \<in> symKeys;
             Gets A \<lbrace>Crypt(shrK A) \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>, X\<rbrace>
                \<in> set evs4;
             Says A B \<lbrace>Agent A, Nonce NA\<rbrace> \<in> set evs4 |]
          ==> Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> # evs4 \<in> yahalom"

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare Fake_parts_insert_in_Un  [dest]
declare analz_into_parts [dest]

text\<open>A "possibility property": there are traces that reach the end\<close>
lemma "[| A \<noteq> Server; Key K \<notin> used []; K \<in> symKeys |]
       ==> \<exists>X NB. \<exists>evs \<in> yahalom.
              Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] yahalom.Nil
                    [THEN yahalom.YM1, THEN yahalom.Reception,
                     THEN yahalom.YM2, THEN yahalom.Reception,
                     THEN yahalom.YM3, THEN yahalom.Reception,
                     THEN yahalom.YM4])
apply (possibility, simp add: used_Cons)
done

subsection\<open>Regularity Lemmas for Yahalom\<close>

lemma Gets_imp_Says:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |] ==> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule yahalom.induct, auto)

(*Must be proved separately for each protocol*)
lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> yahalom |]  ==> X \<in> knows Spy evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

declare Gets_imp_knows_Spy [THEN analz.Inj, dest]

subsection\<open>For reasoning about the encrypted portion of messages\<close>

text\<open>Lets us treat YM4 using a similar argument as for the Fake case.\<close>
lemma YM4_analz_knows_Spy:
     "[| Gets A \<lbrace>Crypt (shrK A) Y, X\<rbrace> \<in> set evs;  evs \<in> yahalom |]
      ==> X \<in> analz (knows Spy evs)"
by blast

lemmas YM4_parts_knows_Spy =
       YM4_analz_knows_Spy [THEN analz_into_parts]

text\<open>Theorems of the form \<^term>\<open>X \<notin> parts (knows Spy evs)\<close> imply
            that NOBODY sends messages containing X!\<close>

text\<open>Spy never sees a good agent's shared key!\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> yahalom ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
apply (erule yahalom.induct, force,
       drule_tac [6] YM4_parts_knows_Spy, simp_all, blast+)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> yahalom ==> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> yahalom|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

text\<open>Nobody can have used non-existent keys!
    Needed to apply \<open>analz_insert_Key\<close>\<close>
lemma new_keys_not_used [simp]:
    "[|Key K \<notin> used evs; K \<in> symKeys; evs \<in> yahalom|]
     ==> K \<notin> keysFor (parts (spies evs))"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake\<close>
apply (force dest!: keysFor_parts_insert, auto)
done

subsection\<open>Secrecy Theorems\<close>

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) ==>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.
****)

subsection\<open>Session keys are not used to encrypt other session keys\<close>

lemma analz_image_freshK [rule_format]:
 "evs \<in> yahalom ==>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
by (erule yahalom.induct,
    drule_tac [7] YM4_analz_knows_Spy, analz_freshK, spy_analz, blast)

lemma analz_insert_freshK:
     "[| evs \<in> yahalom;  KAB \<notin> range shrK |] ==>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The Key K uniquely identifies the Server's  message.\<close>
lemma unique_session_keys:
     "[| Says Server A
          \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>, X\<rbrace> \<in> set evs;
        Says Server A'
          \<lbrace>Crypt (shrK A') \<lbrace>Agent B', Key K, na', nb'\<rbrace>, X'\<rbrace> \<in> set evs;
        evs \<in> yahalom |]
     ==> A=A' \<and> B=B' \<and> na=na' \<and> nb=nb'"
apply (erule rev_mp, erule rev_mp)
apply (erule yahalom.induct, simp_all)
txt\<open>YM3, by freshness, and YM4\<close>
apply blast+
done

text\<open>Crucial secrecy property: Spy does not see the keys sent in msg YM3\<close>
lemma secrecy_lemma:
     "[| A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Says Server A
            \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
              Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
           \<in> set evs \<longrightarrow>
          Key K \<notin> analz (knows Spy evs)"
apply (erule yahalom.induct, force, drule_tac [6] YM4_analz_knows_Spy)
apply (simp_all add: pushes analz_insert_eq analz_insert_freshK, spy_analz)  (*Fake*)
apply (blast dest: unique_session_keys)  (*YM3*)
done

text\<open>Final version\<close>
lemma Spy_not_see_encrypted_key:
     "[| Says Server A
            \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
              Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: secrecy_lemma)

subsection\<open>Security Guarantee for A upon receiving YM3\<close>

text\<open>If the encrypted message appears then it originated with the Server\<close>
lemma A_trusts_YM3:
     "[| Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace> \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> yahalom |]
       ==> Says Server A
            \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
              Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
           \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM3\<close>
apply blast+
done

text\<open>The obvious combination of \<open>A_trusts_YM3\<close> with
  \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma A_gets_good_key:
     "[| Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace> \<in> parts (knows Spy evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: A_trusts_YM3 Spy_not_see_encrypted_key)

subsection\<open>Security Guarantees for B upon receiving YM4\<close>

text\<open>B knows, by the first part of A's message, that the Server distributed
  the key for A and B.  But this part says nothing about nonces.\<close>
lemma B_trusts_YM4_shrK:
     "[| Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>NA NB. Says Server A
                      \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, Nonce NA, Nonce NB\<rbrace>,
                        Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
                     \<in> set evs"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy, simp_all)
txt\<open>Fake, YM3\<close>
apply blast+
done

subsection\<open>The Flaw in the Model\<close>

text\<open>Up to now, the reasoning is similar to standard Yahalom.  Now the
    doubtful reasoning occurs.  We should not be assuming that an unknown
    key is secure, but the model allows us to: there is no Oops rule to
    let session keys become compromised.\<close>

text\<open>B knows, by the second part of A's message, that the Server distributed
  the key quoting nonce NB.  This part says nothing about agent names.
  Secrecy of K is assumed; the valid Yahalom proof uses (and later proves)
  the secrecy of NB.\<close>
lemma B_trusts_YM4_newK [rule_format]:
     "[|Key K \<notin> analz (knows Spy evs);  evs \<in> yahalom|]
      ==> Crypt K (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
          (\<exists>A B NA. Says Server A
                      \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K,
                                Nonce NA, Nonce NB\<rbrace>,
                        Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
                     \<in> set evs)"
apply (erule rev_mp)
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt\<open>Fake\<close>
apply blast
txt\<open>YM3\<close>
apply blast
txt\<open>A is uncompromised because NB is secure
  A's certificate guarantees the existence of the Server message\<close>
apply (blast dest!: Gets_imp_Says Crypt_Spy_analz_bad
             dest: Says_imp_spies
                   parts.Inj [THEN parts.Fst, THEN A_trusts_YM3])
done

text\<open>B's session key guarantee from YM4.  The two certificates contribute to a
  single conclusion about the Server's message.\<close>
lemma B_trusts_YM4:
     "[| Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         Says B Server
           \<lbrace>Agent B, Nonce NB, Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
       ==> \<exists>na nb. Says Server A
                   \<lbrace>Crypt (shrK A) \<lbrace>Agent B, Key K, na, nb\<rbrace>,
                     Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>\<rbrace>
             \<in> set evs"
by (blast dest: B_trusts_YM4_newK B_trusts_YM4_shrK Spy_not_see_encrypted_key
                unique_session_keys)

text\<open>The obvious combination of \<open>B_trusts_YM4\<close> with
  \<open>Spy_not_see_encrypted_key\<close>\<close>
lemma B_gets_good_key:
     "[| Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         Says B Server
           \<lbrace>Agent B, Nonce NB, Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: B_trusts_YM4 Spy_not_see_encrypted_key)

(*** Authenticating B to A: these proofs are not considered.
     They are irrelevant to showing the need for Oops. ***)

(*** Authenticating A to B using the certificate Crypt K (Nonce NB) ***)

text\<open>Assuming the session key is secure, if both certificates are present then
  A has said NB.  We can't be sure about the rest of A's message, but only
  NB matters for freshness.\<close>
lemma A_Said_YM3_lemma [rule_format]:
     "evs \<in> yahalom
      ==> Key K \<notin> analz (knows Spy evs) \<longrightarrow>
          Crypt K (Nonce NB) \<in> parts (knows Spy evs) \<longrightarrow>
          Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
          B \<notin> bad \<longrightarrow>
          (\<exists>X. Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs)"
apply (erule yahalom.induct, force,
       frule_tac [6] YM4_parts_knows_Spy)
apply (analz_mono_contra, simp_all)
txt\<open>Fake\<close>
apply blast
txt\<open>YM3: by \<open>new_keys_not_used\<close>, the message
   \<^term>\<open>Crypt K (Nonce NB)\<close> could not exist\<close>
apply (force dest!: Crypt_imp_keysFor)
txt\<open>YM4: was \<^term>\<open>Crypt K (Nonce NB)\<close> the very last message?
    If not, use the induction hypothesis\<close>
apply (simp add: ex_disj_distrib)
txt\<open>yes: apply unicity of session keys\<close>
apply (blast dest!: Gets_imp_Says A_trusts_YM3 B_trusts_YM4_shrK
                    Crypt_Spy_analz_bad
             dest: Says_imp_knows_Spy [THEN parts.Inj] unique_session_keys)
done

text\<open>If B receives YM4 then A has used nonce NB (and therefore is alive).
  Moreover, A associates K with NB (thus is talking about the same run).
  Other premises guarantee secrecy of K.\<close>
lemma YM4_imp_A_Said_YM3 [rule_format]:
     "[| Gets B \<lbrace>Crypt (shrK B) \<lbrace>Agent A, Key K\<rbrace>,
                  Crypt K (Nonce NB)\<rbrace> \<in> set evs;
         Says B Server
           \<lbrace>Agent B, Nonce NB, Crypt (shrK B) \<lbrace>Agent A, Nonce NA\<rbrace>\<rbrace>
           \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> yahalom |]
      ==> \<exists>X. Says A B \<lbrace>X, Crypt K (Nonce NB)\<rbrace> \<in> set evs"
by (blast intro!: A_Said_YM3_lemma
          dest: Spy_not_see_encrypted_key B_trusts_YM4 Gets_imp_Says)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* License: BSD, terms see file ./LICENSE *)

theory Addr_Type
imports "Word_Lib.WordSetup"
begin

type_synonym addr_bitsize = "32"
type_synonym addr = "addr_bitsize word"
definition addr_bitsize :: nat where "addr_bitsize \<equiv> 32"
definition addr_align :: nat where "addr_align \<equiv> 2"
declare addr_align_def[simp]

definition addr_card :: nat where
  "addr_card \<equiv> card (UNIV::addr set)"

declare addr_bitsize_def[simp]

lemma addr_card:
  "addr_card = 2^addr_bitsize"
  by (simp add: addr_card_def card_word)

lemma len_of_addr_card:
  "2 ^ len_of TYPE(addr_bitsize) = addr_card"
  by (simp add: addr_card)

lemma of_nat_addr_card [simp]:
  "of_nat addr_card = (0::addr)"
  by (simp add: addr_card)

end


theory State_Networks
  imports Networks TA_Impl.Normalized_Zone_Semantics_Impl
    TA_Library.More_Methods
begin

chapter \<open>Networks of Timed Automata with Discrete State\<close>

unbundle no_library_syntax

section \<open>Networks of Timed Automata with Shared State\<close>

subsection \<open>Syntax and Operational Semantics\<close>

(* XXX Update text *)
text \<open>
  We extend Networks of Timed Automata with arbitrary shared (global) state.
  Syntactically, this extension is very simple.
  We can just use the free action label slot to annotate edges with a guard
  and an update function on discrete states.
  The slightly more clumsy part is adding invariants for discrete states
  by directly specifying an invariant annotating function.
\<close>

type_synonym
  ('a, 'c, 'time, 's, 'st) transition =
  "'s * ('st \<Rightarrow> ('c, 'time) cconstraint) * 'a * ('st \<Rightarrow> 'c list) * 's"

type_synonym
  ('a, 'c, 'time, 's, 'st) sta = "('a, 'c, 'time, 's, 'st) transition set * ('c, 'time, 's) invassn"

type_synonym
  ('a, 'c, 't, 's, 'st) snta =
  "('a act \<times> ('st \<Rightarrow> bool) \<times> ('st \<Rightarrow> 'st option), 'c, 't, 's, 'st) sta list \<times> ('s \<Rightarrow> 'st \<Rightarrow> bool) list"

(*
type_synonym
  ('a, 'c, 'time, 's) unta = "programc \<times> ('a act, 'c, 'time, 's) uta list"

type_synonym
  ('a, 'c, 't, 's, 'st) snta =
  "('a, ('st \<Rightarrow> bool) \<times> ('st \<Rightarrow> 'st), 'c, 't, 's) nta \<times> ('s \<Rightarrow> 'st \<Rightarrow> bool) list"
*)

text \<open>
  Semantic states now consist of three things:
  a list of process locations, the shared state, and a clock valuation.
  The semantic extension then is also obvious: we can take the same transitions
  as in the network without shared state, however we have to add state updates
  and checks for guards on the shared state.
  The updates on discrete state for synchronizing transitions are in the same order as in UPPAAL
  (output before input).
\<close>

datatype 'b label = Del | Act 'b | Syn 'b

inductive step_sn ::
  "('a, 'c, 't, 's, 'st) snta \<Rightarrow> 's list \<Rightarrow> 'st \<Rightarrow> ('c, ('t::time)) cval \<Rightarrow> 'a label
  \<Rightarrow> 's list \<Rightarrow> 'st \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
  ("_ \<turnstile> \<langle>_, _, _\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>_, _, _\<rangle>" [61,61,61,61,61] 61)
where
  step_sn_t:
    "(N, I) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L, s, u \<oplus> d\<rangle>"
    if "\<forall> p \<in> {..<length N}. u \<oplus> d \<turnstile> snd (N ! p) (L ! p)"
       "d \<ge> 0" "length N = length I" |
  step_sn_i:
    "(N, I) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Act a\<^esub> \<langle>L', s', u'\<rangle>"
    if "(l, g, (Sil a, c, m), f, l') \<in> fst (N!p)"
       "u \<turnstile> g s" "\<forall> p \<in> {..<length N}. u' \<turnstile> snd (N!p) (L'!p)"
       "r = f s"
       "L!p = l" "p < length L" "L' = L[p := l']" "u' = [r\<rightarrow>0]u"
       "c s" "\<forall> p < length I. (I ! p) (L' ! p) s'" "Some s' = m s"
       "length N = length I" |
  step_sn_s:
    "(N, I) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Syn a\<^esub> \<langle>L', s', u'\<rangle>"
    if "(l1, g1, (In a, ci, mi), f1, l1') \<in> fst (N!p)"
       "(l2, g2, (Out a, co, mo), f2, l2') \<in> fst (N!q)" "u \<turnstile> g1 s" "u \<turnstile> g2 s"
       "\<forall> p \<in> {..<length N}. u' \<turnstile> snd (N!p) (L'!p)"
       "r1 = f1 s" "r2 = f2 s"
       "L!p = l1" "L!q = l2" "p < length L" "q < length L" "p \<noteq> q"
       "L' = L[p := l1', q := l2']" "u' = [(r1 @ r2)\<rightarrow>0]u"
       "ci s" "co s" "\<forall> p < length I. (I ! p) (L' ! p) s'"
       "Some so = mo s" "Some s' = mi so" "length N = length I"

inductive_cases[elim!]: "N \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Syn a\<^esub> \<langle>L', s', u'\<rangle>"

inductive steps_sn ::
  "('a, 'c, 't, 's, 'st) snta \<Rightarrow> 's list \<Rightarrow> 'st \<Rightarrow> ('c, ('t::time)) cval
  \<Rightarrow> 's list \<Rightarrow> 'st \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _, _\<rangle> \<rightarrow>* \<langle>_, _, _\<rangle>" [61, 61, 61,61,61] 61)
where
  refl: "N \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L, s, u\<rangle>" |
  step: "N \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle> \<Longrightarrow> N \<turnstile> \<langle>L', s', u'\<rangle> \<rightarrow>\<^bsub>l\<^esub> \<langle>L'', s'', u''\<rangle>
        \<Longrightarrow> N \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L'', s'', u''\<rangle>"

declare steps_sn.intros[intro]

lemma stepI2:
  "N \<turnstile> \<langle>l, s, u\<rangle> \<rightarrow>* \<langle>l'', s'', u''\<rangle>" if
  "N \<turnstile> \<langle>l', s', u'\<rangle> \<rightarrow>* \<langle>l'', s'', u''\<rangle>" "N \<turnstile> \<langle>l, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>l', s', u'\<rangle>"
  using that
  apply induction
   apply rule
    apply (rule refl)
   apply assumption
  apply simp
  by (rule; assumption)

abbreviation state_set :: "('a, 'c, 't, 's, 'st) transition set \<Rightarrow> 's set" where
  "state_set T \<equiv> fst ` T \<union> (snd o snd o snd o snd) ` T"

subsection \<open>Product Automaton\<close>

locale Prod_TA_Defs =
  fixes A :: "('a, 'c, 't, 's, 'st) snta"
begin

definition
  "T_s p s = {(l, g s, a, f s, l') | l g a f l'. (l, g, a, f, l') \<in> fst (fst A ! p)}"

definition
  "N_s s = map (\<lambda> p. (T_s p s, snd (fst A ! p))) [0..<length (fst A)]"

abbreviation "P \<equiv> snd A"

definition "p \<equiv> length (fst A)"

abbreviation "product s \<equiv> Product_TA_Defs.product_ta (N_s s)"

abbreviation "T' s \<equiv> trans_of (product s)"
abbreviation "I' s \<equiv> inv_of (product s)"

definition
  "prod_trans_i =
    {((L, s), g, a, r, (L', s')) | L s g c a r m L' s'.
     (\<forall> q < p. (P ! q) (L ! q) s) \<and> (\<forall> q < p. (P ! q) (L' ! q) s')
     \<and> (L, g, (a, Networks.label.Act (c, m)), r, L') \<in> T' s \<and> c s \<and> Some s' = m s}"

definition
  "prod_trans_s =
    {((L, s), g, a, r, (L', s')) | L s g ci co a r mi mo L' s' so.
      ci s \<and> co s
      \<and> (\<forall> q < p. (P ! q) (L ! q) s) \<and> (\<forall> q < p. (P ! q) (L' ! q) s')
      \<and> (L, g, (a, Networks.label.Syn (ci, mi) (co, mo)), r, L') \<in> T' s
      \<and> Some so = mo s
      \<and> Some s' = mi so
    }"

  definition
    "prod_trans \<equiv> prod_trans_i \<union> prod_trans_s"

  definition
    "prod_invariant \<equiv> \<lambda> (L, s). I' s L"

  definition prod_ta :: "('a, 'c, 't, 's list \<times> 'st) ta" where
    "prod_ta \<equiv> (prod_trans, prod_invariant)"

  lemma prod_ta_cases:
    assumes "prod_ta \<turnstile> L \<longrightarrow>\<^bsup>g,a,r\<^esup> L'"
    shows "(L, g, a, r, L') \<in> prod_trans_i \<or> (L, g, a, r, L') \<in> prod_trans_s"
    using assms unfolding prod_ta_def trans_of_def prod_trans_def by auto

  lemma inv_of_simp:
    "inv_of prod_ta (L, s) = I' s L"
    unfolding inv_of_def prod_ta_def prod_invariant_def by simp

  lemma I'_simp:
    "I' s L = I' s' L"
    unfolding Product_TA_Defs.product_ta_def inv_of_def Product_TA_Defs.product_invariant_def N_s_def
    apply simp
    apply (rule arg_cong[where f = concat])
    by simp

  lemma collect_clki_prod_invariant:
    "Timed_Automata.collect_clki prod_invariant = Timed_Automata.collect_clki (I' s)"
    unfolding prod_invariant_def Timed_Automata.collect_clki_def
    apply (simp split: prod.split)
    apply safe
     apply (subst (asm) I'_simp[where s' = s])
    by auto

  lemma collect_clki_prod_invariant':
    "Timed_Automata.collect_clki prod_invariant
    \<subseteq> \<Union> {Timed_Automata.collect_clki (snd (fst A ! p)) | p. p < length (fst A)}"
    unfolding collect_clki_prod_invariant[of s]
    unfolding inv_of_def Product_TA_Defs.product_ta_def
    unfolding Product_TA_Defs.product_invariant_def
    unfolding inv_of_def N_s_def
    unfolding Timed_Automata.collect_clki_def
    unfolding collect_clock_pairs_def
    by auto

  lemma collect_clkt_prod_trans_subs:
    "Timed_Automata.collect_clkt prod_trans \<subseteq> Timed_Automata.collect_clkt (\<Union> (T' ` UNIV))"
    unfolding Timed_Automata.collect_clkt_def prod_trans_def prod_trans_i_def prod_trans_s_def
    by fastforce

  lemma collect_clkvt_prod_trans_subs:
    "collect_clkvt prod_trans \<subseteq> collect_clkvt (\<Union> (T' ` UNIV))"
    unfolding collect_clkvt_def prod_trans_def prod_trans_i_def prod_trans_s_def by fastforce

lemma T_simp:
  "T ! q = trans_of (N ! q)" if "q < length N"
  using that oops

  (*
lemma prod_state_set_subs:
  assumes "l \<in> state_set T'" "q < p"
  shows "l ! q \<in> state_set (trans_of (N ! q))"
  using assms
  apply (simp only: T_simp[symmetric] p_def)
  by (rule product_state_set_subs; simp add: product_ta_def trans_of_def)
*)

abbreviation "N \<equiv> fst A"

context
  fixes Q
  assumes finite_state:
    "\<forall> l. \<forall> q < p. (P ! q) l s \<longrightarrow> Q s"
    "finite {s. Q s}"
      and finite_trans: "\<forall> A \<in> set N. finite (fst A)"
      and p_gt_0: "p > 0"
begin

  lemma finite_state':
    "finite {s. \<forall>q<p. (P ! q) (L ! q) s}" (is "finite ?S")
  proof -
    from p_gt_0 obtain q where "q < p" by blast
    then have "?S \<subseteq> {s. Q s}" using finite_state(1) by auto
    moreover have "finite \<dots>" by (rule finite_state(2))
    ultimately show ?thesis by (rule finite_subset)
  qed

  lemma finite_trans':
    "\<forall>A\<in>set (N_s s). finite (trans_of A)"
  unfolding N_s_def apply auto
    unfolding trans_of_def T_s_def
    apply simp
    apply (drule nth_mem)
    using finite_trans
    using [[simproc add: finite_Collect]]
    apply auto
    apply (rule finite_imageI)
    apply (rule finite_vimageI)
     apply simp
    unfolding inj_on_def by auto

  lemma finite_states:
    "finite (Product_TA_Defs.states (N_s s))"
    using finite_trans' by (rule Product_TA_Defs.finite_states)

  lemma
    "finite (T' s)"
    using finite_trans' by (rule Product_TA_Defs.finite_trans_of_product)

  (* XXX Duplicated proof, what is the better way? *)
  lemma finite_product_1:
    "finite (T' s)"
    unfolding product_def
    unfolding trans_of_def Product_TA_Defs.product_ta_def
    apply simp
    unfolding Product_TA_Defs.product_trans_def
  proof safe
    have "Product_TA_Defs.product_trans_i (N_s s)
        \<subseteq> {(L, g, (a, Networks.label.Act (aa, b)), r, L[p := l']) |L p g a aa b r l'.
            L \<in> Product_TA_Defs.states (N_s s) \<and> p < length (N_s s) \<and>
            (L ! p, g, (Sil a, aa, b), r, l') \<in> \<Union> (trans_of ` set (N_s s))}"
      unfolding Product_TA_Defs.product_trans_i_def
      by (fastforce simp: Product_TA_Defs.states_length)
    moreover have "finite \<dots>"
      apply defer_ex
      using finite_states[of s] apply clarsimp
      apply (subst finite_Collect_bounded_ex_6)
      subgoal premises prems for y y'
      proof -
        (* XXX Rewriting could be automated -- consider approach taken in next case *)
        have "
              {(a, b, c, d, e, f). \<exists>x\<in>set (N_s s). x \<turnstile> y ! y' \<longrightarrow>\<^bsup>a,(Sil b, c, d),e\<^esup> f}
            = {xx. \<exists> x a b c d e f. x\<in>set (N_s s) \<and> x \<turnstile> y ! y' \<longrightarrow>\<^bsup>a,(Sil b, c, d),e\<^esup> f
                   \<and> xx = (a, b, c, d, e, f)}"
          by force
        moreover have "finite \<dots>" (* XXX finite_Collect_bounded_ex is not crucial here *)
          using finite_trans'[of s]
          using [[simproc add: finite_Collect]]
          by (auto simp: inj_on_def intro: finite_vimageI simp del: finite_Collect_bounded_ex)
        ultimately show ?thesis by simp
      qed
      by auto
    ultimately show "finite (Product_TA_Defs.product_trans_i (N_s s))" by (rule finite_subset)
  next
    have "Product_TA_Defs.product_trans_s (N_s s)
        \<subseteq> {(L, g1 @ g2, (a, Networks.label.Syn b1 b2), r1 @ r2, L[p := l1', q := l2']) |
              L p q g1 g2 a b1 b2 r1 r2 l1' l2'.
              L \<in> Product_TA_Defs.states (N_s s) \<and>
              p < length (N_s s) \<and> q < length (N_s s) \<and>
              (L ! p, g1, (In a, b1), r1, l1') \<in> map trans_of (N_s s) ! p \<and>
              (L ! q, g2, (Out a, b2), r2, l2') \<in> map trans_of (N_s s) ! q \<and> p \<noteq> q}"
      unfolding Product_TA_Defs.product_trans_s_def
      by (fastforce simp: Product_TA_Defs.states_length)
    moreover have "finite \<dots>"
      apply defer_ex
      using finite_states[of s]
      apply clarsimp
      subgoal
        apply (mini_existential, simp)
        apply (mini_existential, simp)
        apply (mini_existential, simp)
        apply (mini_existential, simp)
        apply (subst finite_Collect_bounded_ex_6)
        subgoal
          using [[simproc add: finite_Collect]] finite_trans'[of s]
          by (auto simp: inj_on_def intro: finite_vimageI)
        apply safe
        apply (subst finite_Collect_bounded_ex_5)
        subgoal
          using [[simproc add: finite_Collect]] finite_trans'[of s]
          by (auto 4 3 simp: simp: inj_on_def intro: finite_vimageI)
        by auto
      done
    ultimately show "finite (Product_TA_Defs.product_trans_s (N_s s))" by (rule finite_subset)
  qed

  lemma prod_trans_i_alt_def:
    "prod_trans_i =
      {((L, s), g, a, r, (L', s')) | L s g c a r m L' s'.
       (L, g, (a, Networks.label.Act (c, m)), r, L') \<in> T' s \<and>
       (\<forall> q < p. (P ! q) (L ! q) s) \<and> (\<forall> q < p. (P ! q) (L' ! q) s')
       \<and> c s \<and> Some s' = m s}"
    unfolding prod_trans_i_def by (safe; metis)

  (* XXX Wierd proof, should there be some automation for this? *)
  lemma Some_finite:
    "finite {x. Some x = y}"
    using not_finite_existsD by fastforce

  lemma finite_prod_trans:
    "finite prod_trans" if "p > 0"
    unfolding prod_trans_def
  proof safe
    have "prod_trans_i \<subseteq>
        {((L, s), g, a, r, (L', s')) | L s g c a r m L' s'.
         Q s \<and>
         (L, g, (a, Networks.label.Act (c, m)), r, L') \<in> T' s \<and>
         (\<forall> q < p. (P ! q) (L ! q) s) \<and> (\<forall> q < p. (P ! q) (L' ! q) s')
         \<and> c s \<and> Some s' = m s}
      "
      unfolding prod_trans_i_alt_def
      using finite_state(1) p_gt_0 by force
    moreover have
      "finite \<dots>"
      apply defer_ex
      apply (mini_existential, simp only: ex_simps)
      using finite_state(2) apply clarsimp
      apply (subst finite_Collect_bounded_ex_7)
      using [[simproc add: finite_Collect]] finite_state' finite_product_1
      by (auto 4 3 simp: inj_on_def intro: finite_vimageI)
    ultimately show "finite prod_trans_i" by (rule finite_subset)
  next
    have "prod_trans_s \<subseteq>
        {((L, s), g, a, r, (L', s')) | L s g ci co a r mi mo L' s' so.
          Q s \<and>
          product s \<turnstile> L \<longrightarrow>\<^bsup>g,(a, Networks.label.Syn (ci, mi) (co, mo)),r\<^esup> L' \<and>
          (\<forall>q<p. (P ! q) (L ! q) s) \<and> (\<forall>q<p. (P ! q) (L' ! q) s') \<and>
          ci s \<and> co s \<and> Some so = mo s \<and> Some s' = mi so}
      "
      unfolding prod_trans_s_def
      using finite_state(1) p_gt_0 by fastforce
    moreover have
      "finite \<dots>"
      apply defer_ex
      apply (mini_existential, simp only: ex_simps)
      using finite_state(2) apply clarsimp
      apply (subst finite_Collect_bounded_ex_9)

      subgoal
        using [[simproc add: finite_Collect]] finite_state' finite_product_1
        by (auto 4 3 simp: inj_on_def intro: finite_vimageI)[]

      apply safe
      subgoal for s a b c d e f g h i
        apply (rule finite_subset[where B =
              "(\<lambda> s'. ((a, s), b, e, f, i, s')) ` { s'. \<exists> so. Some so = h s \<and> Some s' = g so}"
              ])
         apply force
        apply (rule finite_imageI)
        apply (subst finite_Collect_bounded_ex)
        by (force intro: Some_finite)+
      done
    ultimately show "finite prod_trans_s" by (rule finite_subset)
  qed

end (* End of context for finiteness of automaton *)

  abbreviation "states' s \<equiv> Product_TA_Defs.states (N_s s)"

  lemma N_s_length:
    "length (N_s s) = p"
    unfolding N_s_def p_def by simp

end (* End locale for product TA definition *)

thm Prod_TA_Defs.N_s_length

locale Prod_TA_Defs' =
  Prod_TA_Defs A for A :: "('a, 'c, 't :: time, 's, 'st) snta"
begin

lemma A_unfold:
  "A \<equiv> (N, P)"
  by auto

lemma network_step_delay:
  assumes step: "(N, P) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', s', u'\<rangle>" and len: "length L = p"
  shows "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Networks.label.Del\<^esub> \<langle>L', u'\<rangle>"
  subgoal
    using step
    apply cases
    subgoal
      apply simp
      apply (rule step_n_t)
      subgoal
        unfolding N_s_def by (auto simp: inv_of_def)
      apply assumption
      done
    done
  done

lemma network_step_silent:
  assumes step: "(N, P) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Act a\<^esub> \<langle>L', s', u'\<rangle>" and len: "length L = p"
  obtains a where "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Networks.label.Act a\<^esub> \<langle>L', u'\<rangle>"
  subgoal premises prems
    using step
    apply cases
    subgoal
      apply (rule prems)
      apply (rule step_n_i)
      unfolding N_s_def T_s_def by (auto 4 0 simp: trans_of_def inv_of_def len p_def)
    done
  done

lemma network_step_sync:
  assumes step: "(N, P) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Syn a\<^esub> \<langle>L', s', u'\<rangle>" and len: "length L = p"
  obtains a b where "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Networks.label.Syn a b\<^esub> \<langle>L', u'\<rangle>"
  subgoal premises prems
    using step
    apply cases
    subgoal
      subgoal premises A
        apply (rule prems)
        apply (rule step_n_s)
                   defer
                   defer
                   apply (rule A; fail)
                  apply (rule A(4); fail)
        subgoal
          using A unfolding N_s_def by (auto simp: inv_of_def len)
                defer
                defer
                apply (rule A; fail)
               apply (rule A(11); fail)
        using A unfolding N_s_def T_s_def by (auto 4 0 simp: trans_of_def len p_def)
      done
    done
  done

lemma network_step:
  assumes step: "(N, P) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>" and len: "length L = p"
  obtains a where "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', u'\<rangle>"
  subgoal
    using step
    apply (cases a; simp)
      apply (rule that, erule network_step_delay[OF _ len, simplified])
     apply (erule network_step_silent[OF _ len, simplified], erule that)
    apply (erule network_step_sync[OF _ len, simplified], erule that)
    done
  done

lemma trans_of_N_s_1:
  "(fst ` trans_of (N_s s ! q)) = fst ` fst (N ! q)" if "q < p"
  using that unfolding trans_of_def N_s_def p_def T_s_def by (auto 0 7 simp: image_iff)

lemma trans_of_N_s_2:
  "((snd o snd o snd o snd) ` trans_of (N_s s ! q)) = (snd o snd o snd o snd) ` fst (N ! q)" if "q < p"
  using that unfolding trans_of_def N_s_def p_def T_s_def by force

lemma
  "fst ` trans_of (N_s s ! q) = fst ` trans_of (N_s s' ! q)" if "q < p"
  using that by (simp add: trans_of_N_s_1)

lemma states'_simp:
  "states' s = states' s'"
  unfolding Product_TA_Defs.states_def using trans_of_N_s_1 trans_of_N_s_2 by (simp add: N_s_length)

  lemma states_step:
    "L' \<in> states' s" if "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>" "L \<in> states' s"
  proof -
    interpret Product_TA_Defs' "N_s s" .
    from \<open>L \<in> _\<close> have "L \<in> states" .
    from \<open>L \<in> _\<close> have "length L = p" by (simp add: N_s_length states_length)
    with network_step[folded A_unfold, OF that(1)] obtain a where
      "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L',u'\<rangle>"
      by auto
    then show ?thesis using that(2) by (rule states_step)
  qed

  lemma states_steps:
    "L' \<in> states' s'" if "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle>" "L \<in> states' s"
    using that proof (induction A \<equiv> A _ _ _ _ _ _ rule: steps_sn.induct)
    case (refl L s u)
    then show ?case by assumption
  next
    case (step L s u L' s' u' L'' s'' u'')
    with states_step[of L' s' u' L'' s'' u''] states'_simp show ?case by blast
  qed

  lemma inv_step:
    "\<forall>p<length P. (P ! p) (L' ! p) s'" if
    "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>" "\<forall>p<length P. (P ! p) (L ! p) s"
    using that by (cases) auto

  lemma inv_steps:
    "\<forall>p<length P. (P ! p) (L' ! p) s'" if
    "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle>" "\<forall>p<length P. (P ! p) (L ! p) s"
    using that by (induction A \<equiv> A _ _ _ _ _ _ rule: steps_sn.induct) (auto dest: inv_step)

end

(* Network + valid start state *)
locale Prod_TA =
  Prod_TA_Defs' A for A :: "('a, 'c, 't :: time, 's, 'st) snta" +
  fixes L :: "'s list" and s :: 'st
  assumes states[intro]: "L \<in> states' s"
  assumes Len: "length N = length P"
      and inv: "\<forall>p<length P. (P ! p) (L ! p) s"
begin

  sublocale Product_TA "N_s s" L by standard rule

  lemma inv_prod_simp:
    "inv_of prod_ta (l, s') = Product_TA_Defs.product_invariant (N_s s') l" if "length l = p"
    unfolding prod_ta_def prod_invariant_def Product_TA_Defs.product_ta_def N_s_def inv_of_def
    using that by (simp add: p_def)

  lemma inv_of_N_simp:
    "map inv_of (N_s s') ! q = I ! q" if "q < p"
    using that unfolding inv_of_def N_s_def p_def by simp

  lemma product_inv_prod_simp:
    "inv_of prod_ta (l, s') = I' s l" if "length l = p"
    using that
    apply (simp add: inv_prod_simp)
    apply (simp add: N_s_length inv_of_def Product_TA_Defs.product_invariant_def)
    apply (rule arg_cong[where f = concat])
    apply (clarsimp cong: map_cong)
    by (subst inv_of_N_simp; simp)

  lemma product_inv_prod[intro]:
    "u \<turnstile> inv_of prod_ta (l, s')" if "u \<turnstile> inv_of product_ta l" "length l = p"
    using that by (simp add: product_inv_prod_simp)

  lemma A_simp[simp]:
    "N' = N" "P' = P" if "A = (N', P')"
    using that by auto

  lemma length_L[intro]:
    "length L = p"
    by (simp add: N_s_length)

  lemma prod_complete_delay:
    assumes step: "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', s', u'\<rangle>"
    obtains d where "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>(L', s'), u'\<rangle>"
  using step proof cases
    case prems: (step_sn_t N d P)
    note [simp] = A_simp[OF prems(1)]
    from prems have "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Networks.Del\<^esub> \<langle>L', u'\<rangle>"
      unfolding N_s_def by (auto 4 3 simp: inv_of_def intro: step_n_t)
    with prems show ?thesis
      by (auto 4 4
          intro: that
          simp: product_inv_prod_simp[OF length_L]
          elim!: product_delay_complete step_t.cases)
  qed

  lemma prod_complete_silent:
    assumes step: "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Act a\<^esub> \<langle>L', s', u'\<rangle>"
    obtains a where "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>(L', s'), u'\<rangle>"
  using step proof cases
    case prems: (step_sn_i l g c m f l' N q r I)
    note [simp] = A_simp[OF prems(1)]
    from prems(13) have [simp]: "length P = p" by (simp add: p_def)
    have "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Networks.label.Act (c, m)\<^esub> \<langle>L', u'\<rangle>"
      apply (rule step_n_i)
      using prems unfolding N_s_def T_s_def by (auto 3 0 simp: trans_of_def inv_of_def N_s_length)
    with \<open>length P = p\<close> obtain b where
      "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(b, Networks.label.Act (c, m))\<^esub> \<langle>L', u'\<rangle>"
      by (clarsimp elim!: product_int_complete)
    with prems inv obtain g r where step:
      "((L, s), g, b, r, (L', s')) \<in> prod_trans_i"
      "u \<turnstile> g" "[r\<rightarrow>0]u = u'" "u' \<turnstile> inv_of product_ta L'"
        apply atomize_elim
      unfolding prod_trans_i_def by - (erule step_a.cases; auto)
    then have "((L, s), g, b, r, (L', s')) \<in> trans_of prod_ta"
      by (simp add: prod_trans_def trans_of_def prod_ta_def)
    moreover have "length L' = p"
      using length_L prems(8) by auto
    ultimately show ?thesis
      apply -
      apply (rule that)
      apply rule
      using step(2-) by force+
  qed

  lemma prod_complete_sync:
    assumes step: "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Syn a\<^esub> \<langle>L', s', u'\<rangle>"
    obtains a where "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>(L', s'), u'\<rangle>"
  using step proof cases
    case prems: (step_sn_s l1 g1 ci mi f1 l1' N q1 l2 g2 co mo f2 l2' q2 r1 r2 I so)
    note [simp] = A_simp[OF prems(1)]
    from prems(21) have [simp]: "length P = p" by (simp add: p_def)
    (* XXX Clean *)
    have "N_s s \<turnstile>\<^sub>N \<langle>L, u\<rangle> \<rightarrow>\<^bsub>Networks.label.Syn (ci, mi) (co, mo)\<^esub> \<langle>L', u'\<rangle>"
        apply (rule step_n_s)
                   defer
                   defer
                   apply (rule prems; fail)
                  apply (rule prems(5); fail)
        subgoal
          using prems unfolding N_s_def by (auto simp: inv_of_def)
                defer
                defer
                apply (rule prems; fail)
               apply (rule prems(12); fail)
        using prems unfolding N_s_def T_s_def by (auto 3 0 simp: trans_of_def p_def N_s_length)
    with \<open>length P = p\<close> obtain a where
      "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(a, Networks.label.Syn (ci, mi) (co, mo))\<^esub> \<langle>L', u'\<rangle>"
      by (auto elim!: product_sync_complete)
    with prems inv obtain g r where step:
        "((L, s), g, a, r, (L', s')) \<in> prod_trans_s"
        "u \<turnstile> g" "[r\<rightarrow>0]u = u'" "u' \<turnstile> inv_of product_ta L'"
        apply atomize_elim
      unfolding prod_trans_s_def by - (erule step_a.cases; auto; blast) (* XXX Slow *)
        (* XXX Simproc for instantiations from equality? *)
    then have "((L, s), g, a, r, (L', s')) \<in> trans_of prod_ta"
      by (simp add: prod_trans_def trans_of_def prod_ta_def)
    moreover have "length L' = p"
      using length_L \<open>L' = _\<close> by auto
    ultimately show ?thesis
      apply -
      apply (rule that)
      apply rule
      using step(2-) by force+
  qed

  lemma prod_complete:
    assumes step: "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>"
    shows "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow> \<langle>(L', s'), u'\<rangle>"
    using step
    by (cases a; simp; blast elim!: prod_complete_delay prod_complete_silent prod_complete_sync)

  lemma A_unfold:
    "A = (N, P)"
    by simp

  lemma prod_sound'_delay:
    assumes step: "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>(L', s'), u'\<rangle>"
    shows "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', s', u'\<rangle> \<and> product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow> \<langle>L', u'\<rangle>
           \<and> (\<forall>p<length P. (P ! p) (L' ! p) s')"
    using assms proof cases
    case prems: 1
    then have "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>L', u'\<rangle>" unfolding inv_of_simp by fast
    moreover from product_delay_sound[OF this] prems(1-3) have "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', s', u'\<rangle>"
      apply simp
      apply (subst A_unfold)
      apply (rule step_sn_t)
      by (auto simp: N_s_def inv_of_def step_t.simps N_s_length p_def Len intro: \<open>0 \<le> d\<close>)
    ultimately show ?thesis using prems inv by fast
  qed

  lemma prod_sound'_action:
    assumes step: "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>(L', s'), u'\<rangle>"
    obtains a where "(A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle> \<and> a \<noteq> Del) \<and> product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow> \<langle>L', u'\<rangle>
             \<and> (\<forall>p<length P. (P ! p) (L' ! p) s')"
    using assms
  proof cases
    case prems: (1 g r)
    from Len have [simp]: "length P = p" by (simp add: p_def)
    from prems(1) show ?thesis
      apply -
    proof (drule prod_ta_cases, erule disjE, goal_cases)
      case 1
      then obtain c m where *:
        "Some s' = m s" "\<forall>q<p. (P ! q) (L ! q) s" "\<forall>q<p. (P ! q) (L' ! q) s'"
        "product_ta \<turnstile> L \<longrightarrow>\<^bsup>g,(a, Networks.label.Act (c, m)),r\<^esup> L'" "c s"
        unfolding prod_trans_i_def by auto
      with prems have "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(a, Networks.label.Act (c, m))\<^esub> \<langle>L', u'\<rangle>"
        unfolding inv_of_simp by (metis I'_simp step_a.intros)
      moreover from product_action_sound[OF this] prems(3-4) obtain a where
        "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Act a\<^esub> \<langle>L', s', u'\<rangle>"
        apply safe
        apply (simp add: N_s_def trans_of_def N_s_length T_s_def)
        apply (simp only: ex_simps[symmetric])
        apply (erule exE, erule exE)
        apply (rule that)
        apply (subst A_unfold)
        apply (rule step_sn_i)
                   apply fast
        using *(3) by (auto simp: N_s_def inv_of_def p_def \<open>Some s' = m s\<close> intro: \<open>c s\<close>)
      ultimately show ?thesis using * by (auto intro: that)
    next
      case 2
      then obtain ci co mi mo si where *:
        "Some s' = mi si" "Some si = mo s" "\<forall>q<p. (P ! q) (L ! q) s" "\<forall>q<p. (P ! q) (L' ! q) s'"
        "product_ta \<turnstile> L \<longrightarrow>\<^bsup>g,(a, Networks.label.Syn (ci, mi) (co, mo)),r\<^esup> L'"
        "ci s" "co s"
        unfolding prod_trans_s_def by auto
      with prems have "product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow>\<^bsub>(a, Networks.label.Syn (ci, mi) (co, mo))\<^esub> \<langle>L', u'\<rangle>"
        unfolding inv_of_simp by (metis I'_simp step_a.intros)
      moreover from product_action_sound[OF this] prems(3-4) obtain a where
        "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Syn a\<^esub> \<langle>L', s', u'\<rangle>"
        apply safe
        apply (simp add: N_s_def trans_of_def N_s_length T_s_def)
        apply (simp only: ex_simps[symmetric])
        apply (erule exE, erule exE, erule exE, erule exE)
        apply (rule that)
        apply (subst A_unfold)
        apply (rule step_sn_s)
                           apply fast
                          apply blast
        using *(4) by (auto simp: N_s_def inv_of_def p_def \<open>Some s' = _\<close> \<open>Some si = _\<close> intro: *(6-)) (* Slow *)
      ultimately show ?thesis using * by (intro that conjI) auto
    qed
  qed

  lemma prod_sound':
    assumes step: "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow> \<langle>(L', s'), u'\<rangle>"
    obtains a where "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle> \<and> product_ta \<turnstile> \<langle>L, u\<rangle> \<rightarrow> \<langle>L', u'\<rangle>
             \<and> (\<forall>p<length P. (P ! p) (L' ! p) s')"
    using assms apply cases
     apply (erule prod_sound'_action; blast intro: that)
    apply (rule that, erule prod_sound'_delay)
    done

  lemmas prod_sound = prod_sound'[THEN conjunct1]
  lemmas prod_inv_1 = prod_sound'[THEN conjunct2, THEN conjunct1]
  lemmas prod_inv_2 = prod_sound'[THEN conjunct2, THEN conjunct2]

  lemma states_prod_step[intro]:
    "L' \<in> states" if "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow> \<langle>(L', s'), u'\<rangle>"
    by (blast intro: prod_inv_1[OF that])

  lemma inv_prod_step[intro]:
    "\<forall>p<length P. (P ! p) (L' ! p) s'" if "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow> \<langle>(L', s'), u'\<rangle>"
    using that by (blast intro: prod_inv_2)

  lemma prod_steps_sound:
    assumes step: "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>* \<langle>(L', s'), u'\<rangle>"
    shows "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle>"
    using step states inv
  proof (induction A \<equiv> prod_ta l \<equiv> "(L, s)" _ l' \<equiv> "(L', s')" _ arbitrary: L s rule: steps.induct)
    case (refl u)
    then show ?case by blast
  next
    case prems: (step u l' u' u'' L s)
    obtain L'' s'' where "l' = (L'', s'')" by force
    interpret interp: Prod_TA A L s by (standard; rule prems Len)
    from prems(3)[OF \<open>l' = _\<close>] prems(1,2,4-) have *: "A \<turnstile> \<langle>L'', s'', u'\<rangle> \<rightarrow>* \<langle>L', s', u''\<rangle>"
      unfolding \<open>l' = _\<close>
      by (metis Prod_TA_Defs'.states'_simp interp.states_prod_step interp.inv_prod_step)
    show ?case
      using * prems by (auto simp: \<open>l' = _\<close> intro: interp.prod_sound stepI2)
  qed

  lemma prod_steps_complete:
    "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>* \<langle>(L', s'), u'\<rangle>" if "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle>"
    using that states inv proof (induction A \<equiv> A L _ _ _ _ _ rule: steps_sn.induct)
    case (refl L s u)
    then show ?case by blast
  next
    case prems: (step L s u L' s' u' L'' s'' u'')
    interpret interp: Prod_TA A L' s' apply standard
      using prems by - (assumption | rule Prod_TA_Defs'.states_steps Len Prod_TA_Defs'.inv_steps)+
    from prems show ?case by - (rule steps_altI, auto intro!: interp.prod_complete)
  qed

  lemma prod_correct:
    "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>* \<langle>(L', s'), u'\<rangle> \<longleftrightarrow> A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle>"
    by (metis prod_steps_complete prod_steps_sound)

  end (* End context: network + valid start state *)

end (* End of theory *)