theory Common_Primitive_toString
imports "../../Simple_Firewall/Primitives/Primitives_toString"
        Common_Primitive_Matcher
begin

section\<open>Firewall toString Functions\<close>

fun ipt_ipv4range_toString :: "32 ipt_iprange \<Rightarrow> string" where
  "ipt_ipv4range_toString (IpAddr ip) = ipv4addr_toString ip" |
  "ipt_ipv4range_toString (IpAddrNetmask ip n) = ipv4addr_toString ip@''/''@string_of_nat n"  |
  "ipt_ipv4range_toString (IpAddrRange ip1 ip2) = ipv4addr_toString ip1@''-''@ipv4addr_toString ip2"

fun ipt_ipv6range_toString :: "128 ipt_iprange \<Rightarrow> string" where
  "ipt_ipv6range_toString (IpAddr ip) = ipv6addr_toString ip" |
  "ipt_ipv6range_toString (IpAddrNetmask ip n) = ipv6addr_toString ip@''/''@string_of_nat n"  |
  "ipt_ipv6range_toString (IpAddrRange ip1 ip2) = ipv6addr_toString ip1@''-''@ipv6addr_toString ip2"

definition ipv4addr_wordinterval_pretty_toString :: "32 wordinterval \<Rightarrow> string" where
  "ipv4addr_wordinterval_pretty_toString wi = list_toString ipt_ipv4range_toString (wi_to_ipt_iprange wi)"

lemma "ipv4addr_wordinterval_pretty_toString
    (RangeUnion (RangeUnion (WordInterval 0x7F000000 0x7FFFFFFF) (WordInterval 0x1020304 0x1020306))
                (WordInterval 0x8080808 0x8080808)) = ''[127.0.0.0/8, 1.2.3.4-1.2.3.6, 8.8.8.8]''" by eval

fun action_toString :: "action \<Rightarrow> string" where
  "action_toString action.Accept = ''-j ACCEPT''" |
  "action_toString action.Drop = ''-j DROP''" |
  "action_toString action.Reject = ''-j REJECT''" |
  "action_toString (action.Call target) = ''-j ''@target@'' (call)''" |
  "action_toString (action.Goto target) = ''-g ''@target" |
  "action_toString action.Empty = ''''" |
  "action_toString action.Log = ''-j LOG''" |
  "action_toString action.Return = ''-j RETURN''" |
  "action_toString action.Unknown = ''!!!!!!!!!!! UNKNOWN !!!!!!!!!!!''"

fun common_primitive_toString :: "('i::len word \<Rightarrow> string) \<Rightarrow> 'i common_primitive \<Rightarrow> string" where
  "common_primitive_toString ipToStr (Src (IpAddr ip)) = ''-s ''@ipToStr ip" |
  "common_primitive_toString ipToStr (Dst (IpAddr ip)) = ''-d ''@ipToStr ip" |
  "common_primitive_toString ipToStr (Src (IpAddrNetmask ip n)) = ''-s ''@ipToStr ip@''/''@string_of_nat n"  |
  "common_primitive_toString ipToStr (Dst (IpAddrNetmask ip n)) = ''-d ''@ipToStr ip@''/''@string_of_nat n"  |
  "common_primitive_toString ipToStr (Src (IpAddrRange ip1 ip2)) = ''-m iprange --src-range ''@ipToStr ip1@''-''@ipToStr ip2"  |
  "common_primitive_toString ipToStr (Dst (IpAddrRange ip1 ip2)) = ''-m iprange --dst-range ''@ipToStr ip1@''-''@ipToStr ip2"  |
  "common_primitive_toString _ (IIface ifce) = iface_toString ''-i '' ifce" |
  "common_primitive_toString _ (OIface ifce) = iface_toString ''-o '' ifce" |
  "common_primitive_toString _ (Prot prot) = ''-p ''@protocol_toString prot" |
  "common_primitive_toString _ (Src_Ports (L4Ports prot pts)) = ''-m ''@primitive_protocol_toString prot@'' --spts '' @ list_toString (ports_toString '''') pts" |
  "common_primitive_toString _ (Dst_Ports (L4Ports prot pts)) = ''-m ''@primitive_protocol_toString prot@'' --dpts '' @ list_toString (ports_toString '''') pts" |
  "common_primitive_toString _ (MultiportPorts (L4Ports prot pts)) = ''-p ''@primitive_protocol_toString prot@'' -m multiport --ports '' @ list_toString (ports_toString '''') pts" |
  "common_primitive_toString _ (CT_State S) = ''-m state --state ''@ctstate_set_toString S" |
  "common_primitive_toString _ (L4_Flags (TCP_Flags c m)) = ''--tcp-flags ''@ipt_tcp_flags_toString c@'' ''@ipt_tcp_flags_toString m" |
  "common_primitive_toString _ (Extra e) = ''~~''@e@''~~''"

definition common_primitive_ipv4_toString :: "32 common_primitive \<Rightarrow> string" where
  "common_primitive_ipv4_toString \<equiv> common_primitive_toString ipv4addr_toString"

definition common_primitive_ipv6_toString :: "128 common_primitive \<Rightarrow> string" where
  "common_primitive_ipv6_toString \<equiv> common_primitive_toString ipv6addr_toString"

fun common_primitive_match_expr_toString
  :: "('i common_primitive \<Rightarrow> string) \<Rightarrow> 'i common_primitive match_expr \<Rightarrow> string" where
  "common_primitive_match_expr_toString toStr MatchAny = ''''" |
  "common_primitive_match_expr_toString toStr (Match m) = toStr m" |
  "common_primitive_match_expr_toString toStr (MatchAnd m1 m2) =
      common_primitive_match_expr_toString toStr m1 @'' '' @ common_primitive_match_expr_toString toStr m2" |
  "common_primitive_match_expr_toString toStr (MatchNot (Match m)) = ''! ''@toStr m" |
  "common_primitive_match_expr_toString toStr (MatchNot m) = ''NOT (''@common_primitive_match_expr_toString toStr m@'')''"

definition common_primitive_match_expr_ipv4_toString :: "32 common_primitive match_expr \<Rightarrow> string" where
  "common_primitive_match_expr_ipv4_toString \<equiv> common_primitive_match_expr_toString common_primitive_ipv4_toString"

definition common_primitive_match_expr_ipv6_toString :: "128 common_primitive match_expr \<Rightarrow> string" where
  "common_primitive_match_expr_ipv6_toString \<equiv> common_primitive_match_expr_toString common_primitive_ipv6_toString"

fun common_primitive_rule_toString :: "32 common_primitive rule \<Rightarrow> string" where
  "common_primitive_rule_toString (Rule m a) = common_primitive_match_expr_ipv4_toString m @'' ''@action_toString a"

end


(*  Title:      JinjaDCI/BV/BVExec.thy

    Author:     Tobias Nipkow, Gerwin Klein, Susannah Mansky
    Copyright   2000 TUM, 2020 UIUC

    Based on the Jinja theory BV/BVExec.thy by Tobias Nipkow and Gerwin Klein
*)

section \<open> Kildall for the JVM \label{sec:JVM} \<close>

theory BVExec
imports Jinja.Abstract_BV TF_JVM
begin

definition kiljvm :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow>
             instr list \<Rightarrow> ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> ty\<^sub>i' err list"
where
  "kiljvm P mxs mxl T\<^sub>r is xt \<equiv>
  kildall (JVM_SemiType.le P mxs mxl) (JVM_SemiType.sup P mxs mxl)
          (exec P mxs T\<^sub>r xt is)"

definition wt_kildall :: "jvm_prog \<Rightarrow> cname \<Rightarrow> staticb \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
                 instr list \<Rightarrow> ex_table \<Rightarrow> bool"
