(* VDM to Isabelle Translation @2022-03-01T13:27:00.763152Z
   Copyright 2021, Leo Freitas, leo.freitas@newcastle.ac.uk

in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 11:7
files = [./src/test/resources/Examples/CMSL/CM.vdmsl]
*)
theory CM_PO
imports CM
begin

\<comment>\<open>VDM source: Angle = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 11:7\<close>
theorem Angle_TOTAL_PO1:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (num :: VDMNat)  . ((((inv_VDMNat num))) \<longrightarrow> isTest ((inv_Angle num)) (inv_bool))))"
	by simp

\<comment>\<open>VDM source: Angle = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 10:3\<close>
theorem Angle_INV_SATISFIABILITY_PO2:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<exists> (num :: VDMNat)  . ((((inv_VDMNat num))) \<longrightarrow> (num \<le> (360::VDMNat1)))))"
	by blast

\<comment>\<open>VDM source: responseDB = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 59:5\<close>
theorem responseDB_MAP_SEQ_OF_COMPATIBLE_PO3:
	"((\<forall> m1 \<in> {[MissileType.U_MissileA \<mapsto>[(FlareType.U_FlareOneA  , (900::VDMNat1)) , (FlareType.U_FlareTwoA  , (500::VDMNat1)) , (FlareType.U_DoNothingA  , (100::VDMNat1)) , (FlareType.U_FlareOneA  , (500::VDMNat1))]] , [MissileType.U_MissileB \<mapsto>[(FlareType.U_FlareTwoB  , (500::VDMNat1)) , (FlareType.U_FlareTwoB  , (700::VDMNat1))]] , [MissileType.U_MissileC \<mapsto>[(FlareType.U_FlareOneC  , (400::VDMNat1)) , (FlareType.U_DoNothingC  , (100::VDMNat1)) , (FlareType.U_FlareTwoC  , (400::VDMNat1)) , (FlareType.U_FlareOneC  , (500::VDMNat1))]]}  . (\<forall> m2 \<in> {[MissileType.U_MissileA \<mapsto>[(FlareType.U_FlareOneA  , (900::VDMNat1)) , (FlareType.U_FlareTwoA  , (500::VDMNat1)) , (FlareType.U_DoNothingA  , (100::VDMNat1)) , (FlareType.U_FlareOneA  , (500::VDMNat1))]] , [MissileType.U_MissileB \<mapsto>[(FlareType.U_FlareTwoB  , (500::VDMNat1)) , (FlareType.U_FlareTwoB  , (700::VDMNat1))]] , [MissileType.U_MissileC \<mapsto>[(FlareType.U_FlareOneC  , (400::VDMNat1)) , (FlareType.U_DoNothingC  , (100::VDMNat1)) , (FlareType.U_FlareTwoC  , (400::VDMNat1)) , (FlareType.U_FlareOneC  , (500::VDMNat1))]]}  . (\<forall> d3 \<in> (dom m1)  . (\<forall> d4 \<in> (dom m2)  . ((d3 = d4) \<longrightarrow> ((m1 d3) = (m2 d4))))))))"
	by auto

\<comment>\<open>VDM source: missilePriority = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 72:25\<close>
theorem missilePriority_MAP_SEQ_OF_COMPATIBLE_PO4:
	"((\<forall> m1 \<in> {[MissileType.U_MissileA \<mapsto>(1::VDMNat1)] , [MissileType.U_MissileB \<mapsto>(2::VDMNat1)] , [MissileType.U_MissileC \<mapsto>(3::VDMNat1)] , [MissileType.U_None \<mapsto>(0::VDMNat)]}  . (\<forall> m2 \<in> {[MissileType.U_MissileA \<mapsto>(1::VDMNat1)] , [MissileType.U_MissileB \<mapsto>(2::VDMNat1)] , [MissileType.U_MissileC \<mapsto>(3::VDMNat1)] , [MissileType.U_None \<mapsto>(0::VDMNat)]}  . (\<forall> d3 \<in> (dom m1)  . (\<forall> d4 \<in> (dom m2)  . ((d3 = d4) \<longrightarrow> ((m1 d3) = (m2 d4))))))))"
	by auto

\<comment>\<open>VDM source: testval1 = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 79:30\<close>
theorem testval1_SUB_TYPE_PO5:
	"((((inv_Angle (88::VDMNat1)) \<and> isTest ((88::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (70::VDMNat1)) \<and> isTest ((70::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (222::VDMNat1)) \<and> isTest ((222::VDMNat1)) (inv_VDMNat)) \<and> ((inv_Angle (44::VDMNat1)) \<and> isTest ((44::VDMNat1)) (inv_VDMNat))))))"
	unfolding inv_Angle_defs by simp

\<comment>\<open>VDM source: testval2 = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 84:30\<close>
theorem testval2_SUB_TYPE_PO6:
	"((((inv_Angle (188::VDMNat1)) \<and> isTest ((188::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (70::VDMNat1)) \<and> isTest ((70::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (2::VDMNat1)) \<and> isTest ((2::VDMNat1)) (inv_VDMNat)) \<and> ((inv_Angle (44::VDMNat1)) \<and> isTest ((44::VDMNat1)) (inv_VDMNat))))))"

	unfolding inv_Angle_defs by simp

\<comment>\<open>VDM source: testval3 = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 89:30\<close>
theorem testval3_SUB_TYPE_PO7:
	"((((inv_Angle (288::VDMNat1)) \<and> isTest ((288::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (170::VDMNat1)) \<and> isTest ((170::VDMNat1)) (inv_VDMNat)) \<and> (((inv_Angle (222::VDMNat1)) \<and> isTest ((222::VDMNat1)) (inv_VDMNat)) \<and> ((inv_Angle (44::VDMNat1)) \<and> isTest ((44::VDMNat1)) (inv_VDMNat))))))"

	unfolding inv_Angle_defs by simp

	(*
	\<comment>\<open>VDM proof obligation `RelativeToAbsoluteTimes_measure_RelativeToAbsoluteTimes` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; measure_RelativeToAbsoluteTimes = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 130:9\<close>
theorem RelativeToAbsoluteTimes_measure_RelativeToAbsoluteTimes_TOTAL_PO8:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> isTest ((measure_RelativeToAbsoluteTimes ts)) (inv_VDMNat))))"

	oops

	*)

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; f, t = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 123:26\<close>
theorem RelativeToAbsoluteTimes_f_t_NON_EMPTY_SEQ_PO9:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> ((\<not> (ts = [])) \<longrightarrow> (ts \<noteq> [])))))"
	by meson

	(*
	\<comment>\<open>VDM proof obligation `RelativeToAbsoluteTimes_ns` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; ns = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 118:1\<close>
theorem RelativeToAbsoluteTimes_ns_RECURSIVE_PO10:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> ((\<not> (ts = [])) \<longrightarrow> ((measure_RelativeToAbsoluteTimes ts) > (measure_RelativeToAbsoluteTimes (tl ts)))))))"

	oops

	*)

\<comment>\<open>VDM source: RelativeToAbsoluteTimes; ns = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 125:44\<close>
theorem RelativeToAbsoluteTimes_ns_NON_EMPTY_SEQ_PO11:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (ts :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response ts))) \<longrightarrow> ((\<not> (ts = [])) \<longrightarrow> (ts \<noteq> [])))))"
	by blast

\<comment>\<open>VDM source: OutputAtTimeZero; firstFlare = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 136:32\<close>
theorem OutputAtTimeZero_firstFlare_NON_EMPTY_SEQ_PO12:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(absTimes \<noteq> [])
		 else
			undefined
		)
		))))"
	nitpick
	oops

lemma l_CM_AbsTimes_inds: "i \<in> {2..len s} \<Longrightarrow> i - 1 \<in> inds s"
  by (simp add: l_inds_upto)

lemma l_CM_AbsTimes_post: "inv_VDMSeq' inv_Response response \<Longrightarrow> inv_VDMSeq' (\<lambda>(dummy1of2, y). inv_VDMNat y) (RelativeToAbsoluteTimes response)"
  apply (induct response)
   apply (simp add: inv_VDMSeq'_defs)
  thm RelativeToAbsoluteTimes.simps
  oops

lemma l_CM_AbsTimes_post_l0: "inv_VDMSeq' inv_Response response \<Longrightarrow> response \<noteq> [] \<Longrightarrow>
  RelativeToAbsoluteTimes response = [hd response] @ [ (fst n, snd n + snd (hd response)) . n \<leftarrow> tl response ]"
\<comment> \<open>@LF hard lemma about the inner property of \<^term>\<open>RelativeToAbsoluteTimes\<close>\<close>
  sorry

lemma l_CM_AbsTimes_post_l1: "inv_VDMSeq' inv_Response response \<Longrightarrow> response \<noteq> [] \<Longrightarrow> inv_VDMSeq' (\<lambda>(dummy1of2, y). inv_VDMNat y) (RelativeToAbsoluteTimes response)"
  apply (simp add: l_CM_AbsTimes_post_l0[of response] del: RelativeToAbsoluteTimes.simps)
  apply (simp add: inv_VDMSeq'_defs list_all_def inv_Response_defs)
  apply safe
   apply (metis hd_in_set snd_conv)
  by (meson add_increasing list.set_sel(1) list.set_sel(2))

lemma l_CM_AbsTimes_post: "inv_VDMSeq' inv_Response response \<Longrightarrow> inv_VDMSeq' (\<lambda>(dummy1of2, y). inv_VDMNat y) (RelativeToAbsoluteTimes response)"
  apply (induct response)
   apply (simp add: inv_VDMSeq'_defs)
  apply (rule l_CM_AbsTimes_post_l1)
  by simp_all

lemma l_CM_AbsTimes_post': "inv_VDMSeq' inv_Response response \<Longrightarrow>
       inv_VDMNat (snd (hd (RelativeToAbsoluteTimes response)))"
  nitpick
  oops

\<comment>\<open>VDM source: OutputAtTimeZero; t = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 138:24\<close>
theorem OutputAtTimeZero_t_SEQ_APPLY_PO13:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		((i - (1::VDMNat1)) \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	apply (safe, simp del: RelativeToAbsoluteTimes.simps add: Let_def, safe)
	  apply (meson l_CM_AbsTimes_inds)
  using l_CM_AbsTimes_post apply blast
  nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero; f = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 139:24\<close>
theorem OutputAtTimeZero_f_SEQ_APPLY_PO14:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		(i \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero'; firstFlare = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 149:32\<close>
theorem OutputAtTimeZero'_firstFlare_NON_EMPTY_SEQ_PO15:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(absTimes \<noteq> [])
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero' = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 151:13\<close>
theorem OutputAtTimeZero'_SEQ_APPLY_PO16:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		(i \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: OutputAtTimeZero' = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 151:29\<close>
theorem OutputAtTimeZero'_SEQ_APPLY_PO17:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (response :: Response VDMSeq)  . ((((inv_VDMSeq' inv_Response response))) \<longrightarrow> (
		let
(absTimes::(FlareType \<times> VDMNat) VDMSeq) = (RelativeToAbsoluteTimes response)
		in

			(if ((inv_VDMSeq'
		(\<lambda> (dummy1of2, dummy2of2) . (((inv_True dummy1of2)))\<and>
		 (inv_VDMNat dummy2of2)
		) absTimes)) then
			(
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::(FlareType \<times> VDMNat)) = (hd absTimes)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let firstFlare = (fst dummy0); dummy0_ignore = (snd dummy0) in
			(if (
		((((inv_True (fst dummy0))))\<and>
		 (inv_VDMNat (snd dummy0))
		)) then
			(\<forall>
		i \<in> {(2::VDMNat1)..(len absTimes)}

		.
		((i - (1::VDMNat1)) \<in> (inds absTimes)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		))))"
	nitpick
	oops

\<comment>\<open>VDM source: InterruptPlan = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 165:41\<close>
theorem InterruptPlan_MAP_APPLY_PO18:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (curTime :: VDMNat)   (expOutput :: Output)   (plan :: Plan)   (magid :: MagId)  . ((((inv_VDMNat curTime)))  \<and>  (((inv_Output expOutput)))  \<and>  (((inv_Plan plan)))  \<and>  (((inv_MagId magid))) \<longrightarrow> ((magid \<in> (dom expOutput)) \<longrightarrow> (magid \<in> (dom expOutput))))))"

	by blast

\<comment>\<open>VDM source: InterruptPlan = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 164:3\<close>
theorem InterruptPlan_MAP_COMPATIBLE_PO19:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (curTime :: VDMNat)   (expOutput :: Output)   (plan :: Plan)   (magid :: MagId)  . ((((inv_VDMNat curTime)))  \<and>  (((inv_Output expOutput)))  \<and>  (((inv_Plan plan)))  \<and>  (((inv_MagId magid))) \<longrightarrow> (\<forall> ldom1 \<in> (dom [magid\<mapsto>((
		if ((magid \<in> (dom expOutput))) then
		((LeavePrefixUnchanged ((the(expOutput magid)))  curTime))
		else
		([])) @ (MakeOutputFromPlan curTime  plan))])  . (\<forall> rdom2 \<in> (dom ({magid} -\<triangleleft> expOutput))  . ((ldom1 = rdom2) \<longrightarrow> (((the([magid\<mapsto>((
		if ((magid \<in> (dom expOutput))) then
		((LeavePrefixUnchanged ((the(expOutput magid)))  curTime))
		else
		([])) @ (MakeOutputFromPlan curTime  plan))] ldom1))) = ((the(({magid} -\<triangleleft> expOutput) rdom2))))))))))"
	by (simp add: l_dom_dom_ar)

	(*
	\<comment>\<open>VDM proof obligation `CM_measure_CM` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: CM; measure_CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 197:9\<close>
theorem CM_measure_CM_TOTAL_PO20:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> isTest ((measure_CM missileInputs  outputSoFar  lastMissile  curTime)) (inv_VDMNat))))"

	oops

	*)

