theory RHL_Typed
imports RHL_Untyped Hoare_Typed Procs_Typed
begin

subsection {* Definition *}

definition rhoare :: "(memory \<Rightarrow> memory \<Rightarrow> bool) \<Rightarrow> program \<Rightarrow> program \<Rightarrow> (memory \<Rightarrow> memory \<Rightarrow> bool) \<Rightarrow> bool" where
  "rhoare pre c1 c2 post =
  (\<forall>m1 m2. pre m1 m2 \<longrightarrow>
     (\<exists>\<mu>. apply_to_distr fst \<mu> = denotation c1 m1
        \<and> apply_to_distr snd \<mu> = denotation c2 m2
        \<and> (\<forall>m1' m2'. (m1',m2') \<in> support_distr \<mu> \<longrightarrow> post m1' m2')))"

lemma rhoareI:
  assumes "\<And>m1 m2. P m1 m2 \<Longrightarrow>
            (\<exists>\<mu>. apply_to_distr fst \<mu> = denotation p1 m1 \<and>
                  apply_to_distr snd \<mu> = denotation p2 m2 \<and> (\<forall>m1' m2'. (m1',m2') \<in> support_distr \<mu> \<longrightarrow> Q m1' m2'))"
  shows "rhoare P p1 p2 Q"
unfolding rhoare_def using assms by simp

lemma rhoare_untyped: "rhoare P c1 c2 Q = rhoare_untyped P (Rep_program c1) (Rep_program c2) Q"
  unfolding rhoare_def rhoare_untyped_def denotation_def by rule

definition "obs_eq X Y c1 c2 ==
  rhoare (\<lambda>m1 m2. \<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x)
         c1 c2
         (\<lambda>m1 m2. \<forall>x\<in>Y. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x)"
definition "obs_eq' X == obs_eq X X"

lemma obs_eq_obs_eq_untyped: "obs_eq X Y c1 c2 = obs_eq_untyped X Y (Rep_program c1) (Rep_program c2)"
  unfolding obs_eq_def obs_eq_untyped_def rhoare_def
  unfolding rhoare_untyped_def denotation_def by auto

    (*
subsection {* Concrete syntax *}

syntax "_rhoare" :: "(memory \<Rightarrow> bool) \<Rightarrow> program_syntax \<Rightarrow> program_syntax \<Rightarrow> (memory \<Rightarrow> bool) \<Rightarrow> term"
          ("rhoare (\<lambda>m1 m2. (_)}/ (2_) ~ (2_)/ {(_)}")
syntax "_memory" :: memory ("&m")
syntax "_memory1" :: memory ("m1")
syntax "_memory2" :: memory ("m2")
syntax "_select_memory1" :: "'a \<Rightarrow> 'a" ("_\<^sub>1" [1000] 1000)
syntax "_select_memory2" :: "'a \<Rightarrow> 'a" ("_\<^sub>2" [1000] 1000)

ML_file "rhoare_syntax.ML"

parse_translation {*
  let
  in
    [("_rhoare", fn ctx => fn [P,c1,c2,Q] => RHoare_Syntax.trans_hoare ctx P c1 c2 Q)]
  end
*}

(* print_translation {*
  [(@{const_syntax RHL_Typed.rhoare}, fn ctx => fn [P,c1,c2,Q] => RHoare_Syntax.trans_hoare_back ctx P c1 c2 Q)]
*} *)

(* ML {* val testterm = @{term "rhoare (\<lambda>m1 m2. True} skip ~ skip {True}"} *}
ML {* Syntax.string_of_term @{context} testterm |> writeln *} *)

(*
term "x\<^sub>a"
ML {* @{print} @{term x\<^sub>a} *}

consts x::"int variable"
consts f::"memory\<Rightarrow>memory"
term "rhoare (\<lambda>m1 m2. (x)\<^sub>1 = undefined} skip ~ skip {undefined}"
*)
*)

subsection {* Rules *}

lemma rconseq_rule:
  assumes "\<forall>m m'. P m m' \<longrightarrow> P' m m'"
      and "\<forall>m m'. Q' m m' \<longrightarrow> Q m m'"
      and "rhoare P' c d Q'"
  shows "rhoare P c d Q"
  using assms unfolding rhoare_def by blast

lemma rseq_rule:
  assumes PcQ: "rhoare P c1 c2 Q"
  assumes QcR: "rhoare Q c1' c2' R"
  shows "rhoare P (seq c1 c1') (seq c2 c2') R"
using assms unfolding rhoare_untyped Rep_seq by (rule rseq_rule)

lemma rsymmetric_rule:
  assumes "rhoare P c d Q"
  shows "rhoare (\<lambda>m1 m2. P m2 m1) d c (\<lambda>m1 m2. Q m2 m1)"
using assms rhoare_untyped rsymmetric_rule by auto

lemma assign_left_rule:
  fixes P Q x e
  assumes "\<forall>m m'. P m m' \<longrightarrow> Q (memory_update_pattern m x (e_fun e m)) m'"
  shows "rhoare P (assign x e) skip Q"
  unfolding rhoare_untyped Rep_skip Rep_assign
  apply (rule rassign_rule1)
  using assms unfolding memory_update_pattern_def by auto

lemma assign_right_rule:
  fixes P Q x e
  assumes "\<forall>m m'. P m m' \<longrightarrow> Q m (memory_update_pattern m' x (e_fun e m'))"
  shows "rhoare P skip (assign x e) Q"
  unfolding rhoare_untyped Rep_skip Rep_assign
  apply (rule rassign_rule2)
  using assms unfolding memory_update_pattern_def by auto

lemma assign_rule_left_strict:
  fixes Q x e
  defines "Q' == \<lambda>m m'. Q (memory_update_pattern m x (e_fun e m)) m'"
  shows "rhoare Q' (assign x e) skip Q"
  apply (rule assign_left_rule)
  unfolding Q'_def by simp

lemma assign_rule_right_strict:
  fixes Q x e
  defines "Q' == \<lambda>m m'. Q m (memory_update_pattern m' x (e_fun e m'))"
  shows "rhoare Q' skip (assign x e) Q"
  apply (rule assign_right_rule)
  unfolding Q'_def by simp

(*lemma sample_rule_left_strict:
  fixes Q x e
  defines "Q' == \<lambda>m m'. \<forall>v\<in>support_distr (e_fun e m). Q (memory_update_pattern m x v) m'"
  shows "rhoare (\<lambda>m1 m2. Q' m1 m2} (sample x e) ~ skip Q"
  apply (rule sample_rule)
  unfolding Q'_def by simp*)

lemma rcase_rule:
  assumes "\<And>x. rhoare (\<lambda>m1 m2. P m1 m2 \<and> f m1 m2 = x) c d Q"
  shows "rhoare P c d Q"
using assms unfolding rhoare_def by metis

lemma iftrue_rule_left:
  assumes "rhoare P c1 d Q"
          "\<forall>m m'. P m m' \<longrightarrow> e_fun e m"
  shows "rhoare P (ifte e c1 c2) d Q"
  unfolding rhoare_untyped Rep_ifte
  apply (rule iftrue_rule_left)
  using assms unfolding rhoare_untyped by auto

lemma iffalse_rule_left:
  fixes P Q I e p1 p2
  assumes "rhoare P p2 d Q"
          "\<forall>m m'. P m m' \<longrightarrow> \<not> e_fun e m"
  shows "rhoare P (ifte e p1 p2) d Q"
  unfolding rhoare_untyped Rep_ifte
  apply (rule iffalse_rule_left)
  using assms unfolding rhoare_untyped by auto

lemma iftrue_rule_right:
  assumes "rhoare P d c1 Q"
          "\<forall>m m'. P m m' \<longrightarrow> e_fun e m'"
  shows "rhoare P d (ifte e c1 c2) Q"
  unfolding rhoare_untyped Rep_ifte
  apply (rule iftrue_rule_right)
  using assms unfolding rhoare_untyped by auto

lemma iffalse_rule_right:
  fixes P Q I e p1 p2
  assumes "rhoare P d p2 Q"
          "\<forall>m m'. P m m' \<longrightarrow> \<not> e_fun e m'"
  shows "rhoare P d (ifte e p1 p2) Q"
  unfolding rhoare_untyped Rep_ifte
  apply (rule iffalse_rule_right)
  using assms unfolding rhoare_untyped by auto

lemma if_case_rule_left:
  assumes "rhoare P1 (c1) (d) Q"
  assumes "rhoare P2 (c2) (d) Q"
  shows "rhoare (\<lambda>m1 m2. if e_fun e m1 then P1 m1 m2 else P2 m1 m2)
                 (ifte e c1 c2) (d)
               Q"
apply (rule rcase_rule[where f="\<lambda>m1 m2. e_fun e m1"])
apply (case_tac x, auto)
 apply (rule iftrue_rule_left)
  apply (rule rconseq_rule[where P'=P1 and Q'=Q], auto simp: assms)[2]
apply (rule iffalse_rule_left)
 by (rule rconseq_rule[where P'=P2 and Q'=Q], auto simp: assms)

lemma if_case_rule_right:
  assumes "rhoare P1 (c) (d1) Q"
  assumes "rhoare P2 (c) (d2) Q"
  shows "rhoare (\<lambda>m1 m2. if e_fun e m2 then P1 m1 m2 else P2 m1 m2)
                  c (ifte e d1 d2)
                Q"
apply (rule rcase_rule[where f="\<lambda>m1 m2. e_fun e m2"])
apply (case_tac x, auto)
 apply (rule iftrue_rule_right)
  apply (rule rconseq_rule[where P'=P1 and Q'=Q], auto simp: assms)[2]
apply (rule iffalse_rule_right)
 by (rule rconseq_rule[where P'=P2 and Q'=Q], auto simp: assms)

lemma rif_rule:
  assumes "\<And>m1 m2. P m1 m2 \<Longrightarrow> e_fun e1 m1 = e_fun e2 m2"
  assumes "rhoare (\<lambda>m1 m2. P m1 m2 \<and> e_fun e1 m1 \<and> e_fun e2 m2) (then1) (then2) Q"
  assumes "rhoare (\<lambda>m1 m2. P m1 m2 \<and> \<not> e_fun e1 m1 \<and> \<not> e_fun e2 m2) (else1) (else2) Q"
  shows "rhoare P (ifte e1 then1 else1) (ifte e2 then2 else2) Q"
unfolding rhoare_untyped apply simp
apply (rule rif_rule)
using assms unfolding rhoare_untyped by auto

lemma rwhile_rule:
  assumes hoare: "rhoare (\<lambda>m1 m2. I m1 m2 \<and> e_fun e1 m1) (p1) (p2) I"
      and PI: "\<And>m1 m2. P m1 m2 \<Longrightarrow> I m1 m2"
      and Ieq: "\<And>m1 m2. I m1 m2 \<Longrightarrow> e_fun e1 m1 \<longleftrightarrow> e_fun e2 m2"
      and IQ: "\<And>m1 m2. \<not> e_fun e1 m1 \<Longrightarrow> \<not> e_fun e2 m2 \<Longrightarrow> I m1 m2 \<Longrightarrow> Q m1 m2"
  shows "rhoare P (while e1 p1) (while e2 p2) Q"
unfolding rhoare_untyped apply simp
apply (rule rwhile_rule[where I=I])
using assms unfolding rhoare_untyped by auto

lemma rtrans_rule:
  assumes p:"\<And>m1 m2. P m1 m2 \<Longrightarrow> \<exists>m. P1 m1 m \<and> P2 m m2"
      and q:"\<And>m1 m2 m. Q1 m1 m \<Longrightarrow> Q2 m m2 \<Longrightarrow> Q m1 m2"
      and rhl1: "rhoare P1 c1 c Q1"
      and rhl2: "rhoare P2 c c2 Q2"
  shows "rhoare P (c1) (c2) Q"
unfolding rhoare_untyped
apply (rule rtrans_rule[of _ P1 P2 Q1 Q2])
using assms unfolding rhoare_untyped by auto

lemma rtrans3_rule:
  assumes p:"\<And>m1 m2. P m1 m2 \<Longrightarrow> \<exists>m m'. P1 m1 m \<and> P2 m m' \<and> P3 m' m2"
      and q:"\<And>m1 m2 m m'. Q1 m1 m \<Longrightarrow> Q2 m m' \<Longrightarrow> Q3 m' m2 \<Longrightarrow> Q m1 m2"
      and rhl1: "rhoare P1 (c1) (c2) Q1"
      and rhl2: "rhoare P2 (c2) (c3) Q2"
      and rhl3: "rhoare P3 (c3) (c4) Q3"
  shows "rhoare P (c1) (c4) Q"
proof -
  define Q12 where "Q12 \<equiv> \<lambda>m1 m'. \<exists>m. Q1 m1 m \<and> Q2 m m'"
  define P12 where "P12 \<equiv> \<lambda>m1 m'. \<exists>m. P1 m1 m \<and> P2 m m'"
  have rhl12: "rhoare P12 c1 c3 Q12"
    apply (rule rtrans_rule[OF _ _ rhl1 rhl2])
    unfolding P12_def Q12_def by auto
  show ?thesis
    apply (rule rtrans_rule[OF _ _ rhl12 rhl3])
    unfolding P12_def Q12_def
     using p close metis
    using q by metis
qed

lemma seq_assoc_left_rule:
  assumes "rhoare P (seq (seq a b) c) d R"
  shows   "rhoare P (seq a (seq b c)) d R"
using assms denotation_seq_assoc rhoare_def by auto

lemma seq_assoc_right_rule:
  assumes "rhoare P d (seq (seq a b) c) R"
  shows   "rhoare P d (seq a (seq b c)) R"
using assms denotation_seq_assoc rhoare_def by auto

lemma addskip_left_rule:
  assumes "rhoare P (seq skip c) d Q"
  shows "rhoare P c d Q"
  using assms unfolding rhoare_def denotation_seq_skip by simp

lemma addskip_right_rule:
  assumes "rhoare P c (seq skip d) Q"
  shows "rhoare P (c) (d) Q"
  using assms unfolding rhoare_def denotation_seq_skip by simp

(* Ordering of subgoals for certain tactics *)
lemma seq_rule_lastfirst_left:
  fixes P Q R c d e
  assumes "rhoare Q d skip R" and "rhoare P (c) (e) Q"
  shows "rhoare P (seq c d) e R"
proof -
  have "rhoare P (seq c d) (seq e skip) R"
    apply (rule rseq_rule) using assms by simp_all
  thus ?thesis
    unfolding rhoare_def denotation_skip_seq by assumption
qed

(* Ordering of subgoals for certain tactics *)
lemma seq_rule_lastfirst_right:
  fixes P Q R c d e
  assumes "rhoare Q skip d R" and "rhoare P (e) (c) Q"
  shows "rhoare P (e) (seq c d) R"
proof -
  have "rhoare P (seq e skip) (seq c d) R"
    apply (rule rseq_rule) using assms by simp_all
  thus ?thesis
    unfolding rhoare_def denotation_skip_seq by assumption
qed

(*
definition "assign_local_vars_typed locals (pargs::'a::procargs procargvars) (args::'a procargs)
  = Abs_program (assign_local_vars locals (mk_procargvars_untyped pargs) (mk_procargs_untyped args))"

lemma assign_local_vars_typed_simp1 [simp]:
  "assign_local_vars_typed locals (procargvars_add p pargs) (procargs_add e args) =
   seq (assign_local_vars_typed locals pargs args) (assign p e)"
using[[simp_trace_new]]
unfolding assign_local_vars_typed_def seq_def assign_def
apply simp
find_theorems "mk_procargvars_untyped (procargvars_add _ _)"
apply (subst Abs_program_inverse, auto intro!: well_typed_assign_local_vars)
by (subst Abs_program_inverse, auto)
*)

(*
lemma assign_local_vars_typed_simp2 [simp]:
  "assign_local_vars_typed (mk_variable_untyped x#locals) procargvars_empty procargs_empty =
   seq (assign_local_vars_typed locals procargvars_empty procargs_empty) (assign x (const_expression default))"
      unfolding assign_local_vars_typed_def seq_def assign_def
      apply (tactic "cong_tac @{context} 1", auto)
      close (subst Abs_program_inverse, auto intro!: well_typed_assign_local_vars)
      apply (subst Abs_program_inverse, auto simp: const_expression_def const_expression_untyped_def)
      unfolding mk_expression_untyped_def e_fun_def e_vars_def
      apply (subst Abs_expression_inverse) apply auto
      apply (subst Abs_expression_inverse) by auto

lemma assign_local_vars_typed_simp3 [simp]:
  "assign_local_vars_typed [] procargvars_empty procargs_empty = Lang_Typed.skip"
unfolding assign_local_vars_typed_def skip_def by simp
*)

definition "assign_default_typed locals = Abs_program (assign_default locals)"

definition "assign_default_typed_aux p0 vs = Abs_program (foldl (\<lambda>p v. Seq p (Assign (pattern_1var v)
                      (const_expression_untyped (vu_type v) (t_default (vu_type v))))) (Rep_program p0) vs)"