where
  "wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<equiv>
   0 < size is \<and>
   (let first  = Some ([],(case b of Static \<Rightarrow> [] | NonStatic \<Rightarrow> [OK (Class C')])
                            @(map OK Ts)@(replicate mxl\<^sub>0 Err));
        start  = (OK first)#(replicate (size is - 1) (OK None));
        result = kiljvm P mxs
                   ((case b of Static \<Rightarrow> 0 | NonStatic \<Rightarrow> 1)+size Ts+mxl\<^sub>0)
                     T\<^sub>r is xt start
    in \<forall>n < size is. result!n \<noteq> Err)"

definition wf_jvm_prog\<^sub>k :: "jvm_prog \<Rightarrow> bool"
where
  "wf_jvm_prog\<^sub>k P \<equiv>
  wf_prog (\<lambda>P C' (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt) P"

theorem (in start_context) is_bcv_kiljvm:
  "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
(*<*)
proof -
  let ?n = "length is"
  have "Semilat A r f" using semilat_JVM[OF wf]
    by (simp add: Semilat.intro sl_def2)
  moreover have "acc r" using wf by simp blast
  moreover have "top r Err" by (simp add: JVM_le_unfold)
  moreover have "pres_type step ?n A" by (rule exec_pres_type)
  moreover have "bounded step ?n" by (rule bounded_step)
  moreover have "mono r step ?n A" using step_mono[OF wf] by simp
  ultimately have "is_bcv r Err step ?n A (kildall r f step)"
    by(rule is_bcv_kildall)
  moreover have kileq: "kiljvm P mxs mxl T\<^sub>r is xt = kildall r f step"
    using f_def kiljvm_def r_def step_def_exec by blast
  ultimately show ?thesis by simp
qed
(*>*)

(* FIXME: move? *)
lemma subset_replicate [intro?]: "set (replicate n x) \<subseteq> {x}"
  by (induct n) auto

lemma in_set_replicate:
  assumes "x \<in> set (replicate n y)"
  shows "x = y"
(*<*)
proof -
  note assms
  also have "set (replicate n y) \<subseteq> {y}" ..
  finally show ?thesis by simp
qed
(*>*)

lemma (in start_context) start_in_A [intro?]:
  "0 < size is \<Longrightarrow> start \<in> list (size is) A"
  using Ts C
(*<*)
proof(cases b)
qed (force simp: JVM_states_unfold intro!: listI list_appendI
           dest!: in_set_replicate)+
(*>*)

theorem (in start_context) wt_kil_correct:
  assumes wtk: "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  shows "\<exists>\<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from wtk obtain res where
    result:   "res = kiljvm P mxs mxl T\<^sub>r is xt start" and
    success:  "\<forall>n < size is. res!n \<noteq> Err" and
    instrs:   "0 < size is"
    by (unfold wt_kildall_def) simp

  have bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)

  from instrs have "start \<in> list (size is) A" ..
  with bcv success result have
    "\<exists>ts\<in>list (size is) A. start [\<sqsubseteq>\<^sub>r] ts \<and> wt_step r Err step ts"
    by (unfold is_bcv_def) blast
  then obtain \<tau>s' where
    in_A: "\<tau>s' \<in> list (size is) A" and
    s:    "start [\<sqsubseteq>\<^sub>r] \<tau>s'" and
    w:    "wt_step r Err step \<tau>s'"
    by blast
  hence wt_err_step: "wt_err_step (sup_state_opt P) step \<tau>s'"
    by (simp add: wt_err_step_def JVM_le_Err_conv)

  from in_A have l: "size \<tau>s' = size is" by simp
  moreover {
    from in_A  have "check_types P mxs mxl \<tau>s'" by (simp add: check_types_def)
    also from w have "\<forall>x \<in> set \<tau>s'. x \<noteq> Err"
      by (auto simp add: wt_step_def all_set_conv_all_nth)
    hence [symmetric]: "map OK (map ok_val \<tau>s') = \<tau>s'"
      by (auto intro!: map_idI simp add: wt_step_def)
    finally  have "check_types P mxs mxl (map OK (map ok_val \<tau>s'))" .
  }
  moreover {
    from s have "start!0 \<sqsubseteq>\<^sub>r \<tau>s'!0" by (rule le_listD) simp
    moreover
    from instrs w l
    have "\<tau>s'!0 \<noteq> Err" by (unfold wt_step_def) simp
    then obtain \<tau>s0 where "\<tau>s'!0 = OK \<tau>s0" by auto
    ultimately
    have "wt_start P C b Ts mxl\<^sub>0 (map ok_val \<tau>s')" using l instrs
      by (unfold wt_start_def)
         (cases b; simp add: lesub_def JVM_le_Err_conv Err.le_def)
  }
  moreover
  from in_A have "set \<tau>s' \<subseteq> A" by simp
  with wt_err_step bounded_step
  have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s')"
    by (auto intro: wt_err_imp_wt_app_eff simp add: l)
  ultimately
  have "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s')"
    using instrs by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis by blast
qed
(*>*)

theorem (in start_context) wt_kil_complete:
  assumes wtm: "wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  shows "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
(*<*)
proof -
  from wtm obtain
    instrs:   "0 < size is" and
    length:   "length \<tau>s = length is" and
    ck_type:  "check_types P mxs mxl (map OK \<tau>s)" and
    wt_start: "wt_start P C b Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (simp add: wt_method_def2 check_types_def)

  from ck_type
  have in_A: "set (map OK \<tau>s) \<subseteq> A"
    by (simp add: check_types_def)
  with app_eff in_A bounded_step
  have "wt_err_step (sup_state_opt P) (err_step (size \<tau>s) app eff) (map OK \<tau>s)"
    by - (erule wt_app_eff_imp_wt_err,
          auto simp add: exec_def length states_def)
  hence wt_err: "wt_err_step (sup_state_opt P) step (map OK \<tau>s)"
    by (simp add: length)
  have is_bcv: "is_bcv r Err step (size is) A (kiljvm P mxs mxl T\<^sub>r is xt)"
    by (rule is_bcv_kiljvm)
  moreover from instrs have "start \<in> list (size is) A" ..
  moreover
  let ?\<tau>s = "map OK \<tau>s"
  have less_\<tau>s: "start [\<sqsubseteq>\<^sub>r] ?\<tau>s"
  proof (rule le_listI)
    from length instrs
    show "length start = length (map OK \<tau>s)" by simp
  next
    fix n
    from wt_start have "P \<turnstile> ok_val (start!0) \<le>' \<tau>s!0"
      by (cases b; simp add: wt_start_def)
    moreover from instrs length have "0 < length \<tau>s" by simp
    ultimately have "start!0 \<sqsubseteq>\<^sub>r ?\<tau>s!0"
      by (simp add: JVM_le_Err_conv lesub_def)
    moreover {
      fix n'
      have "OK None \<sqsubseteq>\<^sub>r ?\<tau>s!n"
        by (auto simp add: JVM_le_Err_conv Err.le_def lesub_def
                 split: err.splits)
      hence "\<lbrakk>n = Suc n'; n < size start\<rbrakk> \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by simp
    }
    ultimately
    show "n < size start \<Longrightarrow> start!n \<sqsubseteq>\<^sub>r ?\<tau>s!n" by (cases n, blast+)
  qed
  moreover
  from ck_type length
  have "?\<tau>s \<in> list (size is) A"
    by (auto intro!: listI simp add: check_types_def)
  moreover
  from wt_err have "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  ultimately
  have "\<forall>p. p < size is \<longrightarrow> kiljvm P  mxs mxl T\<^sub>r is xt start ! p \<noteq> Err"
    by (unfold is_bcv_def) blast
  with instrs
  show "wt_kildall P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt" by (unfold wt_kildall_def) simp
qed
(*>*)

theorem jvm_kildall_correct:
  "wf_jvm_prog\<^sub>k P = wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C M. let (C,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)) = method P C M in
              SOME \<tau>s. wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  let ?A = "\<lambda>P C' (M, b, Ts, T\<^sub>r, mxs, mxl\<^sub>0, is, xt). wt_kildall P C' b Ts T\<^sub>r mxs mxl\<^sub>0 is xt"
  let ?B\<^sub>\<Phi> = "\<lambda>\<Phi>. (\<lambda>P C (M,b,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,is,xt)).
                wt_method P C b Ts T\<^sub>r mxs mxl\<^sub>0 is xt (\<Phi> C M))"

  show ?thesis proof(rule iffI)
    \<comment> \<open>soundness\<close>
    assume wt: "wf_jvm_prog\<^sub>k P"
    then have "wf_prog ?A P" by(simp add: wf_jvm_prog\<^sub>k_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd
      assume "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M, b :  Ts\<rightarrow>T = m in Ca" and
             "set Ts \<subseteq> types P" and "bd = (M, b, Ts, T, m)" and
             "?A P Ca bd"
      then have "(?B\<^sub>\<Phi> ?\<Phi>) P Ca bd" using sees_method_is_class[OF sees]
        by (auto dest!: start_context.wt_kil_correct [OF start_context.intro]
                 intro: someI)
    }
    ultimately have "wf_prog (?B\<^sub>\<Phi> ?\<Phi>) P" by(rule wf_prog_lift)
    then have "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P" by (simp add: wf_jvm_prog_phi_def)
    thus "wf_jvm_prog P" by (unfold wf_jvm_prog_def) fast
  next
    \<comment> \<open>completeness\<close>
    assume wt: "wf_jvm_prog P"
    then obtain \<Phi> where "wf_prog (?B\<^sub>\<Phi> \<Phi>) P" by(clarsimp simp: wf_jvm_prog_def wf_jvm_prog_phi_def)
    moreover {
      fix wf_md C M b Ts Ca T m bd
      assume "wf_prog wf_md P" and sees: "P \<turnstile> Ca sees M, b :  Ts\<rightarrow>T = m in Ca" and
             "set Ts \<subseteq> types P" and "bd = (M, b, Ts, T, m)" and
             "(?B\<^sub>\<Phi> \<Phi>) P Ca bd"
      then have "?A P Ca bd" using sees_method_is_class[OF sees]
        by (auto intro!: start_context.wt_kil_complete start_context.intro)
    }
    ultimately have "wf_prog ?A P" by(rule wf_prog_lift)
    thus "wf_jvm_prog\<^sub>k P" by (simp add: wf_jvm_prog\<^sub>k_def)
  qed
qed
(*>*)

end


(*  Title:      SSA_Semantics.thy
    Author:     Sebastian Ullrich
*)

section {* Proof of Semantic Equivalence *}

theory SSA_Semantics
imports SSA_CFG
begin

type_synonym ('node, 'var) state = "'var \<rightharpoonup> 'node"

context CFG_SSA_Transformed
begin
  definition step ::
    "'node \<Rightarrow> ('node, 'var) state \<Rightarrow> ('node, 'var) state"
  where
    "step m s v \<equiv> if v \<in> oldDefs m then Some m else s v"

  no_notation Refine_Basic.conc_fun ("\<Down>")

  inductive bs :: "'node list \<Rightarrow> ('node, 'var) state \<Rightarrow> bool" (infix "\<Down>" 50)
  where
    "Entry\<comment>ns\<rightarrow>last ns \<Longrightarrow> ns\<Down>(fold (step) ns Map.empty)"

  definition ssaStep ::
    "'node \<Rightarrow> nat \<Rightarrow> ('node, 'val) state \<Rightarrow> ('node, 'val) state"
  where
    "ssaStep m i s v \<equiv>
      if v \<in> defs m then
        Some m
      else
        case phis (m,v) of
          Some phiParams \<Rightarrow> s (phiParams ! i)
        | None \<Rightarrow> s v"

  inductive ssaBS :: "'node list \<Rightarrow> ('node, 'val) state \<Rightarrow> bool" (infix "\<Down>\<^sub>s" 50)
  where
    empty: "[Entry]\<Down>\<^sub>s(ssaStep (Entry) 0 Map.empty)"
  | snoc: "\<lbrakk>ns\<Down>\<^sub>ss; last ns = predecessors m ! i; m \<in> set \<alpha>n; i < length (predecessors m)\<rbrakk> \<Longrightarrow>
            (ns@[m])\<Down>\<^sub>s(ssaStep m i s)"

  lemma ssaBS_I:
    assumes "Entry\<comment>ns\<rightarrow>n"
    obtains s where "ns\<Down>\<^sub>ss"
  using assms
  proof (atomize_elim, induction rule:path2_rev_induct)
    case (snoc ns m' m)
    then obtain s where s: "ns\<Down>\<^sub>ss" by auto
    from snoc.hyps(2) obtain i where "m' = predecessors m ! i" "i < length (predecessors m)" by (auto simp:in_set_conv_nth)
    with snoc.hyps snoc.prems s show ?case by -(rule exI, erule ssaBS.snoc, auto dest:path2_last)
  qed (auto intro: ssaBS.empty)

  lemma ssaBS_nonempty[simp]: "\<not> ([]\<Down>\<^sub>ss)"
  by (rule notI, cases rule: ssaBS.cases, auto)

  lemma ssaBS_hd[simp]: "ns\<Down>\<^sub>ss \<Longrightarrow> hd ns = Entry"
    apply (induction rule: ssaBS.induct)
     apply (auto simp: hd_append)[1]
    by (case_tac ns; simp)

  lemma equiv_aux:
    assumes "ns\<Down>s" "ns\<Down>\<^sub>ss'" "last ns\<comment>ms\<rightarrow>m" "v \<in> allUses m" "\<forall>n \<in> set (tl ms). var v \<notin> var ` allDefs n"
    shows "s (var v) = s' v"
  using assms(2) assms(1,3-) proof (induction arbitrary: v s ms m)
    case empty
    have "v \<in> defs (Entry)"
    proof-
      from empty.prems(2,3) have "defAss m v" by - (rule allUses_def_ass, auto)
      with empty.prems(2) obtain n where n: "n \<in> set ms" "v \<in> allDefs n" by - (drule defAssD, auto)
      with empty.prems(4) have "n \<notin> set (tl ms)" by auto
      with empty.prems(2) n have "n = Entry" by (cases ms, auto dest: path2_hd)
      with n(2) show ?thesis by (auto simp: allDefs_def)
    qed
    with empty.prems(1) show ?case
      by - (erule bs.cases, auto simp: step_def ssaStep_def oldDefs_def split: option.split)
  next
    case (snoc ns s' n i)
    from snoc.prems(2) have[simp]: "n \<in> set \<alpha>n" "m \<in> set \<alpha>n" by auto
    from snoc.prems(2,3) have[simp]: "v \<in> allVars" by - (rule allUses_in_allVars, auto)
    from snoc.hyps(4) have[simp]: "n \<noteq> Entry" using Entry_unreachable len_greater_imp_nonempty by blast

    show ?case
    proof (cases "var v \<in> var ` allDefs n")
      case True

      have[simp]: "defNode v = n" (is "?n\<^sub>v = _")
      proof-
        from True obtain v' where v': "v' \<in> allDefs n" "var v' = var v" by auto
        from snoc.prems(3) have "defAss m v" by - (rule allUses_def_ass, auto)
        moreover from snoc.prems(1) obtain ns' where ns': "Entry\<comment>ns'\<rightarrow>n" "set ns' \<subseteq> set (ns@[n])" "distinct ns'"
          by (auto elim!: bs.cases intro: simple_path2)
        ultimately have "?n\<^sub>v \<in> set (ns'@tl ms)"
          using snoc.prems(2) by - (drule defAss_defNode, auto elim!: bs.cases dest: path2_app)
        moreover {
          let ?n'' = "last (butlast ns')"
          assume asm: "?n\<^sub>v \<in> set (butlast ns')"
          with ns'(1,3) have[simp]: "?n\<^sub>v \<noteq> n" by (cases ns' rule: rev_cases, auto dest!: path2_last)
          from ns'(1) have "length ns' \<ge> 2" using \<open>n \<noteq> Entry\<close> path2_nontrivial by blast
          with ns' have bns': "Entry\<comment>butlast ns'\<rightarrow>?n''" "?n'' \<in> set (predecessors n)"
            by (auto elim: path2_unsnoc)
          with asm obtain ns'' where ns'': "?n\<^sub>v\<comment>ns''\<rightarrow>?n''" "suffixeq ns'' (butlast ns')" "?n\<^sub>v \<notin> set (tl ns'')"
            by - (rule path2_split_first_last, auto)
          with bns' snoc.prems(2) have "?n\<^sub>v\<comment>(ns''@[n])@tl ms\<rightarrow>m" by - (rule path2_app, auto)
          hence "defNode v' \<notin> set (tl (ns''@[n]@tl ms))"
            using v' snoc.prems(3,4) bns'(2) ns''(1,3)
            by - (rule conventional''[of v _ m], auto intro!: path2_app simp: path2_not_Nil)
          with ns' ns''(1) v'(1) have False by (auto simp: path2_not_Nil)
        }
        ultimately show ?thesis using snoc.prems(4) ns'(1) by (cases ns' rule: rev_cases, auto dest: path2_last)
      qed
      from `v \<in> allVars` show ?thesis
      proof (cases rule: defNode_cases)
        case simpleDef
        thus ?thesis using snoc.prems(1) by - (erule bs.cases, auto simp: step_def ssaStep_def oldDefs_def)
      next
        case phi
        {
          fix v'
          assume asm: "v' \<in> defs n" "var v = var v'"
          with phi have "v' = v" using allDefs_var_disjoint[of n v' v]
            \<open>defNode v = n\<close> \<open>v \<in> allVars\<close> defNode(2) defs_in_allDefs snoc.hyps(3) by blast
          with asm(1) phi have False using simpleDefs_phiDefs_disjoint[of n]
            by (auto dest!: phi_phiDefs)
        }
        note 1 = this
        {
          fix vs
          assume asm: "Entry\<comment>ns @ [n]\<rightarrow>n" "phis (n, v) = Some vs" "var v \<notin> var ` defs n"
          let ?n' = "last ns"
          from asm(1) have "length ns \<ge> 1"
            by (metis One_nat_def \<open>n \<noteq> Entry\<close> append_Nil graph_path_base.path2_def le_0_eq length_0_conv list.sel(1) not_less_eq_eq)
          hence "Entry\<comment>ns\<rightarrow>?n'"
            by - (rule path2_unsnoc[OF asm(1)], auto)
          moreover have "vs ! i \<in> phiUses ?n'" using snoc.hyps(2,4) phis_wf[OF asm(2)]
            by - (rule phiUsesI[OF _ asm(2)], auto simp: set_zip)
          ultimately have "fold (step) ns Map.empty (var (vs ! i)) = s' (vs ! i)"
          by - (rule snoc.IH[where ms4="[?n']" and m4="?n'"], auto intro!: bs.intros)
          hence "fold (step) ns Map.empty (var v) = s' (vs ! i)" using phis_same_var[OF asm(2), of "vs ! i"] snoc.hyps(4) phis_wf[OF asm(2)]
            by auto
        }
        thus ?thesis using phi snoc.prems(1)
          by - (erule bs.cases, auto dest!: 1 simp: step_def ssaStep_def oldDefs_def phi_def)
      qed
    next
      case False
      hence "phis (n, v) = None" by (auto simp: allDefs_def phiDefs_def)
      moreover have "fold (step) ns Map.empty (var v) = s' v"
      proof-
        from snoc.hyps(1) have "length ns \<ge> 1" by (cases ns, auto)
        moreover from snoc.prems(2,4) False have "\<forall>n \<in> set ms. var v \<notin> var ` allDefs n"
          by (cases ms, auto simp: phiDefs_def dest: path2_hd)
        ultimately show ?thesis
          using snoc.prems(1,2,3) by - (rule snoc.IH[where ms4="last ns#ms"], auto elim!: bs.cases intro!: bs.intros elim: path2_unsnoc intro!: Cons_path2)
      qed
      ultimately show ?thesis
        using snoc.prems(1) False by - (erule bs.cases, auto simp: step_def ssaStep_def oldDefs_def defs_in_allDefs)
    qed
  qed

  theorem equiv:
    assumes "ns\<Down>s" "ns\<Down>\<^sub>ss'" "v \<in> uses (last ns)"
    shows "s (var v) = s' v"
  using assms by - (rule equiv_aux[where ms="[last ns]"], auto elim!: bs.cases)
end

end


(*  Title:      JinjaThreads/Compiler/Compiler1.thy
    Author:     Andreas Lochbihler, Tobias Nipkow

    Based on Jinja/Compiler/Compiler1
*)

header {* \isaheader{Compilation Stage 1} *}

theory Compiler1 imports
  PCompiler
  J1State
  ListIndex
begin

definition fresh_var :: "vname list \<Rightarrow> vname"
where "fresh_var Vs \<equiv> Auxiliary.concat (STR ''V'' # Vs)"

lemma fresh_var_fresh: "fresh_var Vs \<notin> set Vs"
proof -
  have "\<forall>V \<in> set Vs. length (String.explode V) < length (String.explode (fresh_var Vs))"
    by(induct Vs)(auto simp add: fresh_var_def Auxiliary.concat_def STR_inverse implode_def)
  thus ?thesis by auto
qed

text{* Replacing variable names by indices. *}

function compE1  :: "vname list \<Rightarrow> 'addr expr      \<Rightarrow> 'addr expr1"
  and compEs1 :: "vname list \<Rightarrow> 'addr expr list \<Rightarrow> 'addr expr1 list"
where
  "compE1 Vs (new C) = new C"
| "compE1 Vs (newA T\<lfloor>e\<rceil>) = newA T\<lfloor>compE1 Vs e\<rceil>"
| "compE1 Vs (Cast T e) = Cast T (compE1 Vs e)"
| "compE1 Vs (e instanceof T) = (compE1 Vs e) instanceof T"
| "compE1 Vs (Val v) = Val v"
| "compE1 Vs (Var V) = Var(index Vs V)"
| "compE1 Vs (e\<guillemotleft>bop\<guillemotright>e') = (compE1 Vs e)\<guillemotleft>bop\<guillemotright>(compE1 Vs e')"
| "compE1 Vs (V:=e) = (index Vs V):= (compE1 Vs e)"
| "compE1 Vs (a\<lfloor>i\<rceil>) = (compE1 Vs a)\<lfloor>compE1 Vs i\<rceil>"
| "compE1 Vs (a\<lfloor>i\<rceil>:=e) = (compE1 Vs a)\<lfloor>compE1 Vs i\<rceil>:=compE1 Vs e"
| "compE1 Vs (a\<bullet>length) = compE1 Vs a\<bullet>length"
| "compE1 Vs (e\<bullet>F{D}) = compE1 Vs e\<bullet>F{D}"
| "compE1 Vs (e\<bullet>F{D}:=e') = compE1 Vs e\<bullet>F{D}:=compE1 Vs e'"
| "compE1 Vs (e\<bullet>M(es)) = (compE1 Vs e)\<bullet>M(compEs1 Vs es)"
| "compE1 Vs {V:T=vo; e} = {(size Vs):T=vo; compE1 (Vs@[V]) e}"
| "compE1 Vs (sync\<^bsub>U\<^esub> (o') e) = sync\<^bsub>length Vs\<^esub> (compE1 Vs o') (compE1 (Vs@[fresh_var Vs]) e)"
| "compE1 Vs (insync\<^bsub>U\<^esub> (a) e) = insync\<^bsub>length Vs\<^esub> (a) (compE1 (Vs@[fresh_var Vs]) e)"
| "compE1 Vs (e1;;e2) = (compE1 Vs e1);;(compE1 Vs e2)"
| "compE1 Vs (if (b) e1 else e2) = (if (compE1 Vs b) (compE1 Vs e1) else (compE1 Vs e2))"
| "compE1 Vs (while (b) e) = (while (compE1 Vs b) (compE1 Vs e))"
| "compE1 Vs (throw e) = throw (compE1 Vs e)"
| "compE1 Vs (try e1 catch(C V) e2) = try(compE1 Vs e1) catch(C (size Vs)) (compE1 (Vs@[V]) e2)"

| "compEs1 Vs []     = []"
| "compEs1 Vs (e#es) = compE1 Vs e # compEs1 Vs es"
by pat_completeness auto
termination
apply(relation "case_sum (\<lambda>p. size (snd p)) (\<lambda>p. size_list size (snd p)) <*mlex*> {}")
apply(rule wf_mlex[OF wf_empty])
apply(rule mlex_less, simp)+
done

lemmas compE1_compEs1_induct =
  compE1_compEs1.induct[case_names New NewArray Cast InstanceOf Val Var BinOp LAss AAcc AAss ALen FAcc FAss Call Block Synchronized InSynchronized Seq Cond While throw TryCatch Nil Cons]

lemma compEs1_conv_map [simp]: "compEs1 Vs es = map (compE1 Vs) es"
by(induct es) simp_all

lemmas compEs1_map_Val = compEs1_conv_map

lemma compE1_eq_Val [simp]: "compE1 Vs e = Val v \<longleftrightarrow> e = Val v"
apply(cases e, auto)
done

lemma Val_eq_compE1 [simp]: "Val v = compE1 Vs e \<longleftrightarrow> e = Val v"
apply(cases e, auto)
done

lemma compEs1_eq_map_Val [simp]: "compEs1 Vs es = map Val vs \<longleftrightarrow> es = map Val vs"
apply(induct es arbitrary: vs)
apply(auto, blast)
done

lemma compE1_eq_Var [simp]: "compE1 Vs e = Var V \<longleftrightarrow> (\<exists>V'. e = Var V' \<and> V = index Vs V')"
by(cases e, auto)

lemma compE1_eq_Call [simp]:
  "compE1 Vs e = obj\<bullet>M(params) \<longleftrightarrow> (\<exists>obj' params'. e = obj'\<bullet>M(params') \<and> compE1 Vs obj' = obj \<and> compEs1 Vs params' = params)"
by(cases e, auto)

lemma length_compEs2 [simp]:
  "length (compEs1 Vs es) = length es"
by(simp add: compEs1_conv_map)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows expr_locks_compE1 [simp]: "expr_locks (compE1 Vs e) = expr_locks e"
  and expr_lockss_compEs1 [simp]: "expr_lockss (compEs1 Vs es) = expr_lockss es"
by(induct Vs e and Vs es rule: compE1_compEs1.induct)(auto intro: ext)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows contains_insync_compE1 [simp]: "contains_insync (compE1 Vs e) = contains_insync e"
  and contains_insyncs_compEs1 [simp]: "contains_insyncs (compEs1 Vs es) = contains_insyncs es"
by(induct Vs e and Vs es rule: compE1_compEs1.induct)simp_all

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows max_vars_compE1: "max_vars (compE1 Vs e) = max_vars e"
  and max_varss_compEs1: "max_varss (compEs1 Vs es) = max_varss es"
apply(induct Vs e and Vs es rule: compE1_compEs1.induct)
apply(auto)
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows \<B>: "size Vs = n \<Longrightarrow> \<B> (compE1 Vs e) n"
  and \<B>s: "size Vs = n \<Longrightarrow> \<B>s (compEs1 Vs es) n"
apply(induct Vs e and Vs es arbitrary: n and n rule: compE1_compEs1.induct)
apply auto
done

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows fv_compE1: "fv e \<subseteq> set Vs \<Longrightarrow> fv (compE1 Vs e) = (index Vs) ` (fv e)"
  and fvs_compEs1: "fvs es \<subseteq> set Vs \<Longrightarrow> fvs (compEs1 Vs es) = (index Vs) ` (fvs es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  have IH: "fv exp \<subseteq> set (Vs @ [V]) \<Longrightarrow> fv (compE1 (Vs @ [V]) exp) = index (Vs @ [V]) ` fv exp" by fact
  from `fv {V:ty=vo; exp} \<subseteq> set Vs` have fv': "fv exp \<subseteq> set (Vs @ [V])" by auto
  from IH[OF this] have IH': "fv (compE1 (Vs @ [V]) exp) = index (Vs @ [V]) ` fv exp" .
  have "fv (compE1 (Vs @ [V]) exp) - {length Vs} = index Vs ` (fv exp - {V})"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x \<in> fv (compE1 (Vs @ [V]) exp) - {length Vs}"
    hence "x \<noteq> length Vs" by simp
    from x IH' have "x \<in> index (Vs @ [V]) ` fv exp" by simp
    thus "x \<in> index Vs ` (fv exp - {V})"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [V]) y"
        and y: "y \<in> fv exp"
      have "y \<noteq> V"
      proof
        assume [simp]: "y = V"
        hence "x = length Vs" by simp
        with `x \<noteq> length Vs` show False by contradiction
      qed
      moreover with fv' y have "y \<in> set Vs" by auto
      ultimately have "index (Vs @ [V]) y = index Vs y" by(simp)
      thus ?thesis using y `y \<noteq> V` by auto
    qed
  next
    fix x
    assume x: "x \<in> index Vs ` (fv exp - {V})"
    thus "x \<in> fv (compE1 (Vs @ [V]) exp) - {length Vs}"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp - {V}"
      with fv' have "y \<in> set Vs" "y \<noteq> V" by auto
      hence "index Vs y = index (Vs @ [V]) y" by simp
      with y have "x \<in> index (Vs @ [V]) ` fv exp" by auto
      thus ?thesis using IH' `y \<in> set Vs` by simp
    qed
  qed
  thus ?case by simp
next
  case (Synchronized Vs V exp1 exp2)
  have IH1: "fv exp1 \<subseteq> set Vs \<Longrightarrow> fv (compE1 Vs exp1) = index Vs ` fv exp1"
    and IH2: "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> fv (compE1 (Vs @ [fresh_var Vs]) exp2) = index (Vs @ [fresh_var Vs]) ` fv exp2"
    by fact+
  from `fv (sync\<^bsub>V\<^esub> (exp1) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set Vs" by auto
  from fv2 have fv2': "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "index (Vs @ [fresh_var Vs]) ` fv exp2 = index Vs ` fv exp2"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp2"
    thus "x \<in> index Vs ` fv exp2"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [fresh_var Vs]) y"
        and y: "y \<in> fv exp2"
      from y fv2 have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately show ?thesis using y by(auto)
    qed
  next
    fix x
    assume x: "x \<in> index Vs ` fv exp2"
    thus "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp2"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp2"
      from y fv2 have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index Vs y = index (Vs @ [fresh_var Vs]) y" by simp
      thus ?thesis using y by(auto)
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2'] show ?case by(auto)
next
  case (InSynchronized Vs V a exp)
  have IH: "fv exp \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> fv (compE1 (Vs @ [fresh_var Vs]) exp) = index (Vs @ [fresh_var Vs]) ` fv exp"
    by fact
  from `fv (insync\<^bsub>V\<^esub> (a) exp) \<subseteq> set Vs` have fv: "fv exp \<subseteq> set Vs" by simp
  hence fv': "fv exp \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "index (Vs @ [fresh_var Vs]) ` fv exp = index Vs ` fv exp"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp"
    thus "x \<in> index Vs ` fv exp"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [fresh_var Vs]) y"
        and y: "y \<in> fv exp"
      from y fv have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index (Vs @ [fresh_var Vs]) y = index Vs y" by simp
      thus ?thesis using y by simp
    qed
  next
    fix x
    assume "x \<in> index Vs ` fv exp"
    thus "x \<in> index (Vs @ [fresh_var Vs]) ` fv exp"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp"
      from y fv have "y \<in> set Vs" by auto
      moreover hence "y \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      ultimately have "index Vs y = index (Vs @ [fresh_var Vs]) y" by simp
      thus ?thesis using y by auto
    qed
  qed
  with IH[OF fv'] show ?case by simp
next
  case (TryCatch Vs exp1 C V exp2)
  have IH1: "fv exp1 \<subseteq> set Vs \<Longrightarrow> fv (compE1 Vs exp1) = index Vs ` fv exp1"
    and IH2: "fv exp2 \<subseteq> set (Vs @ [V]) \<Longrightarrow> fv (compE1 (Vs @ [V]) exp2) = index (Vs @ [V]) ` fv exp2"
    by fact+
  from `fv (try exp1 catch(C V) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set (Vs @ [V])" by auto
  have "index (Vs @ [V]) ` fv exp2 - {length Vs} = index Vs ` (fv exp2 - {V})"
  proof(rule equalityI[OF subsetI subsetI])
    fix x
    assume x: "x \<in> index (Vs @ [V]) ` fv exp2 - {length Vs}"
    hence "x \<noteq> length Vs" by simp
    from x have "x \<in> index (Vs @ [V]) ` fv exp2" by auto
    thus "x \<in> index Vs ` (fv exp2 - {V})"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index (Vs @ [V]) y"
        and y: "y \<in> fv exp2"
      have "y \<noteq> V"
      proof
        assume [simp]: "y = V"
        hence "x = length Vs" by simp
        with `x \<noteq> length Vs` show False by contradiction
      qed
      moreover with fv2 y have "y \<in> set Vs" by auto
      ultimately have "index (Vs @ [V]) y = index Vs y" by(simp)
      thus ?thesis using y `y \<noteq> V` by auto
    qed
  next
    fix x
    assume x: "x \<in> index Vs ` (fv exp2 - {V})"
    thus "x \<in> index (Vs @ [V]) ` fv exp2 - {length Vs}"
    proof(rule imageE)
      fix y
      assume [simp]: "x = index Vs y"
        and y: "y \<in> fv exp2 - {V}"
      with fv2 have "y \<in> set Vs" "y \<noteq> V" by auto
      hence "index Vs y = index (Vs @ [V]) y" by simp
      with y have "x \<in> index (Vs @ [V]) ` fv exp2" by auto
      thus ?thesis using `y \<in> set Vs` by simp
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2] show ?case by auto
qed(auto)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows syncvars_compE1: "fv e \<subseteq> set Vs \<Longrightarrow> syncvars (compE1 Vs e)"
  and syncvarss_compEs1: "fvs es \<subseteq> set Vs \<Longrightarrow> syncvarss (compEs1 Vs es)"
proof(induct Vs e and Vs es rule: compE1_compEs1_induct)
  case (Block Vs V ty vo exp)
  from `fv {V:ty=vo; exp} \<subseteq> set Vs` have "fv exp \<subseteq> set (Vs @ [V])" by auto
  from `fv exp \<subseteq> set (Vs @ [V]) \<Longrightarrow> syncvars (compE1 (Vs @ [V]) exp)`[OF this] show ?case by(simp)
next
  case (Synchronized Vs V exp1 exp2)
  note IH1 = `fv exp1 \<subseteq> set Vs \<Longrightarrow> syncvars (compE1 Vs exp1)`
  note IH2 = `fv exp2 \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> syncvars (compE1 (Vs @ [fresh_var Vs]) exp2)`
  from `fv (sync\<^bsub>V\<^esub> (exp1) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set Vs" and fv2': "fv exp2 \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "length Vs \<notin> index (Vs @ [fresh_var Vs]) ` fv exp2"
  proof
    assume "length Vs \<in> index (Vs @ [fresh_var Vs]) ` fv exp2"
    thus False
    proof(rule imageE)
      fix x
      assume x: "length Vs = index (Vs @ [fresh_var Vs]) x"
        and x': "x \<in> fv exp2"
      from x' fv2 have "x \<in> set Vs" "x \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      with x show ?thesis by(simp)
    qed
  qed
  with IH1[OF fv1] IH2[OF fv2'] fv2' show ?case by(simp add: fv_compE1)
next
  case (InSynchronized Vs V a exp)
  note IH = `fv exp \<subseteq> set (Vs @ [fresh_var Vs]) \<Longrightarrow> syncvars (compE1 (Vs @ [fresh_var Vs]) exp)`
  from `fv (insync\<^bsub>V\<^esub> (a) exp) \<subseteq> set Vs` have fv: "fv exp \<subseteq> set Vs"
    and fv': "fv exp \<subseteq> set (Vs @ [fresh_var Vs])" by auto
  have "length Vs \<notin> index (Vs @ [fresh_var Vs]) ` fv exp"
  proof
    assume "length Vs \<in> index (Vs @ [fresh_var Vs]) ` fv exp"
    thus False
    proof(rule imageE)
      fix x
      assume x: "length Vs = index (Vs @ [fresh_var Vs]) x"
        and x': "x \<in> fv exp"
      from x' fv have "x \<in> set Vs" "x \<noteq> (fresh_var Vs)" by(auto simp add: fresh_var_fresh)
      with x show ?thesis by(simp)
    qed
  qed
  with IH[OF fv'] fv' show ?case by(simp add: fv_compE1)
next
  case (TryCatch Vs exp1 C V exp2)
  note IH1 = `fv exp1 \<subseteq> set Vs \<Longrightarrow> syncvars (compE1 Vs exp1)`
  note IH2 = `fv exp2 \<subseteq> set (Vs @ [V]) \<Longrightarrow> syncvars (compE1 (Vs @ [V]) exp2)`
  from `fv (try exp1 catch(C V) exp2) \<subseteq> set Vs` have fv1: "fv exp1 \<subseteq> set Vs"
    and fv2: "fv exp2 \<subseteq> set (Vs @ [V])" by auto
  from IH1[OF fv1] IH2[OF fv2] show ?case by auto
qed auto

lemma (in heap_base) synthesized_call_compP [simp]:
  "synthesized_call (compP f P) h aMvs = synthesized_call P h aMvs"
by(simp add: synthesized_call_def)

primrec fin1 :: "'addr expr \<Rightarrow> 'addr expr1"
where
  "fin1 (Val v) = Val v"
| "fin1 (throw e) = throw (fin1 e)"

lemma comp_final: "final e \<Longrightarrow> compE1 Vs e = fin1 e"
by(erule finalE, simp_all)

lemma fixes e :: "'addr expr" and es :: "'addr expr list"
  shows [simp]: "max_vars (compE1 Vs e) = max_vars e"
  and "max_varss (compEs1 Vs es) = max_varss es"
by (induct Vs e and Vs es rule: compE1_compEs1_induct)(simp_all)

text{* Compiling programs: *}

definition compP1 :: "'addr J_prog \<Rightarrow> 'addr J1_prog"
where
  "compP1  \<equiv>  compP (\<lambda>C M Ts T (pns,body). compE1 (this#pns) body)"

declare compP1_def[simp]

end


theory ARMv8_Syntax
  imports ARMv8_Rules ARMv8_Inter
begin

datatype register = r\<^sub>0 | r\<^sub>1 | r\<^sub>2 | r\<^sub>3 | r\<^sub>4 | r\<^sub>5

syntax
  "_quote"     :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"                ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"                ("\<acute>_" [1000] 1000)
  "_Assert"    :: "'a \<Rightarrow> 'a set"                    ("(\<llangle>_\<rrangle>)" [0] 1000)

translations
  "\<llangle>b\<rrangle>" \<rightharpoonup> "CONST Collect \<guillemotleft>b\<guillemotright>"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr \<^syntax_const>\<open>_antiquote\<close> t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(\<^syntax_const>\<open>_quote\<close>, K quote_tr)] end
\<close>

type_synonym ('v,'r,'a) thread = "(('v,'a) grel \<times> ('v,'a) grel \<times> ('v,'r,'a) pred \<times> ('v,'r,'a) pred \<times> ('v,'r,'a) com_armv8 \<times> ('v,'r,'a) pred)"
type_synonym ('v,'r,'a) threads = "('v,'r,'a) thread list"

definition addI
  where "addI I \<equiv> \<lambda>x. x ! 0 + I"

definition subI
  where "subI I \<equiv> \<lambda>x. x ! 0 - I"

definition addR
  where "addR \<equiv> \<lambda>x. x ! 0 + x ! 1"

definition subR
  where "subR \<equiv> \<lambda>x. x ! 0 - x ! 1"

definition modI
  where "modI I \<equiv> \<lambda>x. x ! 0 mod I"

definition modR
  where "modR \<equiv> \<lambda>x. x ! 0 mod x ! 1"

definition movI
  where "movI I \<equiv> \<lambda>x. I"

definition ODD :: "'b \<Rightarrow> ((nat,'b) exp \<times> (nat \<Rightarrow> nat \<Rightarrow> bool) \<times> (nat,'b) exp)"
  where "ODD r = (Exp (\<lambda>x. x ! 0 mod 2) [Var r], (=), Val 1)"

definition NEQ :: "'b \<Rightarrow> 'b \<Rightarrow> ((nat,'b) exp \<times> (nat \<Rightarrow> nat \<Rightarrow> bool) \<times> (nat,'b) exp)"
  where "NEQ r1 r2 = (Var r1, (\<noteq>), Var r2)"

definition LE :: "'b \<Rightarrow> 'b \<Rightarrow> ((nat,'b) bexp)"
  where "LE r1 r2 = Exp\<^sub>B (\<lambda>x. x!0 < x!1) [Var r1, Var r2]"

definition Z ::  "'b \<Rightarrow> ((nat,'b) bexp)"
  where "Z r = Exp\<^sub>B (\<lambda>x. x!0 = 0) [Var r]"

syntax
  "_Load"  :: "'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) com_armv8" ("(_ := [_]~_)" [70, 65] 61)
  "_LoadC"  :: "'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> 'c \<Rightarrow> ('v,'r,'a) com_armv8" ("(_ := [_ + #_]~_)" [70, 65] 61)
  "_LoadIC"  :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> 'c \<Rightarrow> ('v,'r,'a) com_armv8" ("(\<lbrace>_\<rbrace> _ := [_ + #_]~_)" [20, 70, 65] 61)

  "_Store" :: "'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) com_armv8" ("([_] := _ ~ _)" [70, 65] 61)
  "_StoreI" :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'v \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) com_armv8" ("(\<lbrace>_\<rbrace> [_ + #_] := _ ~ _)" [20, 70, 65] 61)
  "_StoreIA" :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'v \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) auxfn  \<Rightarrow> ('v,'r,'a) com_armv8" ("(\<lbrace>_\<rbrace> [_ + #_] := _ ~ _ :\<^sub>a _)" [20, 70, 65] 61)

  "_Fence" :: "(nat,'b,'a) com_armv8" ("(fence)" 61)
  "_CFence" :: "(nat,'b,'a) com_armv8" ("(cfence)" 61)
  "_Cas" :: "('v,'r,'a) pred \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'r \<Rightarrow> 'v set \<Rightarrow> ('v,'r,'a) auxfn  \<Rightarrow> ('v,'b,'a) com_armv8" ("(\<lbrace>_\<rbrace> _ := cas _ _ _ ~ _, _)" [20, 70, 65] 61)

  "_AddI"  :: "'b \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ + #_)" [70, 65, 65] 61)
  "_SubI"  :: "'b \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ - #_)" [70, 65, 65] 61)

  "_AddR"  :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ + _)" [70, 65, 65] 61)
  "_SubR"  :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ - _)" [70, 65, 65] 61)

  "_ModI"  :: "'b \<Rightarrow> 'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ % #_)" [70, 65, 65] 61)
  "_ModR"  :: "'b \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := _ % _)" [70, 65, 65] 61)
  "_MovI"  :: "'b \<Rightarrow> nat \<Rightarrow> (nat,'b,'a) com_armv8" ("(_ := #_)" [70, 65] 61)
  "_Seq"   :: "(nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8" ("(_;/ _)" [60,61] 60)

  "_If" :: "((nat,'b) exp \<times> (nat \<Rightarrow> nat \<Rightarrow> bool) \<times> (nat,'b) exp) \<Rightarrow> (nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8 \<Rightarrow> (nat,'b,'a) com_armv8"
                ("(if _/ then _ //else _ /fi)"   [0,0,0] 61)
  "_If1" :: "'b \<Rightarrow> ('v,'r,'a) com_armv8 \<Rightarrow> ('v,'r,'a) com_armv8"
                ("(if _/ then _ /fi)"   [0,0] 61)
  "_Spec" :: "('v,'a) grel \<Rightarrow> ('v,'a) grel \<Rightarrow> ('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) com_armv8 \<Rightarrow> ('v,'r,'a) pred \<Rightarrow> ('v,'r,'a) thread"
                ("(R: _ //G:_ //I: _ //P: _ //{ _ } //Q: _)" [0,0,0,0] 61)
  "_AuxAssign"    :: "idt \<Rightarrow> 'b \<Rightarrow> ('v,'r,'a) auxfn" ("(\<^sup>a_ :=/ _)" [70, 65] 61)