\<comment>\<open>VDM source: CM; curMis, angle = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 177:35\<close>
theorem CM_curMis_angle_NON_EMPTY_SEQ_PO21:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (missileInputs \<noteq> [])))))"
	by meson

lemma l_CM_MAP_APPLY_l1: "list_all inv_True a"
  using inv_SeqElems_def l_invSeqElems_inv_True_True by blast

lemma l_CM_MAP_APPLY_l2: "inv_VDMToken' (inv_VDMSeq' inv_VDMChar) t"
  unfolding inv_VDMToken'_def inv_VDMSeq'_defs inv_VDMChar_def
  by (metis VDMToken.case VDMToken.exhaust l_CM_MAP_APPLY_l1)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 185:14\<close>
theorem CM_MAP_APPLY_PO22:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (curMis \<in> (dom missilePriority))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	apply (simp add: Let_def, safe)
	  apply (meson MissileType.exhaust)
	unfolding inv_MissileInputs_defs inv_VDMSeq'_def list_all_def apply simp
  apply (erule_tac x="(hd missileInputs)" in ballE)
   apply safe
  apply force+
  using inv_MagId_defs Angle2MagId_def l_CM_MAP_APPLY_l2 by simp

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 186:14\<close>
theorem CM_MAP_APPLY_PO23:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (((the((the(lastMissile magid))))) \<in> (dom missilePriority))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	by (smt (z3) CM_MAP_APPLY_PO22 MissileType.exhaust domIff fun_upd_same l_inmapupd_dom option.distinct(1))

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 186:30\<close>
theorem CM_SUB_TYPE_PO24:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (isTest (((the((the(lastMissile magid)))))) (inv_True) \<or> (isTest (((the((the(lastMissile magid)))))) (inv_True) \<or> (isTest (((the((the(lastMissile magid)))))) (inv_True) \<or> isTest (((the((the(lastMissile magid)))))) (inv_True))))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	by (metis CM_MAP_APPLY_PO22 inv_True_def isTest_def)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 186:30\<close>
theorem CM_MAP_APPLY_PO25:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> (magid \<notin> (dom lastMissile))) \<longrightarrow> ((magid \<in> (dom lastMissile)) \<longrightarrow> (magid \<in> (dom lastMissile))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	by (meson CM_MAP_APPLY_PO22)

\<comment>\<open>VDM source: CM; newOutput = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 189:36\<close>
theorem CM_newOutput_MAP_APPLY_PO26:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			(((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid))))))))))) \<longrightarrow> (curMis \<in> (dom responseDB)))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"

	apply (simp add: Let_def, safe)
  \<comment> \<open>@LF clear consequence of multiple let-defs! Safe = 41 goals\<close>
                      apply (meson CM_MAP_APPLY_PO22)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
  apply (rule_tac x="(Some U_MissileA)" in exI)
  defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
  apply (rule_tac x="(Some U_MissileC)" in exI)
  defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
  apply (rule_tac x="(Some U_None)" in exI)
                      defer
                      apply (meson CM_MAP_APPLY_PO25)
  using inv_MagId_def l_CM_MAP_APPLY_l2 apply blast
                      apply (meson MissileType.exhaust)+
  defer
     apply (rule_tac x="(Some U_MissileB)" in exI)
  \<comment> \<open>@LF mostly repeated proof. quite annoying "the" etc.\<close>
	oops

	(*
	\<comment>\<open>VDM proof obligation `CM` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 172:1\<close>
theorem CM_RECURSIVE_PO27:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			(((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid))))))))))) \<longrightarrow> (
		let
(newOutput::Output) = (InterruptPlan curTime  outputSoFar  ((the(responseDB curMis)))  magid)
		;

(magidMaplet::(MagId \<rightharpoonup> MissileType option)) = [magid\<mapsto>curMis]
		in

			(if (inv_Output newOutput)
	 \<and>
	((inv_Map inv_MagId (inv_Option inv_MissileType) magidMaplet)) then
			((measure_CM missileInputs  outputSoFar  lastMissile  curTime) > (measure_CM (tl missileInputs)  newOutput  (lastMissile \<dagger> magidMaplet)  (curTime + stepLength)))
		 else
			undefined
		)
		))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"

	oops

	*)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 192:24\<close>
theorem CM_NON_EMPTY_SEQ_PO28:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			(((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid))))))))))) \<longrightarrow> (
		let
(newOutput::Output) = (InterruptPlan curTime  outputSoFar  ((the(responseDB curMis)))  magid)
		;

\<comment> \<open>@LF missing Some context :-(\<close>
(magidMaplet::(MagId \<rightharpoonup> MissileType option)) = [magid\<mapsto> Some curMis]
		in

			(if (inv_Output newOutput)
	 \<and>
	((inv_Map inv_MagId (inv_Option inv_MissileType) magidMaplet)) then
			(missileInputs \<noteq> [])
		 else
			undefined
		)
		))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	apply (simp add: Let_def, safe)
  \<comment> \<open>@LF even worse: 392 goals! \<close>
	oops

	(*
	\<comment>\<open>VDM proof obligation `CM` is spurious given Isabelle's encoding of `measures`.\<close>

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 172:1\<close>
theorem CM_RECURSIVE_PO29:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> ((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid)))))))))))) \<longrightarrow> ((measure_CM missileInputs  outputSoFar  lastMissile  curTime) > (measure_CM (tl missileInputs)  outputSoFar  lastMissile  (curTime + stepLength))))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"

	oops

	*)

\<comment>\<open>VDM source: CM = ?\<close>
\<comment>\<open>in 'CM' (./src/test/resources/Examples/CMSL/CM.vdmsl) at line 195:21\<close>
theorem CM_NON_EMPTY_SEQ_PO30:
	\<comment>\<open>Implicitly defined type invariant checks for quantified type binds\<close>
	"((\<forall> (missileInputs :: MissileInputs)   (outputSoFar :: Output)   (lastMissile :: (MagId \<rightharpoonup> MissileType option))   (curTime :: VDMNat)  . ((((inv_MissileInputs missileInputs)))  \<and>  (((inv_Output outputSoFar)))  \<and>  (((inv_Map inv_MagId (inv_Option inv_MissileType) lastMissile)))  \<and>  (((inv_VDMNat curTime))) \<longrightarrow> ((\<not> (missileInputs = [])) \<longrightarrow> (
		let
	\<comment>\<open>Implicit pattern context projection for `let-bind definition`\<close>

(dummy0::MissileInput) = (hd missileInputs)
		in
			\<comment>\<open>Implicit pattern context projection for `pattern list`\<close>
	 let curMis = (fst dummy0); angle = (snd dummy0) in
			(if (inv_MissileInput dummy0) then
			(
		let
(magid::MagId) = (Angle2MagId angle)
		in

			(if (inv_MagId magid) then
			((\<not> ((magid \<notin> (dom lastMissile)) \<or> ((magid \<in> (dom lastMissile)) \<and> (((the(missilePriority curMis))) > ((the(missilePriority ((the((the(lastMissile magid)))))))))))) \<longrightarrow> (missileInputs \<noteq> []))
		 else
			undefined
		)
		)
		 else
			undefined
		)
		)))))"
	using CM_MAP_APPLY_PO25 by presburger

\<comment>\<open>Processing VDM exports as Isabelle hidden declarations\<close>

\<comment> \<open>@LF 13 sledgehammered, 3 simplified expansion, 4 oopsed (recursive), 6 nitpicked, 4 manual needing 6 extra lemmas\<close>
end


(* Author: Tobias Nipkow *)

subsection "Security Typing of Commands"

theory Sec_Typing imports Sec_Type_Expr
begin

subsubsection "Syntax Directed Typing"

inductive sec_type :: "nat \<Rightarrow> com \<Rightarrow> bool" ("(_/ \<turnstile> _)" [0,0] 50) where
Skip:
  "l \<turnstile> SKIP" |
Assign:
  "\<lbrakk> sec x \<ge> sec a;  sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile> x ::= a" |
Seq:
  "\<lbrakk> l \<turnstile> c\<^sub>1;  l \<turnstile> c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile> c\<^sub>1;;c\<^sub>2" |
If:
  "\<lbrakk> max (sec b) l \<turnstile> c\<^sub>1;  max (sec b) l \<turnstile> c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2" |
While:
  "max (sec b) l \<turnstile> c \<Longrightarrow> l \<turnstile> WHILE b DO c"

code_pred (expected_modes: i => i => bool) sec_type .

value "0 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"
value "1 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x''  ::= N 0 ELSE SKIP"
value "2 \<turnstile> IF Less (V ''x1'') (V ''x'') THEN ''x1'' ::= N 0 ELSE SKIP"

inductive_cases [elim!]:
  "l \<turnstile> x ::= a"  "l \<turnstile> c\<^sub>1;;c\<^sub>2"  "l \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2"  "l \<turnstile> WHILE b DO c"

text\<open>An important property: anti-monotonicity.\<close>

