section \<open>Type Safety of Boogie expressions\<close>

theory TypeSafety
imports Semantics Typing Util
begin

fun expr_is_defined :: "var_context \<Rightarrow> 'a nstate \<Rightarrow> expr \<Rightarrow> bool"
  where
     "expr_is_defined \<Lambda> ns (Var x) = (lookup_var \<Lambda> ns x \<noteq> None)"
   | "expr_is_defined \<Lambda> ns (BVar i) = (binder_state ns i \<noteq> None)"
   | "expr_is_defined \<Lambda> ns (Lit l) = True"
   | "expr_is_defined \<Lambda> ns (UnOp uop e) = expr_is_defined \<Lambda> ns e"
   | "expr_is_defined \<Lambda> ns (e1 \<guillemotleft>bop\<guillemotright> e2) = ((expr_is_defined \<Lambda> ns e1) \<and> (expr_is_defined \<Lambda> ns e2))"
   | "expr_is_defined \<Lambda> ns (FunExp f tys e) = ((list_all closed tys) \<and> (list_all (expr_is_defined \<Lambda> ns) e))"
   | "expr_is_defined \<Lambda> ns (CondExp cond thn els) = ( (expr_is_defined \<Lambda> ns cond) \<and>
                                                      (expr_is_defined \<Lambda> ns thn) \<and>
                                                      (expr_is_defined \<Lambda> ns els) )"
   | "expr_is_defined \<Lambda> ns (Old e) = expr_is_defined \<Lambda> ns e"
   | "expr_is_defined \<Lambda> ns (Forall ty e) = ((closed ty) \<and> (\<forall>w. (expr_is_defined \<Lambda> (full_ext_env ns w) e)))"
   | "expr_is_defined \<Lambda> ns (Exists ty e) =  ((closed ty) \<and> (\<forall>w. (expr_is_defined \<Lambda> (full_ext_env ns w) e)))"
   | "expr_is_defined \<Lambda> ns (ForallT e) = expr_is_defined \<Lambda> ns e"
   | "expr_is_defined \<Lambda> ns (ExistsT e) = expr_is_defined \<Lambda> ns e"