translations
  "\<^sup>ax := a" \<rightharpoonup> "CONST state_rec.more o \<guillemotleft>\<acute>(state_rec.more_update (_update_name x (\<lambda>_. a)))\<guillemotright>"

  "x := [a]~v" \<rightharpoonup> "CONST Load (CONST UNIV) v (CONST Var a) x (CONST state_rec.more)"
  "x := [a + #I]~v" \<rightharpoonup> "CONST Load (CONST UNIV) v (CONST Exp (CONST addI I) [CONST Var a]) x (CONST state_rec.more)"
  "\<lbrace>P\<rbrace> x := [a + #I]~v" \<rightharpoonup> "CONST Load \<llangle>P\<rrangle> v (CONST Exp (CONST addI I) [CONST Var a]) x (CONST state_rec.more)"

  "[a] := r ~ v" \<rightharpoonup> "CONST Store (CONST UNIV) v (CONST Var a) r (CONST state_rec.more)"
  "\<lbrace>P\<rbrace> [a + #I] := x ~ v" \<rightharpoonup> "CONST Store \<llangle>P\<rrangle> v (CONST Exp (CONST addI I) [CONST Var a]) x (CONST state_rec.more)"
  "\<lbrace>P\<rbrace> [ra + #I] := r ~ v :\<^sub>a a" \<rightharpoonup> "CONST Store \<llangle>P\<rrangle> v (CONST Exp (CONST addI I) [CONST Var ra]) r a"

  "\<lbrace>P\<rbrace> r\<^sub>1 := cas r\<^sub>2 r\<^sub>3 r\<^sub>4 ~ v, a" \<rightharpoonup> "CONST CAS \<llangle>P\<rrangle> v r\<^sub>2 r\<^sub>3 r\<^sub>4 r\<^sub>1 1 0 a"

  "X := Y - #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST subI I) [CONST Var Y])"
  "X := Y + #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST addI I) [CONST Var Y])"
  "X := Y + Z" \<rightharpoonup> "CONST Op X (CONST Exp (CONST addR) [CONST Var Y, CONST Var Z])"
  "X := Y - Z" \<rightharpoonup> "CONST Op X (CONST Exp (CONST subR) [CONST Var Y, CONST Var Z])"
  "X := Y % #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST modI I) [CONST Var Y])"
  "X := Y % Z" \<rightharpoonup> "CONST Op X (CONST Exp (CONST modR) [CONST Var Y, CONST Var Z])"

  "X := #I" \<rightharpoonup> "CONST Op X (CONST Exp (CONST movI I) [])"
  "fence" \<rightharpoonup> "CONST Fence"
  "cfence" \<rightharpoonup> "CONST Fence"
  "c\<^sub>1 ; c\<^sub>2" \<rightharpoonup> "CONST Seq c\<^sub>1 c\<^sub>2"
  "if b then c\<^sub>1 else c\<^sub>2 fi" \<rightharpoonup> "CONST If b c\<^sub>1 c\<^sub>2"
  "if b then c\<^sub>1 fi" \<rightharpoonup> "CONST If b c\<^sub>1 (CONST Skip)"
  "R: R G: G I: I P: P {c} Q: Q" \<rightharpoonup> "(\<llangle>R\<rrangle>,\<llangle>G\<rrangle>,\<llangle>I\<rrangle>,\<llangle>P\<rrangle>,c,\<llangle>Q\<rrangle>)"