lemma assign_default_typed_aux: "assign_default_typed vs = assign_default_typed_aux Lang_Typed.skip vs"
  unfolding assign_default_typed_aux_def assign_default_def assign_default_typed_def
  by auto

lemma assign_default_typed_aux_cons: "assign_default_typed_aux p0 (mk_variable_untyped v # vs) =
  assign_default_typed_aux (seq p0 (assign (variable_pattern v) (const_expression default))) vs"
  unfolding assign_default_typed_def assign_default_typed_aux_def assign_default_def seq_def
    assign_def variable_pattern_def mk_expression_untyped_const_expression
  apply simp
  apply (subst Abs_program_inverse)
   using assign_default_def assign_default_welltyped close auto
  apply (subst Abs_program_inverse)
   close (simp add: embedding_Type eu_type_const_expression_untyped)
  apply (subst Abs_pattern_inverse)
   by auto

lemma assign_default_typed_aux_nil: "assign_default_typed_aux p0 [] = p0"
  unfolding assign_default_typed_def assign_default_typed_aux_def assign_default_def skip_def
  by (auto simp: Rep_program_inverse)

(*
definition "assign_default_typed_rev vs = assign_default_typed (rev vs)"
lemma assign_default_typed_rev: "assign_default_typed vs = assign_default_typed_rev (rev vs)"
unfolding assign_default_typed_rev_def by auto

lemma "assign_default_typed ([mk_variable_untyped a,mk_variable_untyped b,mk_variable_untyped c]) =
  PROGRAM [ skip; a:=default; b:=default; c:=default ]"
  unfolding assign_default_typed_def assign_default_def program_def seq_def assign_def
      variable_pattern_def mk_expression_untyped_const_expression
  apply (subst Abs_program_inverse, tactic \<open>Skip_Proof.cheat_tac @{context} 1\<close>)+
  apply (subst Abs_pattern_inverse, tactic \<open>Skip_Proof.cheat_tac @{context} 1\<close>)+
  by simp

lemma assign_default_typed_rev_cons: "assign_default_typed_rev (mk_variable_untyped v # vs) = seq (assign_default_typed_rev vs) (assign (variable_pattern v) (const_expression default))"
  unfolding assign_default_typed_def assign_default_typed_rev_def assign_default_def seq_def
    assign_def variable_pattern_def mk_expression_untyped_const_expression
  apply simp
  apply (subst Abs_program_inverse)
   using assign_default_def assign_default_welltyped close auto
  apply (subst Abs_program_inverse)
   close (simp add: embedding_Type eu_type_const_expression_untyped)
  apply (subst Abs_pattern_inverse)
   by auto

lemma assign_default_typed_rev_nil: "assign_default_typed_rev [] = Lang_Typed.skip"
  unfolding assign_default_typed_def assign_default_typed_rev_def assign_default_def skip_def
  by auto
*)

(* If the number of subgoals change, inline_rule_conditions_tac must be adapted accordingly *)
lemma callproc_rule:
  fixes p::"('a::prog_type,'b::prog_type) procedure" and x::"'b pattern" and args::"'a expression"
    and locals::"variable_untyped list" and V::"variable_untyped set"
    and non_parg_locals::"variable_untyped list"
  defines "body == p_body p"
  defines "ret == p_return p"
  defines "pargs == p_arg p"
(*  defines "GL == {x. vu_global x}" *)
  assumes proc_locals: "set(local_vars body) \<union> filter_local (set(p_vars pargs) \<union> set(e_vars ret)) \<subseteq> set locals"
  assumes locals_local: "filter_global (set locals) = {}"
  assumes localsV: "V \<inter> set locals \<subseteq> set (p_vars x)"
  assumes proc_globals: "filter_global (set(vars body) \<union> set(e_vars ret)) \<subseteq> V"
  assumes argvarsV: "set(e_vars args) \<subseteq> V"
  assumes non_parg_locals: "set non_parg_locals = set locals - set (p_vars pargs)"

  defines "unfolded == seq (seq (seq (assign pargs args) (assign_default_typed non_parg_locals)) body) (assign x ret)"
  shows "obs_eq' V (callproc x p args) unfolded"
proof -
  (*def GL == "{x. vu_global x} :: variable_untyped set"
  have fl_GL: "\<And>X. filter_local X = X - GL"
    unfolding GL_def filter_local_def by auto
  have fg_GL: "\<And>X. filter_global X = X \<inter> GL"
    unfolding GL_def filter_global_def by auto*)
  define body' where "body' \<equiv> Rep_program (p_body p)"
  define pargs' where "pargs' \<equiv> Rep_pattern (p_arg p)"
  define ret' where "ret' \<equiv> mk_expression_untyped (p_return p)"
  define p' where "p' \<equiv> Proc body' pargs' ret'"
  have p': "mk_procedure_untyped p = p'"
    unfolding mk_procedure_untyped_def p'_def body'_def pargs'_def ret'_def ..
  define x' where "x' \<equiv> Rep_pattern x"
  define args' where "args' \<equiv> mk_expression_untyped args"
  have callproc: "Rep_program (callproc x p args) == CallProc x' p' args'"
    unfolding Rep_callproc x'_def[symmetric] p' args'_def[symmetric] by assumption
  define unfolded' where "unfolded' \<equiv> Seq (Seq (Seq (Assign pargs' args') (assign_default non_parg_locals)) body')
                           (Assign x' ret')"
  have assign: "Rep_program (assign_default_typed locals) == assign_default locals"
      unfolding assign_default_typed_def
      apply (subst Abs_program_inverse, auto)
      by (rule assign_default_welltyped)
  have unfolded: "Rep_program unfolded = unfolded'"
    unfolding unfolded'_def unfolded_def pargs'_def pargs_def args'_def
    Rep_seq assign body'_def body_def Rep_assign ret_def
    x'_def[symmetric] ret'_def[symmetric] assign_default_typed_def
   apply (subst Abs_program_inverse)
   using assign_default_welltyped by auto
  have fl_loc_var: "\<And>p. set (local_vars p) = filter_local (set (vars p))"
    unfolding local_vars_def filter_local_def by auto
  have fl_union: "\<And>A B. filter_local (A \<union> B) = filter_local A \<union> filter_local B"
    unfolding filter_local_def by auto
  have proc_locals': "filter_local (set (vars (p_body p)) \<union> set (p_vars (p_arg p)) \<union> set (eu_vars (mk_expression_untyped (p_return p)))) \<subseteq> set locals"
    using proc_locals unfolding fl_union pargs_def ret_def body_def fl_loc_var by auto
  show "obs_eq' V (callproc x p args) unfolded"
    unfolding obs_eq'_def obs_eq_obs_eq_untyped callproc unfolded unfolded'_def p'_def
    apply (rule callproc_rule)
    unfolding body'_def x'_def vars_def[symmetric] e_vars_def[symmetric] p_vars_def[symmetric] pargs'_def ret'_def args'_def
    using assms proc_locals' local_vars_def by auto
qed

(* Outputs the list of parameters of callproc_rule, ordered like the arguments to Drule.instantiate' *)
ML {* Term.add_vars (Thm.prop_of @{thm callproc_rule}) [] |> rev |> map Var |> map (Syntax.string_of_term @{context}) |> String.concatWith "\n" |> writeln *}

fun varname_to_nat :: "variable_name \<Rightarrow> nat" where
  "varname_to_nat [] = 0"
| "varname_to_nat (c#cs) = nat_of_char c + 1 + varname_to_nat cs * 257"
definition [simp]: "var_to_nat v = 2 * varname_to_nat (vu_name v) + (if vu_global v then 1 else 0)"

lemma inj_varname_to_nat: "inj varname_to_nat"
proof (rule injI)
  fix x y assume assm: "varname_to_nat x = varname_to_nat y"
  show "x = y"
  proof (insert assm, induction x arbitrary: y)
    case Nil then show ?case apply (cases y) by auto
  next case xCons: (Cons c cs)
    show ?case
    proof (cases y)
      case Nil with xCons.prems show ?thesis by auto
    next case yCons: (Cons d ds)
      from xCons.prems yCons
      have vn_same: "varname_to_nat cs = varname_to_nat ds"
        apply auto
        using nat_of_char_less_256[of c] nat_of_char_less_256[of d] by arith
      with xCons have cs_same: "cs = ds" by simp
      from xCons.prems yCons
      have c_same: "c = d"
        apply auto unfolding vn_same by simp
      from cs_same c_same yCons show ?thesis by simp
    qed
  qed
qed

lemma inj_var_to_nat_global:
  assumes "var_to_nat x = var_to_nat y"
  shows "vu_global x = vu_global y"
  using assms unfolding var_to_nat_def
  apply (cases "vu_global x"; cases "vu_global x")
     close arith close close by arith

lemma inj_var_to_nat_name:
  assumes "var_to_nat x = var_to_nat y"
  shows "vu_name x = vu_name y"
proof -
  from assms have "varname_to_nat (vu_name x) = varname_to_nat (vu_name y)"
    unfolding var_to_nat_def inj_var_to_nat_global[OF assms] by simp
  then show ?thesis
    by (rule inj_varname_to_nat[THEN injD])
qed

lemma var_to_nat_mk_variable_untyped_LVariable [simp]:
  "var_to_nat (mk_variable_untyped (LVariable n)) = 2 * varname_to_nat n"
  by simp

lemma var_to_nat_mk_variable_untyped_Variable [simp]:
  "var_to_nat (mk_variable_untyped (Variable n)) = 2 * varname_to_nat n + 1"
  by simp

definition local_renaming1_to_nat :: "(variable_name * variable_name) \<Rightarrow> (nat*nat)" where
  "local_renaming1_to_nat = (\<lambda>(n,m). (2 * varname_to_nat n,2 * varname_to_nat m))"
definition apply_transposition :: "('a*'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "apply_transposition = (\<lambda> (a,b) x. if x = a then b else if x = b then a else x)"
definition apply_permutation :: "('a*'a) list \<Rightarrow> 'a \<Rightarrow> 'a" where
  "apply_permutation = fold apply_transposition"

lemma var_to_nat_local_variable_name_renaming1: "var_to_nat (local_variable_name_renaming1 renaming v) =
  apply_transposition (local_renaming1_to_nat renaming) (var_to_nat v)"
  unfolding apply_transposition_def local_renaming1_to_nat_def
            local_variable_name_renaming1_def
            var_to_nat_def
  apply (cases renaming)
  by (auto simp: inj_varname_to_nat[THEN injD])

lemma var_to_nat_local_variable_name_renaming: "var_to_nat (local_variable_name_renaming renaming v) =
  apply_permutation (map local_renaming1_to_nat renaming) (var_to_nat v)"
  unfolding local_variable_name_renaming_def apply_permutation_def
  apply (induction renaming arbitrary: v) close
  unfolding fold_simps list.map
  apply (subst var_to_nat_local_variable_name_renaming1[symmetric])
  by auto

(* lemma "var_to_nat (mk_variable_untyped (Variable ''hello there'')) = xxx"
  apply simp *)

(* If the subgoals change, Tactic_Inline.callproc_rule_conditions_tac must be adapted accordingly *)
(* locals and non_parg_locals have to be already renamed *)
lemma callproc_rule_renamed:
  fixes p::"('a::prog_type,'b::prog_type) procedure" and x::"'b pattern" and args::"'a expression"
    and locals::"variable_untyped list" and V::"variable_untyped set"
    and non_parg_locals::"variable_untyped list"
    and renaming::"variable_name_renaming"

  defines "body == p_body p"
  defines "ret == p_return p"
  defines "pargs == p_arg p"
  defines "renaming_nat == map local_renaming1_to_nat renaming"

  (* assumes proc_locals: "local_variable_name_renaming renaming ` (set(local_vars body) \<union> filter_local (set(p_vars pargs) \<union> set(e_vars ret))) \<subseteq> set locals" *)
  assumes proc_locals_nat: "apply_permutation renaming_nat ` (var_to_nat`set(local_vars body) \<union> var_to_nat`filter_local(set(p_vars pargs)) \<union> var_to_nat`filter_local(set(e_vars ret))) \<subseteq> var_to_nat`set locals"
  assumes locals_local: "filter_global (set locals) = {}"
  assumes localsV: "V \<inter> set locals \<subseteq> set (p_vars x)"
  assumes proc_globals: "local_variable_name_renaming renaming ` (filter_global(set(vars body) \<union> set(e_vars ret))) \<subseteq> V"
  assumes argvarsV: "set(e_vars args) \<subseteq> V"
  assumes non_parg_locals: "set non_parg_locals = set locals - local_variable_name_renaming renaming ` set (p_vars pargs)"

  defines "unfolded == seq (seq (seq (assign (rename_local_variables_pattern renaming pargs) args)
                                     (assign_default_typed non_parg_locals))
                                     (rename_local_variables renaming body))
                                     (assign x (rename_local_variables_expression renaming ret))"
  shows "obs_eq' V (callproc x p args) unfolded"
