theory TickTock_UntimedPrefix
  imports TickTock_Prefix TickTock_ExtChoice TickTock_Basic_Ops
begin

subsection \<open>Instantaneous (Untimed) Prefix\<close>

definition UntimedPrefixTT :: "'e \<Rightarrow> 'e ttprocess \<Rightarrow> 'e ttprocess" (infixr "\<rightarrow>\<^sub>U" 61) where
  "e \<rightarrow>\<^sub>U P = (e \<rightarrow>\<^sub>C P \<box>\<^sub>C STOP\<^sub>U)"

lemma UntimedPrefixTT_def2:
  "e \<rightarrow>\<^sub>U P = {t. t = [] \<or> (\<exists> X. Event e \<notin> X \<and> t = [[X]\<^sub>R]) \<or> (\<exists> \<sigma>\<in>P. t = [[Event e]\<^sub>E] @ \<sigma>)}"
  unfolding UntimedPrefixTT_def PrefixTT_def ExtChoiceTT_def UntimedStopTT_def
proof (safe, simp_all)
  fix \<sigma>
  assume "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<sigma> \<longrightarrow> \<rho>' \<le>\<^sub>C []" "\<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  then show "\<sigma> = []"
    by (erule_tac x=\<sigma> in ballE, simp_all add: tt_prefix_antisym tt_prefix_refl tocks_tt_subset2 tt_subset_refl)
next
  fix \<sigma>
  assume "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<sigma> \<longrightarrow> \<rho>' \<le>\<^sub>C []" "\<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  then show "\<sigma> = []"
    by (erule_tac x=\<sigma> in ballE, simp_all add: tt_prefix_antisym tt_prefix_refl tocks_tt_subset2 tt_subset_refl)
next
  fix sa X
  assume "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C sa @ [[X]\<^sub>R] \<longrightarrow> \<rho>' \<le>\<^sub>C []" "sa \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  then show "sa \<noteq> [] \<Longrightarrow> False"
    apply (erule_tac x=sa in ballE, simp add: tt_prefix_antisym tt_prefix_concat)
    using tocks_tt_subset2 tt_subset_refl by blast
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then show "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume \<rho>_\<sigma>_in_tocks: "\<rho> @ \<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_longest_tocks_sigma: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<sigma> \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume "\<rho> @ \<tau> = [[X]\<^sub>R]" "\<rho> \<in> tocks UNIV"
  then have "\<rho> = []"
    by (cases \<rho> rule:ttWF.cases, auto simp add: notin_tocks)
  then have "\<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e} \<and> \<rho> = []"
    using \<rho>_\<sigma>_in_tocks by auto
  then show "\<sigma> = []"
    by (metis (full_types) \<rho>_longest_tocks_sigma append_Nil self_extension_tt_prefix tocks_tt_subset2 tt_prefix_refl tt_subset_refl)
next
  fix \<rho> \<sigma> \<tau> s :: "'a tttrace" and X Xa :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<sigma>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C s @ [[Xa]\<^sub>R] \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and s_in_tocks: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]" and \<rho>_\<sigma>_def: "\<rho> @ \<sigma> = s @ [[Xa]\<^sub>R]"

  have "\<rho> = []"
    using \<rho>_in_tocks \<rho>_\<tau>_def by (induct \<rho> rule:ttWF.induct, auto simp add: notin_tocks)
  then have "s = []"
    by (metis (full_types) \<rho>_longest_tocks_\<sigma> neq_Nil_conv s_in_tocks tocks_subset top_greatest tt_prefix.simps(3) tt_prefix_concat)
  then show "s \<noteq> [] \<Longrightarrow> \<sigma> = []"
    by auto
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<tau>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C [[X]\<^sub>R] \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<tau>_refusal_imp_\<sigma>_refusal: "\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and \<rho>_\<sigma>_in_tocks: "\<rho> @ \<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]"

  have \<rho>_empty: "\<rho> = []"
    using \<rho>_\<tau>_def \<rho>_in_tocks append_eq_Cons_conv in_tocks_last by fastforce
  then have \<tau>_refusal: "\<tau> = [[X]\<^sub>R]"
    using \<rho>_\<tau>_def by auto
  then obtain Y where \<sigma>_refusal: "\<sigma> = [[Y]\<^sub>R]"
    using \<tau>_refusal_imp_\<sigma>_refusal by auto
  then have "[[X]\<^sub>R] \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    using \<rho>_\<sigma>_in_tocks end_refusal_notin_tocks by blast
  then have False
    using refusal_notin_tocks by blast
  then show "\<tau> = []"
    by auto
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<tau>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C [[X]\<^sub>R] \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<tau>_refusal_imp_\<sigma>_refusal: "\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and \<rho>_\<sigma>_in_tocks: "\<rho> @ \<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]"

  have \<rho>_empty: "\<rho> = []"
    using \<rho>_\<tau>_def \<rho>_in_tocks append_eq_Cons_conv in_tocks_last by fastforce
  then have \<tau>_refusal: "\<tau> = [[X]\<^sub>R]"
    using \<rho>_\<tau>_def by auto
  then obtain Y where \<sigma>_refusal: "\<sigma> = [[Y]\<^sub>R]"
    using \<tau>_refusal_imp_\<sigma>_refusal by auto
  then have "[[X]\<^sub>R] \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    using \<rho>_\<sigma>_in_tocks end_refusal_notin_tocks by blast
  then have False
    using refusal_notin_tocks by blast
  then show "\<tau> = []"
    by auto