definition inv2
  where "inv2 I \<equiv> {(m,m'). m \<in> glb ` I \<longrightarrow> m' \<in> glb ` I}"

fun fn_valid :: "('v::equal,'r::equal,'a) threads \<Rightarrow> bool"
  where
    "fn_valid [(R,G,I,P,c,Q)] = (stable\<^sub>t R Q \<and> wellformed R G \<and> guar\<^sub>c c (inv2 I \<inter> G) \<and>
                                (stable\<^sub>t R Q \<longrightarrow> P \<subseteq> wp (inv2 I \<inter> R) c Q) \<and>
                                (wellformed R G \<longrightarrow> rif_checks c R G))" |
    "fn_valid _ = undefined"

nonterminal prgs

syntax
  "_PAR"        :: "prgs \<Rightarrow> 'a"              ("COBEGIN//_//COEND" 60)
  "_FN"        :: "prgs \<Rightarrow> 'a"              ("FNBEGIN//_//FNEND" 60)
  "_prg"        :: "'a \<Rightarrow> prgs"              ("_" 57)
  "_prgs"       :: "['a, prgs] \<Rightarrow> prgs"      ("_//\<parallel>//_" [60,57] 57)

translations
  "_prg a" \<rightharpoonup> "[a]"
  "_prgs a ps" \<rightharpoonup> "a # ps"
  "_FN t" \<rightharpoonup> "CONST fn_valid t"

