text\<open>
Interpreter.thy defines a simple programming language over interval-valued variables and executable
semantics (interpreter) for that language. We then prove that the interpretation of interval terms
is a sound over-approximation of a real-valued semantics of the same language.

Our language is a version of first order dynamic logic-style regular programs.
We use a finite identifier space for compatibility with Differential-Dynamic-Logic, where identifier
finiteness is required to treat program states as Banach spaces to enable differentiation.
\<close>
(* Author:     Brandon Bohrer *)
theory Interpreter
imports
  Complex_Main
  "./Finite_String"
  Interval_Word32
  Word_Lib.Word_Lemmas
  Word_Lib.Word_Lib
  Word_Lib.Word_Syntax
begin

section\<open>Syntax\<close>
text\<open>Our term language supports variables, polynomial arithmetic, and extrema. This choice was made
   based on the needs of the original paper and could be extended if necessary.\<close>
datatype  trm =
  Var fin_string
| Const lit
| Plus trm trm
| Times trm trm
| Neg trm
| Max trm trm
| Min trm trm
| Abs trm

text\<open>Our statement language is nondeterministic first-order regular programs.
 This coincides with the discrete subset of hybrid programs from the dL entry.

Our assertion language are the formulas of first-order dynamic logic\<close>
datatype prog =
  Assign fin_string "trm"     (infixr ":=" 10)
| AssignAny fin_string
| Test "formula"              ("?")
| Choice "prog" "prog"        (infixl "\<union>\<union>" 10)
| Sequence "prog"  "prog"     (infixr ";;" 8)
| Loop "prog"                 ("_**")

and formula =
  Geq "trm" "trm"
| Not "formula"                        ("!")
| And "formula" "formula"              (infixl "&&" 8)
| Exists fin_string "formula"
| Diamond "prog" "formula"               ("(\<langle> _ \<rangle> _)" 10)

text\<open>Derived forms\<close>
definition Or :: "formula \<Rightarrow> formula \<Rightarrow> formula" (infixl "||" 7)
where or_simp[simp]:"Or P Q = Not (And (Not P) (Not Q))"

definition Equals :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where equals_simp[simp]:"Equals \<theta> \<theta>' = (And (Geq \<theta> \<theta>') (Geq \<theta>' \<theta>))"

definition Greater :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where greater_simp[simp]:"Greater \<theta> \<theta>' = Not (Geq \<theta>' \<theta>)"

definition Leq :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where leq_simp[simp]:"Leq \<theta> \<theta>' = (Geq \<theta>' \<theta>)"

definition Less :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where less_simp[simp]:"Less \<theta> \<theta>' = (Not (Geq \<theta> \<theta>'))"

section \<open>Semantics\<close>
text\<open> States over reals vs. word intervals which contain them\<close>
type_synonym rstate = "fin_string \<Rightarrow> real"
type_synonym wstate = "(fin_string + fin_string) \<Rightarrow> word"

definition wstate::"wstate \<Rightarrow> prop"
where wstate_def[simp]:"wstate \<nu> \<equiv> (\<And>i. word (\<nu> (Inl i)) \<and> word (\<nu> (Inr i)))"

text\<open>Interpretation of a term in a state\<close>
inductive rtsem :: "trm \<Rightarrow> rstate \<Rightarrow> real  \<Rightarrow> bool"  ("([_]_ \<down> _)" 10)
  where
  rtsem_Const:"Rep_bword w \<equiv>\<^sub>E r \<Longrightarrow> ([Const w]\<nu> \<down> r)"
| rtsem_Var:"([Var x]\<nu> \<down> \<nu> x)"
| rtsem_Plus:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (r1 + r2))"
| rtsem_Times:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Times \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (r1 * r2))"
| rtsem_Max:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Max \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (max r1 r2))"
| rtsem_Min:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Min \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (min r1 r2))"
| rtsem_Abs:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1)\<rbrakk> \<Longrightarrow> ([Abs \<theta>\<^sub>1]\<nu> \<down> (abs r1))"
| rtsem_Neg:"([\<theta>]\<nu> \<down> r) \<Longrightarrow> ([Neg \<theta>]\<nu> \<down> -r)"

inductive_simps
    rtsem_Const_simps[simp] : "([(Const w)]\<nu> \<down> r)"
and rtsem_Var_simps[simp] : "([Var x]\<nu> \<down> r)"
and rtsem_PlusU_simps[simp] : "([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> r)"
and rtsem_TimesU_simps[simp] : "([Times \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> r)"
and rtsem_Max_simps[simp] : "([Max \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<down> r)"
and rtsem_Min_simps[simp] : "([Min \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<down> r)"
and rtsem_Abs_simps[simp] : "([Abs \<theta>] \<nu> \<down> r)"
and rtsem_Neg_simps[simp] : "([Neg \<theta>] \<nu> \<down> r)"

definition set_less :: "real set \<Rightarrow> real set \<Rightarrow> bool" (infix "<\<^sub>S" 10)
where "set_less A B \<equiv> (\<forall> x y. x \<in> A \<and> y \<in> B \<longrightarrow> x < y)"

definition set_geq :: "real set \<Rightarrow> real set \<Rightarrow> bool" (infix "\<ge>\<^sub>S" 10)
where "set_geq A B \<equiv> (\<forall> x y. x \<in> A \<and> y \<in> B \<longrightarrow> x \<ge> y)"