next
  fix \<rho> \<sigma> \<tau> :: "'a tttrace" and X :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<tau>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C [[X]\<^sub>R] \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<tau>_refusal_imp_\<sigma>_refusal: "\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and \<rho>_\<sigma>_in_tocks: "\<rho> @ \<sigma> \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]"

  have \<rho>_empty: "\<rho> = []"
    using \<rho>_\<tau>_def \<rho>_in_tocks append_eq_Cons_conv in_tocks_last by fastforce
  then have \<tau>_refusal: "\<tau> = [[X]\<^sub>R]"
    using \<rho>_\<tau>_def by auto
  then obtain Y where \<sigma>_refusal: "\<sigma> = [[Y]\<^sub>R]"
    using \<tau>_refusal_imp_\<sigma>_refusal by auto
  then have "[[X]\<^sub>R] \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
    using \<rho>_\<sigma>_in_tocks end_refusal_notin_tocks by blast
  then have False
    using refusal_notin_tocks by blast
  then show "\<sigma> = []"
    by auto
next
  fix \<rho> \<sigma> \<tau> s :: "'a tttrace" and X Xa :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<tau>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C [[X]\<^sub>R] \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<tau>_refusal_imp_\<sigma>_refusal: "\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and \<rho>_\<sigma>_in_tocks: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]" and \<rho>_\<sigma>_def: "\<rho> @ \<sigma> = s @ [[Xa]\<^sub>R]"
  assume e_in_X: "Event e \<in> X" and e_in_Xa: "Event e \<notin> Xa"

  have \<rho>_empty: "\<rho> = []"
    using \<rho>_\<tau>_def \<rho>_in_tocks append_eq_Cons_conv in_tocks_last by fastforce
  have \<tau>_refusal: "\<tau> = [[X]\<^sub>R]"
    using \<rho>_empty \<rho>_\<tau>_def by auto
  have \<sigma>_refusal: "\<sigma> = [[Xa]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Xa) \<or> e = Tock)"
    using \<rho>_\<sigma>_def \<tau>_refusal \<tau>_refusal_imp_\<sigma>_refusal by auto
  then have "Event e \<in> Xa"
    using e_in_X by blast
  then have "False"
    using e_in_Xa by blast
  then show "\<tau> = []"
    by auto
next
  fix \<sigma> s \<sigma>' :: "'a tttrace"
  assume \<rho>_longest_tocks_\<sigma>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C s @ [Event e]\<^sub>E # \<sigma>' \<longrightarrow> \<rho>' \<le>\<^sub>C []"
  assume s_in_tocks: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<sigma>_assm: "\<forall>\<sigma>\<in>P. s @ [Event e]\<^sub>E # \<sigma>' \<noteq> [Event e]\<^sub>E # \<sigma>"
  assume \<sigma>'_in_P: "\<sigma>' \<in> P"

  have "s = []"
    by (meson \<rho>_longest_tocks_\<sigma> s_in_tocks tocks_subset top_greatest tt_prefix.simps(1) tt_prefix_antisym tt_prefix_concat)
  then show "False"
    using \<rho>_\<sigma>_assm \<sigma>'_in_P by blast
