theory Failures_TickTock

imports
  Failures_BasicOps
  TickTock.TickTock
begin

text \<open> In calculating the failures, we drop tock events, both in the trace
       and the refusals? We could still include it as part of the refusals
       considering it as a regular event.. but that's probably unnecessary? \<close>

primrec ttevt2F :: "'e evt \<Rightarrow> 'e ttevent" where
"ttevt2F (evt a) = Event a" |
"ttevt2F tick = Tick"

lemma
  "ttevt2F`(A \<union> B) = ttevt2F`A \<union> ttevt2F`B"
  by auto

lemma ttevt2F_evt_set:
  "ttevt2F`evt ` A = (Event`A)"
  by (auto simp add: image_iff)

fun tt2T :: "'a tttrace \<Rightarrow> 'a trace" where
"tt2T [[Tick]\<^sub>E] = [tick]" |
"tt2T ([Event e]\<^sub>E # \<sigma>) = evt e # tt2T \<sigma>" |
"tt2T \<sigma> = []"

lemma tt2T_tocks_simp [simp]:
  assumes "\<rho> \<in> tocks P" "\<rho> \<noteq> []"
  shows "tt2T (\<rho> @ \<sigma>) = []"
  using assms
  using tocks.simps by fastforce

lemma tt2T_empty_concat [simp]:
  assumes "\<rho> = []"
  shows "tt2T (\<rho> @ \<sigma>) = tt2T \<sigma>"
  using assms by auto

fun tt2F :: "'a tttrace \<Rightarrow> 'a failure option" where
"tt2F [[X]\<^sub>R] = Some ([],{x. ttevt2F x \<in> X})" |
"tt2F ([Event e]\<^sub>E # \<sigma>) = (case (tt2F \<sigma>) of (Some fl) \<Rightarrow> Some (evt e # fst fl,snd fl) | None \<Rightarrow> None)" |
"tt2F \<sigma> = None"

text \<open> Below is an attempt at breaking the definition of tt2F in concatenations. \<close>

fun tt2Fconcat :: "'a failure option \<Rightarrow> 'a failure option \<Rightarrow> 'a failure option" (infix "@\<^sub>F" 56) where
"None @\<^sub>F x = None" |
"x @\<^sub>F None = None" |
"(Some fl1) @\<^sub>F (Some fl2) = Some (fst fl1 @ fst fl2,snd fl2)"

lemma tt2F_Event_dist_tt2Fconcat:
  "tt2F ([Event x1]\<^sub>E # x) = Some([evt x1],Z) @\<^sub>F tt2F(x)"
  apply (induct x rule:tt2F.induct, auto)
  by (simp add: option.case_eq_if)

lemma tt2Fconcat_assoc:
  "x @\<^sub>F (y @\<^sub>F z) = (x @\<^sub>F y) @\<^sub>F z"
  apply (induct x, auto)
  apply (induct y, auto)
  by (induct z, auto)

lemma tt2F_ev_neq_None:
  assumes "tt2F ([ev]\<^sub>E # x) \<noteq> None"
  shows "tt2F x \<noteq> None"
  using assms
  apply (cases ev, auto)
  by (smt option.exhaust option.simps(4) surj_pair)

lemma tt2F_dist_tt2Fcontact:
  assumes "set x \<inter> {[X]\<^sub>R | X. True} = {}" "(tt2F x) \<noteq> None" "ttWF(x@y)"
  shows "tt2F (x@y) = (tt2F x) @\<^sub>F (tt2F y)"
  using assms
  proof (induct x)
    case Nil
    then show ?case by auto
  next
    case (Cons a x)
    then show ?case
    proof (cases a)
      case (ObsEvent ev)
      then have "tt2F x \<noteq> None"
        using Cons.prems(2) tt2F_ev_neq_None by blast
      then have tt2F_xy:"tt2F (x @ y) = tt2F x @\<^sub>F tt2F y"
        using Cons ObsEvent
        by (smt Cons.hyps Cons.prems Cons.prems(2) Set.is_empty_def append_Cons empty_set insert_disjoint(1) is_empty_set list.inject list.simps(15) null_rec(1) ttWF.elims(2) ttWF.simps(1) ttobs.distinct(1))

      then show ?thesis
      proof (cases ev)
        case (Event x1)
        then obtain Z where "tt2F ([Event x1]\<^sub>E # (x @ y)) = Some([evt x1],Z) @\<^sub>F tt2F(x @ y)"
            using tt2F_Event_dist_tt2Fconcat by force
        then have "Some([evt x1],Z) @\<^sub>F tt2F(x @ y) = Some([evt x1],Z) @\<^sub>F ((tt2F x) @\<^sub>F (tt2F y))"
          using tt2F_xy by simp
        then show ?thesis
        proof (cases "tt2F x = None")
          case True
          then show ?thesis
            using Event ObsEvent tt2F_xy by auto
        next
          case False
          then show ?thesis
            by (metis Cons_eq_appendI Event ObsEvent tt2F_Event_dist_tt2Fconcat tt2F_xy tt2Fconcat_assoc)
        qed
      next
        case Tock
        then show ?thesis
          using Cons.prems(2) ObsEvent by auto
      next
        case Tick
        then show ?thesis
          by (metis Cons.prems(2) Nil_is_append_conv ObsEvent append_Cons list.exhaust tt2F.simps(3) tt2F.simps(5) tt2Fconcat.simps(1) ttWF.simps(10))
        qed
    next
      case (Ref x2)
      then show ?thesis
        using Cons.prems(1) by auto
    qed
  qed

lemma tt2F_refusal_eq:
  assumes "tt2F [[X]\<^sub>R] = tt2F [[Y]\<^sub>R]" "Tock \<in> X \<longleftrightarrow> Tock \<in> Y"
  shows "[[X]\<^sub>R] = [[Y]\<^sub>R]"
  using assms apply auto
  by (metis mem_Collect_eq ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))+

lemma tt2F_eq_eqsets_or_Tock:
  assumes "(\<forall>e. (e \<in> X) = (e \<in> Y) \<or> e = Tock)"
  shows "tt2F [[X]\<^sub>R] = tt2F [[Y]\<^sub>R]"
  using assms apply auto
  by (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))+

lemma tt2F_some_exists:
  assumes "Some ([], b) = tt2F \<sigma>"
  shows "\<exists>X. \<sigma> = [[X]\<^sub>R]"
  using assms apply (cases \<sigma> rule:tt2F.cases, auto)
  by (metis (no_types, lifting) Pair_inject list.simps(3) not_Some_eq option.case(1) option.inject option.simps(5))

lemma tt2F_tocks_simp [simp]:
  assumes "\<rho> \<in> tocks P" "\<rho> \<noteq> []"
  shows "tt2F (\<rho> @ \<sigma>) = None"
  using assms
  using tocks.simps by fastforce

lemma tt2F_refusal_without_Tock: "tt2F [[X]\<^sub>R] = tt2F [[X-{Tock}]\<^sub>R]"
  apply auto
  by (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))

lemma tt2F_refusal_no_Tock: "tt2F [[X\<union>{Tock}]\<^sub>R] = tt2F [[X]\<^sub>R]"
  apply auto
  by (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))

text \<open> The function mapping tick-tock processes to failures is then defined as follows. \<close>

definition ttproc2F :: "'a ttprocess \<Rightarrow> 'a process" where
  "ttproc2F P = ({(s,X). \<exists>y. Some (s,X) = tt2F y \<and> y \<in> P},{s. \<exists>y. s = tt2T y \<and> y \<in> P})"

lemma Some_tt2F_set:
  "Some ([], b) = tt2F [[{y. \<exists>x. y = ttevt2F x \<and> x \<in> b}]\<^sub>R]"
  apply auto
  by (metis evt.exhaust ttevent.distinct(3) ttevent.inject ttevt2F.simps(1) ttevt2F.simps(2))

lemma TT1_subset_single_ref:
  assumes "TT1 P" "[[X]\<^sub>R] \<in> P"
  shows "[[X-Y]\<^sub>R] \<in> P"
proof -
  have "X-Y \<subseteq> X" by auto

  then have "[[X-Y]\<^sub>R] \<lesssim>\<^sub>C [[X]\<^sub>R]"
    by auto

  then show ?thesis
    using assms unfolding TT1_def by blast
qed

lemma
  shows "tt2T ([Event x]\<^sub>E # ys) = (tt2T [[Event x]\<^sub>E]) @ (tt2T ys)"
  by auto

