(*  Title: HS verification with lenses *)

section \<open> HS verification with lenses \<close>

text \<open> We use shallow expressions to rephrase hybrid systems properties. Each operator below
includes lemmas for verification condition generation. \<close>

theory Evolution_Commands
  imports
    Correctness_Specs
    "Framed_ODEs.Framed_ODEs"
begin

subsection \<open> Analytic dynamics \<close>

definition g_evol :: "(('a::ord) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b pred \<Rightarrow> ('b \<Rightarrow> 'a set) \<Rightarrow> ('b \<Rightarrow> 'b set)" ("EVOL")
  where "g_evol \<phi> G U = (\<lambda>s. g_orbit (\<lambda>t. \<phi> t s) G (U s))"

lemma fbox_g_evol:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "|EVOL \<phi> G U] Q = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  unfolding g_evol_def g_orbit_eq fbox_def by auto

lemma fdia_g_evol:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "|EVOL \<phi> G U\<rangle> Q = (\<lambda>s. \<exists>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<and> Q (\<phi> t s))"
  unfolding g_evol_def g_orbit_eq fdia_def by auto

lemma fbox_g_evol_alt:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "|EVOL \<phi> G U] Q = (\<forall>t\<in>U. ((\<forall>\<tau>\<in>down U \<guillemotleft>t\<guillemotright>. \<phi> \<tau> \<dagger> G) \<longrightarrow> \<phi> t \<dagger> Q))\<^sub>e"
  by (simp add: fbox_g_evol, simp add: expr_defs)