next
  fix \<rho> \<sigma> \<tau> s \<sigma>' :: "'a tttrace" and X :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<sigma>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C s @ [Event e]\<^sub>E # \<sigma>' \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and  s_in_tocks: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]"
  assume \<rho>_\<sigma>_assm: "\<forall>\<sigma>\<in>P. s @ [Event e]\<^sub>E # \<sigma>' \<noteq> [Event e]\<^sub>E # \<sigma>"
  assume \<sigma>'_in_P: "\<sigma>' \<in> P"

  have "\<rho> = []"
    by (metis Cons_eq_append_conv \<rho>_\<tau>_def \<rho>_in_tocks append_Nil2 append_is_Nil_conv refusal_notin_tocks)
  then have "s = []"
    by (metis (mono_tags) \<rho>_longest_tocks_\<sigma> s_in_tocks tocks_subset top_greatest tt_prefix.simps(1) tt_prefix_antisym tt_prefix_concat)
  then show " \<sigma> = []"
    using \<rho>_\<sigma>_assm \<sigma>'_in_P by blast
next
  fix \<rho> \<sigma> \<tau> s \<sigma>' :: "'a tttrace" and X :: "'a ttevent set"
  assume \<rho>_longest_tocks_\<sigma>: "\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C s @ [Event e]\<^sub>E # \<sigma>' \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>"
  assume \<rho>_in_tocks: "\<rho> \<in> tocks UNIV" and  s_in_tocks: "s \<in> tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}"
  assume \<tau>_refusal_imp_\<sigma>_refusal: "\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))"
  assume \<rho>_\<tau>_def: "\<rho> @ \<tau> = [[X]\<^sub>R]" and \<rho>_\<sigma>_def: "\<rho> @ \<sigma> = s @ [Event e]\<^sub>E # \<sigma>'"
  assume \<sigma>'_in_P: "\<sigma>' \<in> P"

  have \<rho>_empty: "\<rho> = []"
    by (metis Cons_eq_append_conv \<rho>_\<tau>_def \<rho>_in_tocks append_Nil2 append_is_Nil_conv refusal_notin_tocks)
  then have "s = []"
    by (metis (mono_tags) \<rho>_longest_tocks_\<sigma> s_in_tocks tocks_subset top_greatest tt_prefix.simps(1) tt_prefix_antisym tt_prefix_concat)
  also have "\<exists>Y. \<sigma> = [[Y]\<^sub>R]"
    using \<rho>_\<tau>_def \<rho>_empty \<tau>_refusal_imp_\<sigma>_refusal by auto
  then have False
    using calculation \<rho>_\<sigma>_def by (simp add: \<rho>_empty)
  then show "\<tau> = []"
    by blast
next
  show "\<exists>\<rho>\<in>tocks UNIV.
       \<exists>\<sigma>. ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<rho> @ \<sigma> = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> \<rho> @ \<sigma> = s @ [[X]\<^sub>R])) \<or>
            (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<rho> @ \<sigma> = s \<or> (\<exists>\<sigma>'\<in>P. \<rho> @ \<sigma> = s @ [Event e]\<^sub>E # \<sigma>'))) \<and>
           (\<exists>\<tau>. (\<rho> = [] \<and> \<tau> = [] \<or> (\<exists>X. \<rho> @ \<tau> = [[X]\<^sub>R])) \<and>
                (\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<sigma> \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>) \<and>
                (\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<tau> \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>) \<and>
                (\<forall>X. \<sigma> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<tau> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))) \<and>
                (\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))) \<and> (\<rho> = [] \<and> \<sigma> = [] \<or> \<rho> = [] \<and> \<tau> = []))"
    by (rule_tac x="[]" in bexI, rule_tac x="[]" in exI, auto simp add: tocks.intros)
next
  fix X
  assume "Event e \<notin> X"
  then show "\<exists>\<rho>\<in>tocks UNIV.
            \<exists>\<sigma>. ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<rho> @ \<sigma> = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> \<rho> @ \<sigma> = s @ [[X]\<^sub>R])) \<or>
                 (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<rho> @ \<sigma> = s \<or> (\<exists>\<sigma>'\<in>P. \<rho> @ \<sigma> = s @ [Event e]\<^sub>E # \<sigma>'))) \<and>
                (\<exists>\<tau>. (\<rho> = [] \<and> \<tau> = [] \<or> (\<exists>X. \<rho> @ \<tau> = [[X]\<^sub>R])) \<and>
                     (\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<sigma> \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>) \<and>
                     (\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<tau> \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>) \<and>
                     (\<forall>X. \<sigma> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<tau> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))) \<and>
                     (\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))) \<and> ([[X]\<^sub>R] = \<rho> @ \<sigma> \<or> [[X]\<^sub>R] = \<rho> @ \<tau>))"
    apply (rule_tac x="[]" in bexI, auto)
    apply (rule_tac x="[[{x\<in>X. x \<noteq> Tock}]\<^sub>R]" in exI, safe, simp_all add: tocks.intros)
    apply (rule_tac x="[[X]\<^sub>R]" in exI, auto)
    using refusal_notin_tocks tt_prefix_notfront_is_whole by force+