syntax
  "_before"  :: "'b \<Rightarrow> 'a" ("\<^sup>1_" [100] 400)
  "_after"   :: "'b \<Rightarrow> 'a" ("\<^sup>2_" [100] 400)
  "_mem"     :: "'g \<Rightarrow> 'a" ("\<^sup>s[_]")
  "_mbefore" :: "'g \<Rightarrow> 'a" ("\<^sup>1[_]")
  "_mafter"  :: "'g \<Rightarrow> 'a" ("\<^sup>2[_]")
  "_reg"     :: "'r \<Rightarrow> 'a" ("\<^sup>r_" [100] 1000)
  "_rbefore" :: "'r \<Rightarrow> 'a" ("\<^sup>1\<^sup>r_")
  "_rafer"   :: "'r \<Rightarrow> 'a" ("\<^sup>2\<^sup>r_")
  "_aux"     :: "'b \<Rightarrow> 'a" ("\<^sup>a_" [100] 1000)
  "_abefore" :: "'b \<Rightarrow> 'a" ("\<^sup>1\<^sup>a_" [100] 400)
  "_aafer"   :: "'b \<Rightarrow> 'a" ("\<^sup>2\<^sup>a_" [100] 400)

definition gld :: "('v,'r,'a) state \<Rightarrow> ('v \<Rightarrow> 'v)"
  where "gld m \<equiv> \<lambda>v. st m (Glb v)"

