section\<open>The Axiom of Replacement in $M[G]$\<close>
theory Replacement_Axiom
  imports
    Separation_Axiom
begin

context forcing_data1
begin

bundle sharp_simps1 = snd_abs[simp] fst_abs[simp] fst_closed[simp del, simplified, simp]
  snd_closed[simp del, simplified, simp] M_inhabited[simplified, simp]
  pair_in_M_iff[simp del, simplified, simp]

lemma sats_body_ground_repl_fm:
  includes sharp_simps1
  assumes
    "\<exists>t p. x=\<langle>t,p\<rangle>" "[x,\<alpha>,m,\<bbbP>,leq,\<one>] @ nenv \<in>list(M)"
    "\<phi>\<in>formula"
  shows
    "(\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(\<lambda>a. (##M)(a),\<alpha>,V) \<and> \<tau> \<in> V \<and> (snd(x) \<tturnstile> \<phi> ([fst(x),\<tau>]@nenv)))
    \<longleftrightarrow> M, [\<alpha>, x, m, \<bbbP>, leq, \<one>] @ nenv \<Turnstile> body_ground_repl_fm(\<phi>)"
  unfolding body_ground_repl_fm_def rename_split_fm_def
  by ((insert assms,rule iff_sats | simp add:nonempty[simplified])+,
      insert sats_incr_bv_iff[where bvs="[_,_,_,_,_,_]", simplified],auto del: iffI)

end \<comment> \<open>\<^locale>\<open>forcing_data1\<close>\<close>

context G_generic1
begin

lemma Replace_sats_in_MG:
  assumes
    "c\<in>M[G]" "env \<in> list(M[G])"
    "\<phi> \<in> formula" "arity(\<phi>) \<le> 2 +\<^sub>\<omega> length(env)"
    "univalent(##M[G], c, \<lambda>x v. (M[G] , [x,v]@env \<Turnstile> \<phi>) )"
    and
    ground_replacement:
    "\<And>nenv. ground_replacement_assm(M,[\<bbbP>,leq,\<one>] @ nenv, \<phi>)"
  shows
    "{v. x\<in>c, v\<in>M[G] \<and> (M[G] , [x,v]@env \<Turnstile> \<phi>)} \<in> M[G]"