lemma Some_tt2F_imp_tt2T:
  assumes "Some (a, b) = tt2F y"
  shows "tt2T y = a"
  using assms apply (induct a y arbitrary:b rule:list_induct2', auto)
  using tt2F_some_exists tt2T.simps(5) apply blast
  apply (case_tac ya, auto, case_tac x1, auto)
    apply (metis (mono_tags, lifting) Pair_inject list.inject option.case_eq_if option.inject option.simps(3))
   apply (smt Pair_inject list.inject option.case_eq_if option.collapse option.inject option.simps(3) prod.collapse)
  by (metis neq_Nil_conv not_Some_eq option.inject prod.inject tt2F.simps(1) tt2F.simps(8))

lemma tt2F_None_merge_traces:
  assumes "([] \<lbrakk>A\<rbrakk>\<^sup>T\<^sub>C q) \<noteq> {}"
  shows "tt2F`([] \<lbrakk>A\<rbrakk>\<^sup>T\<^sub>C q) = {None}"
  using assms apply (induct q arbitrary:A rule:ttWF.induct, auto)
  apply (metis (no_types, lifting) Set.set_insert equals0D image_insert insertI1 option.case_eq_if singletonD)
  by (metis (mono_tags, lifting) equals0D image_eqI mem_Collect_eq option.simps(4) singleton_iff tt2F.simps(2))

lemma tt2F_None_merge_traces':
  assumes "y \<in> ([] \<lbrakk>A\<rbrakk>\<^sup>T\<^sub>C q)"
  shows "tt2F y = None"
  using assms tt2F_None_merge_traces by blast

lemma tt2F_ending_Event_eq_None:
  "tt2F (xs @ [[Event e]\<^sub>E]) = None"
  apply (induct xs, auto)
  by (metis list.exhaust rotate1.simps(2) rotate1_is_Nil_conv tt2F.simps(8) tt2F_ev_neq_None ttobs.exhaust)

lemma ttWF_tt2F_last_refusal_concat:
  assumes "ttWF (xs@[[R]\<^sub>R])" "[Tock]\<^sub>E \<notin> set xs"
  shows "tt2F (xs@[[R]\<^sub>R]) = Some(tt2T xs,{x. ttevt2F x \<in> R})"
  using assms apply (induct xs, auto)
  apply (case_tac a, auto, case_tac x1, auto)
  using ttWF.elims(2) apply auto[1]
  by (smt append_eq_append_conv2 list.distinct(1) list.inject list.set_intros(1) same_append_eq ttWF.elims(2) tt_prefix.elims(2) tt_prefix_concat ttobs.distinct(1))

lemma Some_tt2F_no_Tock:
  assumes "Some (s, Y) = tt2F y"
  shows "[Tock]\<^sub>E \<notin> set y"
  using assms apply(induct y arbitrary:s Y, auto)
  apply (case_tac a, auto)
  apply (smt option.collapse option.simps(4) prod.collapse tt2F.simps(2) tt2F.simps(4) tt2F.simps(5) ttevent.exhaust)
  by (metis list.set_cases option.distinct(1) tt2F.simps(8))

lemma Some_tt2F_no_Tick:
  assumes "Some (s, Y) = tt2F y"
  shows "[Tick]\<^sub>E \<notin> set y"
  using assms apply(induct y arbitrary:s Y, auto)
  apply (case_tac a, auto)
  apply (smt option.collapse option.simps(4) prod.collapse tt2F.simps(2) tt2F.simps(4) tt2F.simps(5) ttevent.exhaust)
  by (metis list.set_cases option.distinct(1) tt2F.simps(8))

lemma some_tt2F_ref_trace:
  assumes "Some (s, Y) = tt2F y" "ttWF y"
  shows "\<exists>ys R. y = ys@[[R]\<^sub>R] \<and> Y = {x. ttevt2F x \<in> R} \<and> tt2T ys = s"
  using assms
proof (induct y rule:rev_induct)
  case Nil
  then show ?case by auto
next
  case (snoc x xs)
  then show ?case
  proof (cases x)
    case (ObsEvent ev)
    then show ?thesis
    proof (cases ev)
      case (Event x1)
      then have "tt2F (xs @ [x]) = None"
        using ObsEvent snoc
        by (simp add: tt2F_ending_Event_eq_None)
      then show ?thesis
        using snoc.prems(1) by auto
    next
      case Tock
      then show ?thesis
        using ObsEvent Some_tt2F_no_Tock snoc.prems(1) by fastforce
    next
      case Tick
      then show ?thesis
        using ObsEvent Some_tt2F_no_Tick snoc.prems(1) by fastforce
    qed
  next
    case (Ref x2)
    then have "[Tock]\<^sub>E \<notin> set xs"
      by (metis Some_tt2F_no_Tock Un_iff set_append snoc.prems(1))
    then show ?thesis using ttWF_tt2F_last_refusal_concat assms
      by (metis Ref old.prod.inject option.inject snoc.prems(1) snoc.prems(2))
  qed
qed

lemma Some_tt2F_imp_tt2T':
  assumes "Some (a, b) = tt2F y"
  shows "tt2T y = a"
  using assms apply (induct a y arbitrary:b rule:list_induct2', auto)
  using tt2F_some_exists tt2T.simps(5) apply blast
  apply (case_tac ya, auto, case_tac x1, auto)
    apply (metis (mono_tags, lifting) Pair_inject list.inject option.case_eq_if option.inject option.simps(3))
   apply (smt Pair_inject list.inject option.case_eq_if option.collapse option.inject option.simps(3) prod.collapse)
  by (metis neq_Nil_conv not_Some_eq option.inject prod.inject tt2F.simps(1) tt2F.simps(8))

lemma tocks_Some_prefix_tt2F:
  assumes "x\<in>tocks P" "x \<le>\<^sub>C y" "Some (a, b) = tt2F y"
  shows "x = []"
  using assms
  apply (induct y rule:tt2F.induct, auto)
  using tocks.simps apply fastforce
  using tt2F_tocks_simp tt_prefix_decompose by fastforce

lemma Some_tt2F_tail:
  assumes "Some (a # s, b) = tt2F y"
  shows "Some (s,b) = tt2F (tl y)"
  using assms apply (induct y arbitrary:a b, auto)
  apply (case_tac aa, auto)
  apply (case_tac x1, auto)
  apply (metis (no_types, lifting) Pair_inject list.inject option.case_eq_if option.expand option.sel option.simps(3) prod.collapse)
  using Some_tt2F_imp_tt2T' by fastforce

lemma Some_no_tt2F_tick:
  assumes "Some (a # s, b) = tt2F y"
  shows "a \<noteq> tick"
  using assms apply (induct y arbitrary:s b, auto)
  apply (case_tac aa, auto)
   apply (case_tac x1, auto)
  apply (metis Some_tt2F_imp_tt2T' evt.distinct(1) list.sel(1) tt2F.simps(2) tt2T.simps(2))
    using Some_tt2F_imp_tt2T' by fastforce

lemma Some_tt2F_exists_filter:
  assumes "Some (s, b) = tt2F y"
  shows "\<exists>z. Some (filter (\<lambda>e. e \<notin> X) s, b) = tt2F z"
  using assms
proof (induct s arbitrary:b y X)
  case Nil
  then show ?case by auto
next
  case (Cons a s)
  then obtain z where z:"Some (filter (\<lambda>e. e \<notin> X) s, b) = tt2F z"
    using Some_tt2F_tail by blast
  then show ?case using Cons
  proof (cases a)
    case tick
    then have "a \<noteq> tick"
      using Cons Some_no_tt2F_tick by blast
    then show ?thesis
      using tick by auto
  next
    case (evt x2)
    then show ?thesis
    proof (cases "evt x2 \<in> X")
      case True
      then show ?thesis
        using Cons.hyps Cons.prems Some_tt2F_tail evt by fastforce
    next
      case False
      then have "filter (\<lambda>e. e \<notin> X) (a # s) = (a # filter (\<lambda>e. e \<notin> X) s)"
        using evt by auto
      then have "Some ((evt x2 # filter (\<lambda>e. e \<notin> X) s), b) = tt2F ([Event x2]\<^sub>E # z)"
        apply auto
        by (metis (no_types, lifting) fst_conv option.simps(5) snd_conv z)
      then show ?thesis
        by (metis \<open>filter (\<lambda>e. e \<notin> X) (a # s) = a # filter (\<lambda>e. e \<notin> X) s\<close> evt)
    qed
  qed
qed

lemma Some_tt2T_exists_filter:
  assumes "Some (s, b) = tt2F y"
  shows "\<exists>z. tt2T z = filter (\<lambda>e. e \<notin> X) s \<and> z \<noteq> []"
  using assms
proof (induct s arbitrary:b y X)
  case Nil
  then show ?case
    apply auto
    using tt2T.simps(5) by blast
next
  case (Cons a s)
  then obtain c z where cz:"Some (s, c) = tt2F z"
    using Cons
    apply (induct y, auto)
    using Some_tt2F_tail by blast
  then obtain z2 where z2:"tt2T z2 = filter (\<lambda>e. e \<notin> X) s"
    using Cons
    by blast
  then show ?case
  proof (cases a)
    case tick
    then have "a \<noteq> tick"
      using Cons Some_no_tt2F_tick by blast
    then show ?thesis
      using tick by auto
  next
    case (evt x2)
    then show ?thesis
      by (metis Cons.hyps \<open>\<And>thesis. (\<And>c z. Some (s, c) = tt2F z \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> filter.simps(2) list.distinct(1) tt2T.simps(2))
  qed
qed

lemma filter_empty_iff:
  "filter (\<lambda>e. e \<notin> HS) s = [] \<longleftrightarrow> (s = [] \<or> set s \<subseteq> HS)"
  apply auto
  by (auto simp add: filter_empty_conv)+

lemma Some_tt2F_event_tl:
  assumes "Some (s, X) = tt2F ([Event e]\<^sub>E # t)"
  shows "Some(tl s,X) = tt2F t"
  using assms apply (induct t arbitrary:e X, auto)
  by (metis (no_types, lifting) list.sel(3) option.case_eq_if option.distinct(1) option.expand option.sel prod.collapse prod.inject)

lemma tt2T_tl_evt:
  assumes "tt2T z = (evt e # xs)"
  shows "tt2T (tl z) = xs"
  using assms apply (induct z, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
  using tt2T.elims by auto

lemma tt2T_hd_evt:
  assumes "tt2T z = (evt e # xs)"
  shows "hd z = [Event e]\<^sub>E"
  using assms apply (induct z, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
  using tt2T.elims by auto

lemma Some_tt2F_concat_refusal:
  assumes "Some (s, X) = tt2F y"
  shows "\<exists>xs R. y = xs@[[R]\<^sub>R] \<and> tt2T xs = s \<and> X = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[R]\<^sub>R])"
  using assms
  proof (induct y arbitrary:s X rule:tt2F.induct)
    case (1 X)
    then show ?case by auto
  next
    case (2 e \<sigma>)
    then obtain t Z where s_R:"Some (t, Z) = tt2F \<sigma>"
      apply auto
      by (meson "2.prems" Some_tt2F_event_tl)
    then have "\<exists>xs R. \<sigma> = xs @ [[R]\<^sub>R] \<and> tt2T xs = t \<and> Z = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[R]\<^sub>R])"
      using 2 by auto
    then have "\<exists>xs R. [Event e]\<^sub>E # \<sigma> = [Event e]\<^sub>E # xs @ [[R]\<^sub>R] \<and> tt2T ([Event e]\<^sub>E # xs @ [[R]\<^sub>R]) = evt e # t \<and> Z = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set ([Event e]\<^sub>E # xs) \<and> ttWF ([Event e]\<^sub>E # xs @ [[R]\<^sub>R])"
      apply auto
      using ttWF_prefix_is_ttWF Some_tt2F_imp_tt2T' s_R by blast
    then show ?case
    proof -
      obtain tts :: "'a ttobs list" and TT :: "'a ttevent set" where
        f1: "[Event e]\<^sub>E # \<sigma> = [Event e]\<^sub>E # tts @ [[TT]\<^sub>R] \<and> tt2T ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R]) = evt e # t \<and> Z = {e. ttevt2F e \<in> TT} \<and> [Tock]\<^sub>E \<notin> set ([Event e]\<^sub>E # tts) \<and> ttWF ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R])"
        using \<open>\<exists>xs R. [Event e]\<^sub>E # \<sigma> = [Event e]\<^sub>E # xs @ [[R]\<^sub>R] \<and> tt2T ([Event e]\<^sub>E # xs @ [[R]\<^sub>R]) = evt e # t \<and> Z = {x. ttevt2F x \<in> R} \<and> [Tock]\<^sub>E \<notin> set ([Event e]\<^sub>E # xs) \<and> ttWF ([Event e]\<^sub>E # xs @ [[R]\<^sub>R])\<close> by blast
      have f2: "\<forall>es E ts. (Some (es, E) \<noteq> tt2F ts \<or> \<not> ttWF ts) \<or> (\<exists>tsa T. ts = tsa @ [[T]\<^sub>R] \<and> E = {e. ttevt2F (e::'a evt) \<in> T} \<and> tt2T tsa = es)"
        by (simp add: some_tt2F_ref_trace)
      obtain ttsa :: "'a ttobs list \<Rightarrow> 'a evt set \<Rightarrow> 'a evt list \<Rightarrow> 'a ttobs list" and TTa :: "'a ttobs list \<Rightarrow> 'a evt set \<Rightarrow> 'a evt list \<Rightarrow> 'a ttevent set" where
        "\<forall>x0 x1 x2. (\<exists>v3 v4. x0 = v3 @ [[v4]\<^sub>R] \<and> x1 = {uua. ttevt2F uua \<in> v4} \<and> tt2T v3 = x2) = (x0 = ttsa x0 x1 x2 @ [[TTa x0 x1 x2]\<^sub>R] \<and> x1 = {uua. ttevt2F uua \<in> TTa x0 x1 x2} \<and> tt2T (ttsa x0 x1 x2) = x2)"
        by moura
      then have f3: "[Event e]\<^sub>E # tts @ [[TT]\<^sub>R] = ttsa ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R]) X s @ [[TTa ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R]) X s]\<^sub>R] \<and> X = {ea. ttevt2F ea \<in> TTa ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R]) X s} \<and> tt2T (ttsa ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R]) X s) = s"
        using f2 f1 "2.prems" by presburger
      then have "[Tock]\<^sub>E \<notin> set (ttsa ([Event e]\<^sub>E # tts @ [[TT]\<^sub>R]) X s)"
        using f1 by simp
      then show ?thesis
        using f3 f1 by metis
    qed
  next
    case "3_1"
    then show ?case by auto
  next
    case ("3_2" va)
    then show ?case by auto
  next
    case ("3_3" va)
    then show ?case by auto
  next
    case ("3_4" vb vc)
    then show ?case by auto
  next
    case ("3_5" vb vc)
    then show ?case by auto
  next
    case ("3_6" va vb vc)
    then show ?case by auto
  qed

lemma
  assumes "Some (s, b) = tt2F (xs@[[X]\<^sub>R])"
  shows "s = tt2T xs \<and> b = {x. ttevt2F x \<in> X}"
  using assms
  using Some_tt2F_concat_refusal by force

lemma tt2F_Some_concat_Nil:
  assumes "[] = tt2T xs" "Some (s, b) = tt2F (xs@[[X]\<^sub>R])"
  shows "xs = []"
  using assms
  by (induct xs rule:ttWF.induct, auto)

lemma ttWF_Some_tt2F:
  assumes "ttWF (xs@[[X]\<^sub>R])" "[Tock]\<^sub>E \<notin> set xs"
  shows "Some (tt2T xs, {x. ttevt2F x \<in> X}) = tt2F (xs@[[X]\<^sub>R])"
  using assms
  apply (induct xs, auto)
  apply (case_tac a, auto)
    apply (case_tac x1, auto)
  apply (smt fst_conv option.simps(5) snd_conv)
   apply (metis list.exhaust_sel option.distinct(1) tt2F.simps(3) ttWF.simps(1) ttWF.simps(8))
  by (case_tac xsa, auto, case_tac a, auto, case_tac x1, auto)

lemma Some_tt2F_subset:
  assumes "Some (s, b \<union> HS) = tt2F y"
  shows "\<exists>z. Some (s, b) = tt2F z \<and> z \<lesssim>\<^sub>C y"
proof -
  obtain xs X where xs_X:"y = xs@[[X]\<^sub>R] \<and> b \<union> HS = {x. ttevt2F x \<in> X} \<and> [Tock]\<^sub>E \<notin> set xs \<and> ttWF(xs@[[X]\<^sub>R])"
    using Some_tt2F_concat_refusal assms by blast

  then have "ttevt2F`(b \<union> HS) \<subseteq> X"
    by auto

  then have "xs@[[ttevt2F`b]\<^sub>R] \<lesssim>\<^sub>C xs@[[X]\<^sub>R]"
    apply auto
    by (simp add: image_Un tt_prefix_common_concat)

  then have "Some (tt2T xs, b \<union> HS) = tt2F (xs@[[X]\<^sub>R])"
    apply auto
    using Some_tt2F_concat_refusal assms xs_X by blast

  have "ttWF (xs@[[ttevt2F`b]\<^sub>R])"
    using \<open>xs @ [[ttevt2F ` b]\<^sub>R] \<lesssim>\<^sub>C xs @ [[X]\<^sub>R]\<close> tt_prefix_subset_ttWF xs_X by blast

  have Tock_not_in_xs_b:"[Tock]\<^sub>E \<notin> set (xs@[[ttevt2F`b]\<^sub>R])"
    by (simp add: xs_X)

  have b_ttevt2F:"b = {x. ttevt2F x \<in> ttevt2F`b}"
    using Some_tt2F_set by fastforce

  then have "Some (tt2T xs, b) = tt2F (xs@[[ttevt2F`b]\<^sub>R])"
    using Tock_not_in_xs_b ttWF_Some_tt2F b_ttevt2F
    using \<open>ttWF (xs @ [[ttevt2F ` b]\<^sub>R])\<close> by fastforce

  then show ?thesis
    by (metis Pair_inject \<open>Some (tt2T xs, b \<union> HS) = tt2F (xs @ [[X]\<^sub>R])\<close> \<open>xs @ [[ttevt2F ` b]\<^sub>R] \<lesssim>\<^sub>C xs @ [[X]\<^sub>R]\<close> assms option.inject xs_X)
qed

lemma Some_no_tick_trace[simp]:
  assumes "Some (a, b) = tt2F y"
  shows "tick \<notin> set a"
  using assms apply (induct a arbitrary:b y, auto)
  using Some_no_tt2F_tick apply blast
  using Some_tt2F_tail by blast

lemma tt2T_concat_dist:
  assumes "[Tick]\<^sub>E \<notin> set s" "[Tock]\<^sub>E \<notin> set s" "\<not>(\<exists>R. [R]\<^sub>R \<in> set s)"
  shows "tt2T (s @ t) = (tt2T s) @ (tt2T t)"
  using assms apply (induct s arbitrary: t, auto)
  apply (case_tac a, auto)
  by (case_tac x1, auto)

lemma Some_tt2F_no_prev_refusals:
  assumes "Some (a, b) = tt2F (s @ [[R]\<^sub>R])"
  shows "\<not>(\<exists>R. [R]\<^sub>R \<in> set s)"
  using assms apply (induct s arbitrary:a b R, auto)
   apply (metis list.exhaust_sel option.distinct(1) snoc_eq_iff_butlast tt2F.simps(8))
  by (metis (no_types, hide_lams) Some_tt2F_tail append_Cons append_Nil list.sel(3) neq_Nil_conv tt2F_some_exists)

lemma tt2T_tick_butlast:
  assumes "s @ [tick] = tt2T y"
  shows "tt2T (butlast y) = s"
  using assms apply (induct y arbitrary:s, auto)
   apply (case_tac a, auto)
   apply (case_tac x1, auto)
  apply (case_tac a, auto)
   apply (case_tac x1, auto)
   apply (metis (no_types, lifting) append_eq_Cons_conv evt.distinct(1) list.inject)
  by (metis list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))

lemma tt2T_tick_exists_Cons:
  assumes "s @ [tick] = tt2T y"
  shows "\<exists>z. z@[[Tick]\<^sub>E] = y"
  using assms apply (induct y arbitrary:s, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
   apply (metis Cons_eq_append_conv evt.distinct(1) list.inject)
  by (metis append_Nil list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))

lemma
  assumes "s @ [tick] = tt2T (z @ [[Tick]\<^sub>E])"
  shows "s = tt2T z"
  using assms
  using tt2T_tick_butlast by fastforce

lemma tick_tt2T_concat_TickE[intro?]:
  assumes "[tick] = tt2T (za @ [[Tick]\<^sub>E])"
  shows "za = []"
  using assms apply (induct za, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
  by (metis list.distinct(1) list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))

lemma Some_concat_extend:
  assumes "Some (t, b) = tt2F ya" "[Tick]\<^sub>E \<notin> set z" "[Tock]\<^sub>E \<notin> set z" "\<not>(\<exists>R. [R]\<^sub>R \<in> set z)" (* *)
  shows "Some (tt2T z @ t, b) = tt2F (z @ ya)"
  using assms apply (induct z arbitrary:t ya b rule:tt2F.induct , auto)
  by (smt fst_conv option.simps(5) snd_conv)

lemma tt2T_concat_Tick_no_Tick_set:
  assumes "s @ [tick] = tt2T (z @ [[Tick]\<^sub>E])"
  shows "[Tick]\<^sub>E \<notin> set z"
  using assms apply (induct z arbitrary:s, auto)
   apply (metis list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
   apply (metis append_Nil evt.distinct(1) list.sel(1) list.sel(3) tl_append2)
  by (metis list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))

lemma tt2T_concat_Tick_no_Ref_set:
  assumes "s @ [tick] = tt2T (z @ [[Tick]\<^sub>E])"
  shows "\<not>(\<exists>R. [R]\<^sub>R \<in> set z)"
  using assms apply (induct z arbitrary:s, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
   apply (metis append_Nil evt.distinct(1) list.sel(1) list.sel(3) tl_append2)
  by (metis list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))

lemma tt2T_concat_Tick_no_Tock_set:
  assumes "s @ [tick] = tt2T (z @ [[Tick]\<^sub>E])"
  shows "[Tock]\<^sub>E \<notin> set z"
  using assms apply (induct z arbitrary:s, auto)
  apply (case_tac a, auto)
  apply (case_tac x1, auto)
   apply (metis append_Nil evt.distinct(1) list.sel(1) list.sel(3) tl_append2)
  by (metis list.exhaust_sel snoc_eq_iff_butlast tt2T.simps(7))

lemma Some_concat_extend':
  assumes "Some (t, b) = tt2F ya" "s @ [tick] = tt2T (z @ [[Tick]\<^sub>E])"
  shows "Some (tt2T z @ t, b) = tt2F (z @ ya)"
  using assms Some_concat_extend tt2T_concat_Tick_no_Tick_set tt2T_concat_Tick_no_Ref_set tt2T_concat_Tick_no_Tock_set
  by blast

lemma Tick_no_eq:
  assumes "[Tick]\<^sub>E \<notin> set y"
  shows "\<forall>s. y \<noteq> s @ [[Tick]\<^sub>E]"
  using assms by (induct y rule:rev_induct, auto)

lemma Tick_set_tt2T_in:
  assumes "tick \<in> set (tt2T y)"
  shows "[Tick]\<^sub>E \<in> set y"
  using assms apply (induct y, auto)
  apply (case_tac a, auto)
  by (case_tac x1, auto)

lemma Tick_set_ends_in_Tick:
  assumes "[Tick]\<^sub>E \<in> set y" "ttWF y"
  shows "\<exists>xs. y = xs@[[Tick]\<^sub>E]"
  using assms apply (induct y, auto)
  using ttWF.elims(2) apply auto[1]
  by (metis append_Cons append_Nil list.exhaust_sel split_list ttWF.simps(8) ttWF_dist_notTock_cons ttevent.distinct(5))

lemma Tock_in_trace_Tick_no_Tick:
  assumes "[Tock]\<^sub>E \<in> set s"  "ttWF (s @ [[Tick]\<^sub>E])"
  shows "tick \<notin> set (tt2T (s @ t))"
  using assms by (induct s rule:tt2T.induct, auto)

lemma Tock_in_trace_Refusal_no_Tick:
  assumes "(\<exists>R. [R]\<^sub>R \<in> set s)"  "ttWF (s @ [[Tick]\<^sub>E])"
  shows "tick \<notin> set (tt2T (s @ t))"
  using assms by (induct s rule:tt2T.induct, auto)

lemma Tock_in_concat_lhs:
  assumes "[Tock]\<^sub>E \<in> set s"
  shows "tt2T (s @ t) = tt2T s"
  using assms by (induct s rule:tt2T.induct, auto)

lemma Ref_in_concat_lhs:
  assumes "(\<exists>R. [R]\<^sub>R \<in> set s)"
  shows "tt2T (s @ t) = tt2T s"
  using assms by (induct s rule:tt2T.induct, auto)

fun F2tt_trace :: "'a failure \<Rightarrow> 'a tttrace set" where
  "F2tt_trace ([], X) = {[[ttevt2F ` X]\<^sub>R], [[(ttevt2F ` X) \<union> {Tock}]\<^sub>R]}" |
  "F2tt_trace (e # t, X) = {s. \<exists>s'. s = [ttevt2F e]\<^sub>E # s' \<and> s' \<in> F2tt_trace (t, X)}"

definition "F2tt" :: "'a process \<Rightarrow> 'a ttprocess" where
  "F2tt P = \<Union>(F2tt_trace ` (fst P)) \<union> map (\<lambda>e. [ttevt2F e]\<^sub>E) ` (snd P)"

lemma F2tt_ttproc2F_no_tocks:
  assumes P_no_tock: "\<forall>t\<in>P. [Tock]\<^sub>E \<notin> set t" and P_wf: "\<forall>x\<in>P. ttWF x" and TT1_P: "TT1 P" and TT2_P: "TT2 P"
  shows "P = F2tt (ttproc2F P)"
  unfolding F2tt_def ttproc2F_def image_def
proof auto
  fix x :: "'a tttrace"
  have "\<And>P. ttWF x \<Longrightarrow> [Tock]\<^sub>E \<notin> set x \<Longrightarrow> x \<in> P \<Longrightarrow> \<forall>xa. (\<forall>a b. (\<forall>y. Some (a, b) = tt2F y \<longrightarrow> y \<notin> P) \<or> xa \<noteq> F2tt_trace (a, b)) \<or> x \<notin> xa \<Longrightarrow>
         \<exists>xa. (\<exists>y. xa = tt2T y \<and> y \<in> P) \<and> x = map (\<lambda>e. [ttevt2F e]\<^sub>E) xa"
  proof (induct x rule:ttWF.induct, auto)
    fix P :: "'a ttprocess"
    show "[] \<in> P \<Longrightarrow> \<exists>y. [] = tt2T y \<and> y \<in> P"
      by (rule_tac x="[]" in exI, auto)
  next
    fix X and P :: "'a ttprocess"
    show "[[X]\<^sub>R] \<in> P \<Longrightarrow>
           \<forall>xa. (\<forall>a b. (\<forall>y. Some (a, b) = tt2F y \<longrightarrow> y \<notin> P) \<or> xa \<noteq> F2tt_trace (a, b)) \<or> [[X]\<^sub>R] \<notin> xa \<Longrightarrow>
           \<exists>xa. (\<exists>y. xa = tt2T y \<and> y \<in> P) \<and> [[X]\<^sub>R] = map (\<lambda>e. [ttevt2F e]\<^sub>E) xa"
      apply (erule_tac x="{[[X\<union>{Tock}]\<^sub>R], [[{e\<in>X. e \<noteq> Tock}]\<^sub>R]}" in allE, auto)
    proof (erule_tac x="[]" in allE, erule_tac x="{e. ttevt2F e \<in> X}" in allE, safe, simp_all)
      have "insert Tock X = insert Tock (ttevt2F ` {e. ttevt2F e \<in> X})"
        by (auto, smt image_eqI mem_Collect_eq ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))
      then show "insert Tock X = ttevt2F ` {e. ttevt2F e \<in> X} \<or> insert Tock X = insert Tock (ttevt2F ` {e. ttevt2F e \<in> X})"
        by auto
    next
      have "{e \<in> X. e \<noteq> Tock} = ttevt2F ` {e. ttevt2F e \<in> X}"
        apply (auto, metis (no_types, lifting) image_iff mem_Collect_eq ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))
        by (metis evt.exhaust ttevent.distinct(1) ttevent.distinct(5) ttevt2F.simps(1) ttevt2F.simps(2))
      then show "{e \<in> X. e \<noteq> Tock} = ttevt2F ` {e. ttevt2F e \<in> X} \<or> {e \<in> X. e \<noteq> Tock} = insert Tock (ttevt2F ` {e. ttevt2F e \<in> X})"
        by auto
    next
      fix x
      assume "x = [[ttevt2F ` {e. ttevt2F e \<in> X}]\<^sub>R] \<or> x = [[insert Tock (ttevt2F ` {e. ttevt2F e \<in> X})]\<^sub>R]"
      then show "x \<noteq> [[insert Tock X]\<^sub>R] \<Longrightarrow> x = [[{e \<in> X. e \<noteq> Tock}]\<^sub>R]"
        by (auto, (smt image_iff mem_Collect_eq ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))+)
    qed
  next
    fix e \<sigma> and P :: "'a ttprocess"
    assume case_assms: "ttWF \<sigma>" "[Event e]\<^sub>E # \<sigma> \<in> P"
    assume ind_hyp: "\<And>P. \<sigma> \<in> P \<Longrightarrow>
             \<forall>xa. (\<forall>a b. (\<forall>y. Some (a, b) = tt2F y \<longrightarrow> y \<notin> P) \<or> xa \<noteq> F2tt_trace (a, b)) \<or> \<sigma> \<notin> xa \<Longrightarrow>
             \<exists>xa. (\<exists>y. xa = tt2T y \<and> y \<in> P) \<and> \<sigma> = map (\<lambda>e. [ttevt2F e]\<^sub>E) xa"
    assume "\<forall>xa. (\<forall>a b. (\<forall>y. Some (a, b) = tt2F y \<longrightarrow> y \<notin> P) \<or> xa \<noteq> F2tt_trace (a, b)) \<or> [Event e]\<^sub>E # \<sigma> \<notin> xa"
    then have "\<forall>xa. (\<forall>a b. (\<forall>y. Some (a, b) = tt2F y \<longrightarrow> y \<notin> {t. [Event e]\<^sub>E # t \<in> P}) \<or> xa \<noteq> F2tt_trace (a, b)) \<or> \<sigma> \<notin> xa"
      apply (auto, erule_tac x="F2tt_trace (evt e # a, b)" in allE, auto)
      apply (erule_tac x="evt e # a" in allE, erule_tac x=b in allE, auto)
      by (erule_tac x="[Event e]\<^sub>E # y" in allE, auto, case_tac "tt2F y", auto)
    then have "\<exists>xa. (\<exists>y. xa = tt2T y \<and> y \<in> {t. [Event e]\<^sub>E # t \<in> P}) \<and> \<sigma> = map (\<lambda>e. [ttevt2F e]\<^sub>E) xa"
      using ind_hyp[where P="{t. [Event e]\<^sub>E # t \<in> P}"] case_assms by auto
    then show "\<exists>xa. (\<exists>y. xa = tt2T y \<and> y \<in> P) \<and> [Event e]\<^sub>E # \<sigma> = map (\<lambda>e. [ttevt2F e]\<^sub>E) xa"
      by auto
  qed
  then show "x \<in> P \<Longrightarrow>
         \<forall>xa. (\<forall>a b. (\<forall>y. Some (a, b) = tt2F y \<longrightarrow> y \<notin> P) \<or> xa \<noteq> F2tt_trace (a, b)) \<or> x \<notin> xa \<Longrightarrow>
         \<exists>xa. (\<exists>y. xa = tt2T y \<and> y \<in> P) \<and> x = map (\<lambda>e. [ttevt2F e]\<^sub>E) xa"
    by (simp add: P_no_tock P_wf)
next
  fix a b and x y :: "'a tttrace"
  have "\<And> P x a. ttWF y \<Longrightarrow> y @ [[Tock]\<^sub>E] \<notin> P \<Longrightarrow> TT1 P \<Longrightarrow> TT2 P \<Longrightarrow> x \<in> F2tt_trace (a, b) \<Longrightarrow>
      Some (a, b) = tt2F y \<Longrightarrow> y \<in> P \<Longrightarrow> x \<in> P"
  proof (induct y rule:ttWF.induct, auto)
    fix X and P :: "'a ttprocess"
    show "TT1 P \<Longrightarrow> [[X]\<^sub>R] \<in> P \<Longrightarrow> [[ttevt2F ` {x. ttevt2F x \<in> X}]\<^sub>R] \<in> P"
      unfolding TT1_def apply auto
      by (metis (no_types, lifting) image_Collect_subsetI tt_prefix_subset.simps(1) tt_prefix_subset.simps(2))
  next
    fix X and P :: "'a ttprocess"
    assume "TT2 P" "[[X]\<^sub>R] \<in> P" "[[X]\<^sub>R, [Tock]\<^sub>E] \<notin> P"
    then have "[[insert Tock X]\<^sub>R] \<in> P"
      unfolding TT2_def
      apply (erule_tac x="[]" in allE, erule_tac x="[]" in allE)
      by (erule_tac x=X in allE, erule_tac x="{Tock}" in allE, auto)
    also have "insert Tock (ttevt2F ` {x. ttevt2F x \<in> X}) = insert Tock X"
      unfolding image_def by (auto, case_tac x, auto, metis ttevt2F.simps(1), metis ttevt2F.simps(2))
    then show "[[insert Tock (ttevt2F ` {x. ttevt2F x \<in> X})]\<^sub>R] \<in> P"
      using calculation by auto
  next
    fix e \<sigma> x a and P :: "'a ttprocess"
    assume case_assms: "ttWF \<sigma>" "[Event e]\<^sub>E # \<sigma> @ [[Tock]\<^sub>E] \<notin> P" "TT1 P" "TT2 P" "x \<in> F2tt_trace (a, b)"
       "Some (a, b) = (case tt2F \<sigma> of None \<Rightarrow> None | Some fl \<Rightarrow> Some (evt e # fst fl, snd fl))" "[Event e]\<^sub>E # \<sigma> \<in> P"
    assume ind_hyp: "\<And>P x a. \<sigma> @ [[Tock]\<^sub>E] \<notin> P \<Longrightarrow> TT1 P \<Longrightarrow> TT2 P \<Longrightarrow> x \<in> F2tt_trace (a, b) \<Longrightarrow> Some (a, b) = tt2F \<sigma> \<Longrightarrow> \<sigma> \<in> P \<Longrightarrow> x \<in> P"

    obtain a' where a'_assms: "Some (a', b) = tt2F \<sigma> \<and> a = evt e # a'"
      using case_assms(6) by (cases "tt2F \<sigma>", safe, simp_all)
    obtain x' where x'_assms: "x = [Event e]\<^sub>E # x' \<and> x' \<in> F2tt_trace (a', b)"
      using case_assms(5) a'_assms by auto

    thm ind_hyp[where P="{t. [Event e]\<^sub>E # t \<in> P}", where x=x, where a=a']
    have 1:  "\<sigma> @ [[Tock]\<^sub>E] \<notin> {t. [Event e]\<^sub>E # t \<in> P}"
      using case_assms(2) by blast
    have 2: "TT1 {t. [Event e]\<^sub>E # t \<in> P}"
      by (simp add: TT1_init_event case_assms(3))
    have 3: "TT2 {t. [Event e]\<^sub>E # t \<in> P}"
      by (simp add: TT2_init_event case_assms(4))

    have "x' \<in> {t. [Event e]\<^sub>E # t \<in> P}"
      using ind_hyp[where P="{t. [Event e]\<^sub>E # t \<in> P}"] 1 2 3 case_assms x'_assms a'_assms by auto
    then show "x \<in> P"
      using x'_assms by blast
  qed
  then show "x \<in> F2tt_trace (a, b) \<Longrightarrow> Some (a, b) = tt2F y \<Longrightarrow> y \<in> P \<Longrightarrow> x \<in> P"
    by (meson P_no_tock P_wf TT1_P TT2_P in_set_conv_decomp)
next
  fix y :: "'a tttrace"
  have "ttWF y \<Longrightarrow> map (\<lambda>e. [ttevt2F e]\<^sub>E) (tt2T y) \<lesssim>\<^sub>C y"
    by (induct y rule:ttWF.induct, auto)
  then show "y \<in> P \<Longrightarrow> map (\<lambda>e. [ttevt2F e]\<^sub>E) (tt2T y) \<in> P"
    using P_wf TT1_P TT1_def by blast
qed

lemma ttproc2F_eq_no_tocks_imp_F2tt_eq:
  assumes "ttproc2F P = Q"
  assumes "\<forall>t\<in>P. [Tock]\<^sub>E \<notin> set t" "\<forall>x\<in>P. ttWF x" "TT1 P" "TT2 P"
  shows "P = F2tt Q"
  using assms F2tt_ttproc2F_no_tocks by auto

end


(*  Title:      JinjaDCI/Compiler/PCompiler.thy

    Author:     Tobias Nipkow, Susannah Mansky
    Copyright   TUM 2003, UIUC 2019-20

    Based on the Jinja theory Common/PCompiler.thy by Tobias Nipkow
*)

section \<open> Program Compilation \<close>

theory PCompiler
imports "../Common/WellForm"
begin

definition compM :: "(staticb \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a mdecl \<Rightarrow> 'b mdecl"
where
  "compM f  \<equiv>  \<lambda>(M, b, Ts, T, m). (M, b, Ts, T, f b m)"

definition compC :: "(staticb \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a cdecl \<Rightarrow> 'b cdecl"
where
  "compC f  \<equiv>  \<lambda>(C,D,Fdecls,Mdecls). (C,D,Fdecls, map (compM f) Mdecls)"

definition compP :: "(staticb \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a prog \<Rightarrow> 'b prog"
where
  "compP f  \<equiv>  map (compC f)"

text\<open> Compilation preserves the program structure.  Therefore lookup
functions either commute with compilation (like method lookup) or are
preserved by it (like the subclass relation). \<close>

lemma map_of_map4:
  "map_of (map (\<lambda>(x,a,b,c).(x,a,b,f c)) ts) =
  map_option (\<lambda>(a,b,c).(a,b,f c)) \<circ> (map_of ts)"
(*<*)
proof(induct ts)
  case Nil then show ?case by simp
qed fastforce
(*>*)

lemma map_of_map245:
  "map_of (map (\<lambda>(x,a,b,c,d).(x,a,b,c,f a c d)) ts) =
  map_option (\<lambda>(a,b,c,d).(a,b,c,f a c d)) \<circ> (map_of ts)"
(*<*)
proof(induct ts)
  case Nil then show ?case by simp
qed fastforce
(*>*)

lemma class_compP:
  "class P C = Some (D, fs, ms)
  \<Longrightarrow> class (compP f P) C = Some (D, fs, map (compM f) ms)"
(*<*)by(simp add:class_def compP_def compC_def map_of_map4)(*>*)

lemma class_compPD:
  "class (compP f P) C = Some (D, fs, cms)
  \<Longrightarrow> \<exists>ms. class P C = Some(D,fs,ms) \<and> cms = map (compM f) ms"
(*<*)by(clarsimp simp add:class_def compP_def compC_def map_of_map4)(*>*)

lemma [simp]: "class (compP f P) C = map_option (\<lambda>c. snd(compC f (C,c))) (class P C)"
(*<*)
by(simp add:compP_def compC_def class_def map_of_map4)
  (simp add:split_def)
(*>*)

lemma sees_methods_compP:
  "P \<turnstile> C sees_methods Mm \<Longrightarrow>
  compP f P \<turnstile> C sees_methods (map_option (\<lambda>((b,Ts,T,m),D). ((b,Ts,T,f b m),D)) \<circ> Mm)"
(*<*)(is "?P \<Longrightarrow> compP f P \<turnstile> C sees_methods (?map Mm)")
proof(induct rule: Methods.induct)
  case Object: (sees_methods_Object D fs ms Mm)
  let ?Mm1 = "\<lambda>x. map_option ((\<lambda>m. (m, Object)) \<circ> (\<lambda>(b, Ts, T, m). (b, Ts, T, f b m))) (map_of ms x)"
  let ?Mm2 = "\<lambda>x. map_option (case_prod (\<lambda>(b, Ts, T, m).
                   Pair (b, Ts, T, f b m)) \<circ> (\<lambda>m. (m, Object))) (map_of ms x)"
  have Mm_eq: "\<And>x. ?Mm1 x = ?Mm2 x"
  proof -
    fix x show "?Mm1 x = ?Mm2 x"
    proof(cases "map_of ms x")
      case None then show ?thesis by simp
    qed fastforce
  qed

  have Mm: "Mm = map_option (\<lambda>m. (m, Object)) \<circ> map_of ms" by fact
  let ?Mm = "map_option (\<lambda>m. (m, Object)) \<circ> map_of (map (compM f) ms)"
  let ?Mm' = "?map Mm"
  have "?Mm' = ?Mm"
    by(rule ext) (simp add:Mm Mm_eq compM_def map_of_map245 option.map_comp)
  then show ?case by(rule sees_methods_Object[OF class_compP[OF Object(1)]])
next
  case rec: (sees_methods_rec C D fs ms Mm Mm')
  have Mm': "Mm' = Mm ++ (map_option (\<lambda>m. (m, C)) \<circ> map_of ms)" by fact
  let ?Mm' = "?map Mm'"
  let ?Mm'' = "(?map Mm) ++ (map_option (\<lambda>m. (m, C)) \<circ> map_of (map (compM f) ms))"
  have "?Mm' = ?Mm''"
    by(rule ext) (simp add:Mm' map_add_def compM_def map_of_map245)
  moreover have "compP f P \<turnstile> C sees_methods ?Mm''"
    using sees_methods_rec[OF class_compP[OF rec(1)] rec(2,4)] by fast
  ultimately show "compP f P \<turnstile> C sees_methods ?Mm'" by simp
qed
(*>*)

lemma sees_method_compP:
  "P \<turnstile> C sees M,b: Ts\<rightarrow>T = m in D \<Longrightarrow>
  compP f P \<turnstile> C sees M,b: Ts\<rightarrow>T = (f b m) in D"
(*<*)by(fastforce elim:sees_methods_compP simp add:Method_def)(*>*)

lemma [simp]:
  "P \<turnstile> C sees M,b: Ts\<rightarrow>T = m in D \<Longrightarrow>
  method (compP f P) C M = (D,b,Ts,T,f b m)"
(*<*)
proof -
  let ?P = "\<lambda>(D, b, Ts, T, m). compP f P \<turnstile> C sees M, b :  Ts\<rightarrow>T = m in D"
  let ?a = "(D, b, Ts, T, f b m)"
  assume cM: "P \<turnstile> C sees M,b: Ts\<rightarrow>T = m in D"
  have compP_cM: "?P ?a" using sees_method_compP[OF cM] by simp
  moreover {
    fix x assume "?P x" then have "x = ?a"
      using compP_cM by(fastforce dest:sees_method_fun)
  }
  ultimately have "(THE x. ?P x) = ?a" by(rule the_equality)
  then show ?thesis by(simp add:method_def)
qed
(*>*)

lemma sees_methods_compPD:
  "\<lbrakk> cP \<turnstile> C sees_methods Mm'; cP = compP f P \<rbrakk> \<Longrightarrow>
  \<exists>Mm. P \<turnstile> C sees_methods Mm \<and>
        Mm' = (map_option (\<lambda>((b,Ts,T,m),D). ((b,Ts,T,f b m),D)) \<circ> Mm)"
(*<*)(is "\<lbrakk> ?P; ?Q \<rbrakk> \<Longrightarrow> \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> Mm' = (?map Mm)")
proof(induct rule: Methods.induct)
  case Object: (sees_methods_Object D fs ms Mm)
  then obtain ms' where P_Obj: "class P Object = \<lfloor>(D, fs, ms')\<rfloor>"
    and ms: "ms = map (compM f) ms'" by(clarsimp simp:compC_def)

  let ?Mm1 = "\<lambda>x. map_option ((\<lambda>m. (m, Object)) \<circ> (\<lambda>(b, Ts, T, m). (b, Ts, T, f b m))) (map_of ms' x)"
  let ?Mm2 = "\<lambda>x. map_option (case_prod (\<lambda>(b, Ts, T, m). Pair (b, Ts, T, f b m)) \<circ> (\<lambda>m. (m, Object)))
          (map_of ms' x)"
  have Mm_eq: "\<And>x. ?Mm1 x = ?Mm2 x"
  proof -
    fix x show "?Mm1 x = ?Mm2 x"
    proof(cases "map_of ms' x")
      case None then show ?thesis by simp
    qed fastforce
  qed

  let ?Mm = "map_option (\<lambda>m. (m,Object)) \<circ> map_of ms'"
  let ?Mm' = "?map ?Mm"
  have Mm: "Mm = map_option (\<lambda>m. (m, Object)) \<circ> map_of ms" by fact
  have "P \<turnstile> Object sees_methods ?Mm"
    using sees_methods_Object[OF P_Obj] by simp
  moreover have "Mm = ?Mm'"
    by(rule ext) (simp add:Mm_eq Mm ms compM_def map_of_map245 option.map_comp)
  ultimately show ?case by fast
next
  case rec: (sees_methods_rec C D fs ms Mm Mm')
  then obtain ms' Mm\<^sub>D where P_D: "class P C = \<lfloor>(D, fs, ms')\<rfloor>"
     and ms: "ms = map (compM f) ms'" and C_nObj: "C \<noteq> Object"
     and Mm\<^sub>D: "P \<turnstile> D sees_methods Mm\<^sub>D"
     and Mm: "Mm = (\<lambda>a. map_option (case_prod (\<lambda>(b, Ts, T, m). Pair (b, Ts, T, f b m))) (Mm\<^sub>D a))"
    by(clarsimp simp:compC_def)

  let ?Mm = "Mm\<^sub>D ++ (map_option (\<lambda>m. (m, C)) \<circ> map_of ms')"
  let ?Mm1 = "Mm ++ (map_option (\<lambda>m. (m, C)) \<circ> map_of ms)"
  let ?Mm2 = "Mm ++ (map_option (\<lambda>m. (m, C)) \<circ> map_of (map (compM f) ms'))"
  let ?Mm3 = "?map ?Mm"
  have "Mm' = ?Mm1" by fact
  also have "\<dots> = ?Mm2" using ms by simp
  also have "\<dots> = ?Mm3"
    by(rule ext)(simp add:Mm map_add_def compM_def map_of_map245)
  moreover have "P \<turnstile> C sees_methods ?Mm"
    using sees_methods_rec[OF P_D C_nObj Mm\<^sub>D] by simp
  ultimately show ?case by fast
qed
(*>*)

lemma sees_method_compPD:
  "compP f P \<turnstile> C sees M,b: Ts\<rightarrow>T = fm in D \<Longrightarrow>
  \<exists>m. P \<turnstile> C sees M,b: Ts\<rightarrow>T = m in D \<and> f b m = fm"
(*<*)
proof -
  assume "compP f P \<turnstile> C sees M,b: Ts\<rightarrow>T = fm in D"
  then obtain Mm where Mm: "compP f P \<turnstile> C sees_methods Mm"
     and MmM: "Mm M = \<lfloor>((b, Ts, T, fm), D)\<rfloor>"
    by(clarsimp simp:Method_def)
  show ?thesis using sees_methods_compPD[OF Mm refl] MmM
    by(fastforce simp: Method_def)
qed
(*>*)

lemma [simp]: "subcls1(compP f P) = subcls1 P"
(*<*)
by(fastforce simp add: is_class_def compC_def intro:subcls1I order_antisym dest:subcls1D)
(*>*)

lemma compP_widen[simp]: "(compP f P \<turnstile> T \<le> T') = (P \<turnstile> T \<le> T')"
(*<*)by(cases T')(simp_all add:widen_Class)(*>*)

lemma [simp]: "(compP f P \<turnstile> Ts [\<le>] Ts') = (P \<turnstile> Ts [\<le>] Ts')"
(*<*)
proof(induct Ts)
  case (Cons a Ts)
  then show ?case by(cases Ts')(auto simp:fun_of_def)
qed simp
(*>*)

lemma [simp]: "is_type (compP f P) T = is_type P T"
(*<*)by(cases T) simp_all(*>*)

lemma [simp]: "(compP (f::staticb\<Rightarrow>'a\<Rightarrow>'b) P \<turnstile> C has_fields FDTs) = (P \<turnstile> C has_fields FDTs)"
(*<*)
 (is "?A = ?B")
proof
  { fix cP::"'b prog" assume "cP \<turnstile> C has_fields FDTs"
    hence "cP = compP f P \<Longrightarrow> P \<turnstile> C has_fields FDTs"
    proof induct
      case has_fields_Object
      thus ?case by(fast intro:Fields.has_fields_Object dest:class_compPD)
    next
      case has_fields_rec
      thus ?case by(fast intro:Fields.has_fields_rec dest:class_compPD)
    qed
  } note lem = this
  assume ?A
  with lem show ?B by blast
next
  assume ?B
  thus ?A
  proof induct
    case has_fields_Object
    thus ?case by(fast intro:Fields.has_fields_Object class_compP)
  next
    case has_fields_rec
    thus ?case by(fast intro:Fields.has_fields_rec class_compP)
  qed
qed
(*>*)

lemma fields_compP [simp]: "fields (compP f P) C = fields P C"
(*<*)by(simp add:fields_def)(*>*)

lemma ifields_compP [simp]: "ifields (compP f P) C = ifields P C"
(*<*)by(simp add:ifields_def)(*>*)

lemma blank_compP [simp]: "blank (compP f P) C = blank P C"
(*<*)by(simp add:blank_def)(*>*)

lemma isfields_compP [simp]: "isfields (compP f P) C = isfields P C"
(*<*)by(simp add:isfields_def)(*>*)

lemma sblank_compP [simp]: "sblank (compP f P) C = sblank P C"
(*<*)by(simp add:sblank_def)(*>*)

lemma sees_fields_compP [simp]: "(compP f P \<turnstile> C sees F,b:T in D) = (P \<turnstile> C sees F,b:T in D)"
(*<*)by(simp add:sees_field_def)(*>*)

lemma has_field_compP [simp]: "(compP f P \<turnstile> C has F,b:T in D) = (P \<turnstile> C has F,b:T in D)"
(*<*)by(simp add:has_field_def)(*>*)

lemma field_compP [simp]: "field (compP f P) F D = field P F D"
(*<*)by(simp add:field_def)(*>*)

subsection\<open>Invariance of @{term wf_prog} under compilation \<close>

lemma [iff]: "distinct_fst (map (compM f) ms) = distinct_fst ms"
(*<*)
by (induct ms)
   (auto simp:distinct_fst_def compM_def image_iff)
(*>*)

lemma [iff]: "wf_syscls (compP f P) = wf_syscls P"
(*<*)by(simp add:wf_syscls_def compP_def compC_def image_def Bex_def)(*>*)

lemma [iff]: "wf_fdecl (compP f P) = wf_fdecl P"
(*<*)by(simp add:wf_fdecl_def)(*>*)

lemma wf_clinit_compM [iff]: "wf_clinit (map (compM f) ms) = wf_clinit ms"
(*<*)
proof(rule iffI)
  assume "wf_clinit (map (compM f) ms)"
  then obtain m where "(clinit, Static, [], Void, m) \<in> set ms"
    by(clarsimp simp: wf_clinit_def compM_def)
  then show "wf_clinit ms" by(fastforce simp: wf_clinit_def)
next
  assume "wf_clinit ms"
  then obtain m where "(clinit, Static, [], Void, m) \<in> set ms"
    by(clarsimp simp: wf_clinit_def compM_def)
  then have "\<exists>m. (clinit, Static, [], Void, m)
        \<in> (\<lambda>x. case x of (M, b, Ts, T, m) \<Rightarrow> (M, b, Ts, T, f b m)) ` set ms"
    by(rule_tac x = "f Static m" in exI) (simp add: rev_image_eqI)
  then show "wf_clinit (map (compM f) ms)"
    by(simp add: wf_clinit_def compM_def)
qed
(*>*)

lemma set_compP:
 "((C,D,fs,ms') \<in> set(compP f P)) =
  (\<exists>ms. (C,D,fs,ms) \<in> set P \<and> ms' = map (compM f) ms)"
(*<*)by(fastforce simp add:compP_def compC_def image_iff Bex_def)(*>*)

lemma wf_cdecl_compPI:
  "\<lbrakk> \<And>C M b Ts T m.
     \<lbrakk> wf_mdecl wf\<^sub>1 P C (M,b,Ts,T,m); P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in C \<rbrakk>
     \<Longrightarrow> wf_mdecl wf\<^sub>2 (compP f P) C (M,b,Ts,T, f b m);
    \<forall>x\<in>set P. wf_cdecl wf\<^sub>1 P x; x \<in> set (compP f P); wf_prog p P \<rbrakk>
  \<Longrightarrow> wf_cdecl wf\<^sub>2 (compP f P) x"
(*<*)
proof -
  assume
   wfm: "\<And>C M b Ts T m. \<lbrakk> wf_mdecl wf\<^sub>1 P C (M,b,Ts,T,m); P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in C \<rbrakk>
     \<Longrightarrow> wf_mdecl wf\<^sub>2 (compP f P) C (M,b,Ts,T, f b m)"
    and wfc: "\<forall>x\<in>set P. wf_cdecl wf\<^sub>1 P x"
    and compP: "x \<in> set (compP f P)" and wf: "wf_prog p P"
  obtain C D fs ms where x: "x = (C, D, fs, map (compM f) ms)"
    and x_set: "(C, D, fs, ms) \<in> set P"
   using compP by(case_tac x) (clarsimp simp: set_compP)
  have wfc': "wf_cdecl wf\<^sub>1 P (C, D, fs, ms)" using wfc x_set by fast
  let ?P = "compP f P" and ?ms = "compM f ` set ms"
  { fix M b Ts T m
    assume M: "(M,b,Ts,T,m) \<in> set ms"
    then have "wf_mdecl wf\<^sub>1 P C (M, b, Ts, T, m)" using wfc'
      by(simp add:wf_cdecl_def)
    moreover have cM: "P \<turnstile> C sees M, b :  Ts\<rightarrow>T = m in C" using M
      by(rule mdecl_visible[OF wf x_set])
    ultimately have "wf_mdecl wf\<^sub>2 (compP f P) C (M, b, Ts, T, f b m)"
      by(rule wfm)
  }
  then have "\<forall>m \<in> ?ms. wf_mdecl wf\<^sub>2 ?P C m"
    by (clarsimp simp:compM_def)
  moreover have "C \<noteq> Object \<longrightarrow>
   (\<forall>(M,b,Ts,T,m)\<in>?ms.
      \<forall>D' b' Ts' T' m'. ?P \<turnstile> D sees M,b':Ts' \<rightarrow> T' = m' in D' \<longrightarrow>
                       b = b' \<and> P \<turnstile> Ts' [\<le>] Ts \<and> P \<turnstile> T \<le> T')"
  proof -
    { fix M b Ts T m D' b' Ts' T' m'
      assume "C \<noteq> Object" and "(M,b,Ts,T,m)\<in>?ms"
        and dM: "?P \<turnstile> D sees M,b':Ts' \<rightarrow> T' = m' in D'"
      then have "b = b' \<and> P \<turnstile> Ts' [\<le>] Ts \<and> P \<turnstile> T \<le> T'"
       using wfc' sees_method_compPD[OF dM]
        by(fastforce simp:wf_cdecl_def image_iff compM_def)
    }
    then show ?thesis by fast
  qed
  moreover have "(\<forall>f\<in>set fs. wf_fdecl P f) \<and> distinct_fst fs
     \<and> distinct_fst ms \<and> wf_clinit ms
     \<and> (C \<noteq> Object \<longrightarrow> is_class P D \<and> \<not> P \<turnstile> D \<preceq>\<^sup>* C)" using wfc'
    by(simp add: wf_cdecl_def)
  ultimately show ?thesis using x by(simp add:wf_cdecl_def)
qed
(*>*)

lemma wf_prog_compPI:
assumes lift:
  "\<And>C M b Ts T m.
    \<lbrakk> P \<turnstile> C sees M,b:Ts\<rightarrow>T = m in C; wf_mdecl wf\<^sub>1 P C (M,b,Ts,T,m) \<rbrakk>
    \<Longrightarrow> wf_mdecl wf\<^sub>2 (compP f P) C (M,b,Ts,T, f b m)"
and wf: "wf_prog wf\<^sub>1 P"
shows "wf_prog wf\<^sub>2 (compP f P)"
(*<*)
using wf
by (simp add:wf_prog_def) (blast intro:wf_cdecl_compPI lift wf)
(*>*)

end


theory TTreeImplCardinalitySafe
imports TTreeImplCardinality TTreeAnalysisSpec CardinalityAnalysisSpec
begin

hide_const Multiset.single

lemma pathsCard_paths_nxt:  "pathsCard (paths (nxt f x)) \<sqsubseteq> record_call x\<cdot>(pathsCard (paths f))"
  apply transfer
  apply (rule pathsCard_below)
  apply auto
  apply (erule below_trans[OF _ monofun_cfun_arg[OF paths_Card_above], rotated]) back
  apply (auto intro: fun_belowI simp add: record_call_simp two_pred_two_add_once)
  done

lemma pathsCards_none: "pathsCard (paths t) x = none \<Longrightarrow> x \<notin> carrier t"
  by transfer (auto dest: pathCards_noneD)

lemma const_on_edom_disj: "const_on f S empty \<longleftrightarrow> edom f \<inter> S = {}"
  by (auto simp add: empty_is_bottom edom_def)

context TTreeAnalysisCarrier
begin
  lemma carrier_Fstack: "carrier (Fstack as S) \<subseteq> fv S"
    by (induction S rule: Fstack.induct)
       (auto simp add: empty_is_bottom[symmetric] carrier_Fexp dest!: set_mp[OF Aexp_edom])

  lemma carrier_FBinds: "carrier ((FBinds \<Gamma>\<cdot>ae) x) \<subseteq> fv \<Gamma>"
  apply (simp add: Texp.AnalBinds_lookup)
  apply (auto split: option.split simp add: empty_is_bottom[symmetric] )
  apply (case_tac "ae x")
  apply (auto simp add: empty_is_bottom[symmetric] carrier_Fexp dest!: set_mp[OF Aexp_edom])
  by (metis (poly_guards_query) contra_subsetD domA_from_set map_of_fv_subset map_of_SomeD option.sel)
end

context TTreeAnalysisSafe
begin

  sublocale CardinalityPrognosisShape prognosis
  proof
    fix \<Gamma> :: heap and ae ae' :: AEnv and u e S as
    assume "ae f|` domA \<Gamma> = ae' f|` domA \<Gamma>"
    from Texp.AnalBinds_cong[OF this]
    show "prognosis ae as u (\<Gamma>, e, S) = prognosis ae' as u (\<Gamma>, e, S)" by simp
  next
    fix ae as a \<Gamma> e S
    show "const_on (prognosis ae as a (\<Gamma>, e, S)) (ap S) many"
    proof
      fix x
      assume "x \<in> ap S"
      hence "[x,x] \<in> paths (Fstack as S)"
        by (induction S rule: Fstack.induct)
           (auto 4 4 intro: set_mp[OF both_contains_arg1] set_mp[OF both_contains_arg2] paths_Cons_nxt)
      hence "[x,x] \<in> paths (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)"
        by (rule set_mp[OF both_contains_arg2])
      hence "[x,x] \<in> paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))"
        by (rule set_mp[OF substitute_contains_arg])
      hence "pathCard [x,x] x \<sqsubseteq> pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))) x"
        by (metis fun_belowD paths_Card_above)
      also have "pathCard [x,x] x = many"  by (auto simp add: pathCard_def)
      finally
      show "prognosis ae as a (\<Gamma>, e, S) x = many"
        by (auto intro: below_antisym)
    qed
  next
    fix \<Gamma> \<Delta> :: heap and e :: exp and ae :: AEnv and as u S
    assume "map_of \<Gamma> = map_of \<Delta>"
    hence "FBinds \<Gamma> = FBinds \<Delta>" and "thunks \<Gamma> = thunks \<Delta>" by (auto intro!: cfun_eqI  thunks_cong simp add: Texp.AnalBinds_lookup)
    thus "prognosis ae as u (\<Gamma>, e, S) = prognosis ae as u (\<Delta>, e, S)"  by simp
  next
    fix \<Gamma> :: heap and e :: exp and ae :: AEnv and as u S x
    show "prognosis ae as u (\<Gamma>, e, S) \<sqsubseteq> prognosis ae as u (\<Gamma>, e, Upd x # S)" by simp
  next
  fix \<Gamma> :: heap and e :: exp and ae :: AEnv and as a S x
  assume "ae x = \<bottom>"

  hence "FBinds (delete x \<Gamma>)\<cdot>ae = FBinds \<Gamma>\<cdot>ae" by (rule Texp.AnalBinds_delete_bot)
  moreover
  hence "((FBinds \<Gamma>\<cdot>ae) x) = \<bottom>" by (metis Texp.AnalBinds_delete_lookup)
  ultimately
  show "prognosis ae as a (\<Gamma>, e, S) \<sqsubseteq> prognosis ae as a (delete x \<Gamma>, e, S)"
    by (simp add: substitute_T_delete empty_is_bottom)
  next
    fix ae as a \<Gamma> x S
    have "once \<sqsubseteq> (pathCard [x]) x" by (simp add: two_add_simp)
    also have "pathCard [x] \<sqsubseteq> pathsCard ({[],[x]})"
      by (rule paths_Card_above) simp
    also have "\<dots> = pathsCard (paths (single x))" by simp
    also have "single x \<sqsubseteq> (Texp (Var x)\<cdot>a)" by (rule Texp_Var)
    also have "\<dots> \<sqsubseteq> Texp (Var x)\<cdot>a \<otimes>\<otimes> Fstack as S" by (rule both_above_arg1)
    also have "\<dots> \<sqsubseteq> substitute  (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (Var x)\<cdot>a \<otimes>\<otimes> Fstack as S)" by (rule substitute_above_arg)
    also have "pathsCard (paths \<dots>) x = prognosis ae as a (\<Gamma>, Var x, S) x" by simp
    finally
    show "once \<sqsubseteq> prognosis ae as a (\<Gamma>, Var x, S) x"
      by this (rule cont2cont_fun, intro cont2cont)+
  qed

  sublocale CardinalityPrognosisApp prognosis
  proof
    fix ae as a \<Gamma> e x S
    have "Texp e\<cdot>(inc\<cdot>a)  \<otimes>\<otimes> many_calls x \<otimes>\<otimes> Fstack as S = many_calls x  \<otimes>\<otimes> (Texp e)\<cdot>(inc\<cdot>a) \<otimes>\<otimes> Fstack as S"
      by (metis both_assoc both_comm)
    thus "prognosis ae as (inc\<cdot>a) (\<Gamma>, e, Arg x # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, App e x, S)"
      by simp (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_App)
  qed

  sublocale CardinalityPrognosisLam prognosis
  proof
    fix ae as a \<Gamma> e y x S
    have "Texp e[y::=x]\<cdot>(pred\<cdot>a) \<sqsubseteq> many_calls x  \<otimes>\<otimes> Texp (Lam [y]. e)\<cdot>a"
      by (rule below_trans[OF Texp_subst both_mono2'[OF Texp_Lam]])
    moreover have "Texp (Lam [y]. e)\<cdot>a \<otimes>\<otimes> many_calls x \<otimes>\<otimes> Fstack as S = many_calls x  \<otimes>\<otimes> Texp (Lam [y]. e)\<cdot>a \<otimes>\<otimes> Fstack as S"
      by (metis both_assoc both_comm)
    ultimately
    show "prognosis ae as (pred\<cdot>a) (\<Gamma>, e[y::=x], S) \<sqsubseteq> prognosis ae as a (\<Gamma>, Lam [y]. e, Arg x # S)"
      by simp (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1')
  qed

  sublocale CardinalityPrognosisVar prognosis
  proof
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and as u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"

    assume "isVal e"
    hence "x \<notin> thunks \<Gamma>" using `map_of \<Gamma> x = Some e` by (metis thunksE)
    hence [simp]: "f_nxt (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) x = FBinds \<Gamma>\<cdot>ae" by (auto simp add: f_nxt_def)

    have "prognosis ae as u (\<Gamma>, e, S) = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (nxt (single x) x \<otimes>\<otimes> Texp e\<cdot>u  \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((nxt (single x) x \<otimes>\<otimes> Fstack as S) \<otimes>\<otimes> Texp e\<cdot>u )))"
      by (metis both_assoc both_comm)
    also have "\<dots> \<sqsubseteq> pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (nxt (single x \<otimes>\<otimes> Fstack as S) x \<otimes>\<otimes> Texp e\<cdot>u)))"
      by (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1'  nxt_both_left) simp
    also have "\<dots> = pathsCard (paths (nxt (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S)) x))"
      using `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` by (simp add: Texp.AnalBinds_lookup)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S))))"
      by (rule pathsCard_paths_nxt)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((Texp (Var x)\<cdot>a) \<otimes>\<otimes> Fstack as S))))"
      by (intro monofun_cfun_arg pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_Var)
    also have "\<dots> = record_call x \<cdot>(prognosis ae as a (\<Gamma>, Var x, S))"
      by simp
    finally
    show "prognosis ae as u (\<Gamma>, e, S) \<sqsubseteq> record_call x\<cdot>(prognosis ae as a (\<Gamma>, Var x, S))" by this simp_all
  next
    fix \<Gamma> :: heap and e :: exp and x :: var and ae :: AEnv and as u a S
    assume "map_of \<Gamma> x = Some e"
    assume "ae x = up\<cdot>u"
    assume "\<not> isVal e"
    hence "x \<in> thunks \<Gamma>" using `map_of \<Gamma> x = Some e` by (metis thunksI)
    hence [simp]: "f_nxt (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) x = FBinds (delete x \<Gamma>)\<cdot>ae"
      by (auto simp add: f_nxt_def Texp.AnalBinds_delete_to_fun_upd empty_is_bottom)

    have "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks (delete x \<Gamma>)) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (Texp e\<cdot>u \<otimes>\<otimes> Fstack as S)))"
       by (rule arg_cong[OF substitute_cong_T]) (auto simp add: empty_is_bottom)
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (nxt (single x) x \<otimes>\<otimes> Texp e\<cdot>u  \<otimes>\<otimes> Fstack as S)))"
      by simp
    also have "\<dots> = pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) ((nxt (single x) x \<otimes>\<otimes> Fstack as S) \<otimes>\<otimes> Texp e\<cdot>u )))"
      by (metis both_assoc both_comm)
    also have "\<dots> \<sqsubseteq> pathsCard (paths (substitute (FBinds (delete x \<Gamma>)\<cdot>ae) (thunks \<Gamma>) (nxt (single x \<otimes>\<otimes> Fstack as S) x  \<otimes>\<otimes> Texp e\<cdot>u)))"
      by (intro pathsCard_mono' paths_mono substitute_mono2' both_mono1'  nxt_both_left) simp
    also have "\<dots> = pathsCard (paths (nxt (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S)) x))"
      using `map_of \<Gamma> x = Some e` `ae x = up\<cdot>u` by (simp add: Texp.AnalBinds_lookup)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (single x \<otimes>\<otimes> Fstack as S))))"
      by (rule pathsCard_paths_nxt)
    also have "\<dots> \<sqsubseteq> record_call x \<cdot>(pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) ((Texp (Var x)\<cdot>a) \<otimes>\<otimes> Fstack as S))))"
      by (intro monofun_cfun_arg pathsCard_mono' paths_mono substitute_mono2' both_mono1' Texp_Var)
    also have "\<dots> = record_call x \<cdot>(prognosis ae as a (\<Gamma>, Var x, S))"
      by simp
    finally
    show "prognosis ae as u (delete x \<Gamma>, e, Upd x # S) \<sqsubseteq> record_call x\<cdot>(prognosis ae as a (\<Gamma>, Var x, S))" by this simp_all
  next
    fix \<Gamma> :: heap and e :: exp and ae :: AEnv and  x :: var and as S
    assume "isVal e"
    hence "repeatable (Texp e\<cdot>0)" by (rule Fun_repeatable)

    assume [simp]: "x \<notin> domA \<Gamma>"

    have [simp]: "thunks ((x, e) # \<Gamma>) = thunks \<Gamma>"
      using `isVal e`
      by (auto simp add: thunks_Cons dest: set_mp[OF thunks_domA])

    have "fup\<cdot>(Texp e)\<cdot>(ae x) \<sqsubseteq> Texp e\<cdot>0" by (metis fup2 monofun_cfun_arg up_zero_top)
    hence "substitute ((FBinds \<Gamma>\<cdot>ae)(x := fup\<cdot>(Texp e)\<cdot>(ae x))) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute ((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0)) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S)"
      by (intro substitute_mono1' fun_upd_mono below_refl monofun_cfun_arg)
    also have "\<dots> = substitute (((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0))(x := empty)) (thunks \<Gamma>) (Texp e\<cdot>0 \<otimes>\<otimes> Fstack as S)"
      using `repeatable (Texp e\<cdot>0)` by (rule substitute_remove_anyways, simp)
    also have "((FBinds \<Gamma>\<cdot>ae)(x := Texp e\<cdot>0))(x := empty) = FBinds \<Gamma>\<cdot>ae"
      by (simp add: fun_upd_idem Texp.AnalBinds_not_there empty_is_bottom)
    finally
    show "prognosis ae as 0 ((x, e) # \<Gamma>, e, S) \<sqsubseteq> prognosis ae as 0 (\<Gamma>, e, Upd x # S)"
      by (simp, intro pathsCard_mono' paths_mono)
  qed

  sublocale CardinalityPrognosisIfThenElse prognosis
  proof
    fix ae as \<Gamma> scrut e1 e2 S a
    have "Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<sqsubseteq> Texp (scrut ? e1 : e2)\<cdot>a"
      by (rule Texp_IfThenElse)
    hence "substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp scrut\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (scrut ? e1 : e2)\<cdot>a \<otimes>\<otimes> Fstack as S)"
      by (rule substitute_mono2'[OF both_mono1'])
    thus "prognosis ae (a#as) 0 (\<Gamma>, scrut, Alts e1 e2 # S) \<sqsubseteq> prognosis ae as a (\<Gamma>, scrut ? e1 : e2, S)"
      by (simp, intro pathsCard_mono' paths_mono)
  next
    fix ae as a \<Gamma> b e1 e2 S
    have "Texp (if b then e1 else e2)\<cdot>a \<sqsubseteq> Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a"
      by (auto simp add: either_above_arg1 either_above_arg2)
    hence "substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (if b then e1 else e2)\<cdot>a \<otimes>\<otimes> Fstack as S) \<sqsubseteq> substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (Texp (Bool b)\<cdot>0 \<otimes>\<otimes> (Texp e1\<cdot>a \<oplus>\<oplus> Texp e2\<cdot>a) \<otimes>\<otimes> Fstack as S)"
      by (rule substitute_mono2'[OF both_mono1'[OF below_trans[OF _ both_above_arg2]]])
    thus "prognosis ae as a (\<Gamma>, if b then e1 else e2, S) \<sqsubseteq> prognosis ae (a#as) 0 (\<Gamma>, Bool b, Alts e1 e2 # S)"
      by (auto intro!: pathsCard_mono' paths_mono)
  qed

end

context TTreeAnalysisCardinalityHeap
begin

  definition cHeap where
    "cHeap \<Gamma> e = (\<Lambda> a. pathsCard (paths (Theap \<Gamma> e\<cdot>a)))"

  lemma cHeap_simp: "(cHeap \<Gamma> e)\<cdot>a = pathsCard (paths (Theap \<Gamma> e\<cdot>a))"
    unfolding cHeap_def  by (rule beta_cfun) (intro cont2cont)

  sublocale CardinalityHeap cHeap.

  sublocale CardinalityHeapSafe cHeap Aheap
  proof
    fix x \<Gamma> e a
    assume "x \<in> thunks \<Gamma>"
    moreover
    assume "many \<sqsubseteq> (cHeap \<Gamma> e\<cdot>a) x"
    hence "many \<sqsubseteq> pathsCard (paths (Theap \<Gamma> e \<cdot>a)) x" unfolding cHeap_def by simp
    hence "\<exists>p\<in> (paths (Theap \<Gamma> e\<cdot>a)). \<not> (one_call_in_path x p)" unfolding pathsCard_def
      by (auto split: if_splits)
    ultimately
    show "(Aheap \<Gamma> e\<cdot>a) x = up\<cdot>0"
      by (metis Theap_thunk)
  next
    fix \<Gamma> e a
    show "edom (cHeap \<Gamma> e\<cdot>a) = edom (Aheap \<Gamma> e\<cdot>a)"
    by (simp add: cHeap_def Union_paths_carrier carrier_Fheap)
  qed

  sublocale CardinalityPrognosisEdom prognosis
  proof
    fix ae as a \<Gamma> e S
    show "edom (prognosis ae as a (\<Gamma>, e, S)) \<subseteq> fv \<Gamma> \<union> fv e \<union> fv S"
      apply (simp add: Union_paths_carrier)
      apply (rule carrier_substitute_below)
      apply (auto simp add: carrier_Fexp dest: set_mp[OF Aexp_edom] set_mp[OF carrier_Fstack] set_mp[OF ap_fv_subset] set_mp[OF carrier_FBinds])
      done
  qed

  sublocale CardinalityPrognosisLet prognosis cHeap
  proof
    fix \<Delta> \<Gamma> :: heap and e :: exp and S :: stack and  ae :: AEnv and a :: Arity and as
    assume "atom ` domA \<Delta> \<sharp>* \<Gamma>"
    assume "atom ` domA \<Delta> \<sharp>* S"
    assume "edom ae \<subseteq> domA \<Gamma> \<union> upds S"

    have "domA \<Delta> \<inter> edom ae = {}"
      using fresh_distinct[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`] fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* S`]
            `edom ae \<subseteq> domA \<Gamma> \<union> upds S` ups_fv_subset[of S]
      by auto

    have const_on1:  "\<And> x. const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (carrier ((FBinds \<Gamma>\<cdot>ae) x)) empty"
      unfolding const_on_edom_disj using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`]
      by (auto dest!: set_mp[OF carrier_FBinds] set_mp[OF Texp.edom_AnalBinds])
    have const_on2:  "const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (carrier (Fstack as S)) empty"
      unfolding const_on_edom_disj using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* S`]
      by (auto dest!: set_mp[OF carrier_FBinds] set_mp[OF carrier_Fstack] set_mp[OF Texp.edom_AnalBinds] set_mp[OF ap_fv_subset ])
    have  const_on3: "const_on (FBinds \<Gamma>\<cdot>ae) (- (- domA \<Delta>)) TTree.empty"
      and const_on4: "const_on (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (domA \<Gamma>) TTree.empty"
      unfolding const_on_edom_disj using fresh_distinct[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`]
      by (auto dest!:  set_mp[OF Texp.edom_AnalBinds])

    have disj1: "\<And> x. carrier ((FBinds \<Gamma>\<cdot>ae) x) \<inter> domA \<Delta> = {}"
      using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`]
      by (auto dest: set_mp[OF carrier_FBinds])
    hence disj1': "\<And> x. carrier ((FBinds \<Gamma>\<cdot>ae) x) \<subseteq> - domA \<Delta>" by auto
    have disj2: "\<And> x. carrier (Fstack as S) \<inter> domA \<Delta> = {}"
      using fresh_distinct_fv[OF `atom \` domA \<Delta> \<sharp>* S`] by (auto dest!: set_mp[OF carrier_Fstack])
    hence disj2': "carrier (Fstack as S) \<subseteq> - domA \<Delta>" by auto

    {
    fix x
    have "(FBinds (\<Delta> @ \<Gamma>)\<cdot>(ae \<squnion> Aheap \<Delta> e\<cdot>a)) x = (FBinds \<Gamma>\<cdot>ae) x \<otimes>\<otimes> (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) x"
    proof (cases "x \<in> domA \<Delta>")
      case True
      have "map_of \<Gamma> x = None" using True fresh_distinct[OF `atom \` domA \<Delta> \<sharp>* \<Gamma>`] by (metis disjoint_iff_not_equal domA_def map_of_eq_None_iff)
      moreover
      have "ae x = \<bottom>" using True `domA \<Delta> \<inter> edom ae = {}` by auto
      ultimately
      show ?thesis using True
          by (auto simp add: Texp.AnalBinds_lookup empty_is_bottom[symmetric] cong: option.case_cong)
    next
      case False
      have "map_of \<Delta> x = None" using False by (metis domA_def map_of_eq_None_iff)
      moreover
      have "(Aheap \<Delta> e\<cdot>a) x = \<bottom>" using False using edom_Aheap by (metis contra_subsetD edomIff)
      ultimately
      show ?thesis using False
         by (auto simp add: Texp.AnalBinds_lookup empty_is_bottom[symmetric] cong: option.case_cong)
    qed
    }
    note FBinds = ext[OF this]

    {
    have "pathsCard (paths (substitute (FBinds (\<Delta> @ \<Gamma>)\<cdot>(Aheap \<Delta> e\<cdot>a \<squnion> ae)) (thunks (\<Delta> @ \<Gamma>)) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S)))
      = pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks (\<Delta> @ \<Gamma>)) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))  (thunks (\<Delta> @ \<Gamma>))  (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S))))"
       by (simp add: substitute_substitute[OF const_on1] FBinds)
    also have "substitute (FBinds \<Gamma>\<cdot>ae) (thunks (\<Delta> @ \<Gamma>)) = substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>)"
      apply (rule substitute_cong_T)
      using const_on3
      by (auto dest: set_mp[OF thunks_domA])
    also have "substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks (\<Delta> @ \<Gamma>)) = substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>)"
      apply (rule substitute_cong_T)
      using const_on4
      by (auto dest: set_mp[OF thunks_domA])
    also have "substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a \<otimes>\<otimes> Fstack as S) = substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S"
      by (rule substitute_only_empty_both[OF const_on2])
    also note calculation
    }
    note eq_imp_below[OF this]
    also
    note env_restr_split[where S = "domA \<Delta>"]
    also
    have "pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S))) f|` domA \<Delta>
        = pathsCard (paths (ttree_restr (domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a))))"
          by (simp add: filter_paths_conv_free_restr ttree_restr_both ttree_rest_substitute[OF disj1]  ttree_restr_is_empty[OF disj2])
    also
    have "ttree_restr (domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<sqsubseteq> Theap \<Delta> e\<cdot>a"  by (rule Theap_substitute)
    also
    have "pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a) \<otimes>\<otimes> Fstack as S))) f|` (- domA \<Delta>) =
          pathsCard (paths (substitute (FBinds \<Gamma>\<cdot>ae) (thunks \<Gamma>) (ttree_restr (- domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a)) (thunks \<Delta>) (Texp e\<cdot>a)) \<otimes>\<otimes> Fstack as S)))"
          by (simp add: filter_paths_conv_free_restr2 ttree_rest_substitute2[OF disj1' const_on3] ttree_restr_both  ttree_restr_noop[OF disj2'])
    also have "ttree_restr (- domA \<Delta>) (substitute (FBinds \<Delta>\<cdot>(Aheap \<Delta> e\<cdot>a))  (thunks \<Delta>)  (Texp e\<cdot>a)) \<sqsubseteq> Texp (Terms.Let \<Delta> e)\<cdot>a" by (rule Texp_Let)
    finally
    show "prognosis (Aheap \<Delta> e\<cdot>a \<squnion> ae) as a (\<Delta> @ \<Gamma>, e, S) \<sqsubseteq> cHeap \<Delta> e\<cdot>a \<squnion> prognosis ae as a (\<Gamma>, Terms.Let \<Delta> e, S)"
      by (simp add: cHeap_def del: fun_meet_simp)
  qed

  sublocale CardinalityPrognosisSafe prognosis cHeap Aheap Aexp ..