translations
  "\<^sup>1x" \<rightleftharpoons> "x (\<acute>CONST fst)"
  "\<^sup>2x" \<rightleftharpoons> "x (\<acute>CONST snd)"
  "\<^sup>s[X]" \<rightleftharpoons> "(\<acute>CONST gld) X"
  "\<^sup>1[X]" \<rightleftharpoons> "(CONST st (\<acute>CONST fst)) X"
  "\<^sup>2[X]" \<rightleftharpoons> "(CONST st (\<acute>CONST snd)) X"
  "\<^sup>rX" \<rightleftharpoons> "(\<acute>CONST rg) X"
  "\<^sup>1\<^sup>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST fst)) X"
  "\<^sup>2\<^sup>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST snd)) X"
  "\<^sup>aX" \<rightleftharpoons> "X (\<acute>CONST state_rec.more)"
  "\<^sup>1\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST fst))"
  "\<^sup>2\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST snd))"

(*
syntax
  "_before"  :: "'b \<Rightarrow> 'a" ("\<^sup>1_" [100] 400)
  "_after"   :: "'b \<Rightarrow> 'a" ("\<^sup>2_" [100] 400)
  "_mem"     :: "'b \<Rightarrow> 'a" ("\<lbrakk>_\<rbrakk>")
  "_mat"     :: "'b \<Rightarrow> 'a" ("\<^sup>0\<lbrakk>_\<rbrakk>")
  "_mbefore" :: "'b \<Rightarrow> 'a" ("\<^sup>1\<lbrakk>_\<rbrakk>")
  "_mafter"  :: "'b \<Rightarrow> 'a" ("\<^sup>2\<lbrakk>_\<rbrakk>")
  "_reg"     :: "'r \<Rightarrow> 'a" ("\<^bold>r_" [1000] 1000)
  "_rar"     :: "'r \<Rightarrow> 'a" ("\<^sup>0\<^bold>r_" [100] 1000)
  "_rbefore" :: "'r \<Rightarrow> 'a" ("\<^sup>1\<^bold>r_")
  "_rafer"   :: "'r \<Rightarrow> 'a" ("\<^sup>2\<^bold>r_")
  "_val"     :: "'b \<Rightarrow> 'a" ("#_" [100] 1000)
  "_aux"     :: "'b \<Rightarrow> 'a" ("\<^sup>a_" [100] 1000)
  "_abefore" :: "'b \<Rightarrow> 'a" ("\<^sup>1\<^sup>a_" [100] 400)
  "_aafer"   :: "'b \<Rightarrow> 'a" ("\<^sup>2\<^sup>a_" [100] 400)

translations
  "\<^sup>1x" \<rightleftharpoons> "x (\<acute>CONST fst)"
  "\<^sup>2x" \<rightleftharpoons> "x (\<acute>CONST snd)"
  "\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "CONST Var (CONST Glb X)"
  "\<^sup>0\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "(CONST st (\<acute>CONST glb)) X"
  "\<^sup>1\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "(CONST st (\<acute>CONST fst)) X"
  "\<^sup>2\<lbrakk>X\<rbrakk>" \<rightleftharpoons> "(CONST st (\<acute>CONST snd)) X"
  "\<^bold>rX" \<rightleftharpoons> "CONST Var (CONST Var X)"
  "\<^sup>0\<^bold>rX" \<rightleftharpoons> "(\<acute>CONST rg) X"
  "\<^sup>1\<^bold>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST fst)) X"
  "\<^sup>2\<^bold>rX" \<rightleftharpoons> "(CONST rg (\<acute>CONST snd)) X"
  "#X" \<rightleftharpoons> "CONST Val X"
  "\<^sup>aX" \<rightleftharpoons> "X (\<acute>CONST state_rec.more)"
  "\<^sup>1\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST fst))"
  "\<^sup>2\<^sup>aX" \<rightleftharpoons> "X (CONST state_rec.more (\<acute>CONST snd))"
*)

syntax
  "_con" :: "nat \<Rightarrow> 'a" ("=[_]" [100] 1000)
  "_inc" :: "nat \<Rightarrow> 'a" ("\<le>[_]" [100] 1000)

translations
  "=[X]" \<rightharpoonup> "(CONST st (\<acute>CONST snd)) X = (CONST st (\<acute>CONST fst)) X"
  "\<le>[X]" \<rightharpoonup> "(CONST st (\<acute>CONST snd)) X \<ge> (CONST st (\<acute>CONST fst)) X"

lemma [simp]:
  "reflexive R \<Longrightarrow> stabilize R {} = {}"
  by (auto simp: reflexive_def stabilize_def)

lemma [simp]:
  "reflexive R \<Longrightarrow> stabilize R (assert P) = assert P"
  by (auto simp: assert_def)

lemma [simp]:
  "{m. m(a :=\<^sub>s e) \<in> (assert P)} = assert P"
  by (auto simp: assert_def)

lemma [simp]:
  "reflexive R \<Longrightarrow> UNIV \<subseteq> stabilize R P = (\<forall>m. m \<in> P)"
  by (auto simp: reflexive_def stabilize_def assert_def glb_def)

lemma [simp]:
  "stabilize R (P \<inter> Q) = stabilize R P \<inter> stabilize R Q"
  by (auto simp: stabilize_def)

lemma [simp]:
  "{m. (f m) \<in> assert P} = assert P"
  by (auto simp: assert_def)

lemma [simp]:
  "UNIV \<subseteq> assert P = P"
  by (auto simp: assert_def)

lemma [simp]:
  "x(aux: state_rec.more) = x"
  by (auto simp: aux_upd_def)

lemma [simp]:
  "st (glb (x(Glb z :=\<^sub>s e))) = (st (glb x))(z := e)"
  by (auto simp: st_upd_def glb_def)

lemma [simp]:
  "st (glb (x(aux:f ))) = (st (glb x))"
  by (auto simp: st_upd_def glb_def)

lemma glb_in [intro!]:
  assumes "\<exists>l. \<lparr> st = (\<lambda>v. case v of Reg v \<Rightarrow> l v | _ \<Rightarrow> st m v), \<dots> = state_rec.more m \<rparr> \<in> P"
  shows "glb m \<in> glb ` P"
proof -
  obtain l where "\<lparr> st = (\<lambda>v. case v of Reg v \<Rightarrow> l v | _ \<Rightarrow> st m v), \<dots> = state_rec.more m \<rparr> \<in> P"
    (is "?m \<in> P")
    using assms by auto
  hence "glb ?m \<in> glb ` P" by auto
  moreover have "glb m = glb ?m" by (auto simp: glb_def)
  ultimately show ?thesis by auto
qed

lemma  a:
  "glb x = glb y \<Longrightarrow> st x (Glb e) = st y (Glb e)"
  unfolding glb_def
  by (metis state_rec.select_convs(1))

lemma  b:
  "glb x = glb y \<Longrightarrow> state_rec.more x = state_rec.more y"
  unfolding glb_def by simp

lemma [simp]:
  "st (glb x) y = st x (Glb y)"
  unfolding glb_def by auto

fun chain
  where "chain [] Q = Q" | "chain (a#xs) Q = chain xs (wpre a Q)"
declare chain.simps [simp del]

lemma chain_singleI:
  "wpre a Q = chain [a] Q"
  unfolding chain.simps by auto

lemma chain_singleI':
  "stabilize R Q = chain [env R] Q"
  unfolding chain.simps by auto

lemma chain_lastE:
  "chain (xs @ [a]) Q = wpre a ( (chain xs Q))"
  by (induct xs arbitrary: Q) (auto simp: chain.simps)

lemma chain_lastI:
  "chain [a] (chain xs Q) = chain (xs@[a]) Q"
  by (induct xs) (auto simp: chain_lastE chain.simps)