definition g_evol_on :: "('c::real_normed_vector \<Longrightarrow> 'a) \<Rightarrow> (real \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool)
  \<Rightarrow> ('c \<Rightarrow> real set) \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "g_evol_on a \<phi> G U s \<equiv>
  put\<^bsub>a\<^esub> s ` (g_evol (\<phi>\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>a\<^esub> s) (\<lambda> v. G (put\<^bsub>a\<^esub> s v)) U (get\<^bsub>a\<^esub> s))"

lemma g_evol_on_eq:
  "vwb_lens a \<Longrightarrow> g_evol_on a \<phi> G U s
    = {(s \<triangleleft>\<^bsub>a\<^esub> \<phi> t s) |t. t \<in> U (get\<^bsub>a\<^esub> s) \<and> (\<forall>\<tau>. \<tau> \<in> down (U (get\<^bsub>a\<^esub> s)) t \<longrightarrow> G (s \<triangleleft>\<^bsub>a\<^esub> \<phi> \<tau> s))}"
  by (auto simp add: g_evol_on_def g_evol_def g_orbit_eq lens_defs tsubst2vecf_eq)

abbreviation g_evol_eqs :: "('c::real_normed_vector \<Longrightarrow> 'b) \<Rightarrow> (real \<Rightarrow> ('c, 'b) expr) \<Rightarrow> 'b pred
  \<Rightarrow> ('c \<Rightarrow> real set) \<Rightarrow> ('b \<Rightarrow> 'b set)"
  where "g_evol_eqs a \<phi> G U \<equiv> g_evol_on a (\<lambda>\<tau>. subst_upd [\<leadsto>] a (\<phi> \<tau>)) G U"

no_notation disj (infixr "|" 30)

syntax
  "_time_var" :: id
  "_EVOL" :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("{EVOL _ = _ | _ on _}")
  "_EVOL_ge" :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("{EVOL _ = _ | _}")
  "_EVOL_simp" :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("{EVOL _ = _}")

parse_translation
  \<open>[(@{syntax_const "_time_var"}, fn ctx => fn term => Syntax.free "\<tau>")]\<close>

translations
  "_EVOL a f G U" => "CONST g_evol_eqs a (\<lambda> _time_var. (f)\<^sub>e) (G)\<^sub>e (U)\<^sub>e"
  "_EVOL a f G U" <= "CONST g_evol_eqs a (\<lambda> b. (f)\<^sub>e) (G)\<^sub>e (U)\<^sub>e"
  "_EVOL_ge a f G" == "_EVOL a f G {0..}"
  "_EVOL_simp a f" == "_EVOL_ge a f (CONST True)"

term "{EVOL x = 5 * \<guillemotleft>\<tau>\<guillemotright> + $x}"
term "{EVOL x = 5 * \<guillemotleft>\<tau>\<guillemotright> + $x | $x \<ge> 0 \<and> \<guillemotleft>\<tau>\<guillemotright> \<le> \<guillemotleft>max\<guillemotright>}"
term "{EVOL x = 5 * \<guillemotleft>\<tau>\<guillemotright> + $x | $x \<ge> 0 \<and> \<guillemotleft>\<tau>\<guillemotright> \<le> \<guillemotleft>max\<guillemotright> on {0--\<guillemotleft>t\<guillemotright>}}"
term "{EVOL (x, y) = ($x * cos \<guillemotleft>\<tau>\<guillemotright> + $y * sin \<guillemotleft>\<tau>\<guillemotright>, - $x * sin \<guillemotleft>\<tau>\<guillemotright> + $y * cos \<guillemotleft>\<tau>\<guillemotright>) | true on UNIV}"

lemma fbox_g_evol_on [wlp]:
  assumes "vwb_lens a"
  shows "|g_evol_on a \<phi> G U] Q
  = (\<forall>t\<in>\<guillemotleft>U\<guillemotright> ($a). (\<forall> \<tau>\<in>down (\<guillemotleft>U\<guillemotright> ($a)) \<guillemotleft>t\<guillemotright> . G\<lbrakk>\<langle>\<phi> \<tau>\<rangle>\<^sub>s a/a\<rbrakk>) \<longrightarrow> Q\<lbrakk>\<langle>\<phi> t\<rangle>\<^sub>s a/a\<rbrakk>)\<^sub>e"
  unfolding fbox_def fun_eq_iff g_evol_on_eq[OF assms]
  by expr_auto

lemma "vwb_lens a \<Longrightarrow> |g_evol_on a \<phi> G U] Q =
  (\<lambda>s. \<forall>t\<in>U (get\<^bsub>a\<^esub> s). (\<forall>\<tau>\<in>down (U (get\<^bsub>a\<^esub> s)) t. G (s \<triangleleft>\<^bsub>a\<^esub> \<phi> \<tau> s)) \<longrightarrow> Q (s \<triangleleft>\<^bsub>a\<^esub> \<phi> t s))"
  by (auto simp add: g_evol_on_eq fbox_def fun_eq_iff)

subsection \<open> ODE-dynamics \<close>

text \<open> Verification by providing solutions \<close>

lemma fbox_g_orbital: "|g_orbital f G U S t\<^sub>0] Q =
  (\<lambda>s. \<forall>X\<in>Sols U S f t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> Q (X t))"
  unfolding fbox_def g_orbital_eq
  by (auto simp: fun_eq_iff)

lemma fdia_g_orbital: "|g_orbital f G U S t\<^sub>0\<rangle> Q =
  (\<lambda>s. \<exists>X\<in>Sols U S f t\<^sub>0 s. \<exists>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<and> Q (X t))"
  unfolding fdia_def g_orbital_eq
  by (auto simp: fun_eq_iff)

context local_flow \<comment> \<open> First we obtain the results for local flows and orbitals \<close>
begin

lemma fbox_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_orbital (\<lambda>t. f) G U S 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>(U s). (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  apply(unfold fbox_g_orbital fun_eq_iff)
  apply(intro iffI allI impI conjI; clarify)
   apply(force simp: in_ivp_sols assms)
  apply(frule ivp_solsD(2), frule ivp_solsD(3), frule ivp_solsD(4))
  apply(subgoal_tac "\<forall>\<tau>\<in>down (U x) t. X \<tau> = \<phi> \<tau> x")
   apply(clarsimp, fastforce, rule ballI)
  apply(rule ivp_unique_solution[OF _ _ _ _ _ in_ivp_sols])
  using assms by auto

lemma fbox_g_ode: "|g_orbital (\<lambda>t. f) G (\<lambda>s. T) S 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  by (subst fbox_g_ode_subset, simp_all add: init_time interval_time)

lemma fbox_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> |g_orbital (\<lambda>t. f) G (\<lambda>s. {0..t}) S 0] Q =
  (\<lambda>s. s \<in> S \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  apply(subst fbox_g_ode_subset, simp_all add: subintervalI init_time real_Icc_closed_segment)
  by (auto simp: closed_segment_eq_real_ivl)

lemma fbox_orbit: "|\<gamma>\<^sup>\<phi>] Q = (\<lambda>s. s \<in> S \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s)))"
  unfolding orbit_def fbox_g_ode by simp

lemma fdia_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_orbital (\<lambda>t. f) G U S 0\<rangle> Q =
  (\<lambda>s. if s \<in> S then (\<exists>t\<in>(U s). (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<and> Q (\<phi> t s))
    else (\<exists>X\<in>Sols U S (\<lambda>t. f) 0 s. \<exists>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<and> Q (X t)))"
  using assms
  apply(unfold fdia_g_orbital fun_eq_iff)
  apply (intro allI iffI impI conjI; (clarsimp split: if_splits)?)
   apply(subgoal_tac "\<forall>\<tau>\<in>down (U x) t. X \<tau> = \<phi> \<tau> x"; clarsimp?)
  apply (rule_tac x=t in bexI; force)
   apply(rule ivp_unique_solution[OF _ _ _ _ _ in_ivp_sols, of _ U _ _]; force?)
  apply (rule_tac x="\<lambda>t. \<phi> t x" in bexI, rule_tac x=t in bexI; force?)
  by (auto intro!: in_ivp_sols)

lemma fdia_g_ode:
  assumes "S = UNIV"
  shows "|g_orbital (\<lambda>t. f) G (\<lambda>s. T) S 0\<rangle> Q =
  (\<lambda>s. (\<exists>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<and> Q (\<phi> t s)))"
  using init_time interval_time assms
  by (subst fdia_g_ode_subset; force)

end

text \<open> Then we relate both orbital operators:  \<close>

lemma fbox_g_orbital_on: "|g_orbital_on x f G U S t\<^sub>0] Q =
  (\<lambda>s. \<forall>X\<in>Sols U S (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t\<^sub>0 (get\<^bsub>x\<^esub> s).
        \<forall>t\<in>U (get\<^bsub>x\<^esub> s). (\<forall>\<tau>. \<tau> \<in> U (get\<^bsub>x\<^esub> s) \<and> \<tau> \<le> t \<longrightarrow> G (put\<^bsub>x\<^esub> s (X \<tau>))) \<longrightarrow> Q (put\<^bsub>x\<^esub> s (X t)))"
  by (auto simp add: g_orbital_on_eq fbox_def g_orbital_eq fun_eq_iff)

lemma fdia_g_orbital_on: "|g_orbital_on x f G U S t\<^sub>0\<rangle> Q =
  (\<lambda>s. \<exists>X\<in>Sols U S (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t\<^sub>0 (get\<^bsub>x\<^esub> s).
        \<exists>t\<in>U (get\<^bsub>x\<^esub> s). (\<forall>\<tau>. \<tau> \<in> U (get\<^bsub>x\<^esub> s) \<and> \<tau> \<le> t \<longrightarrow> G (put\<^bsub>x\<^esub> s (X \<tau>))) \<and> Q (put\<^bsub>x\<^esub> s (X t)))"
  by (auto simp: fdia_def g_orbital_on_eq g_orbital_eq fun_eq_iff)

lemma fbox_orbitals_prelim: "|g_orbital_on x f G U S t\<^sub>0] Q =
  (\<lambda>s. (fbox (g_orbital (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) (G\<down>\<^sub>F\<^bsub>x\<^esub> s) U S t\<^sub>0) (Q\<down>\<^sub>F\<^bsub>x\<^esub> s)) (get\<^bsub>x\<^esub> s))"
  unfolding fbox_g_orbital[unfolded clarify_fbox] fbox_g_orbital_on fun_eq_iff
  by (clarsimp simp: expr_defs)

lemma fdia_orbitals_prelim: "|g_orbital_on x f G U S t\<^sub>0\<rangle> Q =
  (\<lambda>s. (fdia (g_orbital (f\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) (G\<down>\<^sub>F\<^bsub>x\<^esub> s) U S t\<^sub>0) (Q\<down>\<^sub>F\<^bsub>x\<^esub> s)) (get\<^bsub>x\<^esub> s))"
  by (expr_auto add: fdia_def g_orbital_on_eq g_orbital_eq)

lemmas fbox_g_orbital_on_orbital = fbox_orbitals_prelim[
    unfolded clarify_fbox[of
      "g_orbital (tsubst2vecf _ _ _) (_ \<down>\<^sub>F\<^bsub>_\<^esub> _) _ _ _"
      "(_ \<down>\<^sub>F\<^bsub>_\<^esub> _)",
      symmetric
      ]
    ]

lemmas fdia_g_orbital_on_orbital = fdia_orbitals_prelim[
    unfolded clarify_fdia[of
      "g_orbital (tsubst2vecf _ _ _) (_ \<down>\<^sub>F\<^bsub>_\<^esub> _) _ _ _"
      "(_ \<down>\<^sub>F\<^bsub>_\<^esub> _)",
      symmetric
      ]
    ]

subsubsection \<open> ODE notation \<close>

text \<open> We add notation for the general version below.  \<close>

abbreviation g_ode_frame :: "('c::banach \<Longrightarrow> 'a) \<Rightarrow> 'a subst \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> real set)
  \<Rightarrow> 'c set \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "g_ode_frame a \<sigma> G U S t\<^sub>0 \<equiv> g_orbital_on a (\<lambda>t. \<sigma>) G U S t\<^sub>0"

abbreviation g_ode_on :: "('c::banach \<Longrightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> real set)
  \<Rightarrow> 'c set \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "g_ode_on a f G U S t\<^sub>0 \<equiv> g_ode_frame a (subst_upd [\<leadsto>] a f) G U S t\<^sub>0"

abbreviation g_dl_ode_frame :: "('c::banach \<Longrightarrow> 'a) \<Rightarrow> 'a subst \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "g_dl_ode_frame a \<sigma> G \<equiv> g_ode_frame a \<sigma> G ({t. 0 \<le> t})\<^sub>e UNIV 0"

abbreviation g_dl_ode_on :: "('c::banach \<Longrightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a set"
  where "g_dl_ode_on a f G \<equiv> g_ode_on a f G ({t. 0 \<le> t})\<^sub>e UNIV 0"

no_notation (ASCII) disj (infixr "|" 30)

text \<open> We set up syntax for writing a list of derivatives. Internally, these are translated to
  a set of substitution maplets, but the user doesn't see that. \<close>

nonterminal deriv and derivs

syntax
  "_deriv"       :: "[svid, logic] => deriv"             ("_` = _")
  ""             :: "deriv => derivs"            ("_")
  "_Derivs"      :: "[deriv, derivs] => derivs" ("_,/ _")
  "_SDeriv"      :: "smaplets \<Rightarrow> derivs"

syntax
  "_ode_frame"       :: "svid \<Rightarrow> derivs \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("_:{_ | _ on _ _ @ _}")
  "_dl_ode_frame"    :: "svid \<Rightarrow> derivs \<Rightarrow> logic \<Rightarrow> logic" ("_:{_ | _}")
  "_dl_ode_frame_ng" :: "svid \<Rightarrow> derivs \<Rightarrow> logic" ("_:{_}")
  "_g_dl_ode_on"     :: "derivs \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("{_ | _ on _ _ @ _}")
  "_ode"             :: "derivs \<Rightarrow> logic \<Rightarrow> logic" ("{_ | _}")
  "_ode_ng"          :: "derivs \<Rightarrow> logic" ("{_}")

(*  "_dl_derivs"       :: "derivs \<Rightarrow> logic" ("{_}") *)
(*
  "_g_dl_ode_on"     :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("{(_)\<acute> = _ | _ on _ _ @ _}")
  "_ode"             :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("{(_)\<acute> = _ | _}")
   "_ode_ng"          :: "svid \<Rightarrow> logic \<Rightarrow> logic" ("{(_)\<acute> = _}") *)

translations
  "_deriv x v"  => "_smaplet x v"
  "_Derivs d \<sigma>" => "_SMaplets d \<sigma>"
  "_deriv (_salphamk x) v"  <= "_SDeriv (_smaplet x v)"
  "_Derivs (_SDeriv d) (_SDeriv \<sigma>)"  <= "_SDeriv (_SMaplets d \<sigma>)"
  "_ode_frame a \<sigma> G U S t\<^sub>0" => "CONST g_ode_frame a (_Subst \<sigma>) (G)\<^sub>e (U)\<^sub>e S t\<^sub>0"
  "_ode_frame (_salphamk a) (_SDeriv \<sigma>) G U S t\<^sub>0" <= "CONST g_ode_frame a (_Subst \<sigma>) (G)\<^sub>e (U)\<^sub>e S t\<^sub>0"
  "_dl_ode_frame a \<sigma> G" => "CONST g_dl_ode_frame a (_Subst \<sigma>) (G)\<^sub>e"
  "_dl_ode_frame (_salphamk a) (_SDeriv \<sigma>) G" <= "CONST g_dl_ode_frame a (_Subst \<sigma>) (G)\<^sub>e"
  "_dl_ode_frame_ng a \<sigma>" == "_dl_ode_frame a \<sigma> (CONST True)"

  "_g_dl_ode_on \<sigma> G U S t\<^sub>0" => "CONST g_ode_frame (_smaplets_svids \<sigma>) (_Subst \<sigma>) (G)\<^sub>e (U)\<^sub>e S t\<^sub>0"

  "_ode \<sigma> G" => "CONST g_dl_ode_frame (_smaplets_svids \<sigma>) (_Subst \<sigma>) (G)\<^sub>e"
  "_ode (_deriv (_salphamk a) F) G" <= "CONST g_dl_ode_on a (F)\<^sub>e (G)\<^sub>e"
  "_ode_ng \<sigma>" == "_ode \<sigma> (CONST True)"

term "{x` = 1}"
term "{x` = $y, y` =$z + ($y)\<^sup>2 - $y | $y \<ge> 0}"
term "{(x, y)` = (1, 2*$x)}"
term "(x, y, z):{x` = 1, y` = 2*$x}"
term "(x,y):{(x, y)` = (1, 2*$x), z` = $y}"

lemma lens_upd_syntax_sugar:
  "F (x \<leadsto> f) = (\<lambda>s. put\<^bsub>x\<^esub> (F s) (f s))"
  "F (x \<leadsto> f, y \<leadsto> g) = (\<lambda>s. put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> (F s) (f s)) (g s))"
  "F (x\<^sub>1 \<leadsto> f(x\<^sub>2 \<leadsto> g ($x\<^sub>3))) = (\<lambda>s. put\<^bsub>x\<^sub>1\<^esub> (F s) (put\<^bsub>x\<^sub>2\<^esub> (f s) (g s (get\<^bsub>x\<^sub>3\<^esub> s))))"
  by expr_simp+

lemma g_ode_frame_syntax_sugar:
  shows "(x,y):{x` = \<guillemotleft>f\<guillemotright> ($x), y` = g | G on U S @ t\<^sub>0}
  = g_ode_frame (x +\<^sub>L y) [x \<leadsto> \<guillemotleft>f\<guillemotright> ($x), y \<leadsto> g] (G)\<^sub>e (U)\<^sub>e S t\<^sub>0 "
    and "g_ode_frame (x +\<^sub>L y) [x \<leadsto> \<guillemotleft>f\<guillemotright> ($x), y \<leadsto> g] (G)\<^sub>e (U)\<^sub>e S t\<^sub>0
  = g_orbital_on (x +\<^sub>L y) (\<lambda>t s. put\<^bsub>y\<^esub> (put\<^bsub>x\<^esub> s (f (get\<^bsub>x\<^esub> s))) (g s)) G U S t\<^sub>0"
    and "((x,y):{x` = f(y \<leadsto> h) | G on U S @ t\<^sub>0})
  = g_ode_frame (x +\<^sub>L y) [x \<leadsto> f(y \<leadsto> h)] (G)\<^sub>e (U)\<^sub>e S t\<^sub>0"
    and "g_ode_frame (x +\<^sub>L y) [x \<leadsto> f(y \<leadsto> h)] (G)\<^sub>e (U)\<^sub>e S t\<^sub>0
  = g_orbital_on (x +\<^sub>L y) (\<lambda>t s. put\<^bsub>x\<^esub> s (put\<^bsub>y\<^esub> (f s) (h s))) G U S t\<^sub>0"
   apply (rule_tac f="\<lambda>s. g_ode_frame (x +\<^sub>L y) s (G)\<^sub>e (U)\<^sub>e S t\<^sub>0" in arg_cong)
  prefer 3 apply (rule_tac f="\<lambda>s. g_ode_frame (x +\<^sub>L y) s (G)\<^sub>e (U)\<^sub>e S t\<^sub>0" in arg_cong)
  using lens_indep_comm lens_indep_get lens_indep_get[OF lens_indep_sym]
  by expr_simp+

lemma g_ode_on_syntax_sugar:
  "g_ode_on x (f)\<^sub>e (G)\<^sub>e (U)\<^sub>e S t\<^sub>0 = g_orbital_on x (\<lambda>t. [x \<leadsto> f]) G U S t\<^sub>0"
  by (simp add: SEXP_def taut_def subst_upd_def subst_id_def)

lemma g_ode_frame_prod_sugar:
  "h \<bowtie> t \<Longrightarrow> {h` = \<guillemotleft>k\<guillemotright>, t` = 1 | $t \<le> (H\<^sub>u - h\<^sub>m)/\<guillemotleft>k\<guillemotright>} = {(h, t)` = (\<guillemotleft>k\<guillemotright>, 1) | $t \<le> (H\<^sub>u - h\<^sub>m)/\<guillemotleft>k\<guillemotright>}"
  unfolding g_orbital_on_def apply(clarsimp simp add: fun_eq_iff)
  by (rule_tac x="[h \<leadsto> \<guillemotleft>k\<guillemotright>, t \<leadsto> 1]" in arg_cong)
    (expr_simp add: lens_indep.lens_put_comm)

text \<open> We use the local-flow results to show the generalised counterparts. \<close>

definition local_flow_on :: "('s \<Rightarrow> 's) \<Rightarrow> ('c::{heine_borel, banach} \<Longrightarrow> 's) \<Rightarrow> real set
  \<Rightarrow> 'c set \<Rightarrow> (real \<Rightarrow> 's \<Rightarrow> 's) \<Rightarrow> bool"
  where "local_flow_on f x T S \<phi> = (\<forall>s. local_flow (lframe_subst x f s) T S (\<lambda>t. (\<phi>\<down>\<^sub>V\<^sub>e\<^sub>c\<^bsub>x\<^esub> s) t))"

lemma fbox_g_ode_frame_flow:
  fixes a::"'c::{heine_borel,banach} \<Longrightarrow> 's"
    and f::"'s \<Rightarrow> 's"
  assumes "local_flow_on f x T S \<phi>" and "vwb_lens x"
    and "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_ode_frame x f G U S 0] Q = (\<lambda>s. get\<^bsub>x\<^esub> s \<in> S
    \<longrightarrow> (\<forall>t\<in>U (get\<^bsub>x\<^esub> s). (\<forall>\<tau>\<in>down (U (get\<^bsub>x\<^esub> s)) t. G (s \<triangleleft>\<^bsub>x\<^esub> \<phi> \<tau> s)) \<longrightarrow> Q (s \<triangleleft>\<^bsub>x\<^esub> \<phi> t s)))"
  apply (subst fbox_g_orbital_on_orbital)
  apply (subst local_flow.fbox_g_ode_subset[OF assms(1)[unfolded local_flow_on_def, rule_format]])
  using assms by expr_auto+