lemma unop_type_correct: "\<lbrakk> unop_type uop arg_ty = Some ret_ty; type_of_val A v' = TPrim arg_ty;
                         (unop_eval_val uop v') = Some v  \<rbrakk> \<Longrightarrow>
                       type_of_val A v = TPrim ret_ty"
  by (cases uop; rule lit_val_elim[where v=v']; auto)

lemma unop_progress: "\<lbrakk> unop_type uop arg_ty = Some ret_ty; type_of_val A v' = TPrim arg_ty\<rbrakk> \<Longrightarrow>
                       \<exists>v. (unop_eval_val uop v') = Some v "
  by (cases uop; rule lit_val_elim[where v=v']; auto)

lemma binop_type_correct:
 "\<lbrakk> binop_type bop = Some (targs, ret_ty);
    type_of_val  A v1 = (TPrim left_ty); type_of_val A v2 = (TPrim right_ty);
    (left_ty, right_ty) \<in> targs;
    (binop_eval_val bop v1 v2) = Some v  \<rbrakk> \<Longrightarrow>
    type_of_val A v = TPrim ret_ty"
  by (cases bop; rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_progress:
 "\<lbrakk> binop_type bop = Some (targs, ret_ty);
    type_of_val  A v1 = TPrim left_ty; type_of_val A v2 = TPrim right_ty;
   (left_ty, right_ty) \<in> targs \<rbrakk> \<Longrightarrow>
    \<exists>v. (binop_eval_val bop v1 v2) = Some v "
  by (cases bop; rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_realdiv_type_correct:
 "\<lbrakk> (binop_eval_val RealDiv v1 v2) = Some v  \<rbrakk> \<Longrightarrow>
    type_of_val A v = TPrim TReal"
  by (rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_realdiv_progress:
 "\<lbrakk> type_of_val A v1 = TPrim TInt \<or> type_of_val A v1 = TPrim TReal;
    type_of_val A v2 = TPrim TInt \<or> type_of_val A v2 = TPrim TReal \<rbrakk> \<Longrightarrow>
    \<exists>v. binop_eval_val RealDiv v1 v2  = Some v"
  by (rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

lemma binop_poly_type_correct:
 "\<lbrakk> binop_poly_type bop; binop_eval_val bop v1 v2 = Some v \<rbrakk> \<Longrightarrow> type_of_val A v = TPrim TBool"
  by (cases bop; rule lit_val_elim[where v=v1]; rule lit_val_elim[where v=v2]; auto)

text\<open>check whether the free variables of a type are at smaller than some value\<close>
fun wf_ty :: "nat \<Rightarrow> ty \<Rightarrow> bool"
  where
   "wf_ty n (TVar i) = (i < n)"
 | "wf_ty n (TPrim p) = True"
 | "wf_ty n (TCon tcon_id ty_args) = list_all (wf_ty n) ty_args"

primrec wf_expr :: "nat \<Rightarrow> expr \<Rightarrow> bool"
  where
    "wf_expr k (Var x) = True"
  | "wf_expr k (BVar i) = True"
  | "wf_expr k (Lit l) = True"
  | "wf_expr k (UnOp uop e) = wf_expr k e"
  | "wf_expr k (e1 \<guillemotleft>bop\<guillemotright> e2) = (wf_expr k e1 \<and> wf_expr k e2)"
  | "wf_expr k (FunExp f ty_args args) = ((list_all (wf_ty k) ty_args) \<and> (list_all (wf_expr k) args))"
  | "wf_expr k (CondExp cond e1 e2) = (wf_expr k cond \<and> wf_expr k e1 \<and> wf_expr k e2)"
  | "wf_expr k (Old e) = wf_expr k e"
  | "wf_expr k (Forall ty e) = ((wf_ty k ty) \<and> (wf_expr k e))"
  | "wf_expr k (Exists ty e) = ((wf_ty k ty) \<and> (wf_expr k e))"
  | "wf_expr k (ExistsT e) = (wf_expr (k+1) e)"
  | "wf_expr k (ForallT e) = (wf_expr (k+1) e)"

text \<open>A function declaration is well-formed, if the free type variables in the specified types are
captured by the type parameters of the function\<close>

fun wf_fdecl :: "(nat \<times> ty list \<times> ty) \<Rightarrow> bool"
  where
    "wf_fdecl (n, args_ty, ret_ty) = ((list_all (wf_ty n) args_ty) \<and> (wf_ty n ret_ty))"

lemma closed_instantiate: "list_all closed \<Omega> \<Longrightarrow> wf_ty (length \<Omega>) \<tau> \<Longrightarrow> closed (instantiate \<Omega> \<tau>)"
  by (induction \<tau>) (auto simp: list_all_iff)

lemma msubst_msubst:
  assumes "wf_ty (length ts2) t" and
          "list_all (wf_ty (length ts1)) ts2" and
          "list_all closed ts1"
  shows "msubstT ts1 (msubstT ts2 t) = msubstT (map (msubstT ts1) ts2) t"
  using assms
  oops

lemma instantiate_msubst_opt:
  assumes "wf_ty (length ts) \<tau>"
  shows "instantiate \<Omega> (msubstT_opt ts \<tau>) = instantiate (map (instantiate \<Omega>) ts) \<tau>"
  using assms
proof (induction \<tau>)
  case (TVar x)
  hence "x < length ts" by simp
  hence "msubstT_opt ts (TVar x) = ts ! x" by (simp add: msubstT_opt_def)
  thus ?case using \<open>x < length ts\<close> by simp
next
  case (TPrim x)
  then show ?case by (simp add: msubstT_opt_def)
next
  case (TCon x1a x2a)
  thus ?case
  apply (simp add: msubstT_opt_def)
  by (metis (no_types, lifting) in_set_conv_nth list_all_length)
qed

lemma map_of_list_all:
  assumes Map:"map_of xs k = Some x" and
          Pred:"list_all (P \<circ> snd) xs"
  shows "P x"
proof -
  from Map obtain i where "(i,x) \<in> set xs"
    by (meson map_of_SomeD)
  with Pred show ?thesis
    by (metis comp_apply in_set_conv_nth list_all_length snd_conv)
qed

lemma map_map:
  assumes "map f (map g xs) = ys"
  shows "map (f \<circ> g) xs = ys"
  using assms
  by auto

definition state_well_typed :: "'a absval_ty_fun \<Rightarrow> var_context \<Rightarrow> rtype_env \<Rightarrow> 'a nstate \<Rightarrow> bool"
  where "state_well_typed A \<Lambda> \<Omega> ns \<equiv>
         state_typ_wf A \<Omega> (local_state ns) (snd \<Lambda>) \<and>
         state_typ_wf A \<Omega> (global_state ns) (fst \<Lambda>) \<and>
         state_typ_wf A \<Omega> (old_global_state ns) (fst \<Lambda>) \<and>
         (binder_state ns = Map.empty)"

lemma state_well_typed_lookup:
  assumes "state_well_typed A \<Lambda> \<Omega> ns" and
          "lookup_var_ty \<Lambda> x = Some \<tau>"
        shows "\<exists>v. lookup_var \<Lambda> ns x = Some v \<and>type_of_val A v = instantiate \<Omega> \<tau>"
  using assms
  unfolding state_well_typed_def
  using state_typ_wf_lookup lookup_var_ty_decl_Some
  by blast

lemma state_well_typed_lookup_old:
  assumes "state_well_typed A \<Lambda> \<Omega> ns" and
          "lookup_var_ty \<Lambda> x = Some \<tau>"
  shows "\<exists>v. lookup_var \<Lambda> (ns\<lparr>global_state := old_global_state ns\<rparr>) x = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>"
  apply (rule state_typ_wf_lookup)
  using assms
  unfolding state_well_typed_def
  by auto

lemma old_global_switch_wt:
  assumes "state_well_typed A \<Lambda> \<Omega> n_s"
  shows "state_well_typed A \<Lambda> \<Omega> (n_s\<lparr>global_state := old_global_state n_s\<rparr>)"
  using assms
  unfolding state_well_typed_def
  by simp

text \<open>Type preservation theorem\<close>

theorem preservation:
  assumes
          "list_all closed \<Omega>" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> n_s k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          "\<forall> i \<tau>'. ((snd \<Delta>) i = Some \<tau>') \<longrightarrow> (\<exists>v. binder_state n_s i = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          Wf_\<Gamma>:"fun_interp_wf A F \<Gamma>" and
          Wf_F:"list_all (wf_fdecl \<circ> snd) F"
  shows "F, \<Delta> \<turnstile> e : \<tau> \<Longrightarrow> wf_expr (length \<Omega>) e \<Longrightarrow> A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v \<Longrightarrow> type_of_val A v = instantiate \<Omega> \<tau>" and
        "F, \<Delta> \<turnstile> es [:] ts \<Longrightarrow> list_all (wf_expr (length \<Omega>)) es \<Longrightarrow> A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es,n_s\<rangle> [\<Down>] vs \<Longrightarrow>
          map (type_of_val A) vs = (map (instantiate \<Omega>) ts)"
  using assms
proof (induction arbitrary: v n_s \<Omega> and vs n_s \<Omega> rule: typing_typing_list.inducts)
  case (TypVar \<Delta> x ty)
  then show ?case by fastforce
next
  case (TypBVar \<Delta> x ty)
  then show ?case
    by (metis RedBVar expr_eval_determ(1))
next
case (TypPrim l prim_ty \<Delta>)
  then show ?case by fastforce
next
  case (TypUnOp \<Delta> e arg_ty uop ret_ty)
  from this obtain v' where
     "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v'" and "unop_eval_val uop v' = Some v" by auto
  moreover from this have "type_of_val A v' = TPrim arg_ty" using TypUnOp by auto
  ultimately show ?case using \<open>unop_type uop arg_ty = Some ret_ty\<close> unop_type_correct by fastforce
next
  case (TypBinOpMono bop targs ret_ty \<Delta> e1 left_ty e2 right_ty)
  from this obtain v1 v2 where
     "A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e1, n_s\<rangle> \<Down> v1" and "A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e2, n_s\<rangle> \<Down> v2" and
     E:"binop_eval_val bop v1 v2 = Some v"
    by auto
  moreover from this have T1:"type_of_val A v1 = TPrim left_ty" and
    T2:"type_of_val A v2 = TPrim right_ty" using TypBinOpMono by auto
  ultimately show ?case using \<open>(left_ty, right_ty) \<in> targs\<close> \<open>binop_type bop = Some (targs, ret_ty)\<close> binop_type_correct
    using TypBinOpMono.hyps(2)
    by fastforce
next
  case (TypBinopPoly bop \<Delta> e1 ty1 e2 ty2 ty_inst)
  from this obtain v1 v2 where
     E:"binop_eval_val bop v1 v2 = Some v" by auto
  thus ?case using  \<open>binop_poly_type bop\<close> binop_poly_type_correct by fastforce
next
  case (TypFunExp f n_ty_params args_ty ret_ty ty_params args \<Delta>)
  from this obtain vargs fi where
     RedArgs:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>args, n_s\<rangle> [\<Down>] vargs" and Mem\<Gamma>:"\<Gamma> f = Some fi" and
    "fi (map (instantiate \<Omega>) ty_params) vargs = Some v"
    by auto
  with TypFunExp have FunSingleWf:"fun_interp_single_wf A (n_ty_params, args_ty, ret_ty) fi"
    using fun_interp_wf_def by (metis (mono_tags, lifting) option.inject)
  have A1:"length (map (instantiate \<Omega>) ty_params) = n_ty_params" using TypFunExp
    using length_map by simp
  have Wf_args_ty:"list_all (wf_ty n_ty_params) args_ty" using Wf_F \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close>
    by (meson map_of_list_all wf_fdecl.simps)
  have Wf_ret_ty:"wf_ty n_ty_params ret_ty" using Wf_F \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close>
    by (meson map_of_list_all wf_fdecl.simps)
  have A3:"length vargs = length args_ty"
    using RedArgs TypFunExp.hyps(2) red_exprs_length by fastforce
  have A4:"list_all closed (map (instantiate \<Omega>) ty_params)"
    using TypFunExp.prems(1) TypFunExp.prems(3) closed_instantiate wf_ty.simps(3) by fastforce
  have "list_all (wf_expr (length \<Omega>)) args" using TypFunExp by simp
  have InstMSubst:"(map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty)) = map (instantiate (map (instantiate \<Omega>) ty_params)) args_ty"
    using Wf_args_ty \<open>length ty_params = n_ty_params\<close>
    apply simp
    apply rule
    apply (rule instantiate_msubst_opt)
    by (simp add: list.pred_set)
  have
   "map (type_of_val A) vargs = (map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty))"
    using RedArgs TypFunExp \<open>list_all (wf_expr (length \<Omega>)) args\<close>
    using Wf_F by blast
  hence "type_of_val A v = instantiate (map (instantiate \<Omega>) ty_params) ret_ty"
    apply (simp only: InstMSubst)
    using FunSingleWf A1 A3 A4
    apply auto
    by (metis (no_types, lifting) A1 \<open>fi (map (instantiate \<Omega>) ty_params) vargs = Some v\<close> option.inject)
  thus ?case using TypFunExp.IH(1)
    by (simp add: TypFunExp.hyps(1) Wf_ret_ty instantiate_msubst_opt)
next
  case (TypCondExp \<Delta> cond thn ty els)
  thus ?case by auto
next
  case (TypOld \<Delta> e ty)
  from TypOld have RedE:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, n_s\<lparr>global_state := old_global_state n_s \<rparr>\<rangle> \<Down> v" by auto
  show ?case
    apply (rule TypOld.IH(2))
    using TypOld.prems apply simp
          apply (rule RedE)
    using TypOld.prems by auto
next
  case (TypForall \<Delta> ty e)
  then show ?case by (auto dest: forall_red)
next
case (TypExists \<Delta> ty e)
  then show ?case by (auto dest: exists_red)
next
  case (TypForallT \<Delta> e)
  then show ?case using msubst_ty_forallT by (auto dest: forallt_red_bool)
next
  case (TypExistsT \<Delta> e)
  then show ?case using msubst_ty_existsT by (auto dest: existst_red_bool)
next
  case (TypListNil \<Delta>)
  then show ?case by auto
next
  case (TypListCons \<Delta> e ty es tys)
  from \<open>A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>(e # es),n_s\<rangle> [\<Down>] vs\<close> have A0:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> hd vs"
    using cons_exp_elim by blast
  moreover from \<open>A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>(e # es),n_s\<rangle> [\<Down>] vs\<close> have "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es, n_s\<rangle> [\<Down>] tl vs"
   using cons_exp_elim by blast
  with A0 TypListCons have A1:"type_of_val A (hd vs) = instantiate \<Omega> ty" and
                        A2:"map (type_of_val A) (tl vs) = map (instantiate \<Omega>) tys" by auto
  moreover have "(hd vs) # (tl vs) = vs" using \<open>A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>(e # es),n_s\<rangle> [\<Down>] vs\<close>
      using cons_exp_elim list.collapse by blast
  ultimately show ?case
    by (metis list.simps(9))
qed

lemma instantiate_shift: "wf_ty (length \<Omega>) \<tau> \<Longrightarrow> instantiate (t#\<Omega>) (shiftT 1 0 \<tau>) = instantiate \<Omega> \<tau>"
  by (induction \<tau>) (auto simp add: list_all_iff)

lemma instantiate_shift_wf: "wf_ty (length \<Omega>) \<tau> \<Longrightarrow> wf_ty (Suc (length \<Omega>)) (shiftT 1 0 \<tau>)"
  by (induction \<tau>) (auto simp add: list_all_iff)

lemma lookup_only_local_global:
  assumes "local_state ns = local_state ns'" and
          "global_state ns = global_state ns'"
  shows "lookup_var \<Lambda> ns x = lookup_var \<Lambda> ns' x"
  using assms
  by (metis lookup_var_def)

(* TODO: find a better solution *)
lemma helper_lemma_old_state:
  assumes "\<forall>k \<tau>. M k = Some \<tau> \<longrightarrow> (\<exists>v. lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>)"
  shows "  \<forall>k \<tau>. M k = Some \<tau> \<longrightarrow>
                (\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>)"
proof (rule allI, rule allI, rule impI)
  fix k \<tau>
  assume "M k = Some \<tau>"
  from this obtain v where Lookup:"lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v" and Typ:"type_of_val A v = instantiate \<Omega> \<tau>" using assms
    by auto
  have Aux1:"old_global_state (full_ext_env n_s w) = old_global_state n_s"
    by simp
  have Aux2:"\<And>n_s gs. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := gs\<rparr>) k = lookup_var \<Lambda> (n_s\<lparr>global_state := gs\<rparr>) k"
    apply (rule lookup_only_local_global)
     apply simp
    apply simp
    done
  show "(\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>)"
    apply (rule exI[where ?x=v])
    apply (rule conjI)
     apply (simp only: Aux1)
     apply (simp add: Aux2 del: full_ext_env.simps)
     apply (rule Lookup)
    apply (rule Typ)
    done
qed

text \<open>Type progress theorem\<close>

theorem progress:
  assumes
          Closed_\<Omega>:"list_all closed \<Omega>" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> wf_ty (length \<Omega>) \<tau>'" and
          "\<forall> i \<tau>'. ((snd \<Delta>) i = Some \<tau>') \<longrightarrow> wf_ty (length \<Omega>) \<tau>'" and
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> n_s k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
          "\<forall> k \<tau>'. ((fst \<Delta>) k = Some \<tau>') \<longrightarrow> (\<exists>v. (lookup_var \<Lambda> (n_s\<lparr>global_state := old_global_state n_s\<rparr>) k = Some v) \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          "\<forall> i \<tau>'. ((snd \<Delta>) i = Some \<tau>') \<longrightarrow> (\<exists>v. binder_state n_s i = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')" and
          Wf_\<Gamma>:"fun_interp_wf A F \<Gamma>" and
          Wf_F:"list_all (wf_fdecl \<circ> snd) F"
  shows "F, \<Delta> \<turnstile> e : \<tau> \<Longrightarrow> wf_expr (length \<Omega>) e \<Longrightarrow>  \<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v" and
        "F, \<Delta> \<turnstile> es [:] ts \<Longrightarrow> list_all (wf_expr (length \<Omega>)) es \<Longrightarrow>  \<exists>vs. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es,n_s\<rangle> [\<Down>] vs"
  using assms
proof (induction arbitrary: n_s \<Lambda> \<Omega> and n_s \<Lambda> \<Omega> rule: typing_typing_list.inducts)
case (TypVar \<Delta> x ty)
  show ?case
    apply (rule exI[where ?x="the (lookup_var \<Lambda> n_s x)"])
    using TypVar(2)
    by (metis RedVar TypVar.hyps TypVar.prems(5) option.distinct(1) option.exhaust_sel)
next
case (TypBVar \<Delta> x ty)
  show ?case
    apply (rule exI[where ?x="the (binder_state n_s x)"])
    using TypBVar(2)
    by (metis RedBVar TypBVar.hyps TypBVar.prems(7) option.distinct(1) option.exhaust_sel)
next
  case (TypPrim l prim_ty \<Delta>)
  then show ?case by (auto intro: RedLit)
next
  case (TypUnOp \<Delta> e arg_ty uop ret_ty)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> a"
     apply (rule TypUnOp.IH) using TypUnOp.prems by auto
  from this obtain v' where RedE:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v'" by auto
  hence "type_of_val A v' = TPrim arg_ty"
    using TypUnOp preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypUnOp.prems(5) TypUnOp.prems(6) TypUnOp.prems(7) Wf_\<Gamma> Wf_F]
    by fastforce
  thus ?case using \<open>unop_type uop arg_ty = Some ret_ty\<close> unop_progress RedE RedUnOp
    by (metis (full_types))
next
  case (TypBinOpMono bop targs ret_ty \<Delta> e1 left_ty e2 right_ty)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> a"
    apply (rule TypBinOpMono.IH) using TypBinOpMono.prems by auto
  moreover have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> a"
    apply (rule TypBinOpMono.IH) using TypBinOpMono.prems by auto
  ultimately  obtain v1 v2 where RedLeft:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> v1" and  RedRight:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> v2"
    by auto
  moreover from RedLeft have "type_of_val A v1 = TPrim left_ty"
    using TypBinOpMono.IH TypBinOpMono.prems preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypBinOpMono.prems(5) TypBinOpMono.prems(6) TypBinOpMono.prems(7) Wf_\<Gamma> Wf_F]
    by fastforce
  moreover from RedRight have "type_of_val A v2 = TPrim right_ty"
    using TypBinOpMono.IH TypBinOpMono.prems preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypBinOpMono.prems(5) TypBinOpMono.prems(6) TypBinOpMono.prems(7) Wf_\<Gamma> Wf_F]
    by fastforce
  ultimately show ?case using \<open>binop_type bop = Some (targs, ret_ty)\<close> \<open>(left_ty, right_ty) \<in> targs\<close> binop_progress RedBinOp
    by metis
next
  case (TypBinopPoly bop \<Delta> e1 ty1 e2 ty2 ty_inst)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> a"
    apply (rule TypBinopPoly.IH) using TypBinopPoly.prems by auto
  moreover have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> a"
    apply (rule TypBinopPoly.IH) using TypBinopPoly.prems by auto
  ultimately  obtain v1 v2 where RedLeft:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e1,n_s\<rangle> \<Down> v1" and  RedRight:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e2,n_s\<rangle> \<Down> v2"
    by auto
  show ?case
    apply (cases bop; rule exI; rule RedBinOp[OF RedLeft RedRight])
    using \<open>binop_poly_type bop\<close> by auto
next
  case (TypFunExp f n_ty_params args_ty ret_ty ty_params args \<Delta>)
  have "\<exists>vargs. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>args, n_s\<rangle> [\<Down>] vargs"
    apply (rule TypFunExp.IH)
    using TypFunExp.prems by auto
  from this obtain vargs where
     RedArgs:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>args, n_s\<rangle> [\<Down>] vargs" by fastforce
  have Wf_args_ty:"list_all (wf_ty n_ty_params) args_ty" using Wf_F \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close>
    by (meson map_of_list_all wf_fdecl.simps)
  have InstMSubst:"(map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty)) = map (instantiate (map (instantiate \<Omega>) ty_params)) args_ty"
    using Wf_args_ty \<open>length ty_params = n_ty_params\<close>
    apply simp
    apply rule
    apply (rule instantiate_msubst_opt)
    by (simp add: list.pred_set)
  from \<open>map_of F f = Some (n_ty_params, args_ty, ret_ty)\<close> Wf_\<Gamma> obtain fi where
       Mem: "\<Gamma> f = Some fi" and
       FunSingleWf:"fun_interp_single_wf A (n_ty_params, args_ty, ret_ty) fi"
    using fun_interp_wf_def by blast
  from RedArgs have
    "map (type_of_val A) vargs = map (instantiate \<Omega>) (map (msubstT_opt ty_params) args_ty)"
    using preservation(2)[OF \<open>list_all closed \<Omega>\<close> TypFunExp.prems(5) TypFunExp.prems(6) TypFunExp.prems(7) Wf_\<Gamma> Wf_F] TypFunExp.prems TypFunExp.IH
    by auto
  hence "map (type_of_val A) vargs = map (instantiate (map (instantiate \<Omega>) ty_params)) args_ty"
    by (simp only: InstMSubst)
  moreover from \<open>length args = length args_ty\<close> and RedArgs have "length vargs = length args_ty"
    using red_exprs_length by fastforce
  moreover have "list_all closed (map (instantiate \<Omega>) ty_params)"
    using TypFunExp.prems(1) \<open>list_all closed \<Omega>\<close> closed_instantiate wf_ty.simps(3) by fastforce
  ultimately have "\<exists>v. fi (map (instantiate \<Omega>) ty_params) vargs = Some v" using FunSingleWf \<open>length ty_params = n_ty_params\<close>
    fun_interp_single_wf.simps length_map by blast
  with RedArgs show ?case by (metis Mem RedFunOp)
next
  case (TypCondExp \<Delta> cond thn ty els)
  hence RedCond: "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>cond,n_s\<rangle> \<Down> v" and
        RedThn: "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>thn,n_s\<rangle> \<Down> v" and
        RedElse: "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>els,n_s\<rangle> \<Down> v"
    by auto

  moreover from RedCond obtain b where
       "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>cond,n_s\<rangle> \<Down> BoolV b"
    using preservation(1)[OF \<open>list_all closed \<Omega>\<close> TypCondExp.prems(5) TypCondExp.prems(6) TypCondExp.prems(7)
                             Wf_\<Gamma> Wf_F \<open>F,\<Delta> \<turnstile> cond : TPrim TBool\<close>]
          \<open>wf_expr _ _\<close>
    by (metis instantiate.simps(2) type_of_val_bool_elim wf_expr.simps(7))

  ultimately show ?case
    by (metis (full_types) RedCondExpFalse RedCondExpTrue)
next
  case (TypOld \<Delta> e ty)
  have "\<exists>a. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<lparr>global_state := old_global_state n_s\<rparr>\<rangle> \<Down> a"
    apply (rule TypOld.IH)
    using TypOld.prems by auto
  thus ?case
    by (auto intro: RedOld)
next
  case (TypForall \<Delta> ty e)
  have lookup_ext_1: "\<And>ns w. (old_global_state (full_ext_env ns w)) = old_global_state ns"
    by simp
  thm TypForall.IH(2)
  let ?ns'f = "\<lambda>w. full_ext_env n_s w"

  have lookup_aux:"\<And> b x. lookup_var \<Lambda> (n_s\<lparr> binder_state := b \<rparr>) x  = lookup_var \<Lambda> n_s x"  by (simp only: lookup_var_binder_upd)

  have AuxOld:"\<And>w. \<forall>k \<tau>'. fst (fst \<Delta>, ext_env (snd \<Delta>) ty) k = Some \<tau>' \<longrightarrow>
           (\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    apply (rule helper_lemma_old_state)
    using TypForall.prems(6) apply simp
    done
  have RedBody:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<exists>v'. A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, ?ns'f w\<rangle> \<Down> v'"
    apply (rule TypForall.IH(2)[OF _ _ _ _ _ AuxOld])
    using TypForall.prems lookup_aux by auto

  have EnvCorres:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<forall>k \<tau>'. (snd (fst \<Delta>, ext_env (snd \<Delta>) ty)) k = Some \<tau>' \<longrightarrow>
                (\<exists>v. binder_state (full_ext_env n_s w) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    using TypForall.prems(7)
    by simp
  have RedBodyTy:"\<And>w v'. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> v' \<Longrightarrow>
        type_of_val A v' = TPrim TBool"
    using preservation(1)[OF \<open>list_all closed \<Omega>\<close> _ AuxOld EnvCorres Wf_\<Gamma> Wf_F _ _ ]
          TypForall.IH(1) TypForall.prems
    by (metis fst_conv instantiate.simps(2) lookup_full_ext_env_same wf_expr.simps(9))
  show ?case
  proof (cases "\<forall> w. type_of_val A w = instantiate \<Omega> ty \<longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool True)")
    case True
    show ?thesis
      using RedForAllTrue True by blast
  next
    case False
    from this obtain w where
       "type_of_val A w = instantiate \<Omega> ty" and "\<not> (A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool True))"
      by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim (TBool)"
    by fastforce
    ultimately show ?thesis
      by (metis (full_types) RedForAllFalse type_of_val_bool_elim)
  qed
next
  case (TypExists \<Delta> ty e)
  (*  proof is almost identical to TypForall, TODO: re-use proof *)
  have lookup_aux:"\<And> b x. lookup_var \<Lambda> (n_s\<lparr> binder_state := b \<rparr>) x  = lookup_var \<Lambda> n_s x"  by (simp only: lookup_var_binder_upd)
    have AuxOld:"\<And>w. \<forall>k \<tau>'. fst (fst \<Delta>, ext_env (snd \<Delta>) ty) k = Some \<tau>' \<longrightarrow>
           (\<exists>v. lookup_var \<Lambda> ((full_ext_env n_s w)\<lparr>global_state := old_global_state (full_ext_env n_s w)\<rparr>) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    apply (rule helper_lemma_old_state)
    using TypExists.prems(6) apply simp
    done
  have RedBody:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<exists>v'. A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> v'"
    apply (rule TypExists.IH(2)[OF _ _ _ _ _ AuxOld])
    using TypExists.prems lookup_aux by auto
  have EnvCorres:"\<And>w. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> \<forall>k \<tau>'. (snd (fst \<Delta>, ext_env (snd \<Delta>) ty)) k = Some \<tau>' \<longrightarrow>
                (\<exists>v. binder_state (full_ext_env n_s w) k = Some v \<and> type_of_val A v = instantiate \<Omega> \<tau>')"
    using TypExists.prems(7)
    by simp
  have RedBodyTy:"\<And>w v'. type_of_val A w = instantiate \<Omega> ty \<Longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> v' \<Longrightarrow>
        type_of_val A v' = TPrim TBool"
    using preservation(1)[OF \<open>list_all closed \<Omega>\<close> _ AuxOld EnvCorres Wf_\<Gamma> Wf_F]
          TypExists.IH(1) TypExists.prems
    by (metis fst_conv instantiate.simps(2) lookup_full_ext_env_same wf_expr.simps(10))
  show ?case
  proof (cases "\<forall> w. type_of_val A w = instantiate \<Omega> ty \<longrightarrow> A, \<Lambda>, \<Gamma>, \<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool False)")
    case True
    show ?thesis
      using RedExistsFalse True by blast
  next
    case False
    from this obtain w where
       "type_of_val A w = instantiate \<Omega> ty" and "\<not> (A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> LitV (LBool False))"
      by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, full_ext_env n_s w\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim (TBool)"
    by fastforce
    ultimately show ?thesis
      by (metis (full_types) RedExistsTrue type_of_val_bool_elim)
  qed
next
  case (TypForallT \<Delta> e)
  have RedBody:"\<And>t. closed t \<Longrightarrow> (\<exists>v. A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v)"
    apply (rule TypForallT.IH)
    using TypForallT.prems apply simp_all
    using instantiate_shift_wf apply fastforce
    using instantiate_shift_wf apply fastforce
    using instantiate_shift apply auto
    done

  have Closed\<Omega>Ext: "\<And>t. closed t \<Longrightarrow> list_all closed (t#\<Omega>)"
    using \<open>list_all closed \<Omega>\<close> by simp

  have RedBodyTy:"\<And>t v. closed t \<Longrightarrow> A,\<Lambda>,\<Gamma>, t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v \<Longrightarrow> type_of_val A v = instantiate (t#\<Omega>) (TPrim TBool)"
    apply (rule preservation(1)[where ?\<Delta>="(shift_env 1 0 (fst \<Delta>), shift_env 1 0 (snd \<Delta>))" and ?n_s="n_s"])
          apply (simp add: \<open>list_all closed \<Omega>\<close>)
    using TypForallT.prems instantiate_shift
          apply fastforce
    using TypForallT.prems instantiate_shift
          apply fastforce
    using TypForallT.prems instantiate_shift
         apply fastforce
        apply (rule Wf_\<Gamma>)
        apply (rule Wf_F)
      apply (rule TypForallT.IH(1))
    using TypForallT.prems apply simp_all
   done
  show ?case
  proof (cases "\<forall>t. closed t \<longrightarrow> A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool True)")
    case True
    show ?thesis
      using RedForallT_True True by blast
  next
    case False
    from this obtain t where "closed t" and "\<not>(A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool True))" by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,(t#\<Omega>) \<turnstile> \<langle>e, n_s\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim (TBool)" by fastforce
    ultimately show ?thesis
      by (metis (full_types) RedForallT_False type_of_val_bool_elim)
  qed
next
  case (TypExistsT \<Delta> e)
  (* proof is almost identical to TypForallT, TODO: re-use proof *)

  have RedBody:"\<And>t. closed t \<Longrightarrow> (\<exists>v. A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v)"
    apply (rule TypExistsT.IH)
    using TypExistsT.prems
    apply simp_all
    using instantiate_shift_wf apply fastforce
    using instantiate_shift_wf apply fastforce
    using instantiate_shift by auto

  have Closed\<Omega>Ext: "\<And>t. closed t \<Longrightarrow> list_all closed (t#\<Omega>)"
    using \<open>list_all closed \<Omega>\<close> by simp

  have RedBodyTy:"\<And>t v. closed t \<Longrightarrow> A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v \<Longrightarrow> type_of_val A v = instantiate (t#\<Omega>) (TPrim TBool)"
    apply (rule preservation(1)[where ?\<Delta>="(shift_env 1 0 (fst \<Delta>), shift_env 1 0 (snd \<Delta>))" and ?n_s="n_s"])
          apply (simp add: \<open>list_all closed \<Omega>\<close>)
    using TypExistsT.prems instantiate_shift
          apply fastforce
    using TypExistsT.prems instantiate_shift
          apply fastforce
    using TypExistsT.prems instantiate_shift
         apply fastforce
        apply (rule Wf_\<Gamma>)
        apply (rule Wf_F)
      apply (rule TypExistsT.IH(1))
    using TypExistsT.prems apply simp_all
    done
  show ?case
  proof (cases "\<forall>t. closed t \<longrightarrow> A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool False)")
    case True
    show ?thesis
      using RedExistsT_False True by blast
  next
    case False
    from this obtain t where "closed t" and "\<not>(A,\<Lambda>,\<Gamma>,t#\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> LitV (LBool False))" by auto
    moreover from this RedBody RedBodyTy obtain w' where "A,\<Lambda>,\<Gamma>,(t#\<Omega>) \<turnstile> \<langle>e, n_s\<rangle> \<Down> w'"
      and "type_of_val A w' = TPrim TBool" by fastforce
    ultimately show ?thesis
     by (metis (full_types) RedExistsT_True type_of_val_bool_elim)
  qed
next
  case (TypListNil \<Delta>)
  show ?case
    by (auto intro: RedExpListNil)
next
  case (TypListCons \<Delta> e ty es tys)
  hence "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v" and "\<exists>vs. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es,n_s\<rangle> [\<Down>] vs"
    by auto
  from this obtain v vargs where
      "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e, n_s\<rangle> \<Down> v" and "A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>es, n_s\<rangle> [\<Down>] vargs" by auto
  thus ?case by (auto intro: RedExpListCons)
qed

text \<open>We combine type preservation and type progress to get a top-level type safety theorem\<close>

corollary type_safety_top_level:
  assumes "F, (lookup_var_ty \<Lambda>, Map.empty) \<turnstile> e : \<tau>" and
          ClosedEnv:"list_all closed \<Omega>" and
          Wf_\<Gamma>:"fun_interp_wf A F \<Gamma>" and
          Wf_\<Lambda>: "\<forall>x \<tau>. lookup_var_ty \<Lambda> x = Some \<tau> \<longrightarrow> wf_ty (length \<Omega>) \<tau>" and
          Wf_F:"list_all (wf_fdecl \<circ> snd) F" and
          State_wt:"state_well_typed A \<Lambda> \<Omega> n_s" and
          "wf_expr (length \<Omega>) e"
        shows "\<exists>v. (A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v) \<and> type_of_val A v = instantiate \<Omega> \<tau>"
proof -
  let ?\<Delta> = "(lookup_var_ty \<Lambda>, Map.empty)"
  have "\<exists>v. A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v"
    apply (rule progress[where ?\<Delta>="(lookup_var_ty \<Lambda>, Map.empty)"])
             apply (rule ClosedEnv)
    using Wf_\<Lambda> apply simp
           apply simp
    using state_well_typed_lookup[OF State_wt]
          apply simp
    using state_well_typed_lookup_old[OF State_wt]
         apply simp
        apply simp
    using assms
    by auto
  from this obtain v where RedE:"A,\<Lambda>,\<Gamma>,\<Omega> \<turnstile> \<langle>e,n_s\<rangle> \<Down> v"
    by auto
  moreover have "type_of_val A v = instantiate \<Omega> \<tau>"
    apply (rule preservation[where ?\<Delta>="(lookup_var_ty \<Lambda>, Map.empty)"])
    apply (rule ClosedEnv)
    using state_well_typed_lookup[OF State_wt]
    apply fastforce
    using state_well_typed_lookup_old[OF State_wt]
    apply fastforce
    using assms RedE by auto
  ultimately show ?thesis
    by auto
qed

end


section \<open>Two approaches that failed \label{sec:two-approaches-that}\<close>

(*<*) theory Failure imports RealRandVar begin (*>*)

text\<open>
Defining Lebesgue integration can be quite involved, judging by the
process in \ref{sec:stepwise-approach} that imitates Bauer's way
\<^cite>\<open>"Bauer"\<close>.  So it is quite tempting to try cutting a corner. The
following two alternative approaches back up my experience that this
almost never pays in formalization. The theory that seems most complex
at first sight is often the one that is closest to formal reasoning
and deliberately avoids ``hand-waving''.
\<close>

subsection \<open>A closed expression \label{sec:closed-expression}\<close>

text \<open>
  In contrast, Billingsley's definition \<^cite>\<open>\<open>p.~172\<close> in "Billingsley86"\<close> is
  strikingly short. For nonnegative measurable functions $f$:

  \begin{quote}

  $\int f d\mu = \mathit{sup} \sum_i \big[ \mathit{inf}_{\omega \in A_i} f(w) \big] \mu(A_i).$

  The supremum here extends over all finite decompositions $\{A_i\}$ of
  $\Omega$ into $\mathcal{F}$-sets.\footnote{The $\mathcal{F}$-sets are just the measurable sets of a measure
  space.}

  \end{quote}

  Like the definition, the proofs of the essential properties are also
  rather
  short, about three pages in the textbook for almost all the theorems
  in \ref{sec:stepwise-approach}; and a proof of uniqueness is obsolete
  for a closed expression like this. Therefore, I found this approach
  quite tempting. It turns out, however, that it is unfortunately not
  well suited for formalization, at least with the background we use.

  A complication shared by all possible styles of definition is the lack
  of infinite values in our theory, combined with the lack of partial
  functions in HOL. Like the sum operator in
  \ref{sec:measure-spaces}, the integral has to be defined
  indirectly. The classical way to do this employs predicates, invoking \<open>\<epsilon>\<close>
  to choose the value that satisfies the condition:

  \<open>\<integral> f dM \<equiv> (\<epsilon> i. is_integral M f i)\<close>

  To sensibly apply this principle, the predicate has to be \<open>\<epsilon>\<close>-free to supply the information if the integral is
  defined or not. Now the above definition contains up to three additional
  \<open>\<epsilon>\<close> when formalized naively in HOL, namely in the supremum,
  infimum and sum operators. The sum is over a finite set, so it can
  be replaced by a total function. For nonnegative functions, the
  infimum can also be shown to exist everywhere, but, like the
  supremum,  must
  itself be replaced by a predicate.

  Also note that predicates require a proof of uniqueness, thus losing
  the prime advantage of a closed formula anyway. In this case,
  uniqueness can be reduced to uniqueness of the supremum/infimum. The
  problem is that neither suprema nor infima come predefined in
  Isabelle/Isar as of yet. It is an easy task to make up for this ---
  and I did --- but a much harder one to establish all the properties
  needed for reasoning with the defined entities.

  A lot of such reasoning is necessary to deduce from the above definition
  (or a formal version of it, as just outlined) the basic behavior of
  integration, which includes additivity, monotonicity and especially the
  integral of simple functions. It turns out that the brevity of the
  proofs in the textbook stems from a severely informal style that
  assumes ample background knowledge. Formalizing all this knowledge
  started to become overwhelming when the idea of a contrarian approach
  emerged.
\<close>

subsection \<open>A one-step inductive definition \label{sec:one-step}\<close>

text \<open>
  This idea was sparked by the following note: ``(\ldots) the integral
  is uniquely determined by certain simple properties it is natural to
  require of it'' \<^cite>\<open>\<open>p.~175\<close> in "Billingsley86"\<close>. Billingsley goes on
  discussing exactly those properties that are so hard to derive
  from his definition. So why not simply define integration using
  these properties? That is the gist of an inductive set definition, like
  the one we have seen in \ref{sec:sigma}. This time a functional operator is
  to be defined, but it can be represented as a set of pairs, where
  the first component is the function and the second its integral.
  To cut a long story short, here is the definition.\<close>

inductive_set
  integral_set:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> (('a \<Rightarrow> real) * real) set"
  for M :: "'a set set * ('a set \<Rightarrow> real)"
  where
    char: "\<lbrakk>f = \<chi> A; A \<in> measurable_sets M\<rbrakk> \<Longrightarrow> (f,measure M A) \<in> integral_set M"
  | add: "\<lbrakk>f = (\<lambda>w. g w + h w); (g,x) \<in> integral_set M; (h,y) \<in> integral_set M\<rbrakk>
    \<Longrightarrow> (f,(x + y)) \<in> integral_set M"
  | times: "\<lbrakk>f = (\<lambda>w. a*g w); (g,x) \<in> integral_set M\<rbrakk> \<Longrightarrow> (f,a*x) \<in> integral_set M"
  | mon_conv: "\<lbrakk>u\<up>f; \<And>n. (u n, x n) \<in> integral_set M; x\<up>y\<rbrakk>
    \<Longrightarrow> (f,y) \<in> integral_set M"

  text \<open>The technique is also encountered in the \<open>Finite_Set\<close> theory from the Isabelle library. It is used there
    to define the \<open>sum\<close> function, which calculates a sum
    indexed over a finite set and is employed in
    \ref{sec:stepwise-approach}. The definition here is much more
    intricate though.

    An obvious advantage of this approach is that almost all
    important properties are gained without effort. The
    introduction rule \<open>mon_conv\<close> corresponds to what is known as
    the Monotone Convergence Theorem in scientific literature; negative functions are also provided for via
    the \<open>times\<close> rule.
    To be precise,
    there is exactly one important theorem missing ---
    uniqueness. That is, every function appears in at most one pair.

    From uniqueness together with the introduction rules, all the
    other statements about integration, monotonicity for example,
    could be derived. On the other hand, monotonicity implies
    uniqueness. Much to my regret, none of these two could be proven.
    The proof would basically amount to a double induction to show
    that an integral gained via one rule is the same when derived by
    another. A lot of effort was spent trying to strengthen the
    induction hypothesis or reduce the goal to a simpler case. All of
    this was in vain though, and it seems that the hypothesis would
    have to be strengthened as far as to include the concept of
    integration in the first place, which in a way defeats the
    advantages of the approach.\<close>

  (*<*)end  (*>*)


(* @SUITE modules *)

theory "moduletype"
imports "../Modules"
begin

declare[[show_types,show_sorts]]
moduletype MT1 where
  f1 :: "(int*unit,string) procedure"
and f2 :: "(bool*unit,real) procedure"

print_theorems

(* Checking constants *)
term "MT1::module_type"
term "MT1.f1 :: module \<Rightarrow> (int*unit,string) procedure"
term "MT1.f2 :: module \<Rightarrow> (bool*unit,real) procedure"

(* Checking lemmas *)
lemma "has_module_type (M\<Colon>module) MT1 \<Longrightarrow>
    get_proc_in_module M [''f1''] =
    Some (mk_procedure_untyped (MT1.f1 M))"
    by (rule MT1.f1)

lemma "has_module_type (M\<Colon>module) MT1 \<Longrightarrow>
    get_proc_in_module M [''f2''] =
    Some (mk_procedure_untyped (MT1.f2 M))"
    by (rule MT1.f2)

moduletype MT2(M1:MT1) where
  g1 :: "(int*unit,string) procedure"
and g2 :: "(bool*unit,real) procedure"

print_theorems

term "MT2::module_type"
(* TODO: getters *)

(* TODO: check getter lemmas *)

end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Bisim_Pres
  imports Weak_Bisimulation Weak_Sim_Pres Weak_Stat_Imp_Pres
begin

context env begin

lemma weakBisimInputPres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<And>Tvec. length xvec = length Tvec \<Longrightarrow> \<Psi> \<rhd> P[xvec::=Tvec] \<approx> Q[xvec::=Tvec]"

  shows "\<Psi> \<rhd> M\<lparr>\<lambda>*xvec N\<rparr>.P \<approx> M\<lparr>\<lambda>*xvec N\<rparr>.Q"
proof -
  let ?X = "{(\<Psi>, M\<lparr>\<lambda>*xvec N\<rparr>.P, M\<lparr>\<lambda>*xvec N\<rparr>.Q) | \<Psi> M xvec N P Q. \<forall>Tvec. length xvec = length Tvec \<longrightarrow> \<Psi> \<rhd> P[xvec::=Tvec] \<approx> Q[xvec::=Tvec]}"

  from assms have "(\<Psi>, M\<lparr>\<lambda>*xvec N\<rparr>.P, M\<lparr>\<lambda>*xvec N\<rparr>.Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case by(fastforce intro: weak_stat_impInputPres dest: weakBisimE(3))
  next
    case(cSim \<Psi> P Q)
    thus ?case
      by auto (blast intro: weak_inputPres dest: weakBisimE)
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimOutputPres:
  fixes \<Psi>    :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> M\<langle>N\<rangle>.P \<approx> M\<langle>N\<rangle>.Q"
proof -
  let ?X = "{(\<Psi>, M\<langle>N\<rangle>.P, M\<langle>N\<rangle>.Q) | \<Psi> M N P Q. \<Psi> \<rhd> P \<approx> Q}"

  from assms have "(\<Psi>, M\<langle>N\<rangle>.P, M\<langle>N\<rangle>.Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> P Q)
    thus ?case by auto (blast intro: weak_stat_impOutputPres dest: weakBisimE(3))
  next
    case(cSim \<Psi> P Q)
    thus ?case
      by(auto intro: weak_outputPres dest: weakBisimE)
  next
    case(cExt \<Psi> P Q \<Psi>')
    thus ?case by(blast dest: weakBisimE)
  next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<approx> \<lparr>\<nu>x\<rparr>Q"
proof -
  let ?X = "{(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) | \<Psi> x P Q. \<Psi> \<rhd> P \<approx> Q \<and> x \<sharp> \<Psi>}"

  from assms have "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> xP xQ)
    {
      fix \<Psi> P Q x
      assume "\<Psi> \<rhd> P \<approx> Q"
      hence "\<Psi> \<rhd> P \<lessapprox><weakBisim> Q" by(rule weakBisimE)
      moreover have "eqvt weakBisim" by auto
      moreover assume "(x::name) \<sharp> \<Psi>"
      moreover have "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> weakBisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
        by auto
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<lessapprox><(?X \<union> weakBisim)> \<lparr>\<nu>x\<rparr>Q"
        by(rule weak_stat_impResPres)
    }
    with `(\<Psi>, xP, xQ) \<in> ?X` show ?case by auto
  next
    case(cSim \<Psi> xP xQ)
    from `(\<Psi>, xP, xQ) \<in> ?X` obtain x P Q where "\<Psi> \<rhd> P \<approx> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<rhd> P \<leadsto><weakBisim> Q" by(rule weakBisimE)
    moreover have "eqvt ?X"
      by(force simp add: eqvt_def weakBisimClosed pt_fresh_bij[OF pt_name_inst, OF at_name_inst])
    hence "eqvt(?X \<union> weakBisim)" by auto
    moreover note `x \<sharp> \<Psi>`
    moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by auto
    moreover have "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> weakBisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
      by auto
    ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>x\<rparr>Q"
      by(rule weakResPres)
    with `xP = \<lparr>\<nu>x\<rparr>P` `xQ = \<lparr>\<nu>x\<rparr>Q` show ?case
      by simp
  next
    case(cExt \<Psi> xP xQ \<Psi>')
    from `(\<Psi>, xP, xQ) \<in> ?X` obtain x P Q where "\<Psi> \<rhd> P \<approx> Q" and "x \<sharp> \<Psi>" and "xP = \<lparr>\<nu>x\<rparr>P" and "xQ = \<lparr>\<nu>x\<rparr>Q"
      by auto
    obtain y::name where "y \<sharp> P" and "y \<sharp> Q" and "y \<sharp> \<Psi>" and "y \<sharp> \<Psi>'"
     by(generate_fresh "name", auto simp add: fresh_prod)
   from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<otimes> ([(x, y)] \<bullet> \<Psi>') \<rhd> P \<approx> Q"
     by(rule weakBisimE)
   hence "([(x, y)] \<bullet> (\<Psi> \<otimes> ([(x, y)] \<bullet> \<Psi>'))) \<rhd> ([(x, y)] \<bullet> P) \<approx> ([(x, y)] \<bullet> Q)"
     by(rule weakBisimClosed)
   with `x \<sharp> \<Psi>` `y \<sharp> \<Psi>` have "\<Psi> \<otimes> \<Psi>' \<rhd> ([(x, y)] \<bullet> P) \<approx> ([(x, y)] \<bullet> Q)"
     by(simp add: eqvts)
   with `y \<sharp> \<Psi>` `y \<sharp> \<Psi>'` have "(\<Psi> \<otimes> \<Psi>', \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P), \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> Q)) \<in> ?X"
     by auto
   moreover from `y \<sharp> P` `y \<sharp> Q` have "\<lparr>\<nu>x\<rparr>P = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> P)" and "\<lparr>\<nu>x\<rparr>Q = \<lparr>\<nu>y\<rparr>([(x, y)] \<bullet> Q)"
     by(simp add: alpha_res)+
   ultimately show ?case using `xP = \<lparr>\<nu>x\<rparr>P` `xQ = \<lparr>\<nu>x\<rparr>Q` by simp
 next
    case(cSym \<Psi> P Q)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimResChainPres:
  fixes \<Psi>   :: 'b
  and   P    :: "('a, 'b, 'c) psi"
  and   Q    :: "('a, 'b, 'c) psi"
  and   xvec :: "name list"

  assumes "\<Psi> \<rhd> P \<approx> Q"
  and     "xvec \<sharp>* \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>P \<approx> \<lparr>\<nu>*xvec\<rparr>Q"
using assms
by(induct xvec) (auto intro: weakBisimResPres)

lemma weakBisimParPresAux:
  fixes \<Psi>  :: 'b
  and   \<Psi>\<^sub>R :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   Q  :: "('a, 'b, 'c) psi"
  and   R  :: "('a, 'b, 'c) psi"
  and   A\<^sub>R :: "name list"

  assumes "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
  and     FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
  and     "A\<^sub>R \<sharp>* \<Psi>"
  and     "A\<^sub>R \<sharp>* P"
  and     "A\<^sub>R \<sharp>* Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?X = "{(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) | xvec \<Psi> P Q R. xvec \<sharp>* \<Psi> \<and> (\<forall>A\<^sub>R \<Psi>\<^sub>R. (extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q) \<longrightarrow>
                                                                                \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q)}"
  {
    fix xvec :: "name list"
    and \<Psi>    :: 'b
    and P    :: "('a, 'b, 'c) psi"
    and Q    :: "('a, 'b, 'c) psi"
    and R    :: "('a, 'b, 'c) psi"

    assume "xvec \<sharp>* \<Psi>"
    and    "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"

    hence "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X"
      by blast
  }
  note XI = this

  {
    fix xvec :: "name list"
    and \<Psi>    :: 'b
    and P    :: "('a, 'b, 'c) psi"
    and Q    :: "('a, 'b, 'c) psi"
    and R    :: "('a, 'b, 'c) psi"
    and C    :: "'d::fs_name"

    assume "xvec \<sharp>* \<Psi>"
    and    A: "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q; A\<^sub>R \<sharp>* C\<rbrakk> \<Longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"

    from `xvec \<sharp>* \<Psi>` have "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X"
    proof(rule XI)
      fix A\<^sub>R \<Psi>\<^sub>R
      assume FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
      obtain p::"name prm" where "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>R) \<sharp>* P" and "(p \<bullet> A\<^sub>R) \<sharp>* Q" and "(p \<bullet> A\<^sub>R) \<sharp>* R" and "(p \<bullet> A\<^sub>R) \<sharp>* C"
                             and "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<^sub>R" and S: "(set p) \<subseteq> (set A\<^sub>R) \<times> (set(p \<bullet> A\<^sub>R))" and "distinct_perm p"
        by(rule_tac c="(\<Psi>, P, Q, R, \<Psi>\<^sub>R, C)" in name_list_avoiding) auto
      from FrR `(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>\<^sub>R` S have "extract_frame R = \<langle>(p \<bullet> A\<^sub>R), p \<bullet> \<Psi>\<^sub>R\<rangle>" by(simp add: frame_chain_alpha')

      moreover assume "A\<^sub>R \<sharp>* \<Psi>"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> \<Psi>)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `A\<^sub>R \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>` S have "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" by simp
      moreover assume "A\<^sub>R \<sharp>* P"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> P)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `A\<^sub>R \<sharp>* P` `(p \<bullet> A\<^sub>R) \<sharp>* P` S have "(p \<bullet> A\<^sub>R) \<sharp>* P" by simp
      moreover assume "A\<^sub>R \<sharp>* Q"
      hence "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> Q)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R) \<sharp>* Q` S have "(p \<bullet> A\<^sub>R) \<sharp>* Q" by simp
      ultimately have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q" using `(p \<bullet> A\<^sub>R) \<sharp>* C` A by blast
      hence "(p \<bullet> (\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)" by(rule weakBisimClosed)
      with `A\<^sub>R \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* P` `(p \<bullet> A\<^sub>R) \<sharp>* P` `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R) \<sharp>* Q` S `distinct_perm p`
      show "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q" by(simp add: eqvts)
    qed
  }
  note XI' = this

  have "eqvt ?X"
    apply(auto simp add: eqvt_def)
    apply(rule_tac x="p \<bullet> xvec" in exI)
    apply(rule_tac x="p \<bullet> P" in exI)
    apply(rule_tac x="p \<bullet> Q" in exI)
    apply(rule_tac x="p \<bullet> R" in exI)
    apply(simp add: eqvts)
    apply(simp add: fresh_star_bij)
    apply(clarify)
    apply(erule_tac x="(rev p) \<bullet> A\<^sub>R" in allE)
    apply(erule_tac x="(rev p) \<bullet> \<Psi>\<^sub>R" in allE)
    apply(drule mp)
    apply(rule conjI)
    apply(rule_tac pi=p in pt_bij4[OF pt_name_inst, OF at_name_inst])
    apply(simp add: eqvts)
    defer
    apply(drule_tac p=p in weakBisimClosed)
    apply(simp add: eqvts)
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    apply simp
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    apply simp
    apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of p, THEN sym])
    by simp

  moreover have Res: "\<And>\<Psi> P Q x. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> weakBisim; x \<sharp> \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
  proof -
    fix \<Psi> P Q x
    assume "(\<Psi>, P, Q) \<in> ?X \<union> weakBisim" and "(x::name) \<sharp> \<Psi>"
    show "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X \<union> weakBisim"
    proof(case_tac "(\<Psi>, P, Q) \<in> ?X")
      assume "(\<Psi>, P, Q) \<in> ?X"
      with `x \<sharp> \<Psi>` have "(\<Psi>, \<lparr>\<nu>x\<rparr>P, \<lparr>\<nu>x\<rparr>Q) \<in> ?X"
        apply auto
        by(rule_tac x="x#xvec" in exI) auto
      thus ?thesis by simp
    next
      assume "\<not>(\<Psi>, P, Q) \<in> ?X"
      with `(\<Psi>, P, Q) \<in> ?X \<union> weakBisim` have "\<Psi> \<rhd> P \<approx> Q"
        by blast
      hence "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>P \<approx> \<lparr>\<nu>x\<rparr>Q" using `x \<sharp> \<Psi>`
        by(rule weakBisimResPres)
      thus ?thesis
        by simp
    qed
  qed

  {
    fix \<Psi>  :: 'b
      and P  :: "('a, 'b, 'c) psi"
      and Q  :: "('a, 'b, 'c) psi"
      and \<Psi>' :: 'b

    assume "\<Psi> \<rhd> P \<approx> Q"

    hence "\<Psi> \<rhd> Q \<approx> P" by(rule weakBisimE)
    then obtain P' P'' where PChain: "\<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'"
                         and QimpP': "insert_assertion(extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame P') \<Psi>"
                         and P'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> P' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P''"
                         and "\<Psi> \<otimes> \<Psi>' \<rhd> Q \<approx> P''" using weak_stat_imp_def
      by(blast dest: weakBisimE)
    note PChain QimpP' P'Chain
    moreover from `\<Psi> \<otimes> \<Psi>' \<rhd> Q \<approx> P''` have "\<Psi> \<otimes> \<Psi>' \<rhd> P'' \<approx> Q" by(rule weakBisimE)
    ultimately have "\<exists>P' P''. \<Psi> \<rhd> P \<Longrightarrow>\<^sup>^\<^sub>\<tau> P' \<and> insert_assertion(extract_frame Q) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame P') \<Psi> \<and>
                              \<Psi> \<otimes> \<Psi>' \<rhd> P' \<Longrightarrow>\<^sup>^\<^sub>\<tau> P'' \<and> \<Psi> \<otimes> \<Psi>' \<rhd> P'' \<approx> Q"
      by blast
  }
  moreover
  {
    fix \<Psi> P Q A\<^sub>R \<Psi>\<^sub>R R
    assume PSimQ: "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
       and FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
       and "A\<^sub>R \<sharp>* \<Psi>"
       and "A\<^sub>R \<sharp>* P"
       and "A\<^sub>R \<sharp>* Q"
    hence "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X"
    proof -
      have "P \<parallel> R = \<lparr>\<nu>*[]\<rparr>(P \<parallel> R)" by simp
      moreover have "Q \<parallel> R = \<lparr>\<nu>*[]\<rparr>(Q \<parallel> R)" by simp
      moreover have "([]::name list) \<sharp>* \<Psi>" by simp
      moreover
      {
        fix A\<^sub>R' \<Psi>\<^sub>R'

        assume FrR': "extract_frame R = \<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle>"
            and "A\<^sub>R' \<sharp>* \<Psi>"
            and "A\<^sub>R' \<sharp>* P"
            and "A\<^sub>R' \<sharp>* Q"
        obtain p where "(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* P"
                   and "(p \<bullet> A\<^sub>R') \<sharp>* Q"
                   and S: "(set p) \<subseteq> (set A\<^sub>R') \<times> (set(p \<bullet> A\<^sub>R'))" and "distinct_perm p"
          by(rule_tac c="(A\<^sub>R, \<Psi>, \<Psi>\<^sub>R', P, Q)" in name_list_avoiding) auto

        from `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'` S have "\<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle> = \<langle>p \<bullet> A\<^sub>R', p \<bullet> \<Psi>\<^sub>R'\<rangle>"
          by(simp add: frame_chain_alpha)

        with FrR' have FrR'': "extract_frame R = \<langle>p \<bullet> A\<^sub>R', p \<bullet> \<Psi>\<^sub>R'\<rangle>" by simp
        with FrR `(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R`
        obtain q where "p \<bullet> \<Psi>\<^sub>R' = (q::name prm) \<bullet> \<Psi>\<^sub>R" and S': "set q \<subseteq> (set A\<^sub>R) \<times> set(p \<bullet> A\<^sub>R')" and "distinct_perm q"
          apply auto
          apply(drule_tac sym) apply simp
          by(drule_tac frame_chain_eq) auto
        from PSimQ have "(q \<bullet> (\<Psi> \<otimes> \<Psi>\<^sub>R)) \<rhd> (q \<bullet> P) \<approx> (q \<bullet> Q)"
          by(rule weakBisimClosed)
        with `A\<^sub>R \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* P` `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* Q` S'
        have "\<Psi> \<otimes> (q \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q" by(simp add: eqvts)
        hence "(p \<bullet> (\<Psi> \<otimes> (q \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)" by(rule weakBisimClosed)
        with `A\<^sub>R' \<sharp>* \<Psi>` `A\<^sub>R' \<sharp>* P` `A\<^sub>R' \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* Q` S `distinct_perm p` `(p \<bullet> \<Psi>\<^sub>R') = q \<bullet> \<Psi>\<^sub>R`
        have "\<Psi> \<otimes> \<Psi>\<^sub>R' \<rhd> P \<approx> Q"
          by(drule_tac sym) (simp add: eqvts)
      }
      ultimately show ?thesis
        by blast
    qed
    hence "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X \<union> weakBisim"
      by simp
  }
  note C1 = this

  have C2: "\<And>\<Psi> P Q xvec. \<lbrakk>(\<Psi>, P, Q) \<in> ?X \<union> weakBisim; (xvec::name list) \<sharp>* \<Psi>\<rbrakk> \<Longrightarrow> (\<Psi>, \<lparr>\<nu>*xvec\<rparr>P, \<lparr>\<nu>*xvec\<rparr>Q) \<in> ?X \<union> weakBisim"
  proof -
    fix \<Psi> P Q xvec
    assume "(\<Psi>, P, Q) \<in> ?X \<union> weakBisim"
    assume "(xvec::name list) \<sharp>* \<Psi>"
    thus "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>P, \<lparr>\<nu>*xvec\<rparr>Q) \<in> ?X \<union> weakBisim"
    proof(induct xvec)
      case Nil
      thus ?case using `(\<Psi>, P, Q) \<in> ?X \<union> weakBisim` by simp
    next
      case(Cons x xvec)
      thus ?case by(simp only: res_chain.simps) (rule_tac Res, auto)
    qed
  qed

  {
    fix \<Psi> :: 'b
    and P :: "('a, 'b, 'c) psi"
    and Q :: "('a, 'b, 'c) psi"
    and R :: "('a, 'b, 'c) psi"
    and A\<^sub>R :: "name list"
    and \<Psi>\<^sub>R :: 'b

    assume "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
    and     FrR: "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>"
    and     "A\<^sub>R \<sharp>* \<Psi>"
    and     "A\<^sub>R \<sharp>* P"
    and     "A\<^sub>R \<sharp>* Q"

    have "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X"
    proof -
      {
        fix A\<^sub>R' :: "name list"
        and \<Psi>\<^sub>R' :: 'b

        assume FrR': "extract_frame R = \<langle>A\<^sub>R', \<Psi>\<^sub>R'\<rangle>"
        and    "A\<^sub>R' \<sharp>* \<Psi>"
        and    "A\<^sub>R' \<sharp>* P"
        and    "A\<^sub>R' \<sharp>* Q"

        obtain p where "(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R" and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>\<^sub>R'" and "(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>" and "(p \<bullet> A\<^sub>R') \<sharp>* P" and "(p \<bullet> A\<^sub>R') \<sharp>* Q"
                   and Sp: "(set p) \<subseteq> (set A\<^sub>R') \<times> (set(p \<bullet> A\<^sub>R'))" and "distinct_perm p"
          by(rule_tac c="(A\<^sub>R, \<Psi>, \<Psi>\<^sub>R', P, Q)" in name_list_avoiding) auto

        from FrR' `(p \<bullet> A\<^sub>R') \<sharp>*  \<Psi>\<^sub>R'` Sp have "extract_frame R = \<langle>(p \<bullet> A\<^sub>R'), p \<bullet> \<Psi>\<^sub>R'\<rangle>"
          by(simp add: frame_chain_alpha eqvts)
        with FrR `(p \<bullet> A\<^sub>R') \<sharp>* A\<^sub>R` obtain q::"name prm"
          where Sq: "set q \<subseteq> set(p \<bullet> A\<^sub>R') \<times> set A\<^sub>R" and "distinct_perm q" and "\<Psi>\<^sub>R = q \<bullet> p \<bullet> \<Psi>\<^sub>R'"
          by(force elim: frame_chain_eq)

        from `\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q` `\<Psi>\<^sub>R = q \<bullet> p \<bullet> \<Psi>\<^sub>R'` have "\<Psi> \<otimes> (q \<bullet> p \<bullet> \<Psi>\<^sub>R') \<rhd> P \<approx> Q" by simp
        hence "(q \<bullet> (\<Psi> \<otimes> (q \<bullet> p \<bullet> \<Psi>\<^sub>R'))) \<rhd> (q \<bullet> P) \<approx> (q \<bullet> Q)" by(rule weakBisimClosed)
        with Sq `A\<^sub>R \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `A\<^sub>R \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* P` `A\<^sub>R \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* Q` `distinct_perm q`
        have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R') \<rhd> P \<approx> Q" by(simp add: eqvts)
        hence "(p \<bullet> (\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R'))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)" by(rule weakBisimClosed)
        with Sp `A\<^sub>R' \<sharp>* \<Psi>` `(p \<bullet> A\<^sub>R') \<sharp>* \<Psi>` `A\<^sub>R' \<sharp>* P` `(p \<bullet> A\<^sub>R') \<sharp>* P` `A\<^sub>R' \<sharp>* Q` `(p \<bullet> A\<^sub>R') \<sharp>* Q` `distinct_perm p`
        have "\<Psi> \<otimes> \<Psi>\<^sub>R' \<rhd> P \<approx> Q" by(simp add: eqvts)
      }
      thus ?thesis
        apply auto
        apply(rule_tac x="[]" in exI)
        by auto blast
    qed
  }
  note Goal = this
  with assms have "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cStatImp \<Psi> PR QR)
    {
      fix xvec :: "name list"
      fix P Q R
      assume A: "\<forall>A\<^sub>R \<Psi>\<^sub>R. extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q \<longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
      {
        fix A\<^sub>R \<Psi>\<^sub>R
        assume "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* P" and "A\<^sub>R \<sharp>* Q"
        with A have "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<lessapprox><weakBisim> Q" by(auto dest: weakBisimE)
      }
      moreover assume "xvec \<sharp>* \<Psi>"
      moreover have "eqvt weakBisim" by auto
      moreover note C1 C2 statEqWeakBisim
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) \<lessapprox><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
        by(rule weak_stat_impParPres)
    }
    with `(\<Psi>, PR, QR) \<in> ?X` show ?case by auto
  next
    case(cSim \<Psi> PR QR)
    from `(\<Psi>, PR, QR) \<in> ?X`
    obtain xvec P Q R A\<^sub>R \<Psi>\<^sub>R where PFrR: "PR = \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R)" and QFrR: "QR = \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
                               and "xvec \<sharp>* \<Psi>"
      by auto
    with `(\<Psi>, PR, QR) \<in> ?X` have "(\<Psi>, \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)) \<in> ?X" by simp
    hence "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)" using `xvec \<sharp>* \<Psi>`
    proof(induct xvec)
      case Nil
      from `(\<Psi>, \<lparr>\<nu>*[]\<rparr>(P \<parallel> R), \<lparr>\<nu>*[]\<rparr>(Q \<parallel> R)) \<in> ?X` have PRQR: "(\<Psi>, P \<parallel> R, Q \<parallel> R) \<in> ?X" by simp
      from PRQR have "\<And>A\<^sub>R \<Psi>\<^sub>R. \<lbrakk>extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>;  A\<^sub>R \<sharp>* P;  A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> (\<Psi> \<otimes> \<Psi>\<^sub>R, P, Q) \<in> weakBisim"
        by auto
      moreover note weakBisimEqvt
      moreover from `eqvt ?X` have "eqvt(?X \<union> weakBisim)" by auto
      moreover note weakBisimE(2) weakBisimE(4) weakBisimE(3) weakBisimE(1)
      moreover note C1 C2
      ultimately have "\<Psi> \<rhd> P \<parallel> R \<leadsto><(?X \<union> weakBisim)> Q \<parallel> R" using statEqWeakBisim
        by(rule weakParPres)
      thus ?case by simp
    next
      case(Cons x xvec')
      from `(x#xvec') \<sharp>* \<Psi>` have "x \<sharp> \<Psi>" and "xvec' \<sharp>* \<Psi>" by simp+
      with `(\<Psi>, \<lparr>\<nu>*(x#xvec')\<rparr>P \<parallel> R, \<lparr>\<nu>*(x#xvec')\<rparr>Q \<parallel> R) \<in> ?X`
      have "(\<Psi>, \<lparr>\<nu>*(xvec')\<rparr>P \<parallel> R, \<lparr>\<nu>*(xvec')\<rparr>Q \<parallel> R) \<in> ?X"
        apply auto
        apply(subgoal_tac "\<exists>y yvec. xvec=y#yvec")
        apply(clarify)
        apply simp
        apply(simp add: psi.inject alpha)
        apply(clarify)
        apply(erule disjE)
        apply(erule disjE)
        apply(clarify)
        apply blast
        apply(clarify)
        apply(clarify)
        apply(simp add: eqvts)
        apply(rule_tac x="[(x, y)] \<bullet> yvec" in exI)
        apply(rule_tac x="[(x, y)] \<bullet> P" in exI)
        apply(rule_tac x="[(x, y)] \<bullet> Q" in exI)
        apply(rule_tac x="[(x, y)] \<bullet> R" in exI)
        apply(clarsimp)
        apply(rule conjI)
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(clarify)
        apply(erule_tac x="[(x, y)] \<bullet> A\<^sub>R" in allE)
        apply(erule_tac x="[(x, y)] \<bullet> \<Psi>\<^sub>R" in allE)
        apply(drule mp)
        apply(rule conjI)
        apply(rule_tac pi="[(x, y)]" in pt_bij4[OF pt_name_inst, OF at_name_inst])
        apply(simp add: eqvts)
        apply(rule conjI)
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(rule conjI)
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(subst pt_fresh_star_bij[OF pt_name_inst,OF at_name_inst, of "[(x, y)]", THEN sym])
        apply simp
        apply(drule_tac p="[(x, y)]" in weakBisimClosed)
        apply(simp add: eqvts)
        by(case_tac xvec) auto

      with `\<lbrakk>(\<Psi>, \<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R), \<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R)) \<in> ?X; xvec' \<sharp>* \<Psi>\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> \<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R)` `xvec' \<sharp>* \<Psi>`
      have "\<Psi> \<rhd> \<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R)" by blast
      moreover note `eqvt ?X`
      moreover from `eqvt ?X` have "eqvt(?X \<union> weakBisim)" by auto
      moreover note `x \<sharp> \<Psi>`
      moreover have "?X \<union> weakBisim \<subseteq> ?X \<union> weakBisim" by simp
      ultimately have "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec'\<rparr>(P \<parallel> R)) \<leadsto><(?X \<union> weakBisim)> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec'\<rparr>(Q \<parallel> R))" using Res
        by(rule_tac weakResPres)
      thus ?case
        by simp
    qed
    with PFrR QFrR show ?case
      by simp
  next
    case(cExt \<Psi> PR QR \<Psi>')

    from `(\<Psi>, PR, QR) \<in> ?X`
    obtain xvec P Q R A\<^sub>R \<Psi>\<^sub>R where PFrR: "PR = \<lparr>\<nu>*xvec\<rparr>(P \<parallel> R)" and QFrR: "QR = \<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R)"
                               and "xvec \<sharp>* \<Psi>" and A: "\<forall>A\<^sub>R \<Psi>\<^sub>R. (extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle> \<and> A\<^sub>R \<sharp>* \<Psi> \<and> A\<^sub>R \<sharp>* P \<and> A\<^sub>R \<sharp>* Q) \<longrightarrow> \<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q"
      by auto

    obtain p where "(p \<bullet> xvec) \<sharp>* \<Psi>"
               and "(p \<bullet> xvec) \<sharp>* P"
               and "(p \<bullet> xvec) \<sharp>* Q"
               and "(p \<bullet> xvec) \<sharp>* R"
               and "(p \<bullet> xvec) \<sharp>* \<Psi>'"
               and S: "(set p) \<subseteq> (set xvec) \<times> (set(p \<bullet> xvec))" and "distinct_perm p"
      by(rule_tac c="(\<Psi>, P, Q, R, \<Psi>')" in name_list_avoiding) auto

    from `(p \<bullet> xvec) \<sharp>* P` `(p \<bullet> xvec) \<sharp>* R` S have "\<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>(p \<bullet> (P \<parallel> R))"
      by(subst res_chain_alpha) auto
    hence PRAlpha: "\<lparr>\<nu>*xvec\<rparr>(P \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> P) \<parallel> (p \<bullet> R))"
      by(simp add: eqvts)

    from `(p \<bullet> xvec) \<sharp>* Q` `(p \<bullet> xvec) \<sharp>* R` S have "\<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>(p \<bullet> (Q \<parallel> R))"
      by(subst res_chain_alpha) auto
    hence QRAlpha: "\<lparr>\<nu>*xvec\<rparr>(Q \<parallel> R) = \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> Q) \<parallel> (p \<bullet> R))"
      by(simp add: eqvts)

    from `(p \<bullet> xvec) \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>'` have "(\<Psi> \<otimes> \<Psi>', \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> P) \<parallel> (p \<bullet> R)), \<lparr>\<nu>*(p \<bullet> xvec)\<rparr>((p \<bullet> Q) \<parallel> (p \<bullet> R))) \<in> ?X"
   proof(rule_tac C2="(\<Psi>, (p \<bullet> P), (p \<bullet> Q), R, \<Psi>', xvec, p \<bullet> xvec)" in XI', auto)
      fix A\<^sub>R \<Psi>\<^sub>R
      assume FrR: "extract_frame (p \<bullet> R) = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* \<Psi>'" and "A\<^sub>R \<sharp>* (p \<bullet> P)" and "A\<^sub>R \<sharp>* (p \<bullet> Q)"
      from FrR have "(p \<bullet> (extract_frame (p \<bullet> R))) = (p \<bullet> \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>)" by simp
      with `distinct_perm p` have "extract_frame R = \<langle>p \<bullet> A\<^sub>R, p \<bullet> \<Psi>\<^sub>R\<rangle>" by(simp add: eqvts)
      moreover from `A\<^sub>R \<sharp>* \<Psi>` have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> \<Psi>)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `xvec \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>` S have "(p \<bullet> A\<^sub>R) \<sharp>* \<Psi>" by simp
      moreover from `A\<^sub>R \<sharp>* (p \<bullet> P)` have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> p \<bullet> P)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `distinct_perm p` have "(p \<bullet> A\<^sub>R) \<sharp>* P" by simp
      moreover from `A\<^sub>R \<sharp>* (p \<bullet> Q)` have "(p \<bullet> A\<^sub>R) \<sharp>* (p \<bullet> p \<bullet> Q)" by(simp add: pt_fresh_star_bij[OF pt_name_inst, OF at_name_inst])
      with `distinct_perm p` have "(p \<bullet> A\<^sub>R) \<sharp>* Q" by simp
      ultimately have "\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q" using A by blast
      hence "(\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R)) \<otimes> (p \<bullet> \<Psi>') \<rhd> P \<approx> Q" by(rule weakBisimE)
      moreover have "(\<Psi> \<otimes> (p \<bullet> \<Psi>\<^sub>R)) \<otimes> (p \<bullet> \<Psi>') \<simeq> (\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R)"
        by(metis Associativity Commutativity Composition Assertion_stat_eq_trans Assertion_stat_eq_sym)
      ultimately have "(\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R) \<rhd> P \<approx> Q"
        by(rule statEqWeakBisim)
      hence "(p \<bullet> ((\<Psi> \<otimes> (p \<bullet> \<Psi>')) \<otimes> (p \<bullet> \<Psi>\<^sub>R))) \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)"
        by(rule weakBisimClosed)
      with `distinct_perm p` `xvec \<sharp>* \<Psi>` `(p \<bullet> xvec) \<sharp>* \<Psi>` S show "(\<Psi> \<otimes> \<Psi>') \<otimes> \<Psi>\<^sub>R \<rhd> (p \<bullet> P) \<approx> (p \<bullet> Q)"
        by(simp add: eqvts)
    qed
    with PFrR QFrR PRAlpha QRAlpha show ?case by simp
  next
    case(cSym \<Psi> PR QR)
    thus ?case by(blast dest: weakBisimE)
  qed
qed

lemma weakBisimParPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<approx> Q"

  shows "\<Psi> \<rhd> P \<parallel> R \<approx> Q \<parallel> R"
proof -
  obtain A\<^sub>R \<Psi>\<^sub>R where "extract_frame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>" and "A\<^sub>R \<sharp>* \<Psi>" and "A\<^sub>R \<sharp>* P" and "A\<^sub>R \<sharp>* Q"
    by(rule_tac C="(\<Psi>, P, Q)" in fresh_frame) auto
  moreover from `\<Psi> \<rhd> P \<approx> Q` have "\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q" by(rule weakBisimE)
  ultimately show ?thesis by(rule_tac weakBisimParPresAux)
qed

end

end


(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: ulift.thy                                                            *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Predicate Lifting\<close>

theory ulift
imports upred unrest
keywords "declare_uvar" :: thy_decl
begin

text \<open>A parser that lifts HOL predicates into @{type upred} objects.\<close>

subsection \<open>Tool Options\<close>

text \<open>Option that enables implicit typing in lifted predicates.\<close>

ML \<open>
  val (ulift_typing, ulift_typing_setup) =
    Attrib.config_bool @{binding ulift_typing} (K true);
\<close>

setup ulift_typing_setup

text \<open>Option that disables the pretty-printer to facilitate debugging.\<close>

ML \<open>
  val (disable_ulift_pp, disable_ulift_pp_setup) =
    Attrib.config_bool @{binding disable_ulift_pp} (K false);
\<close>

setup disable_ulift_pp_setup

subsection \<open>Lifting Operator\<close>

lift_definition LiftP :: "(ustate \<Rightarrow> bool) \<Rightarrow> upred"
is "\<lambda>f::ustate \<Rightarrow> bool. {b .f b}"
done

(* declare ustate_app_poly_def [evalp] *)

subsection \<open>Lifting Syntax\<close>

text \<open>We define a constant to tag terms to be processed by the parser.\<close>

consts ulift :: "bool \<Rightarrow> upred" ("'(_')\<^sub>p")

text \<open>The following allows us to protect inner terms from processing.\<close>

consts uprotect :: "'a \<Rightarrow> 'a" ("@'(_')")

subsection \<open>Parser and Printer\<close>

ML_file "ulift.ML"

setup \<open>
  Context.theory_map (
    (Syntax_Phases.term_check 2 "ulift parser" Ulift_Parser.ulift_tr) o
    (Syntax_Phases.term_uncheck 2 "ulift printer" Ulift_Printer.ulift_tr'))
\<close>

subsection \<open>Implicit Typing\<close>

parse_translation \<open>
  [(@{const_syntax "ulift"}, Ulift_Typing.implicit_typing)]
\<close>

text \<open>The following configures a command to declare an auxiliary variable.\<close>

ML \<open>
  Outer_Syntax.local_theory @{command_keyword "declare_uvar"} "declare uvar"
    (Parse.const_decl >>
      (fn (uvar, typ, _) => Ulift_Typing.mk_uvar_type_synonym uvar typ));
\<close>

subsection \<open>Proof Support\<close>

theorem EvalP_LiftP [evalp]:
"\<lbrakk>LiftP f\<rbrakk>b = (f b)"
apply (transfer)
apply (simp)
done

subsection \<open>Theorems\<close>

paragraph \<open>Unrestriction of Lifting\<close>

theorem LiftP_unrest_zero:
"vs \<sharp> (LiftP (\<lambda>b. P0))"
apply (transfer)
apply (simp)
done

theorem LiftP_unrest:
"vs \<inter> {v} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P1 b\<cdot>v))"
"vs \<inter> {v1, v2} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P2 b\<cdot>v1 b\<cdot>v2))"
"vs \<inter> {v1, v2, v3} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P3 b\<cdot>v1 b\<cdot>v2 b\<cdot>v3))"
"vs \<inter> {v1, v2, v3, v4} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P4 b\<cdot>v1 b\<cdot>v2 b\<cdot>v3 b\<cdot>v4))"
"vs \<inter> {v1, v2, v3, v4, v5} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P5 b\<cdot>v1 b\<cdot>v2 b\<cdot>v3 b\<cdot>v4 b\<cdot>v5))"
"vs \<inter> {v1, v2, v3, v4, v5, v6} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P6 b\<cdot>v1 b\<cdot>v2 b\<cdot>v3 b\<cdot>v4 b\<cdot>v5 b\<cdot>v6))"
"vs \<inter> {v1, v2, v3, v4, v5, v6, v7} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P7 b\<cdot>v1 b\<cdot>v2 b\<cdot>v3 b\<cdot>v4 b\<cdot>v5 b\<cdot>v6 b\<cdot>v7))"
"vs \<inter> {v1, v2, v3, v4, v5, v6, v7, v8} = {} \<Longrightarrow>
 vs \<sharp> (LiftP (\<lambda>b. P8 b\<cdot>v1 b\<cdot>v2 b\<cdot>v3 b\<cdot>v4 b\<cdot>v5 b\<cdot>v6 b\<cdot>v7 b\<cdot>v8))"
apply (transfer', clarsimp, transfer', simp)+
done

theorem "{$z\<down>} \<sharp> (x = y + (1::nat))\<^sub>p"
apply (unfold ustate_app_poly_def)
apply (rule LiftP_unrest)
apply (code_simp)
done

theorem "{$x\<down>} \<sharp> (x = y + (1::nat))\<^sub>p"
apply (unfold ustate_app_poly_def)
apply (rule LiftP_unrest)
apply (code_simp)
oops

subsection \<open>Experiments\<close>

text \<open>Types propagate through predicate connectives.\<close>

theorem "taut (x = y + 1)\<^sub>p \<and>\<^sub>p (y = 2)\<^sub>p \<Rightarrow>\<^sub>p (x = (3::nat))\<^sub>p"
apply (unfold evalp)
apply (clarify)
apply (simp)
done

text \<open>HOL quantifies can be used in lifted predicates too.\<close>

theorem "taut (\<exists> y . x = y + 1)\<^sub>p \<Rightarrow>\<^sub>p (x > (0::nat))\<^sub>p"
apply (unfold evalp simp_thms)
apply (clarify)
apply (simp)
done

text \<open>Note that the following holds for arbitrary HOL sets!\<close>

inject_type set

theorem "taut (x < 3)\<^sub>p \<and>\<^sub>p (s = {0::nat, 1, 2})\<^sub>p \<Rightarrow>\<^sub>p (x \<in> s)\<^sub>p"
apply (unfold evalp)
apply (safe)
apply (clarsimp)
done

text \<open>Lifting implies that HOL connectives are naturally supported.\<close>

theorem "taut (x < 3 \<and> s = {0, 1, 2::nat} \<longrightarrow> x \<in> s)\<^sub>p"
apply (unfold evalp)
apply (safe)
apply (clarsimp)
done
end