lemma chain_merge:
  "chain l (chain l' Q) = chain (l'@l) Q"
  by (induct l' arbitrary: Q) (simp add: chain.simps)+

lemma stabilize_mono:
  "P \<subseteq> Q \<Longrightarrow> stabilize R P  \<subseteq> stabilize R Q"
  unfolding stabilize_def by auto

lemma pre_mono:
  "P \<subseteq> Q \<Longrightarrow> wpre a P \<subseteq> wpre a Q"
  using  stabilize_mono apply (cases a) apply (auto)
  by blast

lemma chain_mono:
  "P \<subseteq> Q \<Longrightarrow> chain xs P \<subseteq> chain xs Q"
  by (induct xs arbitrary: P Q) (auto simp: pre_mono stabilize_mono chain.simps)

lemma chain1_wpre:
  "P \<subseteq> chain xs (wpre a Q) \<Longrightarrow> P \<subseteq> chain (a#xs) Q"
  unfolding chain.simps .

lemma chain1_stab:
  "P \<subseteq> chain xs (stabilize R Q) \<Longrightarrow> P \<subseteq> chain (env R#xs) Q"
  unfolding chain.simps by auto

lemma chain0:
  "P \<subseteq> Q \<Longrightarrow> P \<subseteq>  chain [] Q"
  unfolding chain.simps .

lemma chain_extend:
  "P \<subseteq> chain xs (Q \<inter> X) \<Longrightarrow> P \<subseteq> chain xs Q"
  using chain_mono[of "Q \<inter> X" Q] by (auto simp: )

lemma chain_rewrite:
  "X \<subseteq> Q \<Longrightarrow> P \<subseteq> chain xs X \<Longrightarrow> P \<subseteq> chain xs Q"
  using chain_mono  by blast

definition str where
  "str R P \<equiv> if P \<subseteq> stabilize R P then P else UNIV"

lemma str_mono:
  "Q \<subseteq> P \<Longrightarrow> Q \<subseteq> str R P"
  unfolding str_def by (auto simp: )

lemma stabilize_univ:
  "UNIV \<subseteq> stabilize R UNIV"
  unfolding stabilize_def by auto

lemma stabilize_str:
  "str R P \<subseteq> stabilize R (str R P)"
  unfolding str_def stabilize_def by simp

lemma [simp]: "wpre a (P \<inter> Q) = (wpre a P \<inter> wpre a Q)"
  by (cases a, auto)

lemma chain_inter: "chain l (P \<inter> Q) = (chain l P \<inter> chain l Q)"
  by (induct l arbitrary: P Q, auto simp: chain.simps)

lemma stable_stabilize:
  "stable\<^sub>t R Q \<Longrightarrow> Q \<subseteq> stabilize R Q"
  unfolding stabilize_def stable_def step\<^sub>t_def
  by auto

lemma strI:
  "stable\<^sub>t R Q \<Longrightarrow> K \<subseteq> chain l (str R Q) \<Longrightarrow>  K \<subseteq> chain (env R#l) Q"
  unfolding chain.simps str_def apply simp
  using stable_stabilize
  by (metis (mono_tags) chain_rewrite)

lemma envI:
  "stable\<^sub>t R Q \<Longrightarrow> K \<subseteq> chain l (Q) \<Longrightarrow>  K \<subseteq> chain (env R#l) Q"
  unfolding chain.simps str_def apply simp
  using stable_stabilize
  by (metis (mono_tags) chain_rewrite)

lemma ir_str:
  "wpre (ir r e) (str R Q) \<supseteq> str R (wpre (ir r e) Q)"
  apply (auto simp: str_def stabilize_def st_upd_def)
   apply (subgoal_tac "rg (x\<lparr>st := (st x)(Reg r := ev\<^sub>E (rg m') e)\<rparr>) = rg (m'\<lparr>st := (st m')(Reg r := ev\<^sub>E (rg m') e)\<rparr>)")
     apply (subgoal_tac "(glb (x\<lparr>st := (st x)(Reg r := ev\<^sub>E (rg m') e)\<rparr>), glb (m'\<lparr>st := (st m')(Reg r := ev\<^sub>E (rg m') e)\<rparr>)) \<in> R")
     apply blast
  apply (auto simp: glb_def)[1]
  unfolding rg_def apply auto[1]
  done

lemma cm_str:
  "wpre (cm b) (str R Q) \<supseteq> str R (wpre (cm b) Q)"
  by (auto simp: str_def stabilize_def st_upd_def)

lemma ncm_str:
  "wpre (ncm b) (str R Q) \<supseteq> str R (wpre (ncm b) Q)"
  by (auto simp: str_def stabilize_def st_upd_def)

lemma ign_str:
  "Q \<subseteq> str R Q"
  by (auto simp: str_def)

lemma [simp]:
  "state_rec.more (glb x) = state_rec.more x"
  unfolding glb_def by auto

end


section \<open>The Second Monotonicity Calculus\<close>
theory Mcalc2
imports Mono
begin

subsection\<open>Extension policies\<close>

text\<open>Extension policy: copy, true or false extension:\<close>

datatype epol = Cext | Text | Fext

text\<open>Problem with infinite knowledge and predicate-extension policy:\<close>

locale ProblemIkPol = ProblemIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp
+ fixes (* the predicate-extension policy *) pol :: "'tp \<Rightarrow> 'psym \<Rightarrow> epol"
and (* guard of a variable occurring in a certain literal of a certain clause: *)
    grdOf ::
"('fsym, 'psym) cls \<Rightarrow> ('fsym, 'psym) lit \<Rightarrow> var \<Rightarrow> ('fsym, 'psym) lit"

context ProblemIkPol begin

subsection\<open>Naked variables\<close>

fun nv2T where
"nv2T (Var x) = {x}"
|
"nv2T (Fn f Tl) = {}"

fun nv2L where
"nv2L (Pos (Eq T1 T2)) = nv2T T1 \<union> nv2T T2"
|
"nv2L (Neg (Eq T1 T2)) = {}"
|
"nv2L (Pos (Pr p Tl)) = {x \<in> \<Union> (set (map nv2T Tl)) . pol (tpOfV x) p = Fext}"
|
"nv2L (Neg (Pr p Tl)) = {x \<in> \<Union> (set (map nv2T Tl)) . pol (tpOfV x) p = Text}"

definition "nv2C c \<equiv> \<Union> (set (map nv2L c))"

lemma in_nv2T: "x \<in> nv2T T \<longleftrightarrow> T = Var x"
apply(cases T)
  apply (metis equals0D nv2T.simps singleton_iff)
  by simp

lemma nv2T_vars[simp]: "x \<in> nv2T T \<Longrightarrow> x \<in> vars T"
by (induct T, auto split: if_splits)

lemma nv2L_varsL[simp]:
assumes "x \<in> nv2L l" shows "x \<in> varsL l"
proof (cases l)
  case (Pos at)
  show ?thesis proof(cases at)
    case (Pr p Tl) thus ?thesis using assms unfolding Pos
    apply(cases "pol (tpOfV x) p", simp_all) by (metis nv2T_vars)
  qed(insert assms, unfold Pos, auto)
next
  case (Neg at)
  show ?thesis proof(cases at)
    case (Pr p Tl) thus ?thesis using assms unfolding Neg
    apply(cases "pol (tpOfV x) p", simp_all) by (metis nv2T_vars)
  qed(insert assms, unfold Neg, auto)
qed

lemma nv2C_varsC[simp]: "x \<in> nv2C c \<Longrightarrow> x \<in> varsC c"
unfolding varsC_def nv2C_def by (induct c, auto)

subsection\<open>The calculus\<close>

text\<open>The notion of a literal being a guard for a (typed) variable:\<close>

fun isGuard :: "var \<Rightarrow> ('fsym,'psym) lit \<Rightarrow> bool" where
"isGuard x (Pos (Eq T1 T2)) \<longleftrightarrow> False"
|
"isGuard x (Neg (Eq T1 T2)) \<longleftrightarrow>
 (T1 = Var x \<and> (\<exists> f Tl. T2 = Fn f Tl)) \<or>
 (T2 = Var x \<and> (\<exists> f Tl. T1 = Fn f Tl))"
|
"isGuard x (Pos (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> (set (map nv2T Tl)) \<and> pol (tpOfV x) p = Text"
|
"isGuard x (Neg (Pr p Tl)) \<longleftrightarrow> x \<in> \<Union> (set (map nv2T Tl)) \<and> pol (tpOfV x) p = Fext"

text\<open>The monotonicity calculus from the Classen et. al. paper, applied
to non-infinite types only: it checks that any variable in any literal of any clause
is indeed guarded by its guard:\<close>

inductive mcalc2 (infix "\<turnstile>2" 40) where
 [simp]: "infTp \<sigma> \<Longrightarrow> \<sigma> \<turnstile>2 c"
|[simp]: "(\<And> l x. \<lbrakk>l \<in> set c; x \<in> nv2L l; tpOfV x = \<sigma>\<rbrakk>
         \<Longrightarrow> isGuard x (grdOf c l x)) \<Longrightarrow> \<sigma> \<turnstile>2 c"

lemma mcalc2_iff:
"\<sigma> \<turnstile>2 c \<longleftrightarrow>
 infTp \<sigma> \<or> (\<forall> l x. l \<in> set c \<and> x \<in> nv2L l \<and> tpOfV x = \<sigma> \<longrightarrow> isGuard x (grdOf c l x))"
unfolding mcalc2.simps by auto

end (* context ProblemIk *)

locale ProblemIkPolMcalc2 = ProblemIkPol wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and pol and grdOf
+ assumes
(* well-definednedd of the guard: *)
    grdOf: "\<And> c l x. \<lbrakk>c \<in> \<Phi>; l \<in> set c; x \<in> nv2L l; \<not> infTp (tpOfV x)\<rbrakk>
                     \<Longrightarrow> grdOf c l x \<in> set c"
and mcalc2: "\<And> \<sigma> c. c \<in> \<Phi> \<Longrightarrow> \<sigma> \<turnstile>2 c"
begin
lemma wtL_grdOf[simp]:
assumes "c \<in> \<Phi>" and "l \<in> set c" and "x \<in> nv2L l" and "\<not> infTp (tpOfV x)"
shows "wtL (grdOf c l x)"
using grdOf[OF assms] by (metis assms list_all_iff wtC_def wtPB_def wt_\<Phi>)
end

locale ModelIkPolMcalc2 =
ModelIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp intT intF intP +
ProblemIkPolMcalc2 wtFsym wtPsym arOf resOf parOf \<Phi> infTp pol grdOf
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp pol and grdOf and intT and intF and intP

end


theory Failures_Stable_TickTock
  imports Failures_TickTock Failures
begin

thm sf2f_def F2f_def mkF24_def ttproc2F_def

(* mapping from  tick-tock to stable failures (with stable tick) *)
definition tt2sf :: "'a ttprocess \<Rightarrow> 'a process" where
  "tt2sf P =
    ({ (t, X) | t X. (map (\<lambda> e. [ttevt2F e]\<^sub>E) t) @ [[ttevt2F ` X]\<^sub>R] \<in> P }
      \<union> {(t, X) | t X. (map (\<lambda> e. [ttevt2F e]\<^sub>E) t) @ [[Tick]\<^sub>E] \<in> P \<and> X \<subseteq> UNIV-{tick}}
      \<union> {(t @ [tick], X) | t X. (map (\<lambda> e. [ttevt2F e]\<^sub>E) t) @ [[Tick]\<^sub>E] \<in> P \<and> X \<subseteq> UNIV},
    {tt2T y |y. y \<in> P})"

lemma end_tick_in_traces:
  "\<And>P. ttWF (map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[Tick]\<^sub>E]) \<Longrightarrow>
       map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow>
  a @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
  apply (induct a, simp_all)
  using traces_def apply force
  apply (case_tac a1, simp_all)
  apply (metis Nil_is_append_conv neq_Nil_conv ttWF.simps(8))
proof -
  fix a1 a2 P x2
  assume ind_hyp: "\<And>P. map (\<lambda>e. [ttevt2F e]\<^sub>E) a2 @ [[Tick]\<^sub>E] \<in> P \<Longrightarrow>
           a2 @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
  assume "[Event x2]\<^sub>E # map (\<lambda>e. [ttevt2F e]\<^sub>E) a2 @ [[Tick]\<^sub>E] \<in> P"
  then have "a2 @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> {t. [Event x2]\<^sub>E # t \<in> P}},
         {tt2T y |y. y \<in> {t. [Event x2]\<^sub>E # t \<in> P}}))"
    using ind_hyp by force
  then show "evt x2 # a2 @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
    by (smt mem_Collect_eq snd_conv traces_def tt2T.simps(2))
qed

lemma end_refusal_ttWF_eq:
  "ttWF (map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R])
    \<Longrightarrow> Some (a, b) = tt2F (map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R])"
  apply (induct a, auto)
  using Some_tt2F_set apply fastforce
  apply (case_tac a1, auto)
  apply (metis Nil_is_append_conv neq_Nil_conv ttWF.simps(8))
  by (metis fst_conv option.simps(5) snd_conv)

lemma tt2F_Some_ref_end_refusal:
  "\<And>a. Some (a, b) = tt2F y \<Longrightarrow>
    y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R]
    \<or> y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[(ttevt2F ` b) \<union> {Tock}]\<^sub>R]"
  apply (induct y rule:ttWF.induct, auto)
    apply (smt image_def mem_Collect_eq ttevent.exhaust ttevt2F.simps(1) ttevt2F.simps(2))
  apply (case_tac xa, auto)
  apply (metis image_eqI mem_Collect_eq ttevt2F.simps(1))
   apply (metis mem_Collect_eq rev_image_eqI ttevt2F.simps(2))
  by (case_tac "tt2F \<sigma>", auto)

lemma tt2F_Some_ref_end_refusal_in_TT1:
  "TT1 P \<Longrightarrow> Some (a, b) = tt2F y \<Longrightarrow> y \<in> P \<Longrightarrow>
    map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R] \<in> P"