lemmas fbox_solve = fbox_g_ode_frame_flow[where T=UNIV, simplified]

lemma fdia_g_ode_frame_flow:
  fixes a::"'c::{heine_borel,banach} \<Longrightarrow> 's"
    and f::"'s \<Rightarrow> 's"
  assumes "local_flow_on f x T UNIV \<phi>" and "vwb_lens x"
    and "\<And>s. 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_ode_frame x f G U UNIV 0\<rangle> Q =
  (\<lambda>s. (\<exists>t\<in>U (get\<^bsub>x\<^esub> s). (\<forall>\<tau>\<in>down (U (get\<^bsub>x\<^esub> s)) t. G (s \<triangleleft>\<^bsub>x\<^esub> \<phi> \<tau> s)) \<and> Q (s \<triangleleft>\<^bsub>x\<^esub> \<phi> t s)))"
  apply (subst fdia_g_orbital_on_orbital, rule ext)
  apply (subst local_flow.fdia_g_ode_subset[OF assms(1)[unfolded local_flow_on_def, rule_format]])
  using assms by expr_auto+

lemma fbox_g_ode_on_flow: (* delete *)
  assumes "local_flow_on (subst_upd [\<leadsto>] A f) A T S \<phi>"
    and "vwb_lens A"
    and "\<And>s. 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_ode_on A f G U S 0] Q = (\<lambda>s. get\<^bsub>A\<^esub> s \<in> S
    \<longrightarrow> (\<forall>t\<in>U (get\<^bsub>A\<^esub> s). (\<forall>\<tau>\<in>down (U (get\<^bsub>A\<^esub> s)) t. G (s \<triangleleft>\<^bsub>A\<^esub> \<phi> \<tau> s)) \<longrightarrow> Q (s \<triangleleft>\<^bsub>A\<^esub> \<phi> t s)))"
  by (subst fbox_g_ode_frame_flow[OF assms], simp)