lemma anti_mono: "\<lbrakk> l \<turnstile> c;  l' \<le> l \<rbrakk> \<Longrightarrow> l' \<turnstile> c"
apply(induction arbitrary: l' rule: sec_type.induct)
apply (metis sec_type.intros(1))
apply (metis le_trans sec_type.intros(2))
apply (metis sec_type.intros(3))
apply (metis If le_refl sup_mono sup_nat_def)
apply (metis While le_refl sup_mono sup_nat_def)
done

lemma confinement: "\<lbrakk> (c,s) \<Rightarrow> t;  l \<turnstile> c \<rbrakk> \<Longrightarrow> s = t (< l)"
proof(induction rule: big_step_induct)
  case Skip thus ?case by simp
next
  case Assign thus ?case by auto
next
  case Seq thus ?case by auto
next
  case (IfTrue b s c1)
  hence "max (sec b) l \<turnstile> c1" by auto
  hence "l \<turnstile> c1" by (metis max.cobounded2 anti_mono)
  thus ?case using IfTrue.IH by metis
next
  case (IfFalse b s c2)
  hence "max (sec b) l \<turnstile> c2" by auto
  hence "l \<turnstile> c2" by (metis max.cobounded2 anti_mono)
  thus ?case using IfFalse.IH by metis
next
  case WhileFalse thus ?case by auto
next
  case (WhileTrue b s1 c)
  hence "max (sec b) l \<turnstile> c" by auto
  hence "l \<turnstile> c" by (metis max.cobounded2 anti_mono)
  thus ?case using WhileTrue by metis
qed

theorem noninterference:
  "\<lbrakk> (c,s) \<Rightarrow> s'; (c,t) \<Rightarrow> t';  0 \<turnstile> c;  s = t (\<le> l) \<rbrakk>
   \<Longrightarrow> s' = t' (\<le> l)"
proof(induction arbitrary: t t' rule: big_step_induct)
  case Skip thus ?case by auto
next
  case (Assign x a s)
  have [simp]: "t' = t(x := aval a t)" using Assign by auto
  have "sec x >= sec a" using \<open>0 \<turnstile> x ::= a\<close> by auto
  show ?case
  proof auto
    assume "sec x \<le> l"
    with \<open>sec x >= sec a\<close> have "sec a \<le> l" by arith
    thus "aval a s = aval a t"
      by (rule aval_eq_if_eq_le[OF \<open>s = t (\<le> l)\<close>])
  next
    fix y assume "y \<noteq> x" "sec y \<le> l"
    thus "s y = t y" using \<open>s = t (\<le> l)\<close> by simp
  qed
next
  case Seq thus ?case by blast
next
  case (IfTrue b s c1 s' c2)
  have "sec b \<turnstile> c1" "sec b \<turnstile> c2" using \<open>0 \<turnstile> IF b THEN c1 ELSE c2\<close> by auto
  show ?case
  proof cases
    assume "sec b \<le> l"
    hence "s = t (\<le> sec b)" using \<open>s = t (\<le> l)\<close> by auto
    hence "bval b t" using \<open>bval b s\<close> by(simp add: bval_eq_if_eq_le)
    with IfTrue.IH IfTrue.prems(1,3) \<open>sec b \<turnstile> c1\<close>  anti_mono
    show ?thesis by auto
  next
    assume "\<not> sec b \<le> l"
    have 1: "sec b \<turnstile> IF b THEN c1 ELSE c2"
      by(rule sec_type.intros)(simp_all add: \<open>sec b \<turnstile> c1\<close> \<open>sec b \<turnstile> c2\<close>)
    from confinement[OF \<open>(c1, s) \<Rightarrow> s'\<close> \<open>sec b \<turnstile> c1\<close>] \<open>\<not> sec b \<le> l\<close>
    have "s = s' (\<le> l)" by auto
    moreover
    from confinement[OF \<open>(IF b THEN c1 ELSE c2, t) \<Rightarrow> t'\<close> 1] \<open>\<not> sec b \<le> l\<close>
    have "t = t' (\<le> l)" by auto
    ultimately show "s' = t' (\<le> l)" using \<open>s = t (\<le> l)\<close> by auto
  qed
next
  case (IfFalse b s c2 s' c1)
  have "sec b \<turnstile> c1" "sec b \<turnstile> c2" using \<open>0 \<turnstile> IF b THEN c1 ELSE c2\<close> by auto
  show ?case
  proof cases
    assume "sec b \<le> l"
    hence "s = t (\<le> sec b)" using \<open>s = t (\<le> l)\<close> by auto
    hence "\<not> bval b t" using \<open>\<not> bval b s\<close> by(simp add: bval_eq_if_eq_le)
    with IfFalse.IH IfFalse.prems(1,3) \<open>sec b \<turnstile> c2\<close> anti_mono
    show ?thesis by auto
  next
    assume "\<not> sec b \<le> l"
    have 1: "sec b \<turnstile> IF b THEN c1 ELSE c2"
      by(rule sec_type.intros)(simp_all add: \<open>sec b \<turnstile> c1\<close> \<open>sec b \<turnstile> c2\<close>)
    from confinement[OF big_step.IfFalse[OF IfFalse(1,2)] 1] \<open>\<not> sec b \<le> l\<close>
    have "s = s' (\<le> l)" by auto
    moreover
    from confinement[OF \<open>(IF b THEN c1 ELSE c2, t) \<Rightarrow> t'\<close> 1] \<open>\<not> sec b \<le> l\<close>
    have "t = t' (\<le> l)" by auto
    ultimately show "s' = t' (\<le> l)" using \<open>s = t (\<le> l)\<close> by auto
  qed
next
  case (WhileFalse b s c)
  have "sec b \<turnstile> c" using WhileFalse.prems(2) by auto
  show ?case
  proof cases
    assume "sec b \<le> l"
    hence "s = t (\<le> sec b)" using \<open>s = t (\<le> l)\<close> by auto
    hence "\<not> bval b t" using \<open>\<not> bval b s\<close> by(simp add: bval_eq_if_eq_le)
    with WhileFalse.prems(1,3) show ?thesis by auto
  next
    assume "\<not> sec b \<le> l"
    have 1: "sec b \<turnstile> WHILE b DO c"
      by(rule sec_type.intros)(simp_all add: \<open>sec b \<turnstile> c\<close>)
    from confinement[OF \<open>(WHILE b DO c, t) \<Rightarrow> t'\<close> 1] \<open>\<not> sec b \<le> l\<close>
    have "t = t' (\<le> l)" by auto
    thus "s = t' (\<le> l)" using \<open>s = t (\<le> l)\<close> by auto
  qed
next
  case (WhileTrue b s1 c s2 s3 t1 t3)
  let ?w = "WHILE b DO c"
  have "sec b \<turnstile> c" using \<open>0 \<turnstile> WHILE b DO c\<close> by auto
  show ?case
  proof cases
    assume "sec b \<le> l"
    hence "s1 = t1 (\<le> sec b)" using \<open>s1 = t1 (\<le> l)\<close> by auto
    hence "bval b t1"
      using \<open>bval b s1\<close> by(simp add: bval_eq_if_eq_le)
    then obtain t2 where "(c,t1) \<Rightarrow> t2" "(?w,t2) \<Rightarrow> t3"
      using \<open>(?w,t1) \<Rightarrow> t3\<close> by auto
    from WhileTrue.IH(2)[OF \<open>(?w,t2) \<Rightarrow> t3\<close> \<open>0 \<turnstile> ?w\<close>
      WhileTrue.IH(1)[OF \<open>(c,t1) \<Rightarrow> t2\<close> anti_mono[OF \<open>sec b \<turnstile> c\<close>]
        \<open>s1 = t1 (\<le> l)\<close>]]
    show ?thesis by simp
  next
    assume "\<not> sec b \<le> l"
    have 1: "sec b \<turnstile> ?w" by(rule sec_type.intros)(simp_all add: \<open>sec b \<turnstile> c\<close>)
    from confinement[OF big_step.WhileTrue[OF WhileTrue.hyps] 1] \<open>\<not> sec b \<le> l\<close>
    have "s1 = s3 (\<le> l)" by auto
    moreover
    from confinement[OF \<open>(WHILE b DO c, t1) \<Rightarrow> t3\<close> 1] \<open>\<not> sec b \<le> l\<close>
    have "t1 = t3 (\<le> l)" by auto
    ultimately show "s3 = t3 (\<le> l)" using \<open>s1 = t1 (\<le> l)\<close> by auto
  qed
qed

subsubsection "The Standard Typing System"

text\<open>The predicate \<^prop>\<open>l \<turnstile> c\<close> is nicely intuitive and executable. The
standard formulation, however, is slightly different, replacing the maximum
computation by an antimonotonicity rule. We introduce the standard system now
and show the equivalence with our formulation.\<close>

inductive sec_type' :: "nat \<Rightarrow> com \<Rightarrow> bool" ("(_/ \<turnstile>'' _)" [0,0] 50) where
Skip':
  "l \<turnstile>' SKIP" |
Assign':
  "\<lbrakk> sec x \<ge> sec a; sec x \<ge> l \<rbrakk> \<Longrightarrow> l \<turnstile>' x ::= a" |
Seq':
  "\<lbrakk> l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' c\<^sub>1;;c\<^sub>2" |
If':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c\<^sub>1;  l \<turnstile>' c\<^sub>2 \<rbrakk> \<Longrightarrow> l \<turnstile>' IF b THEN c\<^sub>1 ELSE c\<^sub>2" |
While':
  "\<lbrakk> sec b \<le> l;  l \<turnstile>' c \<rbrakk> \<Longrightarrow> l \<turnstile>' WHILE b DO c" |
anti_mono':
  "\<lbrakk> l \<turnstile>' c;  l' \<le> l \<rbrakk> \<Longrightarrow> l' \<turnstile>' c"

lemma sec_type_sec_type': "l \<turnstile> c \<Longrightarrow> l \<turnstile>' c"
apply(induction rule: sec_type.induct)
apply (metis Skip')
apply (metis Assign')
apply (metis Seq')
apply (metis max.commute max.absorb_iff2 nat_le_linear If' anti_mono')
by (metis less_or_eq_imp_le max.absorb1 max.absorb2 nat_le_linear While' anti_mono')

lemma sec_type'_sec_type: "l \<turnstile>' c \<Longrightarrow> l \<turnstile> c"
apply(induction rule: sec_type'.induct)
apply (metis Skip)
apply (metis Assign)
apply (metis Seq)
apply (metis max.absorb2 If)
apply (metis max.absorb2 While)
by (metis anti_mono)

subsubsection "A Bottom-Up Typing System"

inductive sec_type2 :: "com \<Rightarrow> level \<Rightarrow> bool" ("(\<turnstile> _ : _)" [0,0] 50) where
Skip2:
  "\<turnstile> SKIP : l" |
Assign2:
  "sec x \<ge> sec a \<Longrightarrow> \<turnstile> x ::= a : sec x" |
Seq2:
  "\<lbrakk> \<turnstile> c\<^sub>1 : l\<^sub>1;  \<turnstile> c\<^sub>2 : l\<^sub>2 \<rbrakk> \<Longrightarrow> \<turnstile> c\<^sub>1;;c\<^sub>2 : min l\<^sub>1 l\<^sub>2 " |
If2:
  "\<lbrakk> sec b \<le> min l\<^sub>1 l\<^sub>2;  \<turnstile> c\<^sub>1 : l\<^sub>1;  \<turnstile> c\<^sub>2 : l\<^sub>2 \<rbrakk>
  \<Longrightarrow> \<turnstile> IF b THEN c\<^sub>1 ELSE c\<^sub>2 : min l\<^sub>1 l\<^sub>2" |
While2:
  "\<lbrakk> sec b \<le> l;  \<turnstile> c : l \<rbrakk> \<Longrightarrow> \<turnstile> WHILE b DO c : l"

lemma sec_type2_sec_type': "\<turnstile> c : l \<Longrightarrow> l \<turnstile>' c"
apply(induction rule: sec_type2.induct)
apply (metis Skip')
apply (metis Assign' eq_imp_le)
apply (metis Seq' anti_mono' min.cobounded1 min.cobounded2)
apply (metis If' anti_mono' min.absorb2 min.absorb_iff1 nat_le_linear)
by (metis While')

lemma sec_type'_sec_type2: "l \<turnstile>' c \<Longrightarrow> \<exists> l' \<ge> l. \<turnstile> c : l'"
apply(induction rule: sec_type'.induct)
apply (metis Skip2 le_refl)
apply (metis Assign2)
apply (metis Seq2 min.boundedI)
apply (metis If2 inf_greatest inf_nat_def le_trans)
apply (metis While2 le_trans)
by (metis le_trans)

end


(*
    Author:   Benedikt Seidl
    License:  BSD
*)

section \<open>The Master Theorem\<close>

theory Master_Theorem
imports
  Advice After
begin

subsection \<open>Checking @{term "X \<subseteq> \<G>\<F> \<phi> w"} and @{term "Y \<subseteq> \<F>\<G> \<phi> w"}\<close>

lemma X_\<G>\<F>_Y_\<F>\<G>:
  assumes
    X_\<mu>: "X \<subseteq> subformulas\<^sub>\<mu> \<phi>"
  and
    Y_\<nu>: "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    X_GF: "\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)"
  and
    Y_FG: "\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)"
  shows
    "X \<subseteq> \<G>\<F> \<phi> w \<and> Y \<subseteq> \<F>\<G> \<phi> w"
proof -
  \<comment> \<open>Custom induction rule with @{term size} as a partial order\<close>
  note induct = finite_ranking_induct[where f = size]

  have "finite (X \<union> Y)"
    using subformulas\<^sub>\<mu>_finite subformulas\<^sub>\<nu>_finite X_\<mu> Y_\<nu> finite_subset
    by blast+

  then show ?thesis
    using assms
  proof (induction "X \<union> Y" arbitrary: X Y \<phi> rule: induct)
    case (insert \<psi> S)

    note IH = insert(3)
    note insert_S = \<open>insert \<psi> S = X \<union> Y\<close>
    note X_\<mu> = \<open>X \<subseteq> subformulas\<^sub>\<mu> \<phi>\<close>
    note Y_\<nu> = \<open>Y \<subseteq> subformulas\<^sub>\<nu> \<phi>\<close>
    note X_GF = \<open>\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)\<close>
    note Y_FG = \<open>\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)\<close>

    from X_\<mu> Y_\<nu> have "X \<inter> Y = {}"
      using subformulas\<^sub>\<mu>\<^sub>\<nu>_disjoint by fast

    from insert_S X_\<mu> Y_\<nu> have "\<psi> \<in> subfrmlsn \<phi>"
      using subformulas\<^sub>\<mu>_subfrmlsn subformulas\<^sub>\<nu>_subfrmlsn by blast

    show ?case
    proof (cases "\<psi> \<notin> S", cases "\<psi> \<in> X")
      assume "\<psi> \<notin> S" and "\<psi> \<in> X"

      {
        \<comment> \<open>Show @{term "X - {\<psi>} \<subseteq> \<G>\<F> \<phi> w"} and @{term "Y \<subseteq> \<F>\<G> \<phi> w"}\<close>

        then have "\<psi> \<notin> Y"
          using \<open>X \<inter> Y = {}\<close> by auto
        then have "S = (X - {\<psi>}) \<union> Y"
          using insert_S \<open>\<psi> \<notin> S\<close> by fast

        moreover

        have "\<forall>\<psi>' \<in> Y. \<psi>'[X - {\<psi>}]\<^sub>\<nu> = \<psi>'[X]\<^sub>\<nu>"
          using GF_advice_minus_size insert(1,2,4) \<open>\<psi> \<notin> Y\<close> by fast

        ultimately have "X - {\<psi>} \<subseteq> \<G>\<F> \<phi> w" and "Y \<subseteq> \<F>\<G> \<phi> w"
          using IH[of "X - {\<psi>}" Y \<phi>] X_\<mu> Y_\<nu> X_GF Y_FG by auto
      }

      moreover

      {
        \<comment> \<open>Show @{term "\<psi> \<in> \<G>\<F> \<phi> w"}\<close>

        have "w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)"
          using X_GF \<open>\<psi> \<in> X\<close> by simp
        then have "\<exists>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>[Y]\<^sub>\<mu>"
          unfolding GF_Inf_many by simp

        moreover

        from Y_\<nu> have "finite Y"
          using subformulas\<^sub>\<nu>_finite finite_subset by auto

        have "\<forall>\<phi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<phi>)"
          using \<open>Y \<subseteq> \<F>\<G> \<phi> w\<close> by (blast dest: \<F>\<G>_elim)
        then have "\<forall>\<phi> \<in> Y. \<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<phi>"
          using FG_suffix_G by blast
        then have "\<forall>\<^sub>\<infinity>i. \<forall>\<phi> \<in> Y. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<phi>"
          using \<open>finite Y\<close> eventually_ball_finite by fast

        ultimately

        have "\<exists>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>[Y]\<^sub>\<mu> \<and> (\<forall>\<phi> \<in> Y. suffix i w \<Turnstile>\<^sub>n G\<^sub>n \<phi>)"
          using INFM_conjI by auto
        then have "\<exists>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>"
          by (elim frequently_elim1) (metis FG_advice_b2_helper)
        then have "w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)"
          unfolding GF_Inf_many by simp
        then have "\<psi> \<in> \<G>\<F> \<phi> w"
          unfolding \<G>\<F>_semantics using \<open>\<psi> \<in> X\<close> X_\<mu> by auto
      }

      ultimately show ?thesis
        by auto
    next
      assume "\<psi> \<notin> S" and "\<psi> \<notin> X"
      then have "\<psi> \<in> Y"
        using insert by fast

      {
        \<comment> \<open>Show @{term "X \<subseteq> \<G>\<F> \<phi> w"} and @{term "Y - {\<psi>} \<subseteq> \<F>\<G> \<phi> w"}\<close>

        then have "S \<inter> X = X"
          using insert \<open>\<psi> \<notin> X\<close> by fast
        then have "S = X \<union> (Y - {\<psi>})"
          using insert_S \<open>\<psi> \<notin> S\<close> by fast

        moreover

        have "\<forall>\<psi>' \<in> X. \<psi>'[Y - {\<psi>}]\<^sub>\<mu> = \<psi>'[Y]\<^sub>\<mu>"
          using FG_advice_minus_size insert(1,2,4) \<open>\<psi> \<notin> X\<close> by fast

        ultimately have "X \<subseteq> \<G>\<F> \<phi> w" and "Y - {\<psi>} \<subseteq> \<F>\<G> \<phi> w"
          using IH[of X "Y - {\<psi>}" \<phi>] X_\<mu> Y_\<nu> X_GF Y_FG by auto
      }

      moreover

      {
        \<comment> \<open>Show @{term "\<psi> \<in> \<F>\<G> \<phi> w"}\<close>

        have "w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)"
          using Y_FG \<open>\<psi> \<in> Y\<close> by simp
        then have "\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>[X]\<^sub>\<nu>"
          unfolding FG_Alm_all by simp

        moreover

        have "\<forall>\<phi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>)"
          using \<open>X \<subseteq> \<G>\<F> \<phi> w\<close> by (blast dest: \<G>\<F>_elim)
        then have "\<forall>\<^sub>\<infinity>i. \<forall>\<phi> \<in> X. suffix i w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>)"
          by simp

        ultimately

        have "\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>[X]\<^sub>\<nu> \<and> (\<forall>\<phi> \<in> X. suffix i w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<phi>))"
          using MOST_conjI by auto
        then have "\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>"
          by (elim MOST_mono) (metis GF_advice_a2_helper)
        then have "w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>)"
          unfolding FG_Alm_all by simp
        then have "\<psi> \<in> \<F>\<G> \<phi> w"
          unfolding \<F>\<G>_semantics using \<open>\<psi> \<in> Y\<close> Y_\<nu> by auto
      }

      ultimately show ?thesis
        by auto
    next
      assume "\<not> \<psi> \<notin> S"
      then have "S = X \<union> Y"
        using insert by fast
      then show ?thesis
        using insert by auto
    qed
  qed fast
qed

lemma \<G>\<F>_implies_GF:
  "\<forall>\<psi> \<in> \<G>\<F> \<phi> w. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>)"
proof safe
  fix \<psi>
  assume "\<psi> \<in> \<G>\<F> \<phi> w"

  then have "\<exists>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>"
    using \<G>\<F>_elim GF_Inf_many by blast

  moreover

  have "\<psi> \<in> subfrmlsn \<phi>"
    using \<open>\<psi> \<in> \<G>\<F> \<phi> w\<close> \<G>\<F>_subfrmlsn by blast

  then have "\<And>i w. \<F>\<G> \<psi> (suffix i w) \<subseteq> \<F>\<G> \<phi> w"
    using \<F>\<G>_suffix \<F>\<G>_subset by blast

  ultimately have "\<exists>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>"
    by (elim frequently_elim1) (metis FG_advice_b1)

  then show "w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>)"
    unfolding GF_Inf_many by simp
qed

lemma \<F>\<G>_implies_FG:
  "\<forall>\<psi> \<in> \<F>\<G> \<phi> w. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[\<G>\<F> \<phi> w]\<^sub>\<nu>)"
proof safe
  fix \<psi>
  assume "\<psi> \<in> \<F>\<G> \<phi> w"

  then have "\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>"
    using \<F>\<G>_elim FG_Alm_all by blast

  moreover

  {
    have "\<psi> \<in> subfrmlsn \<phi>"
      using \<open>\<psi> \<in> \<F>\<G> \<phi> w\<close> \<F>\<G>_subfrmlsn by blast

    moreover have "\<forall>\<^sub>\<infinity>i. \<G>\<F> \<psi> (suffix i w) = \<F> \<psi> (suffix i w)"
      using suffix_\<mu>_stable unfolding \<mu>_stable_def by blast

    ultimately have "\<forall>\<^sub>\<infinity>i. \<F> \<psi> (suffix i w) \<subseteq> \<G>\<F> \<phi> w"
      unfolding MOST_nat_le by (metis \<G>\<F>_subset \<G>\<F>_suffix)
  }

  ultimately have "\<forall>\<^sub>\<infinity>i. \<F> \<psi> (suffix i w) \<subseteq> \<G>\<F> \<phi> w \<and> suffix i w \<Turnstile>\<^sub>n \<psi>"
    using eventually_conj by auto

  then have "\<forall>\<^sub>\<infinity>i. suffix i w \<Turnstile>\<^sub>n \<psi>[\<G>\<F> \<phi> w]\<^sub>\<nu>"
    using GF_advice_a1 by (elim eventually_mono) auto

  then show "w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[\<G>\<F> \<phi> w]\<^sub>\<nu>)"
    unfolding FG_Alm_all by simp
qed

subsection \<open>Putting the pieces together: The Master Theorem\<close>

theorem master_theorem_ltr:
  assumes
    "w \<Turnstile>\<^sub>n \<phi>"
  obtains X and Y where
    "X \<subseteq> subformulas\<^sub>\<mu> \<phi>"
  and
    "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>"
  and
    "\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)"
  and
    "\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)"
proof
  show "\<G>\<F> \<phi> w \<subseteq> subformulas\<^sub>\<mu> \<phi>"
    by (rule \<G>\<F>_subformulas\<^sub>\<mu>)
next
  show "\<F>\<G> \<phi> w \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    by (rule \<F>\<G>_subformulas\<^sub>\<nu>)
next
  obtain i where "\<G>\<F> \<phi> (suffix i w) = \<F> \<phi> (suffix i w)"
    using suffix_\<mu>_stable unfolding MOST_nat \<mu>_stable_def by fast
  then have "\<F> (af \<phi> (prefix i w)) (suffix i w) \<subseteq> \<G>\<F> \<phi> w"
    using \<G>\<F>_af \<F>_af \<G>\<F>_suffix by fast

  moreover

  have "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)"
    using af_ltl_continuation \<open>w \<Turnstile>\<^sub>n \<phi>\<close> by fastforce

  ultimately show "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[\<G>\<F> \<phi> w]\<^sub>\<nu>"
    using GF_advice_a1 by blast
next
  show "\<forall>\<psi> \<in> \<G>\<F> \<phi> w. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[\<F>\<G> \<phi> w]\<^sub>\<mu>)"
    by (rule \<G>\<F>_implies_GF)
next
  show "\<forall>\<psi> \<in> \<F>\<G> \<phi> w. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[\<G>\<F> \<phi> w]\<^sub>\<nu>)"
    by (rule \<F>\<G>_implies_FG)
qed

theorem master_theorem_rtl:
  assumes
    "X \<subseteq> subformulas\<^sub>\<mu> \<phi>"
  and
    "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
  and
    1: "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>"
  and
    2: "\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)"
  and
    3: "\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)"
  shows
    "w \<Turnstile>\<^sub>n \<phi>"
proof -
  from 1 obtain i where "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>"
    by blast

  moreover

  from assms have "X \<subseteq> \<G>\<F> \<phi> w"
    using X_\<G>\<F>_Y_\<F>\<G> by blast
  then have "X \<subseteq> \<G>\<F> \<phi> (suffix i w)"
    using \<G>\<F>_suffix by fast

  ultimately have "suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)"
    using GF_advice_a2 \<G>\<F>_af by metis
  then show "w \<Turnstile>\<^sub>n \<phi>"
    using af_ltl_continuation by force
qed

theorem master_theorem:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow>
    (\<exists>X \<subseteq> subformulas\<^sub>\<mu> \<phi>.
      (\<exists>Y \<subseteq> subformulas\<^sub>\<nu> \<phi>.
        (\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>)
        \<and> (\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>))
        \<and> (\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>))))"
  by (metis master_theorem_ltr master_theorem_rtl)

subsection \<open>The Master Theorem on Languages\<close>

definition "L\<^sub>1 \<phi> X = {w. \<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>}"

definition "L\<^sub>2 X Y = {w. \<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)}"

definition "L\<^sub>3 X Y = {w. \<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)}"

corollary master_theorem_language:
  "language_ltln \<phi> = \<Union> {L\<^sub>1 \<phi> X \<inter> L\<^sub>2 X Y \<inter> L\<^sub>3 X Y | X Y. X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<and> Y \<subseteq> subformulas\<^sub>\<nu> \<phi>}"
proof safe
  fix w
  assume "w \<in> language_ltln \<phi>"

  then have "w \<Turnstile>\<^sub>n \<phi>"
    unfolding language_ltln_def by simp

  then obtain X Y where "X \<subseteq> subformulas\<^sub>\<mu> \<phi>" and "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    and "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>"
    and "\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)"
    and "\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)"
    using master_theorem_ltr by metis

  then have "w \<in> L\<^sub>1 \<phi> X" and "w \<in> L\<^sub>2 X Y" and "w \<in> L\<^sub>3 X Y"
    unfolding L\<^sub>1_def L\<^sub>2_def L\<^sub>3_def by simp+

  then show "w \<in> \<Union> {L\<^sub>1 \<phi> X \<inter> L\<^sub>2 X Y \<inter> L\<^sub>3 X Y | X Y. X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<and> Y \<subseteq> subformulas\<^sub>\<nu> \<phi>}"
    using \<open>X \<subseteq> subformulas\<^sub>\<mu> \<phi>\<close> \<open>Y \<subseteq> subformulas\<^sub>\<nu> \<phi>\<close> by blast
next
  fix w X Y
  assume "X \<subseteq> subformulas\<^sub>\<mu> \<phi>" and "Y \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    and "w \<in> L\<^sub>1 \<phi> X" and "w \<in> L\<^sub>2 X Y" and "w \<in> L\<^sub>3 X Y"

  then show "w \<in> language_ltln \<phi>"
    unfolding language_ltln_def L\<^sub>1_def L\<^sub>2_def L\<^sub>3_def
    using master_theorem_rtl by blast
qed

end


(*  Title:      HOL/MicroJava/BV/Typing_Framework_err.thy
    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

header {* \isaheader{Lifting the Typing Framework to err, app, and eff} *}

theory Typing_Framework_err imports Typing_Framework SemilatAlg begin

definition wt_err_step :: "'s ord \<Rightarrow> 's err step_type \<Rightarrow> 's err list \<Rightarrow> bool"
where
  "wt_err_step r step \<tau>s \<longleftrightarrow> wt_step (Err.le r) Err step \<tau>s"

definition wt_app_eff :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's list \<Rightarrow> bool"
where
  "wt_app_eff r app step \<tau>s \<longleftrightarrow>
    (\<forall>p < size \<tau>s. app p (\<tau>s!p) \<and> (\<forall>(q,\<tau>) \<in> set (step p (\<tau>s!p)). \<tau> <=_r \<tau>s!q))"

definition map_snd :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('a \<times> 'c) list"
where
  "map_snd f = map (\<lambda>(x,y). (x, f y))"

definition error :: "nat \<Rightarrow> (nat \<times> 'a err) list"
where
  "error n = map (\<lambda>x. (x,Err)) [0..<n]"

definition err_step :: "nat \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> 's step_type \<Rightarrow> 's err step_type"
where
  "err_step n app step p t =
  (case t of
    Err   \<Rightarrow> error n
  | OK \<tau> \<Rightarrow> if app p \<tau> then map_snd OK (step p \<tau>) else error n)"

definition app_mono :: "'s ord \<Rightarrow> (nat \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> bool"
where
  "app_mono r app n A \<longleftrightarrow>
    (\<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> app p s)"

lemmas err_step_defs = err_step_def map_snd_def error_def

lemma bounded_err_stepD:
  "\<lbrakk> bounded (err_step n app step) n;
     p < n; app p a; (q,b) \<in> set (step p a) \<rbrakk> \<Longrightarrow> q < n"
(*<*)
  apply (simp add: bounded_def err_step_def)
  apply (erule allE, erule impE, assumption)
  apply (erule_tac x = "OK a" in allE, drule bspec)
   apply (simp add: map_snd_def)
   apply fast
  apply simp
  done
(*>*)

lemma in_map_sndD: "(a,b) \<in> set (map_snd f xs) \<Longrightarrow> \<exists>b'. (a,b') \<in> set xs"
(*<*)
  apply (induct xs)
  apply (auto simp add: map_snd_def)
  done
(*>*)

lemma bounded_err_stepI:
  "\<forall>p. p < n \<longrightarrow> (\<forall>s. ap p s \<longrightarrow> (\<forall>(q,s') \<in> set (step p s). q < n))
  \<Longrightarrow> bounded (err_step n ap step) n"
(*<*)
apply (clarsimp simp: bounded_def err_step_def split: err.splits)
apply (simp add: error_def image_def)
apply (blast dest: in_map_sndD)
done
(*>*)

lemma bounded_lift:
  "bounded step n \<Longrightarrow> bounded (err_step n app step) n"
(*<*)
  apply (unfold bounded_def err_step_def error_def)
  apply clarify
  apply (erule allE, erule impE, assumption)
  apply (case_tac \<tau>)
  apply (auto simp add: map_snd_def split: split_if_asm)
  done
(*>*)

lemma le_list_map_OK [simp]:
  "\<And>b. (map OK a [\<sqsubseteq>\<^bsub>Err.le r\<^esub>] map OK b) = (a [\<sqsubseteq>\<^sub>r] b)"
(*<*)
  apply (induct a)
   apply simp
  apply simp
  apply (case_tac b)
   apply simp
  apply simp
  done
(*>*)

lemma map_snd_lessI:
  "set xs {\<sqsubseteq>\<^bsub>r\<^esub>} set ys \<Longrightarrow> set (map_snd OK xs) {\<sqsubseteq>\<^bsub>Err.le r\<^esub>} set (map_snd OK ys)"
(*<*)
  apply (induct xs)
  apply (unfold lesubstep_type_def map_snd_def)
  apply auto
  done
(*>*)

lemma mono_lift:
  "\<lbrakk> order r; app_mono r app n A; bounded (err_step n app step) n;
    \<forall>s p t. s \<in> A \<and> p < n \<and> s \<sqsubseteq>\<^sub>r t \<longrightarrow> app p t \<longrightarrow> set (step p s) {\<sqsubseteq>\<^bsub>r\<^esub>} set (step p t) \<rbrakk>
  \<Longrightarrow>  mono (Err.le r) (err_step n app step) n (err A)"
(*<*)
apply (unfold app_mono_def SemilatAlg.mono_def err_step_def)
apply clarify
apply (case_tac \<tau>)
 apply simp
apply simp
apply (case_tac \<tau>')
 apply simp
 apply clarify
 apply (simp add: lesubstep_type_def error_def)
 apply clarify
 apply (drule in_map_sndD)
 apply clarify
 apply (drule bounded_err_stepD, assumption+)
 apply (rule exI [of _ Err])
 apply simp
apply simp
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (rule conjI)
apply clarify
apply (erule allE, erule allE, erule allE, erule impE)
 apply (rule conjI, assumption)
 apply (rule conjI, assumption)
 apply assumption
apply (erule impE, assumption)
apply (rule map_snd_lessI, assumption)
apply clarify
apply (simp add: lesubstep_type_def error_def)
apply clarify
apply (drule in_map_sndD)
apply clarify
apply (drule bounded_err_stepD, assumption+)
apply (rule exI [of _ Err])
apply simp
done
(*>*)

lemma in_errorD: "(x,y) \<in> set (error n) \<Longrightarrow> y = Err"
(*<*) by (auto simp add: error_def) (*>*)

lemma pres_type_lift:
  "\<forall>s\<in>A. \<forall>p. p < n \<longrightarrow> app p s \<longrightarrow> (\<forall>(q, s')\<in>set (step p s). s' \<in> A)
  \<Longrightarrow> pres_type (err_step n app step) n (err A)"
(*<*)
apply (unfold pres_type_def err_step_def)
apply clarify
apply (case_tac b)
 apply simp
apply (case_tac \<tau>)
 apply simp
 apply (drule in_errorD)
 apply simp
apply (simp add: map_snd_def split: split_if_asm)
 apply fast
apply (drule in_errorD)
apply simp
done
(*>*)

lemma wt_err_imp_wt_app_eff:
  assumes wt: "wt_err_step r (err_step (size ts) app step) ts"
  assumes b:  "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_app_eff r app step (map ok_val ts)"
(*<*)
proof (unfold wt_app_eff_def, intro strip, rule conjI)
  fix p assume "p < size (map ok_val ts)"
  hence lp: "p < size ts" by simp
  hence ts: "0 < size ts" by (cases p) auto
  hence err: "(0,Err) \<in> set (error (size ts))" by (simp add: error_def)

  from wt lp
  have [intro?]: "\<And>p. p < size ts \<Longrightarrow> ts ! p \<noteq> Err"
    by (unfold wt_err_step_def wt_step_def) simp

  show app: "app p (map ok_val ts ! p)"
  proof (rule ccontr)
    from wt lp obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)
    assume "\<not> app p (map ok_val ts ! p)"
    with OKp lp have "\<not> app p s" by simp
    with OKp have "err_step (size ts) app step p (ts!p) = error (size ts)"
      by (simp add: err_step_def)
    with err ts obtain q where
      "(q,Err) \<in> set (err_step (size ts) app step p (ts!p))" and
      q: "q < size ts" by auto
    with less have "ts!q = Err" by auto
    moreover from q have "ts!q \<noteq> Err" ..
    ultimately show False by blast
  qed

  show "\<forall>(q,t)\<in>set(step p (map ok_val ts ! p)). t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
  proof clarify
    fix q t assume q: "(q,t) \<in> set (step p (map ok_val ts ! p))"

    from wt lp q
    obtain s where
      OKp:  "ts ! p = OK s" and
      less: "\<forall>(q,t) \<in> set (err_step (size ts) app step p (ts!p)). t <=_(Err.le r) ts!q"
      by (unfold wt_err_step_def wt_step_def stable_def)
         (auto iff: not_Err_eq)

    from b lp app q have lq: "q < size ts" by (rule bounded_err_stepD)
    hence "ts!q \<noteq> Err" ..
    then obtain s' where OKq: "ts ! q = OK s'" by (auto iff: not_Err_eq)

    from lp lq OKp OKq app less q
    show "t \<sqsubseteq>\<^sub>r map ok_val ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  qed
qed
(*>*)

lemma wt_app_eff_imp_wt_err:
  assumes app_eff: "wt_app_eff r app step ts"
  assumes bounded: "bounded (err_step (size ts) app step) (size ts)"
  shows "wt_err_step r (err_step (size ts) app step) (map OK ts)"
(*<*)
proof (unfold wt_err_step_def wt_step_def, intro strip, rule conjI)
  fix p assume "p < size (map OK ts)"
  hence p: "p < size ts" by simp
  thus "map OK ts ! p \<noteq> Err" by simp
  { fix q t
    assume q: "(q,t) \<in> set (err_step (size ts) app step p (map OK ts ! p))"
    with p app_eff obtain
      "app p (ts ! p)" "\<forall>(q,t) \<in> set (step p (ts!p)). t \<sqsubseteq>\<^sub>r ts!q"
      by (unfold wt_app_eff_def) blast
    moreover
    from q p bounded have "q < size ts"
      by - (rule boundedD)
    hence "map OK ts ! q = OK (ts!q)" by simp
    moreover
    have "p < size ts" by (rule p)
    moreover note q
    ultimately
    have "t \<sqsubseteq>\<^bsub>Err.le r\<^esub> map OK ts ! q"
      by (auto simp add: err_step_def map_snd_def)
  }
  thus "stable (Err.le r) (err_step (size ts) app step) (map OK ts) p"
    by (unfold stable_def) blast
qed
(*>*)

end


theory test
imports
  "$AFP/IEEE_Floating_Point/RoundError"
  "$AFP/IEEE_Floating_Point/FloatProperty"
begin

definition TwoSum :: "float \<Rightarrow> float \<Rightarrow> float \<times> float" where
  "TwoSum a b = (let
    x = a + b;
    b\<^sub>v = x - a;
    a\<^sub>v = x - b\<^sub>v;
    b\<^sub>r = b - b\<^sub>v;
    a\<^sub>r = a - a\<^sub>v;
    y = a\<^sub>r + b\<^sub>r
    in (x, y))"

lemma finite_0: "Finite Plus_zero"
  by (simp add: Finite_def float_zero1)

lemma val_0_0: "Val Plus_zero = 0"
  using Iszero_def Val_def float_zero1 val_zero by auto

lemma err_smaller: "\<bar>a\<bar> < threshold float_format \<Longrightarrow> \<bar>error a\<bar> \<le> \<bar>a\<bar>"
  using error_at_worst_lemma[of a Plus_zero, OF _ finite_0]
  by (simp add: val_0_0)

lemma err1: "0 \<le> a \<Longrightarrow> a < threshold float_format \<Longrightarrow> error a \<le> a"
  thm error_at_worst_lemma
  using error_at_worst_lemma[of a Plus_zero, OF _ finite_0]
  by (simp add: val_0_0)

lemma
  assumes "\<bar>a\<bar> < threshold float_format" and "\<bar>b\<bar> < threshold float_format"
  and "\<bar>a + b\<bar> < threshold float_format"
  assumes "\<bar>a + b\<bar> \<le> \<bar>a\<bar>" and "\<bar>a + b\<bar> \<le> \<bar>b\<bar>"
  shows "error (a + b) = 0"
  oops

lemma lower_then_finite:
  "\<bar>x\<bar> < threshold float_format \<Longrightarrow> Finite (Float x)"
by (smt Finite_def Float_def Isdenormal_def Isnormal_def Iszero_def defloat_float_round is_finite_closest is_finite_def round.simps(1))

lemma lower_then_finite':
  "Finite x \<Longrightarrow> \<bar>Val x\<bar> < threshold float_format"
  using float_val_gt_threshold float_val_lt_threshold by fastforce

lemma err_simp: "error x = Val (Float x) - x"
  by (simp add: Float_def error_def)

lemma
  assumes "Finite a" "Finite b" "\<bar>Val a + Val b\<bar> < threshold float_format"
  assumes "(s, e) = TwoSum a b"
  shows "Val s + Val e = Val a + Val b"
  proof -
    let ?x = "a + b"
    let ?bv = "?x - a"
    let ?av = "?x - ?bv"
    let ?br = "b - ?bv"
    let ?ar = "a - ?av"
    let ?y = "?ar + ?br"
    note 1 = float_add[OF assms(1, 2, 3)]
    then have "\<bar>Val (?x) - Val a\<bar> = \<bar>Val b + error (Val a + Val b)\<bar>" by simp
    also have "... \<le> \<bar>Val b\<bar> + \<bar>error (Val a + Val b)\<bar>"
      by (simp add: abs_triangle_ineq)
    also have "\<dots> < threshold float_format"
      (*prove "\<bar>f\<bar> < threshold float_format \<Longrightarrow> error f < ulp Max_float" ? *)
      sorry
    ultimately
      have "\<bar>Val (?x) - Val a\<bar> < threshold float_format"
        by simp
    note 2 = float_sub[of ?x a, OF "1"(1) assms(1) this]
    thm float_sub [of ?x ?bv]
    then have "\<bar>Val (?x) - Val (?bv)\<bar> = \<bar>Val (?x) - (Val (?x) - Val a +
    error (Val (?x) - Val a))\<bar>"
      by simp
    also have "\<dots> = \<bar>Val a - error (Val (?x) - Val a)\<bar>"
      by simp
    also have "\<dots> < threshold float_format"
      sorry
    ultimately have "\<bar>Val (?x) - Val (?bv)\<bar> < threshold float_format"
      by simp
    note 3 = float_sub [of ?x ?bv, OF 1(1) 2(1) this]
    from 2 have "\<bar>Val b - Val ?bv\<bar> = \<bar>Val b - (Val (?x) - Val a +
    error (Val (?x) - Val a))\<bar>" by simp
    also have "... < threshold float_format"
      (* sledgehammer: inform Tobias Nipkow *)
      by (smt "1"(2) \<open>\<bar>Val b\<bar> + \<bar>error (Val a + Val b)\<bar> < threshold float_format\<close> assms error_at_worst_lemma)
    ultimately have "\<bar>Val b - Val ?bv\<bar> < threshold float_format"
      by simp
    note 4 = float_sub[of b ?bv, OF assms(2) 2(1) this]
    from 3 have "\<bar>Val a - Val ?av\<bar> = \<bar>Val a - (Val ?x - Val ?bv + error (Val ?x - Val ?bv))\<bar>"
      by simp
    also have "\<dots> < threshold float_format"
      by (smt "1"(1) "2"(2) \<open>\<bar>Val (a + b) - Val (a + b - a)\<bar> < threshold float_format\<close> \<open>\<bar>Val (a + b) - Val a\<bar> < threshold float_format\<close> assms(1) err_smaller error_at_worst_lemma float_val_gt_threshold float_val_lt_threshold)
    ultimately have "\<bar>Val a - Val ?av\<bar> < threshold float_format"
      by simp
    note 5 = float_sub[of a ?av, OF assms(1) 3(1) this]
    thm float_add[of ?ar ?br] 1 2 3 4 5
    from 4 have "\<bar>Val ?ar + Val ?br\<bar> = \<bar>Val ?ar + Val b - Val (a + b - a) +
    error (Val b - Val (a + b - a))\<bar>"
      by simp
    from 5 have "... = \<bar>Val a -
    Val (a + b - (a + b - a)) +
    error
     (Val a -
      Val (a + b - (a + b - a))) + Val b - Val (a + b - a) +
    error (Val b - Val (a + b - a))\<bar>"
      by simp
    thm this [simplified]
    have "error (Val ?x - Val a) = 0"

thm float_add


theory BananasDynamics
imports BananasStatics
begin

record dynamic_environment =
  var\<^sub>e_bind :: "name \<rightharpoonup> expr"
  var\<^sub>t_bind :: "name \<rightharpoonup> funct"

definition empty_dynamic :: dynamic_environment where
  "empty_dynamic = \<lparr> var\<^sub>e_bind = Map.empty, var\<^sub>t_bind = Map.empty \<rparr>"

definition extend\<^sub>e\<^sub>d :: "name \<Rightarrow> expr \<Rightarrow> dynamic_environment \<Rightarrow> dynamic_environment" where
  "extend\<^sub>e\<^sub>d x t \<Lambda> = \<Lambda>\<lparr> var\<^sub>e_bind := var\<^sub>e_bind \<Lambda>(x \<mapsto> t) \<rparr>"

definition combine\<^sub>d :: "dynamic_environment \<Rightarrow> dynamic_environment \<Rightarrow> dynamic_environment" where
  "combine\<^sub>d \<Lambda> \<Lambda>' =
    \<lparr> var\<^sub>e_bind = var\<^sub>e_bind \<Lambda> ++ var\<^sub>e_bind \<Lambda>', var\<^sub>t_bind = var\<^sub>t_bind \<Lambda> ++ var\<^sub>t_bind \<Lambda>' \<rparr>"

definition domain\<^sub>d :: "dynamic_environment \<Rightarrow> name set" where
  "domain\<^sub>d \<Lambda> = dom (var\<^sub>e_bind \<Lambda>) \<union> dom (var\<^sub>t_bind \<Lambda>)"

definition typecheck_env\<^sub>e :: "static_environment \<Rightarrow> (name \<rightharpoonup> (type \<times> type)) \<Rightarrow> (name \<rightharpoonup> expr) \<Rightarrow>
    bool" where
  "typecheck_env\<^sub>e \<Gamma> \<Gamma>\<^sub>e \<Lambda>\<^sub>e = (dom \<Gamma>\<^sub>e = dom \<Lambda>\<^sub>e \<and>
    (\<forall>x t\<^sub>1 t\<^sub>2. \<Gamma>\<^sub>e x = Some (t\<^sub>1, t\<^sub>2) \<longrightarrow> (\<exists>e. \<Lambda>\<^sub>e x = Some e \<and> \<Gamma> \<turnstile> e : t\<^sub>1 \<rightarrow> t\<^sub>2)))"

definition typecheck_environment :: "static_environment \<Rightarrow> dynamic_environment \<Rightarrow> bool"
    (infix "\<tturnstile>" 60) where
  "\<Gamma> \<tturnstile> \<Lambda> = (var\<^sub>t_type \<Gamma> = var\<^sub>t_bind \<Lambda> \<and> typecheck_env\<^sub>e \<Gamma> (var\<^sub>e_type \<Gamma>) (var\<^sub>e_bind \<Lambda>))"

fun apply_functor_expr :: "expr \<Rightarrow> funct \<Rightarrow> expr" (infixl "\<bullet>" 75) where
  "e \<bullet> Id = e"
| "e \<bullet> K t = \<epsilon>"
| "e \<bullet> f\<^sub>1 \<Otimes> f\<^sub>2 = (e \<bullet> f\<^sub>1) \<parallel> (e \<bullet> f\<^sub>2)"
| "e \<bullet> f\<^sub>1 \<Oplus> f\<^sub>2 = (e \<bullet> f\<^sub>1) \<bar> (e \<bullet> f\<^sub>2)"

inductive evaluate :: "dynamic_environment \<Rightarrow> expr \<Rightarrow> val \<Rightarrow> expr \<Rightarrow> val \<Rightarrow> bool"
    (infix "\<turnstile> _ \<cdot> _ \<leadsto> _ \<cdot>" 60) where
  ev_con [simp]: "\<Lambda> \<turnstile> \<kappa> v\<^sub>1 \<cdot> v\<^sub>2 \<leadsto> \<epsilon> \<cdot> v\<^sub>1"
| ev_comp1 [simp]: "\<Lambda> \<turnstile> g \<cdot> v \<leadsto> g' \<cdot> v' \<Longrightarrow> \<Lambda> \<turnstile> (f \<cdot> g) \<cdot> v \<leadsto> (f \<cdot> g') \<cdot> v'"
| ev_comp2 [simp]: "\<Lambda> \<turnstile> (f \<cdot> \<epsilon>) \<cdot> v \<leadsto> f \<cdot> v"
| ev_fst [simp]: "\<Lambda> \<turnstile> \<pi>\<^sub>1 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<cdot> v\<^sub>1"
| ev_snd [simp]: "\<Lambda> \<turnstile> \<pi>\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<cdot> v\<^sub>2"
| ev_pair1 [simp]: "\<Lambda> \<turnstile> f\<^sub>1 \<cdot> v\<^sub>1 \<leadsto> f\<^sub>1' \<cdot> v\<^sub>1' \<Longrightarrow>
    \<Lambda> \<turnstile> f\<^sub>1 \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> f\<^sub>1' \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1' v\<^sub>2"
| ev_pair2 [simp]: "\<Lambda> \<turnstile> f\<^sub>2 \<cdot> v\<^sub>2 \<leadsto> f\<^sub>2' \<cdot> v\<^sub>2' \<Longrightarrow>
    \<Lambda> \<turnstile> \<epsilon> \<parallel> f\<^sub>2 \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<parallel> f\<^sub>2' \<cdot> PairV v\<^sub>1 v\<^sub>2'"
| ev_pair3 [simp]: "\<Lambda> \<turnstile> \<epsilon> \<parallel> \<epsilon> \<cdot> PairV v\<^sub>1 v\<^sub>2 \<leadsto> \<epsilon> \<cdot> PairV v\<^sub>1 v\<^sub>2"
| ev_tup [simp]: "\<Lambda> \<turnstile> \<Theta> \<cdot> v \<leadsto> \<epsilon> \<cdot> PairV v v"
| ev_inl [simp]: "\<Lambda> \<turnstile> \<iota>\<^sub>l \<cdot> v \<leadsto> \<epsilon> \<cdot> InlV v"
| ev_inr [simp]: "\<Lambda> \<turnstile> \<iota>\<^sub>r \<cdot> v \<leadsto> \<epsilon> \<cdot> InrV v"
| ev_strl [simp]: "\<Lambda> \<turnstile> \<Xi> \<cdot> InlV v \<leadsto> \<epsilon> \<cdot> v"
| ev_strr [simp]: "\<Lambda> \<turnstile> \<Xi> \<cdot> InrV v \<leadsto> \<epsilon> \<cdot> v"
| ev_csl [simp]: "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InlV v \<leadsto> (\<iota>\<^sub>l \<cdot> f\<^sub>l) \<cdot> v"
| ev_csr [simp]: "\<Lambda> \<turnstile> f\<^sub>l \<bar> f\<^sub>r \<cdot> InrV v \<leadsto> (\<iota>\<^sub>r \<cdot> f\<^sub>r) \<cdot> v"
| ev_dstl [simp]: "\<Lambda> \<turnstile> \<rhd> \<cdot> PairV (InlV v\<^sub>1) v\<^sub>2 \<leadsto> \<epsilon> \<cdot> InlV (PairV v\<^sub>1 v\<^sub>2)"
| ev_dstr [simp]: "\<Lambda> \<turnstile> \<rhd> \<cdot> PairV (InrV v\<^sub>1) v\<^sub>2 \<leadsto> \<epsilon> \<cdot> InrV (PairV v\<^sub>1 v\<^sub>2)"
| ev_app [simp]: "\<Lambda> \<turnstile> $ \<cdot> PairV (FunV e) v \<leadsto> e \<cdot> v"
| ev_arr [simp]: "\<Lambda> \<turnstile> g \<leftarrow> f \<cdot> FunV e \<leadsto> \<epsilon> \<cdot> FunV (g \<cdot> e \<cdot> f)"
| ev_inj [simp]: "\<Lambda> \<turnstile> \<succ>\<^bsub>n\<^esub> \<cdot> v \<leadsto> \<epsilon> \<cdot> InjV n v"
(* Should have n = m, but makes progress harder. Also, typechecking guarantees it.  *)
| ev_outj [simp]: "\<Lambda> \<turnstile> \<prec>\<^bsub>n\<^esub> \<cdot> InjV m v \<leadsto> \<epsilon> \<cdot> v"
| ev_cata [simp]: "var\<^sub>t_bind \<Lambda> n = Some F \<Longrightarrow> \<Lambda> \<turnstile> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<cdot> v \<leadsto> (f \<cdot> \<lparr> f \<rparr>\<^bsub>n\<^esub> \<bullet> F \<cdot> \<prec>\<^bsub>n\<^esub>) \<cdot> v"
| ev_ana [simp]: "var\<^sub>t_bind \<Lambda> n = Some F \<Longrightarrow> \<Lambda> \<turnstile> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> \<cdot> v \<leadsto> (\<succ>\<^bsub>n\<^esub> \<cdot> \<lbrakk> f \<rbrakk>\<^bsub>n\<^esub> \<bullet> F \<cdot> f) \<cdot> v"
| ev_var [simp]: "var\<^sub>e_bind \<Lambda> x = Some e \<Longrightarrow> \<Lambda> \<turnstile> Var x \<cdot> v \<leadsto> e \<cdot> v"

primrec right_inject :: "nat \<Rightarrow> expr" where
  "right_inject 0 = \<iota>\<^sub>l"
| "right_inject (Suc x) = \<iota>\<^sub>r \<cdot> right_inject x"

fun assemble_context\<^sub>c\<^sub>e :: "name \<Rightarrow> nat \<Rightarrow> (name \<times> name list) list \<Rightarrow> (name \<rightharpoonup> expr)" where
  "assemble_context\<^sub>c\<^sub>e n depth [] = Map.empty"
| "assemble_context\<^sub>c\<^sub>e n depth ((x, t) # cts) =
    (assemble_context\<^sub>c\<^sub>e n (Suc depth) cts)(x \<mapsto> \<succ>\<^bsub>n\<^esub> \<cdot> right_inject depth)"

fun assemble_context\<^sub>c\<^sub>v :: "name \<Rightarrow> (name \<times> name list) list \<Rightarrow> (name \<rightharpoonup> val list \<Rightarrow> val)" where
  "assemble_context\<^sub>c\<^sub>v n [] = Map.empty"
| "assemble_context\<^sub>c\<^sub>v n ((x, ts) # cts) = (assemble_context\<^sub>c\<^sub>v n cts)(x \<mapsto> \<lambda>vs. foldr PairV vs UnitV)"

primrec assemble_context' :: "static_environment \<Rightarrow> decl \<Rightarrow> dynamic_environment" where
  "assemble_context' \<Gamma> (TypeDecl x cts) =
    \<lparr> var\<^sub>e_bind = assemble_context\<^sub>c\<^sub>e x 0 cts, var\<^sub>t_bind = [x := typecheck\<^sub>c\<^sub>t\<^sub>s \<Gamma> x cts] \<rparr>"
| "assemble_context' \<Gamma> (ExprDecl x e) = empty_dynamic \<lparr> var\<^sub>e_bind := [x \<mapsto> e] \<rparr>"

inductive assemble_context :: "static_environment \<Rightarrow> decl list \<Rightarrow> dynamic_environment \<Rightarrow> bool" where
  [simp]: "assemble_context \<Gamma> [] empty_dynamic"
| [simp]: "\<Gamma> \<Turnstile> \<delta> : \<Gamma>' \<Longrightarrow> assemble_context \<Gamma>' \<Delta> \<Lambda> \<Longrightarrow>
    assemble_context \<Gamma> (\<delta> # \<Delta>) (combine\<^sub>d (assemble_context' \<Gamma> \<delta>) \<Lambda>)"

inductive_cases [elim]: "assemble_context \<Gamma> [] \<Lambda>"
inductive_cases [elim]: "assemble_context \<Gamma> (\<delta> # \<Delta>) \<Lambda>"

primrec is_completed :: "prog \<Rightarrow> bool" where
  "is_completed (Prog \<Delta> e v) = (e = \<epsilon>)"

inductive evaluate_prog :: "prog \<Rightarrow> prog \<Rightarrow> bool" (infix "\<leadsto>" 60) where
  ev_prog [simp]: "assemble_context empty_static \<Delta> \<Lambda> \<Longrightarrow> \<Lambda> \<turnstile> e \<cdot> v \<leadsto> e' \<cdot> v' \<Longrightarrow>
    Prog \<Delta> e v \<leadsto> Prog \<Delta> e' v'"

inductive_cases [elim]: "Prog \<Delta> e v \<leadsto> \<Pi>"

(* useful properties *)

lemma [simp]: "var\<^sub>t_bind (extend\<^sub>e\<^sub>d x e \<Lambda>) = var\<^sub>t_bind \<Lambda>"
  by (simp add: extend\<^sub>e\<^sub>d_def)

end


header {* Refinement and Simulation *}

theory Refinement
imports Denotational_Semantics Circus_Syntax
begin

subsection {* Definitions *}

text {* In the following, data (state) simulation and functional backwards simulation
 are defined. The simulation is defined as a function $S$, that corresponds to a state
 abstraction function.*}

definition "Simul S b = extend (make (ok b) (wait b) (tr b) (ref b)) (S (more b))"

definition
Simulation::"('\<theta>::ev_eq,'\<sigma>) action \<Rightarrow> ('\<sigma>1 \<Rightarrow> '\<sigma>) \<Rightarrow> ('\<theta>, '\<sigma>1) action \<Rightarrow> bool" ("_ \<preceq>_ _")
where
"A \<preceq>S B \<equiv> \<forall> a b. (relation_of B) (a, b) \<longrightarrow> (relation_of A) (Simul S a, Simul S b)"

subsection {* Proofs *}

text {* In order to simplify refinement proofs, some general refinement laws are
defined to deal with the refinement of Circus actions at operators level and not at UTP level.
Using these laws, and exploiting the advantages of a shallow embedding, the automated proof of
refinement becomes surprisingly simple. *}

lemma Stop_Sim: "Stop \<preceq>S Stop"
by (auto simp: Simulation_def relation_of_Stop rp_defs design_defs Simul_def alpha_rp.defs
         split: cond_splits)

lemma Skip_Sim: "Skip \<preceq>S Skip"
by (auto simp: Simulation_def relation_of_Skip design_def rp_defs Simul_def alpha_rp.defs
         split: cond_splits)

lemma Chaos_Sim: "Chaos \<preceq>S Chaos"
by (auto simp: Simulation_def relation_of_Chaos rp_defs design_defs Simul_def alpha_rp.defs
         split: cond_splits)

lemma Ndet_Sim:
  assumes A: "P  \<preceq>S Q" and B: "P' \<preceq>S Q'"
  shows "(P \<sqinter> P') \<preceq>S (Q \<sqinter> Q')"
by (insert A B, auto simp: Simulation_def relation_of_Ndet)

lemma Det_Sim:
  assumes A: "P  \<preceq>S Q" and B: "P' \<preceq>S Q'"
  shows "(P \<box> P') \<preceq>S (Q \<box> Q')"
by (auto simp: Simulation_def relation_of_Det design_def rp_defs Simul_def alpha_rp.defs spec_def
         split: cond_splits
         dest: A[simplified Simulation_def Simul_def, rule_format]
               B[simplified Simulation_def Simul_def, rule_format])

lemma Schema_Sim:
  assumes A: "\<And> a. (Pre sc1) (S a) \<Longrightarrow> (Pre sc2) a"
  and B: "\<And> a b. \<lbrakk>Pre sc1 (S a) ; sc2 (a, b)\<rbrakk> \<Longrightarrow> sc1 (S a, S b)"
  shows "(Schema sc1) \<preceq>S (Schema sc2)"
by (auto simp: Simulation_def Simul_def relation_of_Schema rp_defs design_defs alpha_rp.defs A B
         split: cond_splits)

lemma SUb_Sim:
  assumes A: "\<And> a. (Pre sc1) (S a) \<Longrightarrow> (Pre sc2) a"
  and B: "\<And> a b. \<lbrakk>Pre sc1 (S a) ; sc2 (a, b)\<rbrakk> \<Longrightarrow> sc1 (S a, S b)"
  and C: "P \<preceq>S Q"
  shows "(state_update_before sc1 P) \<preceq>S (state_update_before sc2 Q)"
apply (auto simp: Simulation_def Simul_def relation_of_state_update_before rp_defs design_defs alpha_rp.defs A B
         split: cond_splits)
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (case_tac "ok aa", simp_all)
apply (erule notE) back
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (rule A)
apply (case_tac "Pre sc1 (S (alpha_rp.more aa))", simp_all)
apply (erule notE) back
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (drule C[simplified Simulation_def, rule_format])
apply (rule_tac b="Simul S ba" in comp_intro)
apply (auto simp: A B Simul_def alpha_rp.defs)
apply (clarsimp split: cond_splits)+
apply (rule B, auto)
done

lemma Seq_Sim:
  assumes A: "P \<preceq>S Q" and B: "P' \<preceq>S Q'"
  shows "(P `;` P') \<preceq>S (Q `;` Q')"
by (auto simp: Simulation_def relation_of_Seq dest: A[simplified Simulation_def, rule_format]
                                                    B[simplified Simulation_def, rule_format])

lemma Par_Sim:
  assumes A: " P  \<preceq>S Q" and B: " P' \<preceq>S Q'"
  and C: "\<And> a b. S (ns'2 a b) = ns2 (S a) (S b)"
  and D: "\<And> a b. S (ns'1 a b) = ns1 (S a) (S b)"
  shows "(P \<lbrakk> ns1 | cs | ns2 \<rbrakk> P') \<preceq>S (Q \<lbrakk> ns'1 | cs | ns'2 \<rbrakk> Q')"
  apply (auto simp: Simulation_def relation_of_Par fun_eq_iff rp_defs Simul_def design_defs spec_def
                    alpha_rp.defs
              dest: A[simplified Simulation_def Simul_def, rule_format]
                    B[simplified Simulation_def Simul_def, rule_format])
  apply (split cond_splits)+
  apply (simp, erule disjE, rule disjI1, simp, rule disjI2, simp_all, rule impI)
  apply (auto)
  apply (erule_tac x="tr ba" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S ba\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: A[simplified Simulation_def Simul_def, rule_format])
  apply (erule_tac x="tr bb" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S bb\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: B[simplified Simulation_def Simul_def, rule_format])
  apply (erule_tac x="tr ba" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S ba\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: A[simplified Simulation_def Simul_def, rule_format])
  apply (erule_tac x="tr bb" in allE, auto)
  apply (erule notE) back
  apply (rule_tac b="Simul S bb\<lparr>ok := False\<rparr>" in comp_intro)
  apply (auto simp: Simul_def alpha_rp.defs dest: B[simplified Simulation_def Simul_def, rule_format])
  apply (rule_tac x="Simul S s1" in exI)
  apply (rule_tac x="Simul S s2" in exI)
  apply (auto simp: Simul_def alpha_rp.defs
              dest!: B[simplified Simulation_def Simul_def, rule_format]
                     A[simplified Simulation_def Simul_def, rule_format]
              split: cond_splits)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto simp add: M_par_def alpha_rp.defs diff_tr_def fun_eq_iff ParMerge_def Simul_def
            split : cond_splits)
  apply (rule_tac b="\<lparr>ok = ok bb, wait = wait bb, tr = tr bb, ref = ref bb,
              \<dots> = S (alpha_rp.more bb)\<rparr>" in comp_intro, auto)
  apply (subst D[where a="(alpha_rp.more s1)" and b="(alpha_rp.more aa)", symmetric], simp)
  apply (subst C[where a="(alpha_rp.more s2)" and b="(alpha_rp.more bb)", symmetric], simp)
  apply (rule_tac b="\<lparr>ok = ok bb, wait = wait bb, tr = tr bb, ref = ref bb,
              \<dots> = S (alpha_rp.more bb)\<rparr>" in comp_intro, auto)
  apply (subst D[where a="(alpha_rp.more s1)" and b="(alpha_rp.more aa)", symmetric], simp)
  apply (subst C[where a="(alpha_rp.more s2)" and b="(alpha_rp.more bb)", symmetric], simp)
done

lemma Assign_Sim:
  assumes A: "\<And> A. vy A = vx (S A)"
  and B: "\<And> ff A. (S (y_update ff A)) = x_update ff (S A)"
  shows "(x `:=` vx) \<preceq>S (y `:=` vy)"
by (auto simp: Simulation_def relation_of_Assign update_def rp_defs design_defs Simul_def A B
                   alpha_rp.defs split: cond_splits)

lemma Var_Sim:
  assumes A: "P \<preceq>S Q" and B: "\<And> ff A. (S ((snd b) ff A)) = (snd a) ff (S A)"
  shows "(Var a P) \<preceq>S (Var b Q)"
  apply (auto simp: Simulation_def relation_of_Var rp_defs design_defs fun_eq_iff Simul_def B
                    alpha_rp.defs increase_def decrease_def)
  apply (rule_tac b="Simul S ab" in comp_intro)
  apply (split cond_splits)+
  apply (auto simp: B alpha_rp.defs Simul_def elim!: alpha_rp_eqE)
  apply (rule_tac b="Simul S bb" in comp_intro)
  apply (split cond_splits)+
  apply (auto simp: B alpha_rp.defs Simul_def
              elim!: alpha_rp_eqE dest!: A[simplified Simulation_def Simul_def, rule_format])
  apply (split cond_splits)+
  apply (simp add: alpha_rp.defs)
  apply (erule disjE, rule disjI1, simp, rule disjI2, simp)
  apply (simp_all add: alpha_rp.defs true_def)
  apply (rule impI, (erule conjE | simp)+)
  apply (simp add: B)
  apply (split cond_splits)+
  apply (simp add: alpha_rp.defs)
  apply (erule disjE, rule disjI1, simp, rule disjI2, simp_all)
  apply (rule impI, (erule conjE | simp)+)
  apply (simp add: B)
done

lemma Guard_Sim:
  assumes A: "P \<preceq>S Q" and B: "\<And> A. h A = g (S A)"
  shows "(g `&` P) \<preceq>S (h `&` Q)"
apply (auto simp: Simulation_def)
apply (case_tac "h (alpha_rp.more a)")
defer
apply (case_tac "g (S (alpha_rp.more a))")
apply (auto simp: true_Guard1 false_Guard1 Simul_def alpha_rp.defs Simulation_def B
            dest!: A[simplified, rule_format] Stop_Sim[simplified, rule_format])
done

lemma Write0_Sim:
  assumes A: "P \<preceq>S Q"
  shows "a \<rightarrow> P \<preceq>S a \<rightarrow> Q "
  using   A
  apply (auto simp: Simulation_def write0_def relation_of_Prefix0 design_defs rp_defs)
  apply (erule_tac x="ba" in allE)
  apply (erule_tac x="c" in allE, auto)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_def)
done

lemma Read_Sim:
  assumes A: " P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)"
  shows "a`?`c \<rightarrow> P \<preceq>S a`?`d \<rightarrow> Q"
  using A
  apply (auto simp: Simulation_def read_def relation_of_iPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_I_def select_def B)
done

lemma Read1_Sim:
  assumes A: " P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)"
  shows "a`?`c`:`s \<rightarrow> P \<preceq>S a`?`d`:`s \<rightarrow> Q"
  using A
  apply (auto simp: Simulation_def read1_def relation_of_iPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_I_def select_def B)
done

lemma Read1S_Sim:
  assumes A: " P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)" and C: "\<And> A. (s' A) = s (S A)"
  shows "a`?`c`\<in>`s \<rightarrow> P \<preceq>S a`?`d`\<in>`s' \<rightarrow> Q"
  using A
  apply (auto simp: Simulation_def read1_def relation_of_iPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_I_def select_def B C)
done

lemma Write_Sim:
  assumes A: "P \<preceq>S Q" and B: "\<And> A. (d A) = c (S A)"
  shows "a`!`c \<rightarrow> P \<preceq>S a`!`d \<rightarrow> Q "
  using A
  apply (auto simp: Simulation_def write1_def relation_of_oPrefix design_defs rp_defs)
  apply (erule_tac x="ba" in allE, erule_tac x="ca" in allE, simp)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (auto split: cond_splits simp: Simul_def alpha_rp.defs do_def select_def B)
done

lemma Hide_Sim:
  assumes A: " P \<preceq>S Q"
  shows "(P \\ cs) \<preceq>S (Q \\ cs)"
  apply (auto simp: Simulation_def relation_of_Hide design_defs rp_defs Simul_def alpha_rp.defs)
  apply (rule_tac b="Simul S ba" in comp_intro)
  apply (split cond_splits)+
  apply (auto simp: Simul_def alpha_rp.defs Simulation_def
              dest!: A[simplified, rule_format] Skip_Sim[simplified, rule_format])
  apply (rule_tac x=s in exI, auto simp: diff_tr_def)
done

lemma lfp_Siml:
  assumes A: "\<And> X. (X \<preceq>S Q) \<Longrightarrow> ((P X) \<preceq>S Q)" and B: "mono P"
  shows "(lfp P) \<preceq>S Q"
  apply (rule lfp_ordinal_induct, auto simp: B A)
  apply (auto simp add: Simulation_def Sup_action relation_of_bot relation_of_Sup[simplified])
  apply (subst (asm) CSP_is_rd[OF relation_of_CSP])
  apply (auto simp: rp_defs fun_eq_iff Simul_def alpha_rp.defs decrease_def split: cond_splits)
done

lemma Mu_Sim:
  assumes A: "\<And> X Y. X \<preceq>S Y \<Longrightarrow> (P X) \<preceq>S (Q Y)"
  and B: "mono P" and C: "mono Q"
  shows "(lfp P) \<preceq>S (lfp Q) "
  apply (rule lfp_Siml, drule A)
  apply (subst lfp_unfold, simp_all add: B C)
done

lemma bot_Sim: "bot \<preceq>S bot"
by (auto simp: Simulation_def rp_defs Simul_def relation_of_bot alpha_rp.defs split: cond_splits)

lemma sim_is_ref: "P \<sqsubseteq> Q = P \<preceq>(id) Q"
apply (auto simp: ref_def Simulation_def Simul_def alpha_rp.defs)
apply (erule_tac x=a in allE)
apply (erule_tac x=b in allE, auto)
apply (rule_tac t="\<lparr>ok = ok a, wait = wait a, tr = tr a, ref = ref a, \<dots> = alpha_rp.more a\<rparr>" and s=a in subst, simp)
apply (rule_tac t="\<lparr>ok = ok b, wait = wait b, tr = tr b, ref = ref b, \<dots> = alpha_rp.more b\<rparr>" and s=b in subst, simp_all)
apply (erule_tac x=a in allE)
apply (erule_tac x=b in allE, auto)
apply (rule_tac s="\<lparr>ok = ok a, wait = wait a, tr = tr a, ref = ref a, \<dots> = alpha_rp.more a\<rparr>" and t=a in subst, simp)
apply (rule_tac s="\<lparr>ok = ok b, wait = wait b, tr = tr b, ref = ref b, \<dots> = alpha_rp.more b\<rparr>" and t=b in subst, simp_all)
done

lemma ref_eq: "((P::('a::ev_eq,'b) action) = Q) = (P \<sqsubseteq> Q & Q \<sqsubseteq> P)"
apply (rule)
apply (simp add: ref_def)
apply (auto simp add: ref_def fun_eq_iff relation_of_inject[symmetric])
done

lemma rd_ref:
assumes A:"R (P \<turnstile> Q) \<in> {p. is_CSP_process p}"
and B:"R (P' \<turnstile> Q') \<in> {p. is_CSP_process p}"
and C:"\<And> a b. P (a, b) \<Longrightarrow> P' (a, b)"
and D:"\<And> a b. Q' (a, b) \<Longrightarrow> Q (a, b)"
shows "(action_of (R (P \<turnstile> Q))) \<sqsubseteq> (action_of (R (P' \<turnstile> Q')))"
apply (auto simp: ref_def)
apply (subst (asm) action_of_inverse, simp add: B[simplified])
apply (subst action_of_inverse, simp add: A[simplified])
apply (auto simp: rp_defs design_defs C D split: cond_splits)
done

lemma rd_impl:
assumes A:"R (P \<turnstile> Q) \<in> {p. is_CSP_process p}"
and B:"R (P' \<turnstile> Q') \<in> {p. is_CSP_process p}"
and C:"\<And> a b. P (a, b) \<Longrightarrow> P' (a, b)"
and D:"\<And> a b. Q' (a, b) \<Longrightarrow> Q (a, b)"
shows "R (P' \<turnstile> Q') (a, b) \<longrightarrow> R (P \<turnstile> Q) (a::('a::ev_eq, 'b) alpha_rp_scheme, b)"
apply (insert rd_ref[of P Q P' Q', OF A B C D])
apply (auto simp: ref_def)
apply (atomize, auto)
apply (subst (asm) action_of_inverse, simp add: B[simplified])
apply (subst (asm) action_of_inverse, simp add: A[simplified])
apply (erule_tac x=a in allE)
apply (erule_tac x=b in allE)
apply (auto)
done

end