end

end


(* Title:     Xml
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

header \<open>A Sum Type with Bottom Element\<close>

theory Strict_Sum
imports
  "~~/src/HOL/Library/Monad_Syntax"
  Error_Syntax
  "../Partial_Function_MR/Partial_Function_MR"
begin

datatype (dead 'e, 'a) sum_bot (infixr "+\<^sub>\<bottom>" 10) = Bottom | Left 'e | Right 'a for map: sum_bot_map

subsection \<open>Setup for Partial Functions\<close>

abbreviation sum_bot_ord :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a \<Rightarrow> bool"
where
  "sum_bot_ord \<equiv> flat_ord Bottom"

interpretation sum_bot!:
  partial_function_definitions sum_bot_ord "flat_lub Bottom"
  by (rule flat_interpretation)

declaration \<open>
Partial_Function.init
  "sum_bot"
  @{term sum_bot.fixp_fun}
  @{term sum_bot.mono_body}
  @{thm sum_bot.fixp_rule_uc}
  @{thm sum_bot.fixp_induct_uc}
  NONE
\<close>

subsection \<open>Monad Setup\<close>

fun bind :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'e +\<^sub>\<bottom> 'b"
where
  "bind Bottom f = Bottom" |
  "bind (Left e) f = Left e" |
  "bind (Right x) f = f x"

abbreviation mono_sum_bot :: "(('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'f +\<^sub>\<bottom> 'c) \<Rightarrow> bool"
where
  "mono_sum_bot \<equiv> monotone (fun_ord sum_bot_ord) sum_bot_ord"

(* TODO: perhaps use Partial_Function.bind_mono to proof this result immediately *)
lemma bind_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B" and mg: "\<And>y. mono_sum_bot (\<lambda>f. C y f)"
  shows "mono_sum_bot (\<lambda>f. bind (B f) (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then have "sum_bot_ord (bind (B f) (\<lambda>y. C y f)) (bind (B g) (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg have "\<And>y'. sum_bot_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "sum_bot_ord (bind (B g) (\<lambda>y'. C y' f)) (bind (B g) (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (sum_bot.leq_trans)
  show "sum_bot_ord (bind (B f) (\<lambda>y. C y f)) (bind (B g) (\<lambda>y'. C y' g))" .
qed

adhoc_overloading
  Monad_Syntax.bind bind

hide_const (open) bind

fun catch_error :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('e \<Rightarrow> ('f +\<^sub>\<bottom> 'a)) \<Rightarrow> 'f +\<^sub>\<bottom> 'a"
where
  "catch_error Bottom f = Bottom " |
  "catch_error (Left a) f = f a" |
  "catch_error (Right a) f = Right a"

adhoc_overloading
  Error_Syntax.catch catch_error

lemma catch_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B" and mg: "\<And>y. mono_sum_bot (\<lambda>f. C y f)"
  shows "mono_sum_bot (\<lambda>f. try (B f) catch (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then have "sum_bot_ord (try (B f) catch (\<lambda>y. C y f)) (try (B g) catch (\<lambda>y. C y f))"
    unfolding flat_ord_def by auto
  also from mg
  have "\<And>y'. sum_bot_ord (C y' f) (C y' g)"
    by (rule monotoneD) (rule fg)
  then have "sum_bot_ord (try (B g) catch (\<lambda>y'. C y' f)) (try (B g) catch (\<lambda>y'. C y' g))"
    unfolding flat_ord_def by (cases "B g") auto
  finally (sum_bot.leq_trans)
    show "sum_bot_ord (try (B f) catch (\<lambda>y. C y f)) (try (B g) catch (\<lambda>y'. C y' g))" .
qed

definition error :: "'e \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  [simp]: "error x = Left x"

definition return :: "'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  [simp]: "return x = Right x"

fun map_sum_bot :: "('a \<Rightarrow> ('e +\<^sub>\<bottom> 'b)) \<Rightarrow> 'a list \<Rightarrow> 'e +\<^sub>\<bottom> 'b list"
where
  "map_sum_bot f [] = return []" |
  "map_sum_bot f (x#xs) = do {
    y \<leftarrow> f x;
    ys \<leftarrow> map_sum_bot f xs;
    return (y # ys)
  }"

lemma map_sum_bot_cong [fundef_cong]:
  assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> f x = g x"
  shows "map_sum_bot f xs = map_sum_bot g ys"
  unfolding assms(1) using assms(2) by (induct ys) auto

lemmas sum_bot_const_mono =
  sum_bot.const_mono [of "fun_ord sum_bot_ord"]

lemma map_sum_bot_mono [partial_function_mono]:
  fixes C :: "'a \<Rightarrow> ('b \<Rightarrow> ('e +\<^sub>\<bottom> 'c)) \<Rightarrow> 'e +\<^sub>\<bottom> 'd"
  assumes "\<And>y. y \<in> set B \<Longrightarrow> mono_sum_bot (C y)"
  shows "mono_sum_bot (\<lambda>f. map_sum_bot (\<lambda>y. C y f) B)"
  using assms by (induct B) (auto intro!: partial_function_mono)

abbreviation update_error :: "'e +\<^sub>\<bottom> 'a \<Rightarrow> ('e \<Rightarrow> 'f) \<Rightarrow> 'f +\<^sub>\<bottom> 'a"
where
  "update_error r f \<equiv> try r catch (\<lambda> e. error (f e))"

adhoc_overloading
  Error_Syntax.update_error update_error

fun sumbot :: "'e + 'a \<Rightarrow> 'e +\<^sub>\<bottom> 'a"
where
  "sumbot (Inl x) = Left x" |
  "sumbot (Inr x) = Right x"

code_datatype sumbot

lemma [code]:
  "(try (sumbot a) catch f) = (case a of Inl b \<Rightarrow> f b | Inr a \<Rightarrow> sumbot (Inr a))"
  by (cases a) auto

lemma [code]: "Right x = sumbot (Inr x)" by simp

lemma [code]: "Left x = sumbot (Inl x)" by simp

lemma [code]: "return x = sumbot (Inr x)" by simp

lemma [code]: "error x = sumbot (Inl x)" by simp

lemma [code]:
  "case_sum_bot f g h (sumbot p) = case_sum g h p"
  by (cases p) auto

subsection \<open>Connection to @{theory Partial_Function_MR}\<close>

lemma sum_bot_map_mono [partial_function_mono]:
  assumes mf: "mono_sum_bot B"
  shows "mono_sum_bot (\<lambda>f. sum_bot_map h (B f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"
  assume fg: "fun_ord sum_bot_ord f g"
  with mf have "sum_bot_ord (B f) (B g)" by (rule monotoneD [of _ _ _ f g])
  then show "sum_bot_ord (sum_bot_map h (B f)) (sum_bot_map h (B g))"
    unfolding flat_ord_def by auto
qed

declaration \<open>
Partial_Function_MR.init
  "sum_bot"
  (fn (mt, t_to_ss, mtT, msT, t_to_sTs) =>
      list_comb (Const (@{const_name sum_bot_map}, t_to_sTs ---> mtT --> msT), t_to_ss) $ mt)
  (fn (commonTs, argTs) => Type (@{type_name sum_bot}, commonTs @ argTs))
  (fn mT => Term.dest_Type mT |> #2 |> (fn [err, res] => ([err], [res])))
  @{thms sum_bot.map_comp}
  @{thms sum_bot.map_ident}
\<close>

end


(*  Title:      HOL/Auth/n_deadlock_lemma_inv__5_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_deadlock Protocol Case Study*}*)

theory n_deadlock_lemma_inv__5_on_rules imports n_deadlock_lemma_on_inv__5
begin
section{*All lemmas on causal relation between inv__5*}
lemma lemma_inv__5_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__5  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__5) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__5) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Conntrack_State_Transform
imports Common_Primitive_Matcher
        "../Semantics_Ternary/Semantics_Ternary"
begin

text\<open>The following function assumes that the packet is in a certain state.\<close>

fun ctstate_assume_state :: "ctstate \<Rightarrow> 'i::len  common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "ctstate_assume_state s (Match (CT_State x)) = (if s \<in> x then MatchAny else MatchNot MatchAny)" |
  "ctstate_assume_state s (Match m) = Match m" |
  "ctstate_assume_state s (MatchNot m) = MatchNot (ctstate_assume_state s m)" |
  "ctstate_assume_state _ MatchAny = MatchAny" |
  "ctstate_assume_state s (MatchAnd m1 m2) = MatchAnd (ctstate_assume_state s m1) (ctstate_assume_state s m2)"

lemma ctstate_assume_state: "p_tag_ctstate p = s \<Longrightarrow>
    matches (common_matcher, \<alpha>) (ctstate_assume_state s m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
apply(rule matches_iff_apply_f)
by(induction m rule: ctstate_assume_state.induct) (simp_all)

definition ctstate_assume_new :: "'i::len  common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "ctstate_assume_new \<equiv> optimize_matches (ctstate_assume_state CT_New)"

lemma ctstate_assume_new_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (ctstate_assume_new rs)"
  by (simp add: ctstate_assume_new_def optimize_matches_simple_ruleset)

text\<open>Usually, the interesting part of a firewall is only about the rules for setting up connections.
      That means, we mostly only care about packets in state @{const CT_New}.
      Use the function @{const ctstate_assume_new} to remove all state matching and just care about
      the connection setup.
\<close>
corollary ctstate_assume_new: "p_tag_ctstate p = CT_New \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (ctstate_assume_new rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding ctstate_assume_new_def
apply(rule optimize_matches)
apply(simp add: ctstate_assume_state)
done

text\<open>If we assume the CT State is @{const CT_New}, we can also assume that the TCP SYN flag (@{const ipt_tcp_syn}) is set.\<close>

fun ipt_tcp_flags_assume_flag :: "ipt_tcp_flags \<Rightarrow> 'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr" where
  "ipt_tcp_flags_assume_flag flg (Match (L4_Flags x)) = (if ipt_tcp_flags_equal x flg then MatchAny else (case match_tcp_flags_conjunct_option x flg of None \<Rightarrow> MatchNot MatchAny | Some f3 \<Rightarrow> Match (L4_Flags f3)))" |
  "ipt_tcp_flags_assume_flag flg (Match m) = Match m" |
  "ipt_tcp_flags_assume_flag flg (MatchNot m) = MatchNot (ipt_tcp_flags_assume_flag flg m)" |
  "ipt_tcp_flags_assume_flag _ MatchAny = MatchAny" |
  "ipt_tcp_flags_assume_flag flg (MatchAnd m1 m2) = MatchAnd (ipt_tcp_flags_assume_flag flg m1) (ipt_tcp_flags_assume_flag flg m2)"

lemma ipt_tcp_flags_assume_flag: assumes "match_tcp_flags flg (p_tcp_flags p)"
    shows "matches (common_matcher, \<alpha>) (ipt_tcp_flags_assume_flag flg m) a p \<longleftrightarrow> matches (common_matcher, \<alpha>) m a p"
proof(rule matches_iff_apply_f)
show "ternary_ternary_eval (map_match_tac common_matcher p (ipt_tcp_flags_assume_flag flg m)) = ternary_ternary_eval (map_match_tac common_matcher p m)"
  using assms proof(induction m rule: ipt_tcp_flags_assume_flag.induct)
  case (1 flg x)
    thus ?case
    apply(simp add: ipt_tcp_flags_equal del: match_tcp_flags.simps)
    apply(cases "match_tcp_flags_conjunct_option x flg")
     apply(simp)
     using match_tcp_flags_conjunct_option_None bool_to_ternary_simps(2) apply metis
    apply(simp)
    apply(drule_tac pkt="(p_tcp_flags p)" in match_tcp_flags_conjunct_option_Some)
    by simp
  qed(simp_all del: match_tcp_flags.simps)
qed

definition ipt_tcp_flags_assume_syn :: "'i::len common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "ipt_tcp_flags_assume_syn \<equiv> optimize_matches (ipt_tcp_flags_assume_flag ipt_tcp_syn)"

lemma ipt_tcp_flags_assume_syn_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (ipt_tcp_flags_assume_syn rs)"
  by (simp add: ipt_tcp_flags_assume_syn_def optimize_matches_simple_ruleset)

corollary ipt_tcp_flags_assume_syn: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (ipt_tcp_flags_assume_syn rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding ipt_tcp_flags_assume_syn_def
apply(rule optimize_matches)
apply(simp add: ipt_tcp_flags_assume_flag)
done

definition packet_assume_new :: "'i::len common_primitive rule list \<Rightarrow> 'i common_primitive rule list" where
  "packet_assume_new \<equiv> ctstate_assume_new \<circ> ipt_tcp_flags_assume_syn"

lemma packet_assume_new_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (packet_assume_new rs)"
  by (simp add: packet_assume_new_def ipt_tcp_flags_assume_syn_simple_ruleset ctstate_assume_new_simple_ruleset)

corollary packet_assume_new: "match_tcp_flags ipt_tcp_syn (p_tcp_flags p) \<Longrightarrow> p_tag_ctstate p = CT_New \<Longrightarrow>
  approximating_bigstep_fun (common_matcher, \<alpha>) p (packet_assume_new rs) s = approximating_bigstep_fun (common_matcher, \<alpha>) p rs s"
unfolding packet_assume_new_def
by (simp add: ctstate_assume_new ipt_tcp_flags_assume_syn)

end


theory Affine_Arithmetic_Misc
  imports "HOL-ODE-Numerics.ODE_Numerics"
begin

section \<open>Branch-And-Bound Arithmetic\<close>

primrec prove_nonneg::"(nat * nat * string) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> slp \<Rightarrow> real aform list list \<Rightarrow> bool" where
  "prove_nonneg prnt 0 p slp X = (let _ = if prnt \<noteq> [] then print (STR ''# depth limit exceeded\<newline>'') else () in False)"
| "prove_nonneg prnt (Suc i) p slp XXS =
    (case XXS of [] \<Rightarrow> True | (X#XS) \<Rightarrow>
      let RS = approx_slp_outer p 1 slp X
      in if RS\<noteq>None \<and> Inf_aform' p (hd (the RS)) \<ge> 0
        then
          let _ = if prnt \<noteq> [] then print (STR ''# Success\<newline>'') else ();
             _ = if prnt \<noteq> [] then print (String.implode ((shows ''# '' o shows_box_of_aforms_hr X) ''\<newline>'')) else ();
             _ = fold (\<lambda>(a, b, c) _. print (String.implode (shows_segments_of_aform a b X c ''\<newline>''))) prnt ()
          in prove_nonneg prnt i p slp XS
        else let _ = if prnt \<noteq> [] then print (STR ''# Split\<newline>'') else () in case split_aforms_largest_uncond X of (a, b) \<Rightarrow>
          prove_nonneg prnt i p slp (a#b#XS))"

lemma prove_nonneg_simps[simp]:
  "prove_nonneg prnt 0 p slp X = False"
  "prove_nonneg prnt (Suc i) p slp XXS =
    (case XXS of [] \<Rightarrow> True | (X#XS) \<Rightarrow>
      let RS = approx_slp_outer p 1 slp X
      in if RS\<noteq>None \<and> Inf_aform' p (hd (the RS)) \<ge> 0
        then prove_nonneg prnt i p slp XS
        else case split_aforms_largest_uncond X of (a, b) \<Rightarrow> prove_nonneg prnt i p slp (a#b#XS))"
  by (auto simp: Let_def split: if_splits option.splits list.splits)

lemmas [simp del] = prove_nonneg.simps

lemma split_aforms_lemma:
  fixes xs::"real list"
  assumes "split_aforms XS i = (YS, ZS)"
  assumes "xs \<in> Joints XS"
  shows "xs \<in> Joints YS \<union> Joints ZS"
  using set_rev_mp[OF assms(2) Joints_map_split_aform[of XS i]] assms(1)
  by (auto simp: split_aforms_def o_def)

lemma prove_nonneg_empty[simp]: "prove_nonneg prnt (Suc i) p slp []"
  by simp

lemma prove_nonneg_fuel_mono:
  "prove_nonneg prnt (Suc i) p (slp_of_fas [fa]) YSS"
  if "prove_nonneg prnt i p (slp_of_fas [fa]) YSS"
  using that
proof (induction i arbitrary: YSS)
  case 0
  then show ?case by simp
next
  case (Suc i)
  from Suc.prems show ?case
    supply [simp del] = prove_nonneg_simps
    apply (subst prove_nonneg_simps)
    apply (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal apply (rule Suc.IH)
      apply (subst (asm) prove_nonneg_simps)
      by (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal apply (rule Suc.IH)
      apply (subst (asm) prove_nonneg.simps)
      by (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal apply (rule Suc.IH)
      apply (subst (asm) prove_nonneg.simps)
      by (auto simp: Let_def split: if_splits option.splits list.splits)
    done
qed

lemma prove_nonneg_mono:
  "prove_nonneg prnt i p (slp_of_fas [fa]) YSS" if "prove_nonneg prnt i p (slp_of_fas [fa]) (YS # YSS)"
  using that
proof (induction i arbitrary: YS YSS)
  case 0
  then show ?case by auto
next
  case (Suc i)
  from Suc.prems show ?case
    supply [simp del] = prove_nonneg_simps
    apply (subst (asm) prove_nonneg_simps)
    apply (auto simp: Let_def split: if_splits option.splits list.splits)
    subgoal by (rule prove_nonneg_fuel_mono)
    subgoal for x y apply (rule prove_nonneg_fuel_mono)
      apply (rule Suc.IH[of y])
      by (rule Suc.IH[of x])
    subgoal for x y apply (rule prove_nonneg_fuel_mono)
      apply (rule Suc.IH[of y])
      by (rule Suc.IH[of x])
    done
qed

lemma prove_nonneg:
  assumes "prove_nonneg prnt i p (slp_of_fas [fa]) XSS"
  shows "\<forall>XS \<in> set XSS. \<forall>xs \<in> Joints XS. interpret_floatarith fa xs \<ge> 0"
  using assms
proof (induction i arbitrary: XSS)
  case 0
  then show ?case
    by (auto )
next
  case (Suc i)
  show ?case
  proof (cases XSS)
    case Nil then show ?thesis by auto
  next
    case (Cons YS YSS)
    show ?thesis
      unfolding Cons
      apply auto
      subgoal for xs using Suc.prems
        apply (auto simp: Cons Let_def split: if_splits option.splits)
        subgoal for ys
          apply (drule approx_slp_outer_plain)
             apply (rule refl)
            apply force
           apply assumption
          apply simp
          apply (frule Joints_imp_length_eq[where XS=ys])
          apply (auto simp: Suc_length_conv)
          by (smt Inf_aform'_Affine_le)
        subgoal
          apply (simp add: split_aforms_largest_uncond_def split: prod.splits)
          apply (drule Suc.IH)
          apply (drule split_aforms_lemma, assumption)
          by auto
        subgoal
          apply (simp add: split_aforms_largest_uncond_def split: prod.splits)
          apply (drule Suc.IH)
          apply (drule split_aforms_lemma, assumption)
          by auto
        done
      subgoal for XS xs using Suc.prems
        apply (auto simp: Cons Let_def split: if_splits option.splits)
        subgoal for ys by (rule Suc.IH[rule_format], assumption, assumption, assumption)
        subgoal for ys
          apply (drule prove_nonneg_mono)
          apply (drule prove_nonneg_mono)
          by (rule Suc.IH[rule_format], assumption, assumption, assumption)
        subgoal for ys
          apply (drule prove_nonneg_mono)
          apply (drule prove_nonneg_mono)
          by (rule Suc.IH[rule_format], assumption, assumption, assumption)
        done
      done
  qed
qed

end


section "Execution Invariants (Part 2)"
theory execution_invariants2
  imports repliss_sem execution_invariants consistency commutativity "fuzzyrule.fuzzyrule"
begin

text \<open>This theory includes more proofs for invariants that hold for all executions.\<close>

lemma wf_transaction_status_iff_origin_dom:
  assumes wf: "state_wellFormed S"
  shows "dom (txOrigin S) = dom (txStatus S)"
  by (smt Collect_cong dom_def local.wf wf_transaction_status_iff_origin)

lemma wf_generated_ids_invocation_exists:
  assumes wf: "state_wellFormed S"
and "invocOp S i = None"
shows "generatedIds S uid \<noteq> Some i"
  using assms proof (induct rule: wellFormed_induct)
  case initial
  then show ?case by (simp add: initialState_def)
next
  case (step t a s)
  then show ?case by (auto simp add: initialState_def step.simps wf_localState_to_invocOp split: if_splits)
qed

text "Every query can be explained with the corresponding query specification.

"

lemma wf_queryspec:
  assumes wf: "state_wellFormed S"
    and "calls S c \<triangleq> Call op r"
    and "prevCalls = {c'. (c',c)\<in>happensBefore S}"
    and "ctxt = getContextH (calls S |` prevCalls) (happensBefore S |r prevCalls) (Some prevCalls)"
  shows "querySpec (prog S) op ctxt r"
  using assms proof (induct rule: wellFormed_induct)
  case initial
  then show ?case
    by (simp add: initialState_def)
next
  case (step S1 a S2)
  from ` S1 ~~ a \<leadsto> S2`
  show ?case
  proof (cases rule: step.cases)
    case (local i ls f ls')
    then show ?thesis
      using step by auto
  next
    case (newId i ls f ls' uid uidv ls'')
    then show ?thesis using step by auto
  next
    case (beginAtomic i ls f ls' t vis snapshot)
    then show ?thesis using step by auto
  next
    case (endAtomic i ls f ls' t)
    then show ?thesis using step by auto
  next
    case (dbop i ls f Op ls' t c' res vis)
    have [simp]: "prog S2 = prog S1"
      using prog_inv step.hyps(3) by blast

    show ?thesis
    proof (cases "c = c'")
      case True

      have [simp]: "(c', c) \<notin> happensBefore S1" for c
        using local.dbop(7) step.hyps(1) wellFormed_happensBefore_calls_l by blast
      have [simp]: "(c, c') \<notin> happensBefore S1" for c
        using local.dbop(7) step.hyps(1) wellFormed_happensBefore_calls_r by blast
      have [simp]: "c' \<notin> vis"
        using local.dbop(7) local.dbop(9) step.hyps(1) wellFormed_visibleCallsSubsetCalls2 by blast

      have "ctxt = getContext S1 i"
        by (auto simp add: step dbop True getContextH_def operationContext_ext restrict_map_def
            restrict_relation_def
            intro!: ext
            split: option.splits)

      with `querySpec (prog S1) Op (getContext S1 i) res`
      show ?thesis
        using `calls S2 c \<triangleq> Call op r`
        by (simp add: dbop True)

    next
      case False
      show ?thesis
      proof (simp add: step, fuzzy_rule step.hyps; (simp add: step dbop False; fail)?)
        show "calls S1 c \<triangleq> Call op r"
          using `calls S2 c \<triangleq> Call op r`
          by (simp add: dbop False)

        have [simp]: "c' \<notin> prevCalls"
          using False `calls S1 c' = None` wellFormed_happensBefore_calls_l[OF `state_wellFormed S1`]
          by (auto simp add: step dbop, blast)

        have h1: "(calls S2 |` prevCalls) = (calls S1 |` prevCalls)"
          by (auto simp add: restrict_map_def dbop False )

        have h2: "happensBefore S2 |r prevCalls = happensBefore S1 |r prevCalls"
          by (auto simp add: restrict_relation_def dbop False)

        show "ctxt = getContextH (calls S1 |` prevCalls) (happensBefore S1 |r prevCalls) (Some prevCalls)"
          by (simp add: h1 h2 step.prems(3))
      qed
    qed

  next
    case (invocation i proc initialState impl)
    then show ?thesis using step by auto
  next
    case (return i ls f res)
    then show ?thesis using step by auto
  next
    case (crash i ls)
    then show ?thesis using step by auto
  next
    case (invCheck res i)
    then show ?thesis using step by auto
  qed

qed

end