next
  fix \<sigma>
  assume "\<sigma> \<in> P"
  then show "\<exists>\<rho>\<in>tocks UNIV.
            \<exists>\<sigma>'. ((\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<rho> @ \<sigma>' = s \<or> (\<exists>X. Tock \<notin> X \<and> Event e \<notin> X \<and> \<rho> @ \<sigma>' = s @ [[X]\<^sub>R])) \<or>
                  (\<exists>s\<in>tocks {x. x \<noteq> Tock \<and> x \<noteq> Event e}. \<rho> @ \<sigma>' = s \<or> (\<exists>\<sigma>\<in>P. \<rho> @ \<sigma>' = s @ [Event e]\<^sub>E # \<sigma>))) \<and>
                 (\<exists>\<tau>. (\<rho> = [] \<and> \<tau> = [] \<or> (\<exists>X. \<rho> @ \<tau> = [[X]\<^sub>R])) \<and>
                      (\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<sigma>' \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>) \<and>
                      (\<forall>\<rho>'\<in>tocks UNIV. \<rho>' \<le>\<^sub>C \<rho> @ \<tau> \<longrightarrow> \<rho>' \<le>\<^sub>C \<rho>) \<and>
                      (\<forall>X. \<sigma>' = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<tau> = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))) \<and>
                      (\<forall>X. \<tau> = [[X]\<^sub>R] \<longrightarrow> (\<exists>Y. \<sigma>' = [[Y]\<^sub>R] \<and> (\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock))) \<and>
                      ([Event e]\<^sub>E # \<sigma> = \<rho> @ \<sigma>' \<or> [Event e]\<^sub>E # \<sigma> = \<rho> @ \<tau>))"
    apply (rule_tac x="[]" in bexI, auto)
    apply (rule_tac x="[Event e]\<^sub>E # \<sigma>" in exI, safe, simp_all add: tocks.intros)
    apply (erule_tac x="[]" in ballE, safe, simp_all add: tocks.intros, blast)
    by (rule_tac x="[]" in exI, auto, metis tocks.simps tt_prefix.simps(2) tt_prefix_refl ttobs.simps(4))
qed

end


theory SimpTrace
  imports Main
begin

lemma test_simp_trace: "0 = 0"
  using [[simp_trace]]
  apply (simp)
  done

end


theory GeneralKnowledge imports ValueOntology (** Benzmüller, Fuenmayor & Lomfeld, 2021 **)
begin (*** General Legal and World Knowledge (LWK) ***)
(*LWK: kinds of situations addressed*)
consts appObject::\<sigma>  appAnimal::\<sigma> (*appropriation of objects/animals in general*)
       appWildAnimal::\<sigma>  appDomAnimal::\<sigma> (*appropriation of wild/domestic animals*)
(*LWK: postulates for kinds of situations*)
axiomatization where
 W1: "\<lfloor>appAnimal \<^bold>\<rightarrow> appObject\<rfloor>" and
 W2: "\<lfloor>\<^bold>\<not>(appWildAnimal \<^bold>\<and> appDomAnimal)\<rfloor>" and
 W3: "\<lfloor>appWildAnimal \<^bold>\<rightarrow> appAnimal\<rfloor>"  and
 W4: "\<lfloor>appDomAnimal \<^bold>\<rightarrow> appAnimal\<rfloor>"
(*LWK: (prima facie) value preferences for kinds of situations*)
axiomatization where
 R1: "\<lfloor>appAnimal \<^bold>\<rightarrow> ([STAB\<^sup>p] \<^bold>\<prec> [STAB\<^sup>d])\<rfloor>" and
 R2: "\<lfloor>appWildAnimal \<^bold>\<rightarrow> ([WILL\<^sup>x\<inverse>] \<^bold>\<prec> [STAB\<^sup>x])\<rfloor>" and
 R3: "\<lfloor>appDomAnimal  \<^bold>\<rightarrow> ([STAB\<^sup>x\<inverse>] \<^bold>\<prec> [RELI\<^sup>x\<^bold>\<oplus>RESP\<^sup>x])\<rfloor>"
(*LWK: domain vocabulary*)
typedecl e    (*declares new type for 'entities'*)
consts
  Animal::"e\<Rightarrow>\<sigma>" Domestic::"e\<Rightarrow>\<sigma>" Fox::"e\<Rightarrow>\<sigma>" Parrot::"e\<Rightarrow>\<sigma>" Pet::"e\<Rightarrow>\<sigma>" FreeRoaming::"e\<Rightarrow>\<sigma>"
(*LWK: domain knowledge (about animals)*)
axiomatization where
 W5: "\<lfloor>\<^bold>\<forall>a. Fox a \<^bold>\<rightarrow> Animal a\<rfloor>"  and
 W6: "\<lfloor>\<^bold>\<forall>a. Parrot a \<^bold>\<rightarrow> Animal a\<rfloor>" and
 W7: "\<lfloor>\<^bold>\<forall>a. (Animal a \<^bold>\<and> FreeRoaming a \<^bold>\<and> \<^bold>\<not>Pet a) \<^bold>\<rightarrow> \<^bold>\<not>Domestic a\<rfloor>" and
 W8: "\<lfloor>\<^bold>\<forall>a. Animal a \<^bold>\<and> Pet a \<^bold>\<rightarrow> Domestic a\<rfloor>"
(*LWK: legally-relevant, situational 'factors'*)
consts Own::"c\<Rightarrow>\<sigma>"    (*object is owned by party c*)
       Poss::"c\<Rightarrow>\<sigma>"   (*party c has actual possession of object*)
       Intent::"c\<Rightarrow>\<sigma>" (*party c has intention to possess object*)
       Mal::"c\<Rightarrow>\<sigma>" (*party c acts out of malice*)
       Mtn::"c\<Rightarrow>\<sigma>" (*party c respons. for maintenance of object*)
(*LWK: meaning postulates for general notions*)
axiomatization where
 W9: "\<lfloor>Poss x \<^bold>\<rightarrow> (\<^bold>\<not>Poss x\<inverse>)\<rfloor>" and
 W10: "\<lfloor>Own x \<^bold>\<rightarrow> (\<^bold>\<not>Own x\<inverse>)\<rfloor>"
(*LWK: conditional value preferences, e.g. from precedents*)
axiomatization where
 R4: "\<lfloor>(Mal x\<inverse> \<^bold>\<and> Own x)  \<^bold>\<rightarrow> ([STAB\<^sup>x\<inverse>] \<^bold>\<prec> [RESP\<^sup>x\<^bold>\<oplus>RELI\<^sup>x])\<rfloor>"
(*LWK: relate values, outcomes and situational 'factors'*)
axiomatization where
 F1: "Promotes (Intent x) (For x) WILL\<^sup>x" and
 F2: "Promotes (Mal x) (For x\<inverse>) RESP\<^sup>x" and
 F3: "Promotes (Poss x) (For x) STAB\<^sup>x" and
 F4: "Promotes (Mtn x) (For x) RESP\<^sup>x" and
 F5: "Promotes (Own x) (For x) RELI\<^sup>x"
(*Theory is consistent, (non-trivial) model found*)
lemma True nitpick[satisfy,card \<iota>=4] oops
end


(*  Title:      HOL/HOLCF/IOA/NTP/Abschannel.thy
    Author:     Olaf Müller
*)

section {* The (faulty) transmission channel (both directions) *}

theory Abschannel
imports IOA Action
begin

datatype 'a abs_action = S 'a | R 'a

definition
  ch_asig :: "'a abs_action signature" where
  "ch_asig = (UN b. {S(b)}, UN b. {R(b)}, {})"

definition
  ch_trans :: "('a abs_action, 'a multiset)transition set" where
  "ch_trans =
    {tr. let s = fst(tr);
             t = snd(snd(tr))
         in
         case fst(snd(tr))
           of S(b) => t = addm s b |
              R(b) => count s b ~= 0 & t = delm s b}"

definition
  ch_ioa :: "('a abs_action, 'a multiset)ioa" where
  "ch_ioa = (ch_asig, {{|}}, ch_trans,{},{})"

definition
  rsch_actions :: "'m action => bool abs_action option" where
  "rsch_actions (akt) =
          (case akt of
           S_msg(m) => None |
            R_msg(m) => None |
           S_pkt(packet) => None |
            R_pkt(packet) => None |
            S_ack(b) => Some(S(b)) |
            R_ack(b) => Some(R(b)) |
           C_m_s =>  None  |
           C_m_r =>  None |
           C_r_s =>  None  |
           C_r_r(m) => None)"

definition
  srch_actions :: "'m action =>(bool * 'm) abs_action option" where
  "srch_actions (akt) =
          (case akt of
           S_msg(m) => None |
            R_msg(m) => None |
           S_pkt(p) => Some(S(p)) |
            R_pkt(p) => Some(R(p)) |
            S_ack(b) => None |
            R_ack(b) => None |
           C_m_s => None |
           C_m_r => None |
           C_r_s => None |
           C_r_r(m) => None)"

definition
  srch_ioa :: "('m action, 'm packet multiset)ioa" where
  "srch_ioa = rename ch_ioa srch_actions"

definition
  rsch_ioa :: "('m action, bool multiset)ioa" where
  "rsch_ioa = rename ch_ioa rsch_actions"

definition
  srch_asig :: "'m action signature" where
  "srch_asig = asig_of(srch_ioa)"

definition
  rsch_asig :: "'m action signature" where
  "rsch_asig = asig_of(rsch_ioa)"

definition
  srch_wfair :: "('m action)set set" where
  "srch_wfair = wfair_of(srch_ioa)"
definition
  srch_sfair :: "('m action)set set" where
  "srch_sfair = sfair_of(srch_ioa)"
definition
  rsch_sfair :: "('m action)set set" where
  "rsch_sfair = sfair_of(rsch_ioa)"
definition
  rsch_wfair :: "('m action)set set" where
  "rsch_wfair = wfair_of(rsch_ioa)"

definition
  srch_trans :: "('m action, 'm packet multiset)transition set" where
  "srch_trans = trans_of(srch_ioa)"
definition
  rsch_trans :: "('m action, bool multiset)transition set" where
  "rsch_trans = trans_of(rsch_ioa)"

lemmas unfold_renaming =
  srch_asig_def rsch_asig_def rsch_ioa_def srch_ioa_def ch_ioa_def
  ch_asig_def srch_actions_def rsch_actions_def rename_def rename_set_def asig_of_def
  actions_def srch_trans_def rsch_trans_def ch_trans_def starts_of_def
  trans_of_def asig_projections

lemma in_srch_asig:
     "S_msg(m) ~: actions(srch_asig)        &
       R_msg(m) ~: actions(srch_asig)        &
       S_pkt(pkt) : actions(srch_asig)    &
       R_pkt(pkt) : actions(srch_asig)    &
       S_ack(b) ~: actions(srch_asig)     &
       R_ack(b) ~: actions(srch_asig)     &
       C_m_s ~: actions(srch_asig)           &
       C_m_r ~: actions(srch_asig)           &
       C_r_s ~: actions(srch_asig)  & C_r_r(m) ~: actions(srch_asig)"
  by (simp add: unfold_renaming)

lemma in_rsch_asig:
      "S_msg(m) ~: actions(rsch_asig)         &
       R_msg(m) ~: actions(rsch_asig)         &
       S_pkt(pkt) ~: actions(rsch_asig)    &
       R_pkt(pkt) ~: actions(rsch_asig)    &
       S_ack(b) : actions(rsch_asig)       &
       R_ack(b) : actions(rsch_asig)       &
       C_m_s ~: actions(rsch_asig)            &
       C_m_r ~: actions(rsch_asig)            &
       C_r_s ~: actions(rsch_asig)            &
       C_r_r(m) ~: actions(rsch_asig)"
  by (simp add: unfold_renaming)

lemma srch_ioa_thm: "srch_ioa =
    (srch_asig, {{|}}, srch_trans,srch_wfair,srch_sfair)"
apply (simp (no_asm) add: srch_asig_def srch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def srch_wfair_def srch_sfair_def)
apply (simp (no_asm) add: unfold_renaming)
done

lemma rsch_ioa_thm: "rsch_ioa =
     (rsch_asig, {{|}}, rsch_trans,rsch_wfair,rsch_sfair)"
apply (simp (no_asm) add: rsch_asig_def rsch_trans_def asig_of_def trans_of_def wfair_of_def sfair_of_def rsch_wfair_def rsch_sfair_def)
apply (simp (no_asm) add: unfold_renaming)
done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

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

theory ArrayAssertion

imports
  "$L4V_ARCH/ArchArraysMemInstance"
  "StructSupport"

begin

lemma array_tag_n_eq:
  "(array_tag_n n :: ('a :: c_type['b :: finite]) field_desc typ_desc) =
  TypDesc (TypAggregate
    (map (\<lambda>n. DTPair (adjust_ti (typ_info_t TYPE('a)) (\<lambda>x. index x n)
            (\<lambda>x f. Arrays.update f n x)) (replicate n CHR ''1'')) [0..<n]))
  (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @ nat_to_bin_string (card (UNIV :: 'b :: finite set)))"
  apply (induct n)
   apply (simp add: typ_info_array array_tag_def eval_nat_numeral array_tag_n.simps empty_typ_info_def)
   apply (simp add: typ_info_array array_tag_def eval_nat_numeral array_tag_n.simps empty_typ_info_def)
   apply (simp add: ti_typ_combine_def Let_def)
   done

lemma typ_info_array':
  "typ_info_t TYPE ('a :: c_type['b :: finite]) =
  TypDesc (TypAggregate
    (map (\<lambda>n. DTPair (adjust_ti (typ_info_t TYPE('a)) (\<lambda>x. index x n)
            (\<lambda>x f. Arrays.update f n x)) (replicate n CHR ''1'')) [0..<(card (UNIV :: 'b :: finite set))]))
  (typ_name (typ_uinfo_t TYPE('a)) @ ''_array_'' @ nat_to_bin_string (card (UNIV :: 'b :: finite set)))"
  by (simp add: typ_info_array array_tag_def array_tag_n_eq)

definition
  "uinfo_array_tag_n_m (v :: 'a itself) n m = TypDesc
    (TypAggregate (map (\<lambda>i. DTPair (typ_uinfo_t TYPE('a)) (replicate i CHR ''1'')) [0 ..< n]))
    (typ_name (typ_uinfo_t TYPE('a :: c_type)) @ ''_array_'' @ nat_to_bin_string m)"

lemma map_td_list_map:
  "map_td_list f = map (map_td_pair f)"
  by (rule ext, rename_tac x) (induct_tac x, simp_all)

lemma uinfo_array_tag_n_m_eq:
  "n \<le> CARD('b)
    \<Longrightarrow> export_uinfo (array_tag_n n :: (('a :: wf_type)['b :: finite]) field_desc typ_desc)
        = uinfo_array_tag_n_m TYPE ('a) n (CARD('b))"
  apply (clarsimp simp: uinfo_array_tag_n_m_def array_tag_n_eq map_td_list_map
                        o_def adjust_ti_def map_td_map typ_uinfo_t_def export_uinfo_def)
  apply (fastforce intro: map_td_extI simp: field_norm_blah)
  done

lemma typ_uinfo_array_tag_n_m_eq:
  "typ_uinfo_t TYPE (('a :: wf_type)['b :: finite])
        = uinfo_array_tag_n_m TYPE ('a) (CARD('b)) (CARD('b))"
  by (simp add: typ_uinfo_t_def typ_info_array array_tag_def uinfo_array_tag_n_m_eq)

text \<open>Alternative to h_t_valid for arrays. This allows reasoning
about arrays of variable width.\<close>
definition h_t_array_valid :: "heap_typ_desc \<Rightarrow> ('a :: c_type) ptr \<Rightarrow> nat \<Rightarrow> bool" where
  "h_t_array_valid htd ptr n = valid_footprint htd (ptr_val ptr) (uinfo_array_tag_n_m TYPE ('a) n n)"

text \<open>Assertion that pointer p is within an array that continues for at least n more elements.\<close>
definition
  "array_assertion (p :: ('a :: c_type) ptr) n htd
    = (\<exists>q i j. h_t_array_valid htd q j
        \<and> p = CTypesDefs.ptr_add q (int i) \<and> i < j \<and> i + n \<le> j)"

lemma array_assertion_shrink_right:
  "array_assertion p n htd \<Longrightarrow> n' \<le> n \<Longrightarrow> array_assertion p n' htd"
  by (fastforce simp: array_assertion_def)

lemma array_assertion_shrink_leftD:
  "array_assertion p n htd \<Longrightarrow> j < n \<Longrightarrow> array_assertion (CTypesDefs.ptr_add p (int j)) (n - j) htd"
  apply (clarsimp simp: array_assertion_def)
  apply (rule exI, rule_tac x="i + j" in exI, rule exI, erule conjI)
  apply (simp add: CTypesDefs.ptr_add_def field_simps)
  done

lemma array_assertion_shrink_leftI:
  "array_assertion (CTypesDefs.ptr_add p (- (int j))) (n + j) htd
    \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> array_assertion p n htd"
  apply (drule_tac j=j in array_assertion_shrink_leftD, simp)
  apply (simp add: CTypesDefs.ptr_add_def)
  done

lemma h_t_array_valid:
  "h_t_valid htd gd (p :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> h_t_array_valid htd (ptr_coerce p :: 'a ptr) (CARD('b))"
  by (clarsimp simp: h_t_valid_def h_t_array_valid_def typ_uinfo_array_tag_n_m_eq)

lemma array_ptr_valid_array_assertionD:
  "h_t_valid htd gd (p :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> array_assertion (ptr_coerce p :: 'a ptr) (CARD('b)) htd"
  apply (clarsimp simp: array_assertion_def dest!: h_t_array_valid)
  apply (fastforce intro: exI[where x=0])
  done

lemma array_ptr_valid_array_assertionI:
  "h_t_valid htd gd (q :: (('a :: wf_type)['b :: finite]) ptr)
    \<Longrightarrow> q = ptr_coerce p
    \<Longrightarrow> n \<le> CARD('b)
    \<Longrightarrow> array_assertion (p :: 'a ptr) n htd"
  by (auto dest: array_ptr_valid_array_assertionD
           simp: array_assertion_shrink_right)

text \<open>Derived from array_assertion, an appropriate assertion for performing
a pointer addition, or for dereferencing a pointer addition (the strong case).

In either case, there must be an array connecting the two ends of the pointer
transition, with the caveat that the last address can be just out of the array
if the pointer is not dereferenced, thus the strong/weak distinction.

If the pointer doesn't actually move, nothing is learned.
\<close>
definition ptr_add_assertion :: "('a :: c_type) ptr \<Rightarrow> int \<Rightarrow> bool \<Rightarrow> heap_typ_desc \<Rightarrow> bool" where
  "ptr_add_assertion ptr offs strong htd \<equiv>
    offs = 0 \<or>
    array_assertion (if offs < 0 then CTypesDefs.ptr_add ptr offs else ptr)
                    (if offs < 0 then nat (- offs) else if strong then Suc (nat offs) else nat offs)
                    htd"

lemma ptr_add_assertion_positive:
  "offs \<ge> 0 \<Longrightarrow> ptr_add_assertion ptr offs strong htd
    = (offs = 0 \<or> array_assertion ptr (case strong of True \<Rightarrow> Suc (nat offs)
        | False \<Rightarrow> nat offs) htd)"
  by (simp add: ptr_add_assertion_def)

lemma ptr_add_assertion_negative:
  "offs < 0 \<Longrightarrow> ptr_add_assertion ptr offs strong htd
    = array_assertion (CTypesDefs.ptr_add ptr offs) (nat (- offs)) htd"
  by (simp add: ptr_add_assertion_def)

lemma ptr_add_assertion_uint[simp]:
  "ptr_add_assertion ptr (uint offs) strong htd
    = (offs = 0 \<or> array_assertion ptr
        (case strong of True \<Rightarrow> Suc (unat offs) | False \<Rightarrow> unat offs) htd)"
  by (simp add: ptr_add_assertion_positive uint_0_iff unat_def
         split: bool.split)

text \<open>Ignore char and void pointers. The C standard specifies that arithmetic on
char and void pointers doesn't create any special checks.\<close>

definition ptr_add_assertion' :: "('a :: c_type) ptr \<Rightarrow> int \<Rightarrow> bool \<Rightarrow> heap_typ_desc \<Rightarrow> bool" where
  "ptr_add_assertion' ptr offs strong htd =
     (typ_uinfo_t TYPE('a) = typ_uinfo_t TYPE(word8)
      \<or> typ_uinfo_t TYPE ('a) = typ_uinfo_t TYPE(unit)
      \<or> ptr_add_assertion ptr offs strong htd)"

(* Useful for clearing away these assumptions. *)
lemma td_diff_from_typ_name:
  "typ_name td \<noteq> typ_name td' \<Longrightarrow> td \<noteq> td'"
  by clarsimp

lemma typ_name_void:
  "typ_name (typ_uinfo_t TYPE(unit)) = ''unit''"
 by (simp add: typ_uinfo_t_def)

lemmas ptr_add_assertion' = ptr_add_assertion'_def td_diff_from_typ_name typ_name_void

text \<open>Mechanism for retyping a range of memory to a non-constant array size.\<close>

definition ptr_arr_retyps :: "nat \<Rightarrow> ('a :: c_type) ptr \<Rightarrow> heap_typ_desc \<Rightarrow> heap_typ_desc" where
  "ptr_arr_retyps n p \<equiv>
    htd_update_list (ptr_val p)
        (map (\<lambda>i. list_map (typ_slice_t (uinfo_array_tag_n_m TYPE('a) n n) i))
             [0..<n * size_of TYPE('a)])"

lemma ptr_arr_retyps_to_retyp:
  "n = CARD('b :: finite)
    \<Longrightarrow> ptr_arr_retyps n (p :: ('c :: wf_type) ptr) = ptr_retyp (ptr_coerce p :: ('c['b]) ptr)"
  by (auto simp: ptr_arr_retyps_def ptr_retyp_def typ_slices_def typ_uinfo_array_tag_n_m_eq)

end