section \<open>Helper theory for using the main passification global block theorem\<close>

theory PassificationEndToEnd
imports  Semantics Util Passification VCExprHelper
begin

subsection \<open>Picking an initial set of target states\<close>

text \<open>The global block theorem for the entry block in the passification phase states the following:
Given an initial source state s (in the non-passified program) and given a non-empty set of initial target
states U (in the passive program) that are related to s (w.r.t. the initial variable relation), then
it holds for any source execution from s, there is at least target execution from some state in U
that simulates this source execution (there are some more properties on U that we do not mention here,
see \<^const>\<open>passive_lemma_assms_2\<close>).

From the VC phase we know that no target execution can fail if the VC holds. In our proof generation,
we use this result together with the global entry block theorem in the passification phase to get that:
If the VC holds, then there cannot be any failing source execution in the non-passified program).

To obtain this result, we must instantiate U such that every state in U is a feasible initial
target state and satisfies all other properties. This subsection provides the definitions and lemmas
to do so.\<close>

fun initial_set :: "'a absval_ty_fun \<Rightarrow> passive_rel \<Rightarrow> var_context \<Rightarrow> var_context \<Rightarrow> rtype_env \<Rightarrow> 'a nstate \<Rightarrow> ('a nstate) set"
  where "initial_set A R \<Lambda> \<Lambda>' \<Omega> ns =
              {u. state_typ_wf A \<Omega> (local_state u) (snd \<Lambda>') \<and> state_typ_wf A \<Omega> (global_state u) (fst \<Lambda>') \<and>
              (\<forall>x y. R x = Some (Inl y) \<longrightarrow> lookup_var \<Lambda> ns x = lookup_var \<Lambda>' u y) \<and> (\<forall> x y. map_of (fst \<Lambda>) x = Some y \<longrightarrow> (global_state u) x = (global_state ns) x) \<and>
              binder_state u = Map.empty}"

text \<open>We instantiate U with \<^const>\<open>initial_set\<close>\<close>

text \<open>Next we construct a state that is in the selected U to show that U is non-empty under certain assumptions (
that we can prove when validating the passification phase) and that U satisfies the necessary properties.\<close>

fun initial_state_local :: "'a absval_ty_fun \<Rightarrow> rtype_env \<Rightarrow> passive_rel \<Rightarrow> var_context \<Rightarrow> var_context \<Rightarrow> 'a nstate \<Rightarrow> 'a named_state"
  where "initial_state_local A \<Omega> R \<Lambda> \<Lambda>' ns x =
         (case (map_of (snd \<Lambda>') x) of Some tw =>
           (if (\<exists>z. R z = Some (Inl x)) then
              lookup_var \<Lambda> ns (SOME z. R z = Some (Inl x))
            else
              Some (val_of_type A (instantiate \<Omega> (fst tw)))
           )
          | None \<Rightarrow> None)"

fun initial_state_global :: "'a absval_ty_fun \<Rightarrow> rtype_env \<Rightarrow> passive_rel \<Rightarrow> var_context \<Rightarrow> var_context \<Rightarrow> 'a nstate \<Rightarrow> 'a named_state"
  where "initial_state_global A \<Omega> R \<Lambda> \<Lambda>' ns x =
           (case (map_of (fst \<Lambda>') x) of Some tw =>
           (if (\<exists>z. R z = Some (Inl x)) then
              lookup_var \<Lambda> ns (SOME z. R z = Some (Inl x))
            else
              ( Some (val_of_type A (instantiate \<Omega> (fst tw))))
           )
          | None \<Rightarrow> None)"

definition rel_range
  where "rel_range R = {y. \<exists>x. R x = Some (Inl y)}"

definition inj_on_defined
  where "inj_on_defined R = (\<forall> x y z. R x = R y \<and> R x = Some (Inl z) \<longrightarrow> x = y)"

lemma initial_state_lookup:
  assumes InjAssm:"inj_on_defined R" and "R x = Some (Inl y)" and "map_of (snd \<Lambda>') y = Some vd"
  shows "initial_state_local A \<Omega> R \<Lambda> \<Lambda>' ns y = lookup_var \<Lambda> ns x" (is "?u y = lookup_var \<Lambda> ns x")
proof -
  from \<open>R x = Some (Inl y)\<close> \<open>map_of (snd \<Lambda>') y = Some vd\<close> have "?u y = (lookup_var \<Lambda> ns (SOME z. R z = Some (Inl y)))" by auto
  thus "?u y = lookup_var \<Lambda> ns x" using InjAssm
    unfolding inj_on_defined_def
    by (metis (full_types, lifting) assms(2) tfl_some)
qed

lemma initial_state_global_lookup:
  assumes InjAssm: "inj_on_defined R" and "R x = Some (Inl y)" and "map_of (fst \<Lambda>') y = Some vd"
  shows "initial_state_global A \<Omega> R \<Lambda> \<Lambda>' ns y = lookup_var \<Lambda> ns x" (is "?u y = lookup_var \<Lambda> ns x")
proof -
  from \<open>R x = Some (Inl y)\<close> \<open>map_of (fst \<Lambda>') y = Some vd\<close> have "?u y = (lookup_var \<Lambda> ns (SOME z. R z = Some (Inl y)))"
    by auto
  thus "?u y = lookup_var \<Lambda> ns x" using InjAssm
    unfolding inj_on_defined_def
    by (metis (full_types, lifting) assms(2) tfl_some)
qed

text \<open>The following lemma shows the set we pick for U is non-empty under certain assumptions.\<close>
lemma init_state_elem_init_set:
  assumes
          NonEmptyTypes:"\<And> t. closed t \<Longrightarrow> \<exists>v. type_of_val A v = t" and
          Closed:"\<And>y \<tau>. \<not>(\<exists> x. R x = Some (Inl y)) \<Longrightarrow> lookup_var_ty \<Lambda>' y = Some \<tau> \<Longrightarrow> closed (instantiate \<Omega> \<tau>)" and
          RelTy:"\<And>x y. R x = Some (Inl y) \<Longrightarrow> lookup_var_ty \<Lambda> x = lookup_var_ty \<Lambda>' y" and
          RelWt:"rel_well_typed A \<Lambda> \<Omega> R ns" and
          InjAssm:"inj_on_defined R" and
          GlobalsSame: "fst \<Lambda> = fst \<Lambda>'" and
          WellTyp: "(state_typ_wf A \<Omega> (global_state ns) (fst \<Lambda>))" and
       (* since the initial state's global state is the same as for n_s (otherwise the axiom assumption cannot be satisfied)
          the lemma requires that that R maps globals to globals (otherwise it cannot be shown that ns and u respect R)*)
          RelGlobalsSame: "\<forall>x y. R x = Some (Inl y) \<longrightarrow> map_of (fst \<Lambda>') y \<noteq> None \<longrightarrow> x = y" and
       (* no shadowing *)
          ConstsDisj:"set (map fst (fst \<Lambda>)) \<inter> set (map fst (snd \<Lambda>)) = {}" and
          ConstsDisj2:"set (map fst (fst \<Lambda>')) \<inter> set (map fst (snd \<Lambda>')) = {}"
        shows "\<lparr>old_global_state = Map.empty,
               global_state = global_state ns,
               local_state = (initial_state_local A \<Omega> R \<Lambda> \<Lambda>' ns),
               binder_state = Map.empty \<rparr> \<in> initial_set A R \<Lambda> \<Lambda>' \<Omega> ns" (is "?u \<in> ?U")
proof (simp only: initial_set.simps, rule, intro conjI)
  show "state_typ_wf A \<Omega> (local_state ?u) (snd \<Lambda>')"
    unfolding state_typ_wf_def
  proof ((rule allI)+, rule impI)
    fix y \<tau>
    assume localy:"lookup_vdecls_ty (snd \<Lambda>') y = Some \<tau>"
    hence LookupTyY:"lookup_var_ty \<Lambda>' y = Some \<tau>"
      by (simp add: lookup_vdecls_ty_local_3)
    show "map_option (type_of_val A) (local_state ?u y) = Some (instantiate \<Omega> \<tau>)"
    proof (cases "\<exists>x. R x = Some (Inl y)")
      case True
      from this obtain x where "R x = Some (Inl y)" by auto
      hence LookupUY:"local_state ?u y = lookup_var \<Lambda> ns x"
        by (metis InjAssm LookupTyY initial_state_lookup localy lookup_var_decl_local_2 lookup_var_ty_decl_Some lookup_vdecls_ty_def map_option_is_None nstate.select_convs(3) option.discI)
      from RelTy RelWt obtain v where
              "lookup_var \<Lambda> ns x = Some v" and "type_of_val A v = instantiate \<Omega> \<tau>"
        unfolding rel_well_typed_def using LookupTyY \<open>R x = Some (Inl y)\<close>
        by fastforce
      thus ?thesis using LookupUY by auto
    next
      case False
      hence "local_state ?u y = Some (val_of_type A (instantiate \<Omega> \<tau>))"
        using localy lookup_vdecls_ty_map_of
        by fastforce
      thus ?thesis using  False LookupTyY Closed val_of_type_correct NonEmptyTypes
        by blast
    qed
  qed
next
  show "state_typ_wf A \<Omega> (global_state ?u) (fst \<Lambda>')" using WellTyp GlobalsSame by simp
next
  show "\<forall> x y. R x = Some (Inl y) \<longrightarrow> lookup_var \<Lambda> ns x = lookup_var \<Lambda>' ?u y"
  proof (rule+)
    fix x y
    assume "R x = Some (Inl y)"
    hence SameTy:"lookup_var_ty \<Lambda> x = lookup_var_ty \<Lambda>' y" using RelTy by simp
    moreover from \<open>R x = Some (Inl y)\<close> RelWt obtain \<tau> where LookupX:"lookup_var_ty \<Lambda> x = Some \<tau>"
      by (meson rel_well_typed_def)
    hence "lookup_var_ty \<Lambda>' y = Some \<tau>" using RelTy[OF \<open>R x = Some (Inl y)\<close>] by simp
    show "lookup_var \<Lambda> ns x = lookup_var \<Lambda>' ?u y"
    proof (cases "map_of (snd \<Lambda>') y = None")
      case True
      hence global_y:"lookup_vdecls_ty (fst \<Lambda>') y = Some \<tau>" using \<open>lookup_var_ty \<Lambda>' y = Some \<tau>\<close>
        using lookup_vdecls_ty_global_5 by simp
      from True have "lookup_var \<Lambda>' ?u y = global_state ?u y"
        by (simp add: lookup_var_def)
      hence lookup_global_u:"lookup_var \<Lambda>' ?u y = global_state ns y" by simp
      moreover from global_y have "map_of (snd \<Lambda>) y = None" using ConstsDisj
        by (metis GlobalsSame disjoint_iff list.set_map lookup_vdecls_ty_map_of map_of_eq_None_iff option.discI)
      ultimately have "lookup_var \<Lambda> ns y = (global_state ns) y" by (simp add: lookup_var_def)
      with lookup_global_u have "lookup_var \<Lambda> ns y = lookup_var \<Lambda>' ?u y" by simp
      moreover from \<open>lookup_vdecls_ty (fst \<Lambda>') y = Some \<tau>\<close> \<open>R x = Some (Inl y)\<close> RelGlobalsSame have "x = y"
        using lookup_vdecls_ty_map_of by fastforce
      ultimately show ?thesis by simp
    next
      case False
      hence "lookup_var \<Lambda>' ?u y = local_state ?u y"
        by (metis lookup_var_local option.exhaust_sel prod.collapse)
      hence "\<dots> = (lookup_var \<Lambda> ns (SOME z. R z = Some (Inl y)))" using \<open>R x = Some (Inl y)\<close> False by auto
      then show ?thesis using InjAssm \<open>R x = Some (Inl y)\<close> initial_state_lookup
        by (metis False \<open>lookup_var \<Lambda>' ?u y = local_state ?u y\<close> nstate.select_convs(3) option.collapse)
    qed
  qed
next
  show "\<forall>x y. map_of (fst \<Lambda>) x = Some y \<longrightarrow> (global_state ?u) x = (global_state ns) x" by simp
next
  show "binder_state ?u = Map.empty"
    by simp
qed

lemma init_set_non_empty:
  assumes NonEmptyTypes:"\<And> t. closed t \<Longrightarrow> \<exists>v. type_of_val A v = t" and
          Closed:"\<And>y \<tau>. \<not>(\<exists> x. R x = Some (Inl y)) \<Longrightarrow> lookup_var_ty \<Lambda>' y = Some \<tau> \<Longrightarrow> closed (instantiate \<Omega> \<tau>)" and
          RelTy:"\<And>x y. R x = Some (Inl y) \<Longrightarrow> lookup_var_ty \<Lambda> x = lookup_var_ty \<Lambda>' y" and
          RelWt:"rel_well_typed A \<Lambda> \<Omega> R ns" and
          InjAssm:"inj_on_defined R" and
          GlobalsSame: "fst \<Lambda> = fst \<Lambda>'" and
          WellTyp: "(state_typ_wf A \<Omega> (global_state ns) (fst \<Lambda>))" and
          RelGlobalsSame: "\<forall>x y. R x = Some (Inl y) \<longrightarrow> map_of (fst \<Lambda>') y \<noteq> None \<longrightarrow> x = y" and
          ConstsDisj:"set (map fst (fst \<Lambda>)) \<inter> set (map fst (snd \<Lambda>)) = {}" and
          ConstsDisj2:"set (map fst (fst \<Lambda>')) \<inter> set (map fst (snd \<Lambda>')) = {}"
  shows "initial_set A R \<Lambda> \<Lambda>' \<Omega> ns \<noteq> {}"
  using assms init_state_elem_init_set by blast

text \<open>Next, we show that U has the remaining desired properties.\<close>

lemma init_state_dependent:"dependent A \<Lambda>' \<Omega> (initial_set A R \<Lambda> \<Lambda>' \<Omega> ns) ((rel_range R) \<union> set (map fst (fst \<Lambda>)))"
         (is "dependent A \<Lambda>' \<Omega> ?U ((rel_range R) \<union> set (map fst (fst \<Lambda>))) ")
  unfolding dependent_def closed_set_ty_def
  proof (rule ballI, rule allI, rule allI, rule impI, rule conjI[OF _ impI[OF allI[OF impI]]])
    fix u \<tau> d
    assume "u \<in> ?U"
    hence S1:"state_typ_wf A \<Omega> (local_state u) (snd \<Lambda>')" and S2:"state_typ_wf A \<Omega> (global_state u) (fst \<Lambda>')" by auto
    assume LookupTy:"lookup_var_ty \<Lambda>' d = Some \<tau>"
    thus "lookup_var_ty_match A \<Lambda>' \<Omega> u d \<tau>"
      using state_typ_wf_lookup[OF S1 S2 LookupTy]
      by (simp add: lookup_var_ty_match_def)
  next
    fix u \<tau> d v
    assume "u \<in> ?U"
    hence S1:"state_typ_wf A \<Omega> (local_state u) (snd \<Lambda>')" and
          S2:"state_typ_wf A \<Omega> (global_state u) (fst \<Lambda>')" and
          Rel1: "(\<forall>x y. R x = Some (Inl y) \<longrightarrow> lookup_var \<Lambda> ns x = lookup_var \<Lambda>' u y)" and
          Binder1: "binder_state u = Map.empty" by auto
    assume LookupTy:"lookup_var_ty \<Lambda>' d = Some \<tau>"
    assume dNotElem:"d \<notin> rel_range R \<union> set (map fst (fst \<Lambda>))"
    assume TypV:"type_of_val A v = instantiate \<Omega> \<tau>"
    have S1Upd:"state_typ_wf A \<Omega> (local_state (update_var \<Lambda>' u d v)) (snd \<Lambda>')"
      unfolding state_typ_wf_def
    proof (rule allI, rule allI, rule impI)
      fix x \<tau>'
      assume MapOfX:"lookup_vdecls_ty (snd \<Lambda>') x = Some \<tau>'"
      show "map_option (type_of_val A) (local_state (update_var \<Lambda>' u d v) x) = Some (instantiate \<Omega> \<tau>')"
      proof (cases "d = x")
        case True
        then show ?thesis
        by (metis (mono_tags, lifting) LookupTy MapOfX TypV lookup_var_local lookup_vdecls_ty_local_3 lookup_vdecls_ty_map_of option.simps(9) prod.collapse update_var_same)
      next
        case False
        from S1 MapOfX have "map_option (type_of_val A) (local_state u x) = Some (instantiate \<Omega> \<tau>')"
          using state_typ_wf_def by blast
        with False show ?thesis using local_state_update_other
          by metis
      qed
    qed
    have S2Upd:"state_typ_wf A \<Omega> (global_state (update_var \<Lambda>' u d v)) (fst \<Lambda>')"
      unfolding state_typ_wf_def
    proof (rule allI, rule allI, rule impI)
      fix x \<tau>'
      assume MapOfX:"lookup_vdecls_ty (fst \<Lambda>') x = Some \<tau>'"
      from S2 MapOfX have GlobalUX:"map_option (type_of_val A) (global_state u x) = Some (instantiate \<Omega> \<tau>')" using state_typ_wf_def by blast
      show  "map_option (type_of_val A) (global_state (update_var \<Lambda>' u d v) x) = Some (instantiate \<Omega> \<tau>')"
      proof (cases "map_of (snd \<Lambda>') d = None")
        case True
        hence Aux1:"global_state (update_var \<Lambda>' u d v) = (global_state u)(d \<mapsto> v)"  by (simp add: global_update)
        show ?thesis
          proof (cases "d = x")
            case True
            moreover with MapOfX LookupTy \<open>map_of (snd \<Lambda>') d = None\<close> have "\<tau> = \<tau>'"
              using lookup_vdecls_ty_global_4 lookup_vdecls_ty_map_of lookup_var_decl_global
              by auto
            ultimately show ?thesis
              apply (subst Aux1)
              using TypV MapOfX
              by simp
          next
            case False
            thus ?thesis using global_state_update_other GlobalUX
              by metis
          qed
      next
        case False
        hence Aux2: "global_state (update_var \<Lambda>' u d v) = global_state u" using global_state_update_local by blast
        thus ?thesis using GlobalUX by simp
        qed
    qed
    have Rel1Upd: "\<forall>x y. R x = Some (Inl y) \<longrightarrow> lookup_var \<Lambda> ns x = lookup_var \<Lambda>' (update_var \<Lambda>' u d v) y"
    proof (rule allI, rule allI, rule impI)
      fix x y
      assume "R x = Some (Inl y)"
      show "lookup_var \<Lambda> ns x = lookup_var \<Lambda>' (update_var \<Lambda>' u d v) y"
        apply (cases "d = y")
        using \<open>R x = Some (Inl y)\<close> dNotElem
         apply (simp add: rel_range_def)
        using Rel1 \<open>R x = Some (Inl y)\<close>
        apply simp
        done
    qed
    have GlobalConstraint: "\<forall>x y. map_of (fst \<Lambda>) x = Some y \<longrightarrow> global_state (update_var \<Lambda>' u d v) x = global_state ns x"
    proof (rule+)
      fix x y
      assume "map_of (fst \<Lambda>) x = Some y"
      hence "d \<noteq> x" using dNotElem
        by (metis UnCI domI dom_map_of_2)
      thus "global_state (update_var \<Lambda>' u d v) x = global_state ns x" using \<open>u \<in> ?U\<close>
        by (simp add: \<open>map_of (fst \<Lambda>) x = Some y\<close> global_state_update_other)
    qed
    show "update_var \<Lambda>' u d v \<in> ?U"
      apply (simp only: initial_set.simps)
      apply (rule Set.CollectI)
      apply (intro conjI)
         apply (rule S1Upd)
      apply (rule S2Upd)
        apply (rule Rel1Upd)
      apply (rule GlobalConstraint)
      using update_var_binder_same Binder1
      by metis
  qed

lemma state_typ_wf_some:
  assumes "map_of vs x \<noteq> None" and
          "state_typ_wf A \<Omega> ns vs"
        shows "ns x \<noteq> None"
  using assms map_of_lookup_vdecls_ty
  unfolding state_typ_wf_def
  by blast

lemma nstate_old_rel_helper:
  assumes "state_typ_wf A [] (global_state ns) (fst \<Lambda>1)" and
          "global_state ns = old_global_state ns" and
          "set (map fst (fst \<Lambda>1)) \<inter> set (map fst (snd \<Lambda>1)) = {}"
          "u \<in> initial_set  A R \<Lambda>1 \<Lambda>2 [] ns" and
          "\<And>x y. R_old x = Some y \<longrightarrow> map_of (fst \<Lambda>1) x \<noteq> None" and
          "\<And>x y. R_old x = Some y \<longrightarrow> R x = Some y"
        shows "nstate_old_rel \<Lambda>1 \<Lambda>2 R_old ns u"
  unfolding nstate_old_rel_def
proof (rule allI, rule allI, rule impI)
  fix x y
  assume "R_old x = Some (Inl y)"
  hence GlobalX:"map_of (fst \<Lambda>1) x \<noteq> None"
    using assms(5) by simp
  hence NotLocalX:"map_of (snd \<Lambda>1) x = None"
    using assms(3)
    by (metis disjoint_iff_not_equal list.set_map map_of_eq_None_iff)

  from \<open>R_old x = Some (Inl y)\<close> have "R x = Some (Inl y)" using assms(6) by simp
  hence LookupSame:"lookup_var \<Lambda>1 ns x = lookup_var \<Lambda>2 u y" using assms(4)
    by simp

  from \<open>map_of (fst \<Lambda>1) x \<noteq> None\<close>
  obtain v where "global_state ns x = Some v"
    using assms(1) GlobalX state_typ_wf_some
    by fastforce
  moreover from this have "lookup_var \<Lambda>1 ns x = Some v"
    using GlobalX NotLocalX
    by (metis lookup_var_global prod.collapse)
  ultimately have Rel:"(\<exists>v. old_global_state ns x = Some v \<and> lookup_var \<Lambda>2 u y = Some v)"
    using assms(2)
    by (simp add: LookupSame)

  show "(map_of (fst \<Lambda>1) x \<noteq> None \<and> map_of (snd \<Lambda>1) x = None) \<and> (\<exists>v. old_global_state ns x = Some v \<and> lookup_var \<Lambda>2 u y = Some v)"
    using GlobalX NotLocalX Rel
    by simp
qed

lemma nstate_old_rel_states_helper:
  assumes "state_typ_wf A [] (global_state ns) (fst \<Lambda>1)" and
          "global_state ns = old_global_state ns" and
          "set (map fst (fst \<Lambda>1)) \<inter> set (map fst (snd \<Lambda>1)) = {}"
          "\<And>x y. R_old x = Some y \<longrightarrow> map_of (fst \<Lambda>1) x \<noteq> None" and
          "\<And>x y. R_old x = Some y \<longrightarrow> R x = Some y"
        shows "nstate_old_rel_states \<Lambda>1 \<Lambda>2 R_old ns (initial_set  A R \<Lambda>1 \<Lambda>2 [] ns)"
  unfolding nstate_old_rel_states_def
  using assms nstate_old_rel_helper
  by blast

subsection \<open>Some more helper definitions and lemmas for the final part of the passification validation\<close>

lemma const_rel:
  assumes Rel:"nstate_rel ((consts@globals),locals) (consts@globals2, locals2) R ns u" and
          R_consts:"list_all (\<lambda>vd. R (fst vd) = Some (Inl (fst vd))) consts" and
          ConstsDisj:"set (map fst consts) \<inter> set (map fst locals) = {}" and
          ConstsDisj2:"set (map fst consts) \<inter> set (map fst locals2) = {}"
  shows "state_restriction (global_state ns) consts = state_restriction (global_state u) consts"
proof (rule HOL.ext)
  fix x
  show "state_restriction (global_state ns) consts x = state_restriction (global_state u) consts x"
  proof (cases "map_of consts x \<noteq> None")
    case True
    from this obtain \<tau> where "map_of consts x = Some \<tau>" by auto
    moreover have "map_of locals x = None" and "map_of locals2 x = None" using ConstsDisj ConstsDisj2
      by (metis True disjoint_iff_not_equal domIff dom_map_of_2)+
    ultimately have LookupNs:"lookup_var ((consts@globals),locals) ns x = global_state ns x" and
                    LookupU:"lookup_var ((consts@globals2),locals2) u x = global_state u x"
      by (auto simp add: lookup_var_global)
    from \<open>map_of consts x = Some \<tau>\<close> have "(x,\<tau>) \<in> set (consts)"
      by (simp add: map_of_SomeD)
    with R_consts have "R x = Some (Inl x)"
      by (metis (mono_tags, lifting) fst_conv in_set_conv_decomp_last list.pred_inject(2) list_all_append)
    with Rel have "lookup_var ((consts@globals),locals) ns x = lookup_var ((consts@globals2),locals2) u x"
      by (simp add: nstate_rel_def)
    with LookupNs LookupU show ?thesis using \<open>map_of consts x \<noteq> None\<close>
      by (simp add: state_restriction_def)
  next
    case False
    then show ?thesis
      by (simp add: state_restriction_def)
  qed
qed

lemma rel_well_typed_state_typ_wf:
  assumes S1:"state_typ_wf A \<Omega> (local_state ns) (snd \<Lambda>)" and
          S2:"state_typ_wf A \<Omega> (global_state ns) (fst \<Lambda>)" and
          RelWtVar:"\<And>x y. R x = Some (Inl y) \<Longrightarrow> \<exists>\<tau>. lookup_var_ty \<Lambda> x = Some \<tau>" and
          RelWtConst:"\<And>x y. R x = Some (Inr y) \<Longrightarrow> lookup_var \<Lambda> ns x = Some (LitV y) \<and> (\<exists>\<tau>. lookup_var_ty \<Lambda> x = Some \<tau>)"
        shows "rel_well_typed A \<Lambda> \<Omega> R ns"
  unfolding rel_well_typed_def rel_const_correct_def
  apply (rule conjI, rule allI, rule allI, rule impI)
  using state_typ_wf_lookup[OF S1 S2] RelWtVar
   apply blast
  using RelWtConst
  using \<open>\<And>x \<tau>. lookup_var_ty \<Lambda> x = Some \<tau> \<Longrightarrow> \<exists>v. lookup_var \<Lambda> ns x = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>\<close> by force

lemma convert_fun_to_list:
assumes A0:"R_fun = map_of R_list" and
        A1:"list_all (\<lambda>t. P (fst t) (snd t)) R_list"
      shows  "R_fun x = Some y \<longrightarrow> P x y"
proof (rule+)
  assume "R_fun x = Some y"
  hence "(x,y) \<in> set (R_list)"
    using A0
    by (simp add: map_of_SomeD)
  moreover from A1 have "\<forall>t \<in> set (R_list). (\<lambda>t. P (fst t) (snd t)) t"
    by (simp only: List.list_all_iff)
  ultimately show "P x y" by auto
qed

fun custom_cmp :: "(nat + lit) \<Rightarrow> (nat + lit) \<Rightarrow> bool"
  where
    "custom_cmp (Inl n) (Inl m) = (n < m)"
  | "custom_cmp _ _ = False"

lemma custom_cmp_diff: "custom_cmp a b \<Longrightarrow> a \<noteq> b"
  by (cases a, cases b) auto

fun strictly_ordered :: "(nat + lit) list \<Rightarrow> bool"
  where
    "strictly_ordered [] = True"
  | "strictly_ordered [x] = True"
  | "strictly_ordered (x#y#zs) = (custom_cmp x y \<and> strictly_ordered (y#zs))"

lemma strictly_ordered_smaller: "strictly_ordered ((Inl a)#xs) \<Longrightarrow> (\<forall> y \<in> (set xs). \<exists>a'. y= Inl a' \<and> a < a')"
proof (induction arbitrary:a rule: strictly_ordered.induct)
  case 1
  then show ?case by simp
next
  case (2 x)
  then show ?case apply simp
    using custom_cmp.elims(2) by blast
next
  case (3 x y zs)
  show ?case
  proof (rule ballI)
    fix r
    assume RElem:"r \<in> set (x # y # zs)"
    show "\<exists>a'. r = Inl a' \<and> a < a'"
    proof (cases "r = x")
    case True
      then show ?thesis using 3
        by (metis custom_cmp.elims(2) custom_cmp.simps(1) strictly_ordered.simps(3))
    next
      case False
      hence "r \<in> set (y # zs)" using RElem by simp
      then show ?thesis using 3
        by (metis custom_cmp.elims(2) custom_cmp.simps(1) dual_order.strict_trans strictly_ordered.simps(3))
    qed
  qed
qed

lemma strictly_ordered_distinct: "strictly_ordered xs \<Longrightarrow> distinct xs"
proof (induction rule: strictly_ordered.induct)
case 1
then show ?case by simp
next
  case (2 x)
  then show ?case by simp
next
  case (3 x y zs)
  then show ?case apply simp
    by (metis (full_types) custom_cmp.elims(2) custom_cmp.simps(1) strictly_ordered_smaller sup.strict_boundedE sup.strict_order_iff)
qed

lemma distinct_helper:
  assumes A1:"(x, fx) \<in> set xs" and
          A2:"(y, fy) \<in> set xs" and
          "x \<noteq> y"
          "distinct (map snd xs)"
        shows "fx \<noteq> fy"
proof -
  thm distinct_conv_nth
  from A1 obtain i where "i < length xs" and  "xs ! i = (x, fx)"
    by (meson in_set_conv_nth)
  moreover from A2 obtain j where "j < length xs" and "xs ! j = (y, fy)"
    by (meson in_set_conv_nth)
  ultimately show ?thesis using \<open>x \<noteq> y\<close> \<open>distinct (map snd xs)\<close> distinct_conv_nth
    by (metis eq_snd_iff length_map nth_map prod.inject)
qed

lemma injective_fun_to_list:
  assumes R_fun_def: "R_fun = map_of R_list" and
          Distinct:"distinct (map snd R_list)"
  shows "inj_on_defined R_fun"
  unfolding inj_on_defined_def distinct_helper
proof ((rule allI)+, rule impI, erule conjE)
  fix x y z
  let ?map_of_x = "map_of R_list x"
  let ?map_of_y = "map_of R_list y"
  assume "R_fun x = R_fun y" and "R_fun x = Some (Inl z)"
  hence "(x, Inl z) \<in> set R_list"
    using R_fun_def \<open>R_fun x = Some (Inl z)\<close> map_of_SomeD by force
  moreover have "(y, Inl z) \<in> set R_list"
    using R_fun_def \<open>R_fun x = Some (Inl z)\<close> \<open>R_fun x = R_fun y\<close> map_of_SomeD by fastforce
  ultimately show "x = y"
  using distinct_helper Distinct by fastforce
qed

lemma injective_fun_to_list_2:
  assumes "R_fun = map_of R_list" and
          "strictly_ordered (map snd R_list)"
  shows "inj_on_defined R_fun"
  using assms injective_fun_to_list strictly_ordered_distinct by blast

fun max_rel :: "(nat + lit) list \<Rightarrow> nat"
  where
    "max_rel [] = 0"
  | "max_rel ((Inl n) # xs) = (max n (max_rel xs))"
  | "max_rel ((Inr l) # xs) = (max_rel xs)"

lemma max_rel_aux:
  assumes "max_rel xs = w_max" and "(Inl n) \<in> set xs"
  shows "n \<le> w_max"
  using assms
  apply (induction arbitrary: n w_max rule: max_rel.induct)
    apply simp
   apply fastforce
  apply simp
  done

fun max_rel_tail :: "nat \<Rightarrow> (nat + lit) list \<Rightarrow> nat"
  where
    "max_rel_tail k [] = k"
  | "max_rel_tail k ((Inl n) # xs) = (max_rel_tail (max n k) xs)"
  | "max_rel_tail k ((Inr l) # xs) = (max_rel_tail k xs)"

lemma max_rel_tail_equiv_aux: "max_rel_tail k xs = max k (max_rel xs)"
  by (induction arbitrary: k rule: max_rel.induct) auto

lemma max_tail_equiv: "max_rel_tail 0 xs = max_rel xs"
  by (simp add: max_rel_tail_equiv_aux)

lemma rel_range_fun_to_list:
  assumes R_fun_def:"R_fun = map_of R_list" and
          "max_rel_tail 0 (map snd R_list) = w_max"
  shows "\<forall>x. x \<in> rel_range R_fun \<longrightarrow> x \<le> w_max"
  unfolding rel_range_def
proof (rule, rule)
  fix x
  assume "x \<in> {y. \<exists>x. R_fun x = Some (Inl y)}"
  from this obtain z where "R_fun z = Some (Inl x)" by auto
  hence "map_of R_list z = Some (Inl x)" using R_fun_def by simp
  hence "(z,Inl x) \<in> set (R_list)"
    by (simp add: map_of_SomeD)
  thus "x \<le> w_max" using max_tail_equiv max_rel_aux
    by (metis assms(2) set_zip_rightD zip_map_fst_snd)
qed

lemma axiom_assm_aux:
  assumes "axiom_assm A \<Gamma> consts ns1 axioms" and
          "\<And> x y. map_of consts x = Some y \<Longrightarrow> (global_state ns1) x = (global_state ns2) x"
        shows "axiom_assm A \<Gamma> consts ns2 axioms"
  using assms
  unfolding nstate_global_restriction_def state_restriction_def
proof -
  have Aux:" (\<lambda>x. if map_of consts x \<noteq> None then global_state ns2 x else None) =  (\<lambda>x. if map_of consts x \<noteq> None then global_state ns1 x else None)"
    using assms(2) by fastforce
  show "axioms_sat A (consts, []) \<Gamma> (global_to_nstate (\<lambda>x. if map_of consts x \<noteq> None then global_state ns2 x else None)) axioms"
    apply (subst Aux)
    using assms(1)
    unfolding nstate_global_restriction_def state_restriction_def
    apply assumption
    done
qed

lemma helper_init_disj:
  assumes Max1:"\<forall>x. x \<in> xs \<longrightarrow> x \<le> n" and "\<forall>y. y \<in> ys \<longrightarrow> y \<le> m" and "n < w_max" and "m < w_max"
  shows "{w. (w :: nat) \<ge> w_max} \<inter> (xs \<union> ys) = {}"
  using assms
  by auto

fun is_prefix :: "'b list \<Rightarrow> 'b list \<Rightarrow> bool"
  where
    "is_prefix [] ys = True"
  | "is_prefix (x#xs) (y#ys) = ((x = y) \<and> is_prefix xs ys)"
  | "is_prefix  _ _ = False"

lemma is_prefix_empty: "is_prefix ys [] \<Longrightarrow> ys = []"
  by (cases ys) auto

lemma is_prefix_append: "is_prefix xs ys \<Longrightarrow> \<exists>zs. ys = xs@zs"
  by (induction rule: is_prefix.induct) (auto simp: is_prefix_empty)

lemma prefix_map_of:
  assumes "\<exists>zs. ys = xs@zs" and
          "R1 = map_of ys" and
          "R2 = map_of xs"
  shows "\<forall>x y. R2 x = Some y \<longrightarrow> R1 x = Some y"
  using assms
  by auto

end


section\<open>Temporal Properties\<close>
text\<open>This theory presents some examples of temporal properties over the simple drinks machine.\<close>

theory Drinks_Machine_LTL
imports "Drinks_Machine" "EFSM.EFSM_LTL"
begin

declare One_nat_def [simp del]

lemma P_ltl_step_0:
  assumes invalid: "P (None, [], <>)"
  assumes select: "l = STR ''select'' \<longrightarrow> P (Some 1, [], <1 $:= Some (hd i), 2 $:= Some (Num 0)>)"
  shows "P (ltl_step drinks (Some 0) <> (l, i))"
proof-
  have length_i: "\<exists>d. (l, i) = (STR ''select'', [d]) \<Longrightarrow> length i = 1"
    by (induct i, auto)
  have length_i_2: "\<forall>d. i \<noteq> [d] \<Longrightarrow> length i \<noteq> 1"
    by (induct i, auto)
  show ?thesis
    apply (case_tac "\<exists>d. (l, i) = (STR ''select'', [d])")
     apply (simp add: possible_steps_0 length_i select_def apply_updates_def)
    using select apply auto[1]
    by (simp add: possible_steps_0_invalid length_i_2 invalid)
qed

lemma P_ltl_step_1:
  assumes invalid: "P (None, [], r)"
  assumes coin: "l = STR ''coin'' \<longrightarrow> P (Some 1, [value_plus (r $ 2) (Some (hd i))], r(2 $:= value_plus (r $ 2) (Some (i ! 0))))"
  assumes vend_fail: "value_gt (Some (Num 100)) (r $ 2) = trilean.true \<longrightarrow> P (Some 1, [],r)"
  assumes vend: "\<not>? value_gt (Some (Num 100)) (r $ 2) = trilean.true \<longrightarrow> P (Some 2, [r$1], r)"
  shows "P (ltl_step drinks (Some 1) r (l, i))"
proof-
  have length_i: "\<And>s. \<exists>d. (l, i) = (s, [d]) \<Longrightarrow> length i = 1"
    by (induct i, auto)
  have length_i_2: "\<forall>d. i \<noteq> [d] \<Longrightarrow> length i \<noteq> 1"
    by (induct i, auto)
  show ?thesis
    apply (case_tac "\<exists>d. (l, i) = (STR ''coin'', [d])")
     apply (simp add: possible_steps_1_coin length_i coin_def apply_outputs_def apply_updates_def)
    using coin apply auto[1]
    apply (case_tac "(l, i) = (STR ''vend'', [])")
     apply (case_tac "\<exists>n. r $ 2 = Some (Num n)")
      apply clarsimp
      apply (case_tac "n \<ge> 100")
       apply (simp add: drinks_vend_sufficient vend_def apply_updates_def apply_outputs_def)
       apply (metis finfun_upd_triv possible_steps_2_vend vend vend_ge_100)
      apply (simp add: drinks_vend_insufficient vend_fail_def apply_updates_def apply_outputs_def)
      apply (metis MaybeBoolInt.simps(1) finfun_upd_triv not_less value_gt_def vend_fail)
     apply (simp add: drinks_vend_invalid invalid)
    by (simp add: drinks_no_possible_steps_1 length_i_2 invalid)
qed

lemma LTL_r2_not_always_gt_100: "not (alw (check_exp (Gt (V (Rg 2)) (L (Num 100))))) (watch drinks i)"
  using value_gt_def by auto

lemma drinks_step_2_none: "ltl_step drinks (Some 2) r e = (None, [], r)"
  by (simp add: drinks_end ltl_step_none_2)

lemma one_before_two_2:
  "alw (\<lambda>x. statename (shd (stl x)) = Some 2 \<longrightarrow> statename (shd x) = Some 1) (make_full_observation drinks (Some 2) r [r $ 1] x2a)"
proof(coinduction)
  case alw
  then show ?case
    apply (simp add: drinks_step_2_none)
    by (metis (mono_tags, lifting) alw_mono nxt.simps once_none_nxt_always_none option.distinct(1))
qed

lemma one_before_two_aux:
  assumes "\<exists> p r i. j = nxt (make_full_observation drinks (Some 1) r p) i"
  shows "alw (\<lambda>x. nxt (state_eq (Some 2)) x \<longrightarrow> state_eq (Some 1) x) j"
  using assms apply(coinduct)
  apply simp
  apply clarify
  apply standard
   apply simp
  apply simp
  apply (case_tac "shd (stl i)")
  apply (simp del: ltl_step.simps)
  apply (rule P_ltl_step_1)
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (state_eq None)"])
      apply (simp add: once_none_nxt_always_none)
     apply simp
    apply auto[1]
   apply auto[1]
  apply simp
  by (simp add: one_before_two_2)

lemma LTL_nxt_2_means_vend:
  "alw (nxt (state_eq (Some 2)) impl (state_eq (Some 1))) (watch drinks i)"
proof(coinduction)
  case alw
  then show ?case
    apply (case_tac "shd i")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_0)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (state_eq None)"])
      apply (simp add: once_none_nxt_always_none)
    using one_before_two_aux by auto
qed

lemma costsMoney_aux:
  assumes "\<exists>p r i. j = (nxt (make_full_observation drinks (Some 1) r p) i)"
  shows "alw (\<lambda>xs. nxt (state_eq (Some 2)) xs \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
  using assms apply coinduct
  apply clarsimp
  apply (case_tac "shd (stl i)")
  apply (simp del: ltl_step.simps)
  apply (rule P_ltl_step_1)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (state_eq None)"])
      apply (simp add: once_none_nxt_always_none)
     apply simp
    apply auto[1]
   apply auto[1]
  apply simp
  apply standard
  apply (rule disjI2)
  apply (rule alw_mono[of "nxt (state_eq None)"])
   apply (metis (no_types, lifting) drinks_step_2_none fst_conv make_full_observation.sel(2) nxt.simps nxt_alw once_none_always_none_aux)
  by simp

(* costsMoney: THEOREM drinks |- G(X(cfstate=State_2) => gval(value_ge(r_2, Some(NUM(100))))); *)
lemma LTL_costsMoney:
  "(alw (nxt (state_eq (Some 2)) impl (check_exp (Ge (V (Rg 2)) (L (Num 100)))))) (watch drinks i)"
proof(coinduction)
  case alw
  then show ?case
    apply (cases "shd i")
    subgoal for l ip
      apply (case_tac "l = STR ''select'' \<and> length ip = 1")
       defer
       apply (simp add: possible_steps_0_invalid)
       apply (rule disjI2)
       apply (rule alw_mono[of "nxt (state_eq None)"])
        apply (simp add: once_none_nxt_always_none)
       apply (simp add: )
      apply (simp add: possible_steps_0 select_def)
      apply (rule disjI2)
      apply (simp only: nxt.simps[symmetric])
      using costsMoney_aux by auto
    done
qed

lemma LTL_costsMoney_aux:
  "(alw (not (check_exp (Ge (V (Rg 2)) (L (Num 100)))) impl (not (nxt (state_eq (Some 2)))))) (watch drinks i)"
  by (metis (no_types, lifting) LTL_costsMoney alw_mono)

lemma implode_select: "String.implode ''select'' = STR ''select''"
  by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

lemma implode_coin: "String.implode ''coin'' = STR ''coin''"
  by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

lemma implode_vend: "String.implode ''vend'' = STR ''vend''"
  by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

lemmas implode_labels = implode_select implode_coin implode_vend

lemma LTL_neverReachS2:"(((((action_eq (''select'', [Str ''coke''])))
                    aand
                    (nxt ((action_eq (''coin'', [Num 100])))))
                    aand
                    (nxt (nxt((label_eq ''vend'' aand (input_eq []))))))
                    impl
                    (nxt (nxt (nxt (state_eq (Some 2))))))
                    (watch drinks i)"
  apply (simp add: implode_labels)
  apply (cases i)
  apply clarify
  apply simp
  apply (simp add: possible_steps_0 select_def)
  apply (case_tac "shd x2", clarify)
  apply (simp add: possible_steps_1_coin coin_def value_plus_def finfun_update_twist apply_updates_def)
  apply (case_tac "shd (stl x2)", clarify)
  by (simp add: drinks_vend_sufficient )

lemma ltl_step_not_select:
  "\<nexists>i. e = (STR ''select'', [i]) \<Longrightarrow>
   ltl_step drinks (Some 0) r e = (None, [], r)"
  apply (cases e, clarify)
  apply (rule ltl_step_none)
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def select_def)
  by (cases e, case_tac b, auto)

lemma ltl_step_select:
  "ltl_step drinks (Some 0) <> (STR ''select'', [i]) = (Some 1, [], <1 $:= Some i, 2 $:= Some (Num 0)>)"
  apply (rule  ltl_step_some[of _ _ _ _ _ _ select])
    apply (simp add: possible_steps_0)
   apply (simp add: select_def)
  by (simp add: select_def finfun_update_twist apply_updates_def)

lemma ltl_step_not_coin_or_vend:
  "\<nexists>i. e = (STR ''coin'', [i]) \<Longrightarrow>
    e \<noteq> (STR ''vend'', []) \<Longrightarrow>
    ltl_step drinks (Some 1) r e = (None, [], r)"
  apply (cases e)
  apply (simp del: ltl_step.simps)
  apply (rule ltl_step_none)
  apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
  by (case_tac e, case_tac b, auto)

lemma ltl_step_coin:
  "\<exists>p r'. ltl_step drinks (Some 1) r (STR ''coin'', [i]) = (Some 1, p, r')"
  by (simp add: possible_steps_1_coin)

lemma alw_tl:
  "alw \<phi> (make_full_observation e (Some 0) <> [] xs) \<Longrightarrow>
    alw \<phi>
     (make_full_observation e (fst (ltl_step e (Some 0) <> (shd xs))) (snd (snd (ltl_step e (Some 0) <> (shd xs))))
       (fst (snd (ltl_step e (Some 0) <> (shd xs)))) (stl xs))"
  by auto

lemma stop_at_none:
  "alw (\<lambda>xs. output (shd (stl xs)) = [Some (EFSM.Str drink)] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs)
            (make_full_observation drinks None r p t)"
  apply (rule alw_mono[of "nxt (output_eq [])"])
   apply (simp add: no_output_none_nxt)
  by simp

lemma drink_costs_money_aux:
  assumes "\<exists>p r t. j = make_full_observation drinks (Some 1) r p t"
  shows "alw (\<lambda>xs. output (shd (stl xs)) = [Some (EFSM.Str drink)] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
  using assms apply coinduct
  apply clarsimp
  apply (case_tac "shd t")
  apply (simp del: ltl_step.simps)
  apply (rule P_ltl_step_1)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply (simp add: Str_def value_plus_never_string)
    apply auto[1]
   apply auto[1]
  apply simp
  apply standard
  apply (rule disjI2)
  apply (rule alw_mono[of "nxt (output_eq [])"])
   apply (simp add: drinks_step_2_none no_output_none_if_empty nxt_alw)
  by simp

lemma LTL_drinks_cost_money:
  "alw (nxt (output_eq [Some (Str drink)]) impl (check_exp (Ge (V (Rg 2)) (L (Num 100))))) (watch drinks t)"
proof(coinduction)
  case alw
  then show ?case
    apply (case_tac "shd t")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_0)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply simp
    using drink_costs_money_aux
    apply simp
    by blast
qed

lemma steps_1_invalid:
      "\<nexists>i. (a, b) = (STR ''coin'', [i]) \<Longrightarrow>
       \<nexists>i. (a, b) = (STR ''vend'', []) \<Longrightarrow>
       possible_steps drinks 1 r a b = {||}"
  apply (simp add: possible_steps_empty drinks_def transitions can_take_transition_def can_take_def)
  by (induct b, auto)

lemma output_vend_aux:
  assumes "\<exists>p r t. j = make_full_observation drinks (Some 1) r p t"
  shows "alw (\<lambda>xs. label_eq ''vend'' xs \<and> output (shd (stl xs)) = [Some d] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
  using assms apply coinduct
  apply clarsimp
  apply (case_tac "shd t")
  apply (simp add: implode_vend del: ltl_step.simps)
  apply (rule P_ltl_step_1)
     apply simp
     apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply auto[1]
   apply auto[1]
  apply simp
  apply standard
  apply (rule disjI2)
  apply (rule alw_mono[of "nxt (output_eq [])"])
   apply (simp add: drinks_step_2_none no_output_none_if_empty nxt_alw)
  by simp

text_raw\<open>\snip{outputVend}{1}{2}{%\<close>
lemma LTL_output_vend:
  "alw (((label_eq ''vend'') aand (nxt (output_eq [Some d]))) impl
         (check_exp (Ge (V (Rg 2)) (L (Num 100))))) (watch drinks t)"
text_raw\<open>}%endsnip\<close>
proof(coinduction)
  case alw
  then show ?case
    apply (simp add: implode_vend)
    apply (case_tac "shd t")
    apply (simp del: ltl_step.simps)
    apply (rule P_ltl_step_0)
     apply simp
    apply (rule disjI2)
     apply (rule alw_mono[of "nxt (output_eq [])"])
      apply (simp add: no_output_none_nxt)
     apply simp
    apply simp
    subgoal for a b
      using output_vend_aux[of "(make_full_observation drinks (Some 1)
              <1 $:= Some (hd b), 2 $:= Some (Num 0)> [] (stl t))" d]
      using implode_vend by auto
    done
qed

text_raw\<open>\snip{outputVendUnfolded}{1}{2}{%\<close>
lemma LTL_output_vend_unfolded:
  "alw (\<lambda>xs. (label (shd xs) = STR ''vend'' \<and>
             nxt (\<lambda>s. output (shd s) = [Some d]) xs) \<longrightarrow>
              \<not>? value_gt (Some (Num 100)) (datastate (shd xs) $ 2) = trilean.true)
     (watch drinks t)"
text_raw\<open>}%endsnip\<close>
  apply (insert LTL_output_vend[of d t])
  by (simp add: implode_vend)

end


(* CPS conversion *)
theory CPS1_Plotkin
imports Lt
begin

nominal_function
  CPS :: "lt \<Rightarrow> lt" ("_*" [250] 250)
where
  "atom k \<sharp> x \<Longrightarrow> (x~)* = (Lam k ((k~) $$ (x~)))"
| "atom k \<sharp> (x, M) \<Longrightarrow> (Lam x M)* = Lam k (k~ $$ Lam x (M*))"
| "atom k \<sharp> (M, N) \<Longrightarrow> atom m \<sharp> (N, k) \<Longrightarrow> atom n \<sharp> (k, m) \<Longrightarrow>
    (M $$ N)* = Lam k (M* $$ Lam m (N* $$ Lam n (m~ $$ n~ $$ k~)))"
unfolding eqvt_def CPS_graph_aux_def
apply (simp)
using [[simproc del: alpha_lst]]
apply (simp_all add: fresh_Pair_elim)
apply (rule_tac y="x" in lt.exhaust)
apply (auto)[3]
apply (rule_tac x="name" and ?'a="name" in obtain_fresh)
using [[simproc del: alpha_lst]]
apply (simp_all add: fresh_at_base)[3]
apply (rule_tac x="(lt1, lt2)" and ?'a="name" in obtain_fresh)
apply (rule_tac x="(lt2, a)" and ?'a="name" in obtain_fresh)
apply (rule_tac x="(a, aa)" and ?'a="name" in obtain_fresh)
apply (simp add: fresh_Pair_elim fresh_at_base)
apply (rule_tac x="(name, lt)" and ?'a="name" in obtain_fresh)
apply (simp add: fresh_Pair_elim fresh_at_base)[2]
apply (simp add: Abs1_eq_iff lt.fresh fresh_at_base)
--"-"
apply(rule_tac s="[[atom ka]]lst. ka~ $$ Lam x (CPS_sumC M)" in trans)
apply (case_tac "k = ka")
apply simp
thm Abs1_eq_iff
apply(subst Abs1_eq_iff)
apply(rule disjI2)
apply(rule conjI)
apply(simp)
apply(rule conjI)
apply (simp only: lt.perm_simps(1) lt.perm_simps(2) flip_def[symmetric] lt.eq_iff)
apply (subst  flip_at_base_simps(2))
apply(simp)
apply (intro conjI refl)
apply (rule flip_fresh_fresh[symmetric])
apply (simp_all add: lt.fresh)
apply (metis fresh_eqvt_at lt.fsupp)
apply (case_tac "ka = x")
apply simp_all[2]
apply (metis Abs_fresh_iff(3) atom_eq_iff finite_set fresh_Cons fresh_Nil fresh_atom fresh_eqvt_at fresh_finite_atom_set fresh_set lt.fsupp)
apply (metis Abs_fresh_iff(3) atom_eq_iff finite_set fresh_Cons fresh_Nil fresh_atom fresh_eqvt_at fresh_finite_atom_set fresh_set lt.fsupp)
--"-"
apply (simp add: Abs1_eq(3))
apply (erule Abs_lst1_fcb2)
apply (simp_all add: Abs_fresh_iff fresh_Nil fresh_star_def eqvt_at_def)[4]
--"-"
apply (rename_tac k' M N m' n')
apply (subgoal_tac "atom k \<sharp> CPS_sumC M \<and> atom k' \<sharp> CPS_sumC M \<and> atom k \<sharp> CPS_sumC N \<and> atom k' \<sharp> CPS_sumC N \<and>
                    atom m \<sharp> CPS_sumC N \<and> atom m' \<sharp> CPS_sumC N")
prefer 2
apply (intro conjI)
apply (erule fresh_eqvt_at, simp add: finite_supp, assumption)+
apply clarify
apply (case_tac "k = k'", case_tac [!] "m' = k",case_tac [!]"m = k'",case_tac[!] "m = m'")
apply (simp_all add: Abs1_eq_iff lt.fresh flip_def[symmetric] fresh_at_base flip_fresh_fresh permute_eq_iff)
by (metis flip_at_base_simps(3) flip_at_simps(2) flip_commute permute_flip_at)+

nominal_termination (eqvt) by lexicographic_order

lemmas [simp] = fresh_Pair_elim CPS.simps(2,3)[simplified fresh_Pair_elim]

lemma [simp]: "x \<sharp> M* = x \<sharp> M"
  unfolding fresh_def by simp

nominal_function
  convert:: "lt => lt" ("_+" [250] 250)
where
  "(Var x)+ = Var x"
| "(Lam x M)+ = Lam x (M*)"
| "(M $$ N)+ = M $$ N"
  unfolding convert_graph_aux_def eqvt_def
  apply (simp)
  apply(rule TrueI)
  apply (erule lt.exhaust)
  using [[simproc del: alpha_lst]]
  apply (simp_all)
  apply (simp add: Abs1_eq_iff CPS.eqvt)
  by blast

nominal_termination (eqvt)
  by (relation "measure size") (simp_all)

lemma convert_supp[simp]:
  shows "supp (M+) = supp M"
  by (induct M rule: lt.induct, simp_all add: lt.supp)

lemma convert_fresh[simp]:
  shows "x \<sharp> (M+) = x \<sharp> M"
  unfolding fresh_def by simp

lemma [simp]:
  shows "isValue (p \<bullet> (M::lt)) = isValue M"
  by (nominal_induct M rule: lt.strong_induct) auto

nominal_function
  Kapply :: "lt \<Rightarrow> lt \<Rightarrow> lt"       (infixl ";" 100)
where
  "Kapply (Lam x M) K = K $$ (Lam x M)+"
| "Kapply (Var x) K = K $$ Var x"
| "isValue M \<Longrightarrow> isValue N \<Longrightarrow> Kapply (M $$ N) K = M+ $$ N+ $$ K"
| "isValue M \<Longrightarrow> \<not>isValue N \<Longrightarrow> atom n \<sharp> M \<Longrightarrow> atom n \<sharp> K \<Longrightarrow>
    Kapply (M $$ N) K = N; (Lam n (M+ $$ Var n $$ K))"
| "\<not>isValue M \<Longrightarrow> atom m \<sharp> N \<Longrightarrow> atom m \<sharp> K \<Longrightarrow> atom n \<sharp> m \<Longrightarrow> atom n \<sharp> K \<Longrightarrow>
    Kapply (M $$ N) K = M; (Lam m (N*  $$ (Lam n (Var m $$ Var n $$ K))))"
  unfolding Kapply_graph_aux_def eqvt_def
  apply (simp)
using [[simproc del: alpha_lst]]
apply (simp_all)
apply (case_tac x)
apply (rule_tac y="a" in lt.exhaust)
apply (auto)
apply (case_tac "isValue lt1")
apply (case_tac "isValue lt2")
apply (auto)[1]
apply (rule_tac x="(lt1, ba)" and ?'a="name" in obtain_fresh)
apply (simp add: fresh_Pair_elim fresh_at_base)
apply (rule_tac x="(lt2, ba)" and ?'a="name" in obtain_fresh)
apply (rule_tac x="(a, ba)" and ?'a="name" in obtain_fresh)
apply (simp add: fresh_Pair_elim fresh_at_base)
apply (auto simp add: Abs1_eq_iff eqvts)[1]
apply (rename_tac M N u K)
apply (subgoal_tac "Lam n (M+ $$ n~ $$ K) =  Lam u (M+ $$ u~ $$ K)")
apply (simp only:)
apply (auto simp add: Abs1_eq_iff flip_fresh_fresh fresh_at_base)[1]
apply (subgoal_tac "Lam m (Na* $$ Lam n (m~ $$ n~ $$ Ka)) = Lam ma (Na* $$ Lam na (ma~ $$ na~ $$ Ka))")
apply (simp only:)
apply (simp add: Abs1_eq_iff flip_fresh_fresh fresh_at_base)
apply (case_tac "m = ma")
apply simp_all
apply (case_tac "m = na")
apply(simp_all add: flip_fresh_fresh)
done

nominal_termination (eqvt)
  by (relation "measure (\<lambda>(t, _). size t)") (simp_all)

section{* lemma related to Kapply *}

lemma [simp]: "isValue V \<Longrightarrow> V; K = K $$ (V+)"
  by (nominal_induct V rule: lt.strong_induct) auto

section{* lemma related to CPS conversion *}

lemma value_CPS:
  assumes "isValue V"
  and "atom a \<sharp> V"
  shows "V* = Lam a (a~ $$ V+)"
  using assms
proof (nominal_induct V avoiding: a rule: lt.strong_induct, simp_all add: lt.fresh)
  fix name :: name and lt aa
  assume a: "atom name \<sharp> aa" "\<And>b. \<lbrakk>isValue lt; atom b \<sharp> lt\<rbrakk> \<Longrightarrow> lt* = Lam b (b~ $$ lt+)"
    "atom aa \<sharp> lt \<or> aa = name"
  obtain ab :: name where b: "atom ab \<sharp> (name, lt, a)" using obtain_fresh by blast
  show "Lam name lt* = Lam aa (aa~ $$ Lam name (lt*))" using a b
    by (simp add: Abs1_eq_iff fresh_at_base lt.fresh)
qed

section{* first lemma CPS subst *}

lemma CPS_subst_fv:
  assumes *:"isValue V"
  shows "((M[x ::= V])* = (M*)[x ::= V+])"
using * proof (nominal_induct M avoiding: V x rule: lt.strong_induct)
  case (Var name)
  assume *: "isValue V"
  obtain a :: name where a: "atom a \<sharp> (x, name, V)" using obtain_fresh by blast
  show "((name~)[x ::= V])* = (name~)*[x ::= V+]" using a
    by (simp add: fresh_at_base * value_CPS)
next
  case (Lam name lt V x)
  assume *: "atom name \<sharp> V" "atom name \<sharp> x" "\<And>b ba. isValue b \<Longrightarrow> (lt[ba ::= b])* = lt*[ba ::= b+]"
    "isValue V"
  obtain a :: name where a: "atom a \<sharp> (name, lt, lt[x ::= V], x, V)" using obtain_fresh by blast
  show "(Lam name lt[x ::= V])* = Lam name lt*[x ::= V+]" using * a
    by (simp add: fresh_at_base)
next
  case (App lt1 lt2 V x)
  assume *: "\<And>b ba. isValue b \<Longrightarrow> (lt1[ba ::= b])* = lt1*[ba ::= b+]" "\<And>b ba. isValue b \<Longrightarrow> (lt2[ba ::= b])* = lt2*[ba ::= b+]"
    "isValue V"
  obtain a :: name where a: "atom a \<sharp> (lt1[x ::= V], lt1, lt2[x ::= V], lt2, V, x)" using obtain_fresh by blast
  obtain b :: name where b: "atom b \<sharp> (lt2[x ::= V], lt2, a, V, x)" using obtain_fresh by blast
  obtain c :: name where c: "atom c \<sharp> (a, b, V, x)" using obtain_fresh by blast
  show "((lt1 $$ lt2)[x ::= V])* = (lt1 $$ lt2)*[x ::= V+]" using * a b c
    by (simp add: fresh_at_base)
qed

lemma [simp]: "isValue V \<Longrightarrow> isValue (V+)"
  by (nominal_induct V rule: lt.strong_induct, auto)

lemma CPS_eval_Kapply:
  assumes a: "isValue K"
  shows "(M* $$ K) \<longrightarrow>\<^isub>\<beta>\<^sup>* (M ; K)"
  using a
proof (nominal_induct M avoiding: K rule: lt.strong_induct, simp_all)
  case (Var name K)
  assume *: "isValue K"
  obtain a :: name where a: "atom a \<sharp> (name, K)" using obtain_fresh by blast
  show "(name~)* $$ K \<longrightarrow>\<^isub>\<beta>\<^sup>* K $$ name~" using * a
    by simp (rule evbeta', simp_all add: fresh_at_base)
next
  fix name :: name and lt K
  assume *: "atom name \<sharp> K" "\<And>b. isValue b \<Longrightarrow> lt* $$ b \<longrightarrow>\<^isub>\<beta>\<^sup>* lt ; b" "isValue K"
  obtain a :: name where a: "atom a \<sharp> (name, K, lt)" using obtain_fresh by blast
  then have b: "atom name \<sharp> a" using fresh_PairD(1) fresh_at_base atom_eq_iff by metis
  show "Lam name lt* $$ K \<longrightarrow>\<^isub>\<beta>\<^sup>* K $$ Lam name (lt*)" using * a b
    by simp (rule evbeta', simp_all)
next
  fix lt1 lt2 K
  assume *: "\<And>b. isValue b \<Longrightarrow>  lt1* $$ b \<longrightarrow>\<^isub>\<beta>\<^sup>* lt1 ; b" "\<And>b. isValue b \<Longrightarrow>  lt2* $$ b \<longrightarrow>\<^isub>\<beta>\<^sup>* lt2 ; b" "isValue K"
  obtain a :: name where a: "atom a \<sharp> (lt1, lt2, K)" using obtain_fresh by blast
  obtain b :: name where b: "atom b \<sharp> (lt1, lt2, K, a)" using obtain_fresh by blast
  obtain c :: name where c: "atom c \<sharp> (lt1, lt2, K, a, b)" using obtain_fresh by blast
  have d: "atom a \<sharp> lt1" "atom a \<sharp> lt2" "atom a \<sharp> K" "atom b \<sharp> lt1" "atom b \<sharp> lt2" "atom b \<sharp> K" "atom b \<sharp> a"
    "atom c \<sharp> lt1" "atom c \<sharp> lt2" "atom c \<sharp> K" "atom c \<sharp> a" "atom c \<sharp> b" using fresh_Pair a b c by simp_all
  have "(lt1 $$ lt2)* $$ K \<longrightarrow>\<^isub>\<beta>\<^sup>* lt1* $$ Lam b (lt2* $$ Lam c (b~ $$ c~ $$ K))" using * d
    by (simp add: fresh_at_base) (rule evbeta', simp_all add: fresh_at_base)
  also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* lt1 $$ lt2 ; K" proof (cases "isValue lt1")
    assume e: "isValue lt1"
    have "lt1* $$ Lam b (lt2* $$ Lam c (b~ $$ c~ $$ K)) \<longrightarrow>\<^isub>\<beta>\<^sup>* Lam b (lt2* $$ Lam c (b~ $$ c~ $$ K)) $$ lt1+"
      using * d e by simp
    also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* lt2* $$ Lam c (lt1+ $$ c~ $$ K)"
      by (rule evbeta')(simp_all add: * d e)
    also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* lt1 $$ lt2 ; K" proof (cases "isValue lt2")
      assume f: "isValue lt2"
      have "lt2* $$ Lam c (lt1+ $$ c~ $$ K) \<longrightarrow>\<^isub>\<beta>\<^sup>* Lam c (lt1+ $$ c~ $$ K) $$ lt2+" using * d e f by simp
      also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* lt1+ $$ lt2+ $$ K"
        by (rule evbeta', simp_all add: d e f)
      finally show ?thesis using * d e f by simp
    next
      assume f: "\<not> isValue lt2"
      have "lt2* $$ Lam c (lt1+ $$ c~ $$ K) \<longrightarrow>\<^isub>\<beta>\<^sup>* lt2 ; Lam c (lt1+ $$ c~ $$ K)" using * d e f by simp
      also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* lt2 ; Lam a (lt1+ $$ a~ $$ K)" using Kapply.simps(4) d e evs1 f by metis
      finally show ?thesis using * d e f by simp
    qed
    finally show ?thesis .
  qed (metis Kapply.simps(5) isValue.simps(2) * d)
  finally show "(lt1 $$ lt2)* $$ K \<longrightarrow>\<^isub>\<beta>\<^sup>* lt1 $$ lt2 ; K" .
qed

lemma Kapply_eval:
  assumes a: "M \<longrightarrow>\<^isub>\<beta> N" "isValue K"
  shows "(M; K) \<longrightarrow>\<^isub>\<beta>\<^sup>*  (N; K)"
  using assms
proof (induct arbitrary: K rule: eval.induct)
  case (evbeta x V M)
  fix K
  assume a: "isValue K" "isValue V" "atom x \<sharp> V"
  have "Lam x (M*) $$ V+ $$ K \<longrightarrow>\<^isub>\<beta>\<^sup>* (((M*)[x ::= V+]) $$ K)"
    by (rule evs2,rule ev2,rule Lt.evbeta) (simp_all add: fresh_def a[simplified fresh_def] evs1)
  also have "... = ((M[x ::= V])* $$ K)" by (simp add: CPS_subst_fv a)
  also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* ((M[x ::= V]) ; K)" by (rule CPS_eval_Kapply, simp_all add: a)
  finally show "(Lam x M $$ V ; K) \<longrightarrow>\<^isub>\<beta>\<^sup>*  ((M[x ::= V]) ; K)" using a by simp
next
  case (ev1 V M N)
  fix V M N K
  assume a: "isValue V" "M \<longrightarrow>\<^isub>\<beta> N" "\<And>K. isValue K \<Longrightarrow> M ; K \<longrightarrow>\<^isub>\<beta>\<^sup>* N ; K" "isValue K"
  obtain a :: name where b: "atom a \<sharp> (V, K, M, N)" using obtain_fresh by blast
  show "V $$ M ; K \<longrightarrow>\<^isub>\<beta>\<^sup>* V $$ N ; K" proof (cases "isValue N")
    assume "\<not> isValue N"
    then show "V $$ M ; K \<longrightarrow>\<^isub>\<beta>\<^sup>* V $$ N ; K" using a b by simp
  next
    assume n: "isValue N"
    have c: "M; Lam a (V+ $$ a~ $$ K) \<longrightarrow>\<^isub>\<beta>\<^sup>* Lam a (V+ $$ a~ $$ K) $$ N+" using a b by (simp add: n)
    also have d: "... \<longrightarrow>\<^isub>\<beta>\<^sup>* V+ $$ N+ $$ K" by (rule evbeta') (simp_all add: a b n)
    finally show "V $$ M ; K \<longrightarrow>\<^isub>\<beta>\<^sup>* V $$ N ; K" using a b by (simp add: n)
  qed
next
  case (ev2 M M' N)
  assume *: "M \<longrightarrow>\<^isub>\<beta> M'" "\<And>K. isValue K \<Longrightarrow>  M ; K \<longrightarrow>\<^isub>\<beta>\<^sup>* M' ; K" "isValue K"
  obtain a :: name where a: "atom a \<sharp> (K, M, N, M')" using obtain_fresh by blast
  obtain b :: name where b: "atom b \<sharp> (a, K, M, N, M', N+)" using obtain_fresh by blast
  have d: "atom a \<sharp> K" "atom a \<sharp> M" "atom a \<sharp> N" "atom a \<sharp> M'" "atom b \<sharp> a" "atom b \<sharp> K"
    "atom b \<sharp> M" "atom b \<sharp> N" "atom b \<sharp> M'" using a b fresh_Pair by simp_all
  have "M $$ N ; K  \<longrightarrow>\<^isub>\<beta>\<^sup>* M' ; Lam a (N* $$ Lam b (a~ $$ b~ $$ K))" using * d by simp
  also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* M' $$ N ; K" proof (cases "isValue M'")
    assume "\<not> isValue M'"
    then show ?thesis using * d by (simp_all add: evs1)
  next
    assume e: "isValue M'"
    then have "M' ; Lam a (N* $$ Lam b (a~ $$ b~ $$ K)) = Lam a (N* $$ Lam b (a~ $$ b~ $$ K)) $$ M'+" by simp
    also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* (N* $$ Lam b (a~ $$ b~ $$ K))[a ::= M'+]"
      by (rule evbeta') (simp_all add: fresh_at_base e d)
    also have "... = N* $$ Lam b (M'+ $$ b~ $$ K)" using * d by (simp add: fresh_at_base)
    also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* M' $$ N ; K" proof (cases "isValue N")
      assume f: "isValue N"
      have "N* $$ Lam b (M'+ $$ b~ $$ K) \<longrightarrow>\<^isub>\<beta>\<^sup>* Lam b (M'+ $$ b~ $$ K) $$ N+"
        by (rule eval_trans, rule CPS_eval_Kapply) (simp_all add: d e f * evs1)
      also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* M' $$ N ; K" by (rule evbeta') (simp_all add: d e f evs1)
      finally show ?thesis .
    next
      assume "\<not> isValue N"
      then show ?thesis using d e
        by (metis CPS_eval_Kapply Kapply.simps(4) isValue.simps(2))
    qed
    finally show ?thesis .
  qed
  finally show ?case .
qed

lemma Kapply_eval_rtrancl:
  assumes H: "M \<longrightarrow>\<^isub>\<beta>\<^sup>*  N" and "isValue K"
  shows "(M;K) \<longrightarrow>\<^isub>\<beta>\<^sup>* (N;K)"
  using H
  by (induct) (metis Kapply_eval assms(2) eval_trans evs1)+

lemma
  assumes "isValue V" "M \<longrightarrow>\<^isub>\<beta>\<^sup>* V"
  shows "M* $$ (Lam x (x~)) \<longrightarrow>\<^isub>\<beta>\<^sup>* V+"
proof-
  obtain y::name where *: "atom y \<sharp> V" using obtain_fresh by blast
  have e: "Lam x (x~) = Lam y (y~)"
    by (simp add: Abs1_eq_iff lt.fresh fresh_at_base)
  have "M* $$ Lam x (x~) \<longrightarrow>\<^isub>\<beta>\<^sup>* M ; Lam x (x~)"
    by(rule CPS_eval_Kapply,simp_all add: assms)
  also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* (V ; Lam x (x~))" by (rule Kapply_eval_rtrancl, simp_all add: assms)
  also have "... = V ; Lam y (y~)" using e by (simp only:)
  also have "... \<longrightarrow>\<^isub>\<beta>\<^sup>* (V+)" by (simp add: assms, rule evbeta') (simp_all add: assms *)
  finally show "M* $$ (Lam x (x~)) \<longrightarrow>\<^isub>\<beta>\<^sup>* (V+)" .
qed

end


section \<open>Set Interface\<close>
theory IICF_Set
imports "../../Sepref"
begin

subsection \<open>Operations\<close>

context
  notes [simp] = IS_LEFT_UNIQUE_def (* Argh, the set parametricity lemmas use single_valued (K\<inverse>) here. *)
begin

context
  fixes t ::  "unit \<Rightarrow> nat"
begin
  definition "mop_set_empty = SPECT [ {} \<mapsto> enat (t ()) ]"

  lemma mop_set_empty: "tt \<le> lst (SPECT [ {} \<mapsto> (t ()) ]) Q \<Longrightarrow> tt
           \<le> lst (mop_set_empty) Q" unfolding mop_set_empty_def by simp

  sepref_register "mop_set_empty"
end

context
  fixes t ::  "'c set \<Rightarrow> nat"
begin
  definition "mop_set_isempty S = SPECT [ S={} \<mapsto> t S ]"

  lemma  mop_set_isempty: "tt \<le> lst (SPECT [ S={} \<mapsto> t S ])  Q
        \<Longrightarrow> tt \<le> lst (mop_set_isempty S) Q" unfolding mop_set_isempty_def by simp

  sepref_register "mop_set_isempty"
end

context
  fixes t ::  "'c set \<Rightarrow> nat"
begin
  definition "mop_set_pick S = do { ASSERT (S\<noteq>{}); SPECT (emb (\<lambda>x. x\<in>S) (t S)) }"

  lemma  mop_set_pick: "tt \<le> lst (SPECT (emb (\<lambda>x. x\<in>S) (t S)))  Q
        \<Longrightarrow> S \<noteq> {} \<Longrightarrow> tt \<le> lst (mop_set_pick S) Q" unfolding mop_set_pick_def by simp

  lemma progress_mop_set_pick[progress_rules]: "t S > 0 \<Longrightarrow> progress (mop_set_pick S)"
    unfolding mop_set_pick_def by (auto intro!: progress_rules simp add:   zero_enat_def)

  sepref_register "mop_set_pick"
end

context
  fixes t ::  "'c set \<Rightarrow> nat"
begin
  definition "mop_set_pick_extract S = do { ASSERT (S\<noteq>{}); SPECT (emb (\<lambda>(x,C). x\<in>S \<and> C=S-{x}) (t S)) }"

  lemma  mop_set_pick_extract: "tt \<le> lst (SPECT (emb (\<lambda>(x,C). x\<in>S \<and> C=S-{x}) (t S))) Q
        \<Longrightarrow> S \<noteq> {} \<Longrightarrow> tt \<le> lst (mop_set_pick_extract S) Q" unfolding mop_set_pick_extract_def by simp

  thm progress_rules

  lemma progress_mop_set_pick_extract[progress_rules]: "t S > 0 \<Longrightarrow> progress (mop_set_pick_extract S)"
    unfolding mop_set_pick_extract_def by (auto intro!: progress_rules simp add:   zero_enat_def)

  sepref_register "mop_set_pick_extract"
end

context
  fixes t:: "('c * 'c set) \<Rightarrow> nat"
begin
  definition "mop_set_member x S = SPECT [ x \<in> S \<mapsto> enat (t (x,S)) ]"
  sepref_register "mop_set_member"
  print_theorems
end

context
  fixes t ::  "('c set * 'c) \<Rightarrow> nat"
begin
  definition "mop_set_del S x = SPECT [ S - {x} \<mapsto> t (S,x)]"

  lemma  mop_set_del: "tt \<le> lst (SPECT [ S - {x} \<mapsto> t (S,x)])  Q
        \<Longrightarrow> tt \<le> lst (mop_set_del S x) Q" unfolding mop_set_del_def by simp

  lemma progress_mop_set_del[progress_rules]: "t (S,x) > 0 \<Longrightarrow> progress (mop_set_del S x)"
      unfolding mop_set_del_def  by (auto intro: progress_rules simp add:   zero_enat_def)

  sepref_register "mop_set_del"
end

context
  fixes t :: "('c*'c set) \<Rightarrow> nat"
begin

  definition "mop_set_insert x S = SPECT [insert x S \<mapsto> t (x,S)]"

  lemma mop_set_insert: "tt \<le> lst (SPECT [ (insert x S) \<mapsto> t (x,S)]) Q \<Longrightarrow>
         tt \<le> lst (mop_set_insert x S) Q" unfolding mop_set_insert_def by simp

  sepref_register "mop_set_insert"
end

end
end


theory Proof_5_8
  imports Proofs_5
begin

abbreviation s where "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value \<equiv>
 (toEnv
       (setPstate (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) ERROR
         Ctrl'emergency))"

theorem proof_5_8: "VC8 inv5 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC8_def inv5_def R5_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
   apply((drule conjE)+)
                      prefer 31
                      apply assumption
                      prefer 30
                      apply assumption
                      prefer 29
                      apply assumption
                      prefer 28
                      apply assumption
                      prefer 27
                      apply assumption
                      prefer 26
                      apply assumption
                      prefer 25
                      apply assumption
                      prefer 24
                      apply assumption
                      prefer 23
                      apply assumption
                      prefer 22
                      apply assumption
                      prefer 21
                      apply assumption
                      prefer 20
                      apply assumption
                     prefer 19
                     apply assumption
                    prefer 18
                    apply assumption
                   prefer 17
                   apply assumption
                  prefer 16
                  apply assumption
                 prefer 15
                 apply assumption
                prefer 14
                apply assumption
               prefer 13
               apply assumption
              prefer 12
              apply assumption
             prefer 11
             apply assumption
            prefer 10
            apply assumption
           prefer 9
           apply assumption
          prefer 8
          apply assumption
         prefer 7
         apply assumption
        prefer 6
        apply assumption
       prefer 5
       apply assumption
      prefer 4
      apply assumption
     prefer 3
     apply assumption
    prefer 2
    apply assumption
  subgoal premises prems for s1 s2
    apply(rule disjE[OF le_imp_less_or_eq[OF prems(13)]])
    apply(rule cut_rl[of " \<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4  s0 \<and>
         toEnvNum s2 s4 \<le> ERROR \<and>
         getVarBool s4 up' = DOWN' \<and>
         getVarBool s4 down' = DOWN' \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow> getVarBool s3 up' = UP' \<or> getVarBool s3 down' = UP')"])
      apply(drule exE)
       prefer 2
       apply assumption
    subgoal for s4
      apply(rule exI[of _ s4])
      by simp
    using prems(2) prems(4) prems(6) prems(8) prems(9) prems(11) prems(15) prems(16) apply -[1]
     apply(drule allE[of _ s1])
      prefer 2
      apply assumption
     apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply(simp split: if_splits)
    apply(rule cut_rl[of "\<forall> s5. toEnvP s5 \<and> substate s2 s5 \<and> substate s5
 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) \<longrightarrow>
 pred5 s1 s2
 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) s5"])
     apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply(drule impE)
       prefer 3
       apply assumption
    using prems(4,8) substate_refl apply fast
     apply(simp only: pred5_def)
     apply(drule impE)
       prefer 3
       apply assumption
    using prems(2)  prems(4) prems(6) prems(8) prems(9) prems(15) prems(16) substate_refl substate_trans substate_antisym
      apply blast
     apply fast
      apply(rule allI)
    subgoal premises toEnvNums2s for s5
      apply(induction rule: state_down_ind)
      using prems(8) apply simp
       apply(simp only: pred5_def)
       apply(rule impI)
       apply((drule conjE)+)
                  prefer 12
                  apply assumption
                 prefer 11
                 apply assumption
                prefer 10
                apply assumption
               prefer 9
               apply assumption
              prefer 8
              apply assumption
             prefer 7
             apply assumption
            prefer 6
            apply assumption
           prefer 5
           apply assumption
          prefer 4
          apply assumption
         prefer 3
         apply assumption
        prefer 2
        apply assumption

       apply(rule cut_rl[of
 "\<exists>s4. toEnvP s4 \<and> substate s4 s0 \<and> toEnvNum s4 s0 \<le> ERROR \<and> getVarBool s4 up' = DOWN' \<and> getVarBool s4 down' = DOWN'"])
        apply(drule exE)
         prefer 2
         apply assumption
      subgoal for s4
        apply(rule disjE[of "toEnvNum s4 s0 < 1" "toEnvNum s4 s0 = 1"])
          apply(rule le_imp_less_or_eq)
          apply fast
        apply (metis getPstate.simps(9) less_one prems(10) prems(30) prems(5) substate_toEnvNum_id)
        apply(rule cut_rl[of "s4 = s1"])
         apply simp
        apply (simp split: if_splits)
        using toEnvNum3 substate_toEnvNum_id gtimeE_inj
        by (metis prems(10) shift_toEnvNum)
       apply(rule goUp_not_moving[of s2 _ s0])
       apply(rule conjI)
        apply assumption
       apply(rule conjI)
      using prems(10) apply fast
       apply(rule conjI)
        apply (simp split: if_splits)
       apply(rule conjI)
      using substate_refl apply fast
       apply(rule conjI)
        apply(simp split: if_splits)
       apply(rule conjI)
        apply assumption
       apply(rule conjI)
      using prems(5) apply simp
      using prems apply fast

      subgoal for s5
        apply(simp only: pred5_def)
        apply(rule impI)
        apply(cases "getVarBool (predEnv s5) up' = False  \<and> getVarBool (predEnv s5) down' = False")
       apply(rule exI[of _ "predEnv s5"])
       apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
        apply blast
       apply(rule conjI)
      using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) "]
        apply force
       apply(rule conjI)
        apply fast
       apply(rule conjI)
        apply fast
      using substate_antisym apply fast
      apply(drule impE)
        apply(((rule conjI),blast)+)
      using substate_eq_or_predEnv apply blast
      prefer 2
       apply assumption
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
       apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        apply((drule conjE)+)
                           prefer 20
                           apply assumption
                          prefer 19
                          apply assumption
                         prefer 18
                         apply assumption
                        prefer 17
                        apply assumption
                       prefer 16
                       apply assumption
                      prefer 15
                      apply assumption
                     prefer 14
                     apply assumption
                    prefer 13
                    apply assumption
                   prefer 12
                   apply assumption
                  prefer 11
                  apply assumption
                 prefer 10
                 apply assumption
                prefer 9
                apply assumption
               prefer 8
               apply assumption
              prefer 7
              apply assumption
             prefer 6
             apply assumption
            prefer 5
            apply assumption
           prefer 4
           apply assumption
          prefer 3
          apply assumption
         prefer 2
         apply assumption
        using predEnv_substate_imp_eq_or_substate by blast
      done
    done
  done