lemma fbox_g_dl_ode_frame_flow: (* delete *)
  assumes "local_flow_on f A T UNIV \<phi>"
    and "vwb_lens A" and "{t. 0 \<le> t} \<subseteq> T"
  shows "|g_dl_ode_frame A f G] Q = (\<lambda>s.
  (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s \<oplus>\<^sub>L \<phi> \<tau> s on A)) \<longrightarrow> Q (s \<oplus>\<^sub>L \<phi> t s on A)))"
  apply (subst fbox_g_ode_frame_flow[OF assms(1,2)])
  using assms(2,3) by auto

lemma fbox_g_dl_ode_on_flow: (* delete *)
  assumes "local_flow_on (subst_upd [\<leadsto>] A f) A T UNIV \<phi>"
    and "vwb_lens A" and "{t. 0 \<le> t} \<subseteq> T"
  shows "|g_dl_ode_on A f G] Q = (\<lambda>s.
  (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s \<oplus>\<^sub>L \<phi> \<tau> s on A)) \<longrightarrow> Q (s \<oplus>\<^sub>L \<phi> t s on A)))"
  by (subst fbox_g_dl_ode_frame_flow[OF assms], simp)

lemma fbox_g_ode_frame_g_evol:
  assumes "local_flow_on f A T S \<phi>"
    and "vwb_lens A"
    and "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_ode_frame A f G U S 0] Q = (\<lambda>s. get\<^bsub>A\<^esub> s \<in> S \<longrightarrow> ( |g_evol_on A \<phi> G U] Q) s)"
  by (subst fbox_g_ode_frame_flow[OF assms(1,2,3)], force)
    (subst fbox_g_evol_on[OF assms(2)], expr_auto)

lemma fbox_g_ode_on_g_evol: (* delete *)
  assumes "local_flow_on (subst_upd [\<leadsto>] A f) A T UNIV \<phi>" and "vwb_lens A"
    and "\<And>s. 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "|g_ode_on A f G U UNIV 0] Q = |g_evol_on A \<phi> G U] Q"
  using fbox_g_ode_frame_g_evol[OF assms(1,2,3), simplified]
  by force

lemma fbox_g_dl_ode_frame_g_evol: (* delete *)
  assumes "local_flow_on f A T UNIV \<phi>"
    and "vwb_lens A" and "{t. 0 \<le> t} \<subseteq> T"
  shows "|g_dl_ode_frame A f G] Q = |g_evol_on A \<phi> G ({0..})\<^sub>e] Q"
  using assms(3)
  by (subst fbox_g_ode_frame_g_evol[OF assms(1,2)])
    (auto simp: fbox_g_evol_on[OF assms(2)])

lemmas fbox_g_dL_easiest = fbox_g_dl_ode_frame_g_evol[of _ _ UNIV, simplified]

subsection \<open> Differential invariants \<close>

definition g_ode_inv :: "(real \<Rightarrow> 'a::real_normed_vector \<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow>
  real \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(1x\<acute>=_ & _ on _ _ @ _ DINV _ )")
  where "(x\<acute>= f & G on U S @ t\<^sub>0 DINV I) = g_orbital f G U S t\<^sub>0"

lemma fbox_g_orbital_guard:
  assumes "H = (\<lambda>s. G s \<and> Q s)"
  shows "|g_orbital f G U S t\<^sub>0] Q = |g_orbital f G U S t\<^sub>0] H "
  unfolding fbox_g_orbital using assms by auto

lemma fbox_g_orbital_on_guard:
  assumes "H = (G \<and> Q)\<^sub>e"
  shows "|g_orbital_on a f G U S t\<^sub>0] Q = |g_orbital_on a f G U S t\<^sub>0] H "
  unfolding fbox_g_orbital_on
  using assms by auto

lemma fbox_diff_inv:
  "(I \<le> |g_orbital f G U S t\<^sub>0] I) = diff_inv U S G f t\<^sub>0 I"
  by (auto simp: diff_inv_def ivp_sols_def fbox_def g_orbital_eq)

lemma hoare_diff_inv:
  "\<^bold>{I\<^bold>} (g_orbital f G U S t\<^sub>0) \<^bold>{I\<^bold>} = diff_inv (U)\<^sub>e S (G)\<^sub>e f t\<^sub>0 (I)\<^sub>e"
  using fbox_diff_inv[of I f G U S t\<^sub>0] by (simp add: SEXP_def)

lemma fbox_diff_inv_on:
  "I \<le> fbox (g_orbital_on a f G U S t\<^sub>0) I = diff_inv_on a f G U S t\<^sub>0 I"
  by (auto simp: diff_inv_on_def ivp_sols_def fbox_def g_orbital_on_eq SEXP_def)

lemma fbox_diff_inv_on':
  "(I \<le> |g_orbital_on a f G U S t\<^sub>0] I) = diff_inv_on a f G U S t\<^sub>0 I"
  by (simp add: fbox_diff_inv_on expr_defs)

lemma hoare_diff_inv_on:
  "\<^bold>{I\<^bold>} (g_orbital_on a f G U S t\<^sub>0) \<^bold>{I\<^bold>} = diff_inv_on a f G U S t\<^sub>0 I"
  using fbox_diff_inv_on[of I a f G U S]
  by (simp add: SEXP_def)

lemma hoare_diff_inv_on':
  "\<^bold>{I\<^bold>} (g_orbital_on a f G U S t\<^sub>0) \<^bold>{I\<^bold>} = diff_inv_on a f (G)\<^sub>e (U)\<^sub>e S t\<^sub>0 (I)\<^sub>e"
  using fbox_diff_inv_on[of I a f G U S]
  by (simp add: SEXP_def)

lemma diff_inv_guard_ignore:
  assumes "I \<le> |g_orbital f (True)\<^sub>e U S t\<^sub>0] I"
  shows "I \<le> |g_orbital f G U S t\<^sub>0] I"
  using assms
  by (auto simp: fbox_diff_inv diff_inv_eq)

lemma diff_inv_on_guard_ignore:
  assumes "I \<le> |g_orbital_on a f (True)\<^sub>e U S t\<^sub>0] I"
  shows "I \<le> |g_orbital_on a f G U S t\<^sub>0] I"
  using assms
  by (auto simp: fbox_diff_inv_on diff_inv_on_eq expr_defs)

context local_flow
begin