proof -
  define body' where "body' \<equiv> p_body (rename_local_variables_proc renaming p)"
  define ret' where "ret' \<equiv> p_return (rename_local_variables_proc renaming p)"
  define pargs' where "pargs' \<equiv> p_arg (rename_local_variables_proc renaming p)"
  define unfolded' where "unfolded' \<equiv> seq (seq (seq (assign pargs' args) (assign_default_typed non_parg_locals)) body') (assign x ret')"
  have filter_renaming: "\<And>X. filter_local (local_variable_name_renaming renaming ` X) = local_variable_name_renaming renaming ` filter_local X"
    unfolding filter_local_def using local_variable_name_renaming_global by auto
  have aux: "var_to_nat ` local_variable_name_renaming renaming ` X =  apply_permutation (map local_renaming1_to_nat renaming) ` var_to_nat ` X" for X
    using var_to_nat_local_variable_name_renaming
    by (metis (no_types, hide_lams) image_comp image_cong o_def renaming_nat_def)
  from proc_locals_nat
  have proc_locals: "local_variable_name_renaming renaming ` (set(local_vars body) \<union> filter_local (set(p_vars pargs) \<union> set(e_vars ret))) \<subseteq> set locals"
    apply (subst aux) apply auto
  have "unfolded = unfolded'"
    unfolding unfolded_def unfolded'_def pargs'_def pargs_def p_arg_rename_local_variables_proc
              body'_def body_def p_body_rename_local_variables_proc ret'_def ret_def
              p_ret_rename_local_variables_proc by simp
  have obseq: "obs_eq' V (callproc x (rename_local_variables_proc renaming p) args) unfolded'"
    unfolding unfolded'_def pargs'_def ret'_def body'_def
    apply (rule callproc_rule[where locals=locals])
    unfolding p_body_rename_local_variables_proc body_def[symmetric]
    unfolding p_arg_rename_local_variables_proc pargs_def[symmetric]
    unfolding p_ret_rename_local_variables_proc ret_def[symmetric]
    unfolding local_vars_rename_local_variables
    unfolding p_vars_rename_local_variables_pattern
    unfolding e_vars_rename_local_variables_expression
    unfolding vars_rename_local_variables
    unfolding set_map
    using assms unfolding filter_local_def filter_global_def by auto
  hence obseq: "obs_eq' V (callproc x (rename_local_variables_proc renaming p) args) unfolded"
    unfolding `unfolded=unfolded'` by assumption
  then show ?thesis
    unfolding obs_eq'_def obs_eq_def rhoare_def denotation_callproc_rename_local_variables_proc
    by assumption
qed

(* Outputs the list of parameters of callproc_rule, ordered like the arguments to Drule.instantiate' *)
ML {* Term.add_vars (Thm.prop_of @{thm callproc_rule_renamed}) [] |> rev |> map Var |> map (Syntax.string_of_term @{context}) |> String.concatWith "\n" |> writeln *}

(*
definition "blockassign (xs::'a::procargs procargvars) (es::'a procargs) ==
  Abs_program
  (fold
  (\<lambda>(x,e) p. Seq p (Assign x e))
  (zip (mk_procargvars_untyped xs) (mk_procargs_untyped es))
  Skip)"

lemma callproc_equiv:
  fixes x p e
  defines "V_e == set [v. e \<leftarrow> mk_procargs_untyped e, v \<leftarrow> eu_vars e]"
  defines "V_p == set (vars (p_body p)) \<union> set (mk_procargvars_untyped (p_args p)) \<union> set (e_vars (p_return p))"
  assumes "V_p \<inter> V = {}" and "V_p \<inter> V_e = {}"
  shows "rhoare (\<lambda>m1 m2. \<forall>x\<in>V. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x}
                  (callproc x p e) (blockassign (p_args p) e); (p_body p); x := (p_return p)
               {\<forall>x\<in>V. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x}"
*)

definition "obseq_context X C == (\<forall>c d. obs_eq X X c d \<longrightarrow> obs_eq X X (C c) (C d))"

lemma assertion_footprint_left_lookup: "mk_variable_untyped x \<in> X \<Longrightarrow> assertion_footprint_left X (\<lambda>m1 m2. memory_lookup m1 x)"
  unfolding assertion_footprint_left_def by auto
lemma assertion_footprint_right_lookup: "mk_variable_untyped x \<in> X \<Longrightarrow> assertion_footprint_right X (\<lambda>m1 m2. memory_lookup m2 x)"
  unfolding assertion_footprint_right_def by auto

lemma assertion_footprint_left_update:
  assumes "Y \<subseteq> insert (mk_variable_untyped x) X"
  assumes "assertion_footprint_left Y P"
  shows "assertion_footprint_left X (\<lambda>m m'. P (memory_update m x v) m')"
unfolding memory_update_def
apply (rule assertion_footprint_left_update_untyped)
using assms by auto

lemma assertion_footprint_right_update:
  assumes "Y \<subseteq> insert (mk_variable_untyped x) X"
  assumes "assertion_footprint_right Y P"
  shows "assertion_footprint_right X (\<lambda>m m'. P m (memory_update m' x v))"
unfolding memory_update_def
apply (rule assertion_footprint_right_update_untyped)
using assms by auto

lemma assertion_footprint_left_update_pattern:
  assumes "Y \<subseteq> X \<union> set (p_vars pat)"
  assumes "assertion_footprint_left Y P"
  shows "assertion_footprint_left X (\<lambda>m m'. P (memory_update_pattern m pat x) m')"
unfolding memory_update_pattern_def
apply (rule assertion_footprint_left_update_pattern_untyped)
using assms unfolding p_vars_def by auto

lemma assertion_footprint_right_update_pattern:
  assumes "Y \<subseteq> X \<union> set (p_vars pat)"
  assumes "assertion_footprint_right Y P"
  shows "assertion_footprint_right X (\<lambda>m m'. P m (memory_update_pattern m' pat x))"
unfolding memory_update_pattern_def
apply (rule assertion_footprint_right_update_pattern_untyped)
using assms unfolding p_vars_def by auto

lemma rskip_rule [simp]:
  assumes "\<forall>m m'. P m m' \<longrightarrow> Q m m'"
  shows "rhoare P skip skip Q"
  using assms by (simp add: rhoare_untyped RHL_Untyped.rskip_rule)

lemma rskip_rule_strict: "rhoare P skip skip P"
  by (simp add: rhoare_untyped RHL_Untyped.rskip_rule)

lemma obseq_context_as_rule:
  fixes X defines "eq == \<lambda>(m1::memory) m2::memory. \<forall>x::variable_untyped\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  assumes obseq: "obseq_context X C"
  assumes rh: "rhoare eq c d eq"
  shows "rhoare eq (C c) (C d) eq"
using assms unfolding obseq_context_def obs_eq_def eq_def by auto

lemma obseq_context_seq:
  assumes "obseq_context X C1"
  assumes "obseq_context X C2"
  shows "obseq_context X (\<lambda>c. seq (C1 c) (C2 c))"
proof -
  define eq where "eq \<equiv> \<lambda>(m1::memory) m2::memory. \<forall>x::variable_untyped\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  note eq = eq_def[symmetric]
  {fix c d assume rh: "rhoare eq c d eq"
  have "rhoare eq (seq (C1 c) (C2 c)) (seq (C1 d) (C2 d)) eq"
    apply (rule rseq_rule[where Q=eq])
     apply (rule obseq_context_as_rule[OF assms(1), unfolded eq])
     close (fact rh)
    apply (rule obseq_context_as_rule[OF assms(2), unfolded eq])
    by (fact rh)}
  thus ?thesis
    unfolding obseq_context_def obs_eq_def eq_def by simp
qed

lemma obseq_context_ifte:
  assumes C1: "obseq_context X C1"
  assumes C2: "obseq_context X C2"
  assumes vars: "set (e_vars e) \<subseteq> X"
  shows "obseq_context X (\<lambda>c. ifte e (C1 c) (C2 c))"
proof -
  define eq where "eq \<equiv> \<lambda>(m1::memory) m2::memory. \<forall>x::variable_untyped\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  have foot: "\<And>m1 m2. eq m1 m2 \<Longrightarrow> e_fun e m1 = e_fun e m2" unfolding eq_def apply (rule e_fun_footprint) using vars by auto
  note eq = eq_def[symmetric]
  {fix c d assume rh: "rhoare eq c d eq"
  have "rhoare eq (ifte e (C1 c) (C2 c)) (ifte e (C1 d) (C2 d)) eq"
    apply (rule rif_rule)
      close (fact foot)
     apply (rule rconseq_rule[where P'=eq and Q'=eq]) close simp close simp
     apply (rule obseq_context_as_rule[OF C1, unfolded eq])
     close (fact rh)
    apply (rule rconseq_rule[where P'=eq and Q'=eq]) close simp close simp
    apply (rule obseq_context_as_rule[OF C2, unfolded eq])
    by (fact rh)}
  thus ?thesis
    unfolding obseq_context_def obs_eq_def eq_def by simp
qed

lemma obseq_context_while:
  assumes C1: "obseq_context X C1"
  assumes vars: "set (e_vars e) \<subseteq> X"
  shows "obseq_context X (\<lambda>c. Lang_Typed.while e (C1 c))"
proof -
  define eq where "eq \<equiv> \<lambda>m1 m2::memory. \<forall>x::variable_untyped\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  have foot: "\<And>m1 m2. eq m1 m2 \<Longrightarrow> e_fun e m1 = e_fun e m2" unfolding eq_def apply (rule e_fun_footprint) using vars by auto
  note eq = eq_def[symmetric]
  {fix c d assume rh: "rhoare eq c d eq"
  have "rhoare eq (Lang_Typed.while e (C1 c)) (Lang_Typed.while e (C1 d)) eq"
    apply (rule rwhile_rule[where I=eq])
       apply (rule rconseq_rule[where P'=eq and Q'=eq]) close simp close simp
       apply (rule obseq_context_as_rule[OF C1, unfolded eq])
       close (fact rh)
      using foot by auto}
  thus ?thesis
    unfolding obseq_context_def obs_eq_def eq_def by simp
qed

lemma self_obseq_vars:
  assumes vars: "set(vars c) \<subseteq> X"
  assumes YX: "Y \<subseteq> X"
  shows "obs_eq X Y c c"
unfolding obs_eq_obs_eq_untyped
apply (rule self_obseq_vars_untyped)
using assms unfolding vars_def by auto

lemma self_obs_eq_callproc:
  assumes YX: "Y \<subseteq> X \<union> set (p_vars x)"
  assumes bodyX: "set (vars (p_body p)) \<subseteq> X \<union> {x. \<not> vu_global x}"
  assumes retX: "set (e_vars (p_return p)) \<subseteq> X \<union> {x. \<not> vu_global x}"
  assumes argsX: "set (p_vars (p_arg p)) \<subseteq> X \<union> {x. \<not> vu_global x}"
  assumes aX: "set (e_vars y) \<subseteq> X"
  shows "obs_eq X Y (callproc x p y) (callproc x p y)"
proof -
  obtain body args ret where p: "mk_procedure_untyped p = Proc body args ret"
    using mk_procedure_untyped_def by blast
  hence p_body: "Rep_program (p_body p) = body"
    and p_return: "mk_expression_untyped (p_return p) = ret"
    and p_args: "Rep_pattern (p_arg p) = args"
    by (simp_all add: mk_procedure_untyped_def)
  show ?thesis
    unfolding obs_eq_obs_eq_untyped apply (simp add: p)
    apply (rule self_obs_eq_callproc_untyped)
        close (metis YX p_vars_def)
       using bodyX unfolding vars_def p_body close
      using retX mk_expression_untyped_vars p_return close
     close (metis argsX p_args p_vars_def)
    by (simp add: aX)
qed

lemma obseq_context_empty:
  shows "obseq_context X (\<lambda>c. c)"
unfolding obseq_context_def by simp

lemma obseq_context_assign:
  assumes "set (p_vars x) \<subseteq> X"
  assumes "set (e_vars e) \<subseteq> X"
  shows "obseq_context X (\<lambda>c. assign x e)"
unfolding obseq_context_def apply rule+ apply (thin_tac _)
apply (rule self_obseq_vars)
using assms by auto

lemma obseq_context_skip: "obseq_context X (\<lambda>c. Lang_Typed.skip)"
  unfolding obseq_context_def apply auto unfolding obs_eq_def
  by (simp add: rhoare_untyped RHL_Untyped.rskip_rule)

lemma obseq_context_sample:
  assumes "set (p_vars x) \<subseteq> X"
  assumes "set (e_vars e) \<subseteq> X"
  shows "obseq_context X (\<lambda>c. sample x e)"
unfolding obseq_context_def apply rule+ apply (thin_tac _)
apply (rule self_obseq_vars)
using assms by auto

lemma obseq_context_callproc_allglobals:
  fixes X' defines "X == X' \<union> Collect vu_global"
  assumes "set (p_vars x) \<subseteq> X"
  assumes "set (e_vars a) \<subseteq> X"
  shows "obseq_context X (\<lambda>c. callproc x p a)"
unfolding obseq_context_def apply rule+ apply (thin_tac _)
unfolding obs_eq_obs_eq_untyped
apply (rule self_obseq_vars_untyped)
using assms unfolding p_vars_def
by (auto simp: vars_proc_untyped_global)

lemma hoare_obseq_replace_ctx:
  assumes C: "obseq_context X C"
  assumes Q: "assertion_footprint X Q"
  assumes eq: "obs_eq' X c d"
  assumes hoare: "hoare P (C d) Q"
  shows "hoare P (C c) Q"
proof -
  let ?eq = "\<lambda>m1 m2. \<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  let ?c = "Rep_program (C c)"
  let ?d = "Rep_program (C d)"
  have "obs_eq' X (C c) (C d)"
    unfolding obs_eq'_def obs_eq_def
    apply (rule obseq_context_as_rule[OF C])
    using eq unfolding obs_eq'_def obs_eq_def by assumption
  hence "obs_eq_untyped X X ?c ?d"
    by (simp add: obs_eq'_def obs_eq_obs_eq_untyped)
  moreover have "hoare_untyped P ?d Q"
    using hoare hoare_untyped by auto
  ultimately have "hoare_untyped P ?c Q"
    using Q by (rule hoare_obseq_replace_untyped[rotated])
  thus ?thesis unfolding hoare_untyped by assumption
qed

lemma rhoare_left_obseq_replace:
  assumes ctx: "obseq_context X C"
  assumes foot: "assertion_footprint_left X Q"
  assumes obseq: "obs_eq' X c d"
  assumes rhoare: "rhoare P (C d) (c') Q"
  shows "rhoare P (C c) (c') Q"
proof -
  have obseqCc: "obs_eq' X (C c) (C d)"
    using obseq ctx unfolding obseq_context_def obs_eq'_def obs_eq_def by simp
  note obseqCc' = obseqCc[unfolded obs_eq'_def obs_eq_def]
  show ?thesis
    apply (rule rtrans_rule[OF _ _ obseqCc' rhoare])
     close
    using foot by (auto simp: assertion_footprint_left_def)
qed

lemma rhoare_right_obseq_replace:
  assumes "obseq_context X C"
  assumes "assertion_footprint_right X Q"
  assumes "obs_eq' X c d"
  assumes "rhoare P  (c') (C d) Q"
  shows "rhoare P  (c') (C c) Q"
apply (rule rsymmetric_rule)
apply (rule rhoare_left_obseq_replace[where C=C])
   close (fact assms(1))
  using assms(2) unfolding assertion_footprint_left_def assertion_footprint_right_def close auto
 close (fact assms(3))
apply (rule rsymmetric_rule)
by (fact assms(4))

lemma program_footprint_vars: "program_footprint (set(vars p)) p"
  using program_untyped_footprint_vars
  unfolding program_footprint_def program_untyped_footprint_def vars_def denotation_def.

lemma seq_swap2:
  assumes "set (vars a) \<inter> set (write_vars b) = {}"
  assumes "set (vars b) \<inter> set (write_vars a) = {}"
  shows "denotation (seq a b) = denotation (seq b a)"
proof -
  define A where "A \<equiv> set(vars a)"
  define B where "B \<equiv> set(vars b)"
  define R where "R \<equiv> UNIV - set(write_vars a) - set(write_vars b)"
  have "program_readonly R a"
    using R_def denotation_readonly_def program_readonly_def program_readonly_write_vars by auto
  moreover have "program_readonly R b"
    using R_def denotation_readonly_def program_readonly_def program_readonly_write_vars by auto
  moreover have "program_footprint A a"
    using A_def program_footprint_vars by auto
  moreover have "program_footprint B b"
    using B_def program_footprint_vars by auto
  moreover have ABR: "A\<inter>B\<subseteq>R"
    unfolding A_def B_def R_def using assms by auto
  ultimately show ?thesis
    by (rule seq_swap)
qed

lemma frame_rule:
  assumes foot1: "assertion_footprint_left X R" and foot2: "assertion_footprint_right Y R"
  assumes ro1: "program_readonly X p1" and ro2: "program_readonly Y p2"
  assumes rhoare: "rhoare P p1 p2 Q"
  shows "rhoare (\<lambda>m1 m2. P m1 m2 \<and> R m1 m2) p1 p2 (\<lambda>m1 m2. Q m1 m2 \<and> R m1 m2)"
unfolding rhoare_untyped
apply (rule frame_rule_untyped)
using assms unfolding program_readonly_def program_untyped_readonly_def denotation_def rhoare_untyped by auto

lemma callproc_equiv:
  assumes globals_V1: "set (vars_proc_global f) \<subseteq> V1"
  assumes V2V1: "V2 \<subseteq> V1"
  assumes x1V2: "set (p_vars x1) \<inter> V2 = {}"
  assumes x2V2: "set (p_vars x2) \<inter> V2 = {}"
  shows "rhoare (\<lambda>m1 m2. (\<forall>v\<in>V1. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v)
                      \<and> e_fun e1 m1 = e_fun e2 m2)
                   (callproc x1 f e1) (callproc x2 f e2)
                (\<lambda>m1 m2. (\<forall>v\<in>V2. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v)
                      \<and> memory_pattern_related x1 x2 m1 m2)"
proof (rule rhoareI, goal_cases)
case (1 m1 m2)
  hence eq_m1_m2: "memory_lookup_untyped m1 v = memory_lookup_untyped m2 v"
        if "v\<in>V1" for v
    using that by auto
  from 1 have e1e2: "e_fun e1 m1 = e_fun e2 m2" by simp
  define argval where "argval \<equiv> e_fun e1 m1"
  define m1a where "m1a \<equiv> init_locals m1"
  define m1b where "m1b \<equiv> memory_update_pattern m1a (p_arg f) argval"
  define m2a where "m2a \<equiv> init_locals m2"
  define m2b where "m2b \<equiv> memory_update_pattern m2a (p_arg f) argval"

  have eq_m12a: "memory_lookup_untyped m1a v = memory_lookup_untyped m2a v" if "v\<in>V1" for v
    using that eq_m1_m2 by (simp add: Rep_init_locals m1a_def m2a_def)
  have eq_m12a_loc: "memory_lookup_untyped m1a v = memory_lookup_untyped m2a v" if "\<not> vu_global v" for v
    using that by (simp add: Rep_init_locals m1a_def m2a_def)
  have eq_m12b_V1: "memory_lookup_untyped m1b v = memory_lookup_untyped m2b v" if "v\<in>V1" for v
    unfolding m1b_def m2b_def memory_update_pattern_def using that eq_m12a
    by (metis lookup_memory_update_untyped_pattern_getter memory_lookup_update_pattern_notsame)
  have eq_m12b_loc: "memory_lookup_untyped m1b v = memory_lookup_untyped m2b v" if "\<not> vu_global v" for v
    unfolding m1b_def m2b_def memory_update_pattern_def using eq_m12a_loc that
    by (metis lookup_memory_update_untyped_pattern_getter memory_lookup_update_pattern_notsame)
(*   have "memory_lookup_untyped m1b v = memory_lookup_untyped m2b v" if "v \<in> set(p_vars(p_arg f))" for v
    using that by auto *)

  define V1loc where "V1loc \<equiv> V1 \<union> {x. \<not> vu_global x}"

  have vars_V1loc: "set(vars(p_body f)) \<subseteq> V1loc"
    using globals_V1 unfolding vars_proc_global_def V1loc_def by auto
  with eq_m12b_V1 eq_m12b_loc
  have eq_m12b: "memory_lookup_untyped m1b v = memory_lookup_untyped m2b v" if "v \<in> V1loc" for v
    using that V1loc_def by auto

  have "obs_eq V1loc V1loc (p_body f) (p_body f)"
    apply (rule self_obseq_vars)
    using vars_V1loc by (simp_all add: vars_def)

  then obtain \<mu> where \<mu>fst: "apply_to_distr fst \<mu> = denotation (p_body f) m1b"
                  and \<mu>snd: "apply_to_distr snd \<mu> = denotation (p_body f) m2b"
                  and \<mu>post: "\<And>m1' m2' x. (m1',m2') \<in> support_distr \<mu> \<Longrightarrow> x\<in>V1loc \<Longrightarrow>
                                memory_lookup_untyped m1' x = memory_lookup_untyped m2' x"
    unfolding obs_eq_def rhoare_def
    using eq_m12b by blast

  define finalize where "finalize \<equiv> \<lambda>m x. \<lambda>m'. let res = e_fun (p_return f) m'; m' = restore_locals m m' in memory_update_pattern m' x res"

  define \<mu>' where "\<mu>' \<equiv> apply_to_distr (\<lambda>(m1',m2'). (finalize m1 x1 m1', finalize m2 x2 m2')) \<mu>"

  have "apply_to_distr fst \<mu>' = apply_to_distr (\<lambda>m1'. finalize m1 x1 m1') (apply_to_distr fst \<mu>)"
    unfolding \<mu>'_def by (simp add: split_def)
  also have "\<dots> = apply_to_distr (\<lambda>m1'. finalize m1 x1 m1') (denotation (p_body f) m1b)"
    using \<mu>fst by simp
  also have "\<dots> = denotation (callproc x1 f e1) m1"
    unfolding argval_def m1a_def m1b_def finalize_def
    apply (subst denotation_callproc) by auto
  finally have \<mu>'fst: "apply_to_distr fst \<mu>' = denotation (callproc x1 f e1) m1" by assumption

  have "apply_to_distr snd \<mu>' = apply_to_distr (\<lambda>m2'. finalize m2 x2 m2') (apply_to_distr snd \<mu>)"
    unfolding \<mu>'_def by (simp add: split_def)
  also have "\<dots> = apply_to_distr (\<lambda>m2'. finalize m2 x2 m2') (denotation (p_body f) m2b)"
    using \<mu>snd by simp
  also have "\<dots> = denotation (callproc x2 f e2) m2"
    unfolding argval_def m2a_def m2b_def finalize_def e1e2
    apply (subst denotation_callproc) by auto
  finally have \<mu>'snd: "apply_to_distr snd \<mu>' = denotation (callproc x2 f e2) m2"
    by assumption

  have \<mu>'post: "\<And>x. x\<in>V2 \<Longrightarrow> memory_lookup_untyped m1' x = memory_lookup_untyped m2' x"
   and \<mu>'post2: "memory_pattern_related x1 x2 m1' m2'"
               if supp: "(m1',m2') \<in> support_distr \<mu>'"
               for m1' m2'
  proof -
    from supp obtain m1'' m2'' where
        m1': "m1' = finalize m1 x1 m1''" and m2': "m2' = finalize m2 x2 m2''" and "(m1'',m2'') \<in> support_distr \<mu>"
        unfolding \<mu>'_def by auto
    hence eq_m12'': "\<And>x. x\<in>V1loc \<Longrightarrow> memory_lookup_untyped m1'' x = memory_lookup_untyped m2'' x"
      using \<mu>post by simp

    have ret_V1loc: "set (e_vars (p_return f)) \<subseteq> V1loc"
      unfolding V1loc_def using globals_V1 unfolding vars_proc_global_def by auto
    have ret12: "e_fun (p_return f) m1'' = e_fun (p_return f) m2''"
      apply (rule e_fun_footprint)
      apply (rule eq_m12'')
      using ret_V1loc by auto

    show "memory_pattern_related x1 x2 m1' m2'"
      apply (rule memory_pattern_relatedI)
      unfolding m1' m2' finalize_def ret12 by auto

    show "memory_lookup_untyped m1' x = memory_lookup_untyped m2' x" if "x\<in>V2" for x
    proof -
      define ret where "ret \<equiv> e_fun (p_return f) m1''"
      define m1l where "m1l \<equiv> restore_locals m1 m1''"
      define m2l where "m2l \<equiv> restore_locals m2 m2''"
      have "m1' = memory_update_pattern m1l x1 ret"
        unfolding ret_def m1' finalize_def m1l_def by auto
      have "m2' = memory_update_pattern m2l x2 ret"
        unfolding ret_def m2' finalize_def m2l_def ret12 by auto

      have xx1: "x \<notin> set (p_vars x1)" and xx2: "x \<notin> set (p_vars x2)"
        using x1V2 x2V2 that by auto

      have "memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
        using V2V1 eq_m1_m2 that by blast
      moreover have "memory_lookup_untyped m1'' x = memory_lookup_untyped m2'' x"
        using V1loc_def V2V1 eq_m12'' that by auto
      ultimately have "memory_lookup_untyped (restore_locals m1 m1'') x = memory_lookup_untyped (restore_locals m2 m2'') x"
        unfolding Rep_restore_locals by simp

      then have "memory_lookup_untyped (memory_update_pattern (restore_locals m1 m1'') x1 ret) x =
                 memory_lookup_untyped (memory_update_pattern (restore_locals m2 m2'') x2 ret) x"
        unfolding memory_update_pattern_def
        apply (subst memory_lookup_update_pattern_notsame) close (metis p_vars_def xx1)
        apply (subst memory_lookup_update_pattern_notsame) close (metis p_vars_def xx2)
        by assumption
      then show ?thesis
        unfolding m1' m2' finalize_def ret_def[symmetric] ret12[symmetric] by simp
    qed
  qed

  from \<mu>'fst \<mu>'snd \<mu>'post \<mu>'post2 show ?case
    apply (rule_tac exI[of _ \<mu>']) by auto
qed

lemma call_rule:
  fixes globals_f1 globals_f2 and x1::"'x1::prog_type pattern" and x2::"'x2::prog_type pattern"
    and y1::"'y1::prog_type expression" and y2::"'y2::prog_type expression"
    and res1::"'x1 variable" and res2::"'x2 variable" and A B P Q
  assumes globals_f1: "set(write_vars_proc_global f1) \<subseteq> set globals_f1"
  assumes globals_f2: "set(write_vars_proc_global f2) \<subseteq> set globals_f2"
  assumes args1_nin_f1: "mk_variable_untyped args1 \<notin> set (vars_proc_global f1)"
  assumes args2_nin_f2: "mk_variable_untyped args2 \<notin> set (vars_proc_global f2)"
  assumes footQ1: "assertion_footprint_left (-{mk_variable_untyped args1}) Q"
  assumes footQ2: "assertion_footprint_right (-{mk_variable_untyped args2}) Q"
  assumes f1f2: "rhoare P
              (callproc (variable_pattern res1) f1 (var_expression args1))
              (callproc (variable_pattern res2) f2 (var_expression args2))
              Q"
  defines "QB == (\<lambda>m1 m2. (\<forall>gL gR xL xR x'L x'R.
                    gL \<in> t_domain (pu_type (list_pattern_untyped globals_f1))
                \<longrightarrow> gR \<in> t_domain (pu_type (list_pattern_untyped globals_f2))
                \<longrightarrow> Q (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f1) gL) (list_pattern_untyped (p_vars x1)) x'L) res1 xL)
                       (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f2) gR) (list_pattern_untyped (p_vars x2)) x'R) res2 xR)
                \<longrightarrow> B (memory_update_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f1) gL) x1 xL)
                      (memory_update_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f2) gR) x2 xR)))"
  defines "C == (\<lambda>m1 m2. P (memory_update m1 args1 (e_fun y1 m1)) (memory_update m2 args2 (e_fun y2 m2)) \<and> QB m1 m2)"
  assumes p1p2: "rhoare A p1 p2 C"
  shows "rhoare A (seq p1 (callproc x1 f1 y1)) (seq p2 (callproc x2 f2 y2)) B"