proof -
  let ?R = "\<lambda> x v . v\<in>M[G] \<and> (M[G] , [x,v]@env \<Turnstile> \<phi>)"
  from \<open>c\<in>M[G]\<close>
  obtain \<pi>' where "val(G, \<pi>') = c" "\<pi>' \<in> M"
    using GenExt_def by auto
  then
  have "domain(\<pi>')\<times>\<bbbP>\<in>M" (is "?\<pi>\<in>M")
    using cartprod_closed domain_closed by simp
  from \<open>val(G, \<pi>') = c\<close>
  have "c \<subseteq> val(G,?\<pi>)"
    using def_val[of G ?\<pi>] elem_of_val[of _ G \<pi>'] one_in_G
       domain_of_prod[OF one_in_P, of "domain(\<pi>')"]
    by (force del:M_genericD)
  from \<open>env \<in> _\<close>
  obtain nenv where "nenv\<in>list(M)" "env = map(val(G),nenv)"
    using map_val by auto
  then
  have "length(nenv) = length(env)" by simp
  with \<open>arity(\<phi>) \<le> _\<close>
  have "arity(\<phi>) \<le> 2 +\<^sub>\<omega> length(nenv)" by simp
  define f where "f(\<rho>p) \<equiv> \<mu> \<alpha>. \<alpha>\<in>M \<and> (\<exists>\<tau>\<in>M. \<tau> \<in> Vset(\<alpha>) \<and>
        (snd(\<rho>p) \<tturnstile> \<phi> ([fst(\<rho>p),\<tau>] @ nenv)))" (is "_ \<equiv> \<mu> \<alpha>. ?P(\<rho>p,\<alpha>)") for \<rho>p
  have "f(\<rho>p) = (\<mu> \<alpha>. \<alpha>\<in>M \<and> (\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(##M,\<alpha>,V) \<and> \<tau>\<in>V \<and>
        (snd(\<rho>p) \<tturnstile> \<phi> ([fst(\<rho>p),\<tau>] @ nenv))))" (is "_ = (\<mu> \<alpha>. \<alpha>\<in>M \<and> ?Q(\<rho>p,\<alpha>))") for \<rho>p
    unfolding f_def using Vset_abs Vset_closed Ord_Least_cong[of "?P(\<rho>p)" "\<lambda> \<alpha>. \<alpha>\<in>M \<and> ?Q(\<rho>p,\<alpha>)"]
    by (simp, simp del:setclass_iff)
  moreover
  note inM = \<open>nenv\<in>list(M)\<close> \<open>?\<pi>\<in>M\<close>
  moreover
  have "f(\<rho>p) \<in> M" "Ord(f(\<rho>p))" for \<rho>p
    unfolding f_def using Least_closed'[of "?P(\<rho>p)"] by simp_all
  ultimately
  have 1:"least(##M,\<lambda>\<alpha>. ?Q(\<rho>p,\<alpha>),f(\<rho>p))" for \<rho>p
    using least_abs'[of "\<lambda>\<alpha>. \<alpha>\<in>M \<and> ?Q(\<rho>p,\<alpha>)" "f(\<rho>p)"] least_conj
    by (simp flip: setclass_iff)
  define QQ where "QQ\<equiv>?Q"
  from 1
  have "least(##M,\<lambda>\<alpha>. QQ(\<rho>p,\<alpha>),f(\<rho>p))" for \<rho>p
    unfolding QQ_def .
  have body:"(M, [\<rho>p,m,\<bbbP>,leq,\<one>] @ nenv \<Turnstile> ground_repl_fm(\<phi>)) \<longleftrightarrow> least(##M, QQ(\<rho>p), m)"
    if "\<rho>p\<in>M" "\<rho>p\<in>?\<pi>" "m\<in>M" for \<rho>p m
  proof -
    note inM that
    moreover from this assms 1
    have "(M , [\<alpha>,\<rho>p,m,\<bbbP>,leq,\<one>] @ nenv \<Turnstile> body_ground_repl_fm(\<phi>)) \<longleftrightarrow> ?Q(\<rho>p,\<alpha>)" if "\<alpha>\<in>M" for \<alpha>
      using that sats_body_ground_repl_fm[of \<rho>p \<alpha> m nenv \<phi>]
      by auto
    moreover from calculation
    have body:"\<And>\<alpha>. \<alpha> \<in> M \<Longrightarrow> (\<exists>\<tau>\<in>M. \<exists>V\<in>M. is_Vset(\<lambda>a. a\<in>M, \<alpha>, V) \<and> \<tau> \<in> V \<and>
          (snd(\<rho>p) \<tturnstile> \<phi> ([fst(\<rho>p),\<tau>] @ nenv))) \<longleftrightarrow>
          M, Cons(\<alpha>, [\<rho>p, m, \<bbbP>, leq, \<one>] @ nenv) \<Turnstile> body_ground_repl_fm(\<phi>)"
      by simp
    ultimately
    show "(M , [\<rho>p,m,\<bbbP>,leq,\<one>] @ nenv \<Turnstile> ground_repl_fm(\<phi>)) \<longleftrightarrow> least(##M, QQ(\<rho>p), m)"
      using sats_least_fm[OF body,of 1] unfolding QQ_def ground_repl_fm_def
      by (simp, simp flip: setclass_iff)
  qed
  then
  have "univalent(##M, ?\<pi>, \<lambda>\<rho>p m. M , [\<rho>p,m] @ ([\<bbbP>,leq,\<one>] @ nenv) \<Turnstile> ground_repl_fm(\<phi>))"
    unfolding univalent_def by (auto intro:unique_least)
  moreover from \<open>length(_) = _\<close> \<open>env \<in> _\<close>
  have "length([\<bbbP>,leq,\<one>] @ nenv) = 3 +\<^sub>\<omega> length(env)" by simp
  moreover from \<open>arity(\<phi>) \<le> 2 +\<^sub>\<omega> length(nenv)\<close>
    \<open>length(_) = length(_)\<close>[symmetric] \<open>nenv\<in>_\<close> \<open>\<phi>\<in>_\<close>
  have "arity(ground_repl_fm(\<phi>)) \<le> 5 +\<^sub>\<omega> length(env)"
    using arity_ground_repl_fm[of \<phi>] le_trans Un_le by auto
  moreover from \<open>\<phi>\<in>formula\<close>
  have "ground_repl_fm(\<phi>)\<in>formula" by simp
  moreover
  note \<open>length(nenv) = length(env)\<close> inM
  ultimately
  obtain Y where "Y\<in>M"
    "\<forall>m\<in>M. m \<in> Y \<longleftrightarrow> (\<exists>\<rho>p\<in>M. \<rho>p \<in> ?\<pi> \<and> (M, [\<rho>p,m] @ ([\<bbbP>,leq,\<one>] @ nenv) \<Turnstile> ground_repl_fm(\<phi>)))"
    using ground_replacement[of nenv]
    unfolding strong_replacement_def ground_replacement_assm_def replacement_assm_def by auto
  with \<open>least(_,QQ(_),f(_))\<close> \<open>f(_) \<in> M\<close> \<open>?\<pi>\<in>M\<close> body
  have "f(\<rho>p)\<in>Y" if "\<rho>p\<in>?\<pi>" for \<rho>p
    using that transitivity[OF _ \<open>?\<pi>\<in>M\<close>]
    by (clarsimp,rename_tac \<rho> p \<rho>p, rule_tac x="\<langle>\<rho>,p\<rangle>" in bexI, auto)
  from \<open>Y\<in>M\<close>
  have "\<Union> {y\<in>Y. Ord(y)} \<in> M" (is "?sup \<in> M")
    using separation_Ord separation_closed Union_closed by simp
  then
  have "{x\<in>Vset(?sup). x \<in> M} \<times> {\<one>} \<in> M" (is "?big_name \<in> M")
    using Vset_closed cartprod_closed singleton_closed by simp
  then
  have "val(G,?big_name) \<in> M[G]"
    by (blast intro:GenExtI)
  have "{v. x\<in>c, ?R(x,v)} \<subseteq> val(G,?big_name)" (is "?repl\<subseteq>?big")
  proof(intro subsetI)
    fix v
    assume "v\<in>?repl"
    moreover from this
    obtain x where "x\<in>c" "M[G], [x, v] @ env \<Turnstile> \<phi>" "v\<in>M[G]"
      by auto
    moreover
    note \<open>val(G,\<pi>')=c\<close> \<open>\<pi>'\<in>M\<close>
    moreover
    from calculation
    obtain \<rho> p where "\<langle>\<rho>,p\<rangle>\<in>\<pi>'" "val(G,\<rho>) = x" "p\<in>G" "\<rho>\<in>M"
      using elem_of_val_pair' by blast
    moreover from this \<open>v\<in>M[G]\<close>
    obtain \<sigma> where "val(G,\<sigma>) = v" "\<sigma>\<in>M"
      using GenExtD by (force del:M_genericD)
    moreover
    note \<open>\<phi>\<in>_\<close> \<open>nenv\<in>_\<close> \<open>env = _\<close> \<open>arity(\<phi>)\<le> 2 +\<^sub>\<omega> length(env)\<close>
    ultimately
    obtain q where "q\<in>G" "q \<tturnstile> \<phi> ([\<rho>,\<sigma>]@nenv)" "q\<in>\<bbbP>"
      using truth_lemma[OF \<open>\<phi>\<in>_\<close>,of "[\<rho>,\<sigma>] @ nenv"]
      by auto
    with \<open>\<langle>\<rho>,p\<rangle>\<in>\<pi>'\<close> \<open>\<langle>\<rho>,q\<rangle>\<in>?\<pi> \<Longrightarrow> f(\<langle>\<rho>,q\<rangle>)\<in>Y\<close>
    have "f(\<langle>\<rho>,q\<rangle>)\<in>Y"
      using generic by blast
    let ?\<alpha>="succ(rank(\<sigma>))"
    note \<open>\<sigma>\<in>M\<close>
    moreover from this
    have "?\<alpha> \<in> M" "\<sigma> \<in> Vset(?\<alpha>)"
      using rank_closed cons_closed Vset_Ord_rank_iff
      by (simp_all flip: setclass_iff)
    moreover
    note \<open>q \<tturnstile> \<phi> ([\<rho>,\<sigma>] @ nenv)\<close>
    ultimately
    have "?P(\<langle>\<rho>,q\<rangle>,?\<alpha>)" by (auto simp del: Vset_rank_iff)
    moreover
    have "(\<mu> \<alpha>. ?P(\<langle>\<rho>,q\<rangle>,\<alpha>)) = f(\<langle>\<rho>,q\<rangle>)"
      unfolding f_def by simp
    ultimately
    obtain \<tau> where "\<tau>\<in>M" "\<tau> \<in> Vset(f(\<langle>\<rho>,q\<rangle>))" "q \<tturnstile> \<phi> ([\<rho>,\<tau>] @ nenv)"
      using LeastI[of "\<lambda> \<alpha>. ?P(\<langle>\<rho>,q\<rangle>,\<alpha>)" ?\<alpha>] by auto
    with \<open>q\<in>G\<close> \<open>\<rho>\<in>M\<close> \<open>nenv\<in>_\<close> \<open>arity(\<phi>)\<le> 2 +\<^sub>\<omega> length(nenv)\<close>
    have "M[G], map(val(G),[\<rho>,\<tau>] @ nenv) \<Turnstile> \<phi>"
      using truth_lemma[OF \<open>\<phi>\<in>_\<close>, of "[\<rho>,\<tau>] @ nenv"] by auto
    moreover from \<open>x\<in>c\<close> \<open>c\<in>M[G]\<close>
    have "x\<in>M[G]" using transitivity_MG by simp
    moreover
    note \<open>M[G],[x,v] @ env\<Turnstile> \<phi>\<close> \<open>env = map(val(G),nenv)\<close> \<open>\<tau>\<in>M\<close> \<open>val(G,\<rho>)=x\<close>
      \<open>univalent(##M[G],_,_)\<close> \<open>x\<in>c\<close> \<open>v\<in>M[G]\<close>
    ultimately
    have "v=val(G,\<tau>)"
      using GenExtI[of \<tau> G] unfolding univalent_def by (auto)
    from \<open>\<tau> \<in> Vset(f(\<langle>\<rho>,q\<rangle>))\<close> \<open>Ord(f(_))\<close>  \<open>f(\<langle>\<rho>,q\<rangle>)\<in>Y\<close>
    have "\<tau> \<in> Vset(?sup)"
      using Vset_Ord_rank_iff lt_Union_iff[of _ "rank(\<tau>)"] by auto
    with \<open>\<tau>\<in>M\<close>
    have "val(G,\<tau>) \<in> val(G,?big_name)"
      using domain_of_prod[of \<one> "{\<one>}" "{x\<in>Vset(?sup). x \<in> M}" ] def_val[of G ?big_name]
        one_in_G one_in_P  by (auto simp del: Vset_rank_iff)
    with \<open>v=val(G,\<tau>)\<close>
    show "v \<in> val(G,?big_name)"
      by simp
  qed
  from \<open>?big_name\<in>M\<close>
  have "?repl = {v\<in>?big. \<exists>x\<in>c. M[G], [x,v] @ env \<Turnstile>  \<phi>}" (is "_ = ?rhs")
  proof(intro equalityI subsetI)
    fix v
    assume "v\<in>?repl"
    with \<open>?repl\<subseteq>?big\<close>
    obtain x where "x\<in>c" "M[G], [x, v] @ env \<Turnstile> \<phi>" "v\<in>?big"
      using subsetD by auto
    with \<open>univalent(##M[G],_,_)\<close> \<open>c\<in>M[G]\<close>
    show "v \<in> ?rhs"
      unfolding univalent_def
      using transitivity_MG ReplaceI[of "\<lambda> x v. \<exists>x\<in>c. M[G], [x, v] @ env \<Turnstile> \<phi>"] by blast
  next
    fix v
    assume "v\<in>?rhs"
    then
    obtain x where
      "v\<in>val(G, ?big_name)" "M[G], [x, v] @ env \<Turnstile> \<phi>" "x\<in>c"
      by blast
    moreover from this \<open>c\<in>M[G]\<close>
    have "v\<in>M[G]" "x\<in>M[G]"
      using transitivity_MG GenExtI[OF \<open>?big_name\<in>_\<close>,of G] by auto
    moreover from calculation \<open>univalent(##M[G],_,_)\<close>
    have "?R(x,y) \<Longrightarrow> y = v" for y
      unfolding univalent_def by auto
    ultimately
    show "v\<in>?repl"
      using ReplaceI[of ?R x v c]
      by blast
  qed
  moreover
  let ?\<psi> = "(\<cdot>\<exists>\<cdot>\<cdot>0 \<in> 2 +\<^sub>\<omega> length(env) \<cdot> \<and> \<phi>\<cdot>\<cdot>)"
  from \<open>\<phi>\<in>_\<close>
  have "?\<psi>\<in>formula" "arity(?\<psi>) \<le> 2 +\<^sub>\<omega> length(env)"
    using pred_mono[OF _ \<open>arity(\<phi>)\<le>2+\<^sub>\<omega>length(env)\<close>] lt_trans[OF _ le_refl]
    by (auto simp add:ord_simp_union arity)
  moreover
  from \<open>\<phi>\<in>_\<close> \<open>arity(\<phi>)\<le>2+\<^sub>\<omega>length(env)\<close> \<open>c\<in>M[G]\<close> \<open>env\<in>_\<close>
  have "(\<exists>x\<in>c. M[G], [x,v] @ env \<Turnstile> \<phi>) \<longleftrightarrow> M[G], [v] @ env @ [c] \<Turnstile> ?\<psi>" if "v\<in>M[G]" for v
    using that nth_concat transitivity_MG[OF _ \<open>c\<in>M[G]\<close>] arity_sats_iff[of \<phi> "[c]" _ "[_,v]@env"]
    by auto
  moreover from this
  have "{v\<in>?big. \<exists>x\<in>c. M[G], [x,v] @ env \<Turnstile> \<phi>} = {v\<in>?big. M[G], [v] @ env @ [c] \<Turnstile>  ?\<psi>}"
    using transitivity_MG[OF _ GenExtI, OF _ \<open>?big_name\<in>M\<close>]
    by simp
  moreover from calculation and \<open>env\<in>_\<close> \<open>c\<in>_\<close> \<open>?big\<in>M[G]\<close>
  have "{v\<in>?big. M[G] , [v] @ env @ [c] \<Turnstile> ?\<psi>} \<in> M[G]"
    using Collect_sats_in_MG by auto
  ultimately
  show ?thesis by simp
qed

theorem strong_replacement_in_MG:
  assumes
    "\<phi>\<in>formula" and "arity(\<phi>) \<le> 2 +\<^sub>\<omega> length(env)" "env \<in> list(M[G])"
    and
    ground_replacement:
    "\<And>nenv. ground_replacement_assm(M,[\<bbbP>,leq,\<one>] @ nenv, \<phi>)"
  shows
    "strong_replacement(##M[G],\<lambda>x v. M[G],[x,v] @ env \<Turnstile> \<phi>)"
proof -
  let ?R="\<lambda>x y . M[G], [x, y] @ env \<Turnstile> \<phi>"
  {
    fix A
    let ?Y="{v . x \<in> A, v\<in>M[G] \<and> ?R(x,v)}"
    assume 1: "(##M[G])(A)" "univalent(##M[G], A, ?R)"
    with assms
    have "(##M[G])(?Y)"
      using Replace_sats_in_MG ground_replacement 1
      unfolding ground_replacement_assm_def by auto
    have "b \<in> ?Y \<longleftrightarrow> (\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b))" if "(##M[G])(b)" for b
    proof(rule)
      from \<open>(##M[G])(A)\<close>
      show "\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b)" if "b \<in> ?Y"
        using that transitivity_MG by auto
    next
      show "b \<in> ?Y" if "\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b)"
      proof -
        from \<open>(##M[G])(b)\<close>
        have "b\<in>M[G]" by simp
        with that
        obtain x where "(##M[G])(x)" "x\<in>A" "b\<in>M[G] \<and> ?R(x,b)"
          by blast
        moreover from this 1 \<open>(##M[G])(b)\<close>
        have "x\<in>M[G]" "z\<in>M[G] \<and> ?R(x,z) \<Longrightarrow> b = z" for z
          unfolding univalent_def
          by auto
        ultimately
        show ?thesis
          using ReplaceI[of "\<lambda> x y. y\<in>M[G] \<and> ?R(x,y)"] by blast
      qed
    qed
    then
    have "\<forall>b[##M[G]]. b \<in> ?Y \<longleftrightarrow> (\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b))"
      by simp
    with \<open>(##M[G])(?Y)\<close>
    have " (\<exists>Y[##M[G]]. \<forall>b[##M[G]]. b \<in> Y \<longleftrightarrow> (\<exists>x[##M[G]]. x \<in> A \<and> ?R(x,b)))"
      by auto
  }
  then show ?thesis unfolding strong_replacement_def
    by simp
qed

lemma replacement_assm_MG:
  assumes
    ground_replacement:
    "\<And>nenv. ground_replacement_assm(M,[\<bbbP>,leq,\<one>] @ nenv, \<phi>)"
  shows
    "replacement_assm(M[G],env,\<phi>)"
  using assms strong_replacement_in_MG
  unfolding replacement_assm_def by simp

end \<comment> \<open>\<^locale>\<open>G_generic1\<close>\<close>

end


subsection \<open>State Monad\<close>

theory State_Monad_Ext
  imports "HOL-Library.State_Monad"
begin

definition fun_app_lifted :: "('M,'a \<Rightarrow> ('M, 'b) state) state \<Rightarrow> ('M,'a) state \<Rightarrow> ('M,'b) state" where
  "fun_app_lifted f\<^sub>T x\<^sub>T \<equiv> do { f \<leftarrow> f\<^sub>T; x \<leftarrow> x\<^sub>T; f x }"

bundle state_monad_syntax begin

notation fun_app_lifted (infixl "." 999)
type_synonym ('a,'M,'b) fun_lifted = "'a \<Rightarrow> ('M,'b) state" ("_ ==_\<Longrightarrow> _" [3,1000,2] 2)
type_synonym ('a,'b) dpfun = "'a ==('a\<rightharpoonup>'b)\<Longrightarrow> 'b" (infixr "\<Rightarrow>\<^sub>T" 2)
type_notation state ("[_| _]")

notation State_Monad.return ("\<langle>_\<rangle>")
notation (ASCII) State_Monad.return ("(#_#)")
notation Transfer.Rel ("Rel")

end

context includes state_monad_syntax begin

qualified lemma return_app_return:
  "\<langle>f\<rangle> . \<langle>x\<rangle> = f x"
  unfolding fun_app_lifted_def bind_left_identity ..

qualified lemma return_app_return_meta:
  "\<langle>f\<rangle> . \<langle>x\<rangle> \<equiv> f x"
  unfolding return_app_return .

qualified definition if\<^sub>T :: "('M, bool) state \<Rightarrow> ('M, 'a) state \<Rightarrow> ('M, 'a) state \<Rightarrow> ('M, 'a) state" where
  "if\<^sub>T b\<^sub>T x\<^sub>T y\<^sub>T \<equiv> do {b \<leftarrow> b\<^sub>T; if b then x\<^sub>T else y\<^sub>T}"
end

end


theory Linearization
imports "../LinearAssembly/LinearAssemblyLanguage" "../Utilities/Iterate"
begin

fun state_convert :: "assembly_state \<Rightarrow> l_assembly_state" where
  "state_convert (\<mu>, a, d, \<pi>, s, \<omega>) = (\<mu>, a, d, \<pi> @ [JAssm {EQ, GT, LT} s], \<omega>)"

fun linearize_step :: "code_label\<^sub>2 \<times> assembly list \<times> code_label\<^sub>2 \<Rightarrow> l_assembly_program \<Rightarrow>
    l_assembly_program" where
  "linearize_step (s, \<pi>, s') \<Pi> = (s, \<pi> @ [JAssm {EQ, GT, LT} s']) # \<Pi>"

definition linearize :: "assembly_program \<Rightarrow> l_assembly_program" where
  "linearize \<Pi> = finite_map_fold linearize_step [] \<Pi>"

(* linearization correct *)

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> \<Pi> x = None \<Longrightarrow>
    lookup (finite_map_fold linearize_step [] \<Pi>) x = None"
  proof (induction linearize_step "[]::code_label\<^sub>2 \<leadsto> assembly list" \<Pi> rule: finite_map_fold.induct)
  case 1
    thus ?case by metis
  next case 2
    thus ?case by simp
  next case (3 \<Pi>)
    let ?x = "SOME x. x \<in> dom \<Pi>"
    let ?ih = "finite_map_fold linearize_step [] (\<Pi>(?x := None))"
    from 3 have "?x \<in> dom \<Pi>" by (smt Collect_empty_eq card_0_eq dom_def mem_Collect_eq someI_ex)
    with 3 have "x \<noteq> ?x" by blast
    with 3 show ?case by (cases "the (\<Pi> ?x)") (simp add: Let_def)
  qed

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> \<Pi> x = Some (\<pi>, s) \<Longrightarrow>
    lookup (finite_map_fold linearize_step [] \<Pi>) x = Some (\<pi> @ [JAssm {EQ, GT, LT} s])"
  proof (induction linearize_step "[]::code_label\<^sub>2 \<leadsto> assembly list" \<Pi> rule: finite_map_fold.induct)
  case 1
    thus ?case by metis
  next case 2
    thus ?case by (metis card_0_eq dom_eq_empty_conv option.distinct(1))
  next case (3 \<Pi>)
    let ?x = "SOME x. x \<in> dom \<Pi>"
    let ?ih = "finite_map_fold linearize_step [] (\<Pi>(?x := None))"
    show ?case
      proof (cases "x = ?x")
      case True
        with 3 have "\<Pi> ?x = Some (\<pi>, s)" by blast
        with True have "lookup (linearize_step (?x, the (\<Pi> ?x)) ?ih) x =
          Some (\<pi> @ [JAssm {EQ, GT, LT} s])" by (cases "the (\<Pi> ?x)") simp
        with 3 show ?thesis by (simp add: Let_def)
      next case False
        with 3 show ?thesis by (cases "the (\<Pi> ?x)") (simp add: Let_def)
      qed
  qed

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> \<Pi> x = Some (\<pi>, s) \<Longrightarrow>
    lookup (linearize \<Pi>) x = Some (\<pi> @ [JAssm {EQ, GT, LT} s])"
  by (simp add: linearize_def)

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> domain_distinct (finite_map_fold linearize_step [] \<Pi>)"
  proof (induction linearize_step "[]::code_label\<^sub>2 \<leadsto> assembly list" \<Pi> rule: finite_map_fold.induct)
  case 1
    thus ?case by metis
  next case 2
    thus ?case by simp
  next case (3 \<Pi>)
    let ?x = "SOME x. x \<in> dom \<Pi>"
    let ?ih = "finite_map_fold linearize_step [] (\<Pi>(?x := None))"
    show ?case
      proof (cases "the (\<Pi> ?x)")
      case (Pair \<pi> s)
        from 3 have "lookup ?ih ?x = None" by simp
        hence "?x \<notin> dom (lookup ?ih)" by auto
        with 3 Pair show ?thesis by (simp add: Let_def)
      qed
  qed

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> domain_distinct (linearize \<Pi>)"
  by (simp add: linearize_def)

lemma [simp]: "finite (dom \<Pi>) \<Longrightarrow> eval_assembly \<Pi> \<Sigma> = Some \<Sigma>' \<Longrightarrow>
    eval_l_assembly (linearize \<Pi>) (state_convert \<Sigma>) = Some (state_convert \<Sigma>')"
  proof (induction \<Pi> \<Sigma> rule: eval_assembly.induct)
  case (1 \<Pi> \<mu> a d s \<omega>)
    thus ?case by (cases "\<Pi> s") (auto split: prod.splits)
  next case 2
    thus ?case by auto
  next case 3
    thus ?case by (auto simp add: Let_def)
  next case 4
    thus ?case by simp
  next case (5 \<Pi> \<mu> a d jmp s \<pi> s' \<omega>)
    thus ?case by (cases "\<Pi> s") auto
  next case 6
    thus ?case by auto
  qed

theorem linearization_correct [simp]: "iterate (eval_assembly \<Pi>) \<Sigma> \<Sigma>' \<Longrightarrow> finite (dom \<Pi>) \<Longrightarrow>
    iterate (eval_l_assembly (linearize \<Pi>)) (state_convert \<Sigma>) (state_convert \<Sigma>')"
  by (induction "eval_assembly \<Pi>" \<Sigma> \<Sigma>' rule: iterate.induct) simp_all

end


           (*-------------------------------------------*
            |                                           |
            |          Test on LW-CSP-Prover            |
            |                                           |
            *-------------------------------------------*)

theory Test
imports CSP_semantics
begin

(*************************************************************

         1. Test
         2.
         3.
         4.

 *************************************************************)

(* test of transition *)

datatype K_Events = lock | unlock | finish
datatype K_PName = Key

primrec
  Def :: "K_PName => (K_PName, K_Events) proc"
  where
  "Def Key = (lock -> unlock -> $Key) [+] (finish -> STOP)"

overloading K_PNfun ==
  "PNfun :: K_PName => (K_PName, K_Events) proc"
  begin definition "PNfun = Def" end
  declare K_PNfun_def [simp]

lemma trn_exists:
  "$Key ---(Ev lock)---> (unlock -> $Key)"
  apply (rule PName, simp)
  apply (rule ExtCh1)
  apply (rule Prefix)
  done

lemma if_trn_exists:
  "$Key ---e---> P'
   \<Longrightarrow>   (e = (Ev lock) \<and> P' = unlock -> $Key)
       \<or> (e = (Ev finish) \<and> P' = STOP)"
  apply (erule trn.cases, auto)+
  done

(* test of transition *)

datatype FW_Events = in1 | in2 | out1 | out2
datatype FW_PName = FW

primrec
  FW_Def :: "FW_PName => (FW_PName, FW_Events) proc"
  where
  "FW_Def FW = (in1 -> out1 -> $FW) [+] (in2 -> out2 -> $FW)"

overloading FW_PNfun ==
  "PNfun :: FW_PName => (FW_PName, FW_Events) proc"
  begin definition "PNfun = FW_Def" end
  declare FW_PNfun_def [simp]

lemma fw_trn_exists:
  "$FW ---(Ev in1)---> (out1 -> $FW)"
  apply (rule PName, simp)
  apply (rule ExtCh1)
  apply (rule Prefix)
  done

lemma fw_if_trn_exists:
  "$FW ---e---> P'
   ==>   (e = Ev in1 & P' = out1 -> $FW)
       | (e = Ev in2 & P' = out2 -> $FW)"
  apply (erule trn.cases, auto)+
  done

lemma trn_exists_STOP:
  "(in1 -> out1 -> STOP) [+] (in2 -> out2 -> STOP)
   ---(Ev in1)---> (out1 -> STOP)"
  apply (rule ExtCh1)
  apply (rule Prefix)
  done

lemma if_trn_exists_STOP:
  "(in1 -> out1 -> STOP) [+] (in2 -> out2 -> STOP)
   ---e---> P'
   ==>   (e = Ev in1 & P' = out1 -> STOP)
       | (e = Ev in2 & P' = out2 -> STOP)"
  apply (erule trn.cases, auto)+
  done

datatype Events2 = put | pass | get

lemma ex1_transition:
  "((get -> pass -> STOP) |[{pass}]| (pass -> put -> STOP)) ~~ {pass}
   ---(Ev get)--->
   ((pass -> STOP) |[{pass}]| (pass -> put -> STOP)) ~~ {pass}"
  apply (rule Hide1, auto)
  apply (rule Para1, auto)
  apply (rule Prefix)
  done

lemma ex2_transition:
  "((pass -> STOP) |[{pass}]| (pass -> put -> STOP)) ~~ {pass}
   ---Tau--->
   (STOP |[{pass}]| (put -> STOP)) ~~ {pass}"
  apply (intro Hide2 Para3 Prefix, auto?)+
  done

lemma ex3_transition:
  "(STOP |[{pass}]| (put -> STOP)) ~~ {pass}
   ---(Ev put)--->
   (STOP |[{pass}]| STOP) ~~ {pass}"
  apply (intro Hide1 Para2 Prefix, auto?)+
  done

lemma ex4_transition:
  "((get -> pass -> STOP) |[{pass}]| (pass -> put -> STOP)) ~~ {pass}
   ---e---> P'
   ==> e = Ev get &
       P' = ((pass -> STOP) |[{pass}]| (pass -> put -> STOP)) ~~ {pass}"
  apply (erule trn.cases, auto?)+
  done

lemma ex1_transition_manual_proof:
  "((a -> STOP) [+] P) ||| Q ---(Ev a)---> STOP ||| Q"
  apply (rule Para1)
  apply (rule conjI)
  apply (rule ExtCh1)
  apply (rule Prefix)
  apply (simp)
  done

lemma ex2_transition_auto_proof:
  "((a -> STOP) [+] P) ||| Q ---(Ev a)---> STOP ||| Q"
  apply (auto intro: trn.intros)
  done

lemma ex3_decomposition_of_transition:
  "((a -> STOP) [+] (b -> STOP)) ||| Q ---(Ev c)---> STOP ||| Q
   ==> a = c | b = c"
  apply (erule trn.cases)   (* all cases are checked for ||| *)
  apply (auto)
  apply (erule trn.cases)   (* all cases are checked for [+] *)
  apply (auto)
  apply (erule trn.cases)   (* all cases are checked for a -> *)
  apply (auto)
  apply (erule trn.cases)   (* all cases are checked for b -> *)
  apply (auto)
  done

(* ----- loop test (process name) ------ *)

datatype Event = act1 | act2
datatype Name = Ptest

primrec
  Def2 :: "Name => (Name, Event) proc"
  where
  "Def2 Ptest = act1 -> $Ptest [+] act2 -> STOP"

overloading Test_PNfun ==
  "PNfun :: Name => (Name, Event) proc"
  begin
    definition "PNfun == Def2"
  end

declare Test_PNfun_def [simp]

lemma ex4_loop_transition_manual_proof:
  "$Ptest ---(Ev act1)---> $Ptest"
  apply (rule PName)
  apply (simp)
  apply (rule ExtCh1)
  apply (rule Prefix)
  done

lemma ex4_loop_transition_auto_proof:
  "$Ptest ---(Ev act1)---> $Ptest"
  apply (intro trn.intros)
  apply (simp)
  apply (intro trn.intros)
  done

(* test of sequential transition *)

lemma ex5_seq_transition_manual_proof:
  "a ~= b ==> c ~= b
   ==> (a -> b -> c -> STOP) ~~ {b} ---[Ev a, Tau, Ev c]--->> STOP ~~ {b}"
  apply (rule Step)
  apply (rule_tac x="(b -> c -> STOP) ~~ {b}" in exI)
  apply (rule_tac x="Ev a" in exI)
  apply (rule_tac x="[Tau,Ev c]" in exI)
  apply (rule conjI)
   apply (rule Hide1)
   apply (rule conjI)
    apply (rule Prefix)
   apply (simp)
  apply (rule conjI)
   apply (rule Step)
   apply (rule_tac x="(c -> STOP) ~~ {b}" in exI)
   apply (rule_tac x="Tau" in exI)
   apply (rule_tac x="[Ev c]" in exI)
   apply (rule conjI)
    apply (rule Hide2)
    apply (rule conjI)
     apply (rule Prefix)
    apply (simp)
   apply (rule conjI)
    apply (rule Base)
    apply (rule Hide1)
    apply (rule conjI)
     apply (rule Prefix)
    apply (simp)
   apply (simp)
  apply (simp)
  done

(* test of traces *)

lemma ex6_traces_manual_proof:
  "[| a ~= b; c ~= b |]
   ==> [a,c] : traces((a -> b -> c -> STOP) ~~ {b})"
  apply (simp add: traces_def)
  apply (rule_tac x="[Ev a, Tau, Ev c]" in exI)
  apply (rule conjI)
   apply (simp)
  apply (rule_tac x="STOP ~~ {b}" in exI)
  apply (simp add: ex5_seq_transition_manual_proof)
  done

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory IndirectCalls

imports
  "PrettyProgs"

begin

definition
  lookup_proc :: "(string \<Rightarrow> 'proc_addr) \<Rightarrow> ('proc_id \<rightharpoonup> string)
    \<Rightarrow> 'proc_addr \<Rightarrow> 'proc_id"
where
  "lookup_proc symtab naming x
    = (THE pid. naming pid \<noteq> None \<and> symtab (the (naming pid)) = x)"

definition
  lookup_proc_safe :: "(string \<Rightarrow> 'proc_addr) \<Rightarrow> ('proc_id \<rightharpoonup> string)
    \<Rightarrow> 'proc_addr \<Rightarrow> bool"
where
  "lookup_proc_safe symtab naming x
    = (card {pid. naming pid \<noteq> None \<and> symtab (the (naming pid)) = x} = 1)"

definition
  procs_consistent :: "(string \<Rightarrow> 'proc_addr) \<Rightarrow> ('proc_nm \<rightharpoonup> string)
    \<Rightarrow> bool"
where
  "procs_consistent symtab naming
    = (finite (dom naming)
        \<and> (\<forall>x y nm nm'. naming x = Some nm \<and> naming y = Some nm'
            \<and> symtab nm = symtab nm'
                \<longrightarrow> x = y))"

lemma procs_consistent_eq:
  "\<lbrakk> naming proc = Some nm; procs_consistent symtab naming; addr = symtab nm \<rbrakk>
    \<Longrightarrow> lookup_proc symtab naming addr = proc"
  apply (clarsimp simp: procs_consistent_def lookup_proc_def)
  apply (rule the_equality)
   apply clarsimp
  apply clarsimp
  done

lemma procs_consistent_safe:
  "\<lbrakk> naming proc = Some nm; procs_consistent symtab naming; addr = symtab nm \<rbrakk>
    \<Longrightarrow> lookup_proc_safe symtab naming addr"
  apply (clarsimp simp: procs_consistent_def lookup_proc_safe_def)
  apply (rule trans, rule arg_cong[where f=card and y="{proc}"])
   apply auto
  done

lemma hoare_indirect_call_procs_consistent:
  "\<lbrakk> naming proc = Some nm;
        \<Gamma> \<turnstile> P (call initf proc ret c) Q, A \<rbrakk>
    \<Longrightarrow> \<Gamma> \<turnstile> ({s. procs_consistent symtab naming \<and> x_fn s = symtab nm} \<inter> P)
            (dynCall initf (\<lambda>s. lookup_proc symtab naming (x_fn s))
                    ret c) Q, A"
  apply (rule hoare_complete, drule hoare_sound)
  apply (clarsimp simp: cvalid_def HoarePartialDef.valid_def)
  apply (erule exec_dynCall_Normal_elim)
  apply (simp add: procs_consistent_eq)
  apply blast
  done

end


theory ReduceRestr
  imports GenSubEnv WTLemma ResMapDisj ReduceWTS
begin

    (* setup for an important lemma, which states that s + env restricted to part of an rs_map should remain well-typed. *)

definition restr_env where
  "restr_env s rs_map = (\<lambda> x. if lookup_mem rs_map x = None then None else s x)"

definition np_restr_env where
  "np_restr_env env rs_map = (\<lambda> x. if lookup_mem rs_map x = None \<and> non_prim_entry env x then None else env x)"

lemma restr_sub_env: "\<lbrakk> sub_env s env; non_prim_env env \<rbrakk> \<Longrightarrow> sub_env (restr_env s rs_map) (np_restr_env env rs_map)"
  apply (simp add: sub_env_def)
  apply (auto)
  apply (simp add: restr_env_def)
  apply (simp add: np_restr_env_def)
  apply (auto)
  apply (case_tac "lookup_mem rs_map x")
   apply (auto)
  apply (simp add: non_prim_env_def)
  apply (simp add: non_prim_entry_def)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "env x")
   apply (auto)
  done

lemma restr_disj_res_map: "\<lbrakk> valid_res_map s rs_map; lookup_mem rs_map x = Some (r_s, rs_map');
  lookup_res rs_map' x = empty_use_env \<rbrakk> \<Longrightarrow> disj_res_map rs_map'"
  apply (induct rs_map arbitrary: s)
   apply (auto)
  apply (case_tac "x1 = x")
   apply (auto)
   apply (rule_tac x="x" and r_s="r_s" in disj_add_res_map_rev)
    apply (simp add: add_mem_def)
    apply (simp add: valid_res_map_def)
   apply (simp)
  apply (simp add: valid_res_map_def)
    (* - disjointness for induction *)
  apply (cut_tac rs_map="rs_map" and x="x1" and r_s="x2" in disj_add_res_map_rev)
    apply (simp add: add_mem_def)
   apply (simp add: scope_res_map_def)
   apply (simp add: fresh_map_var_def)
   apply (simp add: lookup_res_def)
    (* - containment for induction *)
  apply (cut_tac rs_map="rs_map" and x="x1" and r_s="x2" and s="s" in add_sub_res_map_rev)
    apply (simp add: add_mem_def)
   apply (simp add: scope_res_map_def)
   apply (simp add: fresh_map_var_def)
    (* - scope containment for induction *)
  apply (cut_tac rs_map="rs_map" and x="x1" and r_s="x2" in add_scope_res_map_rev)
   apply (simp add: add_mem_def)
  apply (auto)
  done

lemma restr_sub_res_map: "\<lbrakk> sub_res_map s rs_map; scope_res_map rs_map;
  lookup_mem rs_map x = Some (r_s, rs_map') \<rbrakk> \<Longrightarrow> sub_res_map (restr_env s rs_map') rs_map'"
  apply (cut_tac rs_map="rs_map" and rs_map'="rs_map'" and x="x" and r_s="r_s" in self_scope_use_env_ih2)
    apply (auto)
  apply (simp add: sub_res_map_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
   apply (simp add: sub_scope_use_env_def)
   apply (erule_tac x="xa" in allE)
   apply (auto)
   apply (simp add: restr_env_def)
   apply (case_tac "lookup_mem rs_map' xa")
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (simp add: restr_env_def)
  done

lemma restr_valid_res_map: "\<lbrakk> valid_res_map s rs_map; lookup_mem rs_map x = Some (r_s, rs_map') \<rbrakk> \<Longrightarrow> valid_res_map (restr_env s rs_map') rs_map'"
  apply (simp add: valid_res_map_def)
  apply (auto)
    apply (rule_tac restr_disj_res_map)
      apply (simp add: valid_res_map_def)
     apply (auto)
    apply (cut_tac rs_map="rs_map" and x="x" in scope_res_map_fresh_lookup)
      apply (auto)
    apply (simp add: fresh_map_var_def)
    apply (simp add: lookup_res_def)
   apply (rule_tac restr_sub_res_map)
     apply (auto)
  apply (rule_tac self_scope_res_map)
   apply (auto)
  done

lemma dist_restr_contain_env: "\<lbrakk> sub_scope_use_env rs_map rs_map' \<rbrakk> \<Longrightarrow> contain_env (restr_env r_s rs_map) (restr_env r_s rs_map')"
  apply (simp add: sub_scope_use_env_def)
  apply (simp add: contain_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "restr_env r_s rs_map' x")
   apply (auto)
   apply (simp add: restr_env_def)
   apply (case_tac "lookup_mem rs_map' x")
    apply (auto)
  apply (simp add: restr_env_def)
  done

lemma np_restr_add_contain_env: "\<lbrakk> contain_env r_s r_x \<rbrakk> \<Longrightarrow> contain_env (add_env (np_restr_env r_s rs_map) x t) (np_restr_env (add_env r_x x t) rs_map)"
  apply (simp add: contain_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (case_tac "np_restr_env (add_env r_x x t) rs_map xa")
   apply (auto)
    (* if x = xa, we know that rs_map has an entry, it's just a matter of showing that it's the same entry. *)
  apply (case_tac "x = xa")
   apply (case_tac "np_restr_env (add_env r_x x t) rs_map xa \<noteq> Some t")
    apply (simp add: add_env_def)
    apply (simp add: np_restr_env_def)
    apply (case_tac "lookup_mem rs_map xa = None \<and> non_prim_entry (\<lambda>x'. if xa = x' then Some t else r_x x') xa")
     apply (auto)
   apply (simp add: add_env_def)
    (* otherwise, we know rs_map xa = None or r_x has a prim entry.  *)
  apply (simp add: np_restr_env_def)
  apply (case_tac "lookup_mem rs_map xa = None \<and> non_prim_entry (add_env r_x x t) xa")
   apply (auto)
   apply (simp add: add_env_def)
  apply (simp add: add_env_def)
  apply (simp add: non_prim_entry_def)
  done

lemma np_restr_add_contain_env2: "\<lbrakk> contain_env r_s r_x \<rbrakk> \<Longrightarrow> contain_env (add_env (np_restr_env r_s rs_map) x t) (np_restr_env (add_env r_x x t) (add_mem rs_map x r_c))"
  apply (simp add: contain_env_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (case_tac "np_restr_env (add_env r_x x t) (add_mem rs_map x r_c) xa")
   apply (auto)
    (* if x = xa, then since x wasn't restricted in the original, it wont be restricted here either *)
  apply (case_tac "x = xa")
   apply (simp add: add_env_def)
   apply (simp add: np_restr_env_def)
   apply (auto)
   apply (case_tac "lookup_mem (add_mem rs_map x r_c) x")
    apply (simp add: add_mem_def)
   apply (auto)
    (* for x \<noteq> xa, since xa wasn't restricted in the original, either it has a lookup in rs_map or it is a prim entry *)
  apply (simp add: np_restr_env_def)
  apply (case_tac "lookup_mem (add_mem rs_map x r_c) xa = None \<and> non_prim_entry (add_env r_x x t) xa")
   apply (auto)
    (* if you can find it in rs_map, you can find it here too *)
   apply (simp add: add_env_def)
   apply (simp add: add_mem_def)
    (* if it is prim, it will be prim in the new result as well *)
  apply (simp add: add_env_def)
  apply (simp add: non_prim_entry_def)
  done

lemma restr_env_eq: "\<lbrakk> sub_res_map s rs_map; sub_env s env \<rbrakk> \<Longrightarrow> restr_env env rs_map = env"
  apply (case_tac "\<forall> x. restr_env env rs_map x = env x")
   apply (auto)
  apply (simp add: restr_env_def)
  apply (case_tac "lookup_mem rs_map x = None")
   apply (auto)
  apply (simp add: sub_env_def)
  apply (simp add: sub_res_map_def)
  done

    (* attempt to show restricting the env to rs_map is acceptable. *)(*
lemma well_typed_restr_ih: "\<lbrakk> sub_res_map s rs_map; sub_env s env (*scope_res_map rs_map; scope_use_env rs_map r_s1;*)
  well_typed env r_s1 v tau r_s2 rx; contain_env env' (np_restr_env env rs_map) \<rbrakk> \<Longrightarrow> well_typed env' r_s1 v tau r_s2 rx"
  apply (induct v arbitrary: env env' tau r_s1 r_s2 rx rs_map)
        apply (auto)
    (* var case p1. we must show the de-referenced name will still exist. *)
      apply (case_tac "\<not> non_prim_entry env (deref_name x1a x2a)")
       apply (simp add: np_restr_env_def)
       apply (simp add: contain_env_def)
       apply (erule_tac x="deref_name x1a x2a" in allE)
       apply (auto)
      apply (case_tac "r_s1 x1a = NoPerm")
       apply (cut_tac r_x="ereq_use_env x1a tau" and r_s="r_s1" and x="x1a" in leq_use_none)
         apply (auto)
       apply (cut_tac x="x1a" and tau="tau" in ereq_use_none)
        apply (simp add: non_prim_entry_def)
       apply (auto)
      apply (simp add: scope_use_env_def)
      apply (erule_tac x="x1a" in allE)
      apply (auto)
      apply (simp add: contain_env_def)
      apply (erule_tac x="x1a" in allE)
      apply (case_tac "env' x1a")
       apply (auto)
       apply (simp add: np_restr_env_def)
      apply (simp add: np_restr_env_def)
    (* pair case *)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
     apply (cut_tac r_x="r_s2a" and r_s="r_s1" and rs_map="rs_map" in trans_scope_use_env2)
       apply (simp)
      apply (rule_tac well_typed_perm_leq)
      apply (auto)
    (* if case *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="r_s2a" in exI)
    apply (auto)
    apply (cut_tac r_x="r_s2a" and r_s="r_s1" and rs_map="rs_map" in trans_scope_use_env2)
      apply (simp)
     apply (rule_tac well_typed_perm_leq)
     apply (auto)
    apply (rule_tac x="rx1" in exI)
    apply (auto)
    apply (rule_tac x="rx2" in exI)
    apply (auto)
    (* lam case *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
   apply (rule_tac x="r_end" in exI)
   apply (rule_tac x="r_s'" in exI)
    (* - split over x1a in rs_map *)
  apply (case_tac "fresh_map_var rs_map x1a")
    (* - containment for induction *)
    apply (cut_tac env_c="np_restr_env (add_env env x1a t1) (add_mem rs_map x1a empty_use_env)" and
      env_b="add_env (np_restr_env env rs_map) x1a t1" and env_a="add_env env' x1a t1" in trans_contain_env)
      apply (rule_tac dist_add_contain_env)
      apply (simp)
     apply (rule_tac np_restr_add_contain_env2)
     apply (rule_tac id_contain_env)
    (* - scoping for induction *)
    apply (cut_tac rs_map="rs_map" and r_s="rxa" and x="x1a" and r="r" and r_c="empty_use_env" in dist_add_scope_use_env)
     apply (rule_tac r_s="r_s1" in trans_scope_use_env2)
      apply (simp_all)
    (* - scoping for induction p2 *)
    apply (cut_tac rs_map="rs_map" and x="x1a" and r_s="empty_use_env" in add_scope_res_map)
        apply (auto)
     apply (simp add: strong_use_env_def)
     apply (simp add: empty_use_env_def)
    apply (rule_tac empty_scope_use_env)
    (* if x1a is in rs_map, we have a simpler containment induction *)
   apply (cut_tac env_c="np_restr_env (add_env env x1a t1) rs_map" and
      env_b="add_env (np_restr_env env rs_map) x1a t1" and env_a="add_env env' x1a t1" in trans_contain_env)
     apply (rule_tac dist_add_contain_env)
     apply (simp)
    apply (rule_tac np_restr_add_contain_env)
    apply (rule_tac id_contain_env)
    (* - scoping for induction *)
   apply (cut_tac rs_map="rs_map" and r_s="rxa" and x="x1a" and r="r" in add_scope_use_env)
     apply (rule_tac r_s="r_s1" in trans_scope_use_env2)
      apply (simp_all)
   apply (simp add: fresh_map_var_def)
    (* app case *)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="r" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="r_s2a" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="r_s3" in exI)
  apply (auto)
  apply (cut_tac r_x="r_s2a" and r_s="r_s1" and rs_map="rs_map" in trans_scope_use_env2)
    apply (simp)
   apply (rule_tac well_typed_perm_leq)
   apply (auto)
  done*)

lemma well_typed_restr: "\<lbrakk> (*scope_res_map rs_map; scope_use_env rs_map r_s1; non_prim_env env; *)
  sub_res_map s rs_map; sub_env s env; well_typed env r_s1 v tau r_s2 rx \<rbrakk> \<Longrightarrow>
  well_typed (restr_env env rs_map) r_s1 v tau r_s2 rx"
  apply (simp add: restr_env_eq)
  (*apply (rule_tac well_typed_restr_ih)
     apply (auto)
  apply (simp add: contain_env_def)
  apply (auto)
  apply (case_tac "np_restr_env env rs_map x")
   apply (auto)
  apply (simp add: np_restr_env_def)
  apply (simp add: restr_env_def)
  apply (auto)
  apply (case_tac "lookup_mem rs_map x = None \<and> non_prim_entry env x")
   apply (auto)
  apply (simp add: non_prim_env_def)
  apply (simp add: non_prim_entry_def)
  apply (erule_tac x="x" in allE)
  apply (auto)  *)
  done

lemma well_typed_list_restr: "\<lbrakk> (*scope_res_map rs_map; non_prim_env env;*) sub_res_map s rs_map;
  sub_env s env; well_typed_list env rs_list el n tau \<rbrakk> \<Longrightarrow>
  well_typed_list (restr_env env rs_map) rs_list el n tau"
  apply (induct el arbitrary: n)
   apply (auto)
  apply (rule_tac well_typed_restr)
    apply (auto)(*
  apply (rule_tac self_scope_use_env)
  apply (simp)*)
  done

definition rs_free_vars where
  "rs_free_vars rs_map e = (\<forall> x. lookup_mem rs_map x = None \<longrightarrow> x \<notin> free_vars e)"

lemma rem_add_restr_env: "rem_env (restr_env s rs_map) x = restr_env (rem_env s x) (add_mem rs_map x r_c)"
  apply (case_tac "\<forall> y. rem_env (restr_env s rs_map) x y = restr_env (rem_env s x) (add_mem rs_map x r_c) y")
   apply (auto)
  apply (simp add: rem_env_def)
  apply (simp add: add_mem_def)
  apply (simp add: restr_env_def)
  apply (case_tac "x = y")
   apply (auto)
  apply (simp add: restr_env_def)
  apply (case_tac "lookup_mem rs_map y")
   apply (auto)
  done

    (* a lemma that states that every free variable of e appears in rs_map *)
lemma well_typed_rs_free_vars: "\<lbrakk> scope_use_env rs_map r_s1; well_typed env r_s1 e tau r_s2 rx; non_prim_env env \<rbrakk> \<Longrightarrow> rs_free_vars rs_map e"
  apply (simp add: rs_free_vars_def)
  apply (auto)
  apply (case_tac "r_s1 x = NoPerm")
   apply (cut_tac ?r_s1.0="r_s1" and x="x" and e="e" in well_typed_no_npv_use)
     apply (auto)
   apply (simp add: non_prim_vars_def)
   apply (simp add: non_prim_env_def)
   apply (erule_tac x="x" in allE)
   apply (cut_tac env="env" and x="x" and e="e" in well_typed_fv_env_use)
     apply (auto)
   apply (simp add: non_prim_entry_def)
  apply (simp add: scope_use_env_def)
  done

    (*
lemma aff_value_restr: "\<lbrakk> aff_value s e; rs_free_vars (rs_map :: perm_use_env p_stack) e \<rbrakk> \<Longrightarrow> aff_value (restr_env s rs_map) e"
  apply (induct e arbitrary: s rs_map)
       apply (auto)
    (* var case. *)
        apply (simp add: restr_env_def)
        apply (simp add: rs_free_vars_def)
        apply (erule_tac x="x1a" in allE)
        apply (auto)
    (* if cases 1 - 3. *)
       apply (simp add: rs_free_vars_def)
      apply (simp add: rs_free_vars_def)
     apply (simp add: rs_free_vars_def)
    (* lam case. *)
    apply (case_tac "\<not> rs_free_vars (add_mem rs_map x1a empty_use_env) e")
     apply (simp add: rs_free_vars_def)
     apply (auto)
     apply (erule_tac x="x" in allE)
     apply (simp add: add_mem_def)
     apply (case_tac "x = x1a")
      apply (auto)
    apply (cut_tac s="s" and rs_map="rs_map" and x="x1a" and r_c="empty_use_env" in rem_add_restr_env)
    apply (auto)
    (* app cases 1 + 2. *)
   apply (simp add: rs_free_vars_def)
  apply (simp add: rs_free_vars_def)
  done

lemma neg_aff_value_restr: "\<lbrakk> \<not> aff_value s e; rs_free_vars (rs_map :: perm_use_env p_stack) e \<rbrakk> \<Longrightarrow> \<not> aff_value (restr_env s rs_map) e"
  apply (induct e arbitrary: s rs_map)
       apply (auto)
    (* var case. *)
        apply (simp add: restr_env_def)
        apply (simp add: rs_free_vars_def)
        apply (erule_tac x="x1a" in allE)
        apply (auto)
    (* if cases 1 - 3. *)
       apply (simp add: rs_free_vars_def)
      apply (simp add: rs_free_vars_def)
     apply (simp add: rs_free_vars_def)
    (* lam case. *)
    apply (case_tac "\<not> rs_free_vars (add_mem rs_map x1a empty_use_env) e")
     apply (simp add: rs_free_vars_def)
     apply (auto)
     apply (erule_tac x="x" in allE)
     apply (simp add: add_mem_def)
     apply (case_tac "x = x1a")
      apply (auto)
    apply (cut_tac s="s" and rs_map="rs_map" and x="x1a" and r_c="empty_use_env" in rem_add_restr_env)
    apply (auto)
    (* app cases 1 + 2. *)
   apply (simp add: rs_free_vars_def)
  apply (simp add: rs_free_vars_def)
  done

lemma aff_pair_restr: "\<lbrakk> aff_pair s v1 v2 a; rs_free_vars (rs_map :: perm_use_env p_stack) v1; rs_free_vars rs_map v2 \<rbrakk> \<Longrightarrow> aff_pair (restr_env s rs_map) v1 v2 a"
  apply (simp add: aff_pair_def)
  apply (auto)
     apply (cut_tac s="s" and rs_map="rs_map" and e="v1" in neg_aff_value_restr)
       apply (auto)
    apply (cut_tac s="s" and rs_map="rs_map" and e="v2" in neg_aff_value_restr)
      apply (auto)
   apply (cut_tac s="s" and rs_map="rs_map" and e="v1" in aff_value_restr)
     apply (auto)
  apply (cut_tac s="s" and rs_map="rs_map" and e="v2" in aff_value_restr)
    apply (auto)
  done
    *)
lemma well_typed_mv_restr: "\<lbrakk> (*scope_res_map rs_map; non_prim_env env;*)
  sub_res_map s rs_map; sub_env s env;  well_typed_mem_value s env (lookup_res rs_map x) tau v \<rbrakk> \<Longrightarrow>
  well_typed_mem_value (restr_env s rs_map) (restr_env env rs_map) (lookup_res rs_map x) tau v"
  apply (case_tac v)
  apply (auto)
  apply (rule_tac x="rs_list" in exI)
  apply (auto)
   apply (rule_tac well_typed_list_restr)
    apply (auto)(*
  apply (rule_tac x="rx1" in exI)
  apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (auto)
(*
    apply (rule_tac aff_pair_restr)
      apply (auto)
     apply (rule_tac well_typed_rs_free_vars)
      apply (auto)
    apply (rule_tac well_typed_rs_free_vars)
     apply (auto)*)
   apply (rule_tac well_typed_restr)
     apply (auto)
   apply (rule_tac self_scope_use_env)
   apply (simp)
  apply (rule_tac well_typed_restr)
    apply (auto)
  apply (rule_tac self_scope_use_env)
  apply (simp)*)
  done

definition spec_scope_use_env where
  "spec_scope_use_env rs_map rs_map' = (\<forall> y. case lookup_mem rs_map' y of None \<Rightarrow> True | Some (r_s, rs_map') \<Rightarrow> lookup_mem rs_map y = Some (r_s, rs_map'))"

lemma add_spec_scope_use_env: "\<lbrakk> spec_scope_use_env rs_map rs_map'; fresh_map_var rs_map x \<rbrakk> \<Longrightarrow> spec_scope_use_env (add_mem rs_map x r_s) rs_map'"
  apply (simp add: spec_scope_use_env_def)
  apply (auto)
  apply (case_tac "lookup_mem rs_map' y")
   apply (auto)
  apply (erule_tac x="y" in allE)
  apply (auto)
  apply (simp add: fresh_map_var_def)
  apply (simp add: add_mem_def)
  apply (auto)
  done

lemma self_spec_scope_use_env: "\<lbrakk> scope_res_map rs_map; lookup_mem rs_map x = Some (r_s, rs_map') \<rbrakk> \<Longrightarrow> spec_scope_use_env rs_map rs_map'"
  apply (induct rs_map)
   apply (auto)
    (* if x1 = x, rs_map' is only one level down from rs_map. any y that can be sucessfully looked-up from rs_map' is distinct from x1 by freshness,
      meaning we look it up from rs_map' *)
  apply (case_tac "x1 = x")
   apply (auto)
   apply (simp add: spec_scope_use_env_def)
   apply (auto)
   apply (simp add: scope_res_map_def)
   apply (simp add: fresh_map_var_def)
   apply (case_tac "lookup_mem rs_map' y")
    apply (auto)
    (* otherwise we have to induct *)
  apply (cut_tac rs_map="rs_map" and x="x1" and r_s="x2" in add_scope_res_map_rev)
   apply (simp add: add_mem_def)
  apply (auto)
  apply (cut_tac rs_map="rs_map" and x="x1" and rs_map'="rs_map'" in add_spec_scope_use_env)
    apply (simp)
   apply (simp add: scope_res_map_def)
  apply (simp add: add_mem_def)
  done
    (*
lemma well_typed_restr_state: "\<lbrakk> well_typed_state s env rs_map; lookup_mem rs_map x = Some (r_s, rs_map') \<rbrakk> \<Longrightarrow>
  well_typed_state (restr_env s rs_map') (restr_env env rs_map') rs_map'"
  apply (simp add: well_typed_state_def)
  apply (auto)
    apply (rule_tac restr_sub_env)
    apply (simp)
   apply (rule_tac restr_valid_res_map)
    apply (auto)
  apply (case_tac "restr_env s rs_map' xa")
   apply (auto)
  apply (case_tac "s xa = None")
   apply (simp add: restr_env_def)
   apply (case_tac "lookup_mem rs_map' xa")
    apply (auto)
  apply (case_tac "restr_env env rs_map' xa")
   apply (auto)
   apply (erule_tac x="xa" in allE)
   apply (case_tac "env xa \<noteq> None")
    apply (simp add: restr_env_def)
    apply (case_tac "lookup_mem rs_map' xa")
     apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (auto)
  apply (case_tac "env xa")
   apply (auto)
  apply (case_tac "aa \<noteq> ab")
   apply (simp add: restr_env_def)
   apply (case_tac "lookup_mem rs_map' xa")
    apply (auto)
  apply (rule_tac well_typed_mv_restr)
   apply (simp add: valid_res_map_def)
   apply (auto)
   apply (rule_tac rs_map="rs_map" and x="x" in self_scope_res_map)
    apply (auto)
  apply (simp add: restr_env_def)
  apply (case_tac "lookup_mem rs_map' xa")
   apply (auto)
  apply (simp add: lookup_res_def)
  apply (cut_tac rs_map="rs_map" and rs_map'="rs_map'" in self_spec_scope_use_env)
    apply (auto)
   apply (simp add: valid_res_map_def)
  apply (simp add: spec_scope_use_env_def)
  apply (erule_tac x="xa" in allE)
  apply (auto)
  done    *)

end


theory Simple_Stm
  imports "RoboChart-Circus.RoboChart_Circus"
begin

stm stm1 =
  var x :: int
  event e :: unit
  initial s1
  final s2
  transition t1 [frm s1 to s2 condition "x = 0" action "x := 1"]

context stm1
begin

term null_event

thm t1_def

term machine

thm nodes

thm transitions

thm machine

lemma "action = undefined"
  apply (simp add: sm_sem action_simp sm_trans_map_def action_def)
  oops

lemma "action = undefined"
  apply (simp add: action_def sm_semantics_def)
  apply (simp add: s1_def basic_Node_sem)
  apply (simp add: tr_semantics_def t1_def tn_action_def Let_unfold action_simp tn_condition_def)
  oops

end

end