text\<open>Interpretation of an assertion in a state\<close>
inductive rfsem :: "formula \<Rightarrow> rstate \<Rightarrow> bool \<Rightarrow> bool" ("([_]_) \<downharpoonright> _" 20)
where
  rGreaterT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 > r2 \<Longrightarrow> ([Greater \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rGreaterF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r2 \<ge> r1 \<Longrightarrow> ([Greater \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rGeqT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 \<ge> r2 \<Longrightarrow> ([Geq \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rGeqF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r2 > r1 \<Longrightarrow> ([Geq \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rEqualsT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 = r2 \<Longrightarrow> ([Equals \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rEqualsF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 \<noteq> r2 \<Longrightarrow> ([Equals \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rAndT:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> True); ([\<psi>]\<nu> \<downharpoonright> True)\<rbrakk> \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rAndF1:"([\<phi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rAndF2:"([\<psi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rOrT1:"([\<phi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([Or \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rOrT2:"([\<psi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([Or \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rOrF:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> False) ;([\<psi>]\<nu> \<downharpoonright> False)\<rbrakk> \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rNotT:"([\<phi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([(Not \<phi>)]\<nu> \<downharpoonright> True)"
| rNotF:"([\<phi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([(Not \<phi>)]\<nu> \<downharpoonright> False)"

inductive_simps
    rfsem_Greater_simps[simp]: "([Greater \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_Geq_simps[simp]: "([Geq \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_Equals_simps[simp]: "([Equals \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_And_simps[simp]: "([And \<phi>  \<psi>]\<nu> \<downharpoonright> b)"
and rfsem_Or_simps[simp]: "([(Or \<phi> \<psi>)]\<nu> \<downharpoonright> b)"
and rfsem_Not_simps[simp]: "([Not \<phi>]\<nu> \<downharpoonright> b)"

text\<open>Interpretation of a program is a transition relation on states\<close>
inductive rpsem :: "prog \<Rightarrow> rstate \<Rightarrow>  rstate \<Rightarrow> bool" ("([_]_) \<downharpoonleft> _" 20)
where
  rTest[simp]:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> True); \<nu> = \<omega>\<rbrakk> \<Longrightarrow> ([? \<phi>]\<nu> \<downharpoonleft> \<omega>)"
| rSeq[simp]:"\<lbrakk>([\<alpha>]\<nu> \<downharpoonleft> \<mu>); ([\<beta>]\<mu> \<downharpoonleft> \<omega>)\<rbrakk> \<Longrightarrow> ([\<alpha>;; \<beta>]\<nu> \<downharpoonleft> \<omega>)"
| rAssign[simp]:"\<lbrakk>([\<theta>]\<nu> \<down> r); \<omega> = (\<nu> (x := r))\<rbrakk> \<Longrightarrow> ([Assign x \<theta>]\<nu> \<downharpoonleft> \<omega>)"
| rChoice1[simp]:"([\<alpha>]\<nu> \<downharpoonleft> \<omega>) \<Longrightarrow> ([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> \<omega>)"
| rChoice2[simp]:"([\<beta>]\<nu> \<downharpoonleft> \<omega>) \<Longrightarrow> ([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> \<omega>)"

inductive_simps
    rpsem_Test_simps[simp]: "([? \<phi>]\<nu> \<downharpoonleft> b)"
and rpsem_Seq_simps[simp]: "([\<alpha>;; \<beta>]\<nu> \<downharpoonleft> b)"
and rpsem_Assign_simps[simp]: "([Assign x \<theta>]\<nu> \<downharpoonleft> b)"
and rpsem_Choice_simps[simp]: "([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> b)"

text\<open>Upper bound of arbitrary term\<close>
fun wtsemU :: "trm \<Rightarrow> wstate \<Rightarrow>  word * word " ("([_]<>_)" 20)
where "([Const r]<>\<nu>) = (Rep_bword r::word, Rep_bword r)"
| wVarU:"([Var x]<>\<nu>) = (\<nu> (Inl x), \<nu> (Inr x))"
| wPlusU:"([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
   (pl l1 l2, pu u1 u2))"
| wTimesU:"([(Times \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
   (tl l1 u1 l2 u2, tu l1 u1 l2 u2))"
| wMaxU:"([(Max \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
  (wmax l1 l2, wmax u1 u2))"
| wMinU:"([(Min \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
  (wmin l1 l2, wmin u1 u2))"
| wNegU:"([(Neg \<theta>)]<> \<nu>) =
  (let (l, u) = [\<theta>]<> \<nu> in
   (wneg u, wneg l))"
| wAbsU:"([(Abs \<theta>\<^sub>1)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
  (wmax l1 (wneg u1), wmax u1 (wneg l1)))"

inductive wfsem :: "formula \<Rightarrow> wstate \<Rightarrow> bool \<Rightarrow> bool" ("([[_]]_ \<down> _)" 20)
where
  wGreaterT:"wgreater (fst ([\<theta>\<^sub>1]<>\<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[(Greater \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> True)"
| wGreaterF:"wgeq (fst ([\<theta>\<^sub>2]<>\<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[(Greater \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> False)"
| wGeqT:"wgeq (fst ([\<theta>\<^sub>1]<> \<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[(Geq \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> True)"
| wGeqF:"wgreater (fst ([\<theta>\<^sub>2]<>\<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[(Geq \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> False)"
| wEqualsT:"\<lbrakk>(fst ([\<theta>\<^sub>2]<>\<nu>) = snd ([\<theta>\<^sub>2]<>\<nu>)); (snd ([\<theta>\<^sub>2]<>\<nu>) = snd ([\<theta>\<^sub>1]<>\<nu>));
             (snd ([\<theta>\<^sub>1]<>\<nu>) = fst ([\<theta>\<^sub>1]<>\<nu>)); (fst ([\<theta>\<^sub>2]<>\<nu>) \<noteq> NEG_INF);
             (fst ([\<theta>\<^sub>2]<>\<nu>) \<noteq> POS_INF)\<rbrakk>
         \<Longrightarrow> ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> True)"
| wEqualsF1:"wgreater (fst ([\<theta>\<^sub>1]<> \<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> False)"
| wEqualsF2:"wgreater (fst ([\<theta>\<^sub>2]<> \<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> False)"
| wAndT:"\<lbrakk>[[\<phi>]]\<nu> \<down> True; [[\<psi>]]\<nu> \<down> True\<rbrakk> \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> True)"
| wAndF1:"[[\<phi>]]\<nu> \<down> False \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wAndF2:"[[\<psi>]]\<nu> \<down> False \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wOrT1:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> ([[Or \<phi> \<psi>]]\<nu> \<down> True)"
| wOrT2:"([[\<psi>]]\<nu> \<down> True) \<Longrightarrow> ([[Or \<phi> \<psi>]]\<nu> \<down> True)"
| wOrF:"\<lbrakk>[[\<phi>]]\<nu> \<down> False; [[\<psi>]]\<nu> \<down> False\<rbrakk> \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wNotT:"([[\<phi>]]\<nu> \<down> False) \<Longrightarrow> ([[Not \<phi>]]\<nu> \<down> True)"
| wNotF:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> ([[Not \<phi>]]\<nu> \<down> False)"

inductive_simps
    wfsem_Gr_simps[simp]: "([[Le \<theta>\<^sub>1 \<theta>\<^sub>2]]\<nu> \<down> b)"
and wfsem_And_simps[simp]: "([[And \<phi> \<psi>]]\<nu> \<down> b)"
and wfsem_Or_simps[simp]: "([[Or \<phi> \<psi>]]\<nu> \<down> b)"
and wfsem_Not_simps[simp]: "([[Not \<phi>]]\<nu> \<down> b)"
and wfsem_Equals_simps[simp]: "([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]]\<nu> \<down> b)"

text\<open>Program semantics\<close>
inductive wpsem :: "prog \<Rightarrow>  wstate \<Rightarrow> wstate \<Rightarrow> bool" ("([[_]]_ \<down> _)" 20)
where
  wTest:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> \<nu> = \<omega> \<Longrightarrow> ([[? \<phi>]] \<nu> \<down> \<omega>)"
| wSeq:"([[\<alpha>]]\<nu> \<down> \<mu>) \<Longrightarrow> ([[\<beta>]] \<mu> \<down> \<omega>) \<Longrightarrow> ([[\<alpha>;; \<beta>]] \<nu> \<down> \<omega>)"
| wAssign:"\<omega> = ((\<nu> ((Inr x) := snd([\<theta>]<>\<nu>))) ((Inl x) := fst([\<theta>]<>\<nu>))) \<Longrightarrow> ([[Assign x \<theta>]] \<nu> \<down> \<omega>)"
| wChoice1[simp]:"([[\<alpha>]]\<nu> \<down> \<omega>) \<Longrightarrow> ([[Choice \<alpha> \<beta>]]\<nu> \<down> \<omega>)"
| wChoice2[simp]:"([[\<beta>]]\<nu> \<down> \<omega>) \<Longrightarrow> ([[Choice \<alpha> \<beta>]]\<nu> \<down> \<omega>)"

inductive_simps
    wpsem_Test_simps[simp]: "([[Test \<phi>]]\<nu> \<down> b)"
and wpsem_Seq_simps[simp]: "([[\<alpha>;; \<beta>]]\<nu> \<down> b)"
and wpsem_Assign_simps[simp]: "([[Assign x \<theta>]]\<nu> \<down> b)"
and wpsem_Choice_simps[simp]: "([[Choice \<alpha> \<beta>]]\<nu> \<down> b)"

lemmas real_max_mono =  Lattices.linorder_class.max.mono
lemmas real_minus_le_minus = Groups.ordered_ab_group_add_class.neg_le_iff_le

text\<open>Interval state consists of upper and lower bounds for each real variable\<close>
inductive represents_state::"wstate \<Rightarrow> rstate \<Rightarrow> bool" (infix "REP" 10)
where REPI:"(\<And>x. (\<nu> (Inl x) \<equiv>\<^sub>L \<nu>' x) \<and> (\<nu> (Inr x) \<equiv>\<^sub>U \<nu>' x)) \<Longrightarrow> (\<nu> REP \<nu>')"

inductive_simps repstate_simps:"\<nu> REP \<nu>'"

section\<open>Soundness proofs\<close>
text\<open>Interval term valuation soundly contains real valuation\<close>
lemma trm_sound:
  fixes \<theta>::"trm"
  shows "([\<theta>]\<nu>' \<down> r) \<Longrightarrow> (\<nu> REP \<nu>') \<Longrightarrow>   ([\<theta>]<>\<nu>) \<equiv>\<^sub>P r"
proof (induction rule: rtsem.induct)
 case rtsem_Const
   fix w r \<nu>'
   show "Rep_bword w \<equiv>\<^sub>E r \<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> [Const w]<>\<nu> \<equiv>\<^sub>P r"
     using repU_def repL_def repP_def repe.simps rep_simps repstate_simps
     by auto
next
 case rtsem_Var
   fix x \<nu>'
   show "\<nu> REP \<nu>' \<Longrightarrow> [Var x]<>\<nu> \<equiv>\<^sub>P \<nu>' x"
   by(auto simp add: repU_def repL_def repP_def repe.simps rep_simps repstate_simps)
next
 case rtsem_Plus
   fix \<theta>\<^sub>1 :: "trm" and \<nu>':: "rstate" and r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume rep:"\<nu> REP \<nu>'"
   assume eval1:"[\<theta>\<^sub>1]\<nu>' \<down> r1"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume eval2:"[\<theta>\<^sub>2]\<nu>' \<down> r2"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"(l1, u1) = ([\<theta>\<^sub>1]<> \<nu>)"
    and lu2:"(l2, u2) = ([\<theta>\<^sub>2]<> \<nu>)"
    using IH1 IH2 repP_def by auto
   from lu1 and lu2 have
        lu1':"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2':"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    by auto
  have l1:"l1 \<equiv>\<^sub>L r1" using IH1 lu1 unfolding repP_def by auto
  have u1:"u1 \<equiv>\<^sub>U r1" using IH1 lu1 unfolding repP_def by auto
  have l2:"l2 \<equiv>\<^sub>L r2" using IH2 lu2 unfolding repP_def by auto
  have u2:"u2 \<equiv>\<^sub>U r2" using IH2 lu2 unfolding repP_def by auto
  then have "([(Plus \<theta>\<^sub>1 \<theta>\<^sub>2)]<>\<nu>) = (pl l1 l2, pu u1 u2)"
   using lu1' lu2' by auto
  have lBound:"(pl l1 l2 \<equiv>\<^sub>L r1 + r2)"
    using l1 l2 pl_lemma by auto
  have uBound:"(pu u1 u2 \<equiv>\<^sub>U r1 + r2)"
    using pu_lemma[OF u1 u2] by auto
  have "(pl l1 l2, pu u1 u2) \<equiv>\<^sub>P (r1 + r2)"
    unfolding repP_def Let_def using lBound uBound by auto
  then show"[Plus \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r1 + r2"
    using lu1' lu2' by auto
next
 case rtsem_Times
   fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and r2
   assume eval1:"[\<theta>\<^sub>1]\<nu>' \<down> r1"
   assume eval2:"[\<theta>\<^sub>2]\<nu>' \<down> r2"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> ([\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1))"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> ([\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2))"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
    obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1) "
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
  have l1:"l1 \<equiv>\<^sub>L r1" using IH1 lu1 unfolding repP_def by auto
  have u1:"u1 \<equiv>\<^sub>U r1" using IH1 lu1 unfolding repP_def by auto
  have l2:"l2 \<equiv>\<^sub>L r2" using IH2 lu2 unfolding repP_def by auto
  have u2:"u2 \<equiv>\<^sub>U r2" using IH2 lu2 unfolding repP_def by auto
  then have "([(Times \<theta>\<^sub>1  \<theta>\<^sub>2)]<>\<nu>) = (tl l1 u1 l2 u2, tu l1 u1 l2 u2)"
   using lu1 lu2 unfolding wTimesU Let_def by auto
  have lBound:"(tl l1 u1 l2 u2 \<equiv>\<^sub>L r1 * r2)"
    using l1 u1 l2 u2 tl_lemma by auto
  have uBound:"(tu l1 u1 l2 u2 \<equiv>\<^sub>U r1 * r2)"
    using l1 u1 l2 u2 tu_lemma by auto
  have "(tl l1 u1 l2 u2, tu l1 u1 l2 u2) \<equiv>\<^sub>P (r1 * r2)"
    unfolding repP_def Let_def using lBound uBound by auto
  then show "[Times \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r1 * r2"
    using lu1 lu2 by auto
next
 case rtsem_Max
   fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume eval1:"([\<theta>\<^sub>1]\<nu>' \<down> r1)"
   assume eval2:"([\<theta>\<^sub>2]\<nu>' \<down> r2)"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
   from IH1 IH2
   obtain ub1 ub2 lb1 lb2:: real
   where urep1:"(ub1 \<ge> r1) \<and> (snd ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E ub1)"
   and   urep2:"(ub2 \<ge> r2) \<and> (snd ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E ub2)"
   and   lrep1:"(lb1 \<le> r1) \<and> (fst ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E lb1)"
   and   lrep2:"(lb2 \<le> r2) \<and> (fst ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E lb2)"
     using repP_def repU_def repL_def by auto
   have lbound:"wmax l1 l2 \<equiv>\<^sub>L max r1 r2"
     by (metis dual_order.trans fst_conv le_cases lrep1 lrep2 lu1 lu2 max_def repL_def wmax.elims)
   have ubound:"wmax u1 u2 \<equiv>\<^sub>U max r1 r2"
     by (metis real_max_mono lu1 lu2 repU_def snd_conv urep1 urep2 wmax_lemma)
   have "([trm.Max \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu>) = (wmax l1 l2, wmax u1 u2)"
     using lu1 lu2 unfolding wMaxU Let_def
     by (simp)
   then show "[trm.Max \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P max r1 r2"
    unfolding repP_def
    using lbound ubound lu1 lu2 by auto
next
  case rtsem_Min
    fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume eval1:"([\<theta>\<^sub>1]\<nu>' \<down> r1)"
   assume eval2:"([\<theta>\<^sub>2]\<nu>' \<down> r2)"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
   from IH1 IH2
   obtain ub1 ub2 lb1 lb2:: real
   where urep1:"(ub1 \<ge> r1) \<and> (snd ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E ub1)"
   and   urep2:"(ub2 \<ge> r2) \<and> (snd ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E ub2)"
   and   lrep1:"(lb1 \<le> r1) \<and> (fst ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E lb1)"
   and   lrep2:"(lb2 \<le> r2) \<and> (fst ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E lb2)"
     using prod.case_eq_if repP_def  repU_def repL_def by auto
   have lbound:"wmin l1 l2 \<equiv>\<^sub>L min r1 r2"
     by (metis fst_conv lrep1 lrep2 lu1 lu2 min.mono repL_def wmin_lemma)
   have ubound:"wmin u1 u2 \<equiv>\<^sub>U min r1 r2"
     using lu1 lu2 min_le_iff_disj repU_def urep1 urep2 by auto
   have "([Min \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu>) = (wmin l1 l2, wmin u1 u2)"
     using lu1 lu2 unfolding wMinU Let_def by auto
  then show "[Min \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P min r1 r2"
    unfolding repP_def
    using lbound ubound lu1 lu2 by auto
next
  case rtsem_Neg
  fix \<theta> :: "trm" and \<nu>' r
  assume eval:"[\<theta>]\<nu>' \<down> r"
  assume rep:"\<nu> REP \<nu>'"
  assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>]<>\<nu> \<equiv>\<^sub>P r)"
  then have IH:"[\<theta>]<>\<nu> \<equiv>\<^sub>P r" using rep by auto
  obtain l1 u1  where
        lu:"([\<theta>]<> \<nu>) = (l1, u1)"
    using IH repP_def by auto
  from IH
  obtain ub lb:: real
   where urep:"(ub \<ge> r) \<and> (snd ([\<theta>]<>\<nu>) \<equiv>\<^sub>E ub)"
   and   lrep:"(lb \<le> r) \<and> (fst ([\<theta>]<>\<nu>) \<equiv>\<^sub>E lb)"
    using  repP_def repU_def repL_def by auto
  have ubound:"((wneg u1) \<equiv>\<^sub>L (uminus r))"
    by (metis real_minus_le_minus lu repL_def snd_conv urep wneg_lemma)
  have lbound:"((wneg l1) \<equiv>\<^sub>U (uminus r))"
    using real_minus_le_minus lu repU_def lrep wneg_lemma
    by (metis fst_conv)
  show "[Neg \<theta>]<>\<nu> \<equiv>\<^sub>P - r"
    unfolding repP_def Let_def using ubound lbound lu
    by (auto)
next
  case rtsem_Abs
  fix \<theta> :: "trm" and \<nu>' r
  assume eval:"[\<theta>]\<nu>' \<down> r"
  assume rep:"\<nu> REP \<nu>'"
  assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>]<>\<nu> \<equiv>\<^sub>P r)"
  then have IH:"[\<theta>]<>\<nu> \<equiv>\<^sub>P r" using rep by auto
  obtain l1 u1  where
        lu:"([\<theta>]<> \<nu>) = (l1, u1)"
    using IH repP_def by auto
  from IH
  obtain ub lb:: real
   where urep:"(ub \<ge> r) \<and> (snd ([\<theta>]<>\<nu>) \<equiv>\<^sub>E ub)"
   and   lrep:"(lb \<le> r) \<and> (fst ([\<theta>]<>\<nu>) \<equiv>\<^sub>E lb)"
    using prod.case_eq_if repP_def  repU_def repL_def by auto
  have lbound:"wmax l1 (wneg u1) \<equiv>\<^sub>L (abs r)"
    apply(simp only: repL_def)
    apply(rule exI[where x="max lb (- ub)"])
    apply(rule conjI)
    using lrep wmax_lemma lu urep wneg_lemma by auto
  have ubound:"(wmax u1 (wneg l1) \<equiv>\<^sub>U (abs r))"
    apply(simp only: repU_def)
    apply(rule exI[where x="max ub (- lb)"])
    using lrep wmax_lemma lu urep wneg_lemma by auto
  show "[Abs \<theta>]<>\<nu> \<equiv>\<^sub>P abs r"
    using repP_def Let_def ubound lbound lu lu wAbsU by auto
qed

text\<open>Every word represents some real\<close>
lemma word_rep:"\<And>bw::bword. \<exists>r::real. Rep_bword bw \<equiv>\<^sub>E r"
proof -
  fix bw
  obtain w where weq:"w = Rep_bword bw" by auto
  have negInfCase:"w = NEG_INF \<Longrightarrow> ?thesis bw"
   apply(rule exI[where x="-((2 ^ 31) -1)"])
    using weq by (auto simp add: repe.simps)
  have posInfCase:"w = POS_INF \<Longrightarrow> ?thesis bw"
    apply(rule exI[where x="((2 ^ 31) -1)"])
    using weq by (auto simp add: repe.simps)
  have boundU:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> sint (Rep_bword bw) < sint POS_INF"
    using Rep_bword weq
    by (metis (no_types, lifting) mem_Collect_eq min.absorb_iff2 min_def not_le
        Word.word_sint.Rep_eqD)
  have boundL:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> sint NEG_INF < sint (Rep_bword bw)"
    using Rep_bword weq
    by (metis (no_types, lifting) mem_Collect_eq min.absorb_iff2 min_def not_le
        Word.word_sint.Rep_eqD)
  have intCase:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> ?thesis bw"
    apply(rule exI[where x=" (real_of_int (sint (Rep_bword bw)))"])
    apply(rule repINT)
    using boundU boundL by(auto)
  then show "?thesis bw"
    apply(cases "w = POS_INF")
     apply(cases "w = NEG_INF")
      using posInfCase intCase negInfCase by auto
  qed

text\<open>Every term has a value\<close>
lemma eval_tot:"(\<exists>r. ([\<theta>::trm]\<nu>' \<down> r))"
proof (induction "\<theta>")
qed (auto simp add: Min_def word_rep bword_neg_one_def, blast?)

text\<open>Interval formula semantics soundly implies real semantics\<close>
lemma fml_sound:
  fixes \<phi>::"formula" and \<nu>::"wstate"
  shows "(wfsem \<phi> \<nu> b) \<Longrightarrow>  (\<nu> REP \<nu>') \<Longrightarrow> (rfsem \<phi> \<nu>'  b)"
proof (induction arbitrary: \<nu>' rule: wfsem.induct)
case (wGreaterT t1 v t2 w)
  assume wle:"wgreater (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP w"
  obtain r1 and r2 where eval1:"[t1]w \<down> r1" and  eval2:"[t2]w \<down> r2"
    using eval_tot[of t1 w] eval_tot[of t2 w] by (auto)
  note rep1 = trm_sound[of t1 w r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 w r2, where \<nu>=v, OF eval2 rep]
  show "[Greater t1 t2]w \<downharpoonright> True"
    apply(rule rGreaterT[where ?r1.0 = r1, where ?r2.0 = r2])
    prefer 3
    apply(rule wgreater_lemma[where ?w1.0="fst([t1]<> v)", where ?w2.0="snd([t2]<> v)"])
    using rep1 rep2 wle repP_def repL_def repU_def  eval1 eval2
    by ((simp add: prod.case_eq_if | blast)+)
next
  case (wGreaterF t2 v t1 v')
  assume wl:"wgeq (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v' r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v']  by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Greater t1 t2]v' \<downharpoonright> False"
    apply(rule rGreaterF [of t1 v' r1 t2 r2])
    apply(rule eval1)
     apply(rule eval2)
    apply(rule wgeq_lemma[where ?w1.0="fst([t2]<> v)", where ?w2.0="snd([t1]<> v)"])
    using rep1 rep2 repP_def wgeq_lemma wl rep
    by auto
next
  case (wGeqT t1 v t2 v')
  assume a1:"wgeq (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v' r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v']  by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Geq t1 t2]v' \<downharpoonright> True"
    apply(rule rGeqT)
      apply(rule eval1)
    apply(rule eval2)
  using wgeq_lemma eval1 eval2 rep1 rep2 unfolding repP_def Let_def
  using wgreater_lemma prod.case_eq_if a1
  by auto
next
  case (wGeqF t2 v t1 v')
  assume a1:"wgreater (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Geq t1 t2]v' \<downharpoonright> False"
    apply(rule rGeqF, rule eval1, rule eval2)
  using wgeq_lemma eval1 eval2 rep1 rep2 unfolding repP_def Let_def
  using wgreater_lemma rGreaterF prod.case_eq_if a1 rGreaterF by auto
next
  case (wEqualsT t2 v t1 v')
  assume eq1:"fst ([t2]<>v) = snd ([t2]<>v)"
  assume eq2:"snd ([t2]<>v) = snd ([t1]<>v)"
  assume eq3:"snd ([t1]<>v) = fst ([t1]<>v)"
  assume rep:"v REP v'"
  assume neq1:"fst ([t2]<>v) \<noteq> NEG_INF"
  assume neq2:"fst ([t2]<>v) \<noteq> POS_INF"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
        eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> True"
    apply(rule rEqualsT, rule eval1, rule eval2)
    using eq1 eq2 eq3 eval1 eval2 rep1 rep2
    unfolding repP_def Let_def repL_def repU_def repe.simps using neq1 neq2 by auto
next
  case (wEqualsF1 t1 v t2 v')
  assume wle:"wgreater (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> False"
  apply(rule rEqualsF, rule eval1, rule eval2)
    using wgeq_lemma eval1 eval2 rep1 rep2 wgreater_lemma rGreaterF  prod.case_eq_if wle
    unfolding repP_def
    by (metis (no_types, lifting) less_irrefl)
next
  case (wEqualsF2 t2 v t1 v')
  assume wle:"wgreater (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> False"
    apply(rule rEqualsF, rule eval1, rule eval2)
    using wgeq_lemma eval1 eval2 rep1 rep2  wgreater_lemma rGreaterF prod.case_eq_if wle
    unfolding repP_def
    by (metis (no_types, lifting) less_irrefl)
qed (auto)

lemma rep_upd:"\<omega> = (\<nu>(Inr x := snd([\<theta>]<>\<nu>)))(Inl x := fst([\<theta>]<>\<nu>))
\<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> ([\<theta>::trm]\<nu>' \<down> r) \<Longrightarrow> \<omega> REP \<nu>'(x := r)"
  apply(rule REPI)
  apply(rule conjI)
   apply(unfold repL_def)
   using trm_sound prod.case_eq_if repP_def repstate_simps repL_def
   apply(metis (no_types, lifting) Inl_Inr_False fun_upd_apply sum.inject(1))
  using repP_def repstate_simps repU_def
  apply(auto simp add: repU_def)
  by (metis (full_types) surjective_pairing trm_sound)

text\<open>Interval program semantics soundly contains real semantics existentially\<close>
theorem interval_program_sound:
  fixes \<alpha>::"prog"
  shows "([[\<alpha>]] \<nu> \<down> \<omega>)  \<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> (\<exists>\<omega>'. (\<omega> REP \<omega>') \<and> ([\<alpha>] \<nu>' \<downharpoonleft> \<omega>'))"
proof (induction arbitrary: \<nu>' rule: wpsem.induct)
  case (wTest \<phi> \<nu> \<omega> \<nu>')
  assume sem:"[[\<phi>]]\<nu> \<down> True"
  and eq:"\<nu> = \<omega>"
  and rep:"\<nu> REP \<nu>'"
  show ?case
    apply(rule exI[where x=\<nu>'])
    using sem rep by (auto simp add: eq fml_sound rep)
next
  case (wAssign \<omega> \<nu> x \<theta> \<nu>')
  assume eq:"\<omega> = \<nu>(Inr x := snd ([\<theta>]<>\<nu>), Inl x := fst ([\<theta>]<>\<nu>))"
  and rep:"\<nu> REP \<nu>'"
  obtain r::real where eval:"([\<theta>::trm]\<nu>' \<down> r)" using eval_tot  by auto
  show ?case
    apply(rule exI[where x="\<nu>'(x := r)"])
    apply(rule conjI)
    apply(rule rep_upd[OF eq rep eval])
    apply auto
    apply(rule exI[where x=r])
    by (auto simp add: eval)
next case (wSeq \<alpha> \<nu> \<mu> \<beta> \<omega> \<nu>') then show ?case by (simp, blast)
next case (wChoice1 a v w b v') then show ?case by auto
next case (wChoice2 a v w b v') then show ?case by auto
qed

end


(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Prelim.thy
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Preliminaries.
*)

section \<open>Preliminaries\<close>

theory Prelim
imports "HOL-Library.FSet"
begin

notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")

declare fset_to_fset[simp]

lemma fst_snd_convol_o[simp]: "\<langle>fst o s, snd o s\<rangle> = s"
apply(rule ext) by (simp add: convol_def)

abbreviation sm_abbrev (infix "\<oplus>" 60)
where "f \<oplus> g \<equiv> Sum_Type.map_sum f g"

lemma map_sum_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
by (cases z) auto

lemma map_sum_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
by (cases z) auto

abbreviation case_sum_abbrev ("[[_,_]]" 800)
where "[[f,g]] \<equiv> Sum_Type.case_sum f g"

lemma Inl_oplus_elim:
assumes "Inl tr \<in> (id \<oplus> f) ` tns"
shows "Inl tr \<in> tns"
using assms apply clarify by (case_tac x, auto)

lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
using Inl_oplus_elim
by (metis id_def image_iff map_sum.simps(1))

lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
using Inl_oplus_iff unfolding vimage_def by auto

lemma Inr_oplus_elim:
assumes "Inr tr \<in> (id \<oplus> f) ` tns"
shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
using assms apply clarify by (case_tac x, auto)

lemma Inr_oplus_iff[simp]:
"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
apply (rule iffI)
 apply (metis Inr_oplus_elim)
by (metis image_iff map_sum.simps(2))

lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
using Inr_oplus_iff unfolding vimage_def by auto

lemma Inl_Inr_image_cong:
assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
shows "A = B"
apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)

end


theory BasicL
imports Main
        "../Listing"
        "$HIPSTER_HOME/IsaHipster"
        "../Naturals"

begin

(* FIXME: more than reversing lists, etc. deciding which scheme to start with might reside solely
    on how different some are from others: shall we start with those "different" from the structural
    one? How can we determine this? *)

(*print_rules
print_induct_rules*)
ML \<open>Outer_Syntax.improper_command\<close>
ML \<open>Datatype.get_info\<close>

(*hipster_cond notNil maps tail init len*)
lemma lemma_a [thy_expl]: "tail (maps x2 y2) = maps x2 (tail y2)"
by hipster_induct_simp_metis
(*apply(induction y2)
apply(simp_all)
done*)

lemma lemma_aa [thy_expl]: "len (maps x2 y2) = len y2"
by hipster_induct_schemes
(*apply(induction y2)
apply(simp_all)
done*)

lemma hdmap:
  "xs \<noteq> Nil ==> head (maps f xs) = f (head xs)"
  by hipster_induct_simp_metis

lemma maptl:
  "maps f (tail xs) = tail (maps f xs)"
  by hipster_induct_simp_metis

lemma map_ext: "(!!x. x : set xs --> f x = g x) ==> map f xs = map g xs"
by (induct xs) simp_all

lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"
by (rule ext, induct_tac xs) auto

lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"
by (induct xs) auto

lemma map_map [simp]: "map f (map g xs) = map (f o g) xs"
by (induct xs) auto
(*
lemma map_comp_map[simp]: "((maps f) o (maps g)) = maps(f o g)"
apply(rule ext)
apply(simp)
oops

lemma rev_map: "rev (maps f xs) = maps f (rev xs)"
by (induct xs) auto

lemma map_eq_conv[simp]: "(map f xs = map g xs) = (!x : set xs. f x = g x)"
by (induct xs) auto

lemma map_cong [fundef_cong]:
  "xs = ys ==> (!!x. x \<in> set ys ==> f x = g x) ==> map f xs = map g ys"
  by simp

lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"
by (cases xs) auto

lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"
by (cases xs) auto

lemma map_eq_Cons_conv:
 "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"
by (cases xs) auto

lemma Cons_eq_map_conv:
 "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"
by (cases ys) auto

lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]
lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]
declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]

lemma ex_map_conv:
  "(EX xs. ys = map f xs) = (ALL y : set ys. EX x. y = f x)"
by(induct ys, auto simp add: Cons_eq_map_conv)

lemma map_eq_imp_length_eq:
  assumes "map f xs = map g ys"
  shows "length xs = length ys"
using assms proof (induct ys arbitrary: xs)
  case Nil then show ?case by simp
next
  case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto
  from Cons xs have "map f zs = map g ys" by simp
  moreover with Cons have "length zs = length ys" by blast
  with xs show ?case by simp
qed

lemma map_inj_on:
 "[| map f xs = map f ys; inj_on f (set xs Un set ys) |]
  ==> xs = ys"
apply(frule map_eq_imp_length_eq)
apply(rotate_tac -1)
apply(induct rule:list_induct2)
 apply simp
apply(simp)
apply (blast intro:sym)
done

lemma inj_on_map_eq_map:
 "inj_on f (set xs Un set ys) ==> (map f xs = map f ys) = (xs = ys)"
by(blast dest:map_inj_on)

lemma map_injective:
 "map f xs = map f ys ==> inj f ==> xs = ys"
by (induct ys arbitrary: xs) (auto dest!:injD)

lemma inj_map_eq_map[simp]: "inj f ==> (map f xs = map f ys) = (xs = ys)"
by(blast dest:map_injective)

lemma inj_mapI: "inj f ==> inj (map f)"
by (iprover dest: map_injective injD intro: inj_onI)

lemma inj_mapD: "inj (map f) ==> inj f"
apply (unfold inj_on_def, clarify)
apply (erule_tac x = "[x]" in ballE)
 apply (erule_tac x = "[y]" in ballE, simp, blast)
apply blast
done

lemma inj_map[iff]: "inj (map f) = inj f"
by (blast dest: inj_mapD intro: inj_mapI)

lemma inj_on_mapI: "inj_on f (\<Union>(set ` A)) ==> inj_on (map f) A"
apply(rule inj_onI)
apply(erule map_inj_on)
apply(blast intro:inj_onI dest:inj_onD)
done

lemma map_idI: "(!!x. x \<in> set xs ==> f x = x) ==> map f xs = xs"
by (induct xs, auto)

lemma map_fun_upd [simp]: "y \<notin> set xs ==> map (f(y:=v)) xs = map f xs"
by (induct xs) auto

lemma map_fst_zip[simp]:
  "length xs = length ys ==> map fst (zip xs ys) = xs"
by (induct rule:list_induct2, simp_all)

lemma map_snd_zip[simp]:
  "length xs = length ys ==> map snd (zip xs ys) = ys"
by (induct rule:list_induct2, simp_all)
*)
lemma map_snd_zip: "len xs = len ys \<Longrightarrow> maps snd (zip xs ys) = ys"
oops

lemma lemma_ac [thy_expl]: "(Nil \<noteq> (maps x2 y2)) = (Nil \<noteq> y2)"
by hipster_induct_simp_metis (* just metis *)
(*apply(induction y2)
apply(simp_all)
done*)

setup\<open>Hip_Tac_Ops.set_full_types @{context} true\<close>
(* internally goes into conditional which Hipster cannot solve right now *)
(* FIXME: we rev the list so that it doesn't get stuck in maps.induct BUT we should control this
  behaviour! \<Rightarrow> limit simp_or_metis... *)
lemma unknown01 [thy_expl]: "init (maps x y) = maps x (init y)"
by hipster_induct_schemes
(*
apply(induction y rule: init.induct)
apply(simp_all)
done*)

lemma auxNilIn : "init Nil = tail Nil"
by (metis init.simps tail.simps)

lemma unknown02 [thy_expl]: "init (tail x) = tail (init x)"
by hipster_induct_schemes (*
apply(induction x)
apply(simp_all)
apply(case_tac x)
apply(simp_all)
done*)

lemma unknown03 [thy_expl]: "len (init x) = len (tail x)"
by hipster_induct_schemes (*
apply(induction x)
apply(simp_all)
apply(case_tac x)
apply(simp_all)
done*)

lemma unknown04 [thy_expl]: "notNil (init x) = notNil (tail x)" (* required schemes: init.induct *)
by hipster_induct_schemes (*
apply(case_tac x)
apply(simp_all)
apply(case_tac List)
apply(simp_all)
done *)

lemma unknown04': " (Nil \<noteq> init x) = (Nil \<noteq> tail x)" (* required schemes: init.induct *)
by hipster_induct_schemes

(*
fun noNat :: "Nat List \<Rightarrow> bool" where
  "noNat l = notNil l"
fun appnat :: "Nat List \<Rightarrow> Nat List \<Rightarrow> Nat List " where
  "appnat x y = app x y"

hipster noNat appnat*)

lemma initDef: "init (app ts (Cons t Nil)) = ts"
by hipster_induct_schemes (*
apply(induction ts rule: init.induct)
apply(simp_all)
done*)

lemma lastDef: "\<not> notNil ts \<Longrightarrow> last (Cons t ts) = t"
by (hipster_induct_simp_metis Listing.notNil.simps Listing.last.simps)

lemma lastDef' : "last (Cons t Nil) = t"
by(tactic \<open>Tactic_Data.routine_tac @{context}\<close>)

(* auxiliary *)
lemma noElems: "count t Nil = Z"
by simp

lemma appNil: "app ts Nil = ts"
by (hipster_induct_simp_metis app.simps )
(*
hipster_cond notNil app init*)

(* XXX: shall we try and have some reasonable decision as to which argument + function to start inducting upon?
  eg: inner-most-left-most *)
lemma initLast: "ts \<noteq> Nil \<Longrightarrow> app (init ts) (Cons (last ts) Nil) = ts"
by (hipster_induct_schemes)
(*by (hipster_induct_schemes Listing.notNil.simps Listing.init.simps app.simps Listing.last.simps)*)
(* by hipster_induct_schemes : succeeds but takes long because it tries first notNil.induct, app.induct
    and then init.induct *)(*
apply(induction ts rule: init.induct)
apply(simp_all)
done*)

lemma initCons: "notNil ts \<Longrightarrow> init (Cons t ts) = Cons t (init ts)"
by (metis init.simps(3) notNil.elims(2))
(*by (hipster_induct_simp_metis)
by (metis init.simps(3) notNil.cases)*)

lemma initApp: "notNil ts \<Longrightarrow> init (app rs ts) = app rs (init ts)"
by (hipster_induct_schemes initCons)
(* by (hipster_induct_schemes initCons : needs initCons! succeeds but takes long - tries notNil.induct
  and app.induct before last.induct... *)(*
apply(induction rs rule: init.induct)
apply(simp_all)
apply(case_tac ts)
apply(simp_all)
done*)

lemma initAppNil: "\<not> notNil ts \<Longrightarrow> init (app rs ts) = init rs"
by (hipster_induct_schemes Listing.notNil.simps app.simps Listing.init.simps appNil)
(* before: apply(induction ts rule: init.induct) apply(simp_all add: appNil) *)

lemma lastCons: "notNil ts \<Longrightarrow> last (Cons t ts) = last ts"
by (hipster_induct_simp_metis)

lemma lastApp: "notNil ts \<Longrightarrow> last (app rs ts) = last ts"
by (hipster_induct_schemes lastCons)
(* by (hipster_induct_schemes lastCons) : needs lastCons! succeeds but takes long - tries notNil.induct
  and app.induct before last.induct... XXX: check order in general! *)
(* XXX2: seems like case distinctions (maybe double inductions too) could benefit from auxiliary
    lemmas, in general *)(*
apply(induction rs rule: last.induct)
apply(simp_all)
apply(case_tac ts)
apply(simp_all)
done*)

lemma lastAppNil: "\<not> notNil ts \<Longrightarrow> last (app rs ts) = last rs"
by (hipster_induct_schemes appNil) (* needs it! *)
(*
lemma countDiff: "\<not> eqN r t \<Longrightarrow> count r (app (Cons t Nil) ts) = count r ts"
by (hipster_induct_simp_metis)*)

lemma countInc: "eqN r t \<Longrightarrow> count r (Cons t ts) = S (count r ts)"
by (hipster_induct_simp_metis)

ML \<open>
   fun infer_term x ctxt =
     let val (T, ctxt') = Proof_Context.inferred_param x ctxt
     in (Free (x, T), ctxt') end;
   fun bis x = Attrib.thms x ;
   fun induct_for_me ctxt xss rule i =
     let
       val (tss, ctxt') = (fold_map o fold_map) infer_term xss ctxt
       val instss = map (map (fn inst => SOME (NONE, (inst, false)))) tss;
     in Seq.map snd o Induct.induct_tac ctxt' false instss [] [] NONE (*SOME rule*) [] i end;
\<close>
fun drop' :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "drop' _ [] = []"
| "drop' 0 xs = xs"
| "drop' (Suc n) (x#xs) = drop' n xs"
(* XXX: mailing list!  But hipster_induct_simp_metis (or schemes) never work with this, regular
  List.drop which is implemented like ours or ours *)
lemma drop'Nil: "drop' n [] = []"
apply(raw_tactic \<open>ALLGOALS(induct_for_me @{context} [["n"]] [])\<close>)
apply(simp_all)
done
(*by(tactic {* Tactic_Data.routine_tac @{context} *}) works too *)

(*XXX: maybe schemes will solve it when we pick the appropriate variable (type-wise) on which to
    induct?
       or does it have something to do with how the goal of a proof is set?
  XXX: look up for a type T what T.exhaust is *)

  declare [[show_types]]
  declare [[show_sorts]]
  declare [[show_consts]]
lemma dropNil: "drop n Nil = Nil" (* XXX: check why this solves our problem... why no "unification" *)
(*by (metis drop.simps Nat.exhaust)*)
by hipster_induct_simp_metis

ML \<open>
  @{thm "drop.induct"};
  (Thm.concl_of @{thm "drop.induct"});
  (HOLogic.dest_Trueprop (Thm.concl_of @{thm "drop.induct"}));
  @{term "case x of 0 \<Rightarrow> 0 | Suc y \<Rightarrow> y"};
  @{term "P y x"};
  fun reP uu = case uu of
        Var (_,t) => t
      | (t$_) => reP t
      | (Abs (_, t, _)) => t
      | (Free (_, t)) => t; (* TODO: Bound, Const *)
  val ump = binder_types (reP(HOLogic.dest_Trueprop (Thm.concl_of @{thm "drop.induct"})));
  val tumf = fastype_of @{term "Cons Z Nil"};
  hd (tl ump) = tumf;
  fastype_of1 ([],@{term "Cons Z Nil"});
  Type.could_match(hd (tl ump), tumf);

(*typ list * term -> typ

  hd (tl ump) = Type ( *)
\<close>

thm drop.induct
(*thm List.rel_induct[case_names Nil Cons, {* @{thm "List.induct"} *}]*)

lemma dropMapComm: "drop n (maps f ts) = maps f (drop n ts)"
by hipster_induct_schemes (*
apply(induction ts rule: drop.induct)
apply(simp_all)
done*)

lemma takeMapCom: "take n (maps f ts) = maps f (take n ts)" (* needs schemes! *)
by hipster_induct_schemes (*
apply(induction ts rule: drop.induct) (* XXX: either works! drop.induct OR take.induct *)
apply(simp_all)
done*)

(* XXX: for now changed order \<Longrightarrow> do something about those HO objects, such as f *)
lemma mapIntersperse: "intersperse (f a) (maps f xs) = maps f (intersperse a xs)"
by hipster_induct_schemes

fun ith :: "'a List \<Rightarrow> nat \<Rightarrow> 'a" where
  "ith (Cons t ts) 0 = t"
| "ith (Cons t ts) (Suc n) = ith ts n"

fun len' :: "'a List \<Rightarrow> nat" where
  "len' Nil = 0"
| "len' (Cons t ts) = Suc (len' ts)"

lemma extens: "\<lbrakk> len' xs = len' ys ; ALL i < len' xs. ith xs i = ith ys i \<rbrakk> \<Longrightarrow> xs = ys"
(*apply hipster_induct_schemes*)

oops

fun map' :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b List" where
  "map' f [] = Nil"
| "map' f (t # ts) = Cons (f t) (map' f ts)"

lemma mapIth:  "map' (\<lambda>i. ith xs i) [0..<len' xs] = xs"
oops

end


section \<open>Bouncing ball example, parallel version\<close>

theory BouncingBallPar
  imports BigStep
begin

locale bouncing_ball_par =
  fixes g :: real and
    c :: real and
    H :: real
  assumes pos_g: "g > 0" and
    pos_c: "c > 0" and
    le1_c: "c \<le> 1"
begin

definition V :: char where "V = CHR ''v''"

lemma vars_distinct: "X \<noteq> V"
  unfolding X_def V_def by auto

definition Inv :: "state \<Rightarrow> real" where
  "Inv = (\<lambda>s. (s V) ^ 2 + 2 * g * s X)"

inductive valid_blocks_plant :: "state \<Rightarrow> trace_block list \<Rightarrow> bool" where
  "valid_blocks_plant st []"
| "valid_blocks_plant ((p d)(V := v1)) blks \<Longrightarrow>
   d \<ge> 0 \<Longrightarrow> p 0 = st \<Longrightarrow>
   (\<forall>t. 0\<le>t \<and> t\<le>d \<longrightarrow> Inv (p t) = Inv (p 0)) \<Longrightarrow>
   valid_blocks_plant st (ODEBlock d (restrict p {0..d}) #
                          OutBlock dly1 ''ch1'' (p d V) ({''ch1''}, {}) #
                          InBlock dly2 ''ch2'' V v1 ({}, {''ch2''}) # blks)"

lemma valid_blocks_plant_snoc:
  "valid_blocks_plant st blks \<Longrightarrow>
   d \<ge> 0 \<Longrightarrow> p 0 = end_of_trace (Trace st blks) \<Longrightarrow>
   (\<forall>t. 0\<le>t \<and> t\<le>d \<longrightarrow> Inv (p t) = Inv (p 0)) \<Longrightarrow>
   valid_blocks_plant st
                      (blks @ [ODEBlock d (restrict p {0..d}),
                               OutBlock dly1 ''ch1'' (p d V) ({''ch1''}, {}),
                               InBlock dly2 ''ch2'' V v1 ({}, {''ch2''})])"
proof (induct rule: valid_blocks_plant.induct)
  case (1 st)
  then show ?case
    apply (subst append.left_neutral)
    by (auto intro: valid_blocks_plant.intros)
next
  case (2 p2 d2 v1 blks st dly1 dly2)
  show ?case
    apply (simp only: append_Cons)
    apply (rule valid_blocks_plant.intros(2)[where p=p2, OF _ 2(3-5)])
    apply (rule 2(2)[OF 2(6) _ 2(8)])
    using 2(7) by (simp add: 2(3) fun_upd_def)
qed

lemma bouncingBallPlant:
  assumes "v0 > 0"
  shows "Valid
    (\<lambda>t. t = Trace ((\<lambda>_. 0)(V := v0)) [])
    (Rep (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>s. s V), V := (\<lambda>_. -g)))) (\<lambda>s. s X > 0 \<or> s V > 0);
          Cm (Send ''ch1'' (\<lambda>s. s V)); Cm (Receive ''ch2'' V)))
    (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks)"
proof -
  have 1: "Valid
     (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks)
     (Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s V, V := \<lambda>_. - g))) (\<lambda>s. 0 < s X \<or> 0 < s V))
     (\<lambda>t. \<exists>blks d p.
             t = Trace ((\<lambda>_. 0)(V := v0)) (blks @ [ODEBlock d (restrict p {0..d})]) \<and>
             valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks \<and> d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<and>
             (\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)))"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    subgoal premises pre for blks
      apply (rule Valid_post)
      prefer 2
       apply (rule Valid_ode_invariant[where inv=Inv])
        prefer 3 apply clarify
      subgoal for blks2 d p
        apply (rule exI[where x=blks]) apply (rule exI[where x=d]) apply (rule exI[where x=p])
        using pre by fastforce
      apply (auto simp add: vec2state_def Inv_def)[1]
      apply (auto intro!: derivative_intros)[1]
      by (auto simp add: state2vec_def vars_distinct)
    done
  have 2: "Valid
     (\<lambda>t. \<exists>blks d p.
             t = Trace ((\<lambda>_. 0)(V := v0)) (blks @ [ODEBlock d (restrict p {0..d})]) \<and>
             valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks \<and> d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<and>
             (\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)))
     (Cm (''ch1''[!](\<lambda>s. s V)))
     (\<lambda>t. \<exists>blks d p dly1.
             t = Trace ((\<lambda>_. 0)(V := v0)) (blks @ [ODEBlock d (restrict p {0..d}),
                                                   OutBlock dly1 ''ch1'' (p d V) ({''ch1''}, {})]) \<and>
             valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks \<and> d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<and>
             (\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)))"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    subgoal premises pre for blks d p
      apply (rule Valid_send2)
      apply clarify
      subgoal for dly1
        apply (rule exI[where x=blks]) apply (rule exI[where x=d])
        apply (rule exI[where x=p]) apply (rule exI[where x=dly1])
        using pre by (auto simp add: extend_send_def end_of_blocks_append)
      done
    done
  have 3: "Valid
     (\<lambda>t. \<exists>blks d p dly1.
             t = Trace ((\<lambda>_. 0)(V := v0)) (blks @ [ODEBlock d (restrict p {0..d}),
                                                   OutBlock dly1 ''ch1'' (p d V) ({''ch1''}, {})]) \<and>
             valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks \<and> d \<ge> 0 \<and> p 0 = end_of_trace (Trace ((\<lambda>_. 0)(V := v0)) blks) \<and>
             (\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)))
     (Cm (''ch2''[?]V))
     (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks)"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    subgoal premises pre for blks d p dly1
      apply (rule Valid_receive2)
      apply (auto simp add: extend_receive_def)
      using pre by (rule valid_blocks_plant_snoc)
    done
  have 4: "Valid
     (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks)
     (Rep (Cont (ODE ((\<lambda>_ _. 0)(X := \<lambda>s. s V, V := \<lambda>_. - g)))
            (\<lambda>s. 0 < s X \<or> 0 < s V); Cm (''ch1''[!](\<lambda>s. s V)); Cm (''ch2''[?]V)))
     (\<lambda>t. \<exists>blks. t = Trace ((\<lambda>_. 0)(V := v0)) blks \<and> valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks)"
    by (auto intro!: Valid_rep Valid_seq 1 2 3)
  show ?thesis
    apply (rule Valid_pre)
    using 4 using assms by (auto intro: valid_blocks_plant.intros(1))
qed

inductive valid_blocks_ctrl :: "trace_block list \<Rightarrow> bool" where
  "valid_blocks_ctrl []"
| "valid_blocks_ctrl blks \<Longrightarrow>
   valid_blocks_ctrl (InBlock dly1 ''ch1'' V v ({}, {''ch1''}) #
                      OutBlock dly2 ''ch2'' (- (c * v)) ({''ch2''}, {}) # blks)"

lemma valid_blocks_ctrl_snoc:
  "valid_blocks_ctrl blks \<Longrightarrow>
   valid_blocks_ctrl (blks @ [InBlock dly1 ''ch1'' V v ({}, {''ch1''}),
                              OutBlock dly2 ''ch2'' (- (c * v)) ({''ch2''}, {})])"
proof (induct rule: valid_blocks_ctrl.induct)
  case 1
  then show ?case
    by (auto intro: valid_blocks_ctrl.intros)
next
  case (2 blks dly1 v dly2)
  show ?case
    by (auto intro: valid_blocks_ctrl.intros(2) 2(2))
qed

lemma bouncingBallCtrl:
  "Valid
    (\<lambda>t. t = Trace (\<lambda>_. 0) [])
    (Rep (Cm (Receive ''ch1'' V); Cm (Send ''ch2'' (\<lambda>s. - (c * s V)))))
    (\<lambda>t. \<exists>blks. t = Trace (\<lambda>_. 0) blks \<and> valid_blocks_ctrl blks)"
proof -
  have 1: "Valid
      (\<lambda>t. \<exists>blks. t = Trace (\<lambda>_. 0) blks \<and> valid_blocks_ctrl blks)
      (Cm (''ch1''[?]V))
      (\<lambda>t. \<exists>blks dly1 v. t = Trace (\<lambda>_. 0) (blks @ [InBlock dly1 ''ch1'' V v ({}, {''ch1''})]) \<and>
                         valid_blocks_ctrl blks)"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    apply (rule Valid_receive2)
    by (auto simp add: extend_receive_def)
  have 2: "Valid
      (\<lambda>t. \<exists>blks dly1 v. t = Trace (\<lambda>_. 0) (blks @ [InBlock dly1 ''ch1'' V v ({}, {''ch1''})]) \<and>
                         valid_blocks_ctrl blks)
      (Cm (''ch2''[!](\<lambda>s. - c * s V)))
      (\<lambda>t. \<exists>blks. t = Trace (\<lambda>_. 0) blks \<and> valid_blocks_ctrl blks)"
    apply (simp only: Valid_ex_pre Valid_and_pre, clarify)
    subgoal premises pre for blks dly1 v
      apply (rule Valid_send2)
      apply (auto simp add: extend_send_def end_of_blocks_append)
      using pre by (rule valid_blocks_ctrl_snoc)
    done
  have 3: "Valid
      (\<lambda>t. \<exists>blks. t = Trace (\<lambda>_. 0) blks \<and> valid_blocks_ctrl blks)
      (Rep (Cm (''ch1''[?]V); Cm (''ch2''[!](\<lambda>s. - c * s V))))
      (\<lambda>t. \<exists>blks. t = Trace (\<lambda>_. 0) blks \<and> valid_blocks_ctrl blks)"
    apply (auto intro!: Valid_rep Valid_seq)
    using 1 2 by auto
  show ?thesis
    apply (rule Valid_pre)
    using 3 by (auto intro: valid_blocks_ctrl.intros(1))
qed

inductive valid_blocks_par :: "par_block list \<Rightarrow> bool" where
  "valid_blocks_par []"
| "valid_blocks_par pblks \<Longrightarrow> d \<ge> 0 \<Longrightarrow> \<forall>t. 0\<le>t \<and> t\<le>d \<longrightarrow> Inv ((p t)!0) = Inv ((p 0)!0) \<Longrightarrow>
   valid_blocks_par (ParWaitBlock d (restrict p {0..d}) # IOBlock 1 0 ''ch1''V v # IOBlock 0 1 ''ch2'' V (- (c * v)) # pblks)"

lemma bouncingBallBlocks:
  "valid_blocks_plant st blks1 \<Longrightarrow>
   valid_blocks_ctrl blks2 \<Longrightarrow>
   combine_blocks [st, sr] [blks1, blks2] par_blks \<Longrightarrow>
   valid_blocks_par par_blks"
proof (induct arbitrary: blks2 par_blks sr rule: valid_blocks_plant.induct)
  case (1 st)
  note plant1 = 1
  from plant1(1) show ?case
  proof (induct rule: valid_blocks_ctrl.cases)
    case 1
    note ctrl1 = 1
    have s1: "par_blks = []"
      using plant1(2) unfolding ctrl1
      by (rule combine_blocks_triv2)
    show ?case
      unfolding s1 by (rule valid_blocks_par.intros(1))
  next
    case (2 blks dly1 v dly2)
    note ctrl2 = 2
    show ?case
      using plant1(2) ctrl2(1)
      using combine_blocks_NilIn by blast
  qed
next
  case (2 p d v1 blks st dly11 dly12)
  note plant2 = 2
  from plant2(6) show ?case
  proof (induct rule: valid_blocks_ctrl.cases)
    case 1
    note ctrl1 = 1
    show ?case
      using plant2(7) unfolding ctrl1
      using combine_blocks_ODENil2 combine_blocks_OutNil by blast
  next
    case (2 blks2' dly21 v dly22)
    note ctrl2 = 2
    have 21: "restrict p {0..d} d = p d" using plant2(3) by auto
    have 22: "(\<lambda>t\<in>{0..d}. [restrict p {0..d} t, sr]) = (\<lambda>t\<in>{0..d}. [p t, sr])"
      using plant2(3) by auto
    obtain rest where s1: "d \<le> dly21"
      "combine_blocks [p d, sr]
       [OutBlock dly11 ''ch1'' (p d V) ({''ch1''}, {}) # InBlock dly12 ''ch2'' V v1 ({}, {''ch2''}) # blks,
        InBlock (dly21 - d) ''ch1'' V v ({}, {''ch1''}) # OutBlock dly22 ''ch2'' (- (c * v)) ({''ch2''}, {}) # blks2']
       rest"
      "par_blks = ParWaitBlock d (restrict (\<lambda>t. [p t, sr]) {0..d}) # rest"
      using plant2(3, 7) unfolding ctrl2(1)
      using combine_blocks_ODEIn2[of st sr d "(restrict p {0..d})"
        "OutBlock dly11 ''ch1'' (p d V) ({''ch1''}, {}) # InBlock dly12 ''ch2'' V v1 ({}, {''ch2''}) # blks"
       dly21 "''ch1''" V v "({}, {''ch1''})" "OutBlock dly22 ''ch2'' (- (c * v)) ({''ch2''}, {}) # blks2'" par_blks
       ] 21 22 by auto
    have 23: "[p d, sr][1 := end_of_blocks ([p d, sr] ! 1) [InBlock (dly21 - d) ''ch1'' V v ({}, {''ch1''})]]
            = [p d, sr (V:=v)]"
      by auto
     obtain rest2 where s2:
      "dly11 = 0" "dly21 - d = 0" "p d V = v"
      "combine_blocks [p d, sr(V:=v)] [InBlock dly12 ''ch2'' V v1 ({}, {''ch2''}) # blks,
                       OutBlock dly22 ''ch2'' (- (c * v)) ({''ch2''}, {}) # blks2'] rest2"
      "rest = IOBlock 1 0 ''ch1'' V (p d V) # rest2"
       using combine_blocks_IO2[OF s1(2)] 23  by auto
     have 24: "([p d, sr(V := v)][0 := end_of_blocks ([p d, sr(V := v)] ! 0) [InBlock dly12 ''ch2'' V v1 ({}, {''ch2''})]])
              =  [(p d)(V := v1), sr(V := v)]" by auto
    obtain rest3 where s3:
      "dly22 = 0" "dly12 = 0" "- (c * v) = v1"
      "combine_blocks [(p d)(V:=v1), sr(V:=v)] [blks, blks2'] rest3" "rest2 = IOBlock 0 1 ''ch2'' V (- (c * v)) # rest3"
      using combine_blocks_IO2'[OF s2(4)] 24 by auto
    have s4: "valid_blocks_par rest3"
      using plant2(2)[of blks2'] ctrl2(2) s3(4) by blast
    have "d \<ge> 0" using plant2(3) by auto
    have 26: "\<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv (p t) = Inv (p 0)"
      by (rule plant2(5))
    have 27: " \<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv([p t, sr] ! 0) = Inv(p t)" by auto
    have 28: " \<forall>t. 0 \<le> t \<and> t \<le> d \<longrightarrow> Inv([p 0, sr] ! 0) = Inv(p 0)" by auto
    show ?case
      unfolding s1(3) s2(5) s3(5) s2(3)
      apply (rule valid_blocks_par.intros(2)[OF s4 \<open>0 \<le> d\<close>])
      using 26 27 28 by arith
  qed
qed

lemma bouncingBall:
  assumes "v0 > 0"
  shows "ParValid
    (\<lambda>t. t = ParTrace [((\<lambda>_. 0)(V := v0)), (\<lambda>_. 0)] [])
    (PProc [Rep (Cont (ODE ((\<lambda>_ _. 0)(X := (\<lambda>s. s V), V := (\<lambda>_. -g)))) (\<lambda>s. s X > 0 \<or> s V > 0);
            Cm (Send ''ch1'' (\<lambda>s. s V)); Cm (Receive ''ch2'' V)),
            Rep (Cm (Receive ''ch1'' V); Cm (Send ''ch2'' (\<lambda>s. - (c * s V))))])
    (\<lambda>t. \<exists>pblks. t = ParTrace [((\<lambda>_. 0)(V := v0)), (\<lambda>_. 0)] pblks \<and> valid_blocks_par pblks)"
proof -
  have 1: "\<exists>pblks. par_t = ParTrace [(\<lambda>_. 0)(V := v0), \<lambda>_. 0] pblks \<and> valid_blocks_par pblks"
    if tr1: "tr1 = Trace ((\<lambda>_. 0)(V := v0)) blks1" "valid_blocks_plant ((\<lambda>_. 0)(V := v0)) blks1" and
       tr2: "tr2 = Trace (\<lambda>_. 0) blks2" "valid_blocks_ctrl blks2" and
       rdy: "compat_trace_pair tr1 tr2" and
       par_trace: "combine_par_trace [tr1, tr2] par_t"
     for par_t tr1 tr2 blks1 blks2
  proof -
    from par_trace[unfolded tr1 tr2] obtain par_blks where
      1: "par_t = ParTrace [(\<lambda>_. 0)(V := v0), \<lambda>_. 0] par_blks" and
      2: "combine_blocks  [((\<lambda>_. 0)(V := v0)), (\<lambda>_. 0)]  [blks1, blks2] par_blks"
      using combine_par_traceE2 by blast
    then have 3: "valid_blocks_par par_blks"
      using bouncingBallBlocks[OF tr1(2) tr2(2) 2] by auto
    show ?thesis
      apply (rule exI[where x=par_blks])
      using 1 3 by auto
  qed
  show ?thesis
    apply (rule Valid_parallel2'[OF _ _ bouncingBallPlant[OF assms] bouncingBallCtrl])
    using 1 by blast+
qed

end  (* locale bouncing_ball_par *)

end


theory Hoare_Indexed_Sound imports Hoare_Indexed Hoare
begin

(*
 * Here we show that the Hoare logic with explicit step-indexes defined in
 * Hoare_Indexed.thy is sound with respect to the one defined in Hoare.thy.
 * I do not believe the indexed Hoare logic is complete with respect to the non-indexed one,
 * but this doesn't really matter since its use is primarily in making it easier to prove
 * certain Hoare rules which are to be used in a non-indexed setting.
 *)

lemma safe_imp_safe_for :
  assumes H: "safe gs m"
  shows "safe_for gs m n" using H
proof(induction n arbitrary: m)
  case 0

  have Ex0 : "sem_exec_p gs m m"
    unfolding sem_exec_p_def by auto

  have Nostep : "sem_exec_c_p gs m 0 m"
      by(auto intro: sem_exec_c_p.intros)

  have "imm_safe gs m" using safeD[OF 0 Ex0]
    by simp

  then consider (1) "cont m = Inl []"  |
                (2) m' where "(sem_step_p gs m m')"
    unfolding imm_safe_def by blast
  then show ?case
  proof cases
    case 1

    have "sem_exec_c_p gs m 0 m"
      by(auto intro: sem_exec_c_p.intros)

    then show ?thesis using 1 unfolding safe_for_def by blast
  next
    case 2

    then obtain h t where Cons : "cont m = Inl (h#t)"
      unfolding sem_step_p_eq
      by(auto simp add: sem_step_def split: list.splits sum.splits)

    show ?thesis using Cons Nostep unfolding safe_for_def by blast
  qed
next
  case (Suc n)

  have Ex0 : "sem_exec_p gs m m"
    unfolding sem_exec_p_def by auto

  have "imm_safe gs m" using safeD[OF Suc.prems Ex0]
    by simp

  then consider (A) "cont m = Inl []"  |
                (B) m' where "(sem_step_p gs m m')"
    unfolding imm_safe_def by blast
  then show ?case
  proof cases
    case A

    have "sem_exec_c_p gs m 0 m"
      by(auto intro: sem_exec_c_p.intros)

    then show ?thesis using A unfolding safe_for_def by blast
  next
    case B

    then have Exec : "sem_exec_p gs m m'"
      unfolding sem_exec_p_def by auto

    have Safe: "safe gs m'" using safe_exec_safe[OF Suc.prems Exec] by simp

    have "safe_for gs m' n" using Suc.IH[OF Safe] by simp

    then consider (B1) n0 full' where "n0 \<le> n" "sem_exec_c_p gs m' n0 full'" "cont full' = Inl []" |
                  (B2) "\<And> n0 . n0\<le>n \<Longrightarrow> \<exists>full' h t. sem_exec_c_p gs m' n0 full' \<and> cont full' = Inl (h # t)"
      unfolding safe_for_def
      by blast

    then show ?thesis
    proof cases
      case B1

      have Conc1 : "(Suc n0) \<le> Suc n" using B1 by simp

      have Conc2 : "sem_exec_c_p gs m (Suc n0) full'"
        using Excp_Suc[OF B B1(2)] by simp

      show ?thesis unfolding safe_for_def
        using Conc1 Conc2 B1(3)
        by blast
    next
      case B2

      have Conc' : "\<And> n0 . n0\<le>Suc n \<Longrightarrow> \<exists>full' h t. sem_exec_c_p gs m n0 full' \<and> cont full' = Inl (h # t)"
      proof-
        fix n0
        assume N0 : "n0 \<le> Suc n"
        show "\<exists>full' h t. sem_exec_c_p gs m n0 full' \<and> cont full' = Inl (h # t)"
        proof(cases n0)
          case Z' : 0

          have Conc1 : "sem_exec_c_p gs m 0 m"
            by(auto intro: sem_exec_c_p.intros)

          obtain h t where Conc2 : "cont m = Inl (h#t)"
            using B
            unfolding sem_step_p_eq
            by(auto simp add: sem_step_def split: list.splits sum.splits)

          show ?thesis using Conc1 Conc2 unfolding Z' by blast
        next
          case Suc' : (Suc n0')

          have N0'_n : "n0' \<le> n" using N0 Suc'
            by auto

          obtain full' h t where Tail_exec : "sem_exec_c_p gs m' n0' full'"
            and Tail_cont : "cont full' = Inl (h # t)"
            using B2[OF N0'_n] by blast

          have Full_Exec : "sem_exec_c_p gs m (Suc n0') full'"
            using Excp_Suc[OF B Tail_exec] by simp

          then show ?thesis using Tail_cont unfolding Suc' by blast
        qed
      qed

      then show ?thesis
        unfolding safe_for_def
        by blast
    qed
  qed
qed

lemma safe_for_imm_safe :
  assumes H : "safe_for gs m n"
  assumes H' : "sem_exec_c_p gs m n m'"
  shows "imm_safe gs m'"
proof-

  consider
    (1) n0 m'_alt where "n0 \<le> n" "sem_exec_c_p gs m n0 m'_alt" "cont m'_alt = Inl []" |
    (2) "\<And> n0 . n0 \<le>n  \<Longrightarrow> \<exists>m'_alt h t. sem_exec_c_p gs m n0 m'_alt \<and> cont m'_alt = Inl (h # t)"
    using H unfolding safe_for_def
    by blast

  then show "imm_safe gs m'"
  proof cases
    case 1

    obtain m2 where Exec_start : "sem_exec_c_p gs m n0 m2"
              and Exec_finish : "sem_exec_c_p gs m2 (n - n0) m'"
      using exec_c_p_split[OF H' 1(1)]
      by blast

    have M2_m'_alt : "m2 = m'_alt"
      using exec_c_p_determ[OF 1(2) Exec_start] by simp

    (* idea: if n0 = n, we are done *)
    show ?thesis
    proof(cases "n0 = n")
      case True

      have Exec_alt_n : "sem_exec_c_p gs m n m'_alt"
        using 1 unfolding True by simp

      have M'_eq : "m'_alt = m'"
        using exec_c_p_determ[OF H' Exec_alt_n] by auto

      then show ?thesis using 1 unfolding imm_safe_def M'_eq by blast
    next
      (* otherwise we have a contradiction, since we need to execute past an Inl [] *)
      case False

      have Leq' : "1 \<le> n - n0"
        using False 1(1) by auto

      obtain mbad where Bad: "sem_exec_c_p gs m2 1 mbad"
        using exec_c_p_split[OF Exec_finish Leq'] by blast

      have Bad_step : "sem_step_p gs m2 mbad"
        using Excp_1'[OF Bad] by simp

      then obtain bad_h bad_t where Bad_nonnil : "cont m2 = Inl (bad_h#bad_t)"
        unfolding sem_step_p_eq
        by(auto simp add: sem_step_def split: sum.splits list.splits)

      hence False using 1(3) unfolding M2_m'_alt by simp

      then show ?thesis by simp
    qed
  next
    case 2

    obtain m'_alt h t where Exec_alt : "sem_exec_c_p gs m n m'_alt" and Cont_alt : "cont m'_alt = Inl (h # t)"
      using 2[of n] by blast

    have Eq : "m'_alt = m'" using exec_c_p_determ[OF H' Exec_alt] by simp

    obtain m'a where "sem_step_p gs m' m'a"
      using Cont_alt Exec_alt
      unfolding imm_safe_def Eq sem_step_p_eq sem_step_def
      by(cases h; auto)

    then show ?thesis unfolding imm_safe_def by blast
  qed
qed

lemma safe_for_imp_safe :
  assumes H : "\<And> n . safe_for gs m n"
  shows "safe gs m"
proof
  fix m'
  assume Exec : "sem_exec_p gs m m'"

  obtain n where N: "sem_exec_c_p gs m n m'"
    using exec_p_imp_exec_c_p[OF Exec] by blast

  show "imm_safe gs m'" using safe_for_imm_safe[OF H N] by simp
qed

lemma guarded_weaken :
  assumes H : "|#gs#| {#P, n1#} c"
  assumes H' : "n2 \<le> n1"
  shows "|#gs#| {#P, n2#} c"
proof
  fix m :: "('a, 'b) control"
  assume M_ok : "m \<in> ok_S"
  assume P : "P (payload m)"
  assume C : "cont m = Inl c"

  have Conc' : "safe_for gs m n1"
    using guardediD[OF H M_ok P C]
    by auto

  show "safe_for gs m n2"
    using safe_for_weaken[OF Conc' H']
    by auto
qed

lemma unsafe_imp_unsafe_for :
  assumes H : "\<not> safe gs m"
  shows "\<exists> n . \<not> safe_for gs m n"
  using H safe_for_imp_safe
  by blast

lemma HT'_imp_HT :
  assumes H : "HT' gs P c Q"
  shows "|gs| {-P-} c {-Q-}"
proof
  fix c'
  assume Guard : "|gs| {Q} c'"
  show "|gs| {P} (c @ c')"
  proof
    fix m :: "('a, 'b) control"
    assume M_ok : "m \<in> ok_S"
    assume Pm : "P (payload m)"
    assume Cm : "cont m = Inl (c @ c')"
    show "safe gs m"
    proof
      fix m'
      assume Exec : "sem_exec_p gs m m'"

      obtain n where Execc : "sem_exec_c_p gs m n m'"
        using exec_p_imp_exec_c_p[OF Exec] by auto

      obtain npre where Npost : "|#gs#| {#-P, (npre + n)-#} c {#-Q, n-#}" using HT'D[OF H, of n]
        by blast

      have Guard'_out : "|#gs#| {#Q, n#} c'"
      proof
        fix mx :: "('a, 'b) control"
        assume Mx_ok : "mx \<in> ok_S"
        assume Q: "Q (payload mx)"
        assume C: "cont mx = Inl c'"

        have Safe : "safe gs mx"
          using guardedD[OF Guard Mx_ok Q C]
          by simp

        show "safe_for gs mx n"
          using safe_imp_safe_for[OF Safe] by simp
      qed

      have Guard'_in : "|#gs#| {#P, (npre + n)#} (c @ c')"
        using HTiE[OF Npost Guard'_out] by simp

      have Guard'_in' : "|#gs#| {#P, n#} (c @ c')"
        using guarded_weaken[OF Guard'_in] by simp

      have Safe' : "safe_for gs m n"
        using guardediD[OF Guard'_in' M_ok Pm Cm] by simp

      show "imm_safe gs m'"
        using safe_for_imm_safe[OF Safe' Execc] by simp
    qed
  qed
qed

(* I don't think the converse (completeness) holds in general. *)
(*
lemma HT_imp_HT' :
  assumes H : "|gs| {-P-} c {-Q-}"
  shows "HT' gs P c Q"
proof(rule HT'I)
  fix npost

(*  have Hmm : "\<And> c' . ( |gs| {Q} c' \<or> (\<exists> mbad .  *)

  have Conc' : "|#gs#| {#-P, (npost)-#} c {#-Q, npost-#}"
  proof
    fix c'
    assume G: "|#gs#| {#Q, npost#} c'"

    show "|#gs#| {#P, npost#} (c @ c')"
    proof(cases "|gs| {Q} c'")
      case True
      then show ?thesis \<comment> \<open>get stuck here\<close>
    next
      case False

      then obtain mbad where Bad:
        "Q (payload mbad)" "cont mbad = Inl c'" "\<not> safe gs mbad"
        unfolding guarded_def
        by blast

      have Safe_post : "safe_for gs mbad npost"
        using guardediD[OF G Bad(1) Bad(2)]
        by simp

      then show ?thesis
    qed

  show "\<exists>npre. |#gs#| {#-P, (npre + npost)-#} c {#-Q, npost-#}"
*)

(* The following is of less practical use, but still interesting: we can actually prove
 * soundness and completeness for a slightly different version of the rule - however,
 * it seems like the changes we make in doing so are precisely those that make it
 * harder to reason about loops and termination without extra assumptions on control flow... *)
(* The issue is that the existentials are nested in such a way that this doesn't work...
 * this is why we have a new construct, HT''. But, what are the implications of this...? *)
definition HT'' :: "('syn, ('mstate :: Okay)) semc \<Rightarrow> ('mstate \<Rightarrow> bool) \<Rightarrow> 'syn gensyn list \<Rightarrow> ('mstate \<Rightarrow> bool)\<Rightarrow> bool" where
"HT'' gs P c Q \<equiv> (\<forall> npre c' . \<exists> npost . ( |#gs#| {#Q, npost#} c' \<longrightarrow> |#gs#| {#P, npre#} (c @ c')))"

lemma HT''I :
  assumes H : "\<And> npre c' .(\<And> npost . |#gs#| {#Q, npost#} c') \<Longrightarrow> |#gs#| {#P, npre#} (c @ c')"
  shows "HT'' gs P c Q" using assms unfolding HT''_def by blast

lemma HT''D :
  assumes H : "HT'' gs P c Q"
  assumes H1 : "(\<And> npost . |#gs#| {#Q, npost#} c')"
  shows "|#gs#| {#P, npre#} (c @ c')"
  using assms unfolding HT''_def by simp

lemma HT_imp_HT'' :
  assumes H : "|gs| {-P-} c {-Q-}"
  shows "HT'' gs P c Q"
proof(rule HT''I)
  fix npre c'

  assume X : "(\<And>npost. |#gs#| {#Q, npost#} c')"

  show "|#gs#| {#P, npre#} (c @ c')"
  proof(cases "guarded gs Q c'")
    case True

    have Guard : "|gs| {P} (c @ c')" using HTE[OF H True]
      by auto

    show ?thesis
    proof
      fix m :: "('a, 'b) control"
      assume M_ok : "m \<in> ok_S"
      assume HP : "P (payload m)"
      assume CP : "cont m = Inl (c @ c')"

      show "safe_for gs m npre" using safe_imp_safe_for[OF guardedD[OF Guard M_ok HP CP]]
        by blast
    qed

  next
    case False

    then obtain bad where Bad : "bad \<in> ok_S" "Q (payload bad)" "cont bad = Inl c'" "\<not> safe gs bad"
      unfolding guarded_def
      by blast

    obtain nbad where Nbad: "\<not> safe_for gs bad nbad" using unsafe_imp_unsafe_for[OF Bad(4)]
      by blast

    then have False using guardediD[OF X[of nbad] Bad(1) Bad(2) Bad(3)] by blast

    thus "|#gs#| {#P, npre#} (c @ c')" by blast
  qed
qed

lemma HT''_imp_HT :
  assumes H : "HT'' gs P c Q"
  shows "|gs| {-P-} c {-Q-}"
proof
  fix c'
  assume Guard : "|gs| {Q} c'"
  show "|gs| {P} (c @ c')"
  proof
    fix m :: "('a, 'b) control"
    assume M_ok : "m \<in> ok_S"
    assume Pm : "P (payload m)"
    assume Cm : "cont m = Inl (c @ c')"
    show "safe gs m"
    proof
      fix m'
      assume Exec : "sem_exec_p gs m m'"

      obtain n where Execc : "sem_exec_c_p gs m n m'"
        using exec_p_imp_exec_c_p[OF Exec] by auto

      have Guard'_out : "(\<And>npost. |#gs#| {#Q, npost#} c')"
      proof
        fix npost
        fix mx :: "('a, 'b) control"
        assume Mx_ok : "mx \<in> ok_S"
        assume Q: "Q (payload mx)"
        assume C: "cont mx = Inl c'"

        have Safe : "safe gs mx"
          using guardedD[OF Guard Mx_ok Q C] by simp

        show "safe_for gs mx npost"
          using safe_imp_safe_for[OF Safe] by simp
      qed

      have Guard'_in : "|#gs#| {#P, n#} (c @ c')"
        using HT''D[OF H Guard'_out] by blast

      have Safe' : "safe_for gs m n"
        using guardediD[OF Guard'_in M_ok Pm Cm] by simp

      show "imm_safe gs m'"
        using safe_for_imm_safe[OF Safe' Execc] by simp
    qed
  qed
qed

end