proof -

(* Proof plan:

- Show:  rhoare    P{args/y}  (callproc x=f(y))  Q{x/res}    (substitution)   \<longrightarrow>  rhoareP'Q'
- Show:  footprint QB   disjoint of   callproc x=f(y)
- Show:  rhoare    C=P{args/y}\<and>QB     (callproc x=f(y))   Q{res/x}\<and>QB   (frame_rule) \<longrightarrow> rhoareQB
- Show:  Q{res/x} \<and> QB \<Longrightarrow> B
- Show:  rhoare    C     (callproc x=f(y))   B    (conseq)
- Show:  rhoare    A     (p; callproc x=f(y))   B    (seq with assm)

*)
  define P' where "P' \<equiv> \<lambda>m1 m2. P (memory_update m1 args1 (e_fun y1 m1)) (memory_update m2 args2 (e_fun y2 m2))"
  define x1l where "x1l \<equiv> list_pattern_untyped (p_vars x1)"
  define x2l where "x2l \<equiv> list_pattern_untyped (p_vars x2)"
  define Q' where "Q' \<equiv> \<lambda>m1 m2. (\<exists>res1_val res2_val x1_val x2_val.
      memory_update_pattern m1 x1 res1_val = m1 \<and> memory_update_pattern m2 x2 res2_val = m2 \<and>
      Q (memory_update (memory_update_untyped_pattern m1 x1l x1_val) res1 res1_val) (memory_update (memory_update_untyped_pattern m2 x2l x2_val) res2 res2_val))"

  define VV1 where "VV1 \<equiv> - {mk_variable_untyped args1}"
  define VV2 where "VV2 \<equiv> UNIV - {mk_variable_untyped args1, mk_variable_untyped res1} - set(p_vars x1)"
  define VV1' where "VV1' \<equiv> - {mk_variable_untyped args2}"
  define VV2' where "VV2' \<equiv> UNIV - {mk_variable_untyped args2, mk_variable_untyped res2} - set(p_vars x2)"

  have y1_VV1: "mk_variable_untyped (args1::'y1 variable) \<notin> VV1" unfolding VV1_def by simp
  have vv1_1: "set (vars_proc_global f1) \<subseteq> VV1" unfolding VV1_def using args1_nin_f1 by auto

  have y2_VV1': "mk_variable_untyped (args2::'y2 variable) \<notin> VV1'" unfolding VV1'_def by simp
  have x1: "set (vars_proc_global f2) \<subseteq> VV1'" unfolding VV1'_def using args2_nin_f2 by auto

  have vv1_2: "VV2 \<subseteq> VV1" unfolding VV2_def VV1_def by auto
  have x1_vv2: "set (p_vars x1) \<inter> VV2 = {}" unfolding VV2_def by auto
  have res_vv2: "set (p_vars (variable_pattern res1 :: 'x1 pattern)) \<inter> VV2 = {}" unfolding VV2_def by auto

  have x2: "VV2' \<subseteq> VV1'" unfolding VV2'_def VV1'_def by auto
  have x3: "set (p_vars (variable_pattern res2 :: 'x2 pattern)) \<inter> VV2' = {}" unfolding VV2'_def by auto
  have x4: "set (p_vars x2) \<inter> VV2' = {}" unfolding VV2'_def by auto

  have foot_Q1: "assertion_footprint_left (insert (mk_variable_untyped (res1::'x1 variable)) VV2 \<union> set(p_vars x1)) Q"
    apply (rule assertion_footprint_left_mono[OF _ footQ1]) unfolding VV2_def by auto

  have foot_Q2: "assertion_footprint_right (insert (mk_variable_untyped (res2::'x2 variable)) VV2' \<union> set(p_vars x2)) Q"
    apply (rule assertion_footprint_right_mono[OF _ footQ2]) unfolding VV2'_def by auto

  have x1_f1_res_f1: "rhoare (\<lambda>m1 m2. (\<forall>v\<in>VV1. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v) \<and> e_fun y1 m1 = e_fun (var_expression args1) m2)
          (callproc x1 f1 y1) (callproc (variable_pattern res1) f1 (var_expression args1))
        (\<lambda>m1 m2. (\<forall>v\<in>VV2. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v) \<and> memory_pattern_related x1 (variable_pattern res1) m1 m2)"
    apply (rule callproc_equiv)
    using vv1_1 vv1_2 x1_vv2 res_vv2 by auto

  have res_f2_x2_f2: "rhoare (\<lambda>m1 m2. (\<forall>v\<in>VV1'. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v) \<and> e_fun (var_expression args2) m1 = e_fun y2 m2)
        (callproc (variable_pattern res2) f2 (var_expression args2)) (callproc x2 f2 y2)
          (\<lambda>m1 m2. (\<forall>v\<in>VV2'. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v) \<and> memory_pattern_related (variable_pattern res2) x2 m1 m2)"
    apply (rule callproc_equiv)
    using x1 x2 x3 x4 by auto

  have t3: "\<exists>m m'. ((\<forall>v\<in>VV1. memory_lookup_untyped m1 v = memory_lookup_untyped m v) \<and>
                     e_fun y1 m1 = e_fun (var_expression args1) m) \<and>
                    P m m' \<and>
                    (\<forall>v\<in>VV1'. memory_lookup_untyped m' v = memory_lookup_untyped m2 v) \<and> e_fun (var_expression args2) m' = e_fun y2 m2"
                    if "P' m1 m2" for m1 m2
    apply (rule exI[of _ "memory_update m1 args1 (e_fun y1 m1)"], rule exI[of _ "memory_update m2 args2 (e_fun y2 m2)"])
    using y1_VV1 y2_VV1' that unfolding P'_def by simp

  have t4: "Q' m1 m2"
       if eq2: "\<forall>v\<in>VV2'. memory_lookup_untyped m' v = memory_lookup_untyped m2 v"
       and res_x2: "memory_pattern_related (variable_pattern res2) x2 m' m2"
       and eq1: "\<forall>v\<in>VV2. memory_lookup_untyped m1 v = memory_lookup_untyped m v"
       and x1_res: "memory_pattern_related x1 (variable_pattern res1) m1 m"
       and "Q m m'" for m1 m2 m m'
  proof -
    define res1_val where "res1_val \<equiv> memory_lookup m res1 :: 'x1"
    define res2_val where "res2_val \<equiv> memory_lookup m' res2 :: 'x2"
    define x1_val where "x1_val \<equiv> eu_fun (list_expression_untyped (p_vars x1)) m"
    define x2_val where "x2_val \<equiv> eu_fun (list_expression_untyped (p_vars x2)) m'"

    from x1_res
    obtain v where x1_v: "m1 = memory_update_pattern m1 x1 v" and res_v: "m = memory_update_pattern m (variable_pattern res1) v"
      unfolding memory_pattern_related_def by auto
    have "v = res1_val" unfolding res1_val_def apply (subst res_v) by simp
    have x1_res1_val: "memory_update_pattern m1 x1 res1_val = m1" using x1_v `v=res1_val` by simp

    from res_x2
    obtain w where res_w: "m' = memory_update_pattern m' (variable_pattern res2) w" and x2_w: "m2 = memory_update_pattern m2 x2 w"
      unfolding memory_pattern_related_def by auto
    have "w = res2_val" unfolding res2_val_def apply (subst res_w) by simp
    have x2_res2_val: "memory_update_pattern m2 x2 res2_val = m2" using x2_w `w=res2_val` by simp

    have "Q (memory_update (memory_update_untyped_pattern m1 x1l x1_val) res1 res1_val) (memory_update (memory_update_untyped_pattern m2 x2l x2_val) res2 res2_val) = Q m (memory_update (memory_update_untyped_pattern m2 x2l x2_val) res2 res2_val)"
      apply (rule assertion_footprint_leftE[OF foot_Q1])
      using res1_val_def eq1 apply auto
       close (metis list_pattern_untyped_list_expression_untyped lookup_memory_update_untyped_pattern_getter memory_lookup_update_pattern_notsame x1_val_def x1l_def)
      by (metis list_pattern_untyped_list_expression_untyped lookup_memory_update_untyped_pattern_getter pu_vars_list_pattern_untyped x1_val_def x1l_def)
    also have "\<dots> = Q m m'"
      apply (rule assertion_footprint_rightE[OF foot_Q2])
      using res2_val_def eq2 apply auto
       close (metis list_pattern_untyped_list_expression_untyped lookup_memory_update_untyped_pattern_getter memory_lookup_update_pattern_notsame x2_val_def x2l_def)
      by (metis list_pattern_untyped_list_expression_untyped lookup_memory_update_untyped_pattern_getter pu_vars_list_pattern_untyped x2_val_def x2l_def)
  finally have Q': "Q (memory_update (memory_update_untyped_pattern m1 x1l x1_val) res1 res1_val)
                      (memory_update (memory_update_untyped_pattern m2 x2l x2_val) res2 res2_val)"
    using that by simp

    from Q' x1_res1_val x2_res2_val show ?thesis unfolding Q'_def by auto
  qed

  have rhoareP'Q': "rhoare P' (callproc x1 f1 y1) (callproc x2 f2 y2) Q'"
    apply (rule rtrans3_rule[OF _ _ x1_f1_res_f1 f1f2 res_f2_x2_f2])
     close (rule t3, simp)
    by (rule t4, simp_all)

  have foot_QB1: "assertion_footprint_left (UNIV - set globals_f1 - set (p_vars x1)) QB"
    unfolding QB_def
    apply (rule assertion_footprint_left_forall)+
    apply (rule assertion_footprint_left_op2[where f="(\<longrightarrow>)", OF assertion_footprint_left_const])
    apply (rule assertion_footprint_left_op2[where f="(\<longrightarrow>)", OF assertion_footprint_left_const])
    apply (rule assertion_footprint_left_op2[where f="(\<longrightarrow>)"])
     apply (rule assertion_footprint_left_update_pattern_untyped[where Y="UNIV - set (p_vars x1)"])
      close (simp, blast)
     apply (rule assertion_footprint_left_update_pattern_untyped[where Y="UNIV"])
      close simp
     apply (rule assertion_footprint_left_update[where Y="UNIV"])
      close
     close (rule assertion_footprint_left_UNIV)
    apply (rule assertion_footprint_left_update_pattern_untyped[where Y="UNIV - set (p_vars x1)"])
     close (simp, blast)
    apply (rule assertion_footprint_left_update_pattern[where Y="UNIV"])
     close simp
    by (rule assertion_footprint_left_UNIV)

  have foot_QB2: "assertion_footprint_right (UNIV - set globals_f2 - set (p_vars x2)) QB"
    unfolding QB_def
    apply (rule assertion_footprint_right_forall)+
    apply (rule assertion_footprint_right_op2[where f="(\<longrightarrow>)", OF assertion_footprint_right_const])
    apply (rule assertion_footprint_right_op2[where f="(\<longrightarrow>)", OF assertion_footprint_right_const])
    apply (rule assertion_footprint_right_op2[where f="(\<longrightarrow>)"])
     apply (rule assertion_footprint_right_update_pattern_untyped[where Y="UNIV - set (p_vars x2)"])
      close (simp, blast)
     apply (rule assertion_footprint_right_update_pattern_untyped[where Y="UNIV"])
      close simp
     apply (rule assertion_footprint_right_update[where Y="UNIV"])
      close
     close (rule assertion_footprint_right_UNIV)
    apply (rule assertion_footprint_right_update_pattern_untyped[where Y="UNIV - set (p_vars x2)"])
     close (simp, blast)
    apply (rule assertion_footprint_right_update_pattern[where Y="UNIV"])
     close simp
    by (rule assertion_footprint_right_UNIV)

  have ro_f1: "program_readonly (UNIV - set globals_f1 - set (p_vars x1)) (callproc x1 f1 y1)"
    apply (rule program_readonly_mono[rotated])
     close (rule program_readonly_write_vars)
    using globals_f1 by auto
  have ro_f2: "program_readonly (UNIV - set globals_f2 - set (p_vars x2)) (callproc x2 f2 y2)"
    apply (rule program_readonly_mono[rotated])
     close (rule program_readonly_write_vars)
    using globals_f2 by auto

  have rhoareQB: "rhoare (\<lambda>m1 m2. P' m1 m2 \<and> QB m1 m2) (callproc x1 f1 y1) (callproc x2 f2 y2) (\<lambda>m1 m2. Q' m1 m2 \<and> QB m1 m2)"
    apply (rule frame_rule)
        close (fact foot_QB1)
       close (fact foot_QB2)
      close (fact ro_f1)
     close (fact ro_f2)
    by (fact rhoareP'Q')

  have QB_Q: "B m1 m2" if Q'm1m2: "Q' m1 m2" and QBm1m2: "QB m1 m2" for m1 m2
  proof -
    from Q'm1m2 obtain res1_val res2_val x1_val x2_val
      where ux1: "memory_update_pattern m1 x1 res1_val = m1"
        and ux2: "memory_update_pattern m2 x2 res2_val = m2"
        and Q: "Q (memory_update (memory_update_untyped_pattern m1 x1l x1_val) res1 res1_val)
                  (memory_update (memory_update_untyped_pattern m2 x2l x2_val) res2 res2_val)"
      unfolding Q'_def by auto

    define gL where "gL \<equiv> eu_fun (list_expression_untyped globals_f1) m1"
    define gR where "gR \<equiv> eu_fun (list_expression_untyped globals_f2) m2"
    have gL_type: "gL \<in> t_domain (pu_type (list_pattern_untyped globals_f1))"
      by (metis eu_fun_type gL_def type_list_expression_list_pattern)
    have gR_type: "gR \<in> t_domain (pu_type (list_pattern_untyped globals_f2))"
      by (metis eu_fun_type gR_def type_list_expression_list_pattern)

    have Q2: "Q (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f1) gL) x1l x1_val) res1 res1_val)
                (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f2) gR) x2l x2_val) res2 res2_val)"
      unfolding gL_def apply (subst list_pattern_untyped_list_expression_untyped)
      unfolding gR_def apply (subst list_pattern_untyped_list_expression_untyped)
      unfolding ux1 ux2 by (fact Q)

    have B2: "B (memory_update_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f1) gL) x1 res1_val)
                (memory_update_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f2) gR) x2 res2_val)"
      apply (rule QBm1m2[unfolded QB_def, folded x1l_def x2l_def, rule_format, of gL gR x1_val res1_val x2_val res2_val])
        using gL_type gR_type close 2
      unfolding QB_def using Q2 by simp

    show "B m1 m2"
      using B2
      unfolding gL_def apply (subst (asm) list_pattern_untyped_list_expression_untyped)
      unfolding gR_def apply (subst (asm) list_pattern_untyped_list_expression_untyped)
      unfolding ux1 ux2 by simp
  qed

  have rhoareCQ: "rhoare (\<lambda>m1 m2. C m1 m2) (callproc x1 f1 y1) (callproc x2 f2 y2) B"
    apply (rule rconseq_rule[rotated -1])
      close (fact rhoareQB)
     unfolding C_def P'_def close
    using QB_Q by auto

  show ?thesis
    apply (rule rseq_rule)
     close (fact p1p2)
    by (fact rhoareCQ)