lemma fbox_diff_inv_eq:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "diff_inv U S (\<lambda>s. True) (\<lambda>t. f) 0 I =
  ((\<lambda>s. s \<in> S \<longrightarrow> I s) = |g_orbital (\<lambda>t. f) (True)\<^sub>e U S 0] (\<guillemotleft>\<s>\<guillemotright> \<in> \<guillemotleft>S\<guillemotright> \<longrightarrow> I))"
  unfolding fbox_diff_inv[symmetric]
  apply(subst fbox_g_ode_subset[OF assms], simp)+
  apply(clarsimp simp: le_fun_def fun_eq_iff, safe, force)
   apply(erule_tac x=0 in ballE)
  using init_time in_domain ivp(2) assms apply(force, force)
  apply(erule_tac x=x in allE, clarsimp, erule_tac x=t in ballE)
  using in_domain ivp(2) assms by force+

lemma diff_inv_eq_inv_set:
  "diff_inv (\<lambda>s. T) S (\<lambda>s. True) (\<lambda>t. f) 0 I = (\<forall>s. I s \<longrightarrow> \<gamma>\<^sup>\<phi> s \<subseteq> {s. I s})"
  unfolding diff_inv_eq_inv_set orbit_def by simp

end

lemma fbox_g_odei: "P \<le> I \<Longrightarrow> I \<le> |g_orbital f G U S t\<^sub>0] I \<Longrightarrow> (\<lambda>s. I s \<and> G s) \<le> Q \<Longrightarrow>
  P \<le> |x\<acute>= f & G on U S @ t\<^sub>0 DINV I] Q"
  unfolding g_ode_inv_def
  apply(rule_tac b="|g_orbital f G U S t\<^sub>0] I" in order.trans)
   apply(rule_tac I="I" in fbox_inv, simp_all)
  apply(subst fbox_g_orbital_guard, simp)
  by (rule fbox_iso, force)

lemma hoare_g_odei: " \<^bold>{I\<^bold>} (g_orbital f G U S t\<^sub>0) \<^bold>{I\<^bold>}  \<Longrightarrow> `P \<longrightarrow> I` \<Longrightarrow> `I \<and> G \<longrightarrow> Q` \<Longrightarrow>
 \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0 DINV I) \<^bold>{Q\<^bold>}"
  by (rule fbox_g_odei, simp_all add: SEXP_def taut_def le_fun_def)

lemma fbox_diff_invI: "(I)\<^sub>e \<le> |g_orbital_on a f G U S t\<^sub>0] I \<Longrightarrow> P \<le> (I)\<^sub>e \<Longrightarrow> (I \<and> G)\<^sub>e \<le> Q
  \<Longrightarrow> P \<le> |g_orbital_on a f G U S t\<^sub>0] Q"
  apply(rule_tac b="|g_orbital_on a f G U S t\<^sub>0] I" in order.trans)
   apply (rule_tac I=I in fbox_inv; expr_simp)
  by (subst fbox_g_orbital_on_guard, force)
    (rule fbox_iso, force)

lemmas fbox_diff_inv_rawI = fbox_diff_invI[unfolded clarify_fbox expr_defs]

lemma hoare_diff_inv_on_post_inv: (* generalise and wrap in tactic *)
  assumes "`P \<longrightarrow> Q`" "\<^bold>{Q\<^bold>} {a` = f | G on U S @ t\<^sub>0} \<^bold>{Q\<^bold>}"
  shows "\<^bold>{P\<^bold>} {a` = f | G on U S @ t\<^sub>0} \<^bold>{Q\<^bold>}"
  using assms(2) by (rule hoare_conseq; simp add: assms)

end


theory Bisimulation
  imports Execution
begin

(* Need to expand to all traces *)

locale bisimulation = execution eval
  for eval :: "'a \<Rightarrow> 's rel"

context bisimulation
begin

type_synonym 'b state = "('b \<times> 'b) set"
type_synonym 'b step = "('b \<times> 'b) rel"

definition stable :: "'s state \<Rightarrow> 's step \<Rightarrow> bool" where
  "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"

(* Apply a step to a set of states *)
definition trans :: "'s state \<Rightarrow> 's step \<Rightarrow> 's state" ("_+[_]")
  where "trans P R \<equiv> {t. \<exists>s. s \<in> P \<and> (s, t) \<in> R}"

(* Lift an action to a set of steps *)
definition lift\<^sub>a :: "'a \<Rightarrow> 's step" where
  "lift\<^sub>a \<alpha> \<equiv> {((m\<^sub>1,m\<^sub>2),(m\<^sub>1',m\<^sub>2')). (m\<^sub>1,m\<^sub>1') \<in> eval \<alpha> \<and> (m\<^sub>2,m\<^sub>2') \<in> eval \<alpha>}"

(* Lift a set of states to a set of steps it could perform *)
definition lift\<^sub>P :: "'s state \<Rightarrow> 's step" where
  "lift\<^sub>P P \<equiv> {((m\<^sub>1,m\<^sub>2),(m\<^sub>1',m\<^sub>2')). (m\<^sub>1,m\<^sub>2) \<in> P}"

definition progress :: "'s \<Rightarrow> 's \<Rightarrow> 'a \<Rightarrow> bool" where
  "progress m\<^sub>1 m\<^sub>2 \<alpha> \<equiv> (\<exists>m\<^sub>1'. (m\<^sub>1, m\<^sub>1') \<in> eval \<alpha>) \<longrightarrow> (\<exists>m\<^sub>2'. (m\<^sub>2, m\<^sub>2') \<in> eval \<alpha>)"

definition bisim_act :: "'s state \<Rightarrow> 'a \<Rightarrow> bool" where
  "bisim_act P \<alpha> \<equiv> \<forall>(m\<^sub>1,m\<^sub>2) \<in> P. progress m\<^sub>1 m\<^sub>2 \<alpha> \<and> progress m\<^sub>2 m\<^sub>1 \<alpha>"

inductive rules ::
  "'s step \<Rightarrow> 's step \<Rightarrow> 's state \<Rightarrow> 'a Stmt \<Rightarrow> 's state \<Rightarrow> bool"
  ("_,_ \<turnstile>\<^sub>s _ {_} _" [20, 20, 20, 20] 20)
where
  skip [intro]:     "stable P R \<Longrightarrow> R,G \<turnstile>\<^sub>s P { Skip } P" |
  seq [intro]:      "R,G \<turnstile>\<^sub>s P { c\<^sub>1 } Q \<Longrightarrow> R,G \<turnstile>\<^sub>s Q { c\<^sub>2 } M \<Longrightarrow> R,G \<turnstile>\<^sub>s P { c\<^sub>1 ;; c\<^sub>2 } M" |
  choice [intro]:   "R,G \<turnstile>\<^sub>s P { c\<^sub>1 } Q \<Longrightarrow> R,G \<turnstile>\<^sub>s P { c\<^sub>2 } Q \<Longrightarrow> R,G \<turnstile>\<^sub>s P { c\<^sub>1 \<sqinter> c\<^sub>2 } Q" |
  loop [intro]:     "stable P R \<Longrightarrow> R,G \<turnstile>\<^sub>s P { c } P \<Longrightarrow> R,G \<turnstile>\<^sub>s P { c* } P" |
  act [intro]:      "stable P R \<Longrightarrow> stable Q R \<Longrightarrow> lift\<^sub>P P \<inter> lift\<^sub>a \<alpha> \<subseteq> G \<Longrightarrow> P+[lift\<^sub>a \<alpha>] \<subseteq> Q \<Longrightarrow> bisim_act P \<alpha> \<Longrightarrow>
                      R,G \<turnstile>\<^sub>s P { Basic \<alpha> } Q" |
  rewrite [intro]:  "R,G \<turnstile>\<^sub>s P { c } Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> R' \<subseteq> R \<Longrightarrow> G \<subseteq> G' \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow>
                      R',G' \<turnstile>\<^sub>s P' { c } Q'" |
  parallel [intro]: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1 \<Longrightarrow> R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2 \<Longrightarrow> G\<^sub>2 \<subseteq> R\<^sub>1 ==> G\<^sub>1 \<subseteq> R\<^sub>2 \<Longrightarrow>
                      R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>1 \<inter> P\<^sub>2 { c\<^sub>1 || c\<^sub>2 } Q\<^sub>1 \<inter> Q\<^sub>2"