proof -
  assume TT1_P: "TT1 P"
  assume y_in_P: "y \<in> P"
  assume tt2F_y_Some: "Some (a, b) = tt2F y"

  have "y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R]
    \<or> y = map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[(ttevt2F ` b) \<union> {Tock}]\<^sub>R]"
    using tt2F_Some_ref_end_refusal tt2F_y_Some by blast
  then show "map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R] \<in> P"
    using y_in_P
  proof auto
    have "map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R]
      \<lesssim>\<^sub>C map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[insert Tock (ttevt2F ` b)]\<^sub>R]"
      by (induct a, auto)
    then show "map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[insert Tock (ttevt2F ` b)]\<^sub>R] \<in> P
      \<Longrightarrow> map (\<lambda>e. [ttevt2F e]\<^sub>E) a @ [[ttevt2F ` b]\<^sub>R] \<in> P"
      using TT1_P TT1_def by blast
  qed
qed

lemma end_tick_in_traces_imp_in_ttproc:
  "\<And>P. s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))
    \<Longrightarrow> map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> P"
proof (induct s, auto)
  fix P
  show "[tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P})) \<Longrightarrow> [[Tick]\<^sub>E] \<in> P"
    by (smt append_Nil mem_Collect_eq snd_conv tick_tt2T_concat_TickE traces_def tt2T_tick_exists_Cons)
next
  fix a s P
  assume ind_hyp: "\<And>P. s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P})) \<Longrightarrow>
             map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> P"
  assume "a # s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P}))"
  then have "s @ [tick]
    \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> {t. [ttevt2F a]\<^sub>E # t \<in> P}},
               {tt2T y |y. y \<in> {t. [ttevt2F a]\<^sub>E # t \<in> P}}))"
    unfolding traces_def
  proof auto
    fix y
    assume case_assms: "a # s @ [tick] = tt2T y" "y \<in> P"
    then obtain y' where y'_assms: "s @ [tick] = tt2T y' \<and> y = [ttevt2F a]\<^sub>E # y'"
      apply (cases y, auto, cases a, auto, case_tac aa, auto, case_tac x1, auto)
      apply (metis append_Cons neq_Nil_conv self_append_conv2 tt2T.simps(1) tt2T.simps(7))
      apply (case_tac aa, auto, case_tac x1, auto)
      by (metis append_Cons neq_Nil_conv self_append_conv2 tt2T.simps(1) tt2T.simps(7))
    then have "map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> {t. [ttevt2F a]\<^sub>E # t \<in> P}"
      using ind_hyp[where P="{t. [ttevt2F a]\<^sub>E # t \<in> P}"] case_assms(2) traces_def by fastforce
    then show "\<exists>y. s @ [tick] = tt2T y \<and> [ttevt2F a]\<^sub>E # y \<in> P"
      using y'_assms case_assms(2) by blast
  qed
  then show "a # s @ [tick] \<in> traces(({(s, X). \<exists>y. Some (s, X) = tt2F y \<and> y \<in> P}, {tt2T y |y. y \<in> P})) \<Longrightarrow>
       [ttevt2F a]\<^sub>E # map (\<lambda>e. [ttevt2F e]\<^sub>E) s @ [[Tick]\<^sub>E] \<in> P"
    using ind_hyp by blast
qed

lemma tt2sf_eq_mkF24_ttproc2F:
  assumes P_wf: "\<forall>x\<in>P. ttWF x" and TT1_P: "TT1 P"
  shows "tt2sf P = mkF24 (ttproc2F P)"
  unfolding mkF24_def tt2sf_def ttproc2F_def
  apply auto
  using assms end_refusal_ttWF_eq apply blast
  using assms end_tick_in_traces apply blast
  using assms end_tick_in_traces apply blast
  apply (simp add: TT1_P tt2F_Some_ref_end_refusal_in_TT1)
  apply (simp add: TT1_P tt2F_Some_ref_end_refusal_in_TT1)
  using end_tick_in_traces_imp_in_ttproc apply blast
  using end_tick_in_traces_imp_in_ttproc apply blast
  using end_tick_in_traces_imp_in_ttproc apply blast
  by (auto simp add: traces_def)

end


(*  Title:      Mapping_Exts.thy
    Author:     Denis Lohner, Sebastian Ullrich
*)

subsection "Mapping Extensions"

text \<open>Some lifted definition on mapping and efficient implementations.\<close>

theory Mapping_Exts
imports "HOL-Library.Mapping" FormalSSA_Misc
begin

lift_definition mapping_delete_all :: "('a \<Rightarrow> bool) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
  is "\<lambda>P m x. if (P x) then None else m x" .
lift_definition map_keys :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a,'c) mapping \<Rightarrow> ('b,'c) mapping"
  is "\<lambda>f m x. if f -` {x} \<noteq> {} then m (THE k. f -` {x} = {k}) else None" .
lift_definition map_values :: "('a \<Rightarrow> 'b \<Rightarrow> 'c option) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'c) mapping"
  is "\<lambda>f m x. Option.bind (m x) (f x)" .
lift_definition restrict_mapping :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a, 'b) mapping"
  is "\<lambda>f. restrict_map (Some \<circ> f)" .
lift_definition mapping_add :: "('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
  is "(++)" .

definition "mmap = Mapping.map id"

lemma lookup_map_keys: "Mapping.lookup (map_keys f m) x = (if f -` {x} \<noteq> {} then Mapping.lookup m (THE k. f -` {x} = {k}) else None)"
apply transfer ..

lemma Mapping_Mapping_lookup [simp, code_unfold]: "Mapping.Mapping (Mapping.lookup m) = m" by transfer simp
declare Mapping.lookup.abs_eq[simp]

lemma Mapping_eq_lookup: "m = m' \<longleftrightarrow> Mapping.lookup m = Mapping.lookup m'" by transfer simp

lemma map_of_map_if_conv:
  "map_of (map (\<lambda>k. (k, f k)) xs) x = (if (x \<in> set xs) then Some (f x) else None)"
  by (clarsimp simp: map_of_map_restrict)

lemma Mapping_lookup_map: "Mapping.lookup (Mapping.map f g m) a = map_option g (Mapping.lookup m (f a))"
  by transfer simp

lemma Mapping_lookup_map_default: "Mapping.lookup (Mapping.map_default k d f m) k' = (if k = k'
  then (Some \<circ> f) (case Mapping.lookup m k of None \<Rightarrow> d | Some x \<Rightarrow> x)
  else Mapping.lookup m k')"
  unfolding Mapping.map_default_def Mapping.default_def
  by transfer auto

lemma Mapping_lookup_mapping_add: "Mapping.lookup (mapping_add m1 m2) k =
  case_option (Mapping.lookup m1 k) Some (Mapping.lookup m2 k)"
  by transfer (simp add: map_add_def)

lemma Mapping_lookup_map_values: "Mapping.lookup (map_values f m) k =
  Option.bind (Mapping.lookup m k) (f k)"
  by transfer simp

lemma lookup_fold_update [simp]: "Mapping.lookup (fold (\<lambda>n. Mapping.update n (g n)) xs m) x
  = (if (x \<in> set xs) then Some (g x) else Mapping.lookup m x)"
  by transfer (rule fold_update_conv)

lemma mapping_eq_iff: "m1 = m2 \<longleftrightarrow> (\<forall>k. Mapping.lookup m1 k = Mapping.lookup m2 k)"
  by transfer auto

lemma lookup_delete: "Mapping.lookup (Mapping.delete k m) k' = (if k = k' then None else Mapping.lookup m k')"
  by transfer auto

lemma keys_map_values: "Mapping.keys (map_values f m) = Mapping.keys m - {k\<in>Mapping.keys m. f k (the (Mapping.lookup m k)) = None}"
  by transfer (auto simp add: bind_eq_Some_conv)

lemma map_default_eq: "Mapping.map_default k v f m = m \<longleftrightarrow> (\<exists>v. Mapping.lookup m k = Some v \<and> f v = v)"
  apply (clarsimp simp: Mapping.map_default_def Mapping.default_def)
  by transfer' (auto simp: fun_eq_iff split: if_splits)

lemma lookup_update_cases: "Mapping.lookup (Mapping.update k v m) k' = (if k=k' then Some v else Mapping.lookup m k')"
by (cases "k=k'", simp_all add: Mapping.lookup_update Mapping.lookup_update_neq)

end


(* TODO: Move to Refine-Monadic *)
theory Refine_Monadic_Add
imports Refine_Monadic_Thin
begin

  lemma option_rel_inv_conv:
    "(x,Some v')\<in>\<langle>V\<rangle>option_rel \<longleftrightarrow> (\<exists>v. x=Some v \<and> (v,v')\<in>V)"
    "(Some v,x')\<in>\<langle>V\<rangle>option_rel \<longleftrightarrow> (\<exists>v'. x'=Some v' \<and> (v,v')\<in>V)"
    subgoal by (cases x; auto)
    subgoal by (cases x'; auto)
    done

  definition "monadic_WHILEIT I b f s \<equiv> do {
    RECT (\<lambda>D s. do {
      ASSERT (I s);
      bv \<leftarrow> b s;
      if bv then do {
        s \<leftarrow> f s;
        D s
      } else do {RETURN s}
    }) s
  }"

  lemma WHILEIT_to_monadic: "WHILEIT I b f s = monadic_WHILEIT I (\<lambda>s. RETURN (b s)) f s"
    unfolding WHILEIT_def monadic_WHILEIT_def
    unfolding WHILEI_body_def bind_ASSERT_eq_if
    by (simp cong: if_cong)

lemma monadic_WHILEIT_refine[refine]:
  assumes [refine]: "(s',s) \<in> R"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s \<rbrakk> \<Longrightarrow> I' s'"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s' \<rbrakk> \<Longrightarrow> b' s' \<le>\<Down>bool_rel (b s)"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s'; nofail (b s); inres (b s) True \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (f s)"
  shows "monadic_WHILEIT I' b' f' s' \<le>\<Down>R (monadic_WHILEIT I b f s)"
  unfolding monadic_WHILEIT_def
  by (refine_rcg bind_refine'; assumption?; auto)

lemma monadic_WHILEIT_refine_WHILEIT[refine]:
  assumes [refine]: "(s',s) \<in> R"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s \<rbrakk> \<Longrightarrow> I' s'"
  assumes [THEN order_trans,refine_vcg]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s' \<rbrakk> \<Longrightarrow> b' s' \<le> SPEC (\<lambda>r. r = b s)"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s'; b s \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (f s)"
  shows "monadic_WHILEIT I' b' f' s' \<le>\<Down>R (WHILEIT I b f s)"
  unfolding WHILEIT_to_monadic
  by (refine_vcg; assumption?; auto)

lemma monadic_WHILEIT_refine_WHILET[refine]:
  assumes [refine]: "(s',s) \<in> R"
  assumes [THEN order_trans,refine_vcg]: "\<And>s' s. \<lbrakk> (s',s)\<in>R \<rbrakk> \<Longrightarrow> b' s' \<le> SPEC (\<lambda>r. r = b s)"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; b s \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (f s)"
  shows "monadic_WHILEIT (\<lambda>_. True) b' f' s' \<le>\<Down>R (WHILET b f s)"
  unfolding WHILET_def
  by (refine_vcg; assumption?)

end