qed

lemma callproc_split_args_equiv:
  assumes fX: "set (vars_proc_global f) \<subseteq> X"
  assumes eX: "set (e_vars e) \<subseteq> X"
  assumes Y: "Y \<subseteq> X \<union> set (p_vars p)"
  assumes xX: "mk_variable_untyped x \<notin> X"
  shows "obs_eq X Y (callproc p f e) (seq (assign (variable_pattern x) e) (callproc p f (var_expression x)))"
proof -
  define Y' where "Y' \<equiv> Y - set (p_vars p)"

  have callproc_eq: "rhoare (\<lambda>m1 m2. (\<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x) \<and> e_fun e m1 = e_fun (var_expression x) m2)
    (callproc p f e) (callproc p f (var_expression x)) (\<lambda>m1 m2. (\<forall>v\<in>Y'. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v)
                      \<and> memory_pattern_related p p m1 m2)"
    apply (rule callproc_equiv) close (rule fX)
    using Y'_def Y by auto

  hence rh_call: "rhoare (\<lambda>m1 m2. (\<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x) \<and> e_fun e m1 = e_fun (var_expression x) m2)
    (callproc p f e) (callproc p f (var_expression x)) (\<lambda>m1 m2. (\<forall>v\<in>Y. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v))"
    apply (rule rconseq_rule[rotated -1])
     close auto
    unfolding Y'_def
    by (metis DiffI lookup_memory_update_untyped_pattern_getter memory_pattern_related_def memory_update_pattern_def p_vars_def)

  have impl1: "memory_lookup_untyped m y = memory_lookup_untyped (memory_update_pattern m' (variable_pattern x) (e_fun e m')) y"
           if "y\<in>X" and Y'_eq: "\<And>v. v\<in>X \<Longrightarrow> memory_lookup_untyped m v = memory_lookup_untyped m' v"
           for m m' y
    using xX that by auto

  have impl2: "(e_fun e m = e_fun (var_expression x) (memory_update_pattern m' (variable_pattern x) (e_fun e m')))"
           if Y'_eq: "\<And>v. v\<in>X \<Longrightarrow> memory_lookup_untyped m v = memory_lookup_untyped m' v"
           for m m'
    using eX apply auto
    by (meson e_fun_footprint subsetCE that)

  have "obs_eq X Y (seq Lang_Typed.skip (callproc p f e)) (seq (assign (variable_pattern x) e) (callproc p f (var_expression x)))"
    unfolding obs_eq_def
    apply (rule rseq_rule[rotated])
     close (fact rh_call)
    apply (rule assign_right_rule)
    using impl1 impl2 by metis

  thus "obs_eq X Y (callproc p f e) (seq (assign (variable_pattern x) e) (callproc p f (var_expression x)))"
    unfolding obs_eq_def by (simp add: rhoare_def)
qed

lemma callproc_split_result_equiv:
  assumes fX: "set (vars_proc_global f) \<subseteq> X"
  assumes eX: "set (e_vars e) \<subseteq> X"
  assumes Y: "Y \<subseteq> X \<union> set (p_vars p)"
  assumes xY: "mk_variable_untyped x \<notin> Y"
  shows "obs_eq X Y (callproc p f e) (seq (callproc (variable_pattern x) f e) (assign p (var_expression x)))"
proof -
  define Y' where "Y' \<equiv> Y - set (p_vars p)"
  have callproc_eq: "rhoare (\<lambda>m1 m2. (\<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x) \<and> e_fun e m1 = e_fun e m2)
    (callproc p f e) (callproc (variable_pattern x) f e) (\<lambda>m1 m2. (\<forall>v\<in>Y'. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v)
                      \<and> memory_pattern_related p (variable_pattern x) m1 m2)"
    apply (rule callproc_equiv) close (rule fX)
      using Y'_def Y xY by auto
  hence rh_call: "rhoare (\<lambda>m1 m2. (\<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x))
    (callproc p f e) (callproc (variable_pattern x) f e) (\<lambda>m1 m2. (\<forall>v\<in>Y'. memory_lookup_untyped m1 v = memory_lookup_untyped m2 v)
                      \<and> memory_pattern_related p (variable_pattern x) m1 m2)"
    apply (rule rconseq_rule[rotated -1])
     using eX e_fun_footprint close blast
    by simp
  have impl: "memory_lookup_untyped m y = memory_lookup_untyped (memory_update_pattern m' p (e_fun (var_expression x) m')) y"
            if "y\<in>Y" and Y'_eq: "\<And>v. v\<in>Y' \<Longrightarrow> memory_lookup_untyped m v = memory_lookup_untyped m' v" and p_rel: "memory_pattern_related p (variable_pattern x) m m'"
           for m m' y
  proof (cases "y\<in>set(p_vars p)")
    case True
      thus ?thesis using p_rel
      by (metis e_fun_var_expression lookup_memory_update_untyped_pattern_getter memory_lookup_update_same memory_pattern_related_def memory_update_pattern_def memory_update_variable_pattern p_vars_def)
    next case False
      thus ?thesis using `y\<in>Y` Y'_eq unfolding Y'_def
      by (simp add: DiffI memory_lookup_update_pattern_notsame memory_update_pattern_def p_vars_def)
  qed
  have "obs_eq X Y (seq (callproc p f e) Lang_Typed.skip) (seq (callproc (variable_pattern x) f e) (assign p (var_expression x)))"
    unfolding obs_eq_def
    apply (rule rseq_rule)
     close (fact rh_call)
    apply (rule assign_right_rule)
    using impl by auto
  thus "obs_eq X Y (callproc p f e) (seq (callproc (variable_pattern x) f e) (assign p (var_expression x)))"
    unfolding obs_eq_def by (simp add: rhoare_def)
qed

end


(*
    File:        Length.thy
    Time-stamp:  <2016-01-06T17:48:20Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory Length imports Lambda dLambda begin

definition LLength :: "i=>i" where
"LLength(M) == LTerm_rec(%x. 0, %x m r. succ(r),
                         %m n rm rn. succ(rm Un rn), M)"

definition Length :: "i=>i" where
"Length(M) == THE n. n: (INT m: M. {LLength(m)})"

lemma LLength_eqns:
  "LLength(LVar(x)) = 0"
  "LLength(LLam(x, M)) = succ(LLength(M))"
  "LLength(LApp(M, N)) = succ(LLength(M) Un LLength(N))"
apply (unfold LLength_def)
apply simp_all
done

lemma LLength_type:
  "M: LTerm ==> LLength(M): nat"
apply (erule LTerm.induct)
apply (simp_all only: LLength_eqns)
apply (assumption | rule nat_succI nat_UnI nat_0I)+
done

lemma LSkeltonEq_imp_LLength_eq:
  assumes major: "LSkeltonEq(M, N)"
  shows "LLength(M) = LLength(N)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="N" in spec)
apply (rule major [THEN LSkeltonEqD1, THEN LTerm.induct])
apply (safe elim!: LSkeltonEq_LTermEs)
apply (simp_all add: LLength_eqns)
done

lemma Length_LAQ:
  "m: LTerm ==> Length(LAQ(m)) = LLength(m)"
apply (unfold Length_def)
apply (rule the_equality)
apply (rule INT_I)
apply (rule_tac [2] not_emptyI)
apply (erule_tac [2] LAQ_self)
apply (drule LAQ_D)
apply (drule LAlphaD1 [THEN LSkeltonEq_imp_LLength_eq])
apply blast
apply (drule INT_E)
apply (erule LAQ_self)
apply (erule singletonE)
apply assumption
done

lemma Length_type:
  "M: Term ==> Length(M): nat"
apply (erule TermE)
apply hypsubst
apply (simp only: Length_LAQ)
apply (erule LLength_type)
done

lemma Length_Var:
  "x: LVariable ==> Length(Var(x)) = 0"
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemma Length_Lam:
  "[| x: LVariable; M: Term |] ==>
        Length(Lam(x, M)) = succ(Length(M))"
apply (erule TermE)+
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemma Length_App:
  "[| M: Term; N: Term |] ==>
        Length(App(M, N)) = succ(Length(M) Un Length(N))"
apply (erule TermE)+
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemmas Length_eqns = Length_Var Length_Lam Length_App

lemma Length_induct:
  assumes major: "M: Term"
  and prem:
     "!!M. [| M: Term; ALL N: Term. Length(N) < Length(M) --> P(N) |]
           ==> P(M)"
  shows "P(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac P="Length(M) = Length(M)" in rev_mp)
apply (rule_tac [2] P="%x. Length(M) = Length(x) --> x : Term --> P(x)" in major [THEN [2] bspec])
apply (rule_tac [2] P="%n. ALL M: Term. n = Length(M) --> M: Term --> P(M)" in
         major [THEN Length_type, THEN complete_induct0])
apply (rule refl)
apply safe
apply (erule prem)
apply safe
apply (erule bspec [THEN bspec, THEN mp, THEN mp])
apply (erule ltD)
apply (assumption | rule refl)+
done

lemma Term_induct2:
  assumes major: "M: Term"
  and prem1: "X: Fin(LVariable)"
  and
     "!! x . x: LVariable ==> P(Var(x))"
  and
     "!! x M . [| x: LVariable; x ~: X; M: Term; P(M) |]
          ==> P(Lam(x, M))"
  and
     "!! M N . [| M: Term; P(M); N: Term; P(N) |] ==> P(App(M, N))"
  shows "P(M)"
apply (rule major [THEN Length_induct])
apply (erule Term_cases)
apply safe
apply (rule_tac [2] prem1 [THEN [3] Infinite_LVariable_Alpha_lemma2,
          THEN bexE])
apply (erule_tac [2] asm_rl)+
apply (erule_tac [2] bexE conjE)+
apply (rotate_tac [1] 1)
apply (rotate_tac [2] 1)
apply (rotate_tac [3] 1)
prefer 2 apply simp
apply (simp_all add: Length_eqns)
apply (rule_tac [3] assms)
apply (rule_tac [2] assms)
apply (rule_tac [1] assms)
prefer 5
prefer 6
prefer 8
apply assumption+
apply (erule_tac [3] bspec [THEN mp])
apply (erule_tac [2] bspec [THEN mp])
apply (erule_tac [1] bspec [THEN mp])
apply (assumption | rule nat_into_Ord le_refl Length_type
         Un_upper1_le Un_upper2_le)+
done

lemmas Term_typechecks = Term_intros subst_type Length_type
lemmas Term_simps = Term_free_iffs Length_eqns subst_eqns FV_eqns

declare Term_typechecks [TC]
declare Term_simps [simp]

end


(*  Title:      HOL/MicroJava/J/TypeRel.thy
    Author:     David von Oheimb, Technische Universitaet Muenchen
*)

section {* Relations between Java Types *}

theory TypeRel
imports Decl
begin

-- "direct subclass, cf. 8.1.3"

inductive_set
  subcls1 :: "'c prog => (cname \<times> cname) set"
  and subcls1' :: "'c prog => cname \<Rightarrow> cname => bool" ("_ \<turnstile> _ \<prec>C1 _" [71,71,71] 70)
  for G :: "'c prog"
where
  "G \<turnstile> C \<prec>C1 D \<equiv> (C, D) \<in> subcls1 G"
  | subcls1I: "\<lbrakk>class G C = Some (D,rest); C \<noteq> Object\<rbrakk> \<Longrightarrow> G \<turnstile> C \<prec>C1 D"

abbreviation
  subcls  :: "'c prog => cname \<Rightarrow> cname => bool" ("_ \<turnstile> _ \<preceq>C _"  [71,71,71] 70)
  where "G \<turnstile> C \<preceq>C D \<equiv> (C, D) \<in> (subcls1 G)^*"

lemma subcls1D:
  "G\<turnstile>C\<prec>C1D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class G C = Some (D,fs,ms))"
apply (erule subcls1.cases)
apply auto
done

lemma subcls1_def2:
  "subcls1 P =
     (SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D})"
  by (auto simp add: is_class_def dest: subcls1D intro: subcls1I)

lemma finite_subcls1: "finite (subcls1 G)"
apply(simp add: subcls1_def2 del: mem_Sigma_iff)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{fst (the (class G C))}" in finite_subset)
apply  auto
done

lemma subcls_is_class: "(C, D) \<in> (subcls1 G)^+  ==> is_class G C"
apply (unfold is_class_def)
apply(erule trancl_trans_induct)
apply (auto dest!: subcls1D)
done

lemma subcls_is_class2 [rule_format (no_asm)]:
  "G\<turnstile>C\<preceq>C D \<Longrightarrow> is_class G D \<longrightarrow> is_class G C"
apply (unfold is_class_def)
apply (erule rtrancl_induct)
apply  (drule_tac [2] subcls1D)
apply  auto
done

definition class_rec :: "'c prog \<Rightarrow> cname \<Rightarrow> 'a \<Rightarrow>
    (cname \<Rightarrow> fdecl list \<Rightarrow> 'c mdecl list \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a" where
  "class_rec G == wfrec ((subcls1 G)^-1)
    (\<lambda>r C t f. case class G C of
         None \<Rightarrow> undefined
       | Some (D,fs,ms) \<Rightarrow>
           f C fs ms (if C = Object then t else r D t f))"

lemma class_rec_lemma:
  assumes wf: "wf ((subcls1 G)^-1)"
    and cls: "class G C = Some (D, fs, ms)"
  shows "class_rec G C t f = f C fs ms (if C=Object then t else class_rec G D t f)"
  by (subst wfrec_def_adm[OF class_rec_def])
     (auto simp: assms adm_wf_def fun_eq_iff subcls1I split: option.split)

definition
  "wf_class G = wf ((subcls1 G)^-1)"

text {* Code generator setup *}

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  subcls1p
  .

declare subcls1_def [code_pred_def]

code_pred
  (modes: i \<Rightarrow> i \<times> o \<Rightarrow> bool, i \<Rightarrow> i \<times> i \<Rightarrow> bool)
  [inductify]
  subcls1
  .

definition subcls' where "subcls' G = (subcls1p G)^**"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  subcls'
  .

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 G)^* = {(C, D). subcls' G C D}"
by(simp add: subcls'_def subcls1_def rtrancl_def)

lemma class_rec_code [code]:
  "class_rec G C t f =
  (if wf_class G then
    (case class G C of
       None \<Rightarrow> class_rec G C t f
     | Some (D, fs, ms) \<Rightarrow>
       if C = Object then f Object fs ms t else f C fs ms (class_rec G D t f))
   else class_rec G C t f)"
apply(cases "wf_class G")
 apply(unfold class_rec_def wf_class_def)
 apply(subst wfrec, assumption)
 apply(cases "class G C")
  apply(simp add: wfrec)
 apply clarsimp
 apply(rename_tac D fs ms)
 apply(rule_tac f="f C fs ms" in arg_cong)
 apply(clarsimp simp add: cut_def)
 apply(blast intro: subcls1I)
apply simp
done

lemma wf_class_code [code]:
  "wf_class G \<longleftrightarrow> (\<forall>(C, rest) \<in> set G. C \<noteq> Object \<longrightarrow> \<not> G \<turnstile> fst (the (class G C)) \<preceq>C C)"
proof
  assume "wf_class G"
  hence wf: "wf (((subcls1 G)^+)^-1)" unfolding wf_class_def by(rule wf_converse_trancl)
  hence acyc: "acyclic ((subcls1 G)^+)" by(auto dest: wf_acyclic)
  show "\<forall>(C, rest) \<in> set G. C \<noteq> Object \<longrightarrow> \<not> G \<turnstile> fst (the (class G C)) \<preceq>C C"
  proof(safe)
    fix C D fs ms
    assume "(C, D, fs, ms) \<in> set G"
      and "C \<noteq> Object"
      and subcls: "G \<turnstile> fst (the (class G C)) \<preceq>C C"
    from `(C, D, fs, ms) \<in> set G` obtain D' fs' ms'
      where "class": "class G C = Some (D', fs', ms')"
      unfolding class_def by(auto dest!: weak_map_of_SomeI)
    hence "G \<turnstile> C \<prec>C1 D'" using `C \<noteq> Object` ..
    hence *: "(C, D') \<in> (subcls1 G)^+" ..
    also from * acyc have "C \<noteq> D'" by(auto simp add: acyclic_def)
    with subcls "class" have "(D', C) \<in> (subcls1 G)^+" by(auto dest: rtranclD)
    finally show False using acyc by(auto simp add: acyclic_def)
  qed
next
  assume rhs[rule_format]: "\<forall>(C, rest) \<in> set G. C \<noteq> Object \<longrightarrow> \<not> G \<turnstile> fst (the (class G C)) \<preceq>C C"
  have "acyclic (subcls1 G)"
  proof(intro acyclicI strip notI)
    fix C
    assume "(C, C) \<in> (subcls1 G)\<^sup>+"
    thus False
    proof(cases)
      case base
      then obtain rest where "class G C = Some (C, rest)"
        and "C \<noteq> Object" by cases
      from `class G C = Some (C, rest)` have "(C, C, rest) \<in> set G"
        unfolding class_def by(rule map_of_SomeD)
      with `C \<noteq> Object` `class G C = Some (C, rest)`
      have "\<not> G \<turnstile> C \<preceq>C C" by(auto dest: rhs)
      thus False by simp
    next
      case (step D)
      from `G \<turnstile> D \<prec>C1 C` obtain rest where "class G D = Some (C, rest)"
        and "D \<noteq> Object" by cases
      from `class G D = Some (C, rest)` have "(D, C, rest) \<in> set G"
        unfolding class_def by(rule map_of_SomeD)
      with `D \<noteq> Object` `class G D = Some (C, rest)`
      have "\<not> G \<turnstile> C \<preceq>C D" by(auto dest: rhs)
      moreover from `(C, D) \<in> (subcls1 G)\<^sup>+`
      have "G \<turnstile> C \<preceq>C D" by(rule trancl_into_rtrancl)
      ultimately show False by contradiction
    qed
  qed
  thus "wf_class G" unfolding wf_class_def
    by(rule finite_acyclic_wf_converse[OF finite_subcls1])
qed

consts
  method :: "'c prog \<times> cname => ( sig   \<rightharpoonup> cname \<times> ty \<times> 'c)" (* ###curry *)
  field  :: "'c prog \<times> cname => ( vname \<rightharpoonup> cname \<times> ty     )" (* ###curry *)
  fields :: "'c prog \<times> cname => ((vname \<times> cname) \<times> ty) list" (* ###curry *)

-- "methods of a class, with inheritance, overriding and hiding, cf. 8.4.6"
defs method_def [code]: "method \<equiv> \<lambda>(G,C). class_rec G C empty (\<lambda>C fs ms ts.
                           ts ++ map_of (map (\<lambda>(s,m). (s,(C,m))) ms))"

lemma method_rec_lemma: "[|class G C = Some (D,fs,ms); wf ((subcls1 G)^-1)|] ==>
  method (G,C) = (if C = Object then empty else method (G,D)) ++
  map_of (map (\<lambda>(s,m). (s,(C,m))) ms)"
apply (unfold method_def)
apply (simp split del: split_if)
apply (erule (1) class_rec_lemma [THEN trans])
apply auto
done

-- "list of fields of a class, including inherited and hidden ones"
defs fields_def [code]: "fields \<equiv> \<lambda>(G,C). class_rec G C []    (\<lambda>C fs ms ts.
                           map (\<lambda>(fn,ft). ((fn,C),ft)) fs @ ts)"

lemma fields_rec_lemma: "[|class G C = Some (D,fs,ms); wf ((subcls1 G)^-1)|] ==>
 fields (G,C) =
  map (\<lambda>(fn,ft). ((fn,C),ft)) fs @ (if C = Object then [] else fields (G,D))"
apply (unfold fields_def)
apply (simp split del: split_if)
apply (erule (1) class_rec_lemma [THEN trans])
apply auto
done

defs field_def [code]: "field == map_of o (map (\<lambda>((fn,fd),ft). (fn,(fd,ft)))) o fields"

lemma field_fields:
"field (G,C) fn = Some (fd, fT) \<Longrightarrow> map_of (fields (G,C)) (fn, fd) = Some fT"
apply (unfold field_def)
apply (rule table_of_remap_SomeD)
apply simp
done

-- "widening, viz. method invocation conversion,cf. 5.3 i.e. sort of syntactic subtyping"
inductive
  widen   :: "'c prog => [ty   , ty   ] => bool" ("_ \<turnstile> _ \<preceq> _"   [71,71,71] 70)
  for G :: "'c prog"
where
  refl   [intro!, simp]:       "G\<turnstile>      T \<preceq> T"   -- "identity conv., cf. 5.1.1"
| subcls         : "G\<turnstile>C\<preceq>C D ==> G\<turnstile>Class C \<preceq> Class D"
| null   [intro!]:             "G\<turnstile>     NT \<preceq> RefT R"

code_pred widen .

lemmas refl = HOL.refl

-- "casting conversion, cf. 5.5 / 5.1.5"
-- "left out casts on primitve types"
inductive
  cast    :: "'c prog => [ty   , ty   ] => bool" ("_ \<turnstile> _ \<preceq>? _"  [71,71,71] 70)
  for G :: "'c prog"
where
  widen:  "G\<turnstile> C\<preceq> D ==> G\<turnstile>C \<preceq>? D"
| subcls: "G\<turnstile> D\<preceq>C C ==> G\<turnstile>Class C \<preceq>? Class D"

lemma widen_PrimT_RefT [iff]: "(G\<turnstile>PrimT pT\<preceq>RefT rT) = False"
apply (rule iffI)
apply (erule widen.cases)
apply auto
done

lemma widen_RefT: "G\<turnstile>RefT R\<preceq>T ==> \<exists>t. T=RefT t"
apply (ind_cases "G\<turnstile>RefT R\<preceq>T")
apply auto
done

lemma widen_RefT2: "G\<turnstile>S\<preceq>RefT R ==> \<exists>t. S=RefT t"
apply (ind_cases "G\<turnstile>S\<preceq>RefT R")
apply auto
done

lemma widen_Class: "G\<turnstile>Class C\<preceq>T ==> \<exists>D. T=Class D"
apply (ind_cases "G\<turnstile>Class C\<preceq>T")
apply auto
done

lemma widen_Class_NullT [iff]: "(G\<turnstile>Class C\<preceq>NT) = False"
apply (rule iffI)
apply (ind_cases "G\<turnstile>Class C\<preceq>NT")
apply auto
done

lemma widen_Class_Class [iff]: "(G\<turnstile>Class C\<preceq> Class D) = (G\<turnstile>C\<preceq>C D)"
apply (rule iffI)
apply (ind_cases "G\<turnstile>Class C \<preceq> Class D")
apply (auto elim: widen.subcls)
done

lemma widen_NT_Class [simp]: "G \<turnstile> T \<preceq> NT \<Longrightarrow> G \<turnstile> T \<preceq> Class D"
by (ind_cases "G \<turnstile> T \<preceq> NT",  auto)

lemma cast_PrimT_RefT [iff]: "(G\<turnstile>PrimT pT\<preceq>? RefT rT) = False"
apply (rule iffI)
apply (erule cast.cases)
apply auto
done

lemma cast_RefT: "G \<turnstile> C \<preceq>? Class D \<Longrightarrow> \<exists> rT. C = RefT rT"
apply (erule cast.cases)
apply simp apply (erule widen.cases)
apply auto
done

theorem widen_trans[trans]: "\<lbrakk>G\<turnstile>S\<preceq>U; G\<turnstile>U\<preceq>T\<rbrakk> \<Longrightarrow> G\<turnstile>S\<preceq>T"
proof -
  assume "G\<turnstile>S\<preceq>U" thus "\<And>T. G\<turnstile>U\<preceq>T \<Longrightarrow> G\<turnstile>S\<preceq>T"
  proof induct
    case (refl T T') thus "G\<turnstile>T\<preceq>T'" .
  next
    case (subcls C D T)
    then obtain E where "T = Class E" by (blast dest: widen_Class)
    with subcls show "G\<turnstile>Class C\<preceq>T" by auto
  next
    case (null R RT)
    then obtain rt where "RT = RefT rt" by (blast dest: widen_RefT)
    thus "G\<turnstile>NT\<preceq>RT" by auto
  qed
qed

end


(*  Title:      HOL/TLA/Memory/ProcedureInterface.thy
    Author:     Stephan Merz, University of Munich
*)

section \<open>Procedure interface for RPC-Memory components\<close>

theory ProcedureInterface
imports "HOL-TLA.TLA" RPCMemoryParams
begin

typedecl ('a,'r) chan
  (* type of channels with argument type 'a and return type 'r.
     we model a channel as an array of variables (of type chan)
     rather than a single array-valued variable because the
     notation gets a little simpler.
  *)
type_synonym ('a,'r) channel =" (PrIds \<Rightarrow> ('a,'r) chan) stfun"

(* data-level functions *)

consts
  cbit          :: "('a,'r) chan \<Rightarrow> bit"
  rbit          :: "('a,'r) chan \<Rightarrow> bit"
  arg           :: "('a,'r) chan \<Rightarrow> 'a"
  res           :: "('a,'r) chan \<Rightarrow> 'r"

(* state functions *)

definition caller :: "('a,'r) channel \<Rightarrow> (PrIds \<Rightarrow> (bit * 'a)) stfun"
  where "caller ch == \<lambda>s p. (cbit (ch s p), arg (ch s p))"

definition rtrner :: "('a,'r) channel \<Rightarrow> (PrIds \<Rightarrow> (bit * 'r)) stfun"
  where "rtrner ch == \<lambda>s p. (rbit (ch s p), res (ch s p))"

(* slice through array-valued state function *)

definition slice :: "('a \<Rightarrow> 'b) stfun \<Rightarrow> 'a \<Rightarrow> 'b stfun"
  where "slice x i s \<equiv> x s i"

syntax
  "_slice" :: "[lift, 'a] \<Rightarrow> lift"  ("(_!_)" [70,70] 70)
translations
  "_slice" \<rightleftharpoons> "CONST slice"

(* state predicates *)

definition Calling :: "('a,'r) channel \<Rightarrow> PrIds \<Rightarrow> stpred"
  where "Calling ch p == PRED cbit< ch!p > \<noteq> rbit< ch!p >"

(* actions *)

definition ACall :: "('a,'r) channel \<Rightarrow> PrIds \<Rightarrow> 'a stfun \<Rightarrow> action"
  where "ACall ch p v \<equiv> ACT
      \<not> $Calling ch p
    \<and> (cbit<ch!p>$ \<noteq> $rbit<ch!p>)
    \<and> (arg<ch!p>$ = $v)"

definition AReturn :: "('a,'r) channel \<Rightarrow> PrIds \<Rightarrow> 'r stfun \<Rightarrow> action"
  where "AReturn ch p v == ACT
      $Calling ch p
    \<and> (rbit<ch!p>$ = $cbit<ch!p>)
    \<and> (res<ch!p>$ = $v)"

syntax
  "_Call" :: "['a, 'b, lift] \<Rightarrow> lift"  ("(Call _ _ _)" [90,90,90] 90)
  "_Return" :: "['a, 'b, lift] \<Rightarrow> lift"  ("(Return _ _ _)" [90,90,90] 90)
translations
  "_Call" \<rightleftharpoons> "CONST ACall"
  "_Return" \<rightleftharpoons> "CONST AReturn"

(* temporal formulas *)

definition PLegalCaller :: "('a,'r) channel \<Rightarrow> PrIds \<Rightarrow> temporal"
  where "PLegalCaller ch p == TEMP
     Init(\<not> Calling ch p)
     \<and> \<box>[\<exists>a. Call ch p a ]_((caller ch)!p)"

definition LegalCaller :: "('a,'r) channel \<Rightarrow> temporal"
  where "LegalCaller ch == TEMP (\<forall>p. PLegalCaller ch p)"

definition PLegalReturner :: "('a,'r) channel \<Rightarrow> PrIds \<Rightarrow> temporal"
  where "PLegalReturner ch p == TEMP \<box>[\<exists>v. Return ch p v ]_((rtrner ch)!p)"

definition LegalReturner :: "('a,'r) channel \<Rightarrow> temporal"
  where "LegalReturner ch == TEMP (\<forall>p. PLegalReturner ch p)"

declare slice_def [simp]

lemmas Procedure_defs = caller_def rtrner_def Calling_def ACall_def AReturn_def
  PLegalCaller_def LegalCaller_def PLegalReturner_def LegalReturner_def

(* Calls and returns change their subchannel *)
lemma Call_changed: "\<turnstile> Call ch p v \<longrightarrow> <Call ch p v>_((caller ch)!p)"
  by (auto simp: angle_def ACall_def caller_def Calling_def)

lemma Return_changed: "\<turnstile> Return ch p v \<longrightarrow> <Return ch p v>_((rtrner ch)!p)"
  by (auto simp: angle_def AReturn_def rtrner_def Calling_def)

end