lemma stableI [intro]:
  assumes "stable P R" "R' \<subseteq> R"
  shows "stable P R'"
  using assms by (auto simp: stable_def)

lemma stable_conj [intro]:
  assumes "stable P R" "stable P' R'"
  shows "stable (P \<inter> P') (R \<inter> R')"
  using assms by (auto simp: stable_def)

lemma lift\<^sub>P_conj [simp]:
  shows "lift\<^sub>P (P \<inter> M) = lift\<^sub>P P \<inter> lift\<^sub>P M"
  by (auto simp: lift\<^sub>P_def)

lemma bisim_act_imp [intro]:
  assumes "bisim_act P \<alpha>" "Q \<subseteq> P"
  shows "bisim_act Q \<alpha>"
  using assms by (auto simp: bisim_act_def)

lemma stable_trans:
  assumes "stable M R"
  shows "M+[R] \<subseteq> M"
  using assms by (auto simp: stable_def trans_def)

lemma trans_conj [intro]:
  assumes "P+[R] \<subseteq> Q" "P'+[R] \<subseteq> Q'"
  shows "(P \<inter> P')+[R] \<subseteq> Q \<inter> Q'"
  using assms by (auto simp: trans_def)

lemma frame_act:
  assumes "stable M G"
  assumes "lift\<^sub>P P \<inter> lift\<^sub>a \<alpha> \<subseteq> G"
  assumes "P+[lift\<^sub>a \<alpha>] \<subseteq> Q"
  shows "(P \<inter> M)+[lift\<^sub>a \<alpha>] \<subseteq> (M \<inter> Q)"
  using assms
  by (auto simp: stable_def lift\<^sub>P_def lift\<^sub>a_def trans_def, blast+)

lemma false:
  shows "R,G \<turnstile>\<^sub>s {} { c } {}"
proof (induct c arbitrary: R G)
  case Skip
  hence "stable {} R" by (auto simp: stable_def)
  thus ?case by auto
next
  case (Basic x)
  then show ?case
  proof (intro act)
    show "stable {} R" by (auto simp: stable_def)
    show "stable {} R" by (auto simp: stable_def)
    show "lift\<^sub>P {} \<inter> lift\<^sub>a x \<subseteq> G" by (auto simp: lift\<^sub>P_def)
    show "{}+[lift\<^sub>a x] \<subseteq> {}" by (auto simp: trans_def)
    show "bisim_act {} x" by (auto simp: bisim_act_def)
  qed
next
  case (Seq c1 c2)
  then show ?case by blast
next
  case (Choice c1 c2)
  then show ?case by auto
next
  case (Loop c)
  hence "stable {} R" by (auto simp: stable_def)
  then show ?case using Loop by auto
next
  case (Parallel c1 c2)
  hence "(G \<union> R,R \<inter> G \<turnstile>\<^sub>s {} {c1} {}) \<and> (R,R \<inter> G \<union> G \<inter> G \<turnstile>\<^sub>s {} {c2} {})"
    by (meson)
  then show ?case by auto
qed

subsection \<open>Elimination Rules\<close>

lemma skipE [elim]:
  assumes "R,G \<turnstile>\<^sub>s P {Skip} Q"
  obtains M where "stable M R" "P \<subseteq> M" "M \<subseteq> Q"
  using assms
  by (induct R G P "Skip :: 'a Stmt" Q rule: rules.induct) blast+

lemma seqE [elim]:
  assumes "R,G \<turnstile>\<^sub>s P {c\<^sub>1 ;; c\<^sub>2} Q"
  obtains M where "R,G \<turnstile>\<^sub>s P {c\<^sub>1} M" "R,G \<turnstile>\<^sub>s M {c\<^sub>2} Q"
  using assms by (induct R G P "c\<^sub>1 ;; c\<^sub>2" Q arbitrary: c\<^sub>1 c\<^sub>2) blast+

lemma choiceE [elim]:
  assumes "R,G \<turnstile>\<^sub>s P {c\<^sub>1 \<sqinter> c\<^sub>2} Q"
  obtains "R,G \<turnstile>\<^sub>s P {c\<^sub>1} Q" "R,G \<turnstile>\<^sub>s P {c\<^sub>2} Q"
  using assms by (induct R G P "c\<^sub>1 \<sqinter> c\<^sub>2" Q arbitrary: c\<^sub>1 c\<^sub>2) auto

lemma loopE [elim]:
  assumes "R,G \<turnstile>\<^sub>s P { c* } Q"
  obtains I where "P \<subseteq> I" "R,G \<turnstile>\<^sub>s I { c } I" "I \<subseteq> Q" "stable I R"
  using assms
proof (induct R G P "c*" Q arbitrary: c)
  case (loop R G P c)
  then show ?case by blast
next
  case (rewrite R G P Q P' R' G' Q')
  then show ?case by (smt order_refl rules.rewrite stableI subset_trans)
qed

lemma actE [elim]:
  assumes "R,G \<turnstile>\<^sub>s P { Basic \<alpha> } Q"
  obtains P' Q' where "P \<subseteq> P'" "Q' \<subseteq> Q" "stable P' R" "stable Q' R" "lift\<^sub>P P' \<inter> lift\<^sub>a \<alpha> \<subseteq> G" "P'+[lift\<^sub>a \<alpha>] \<subseteq> Q'" "bisim_act P' \<alpha>"
  using assms
proof (induct R G P "Basic \<alpha>" Q)
  case (act P R Q G)
  then show ?case by blast
next
  case (rewrite R G P Q P' R' G' Q')
  then show ?case by (meson stableI subset_trans)
qed

lemma parallelE [elim]:
  assumes "R,G \<turnstile>\<^sub>s P { c\<^sub>1 || c\<^sub>2 } Q"
  obtains R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where  "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2"
    "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
  using assms
proof (induct R G P "c\<^sub>1 || c\<^sub>2" Q)
  case (rewrite R G P Q P' R' G' Q')
  show ?case
  proof (rule rewrite(2), goal_cases)
    case (1 R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2)
    then show ?case using rewrite(3,4,5,6) rewrite(7)[OF 1(1,2)] by blast
  qed
next
  case (parallel R\<^sub>1 G\<^sub>2 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 P\<^sub>2 Q\<^sub>2)
  then show ?case by (smt Int_lower2 inf_mono inf_sup_absorb order_refl sup_commute)
qed

lemma parallelI [intro]:
  assumes "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2"
    "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
  shows "R,G \<turnstile>\<^sub>s P { c\<^sub>1 || c\<^sub>2 } Q"
  using assms by (meson parallel rules.rewrite)

subsection \<open>Introduction Rules\<close>

lemma frameI [intro]:
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  assumes "stable M R\<^sub>2" "G \<subseteq> R\<^sub>2"
  shows "R \<inter> R\<^sub>2,G \<turnstile>\<^sub>s P \<inter> M {c} Q \<inter> M"
  using assms
proof (induct arbitrary: M)
  case (skip P R G)
  then show ?case by blast
next
  case (act P R Q \<alpha> G)
  show ?case
  proof (rule rules.act)
    have "stable M G"
      using act by blast
    thus "(P \<inter> M)+[lift\<^sub>a \<alpha>] \<subseteq> Q \<inter> M"
      using act(3,4) frame_act by auto
  qed (insert act, auto)
next
  case (parallel R\<^sub>1 G\<^sub>2 G\<^sub>1 P\<^sub>1 c\<^sub>1 Q\<^sub>1 R\<^sub>2 P\<^sub>2 c\<^sub>2 Q\<^sub>2)
  then show ?case
    by (metis (no_types, lifting) inf_assoc rules.parallel sup.absorb_iff1 sup.bounded_iff sup_inf_distrib2)
qed blast+

lemma rwI [intro]:
  assumes "c \<leadsto> c'"
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  shows "R,G \<turnstile>\<^sub>s P {c'} Q"
  using assms
proof (induct arbitrary: R G P Q)
  case (par1 c\<^sub>1 c\<^sub>1' c\<^sub>2)
  then obtain R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where a: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2"
      "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
    by auto
  hence "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1' } Q\<^sub>1" using par1 by auto
  then show ?case using a by blast
next
  case (par2 c\<^sub>2 c\<^sub>2' c\<^sub>1)
  then obtain R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where a: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2"
      "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
    by auto
  hence "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2' } Q\<^sub>2" using par2 by auto
  then show ?case using a by blast
next
  case (parE1 c)
  then obtain R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where a: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { Skip } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c } Q\<^sub>2"
      "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
    by auto
  then obtain M where "stable M R\<^sub>1" "P\<^sub>1 \<subseteq> M" "M \<subseteq> Q\<^sub>1" by auto
  then show ?case using a by blast
next
  case (parE2 c)
  then obtain R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where a: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { Skip } Q\<^sub>2"
      "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
    by auto
  then obtain M where "stable M R\<^sub>2" "P\<^sub>2 \<subseteq> M" "M \<subseteq> Q\<^sub>2" by auto
  then show ?case using a by blast
next
  case (loop c n)
  then obtain I where s: "P \<subseteq> I" "R,G \<turnstile>\<^sub>s I {c} I" "I \<subseteq> Q" "stable I R" by auto
  hence "R,G \<turnstile>\<^sub>s I {unroll n c} I" by (induct n) auto
  then show ?case using s by blast
qed fast+

lemma multi_rwI [intro]:
  assumes "c \<mapsto>[]\<^sup>* c'"
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  shows "R,G \<turnstile>\<^sub>s P {c'} Q"
  using assms by (induct c "[] :: 'a Trace" c') auto

lemma precontext_stable:
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  obtains P' where "P \<subseteq> P'" "stable P' R" "R,G \<turnstile>\<^sub>s P' {c} Q"
  using assms
proof (induct)
  case (skip P R G)
  then show ?case by blast
next
  case (seq R G P c\<^sub>1 Q c\<^sub>2 M)
  then show ?case by blast
next
  case (choice R G P c\<^sub>1 Q c\<^sub>2)
  show ?case
  proof (rule choice(2), rule choice(4),  goal_cases)
    case (1 P' P'')
    have a: "stable (P' \<inter> P'') R" using 1 by auto
    have b: "P \<subseteq> P' \<inter> P''" using 1 by auto
    then show ?case using 1 choice(5)[OF b a] by blast
  qed
next
  case (loop P R G c)
  then show ?case by auto
next
  case (act P R Q \<alpha> G)
  then show ?case by auto
next
  case (rewrite R G P c Q P' R' G' Q')
  then show ?case by blast
next
  case (parallel R\<^sub>1 G\<^sub>1 P\<^sub>1 c\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 c\<^sub>2 Q\<^sub>2)
  show ?case
  proof (rule parallel(2), rule parallel(4), goal_cases)
    case (1 P' P'')
    then show ?case using parallel(7)[of "P' \<inter> P''"] parallel(5,6) by blast
  qed
qed

lemma progI [intro]:
  assumes "c \<mapsto>\<^sub>\<alpha> c'"
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  shows "R,G \<turnstile>\<^sub>s P {Basic \<alpha> ;; c'} Q"
  using assms
proof (induct arbitrary: R G P Q)
  case (act \<alpha>)
  then obtain P' Q' where a: "P \<subseteq> P'" "Q' \<subseteq> Q" "stable P' R" "stable Q' R"
      "lift\<^sub>P P' \<inter> lift\<^sub>a \<alpha> \<subseteq> G" "P'+[lift\<^sub>a \<alpha>] \<subseteq> Q'" "bisim_act P' \<alpha>"
    by auto
  hence "R,G \<turnstile>\<^sub>s Q' {Skip} Q" by auto
  moreover have "R,G \<turnstile>\<^sub>s P {Basic \<alpha>} Q'" using a by blast
  ultimately show ?case by auto
next
  case (seq c\<^sub>1 \<alpha> c\<^sub>1' c\<^sub>2)
  then obtain M where a: "R,G \<turnstile>\<^sub>s P {c\<^sub>1} M" "R,G \<turnstile>\<^sub>s M {c\<^sub>2} Q"
    by auto
  hence "R,G \<turnstile>\<^sub>s P {Basic \<alpha> ;; c\<^sub>1'} M" using seq by auto
  then show ?case using a(2) by auto
next
  case (par1 c\<^sub>1 \<alpha> c\<^sub>1' c\<^sub>2)
  then obtain R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where a: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2"
      "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
    by auto
  then obtain M where b: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 {Basic \<alpha>} M" "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s M {c\<^sub>1'} Q\<^sub>1" using par1 by force
  obtain P' where c: "P\<^sub>2 \<subseteq> P'" "stable P' R\<^sub>2" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P' {c\<^sub>2} Q\<^sub>2"
    using a(2) precontext_stable by metis
  have "R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>1 \<inter> P\<^sub>2 {Basic \<alpha>} M \<inter> P'"
    using frameI[OF b(1) c(2) a(7)] c(1) by blast
  moreover have "R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile>\<^sub>s M \<inter> P' {c\<^sub>1' || c\<^sub>2} Q\<^sub>1 \<inter> Q\<^sub>2"
    using b(2) c(3) a(7,8) by blast
  ultimately show ?case using a(3,4,5,6) by blast
next
  case (par2 c\<^sub>2 \<alpha> c\<^sub>2' c\<^sub>1)
  then obtain R\<^sub>1 G\<^sub>1 P\<^sub>1 Q\<^sub>1 R\<^sub>2 G\<^sub>2 P\<^sub>2 Q\<^sub>2 where a: "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P\<^sub>1 { c\<^sub>1 } Q\<^sub>1" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 { c\<^sub>2 } Q\<^sub>2"
      "P \<subseteq> P\<^sub>1 \<inter> P\<^sub>2" "R \<subseteq> R\<^sub>1 \<inter> R\<^sub>2" "G\<^sub>1 \<union> G\<^sub>2 \<subseteq> G" "Q\<^sub>1 \<inter> Q\<^sub>2 \<subseteq> Q" "G\<^sub>1 \<subseteq> R\<^sub>2" "G\<^sub>2 \<subseteq> R\<^sub>1"
    by auto
  then obtain M where b: "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>2 {Basic \<alpha>} M" "R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>s M {c\<^sub>2'} Q\<^sub>2" using par2 by force
  obtain P' where c: "P\<^sub>1 \<subseteq> P'" "stable P' R\<^sub>1" "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>s P' {c\<^sub>1} Q\<^sub>1"
    using a(1) precontext_stable by metis
  have "R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile>\<^sub>s P\<^sub>1 \<inter> P\<^sub>2 {Basic \<alpha>} M \<inter> P'"
    using frameI[OF b(1) c(2) a(8)] c(1) by blast
  moreover have "R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile>\<^sub>s M \<inter> P' {c\<^sub>1 || c\<^sub>2'} Q\<^sub>1 \<inter> Q\<^sub>2"
    using b(2) c(3) a(7,8) by blast
  ultimately show ?case using a(3,4,5,6) by blast
qed

lemma multi_progI [intro]:
  assumes "c \<mapsto>[\<alpha>]\<^sup>* c'"
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  shows "R,G \<turnstile>\<^sub>s P {Basic \<alpha> ;; c'} Q"
  using assms
proof (induct c "[\<alpha>]" c' arbitrary: R G P Q)
  case (rewrite c\<^sub>1 c\<^sub>2 c\<^sub>3)
  then show ?case by blast
next
  case (prepend c\<^sub>1 c\<^sub>2 c\<^sub>3)
  then show ?case by (meson multi_rwI seqE progI seq)
qed

fun trace_prog
  where "trace_prog [] = Skip" | "trace_prog (\<alpha>#t) = Basic \<alpha> ;; trace_prog t"

lemma trace_progI:
  assumes "c \<mapsto>t\<^sup>* c'"
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  shows "R,G \<turnstile>\<^sub>s P {trace_prog t ;; c'} Q"
  using assms
proof (induct c t c' arbitrary: R G P Q)
  case (lift c)
  then obtain M where "R,G \<turnstile>\<^sub>s M { c  } Q" "P \<subseteq> M" "stable M R"
    by (meson precontext_stable)
  then show ?case by (smt rewrite seq skip trace_prog.simps(1) subset_refl)
next
  case (rewrite c\<^sub>1 c\<^sub>2 t c\<^sub>3)
  then show ?case by blast
next
  case (prepend c\<^sub>1 \<alpha> c\<^sub>2 t c\<^sub>3)
  hence "R,G \<turnstile>\<^sub>s P {Basic \<alpha> ;; c\<^sub>2} Q" using multi_progI by auto
  then obtain M where c: "R,G \<turnstile>\<^sub>s P {Basic \<alpha>} M" "R,G \<turnstile>\<^sub>s M {c\<^sub>2} Q" by auto
  hence "R,G \<turnstile>\<^sub>s M {trace_prog t ;; c\<^sub>3} Q" using prepend by auto
  then show ?case using c(1) by (smt trace_prog.simps(2) local.seqE rules.seq)
qed

lemma bisim_act:
  assumes "(m\<^sub>1,m\<^sub>1') \<in> eval \<alpha>"
  assumes "(m\<^sub>1,m\<^sub>2) \<in> P"
  assumes "P+[lift\<^sub>a \<alpha>] \<subseteq> Q"
  assumes "bisim_act P \<alpha>"
  obtains m\<^sub>2' where "(m\<^sub>2, m\<^sub>2') \<in> eval \<alpha>" "(m\<^sub>1',m\<^sub>2') \<in> Q"
proof -
  have "progress m\<^sub>1 m\<^sub>2 \<alpha> \<and> progress m\<^sub>2 m\<^sub>1 \<alpha>"
    using assms(2,4) by (auto simp: bisim_act_def)
  then obtain m\<^sub>2' where "(m\<^sub>2, m\<^sub>2') \<in> eval \<alpha>"
    using assms(1) by (auto simp: progress_def)
  moreover have "(m\<^sub>1',m\<^sub>2') \<in> Q"
    using calculation assms(1,2,3) by (auto simp: lift\<^sub>a_def trans_def)
  ultimately show ?thesis using that by blast
qed

lemma info_type_progE:
  assumes "c \<mapsto>[\<alpha>]\<^sup>* c'"
  assumes "R,G \<turnstile>\<^sub>s P {c} Q"
  obtains M where "lift\<^sub>P P \<inter> lift\<^sub>a \<alpha> \<subseteq> G" "P+[lift\<^sub>a \<alpha>] \<subseteq> M" "bisim_act P \<alpha>" "R,G \<turnstile>\<^sub>s M {c'} Q"
proof -
  have "R,G \<turnstile>\<^sub>s P {Basic \<alpha> ;; c'} Q" using assms multi_progI by auto
  then obtain M where c: "R,G \<turnstile>\<^sub>s P {Basic \<alpha>} M" "R,G \<turnstile>\<^sub>s M {c'} Q" by auto
  then obtain P' M' where b: "P \<subseteq> P'" "M' \<subseteq> M" "stable P' R" "stable M' R" "lift\<^sub>P P' \<inter> lift\<^sub>a \<alpha> \<subseteq> G"
    "P'+[lift\<^sub>a \<alpha>] \<subseteq> M'" "bisim_act P' \<alpha>"
    by auto
  have "lift\<^sub>P P \<inter> lift\<^sub>a \<alpha> \<subseteq> G" using b unfolding lift\<^sub>P_def lift\<^sub>a_def by auto
  moreover have "P+[lift\<^sub>a \<alpha>] \<subseteq> M" using b unfolding lift\<^sub>P_def lift\<^sub>a_def trans_def by blast
  moreover have "bisim_act P \<alpha>" using b by auto
  ultimately show ?thesis using that c by auto
qed

lemma bisim:
  assumes "\<langle>c,m\<^sub>1\<rangle> \<rightarrow>t\<^sup>* \<langle>c\<^sub>1,m\<^sub>1'\<rangle>"
  assumes "R,G \<turnstile>\<^sub>s P { c } Q"
  assumes "(m\<^sub>1,m\<^sub>2) \<in> P"
  assumes "(m\<^sub>1,m\<^sub>2) \<in> \<L>"
  assumes "stable \<L> G"
  obtains m\<^sub>2' c\<^sub>2 where "\<langle>c,m\<^sub>2\<rangle> \<rightarrow>t\<^sup>* \<langle>c\<^sub>2,m\<^sub>2'\<rangle>" "(m\<^sub>1',m\<^sub>2') \<in> \<L>"
  using assms(1) unfolding ev_def
proof
  assume "trace_mem m\<^sub>1 t m\<^sub>1'" "c \<mapsto>t\<^sup>* c\<^sub>1"
  hence "\<exists>m\<^sub>2' c\<^sub>2. \<langle>c,m\<^sub>2\<rangle> \<rightarrow>t\<^sup>* \<langle>c\<^sub>2,m\<^sub>2'\<rangle> \<and> (m\<^sub>1',m\<^sub>2') \<in> \<L>"
    using assms(2,3,4)
  proof (induct m\<^sub>1 t m\<^sub>1' arbitrary: P m\<^sub>2 c rule: trace_mem.induct)
    case (1 m)
    then show ?case by (meson ev_def trace_mem.intros(1))
  next
    case (2 m'' m \<alpha> t m')
    then obtain c' where f1: "c \<mapsto>[\<alpha>]\<^sup>* c'" "c' \<mapsto>t\<^sup>* c\<^sub>1" by auto
    obtain M where f2: "lift\<^sub>P P \<inter> lift\<^sub>a \<alpha> \<subseteq> G" "P+[lift\<^sub>a \<alpha>] \<subseteq> M" "bisim_act P \<alpha>" "R,G \<turnstile>\<^sub>s M {c'} Q"
      using info_type_progE[OF f1(1) 2(5)] by metis
    obtain m\<^sub>2' where f3: "(m\<^sub>2, m\<^sub>2') \<in> eval \<alpha>" "(m, m\<^sub>2') \<in> M"
      using f2 bisim_act[OF 2(1,6)] by blast
    have "((m'', m\<^sub>2), (m, m\<^sub>2')) \<in> G" using "2.hyps"(1) "2.prems"(3) f2(1) f3(1)
      unfolding lift\<^sub>P_def lift\<^sub>a_def by auto
    hence "(m,m\<^sub>2') \<in> \<L>" using 2(7) assms(5) by (meson stable_def)
    hence "\<exists>m\<^sub>2'' c\<^sub>2. \<langle>c',m\<^sub>2'\<rangle> \<rightarrow>t\<^sup>* \<langle>c\<^sub>2,m\<^sub>2''\<rangle> \<and> (m',m\<^sub>2'') \<in> \<L>"
      using 2(3)[OF f1(2) f2(4) f3(2)] by auto
    then show ?case using f3(1) 2(4) by (meson ev_def trace_mem.intros(2))
  qed
  thus ?thesis using that by auto
qed

lemma secure:
  assumes "\<langle>c,m\<^sub>1\<rangle> \<rightarrow>t\<^sup>* \<langle>c\<^sub>1,m\<^sub>1'\<rangle>"
  assumes "R,G \<turnstile>\<^sub>s P { c } Q"
  assumes "(m\<^sub>1,m\<^sub>2) \<in> P"
  assumes "(m\<^sub>1,m\<^sub>2) \<in> \<L>"
  assumes "stable \<L> G"
  assumes "\<langle>c,m\<^sub>2\<rangle> \<rightarrow>t\<^sup>* \<langle>c\<^sub>2,m\<^sub>2'\<rangle>"
  shows "(m\<^sub>1',m\<^sub>2') \<in> \<L>"
  using bisim[OF assms(1,2,3,4,5)] assms(6)
  using ev_det by metis

end

end