(*  Title:       Examples of hybrid systems verifications
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

subsection \<open> Examples \<close>

text \<open> We prove partial correctness specifications of some hybrid systems with our
refinement and verification components.\<close>

theory HS_VC_KAT_Examples_rel
  imports
    HS_VC_KAT_rel
    "HOL-Eisbach.Eisbach"

begin

\<comment> \<open>A tactic for verification of hybrid programs \<close>

named_theorems hoare_intros

declare H_assignl [hoare_intros]
    and H_cond [hoare_intros]
    and local_flow.H_g_ode_subset [hoare_intros]
    and H_g_ode_inv [hoare_intros]

method body_hoare
  = (rule hoare_intros,(simp)?; body_hoare?)

method hyb_hoare for P::"'a pred"
  = (rule H_loopI, rule H_seq[where R=P]; body_hoare?)

\<comment> \<open>A tactic for refinement of hybrid programs \<close>

named_theorems refine_intros "selected refinement lemmas"

declare R_loopI [refine_intros]
    and R_loop_mono [refine_intros]
    and R_cond_law [refine_intros]
    and R_cond_mono [refine_intros]
    and R_while_law [refine_intros]
    and R_assignl [refine_intros]
    and R_seq_law [refine_intros]
    and R_seq_mono [refine_intros]
    and R_g_evol_law [refine_intros]
    and R_skip [refine_intros]
    and R_g_ode_inv [refine_intros]

method refinement
  = (rule refine_intros; (refinement)?)

subsubsection \<open>Pendulum\<close>

text \<open> The ODEs @{text "x' t = y t"} and {text "y' t = - x t"} describe the circular motion of
a mass attached to a string looked from above. We use @{text "s$1"} to represent the x-coordinate
and @{text "s$2"} for the y-coordinate. We prove that this motion remains circular. \<close>

abbreviation fpend :: "real^2 \<Rightarrow> real^2" ("f")
  where "f s \<equiv> (\<chi> i. if i=1 then s$2 else -s$1)"

abbreviation pend_flow :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> \<tau> s \<equiv> (\<chi> i. if i = 1 then s$1 \<cdot> cos \<tau> + s$2 \<cdot> sin \<tau>
  else - s$1 \<cdot> sin \<tau> + s$2 \<cdot> cos \<tau>)"

\<comment> \<open>Verified with annotated dynamics \<close>

lemma pendulum_dyn: "\<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>} EVOL \<phi> G T \<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>}"
  by simp

\<comment> \<open>Verified with differential invariants \<close>

lemma pendulum_inv: "\<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>} (x\<acute>=f & G) \<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>}"
  by (auto intro!: diff_invariant_rules poly_derivatives)

\<comment> \<open>Verified with the flow \<close>

lemma local_flow_pend: "local_flow f UNIV UNIV \<phi>"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
  apply(rule_tac x="1" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def power2_commute UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma pendulum_flow: "\<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>} (x\<acute>=f & G) \<^bold>{\<lambda>s. r\<^sup>2 = (s $ 1)\<^sup>2 + (s $ 2)\<^sup>2\<^bold>}"
  by (subst local_flow.sH_g_ode_subset[OF local_flow_pend], simp_all)

no_notation fpend ("f")
        and pend_flow ("\<phi>")

subsubsection \<open> Bouncing Ball \<close>

text \<open> A ball is dropped from rest at an initial height @{text "h"}. The motion is described with
the free-fall equations @{text "x' t = v t"} and @{text "v' t = g"} where @{text "g"} is the
constant acceleration due to gravity. The bounce is modelled with a variable assignment that
flips the velocity. That is, we model it as a completely elastic collision with the ground. We use
@{text "s$1"} to represent the ball's height and @{text "s$2"} for its velocity. We prove that the
ball remains above ground and below its initial resting position. \<close>

abbreviation fball :: "real \<Rightarrow> real^2 \<Rightarrow> real^2" ("f")
  where "f g s \<equiv> (\<chi> i. if i=1 then s$2 else g)"

abbreviation ball_flow :: "real \<Rightarrow> real \<Rightarrow> real^2 \<Rightarrow> real^2" ("\<phi>")
  where "\<phi> g \<tau> s \<equiv> (\<chi> i. if i=1 then g \<cdot> \<tau> ^ 2/2 + s$2 \<cdot> \<tau> + s$1 else g \<cdot> \<tau> + s$2)"

\<comment> \<open>Verified with differential invariants \<close>

named_theorems bb_real_arith "real arithmetic properties for the bouncing ball."

lemma [bb_real_arith]:
  assumes "0 > g" and inv: "2 \<cdot> g \<cdot> x - 2 \<cdot> g \<cdot> h = v \<cdot> v"
  shows "(x::real) \<le> h"
proof-
  have "v \<cdot> v = 2 \<cdot> g \<cdot> x - 2 \<cdot> g \<cdot> h \<and> 0 > g"
    using inv and \<open>0 > g\<close> by auto
  hence obs:"v \<cdot> v = 2 \<cdot> g \<cdot> (x - h) \<and> 0 > g \<and> v \<cdot> v \<ge> 0"
    using left_diff_distrib mult.commute by (metis zero_le_square)
  hence "(v \<cdot> v)/(2 \<cdot> g) = (x - h)"
    by auto
  also from obs have "(v \<cdot> v)/(2 \<cdot> g) \<le> 0"
    using divide_nonneg_neg by fastforce
  ultimately have "h - x \<ge> 0"
    by linarith
  thus ?thesis by auto
qed

lemma fball_invariant:
  fixes g h :: real
  defines dinv: "I \<equiv> (\<lambda>s. 2 \<cdot> g \<cdot> s$1 - 2 \<cdot> g \<cdot> h - (s$2 \<cdot> s$2) = 0)"
  shows "diff_invariant I (\<lambda>t. f g) (\<lambda>s. UNIV) UNIV 0 G"
  unfolding dinv apply(rule diff_invariant_rules, simp)
  by(auto intro!: poly_derivatives)

lemma bouncing_ball_inv: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
 \<^bold>{\<lambda>s. s$1 = h \<and> s$2 = 0\<^bold>}
  (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0) DINV (\<lambda>s. 2 \<cdot> g \<cdot> s$1 - 2 \<cdot> g \<cdot> h - s$2 \<cdot> s$2 = 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2))
 \<^bold>{\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<^bold>}"
  apply(hyb_hoare "\<lambda>s::real^2. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2")
  using fball_invariant by (auto simp: bb_real_arith intro!: poly_derivatives diff_invariant_rules)

\<comment> \<open>Verified with annotated dynamics \<close>

lemma [bb_real_arith]:
  assumes invar: "2 \<cdot> g \<cdot> x = 2 \<cdot> g \<cdot> h + v \<cdot> v"
    and pos: "g \<cdot> \<tau>\<^sup>2 / 2 + v \<cdot> \<tau> + (x::real) = 0"
  shows "2 \<cdot> g \<cdot> h + (- (g \<cdot> \<tau>) - v) \<cdot> (- (g \<cdot> \<tau>) - v) = 0"
    and "2 \<cdot> g \<cdot> h + (g \<cdot> \<tau> \<cdot> (g \<cdot> \<tau> + v) + v \<cdot> (g \<cdot> \<tau> + v)) = 0"
proof-
  from pos have "g \<cdot> \<tau>\<^sup>2  + 2 \<cdot> v \<cdot> \<tau> + 2 \<cdot> x = 0" by auto
  then have "g\<^sup>2  \<cdot> \<tau>\<^sup>2  + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> x = 0"
    by (metis (mono_tags) Groups.mult_ac(1,3) mult_zero_right
        monoid_mult_class.power2_eq_square semiring_class.distrib_left)
  hence "g\<^sup>2 \<cdot> \<tau>\<^sup>2 + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + v\<^sup>2 + 2 \<cdot> g \<cdot> h = 0"
    using invar by (simp add: monoid_mult_class.power2_eq_square)
  hence obs: "(g \<cdot> \<tau> + v)\<^sup>2 + 2 \<cdot> g \<cdot> h = 0"
    apply(subst power2_sum) by (metis (no_types) Groups.add_ac(2, 3)
        Groups.mult_ac(2, 3) monoid_mult_class.power2_eq_square nat_distrib(2))
  thus "2 \<cdot> g \<cdot> h + (g \<cdot> \<tau> \<cdot> (g \<cdot> \<tau> + v) + v \<cdot> (g \<cdot> \<tau> + v)) = 0"
    by (simp add: monoid_mult_class.power2_eq_square)
  have  "2 \<cdot> g \<cdot> h + (- ((g \<cdot> \<tau>) + v))\<^sup>2 = 0"
    using obs by (metis Groups.add_ac(2) power2_minus)
  thus "2 \<cdot> g \<cdot> h + (- (g \<cdot> \<tau>) - v) \<cdot> (- (g \<cdot> \<tau>) - v) = 0"
    by (simp add: monoid_mult_class.power2_eq_square)
qed

lemma [bb_real_arith]:
  assumes invar: "2 \<cdot> g \<cdot> x = 2 \<cdot> g \<cdot> h + v \<cdot> v"
  shows "2 \<cdot> g \<cdot> (g \<cdot> \<tau>\<^sup>2 / 2 + v \<cdot> \<tau> + (x::real)) =
  2 \<cdot> g \<cdot> h + (g \<cdot> \<tau> \<cdot> (g \<cdot> \<tau> + v) + v \<cdot> (g \<cdot> \<tau> + v))" (is "?lhs = ?rhs")
proof-
  have "?lhs = g\<^sup>2 \<cdot> \<tau>\<^sup>2 + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> x"
    by(auto simp: algebra_simps semiring_normalization_rules(29))
    also have "... = g\<^sup>2 \<cdot> \<tau>\<^sup>2 + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> h + v \<cdot> v" (is "... = ?middle")
      by(subst invar, simp)
    finally have "?lhs = ?middle".
  moreover
  {have "?rhs = g \<cdot> g \<cdot> (\<tau> \<cdot> \<tau>) + 2 \<cdot> g \<cdot> v \<cdot> \<tau> + 2 \<cdot> g \<cdot> h + v \<cdot> v"
    by (simp add: Groups.mult_ac(2,3) semiring_class.distrib_left)
  also have "... = ?middle"
    by (simp add: semiring_normalization_rules(29))
  finally have "?rhs = ?middle".}
  ultimately show ?thesis by auto
qed

lemma bouncing_ball_dyn: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<^bold>{\<lambda>s. s$1 = h \<and> s$2 = 0\<^bold>}
  (LOOP
      ((EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T);
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2)
  ) \<^bold>{\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<^bold>}"
  apply(hyb_hoare "\<lambda>s::real^2. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2")
  by (auto simp: bb_real_arith)

\<comment> \<open>Verified with the flow \<close>

lemma local_flow_ball: "local_flow (f g) UNIV UNIV (\<phi> g)"
  apply(unfold_locales, simp_all add: local_lipschitz_def lipschitz_on_def vec_eq_iff, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
    apply(simp add: dist_norm norm_vec_def L2_set_def UNIV_2)
  by (auto simp: forall_2 intro!: poly_derivatives)

lemma bouncing_ball_flow: "g < 0 \<Longrightarrow> h \<ge> 0 \<Longrightarrow>
  \<^bold>{\<lambda>s. s$1 = h \<and> s$2 = 0\<^bold>}
  (LOOP
      ((x\<acute>= f g & (\<lambda> s. s$1 \<ge> 0));
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2)
  ) \<^bold>{\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<^bold>}"
  apply(rule H_loopI; (rule H_seq[where R="\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2"])?)
     apply(subst local_flow.sH_g_ode_subset[OF local_flow_ball])
  by (auto simp: bb_real_arith)

\<comment> \<open>Refined with annotated dynamics \<close>

lemma R_bb_assign: "g < (0::real) \<Longrightarrow> 0 \<le> h \<Longrightarrow>
  2 ::= (\<lambda>s. - s$2) \<le> rel_R
    \<lceil>\<lambda>s. s$1 = 0 \<and> 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2\<rceil>
    \<lceil>\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2\<rceil>"
  by (rule R_assign_law, auto)

lemma R_bouncing_ball_dyn:
  assumes "g < 0" and "h \<ge> 0"
  shows "rel_R \<lceil>\<lambda>s. s$1 = h \<and> s$2 = 0\<rceil> \<lceil>\<lambda>s. 0 \<le> s$1 \<and> s$1 \<le> h\<rceil> \<ge>
  (LOOP
      ((EVOL (\<phi> g) (\<lambda> s. s$1 \<ge> 0) T);
       (IF (\<lambda> s. s$1 = 0) THEN (2 ::= (\<lambda>s. - s$2)) ELSE skip))
    INV (\<lambda>s. 0 \<le> s$1 \<and> 2 \<cdot> g \<cdot> s$1 = 2 \<cdot> g \<cdot> h + s$2 \<cdot> s$2))"
  apply(refinement; (rule R_bb_assign[OF assms])?)
  using assms by (auto simp: bb_real_arith)

no_notation fball ("f")
        and ball_flow ("\<phi>")

subsubsection \<open> Thermostat \<close>

text \<open> A thermostat has a chronometer, a thermometer and a switch to turn on and off a heater.
At most every @{text "\<tau>"} minutes, it sets its chronometer to @{term "0::real"}, it registers
the room temperature, and it turns the heater on (or off) based on this reading. The temperature
follows the ODE @{text "T' = - a * (T - U)"} where @{text "U = L \<ge> 0"} when the heater
is on, and @{text "U = 0"} when it is off. We use @{term "1::4"} to denote the room's temperature,
@{term "2::4"} is time as measured by the thermostat's chronometer, and @{term "3::4"} is a variable
to save temperature measurements. Finally, @{term "4::5"} states whether the heater is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the thermostat keeps the room's
temperature between @{text "Tmin"} and @{text "Tmax"}. \<close>

abbreviation therm_vec_field :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f a L s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then - a * (s$1 - L) else 0))"

abbreviation therm_guard :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Tmin Tmax a L s \<equiv> (s$2 \<le> - (ln ((L-(if L=0 then Tmin else Tmax))/(L-s$3)))/a)"

abbreviation therm_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I Tmin Tmax s \<equiv> Tmin \<le> s$1 \<and> s$1 \<le> Tmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation therm_flow :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> a L \<tau> s \<equiv> (\<chi> i. if i = 1 then - exp(-a * \<tau>) * (L - s$1) + L else
  (if i = 2 then \<tau> + s$2 else s$i))"

\<comment> \<open>Verified with the flow \<close>

lemma norm_diff_therm_dyn: "0 < a \<Longrightarrow> \<parallel>f a L s\<^sub>1 - f a L s\<^sub>2\<parallel> = \<bar>a\<bar> * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
proof(simp add: norm_vec_def L2_set_def, unfold UNIV_4, simp)
  assume a1: "0 < a"
  have f2: "\<And>r ra. \<bar>(r::real) + - ra\<bar> = \<bar>ra + - r\<bar>"
    by (metis abs_minus_commute minus_real_def)
  have "\<And>r ra rb. (r::real) * ra + - (r * rb) = r * (ra + - rb)"
    by (metis minus_real_def right_diff_distrib)
  hence "\<bar>a * (s\<^sub>1$1 + - L) + - (a * (s\<^sub>2$1 + - L))\<bar> = a * \<bar>s\<^sub>1$1 + - s\<^sub>2$1\<bar>"
    using a1 by (simp add: abs_mult)
  thus "\<bar>a * (s\<^sub>2$1 - L) - a * (s\<^sub>1$1 - L)\<bar> = a * \<bar>s\<^sub>1$1 - s\<^sub>2$1\<bar>"
    using f2 minus_real_def by presburger
qed

lemma local_lipschitz_therm_dyn:
  assumes "0 < (a::real)"
  shows "local_lipschitz UNIV UNIV (\<lambda>t::real. f a L)"
  apply(unfold local_lipschitz_def lipschitz_on_def dist_norm)
  apply(clarsimp, rule_tac x=1 in exI, clarsimp, rule_tac x=a in exI)
  using assms apply(simp_all add: norm_diff_therm_dyn)
  apply(simp add: norm_vec_def L2_set_def, unfold UNIV_4, clarsimp)
  unfolding real_sqrt_abs[symmetric] by (rule real_le_lsqrt) auto

lemma local_flow_therm: "a > 0 \<Longrightarrow> local_flow (f a L) UNIV UNIV (\<phi> a L)"
  by (unfold_locales, auto intro!: poly_derivatives local_lipschitz_therm_dyn
      simp: forall_4 vec_eq_iff)

lemma therm_dyn_down_real_arith:
  assumes "a > 0" and Thyps: "0 < Tmin" "Tmin \<le> T" "T \<le> Tmax"
    and thyps: "0 \<le> (\<tau>::real)" "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - (ln (Tmin / T) / a) "
  shows "Tmin \<le> exp (-a * \<tau>) * T" and "exp (-a * \<tau>) * T \<le> Tmax"
proof-
  have "0 \<le> \<tau> \<and> \<tau> \<le> - (ln (Tmin / T) / a)"
    using thyps by auto
  hence "ln (Tmin / T) \<le> - a * \<tau> \<and> - a * \<tau> \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "Tmin / T > 0"
    using Thyps by auto
  ultimately have obs: "Tmin / T \<le> exp (-a * \<tau>)" "exp (-a * \<tau>) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less, simp)
  thus "Tmin \<le> exp (-a * \<tau>) * T"
    using Thyps by (simp add: pos_divide_le_eq)
  show "exp (-a * \<tau>) * T \<le> Tmax"
    using Thyps mult_left_le_one_le[OF _ exp_ge_zero obs(2), of T]
      less_eq_real_def order_trans_rules(23) by blast
qed

lemma therm_dyn_up_real_arith:
  assumes "a > 0" and Thyps: "Tmin \<le> T" "T \<le> Tmax" "Tmax < (L::real)"
    and thyps: "0 \<le> \<tau>" "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a) "
  shows "L - Tmax \<le> exp (-(a * \<tau>)) * (L - T)"
    and "L - exp (-(a * \<tau>)) * (L - T) \<le> Tmax"
    and "Tmin \<le> L - exp (-(a * \<tau>)) * (L - T)"
proof-
  have "0 \<le> \<tau> \<and> \<tau> \<le> - (ln ((L - Tmax) / (L - T)) / a)"
    using thyps by auto
  hence "ln ((L - Tmax) / (L - T)) \<le> - a * \<tau> \<and> - a * \<tau> \<le> 0"
    using assms(1) divide_le_cancel by fastforce
  also have "(L - Tmax) / (L - T) > 0"
    using Thyps by auto
  ultimately have "(L - Tmax) / (L - T) \<le> exp (-a * \<tau>) \<and> exp (-a * \<tau>) \<le> 1"
    using exp_ln exp_le_one_iff by (metis exp_less_cancel_iff not_less)
  moreover have "L - T > 0"
    using Thyps by auto
  ultimately have obs: "(L - Tmax) \<le> exp (-a * \<tau>) * (L - T) \<and> exp (-a * \<tau>) * (L - T) \<le> (L - T)"
    by (simp add: pos_divide_le_eq)
  thus "(L - Tmax) \<le> exp (-(a * \<tau>)) * (L - T)"
    by auto
  thus "L - exp (-(a * \<tau>)) * (L - T) \<le> Tmax"
    by auto
  show "Tmin \<le> L - exp (-(a * \<tau>)) * (L - T)"
    using Thyps and obs by auto
qed

lemmas H_g_ode_therm = local_flow.sH_g_ode_ivl[OF local_flow_therm _ UNIV_I]

lemma thermostat_flow:
  assumes "0 < a" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "\<^bold>{I Tmin Tmax\<^bold>}
  (LOOP (
    \<comment> \<open>control\<close>
    (2 ::= (\<lambda>s. 0));
    (3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN
      (4 ::= (\<lambda>s.1))
     ELSE IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN
      (4 ::= (\<lambda>s.0))
     ELSE skip);
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN
      (x\<acute>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
    ELSE
      (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0))
  ) INV I Tmin Tmax)
   \<^bold>{I Tmin Tmax\<^bold>}"
  apply(rule H_loopI)
    apply(rule_tac R="\<lambda>s. I Tmin Tmax s \<and> s$2=0" in H_seq, simp)
     apply(rule_tac R="\<lambda>s. I Tmin Tmax s \<and> s$2=0 \<and> s$1 = s$3" in H_seq, simp)
  apply(rule_tac R="\<lambda>s. I Tmin Tmax s \<and> s$2=0 \<and> s$1 = s$3" in H_seq, simp)
    apply(rule H_cond, simp_all add: H_g_ode_therm[OF assms(1,2)], safe)
  using therm_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin]
    and therm_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

\<comment> \<open>Refined with the flow \<close>

lemma R_therm_dyn_down:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "rel_R \<lceil>\<lambda>s. s$4 = 0 \<and> I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
    (x\<acute>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)"
  apply(rule local_flow.R_g_ode_ivl[OF local_flow_therm])
  using assms therm_dyn_down_real_arith[OF assms(1,3), of _ Tmax] by auto

lemma R_therm_dyn_up:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "rel_R \<lceil>\<lambda>s. s$4 \<noteq> 0 \<and> I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
    (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0)"
  apply(rule local_flow.R_g_ode_ivl[OF local_flow_therm])
  using assms therm_dyn_up_real_arith[OF assms(1) _ _ assms(4), of Tmin] by auto

lemma R_therm_dyn:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "rel_R \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
  (IF (\<lambda>s. s$4 = 0) THEN
    (x\<acute>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
  ELSE
    (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0))"
  apply(rule order_trans, rule R_cond_mono)
  apply(rule R_therm_dyn_down[OF assms])
  using R_therm_dyn_down[OF assms] R_therm_dyn_up[OF assms] by (auto intro!: R_cond)

lemma R_therm_assign1: "rel_R \<lceil>I Tmin Tmax\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0\<rceil> \<ge> (2 ::= (\<lambda>s. 0))"
  by (auto simp: R_assign_law)

lemma R_therm_assign2:
  "rel_R \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<ge> (3 ::= (\<lambda>s. s$1))"
  by (auto simp: R_assign_law)

lemma R_therm_ctrl:
  "rel_R \<lceil>I Tmin Tmax\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<ge>
  (2 ::= (\<lambda>s. 0));
  (3 ::= (\<lambda>s. s$1));
  (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN
    (4 ::= (\<lambda>s.1))
   ELSE IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN
    (4 ::= (\<lambda>s.0))
   ELSE skip)"
  apply(refinement, rule R_therm_assign1, rule R_therm_assign2)
  by (rule R_assign_law, simp)+ auto

lemma R_therm_loop: "rel_R \<lceil>I Tmin Tmax\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
  (LOOP
    rel_R \<lceil>I Tmin Tmax\<rceil> \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil>;
    rel_R \<lceil>\<lambda>s. I Tmin Tmax s \<and> s$2 = 0 \<and> s$3 = s$1\<rceil> \<lceil>I Tmin Tmax\<rceil>
  INV I Tmin Tmax)"
  by (intro R_loopI R_seq, simp_all)

lemma R_thermostat_flow:
  assumes "a > 0" and "0 \<le> \<tau>" and "0 < Tmin" and "Tmax < L"
  shows "rel_R \<lceil>I Tmin Tmax\<rceil> \<lceil>I Tmin Tmax\<rceil> \<ge>
  (LOOP (
    \<comment> \<open>control\<close>
    (2 ::= (\<lambda>s. 0));(3 ::= (\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> Tmin + 1) THEN
      (4 ::= (\<lambda>s.1))
     ELSE IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> Tmax - 1) THEN
      (4 ::= (\<lambda>s.0))
     ELSE skip);
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN
      (x\<acute>= (\<lambda>t. f a 0) & G Tmin Tmax a 0 on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
    ELSE
      (x\<acute>= (\<lambda>t. f a L) & G Tmin Tmax a L on (\<lambda>s. {0..\<tau>}) UNIV @ 0))
  ) INV I Tmin Tmax)"
  apply(refinement; (rule R_therm_assign1)?, (rule R_therm_assign2)?,
      (rule R_therm_dyn_down)?, (rule R_therm_dyn_up)?, (rule R_assign_law)?)
  using assms by auto

no_notation therm_vec_field ("f")
        and therm_flow ("\<phi>")
        and therm_guard ("G")
        and therm_loop_inv ("I")

subsubsection \<open> Water tank \<close> \<comment> \<open> Variation of Hespanha and Alur's tank \<close>

subsubsection \<open> Tank \<close>

text \<open> A controller turns a water pump on and off to keep the level of water @{text "h"} in a tank
within an acceptable range @{text "hmin \<le> h \<le> hmax"}. Just like in the previous example, after
each intervention, the controller registers the current level of water and resets its chronometer,
then it changes the status of the water pump accordingly. The level of water grows linearly
@{text "h' = k"} at a rate of @{text "k = c\<^sub>i-c\<^sub>o"} if the pump is on, and at a rate of
@{text "k = -c\<^sub>o"} if the pump is off. We use @{term "1::4"} to denote the tank's level of water,
@{term "2::4"} is time as measured by the controller's chronometer, @{term "3::4"} is the
level of water measured by the chronometer, and @{term "4::4"} states whether the pump is on
(@{text "s$4 = 1"}) or off (@{text "s$4 = 0"}). We prove that the controller keeps the level of
water between @{text "hmin"} and @{text "hmax"}. \<close>

abbreviation tank_vec_field :: "real \<Rightarrow> real^4 \<Rightarrow> real^4" ("f")
  where "f k s \<equiv> (\<chi> i. if i = 2 then 1 else (if i = 1 then k else 0))"

abbreviation tank_flow :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> real^4" ("\<phi>")
  where "\<phi> k \<tau> s \<equiv> (\<chi> i. if i = 1 then k * \<tau> + s$1 else
  (if i = 2 then \<tau> + s$2 else s$i))"

abbreviation tank_guard :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("G")
  where "G Hm k s \<equiv> s$2 \<le> (Hm - s$3)/k"

abbreviation tank_loop_inv :: "real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("I")
  where "I hmin hmax s \<equiv> hmin \<le> s$1 \<and> s$1 \<le> hmax \<and> (s$4 = 0 \<or> s$4 = 1)"

abbreviation tank_diff_inv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real^4 \<Rightarrow> bool" ("dI")
  where "dI hmin hmax k s \<equiv> s$1 = k \<cdot> s$2 + s$3 \<and> 0 \<le> s$2 \<and>
    hmin \<le> s$3 \<and> s$3 \<le> hmax \<and> (s$4 =0 \<or> s$4 = 1)"

\<comment> \<open>Verified with the flow \<close>

lemma local_flow_tank: "local_flow (f k) UNIV UNIV (\<phi> k)"
  apply (unfold_locales, unfold local_lipschitz_def lipschitz_on_def, simp_all, clarsimp)
  apply(rule_tac x="1/2" in exI, clarsimp, rule_tac x=1 in exI)
  apply(simp add: dist_norm norm_vec_def L2_set_def, unfold UNIV_4)
  by (auto intro!: poly_derivatives simp: vec_eq_iff)

lemma tank_arith:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> - ((hmin - y) / c\<^sub>o) \<Longrightarrow>  hmin \<le> y - c\<^sub>o * \<tau>"
    and "\<forall>\<tau>\<in>{0..\<tau>}. \<tau> \<le> (hmax - y) / (c\<^sub>i - c\<^sub>o) \<Longrightarrow>  (c\<^sub>i - c\<^sub>o) * \<tau> + y \<le> hmax"
    and "hmin \<le> y \<Longrightarrow> hmin \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y"
    and "y \<le> hmax \<Longrightarrow> y - c\<^sub>o \<cdot> \<tau> \<le> hmax"
  apply(simp_all add: field_simps le_divide_eq assms)
  using assms apply (meson add_mono less_eq_real_def mult_left_mono)
  using assms by (meson add_increasing2 less_eq_real_def mult_nonneg_nonneg)

lemmas H_g_ode_tank = local_flow.sH_g_ode_ivl[OF local_flow_tank _ UNIV_I]

lemma tank_flow:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<^bold>{I hmin hmax\<^bold>}
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN (x\<acute>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0)
     ELSE (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0)) )
  INV I hmin hmax)
  \<^bold>{I hmin hmax\<^bold>}"
   apply(rule H_loopI)
    apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0" in H_seq, simp)
     apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq, simp)
      apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq, simp)
     apply(rule H_cond, simp_all add: H_g_ode_tank[OF assms(1)])
  using assms tank_arith[OF _ assms(2,3)] by auto

\<comment> \<open>Verified with differential invariants \<close>

lemma tank_diff_inv:
  "0 \<le> \<tau> \<Longrightarrow> diff_invariant (dI hmin hmax k) (\<lambda>t. f k) (\<lambda>s. {0..\<tau>}) UNIV 0 Guard"
  apply(intro diff_invariant_conj_rule)
      apply(force intro!: poly_derivatives diff_invariant_rules)
     apply(rule_tac \<nu>'="\<lambda>t. 0" and \<mu>'="\<lambda>t. 1" in diff_invariant_leq_rule, simp_all, presburger)
    apply(rule_tac \<nu>'="\<lambda>t. 0" and \<mu>'="\<lambda>t. 0" in diff_invariant_leq_rule, simp_all)
    apply(force intro!: poly_derivatives)+
  by (auto intro!: poly_derivatives diff_invariant_rules)

lemma tank_inv_arith1:
  assumes "0 \<le> (\<tau>::real)" and "c\<^sub>o < c\<^sub>i" and b: "hmin \<le> y\<^sub>0" and g: "\<tau> \<le> (hmax - y\<^sub>0) / (c\<^sub>i - c\<^sub>o)"
  shows "hmin \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0" and "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0 \<le> hmax"
proof-
  have "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> \<le> (hmax - y\<^sub>0)"
    using g assms(2,3) by (metis diff_gt_0_iff_gt mult.commute pos_le_divide_eq)
  thus "(c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0 \<le> hmax"
    by auto
  show "hmin \<le> (c\<^sub>i - c\<^sub>o) \<cdot> \<tau> + y\<^sub>0"
    using b assms(1,2) by (metis add.commute add_increasing2 diff_ge_0_iff_ge
        less_eq_real_def mult_nonneg_nonneg)
qed

lemma tank_inv_arith2:
  assumes "0 \<le> (\<tau>::real)" and "0 < c\<^sub>o" and b: "y\<^sub>0 \<le> hmax" and g: "\<tau> \<le> - ((hmin - y\<^sub>0) / c\<^sub>o)"
  shows "hmin \<le> y\<^sub>0 - c\<^sub>o \<cdot> \<tau>" and "y\<^sub>0 - c\<^sub>o \<cdot> \<tau> \<le> hmax"
proof-
  have "\<tau> \<cdot> c\<^sub>o \<le> y\<^sub>0 - hmin"
    using g \<open>0 < c\<^sub>o\<close> pos_le_minus_divide_eq by fastforce
  thus "hmin \<le> y\<^sub>0 - c\<^sub>o \<cdot> \<tau>"
    by (auto simp: mult.commute)
  show "y\<^sub>0 - c\<^sub>o \<cdot> \<tau> \<le> hmax"
    using b assms(1,2) by (smt mult_nonneg_nonneg)
qed

lemma tank_inv:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "\<^bold>{I hmin hmax\<^bold>}
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN
      (x\<acute>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (c\<^sub>i-c\<^sub>o)))
     ELSE
      (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (-c\<^sub>o)))) )
  INV I hmin hmax)
  \<^bold>{I hmin hmax\<^bold>}"
  apply(rule H_loopI)
    apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0" in H_seq, simp)
    apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq, simp)
      apply(rule_tac R="\<lambda>s. I hmin hmax s \<and> s$2=0 \<and> s$3 = s$1" in H_seq, simp)
    apply(rule H_cond, simp)
     apply(rule H_g_ode_inv, simp add: tank_diff_inv[OF assms(1)], clarsimp, clarsimp)
  using assms tank_inv_arith1 apply force
    apply(rule H_g_ode_inv, simp only: sH_diff_inv)
      apply(rule tank_diff_inv[OF assms(1)])
  using assms tank_inv_arith2 by auto

\<comment> \<open>Refined with differential invariants \<close>

abbreviation tank_ctrl :: "real \<Rightarrow> real \<Rightarrow> (real^4) rel" ("ctrl")
  where "ctrl hmin hmax \<equiv> ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip)))"

abbreviation tank_dyn_dinv :: "real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> (real^4) rel" ("dyn")
  where "dyn c\<^sub>i c\<^sub>o hmin hmax \<tau> \<equiv> (IF (\<lambda>s. s$4 = 0) THEN
      (x\<acute>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (c\<^sub>i-c\<^sub>o)))
     ELSE
      (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (-c\<^sub>o))))"

abbreviation "tank_dinv c\<^sub>i c\<^sub>o hmin hmax \<tau> \<equiv>
  LOOP (ctrl hmin hmax ; dyn c\<^sub>i c\<^sub>o hmin hmax \<tau>) INV (I hmin hmax)"

lemma R_tank_inv:
  assumes "0 \<le> \<tau>" and "0 < c\<^sub>o" and "c\<^sub>o < c\<^sub>i"
  shows "rel_R \<lceil>I hmin hmax\<rceil> \<lceil>I hmin hmax\<rceil> \<ge>
  (LOOP
    \<comment> \<open>control\<close>
    ((2 ::=(\<lambda>s.0));(3 ::=(\<lambda>s. s$1));
    (IF (\<lambda>s. s$4 = 0 \<and> s$3 \<le> hmin + 1) THEN (4 ::= (\<lambda>s.1)) ELSE
    (IF (\<lambda>s. s$4 = 1 \<and> s$3 \<ge> hmax - 1) THEN (4 ::= (\<lambda>s.0)) ELSE skip));
    \<comment> \<open>dynamics\<close>
    (IF (\<lambda>s. s$4 = 0) THEN
      (x\<acute>= (\<lambda>t. f (c\<^sub>i-c\<^sub>o)) & G hmax (c\<^sub>i-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (c\<^sub>i-c\<^sub>o)))
     ELSE
      (x\<acute>= (\<lambda>t. f (-c\<^sub>o)) & G hmin (-c\<^sub>o) on (\<lambda>s. {0..\<tau>}) UNIV @ 0 DINV (dI hmin hmax (-c\<^sub>o)))) )
  INV I hmin hmax)"
proof-
  have "rel_R \<lceil>I hmin hmax\<rceil> \<lceil>I hmin hmax\<rceil> \<ge>
    LOOP (
      (2 ::= (\<lambda>s. 0)); (rel_R \<lceil>\<lambda>s. I hmin hmax s \<and> s$2 = 0\<rceil> \<lceil>I hmin hmax\<rceil>)
    ) INV I hmin hmax" (is "_ \<ge> ?R")
    by (refinement, auto)
  moreover have
    "?R \<ge> LOOP (
      (2 ::= (\<lambda>s. 0));(3 ::=(\<lambda>s. s$1));
      (rel_R \<lceil>\<lambda>s. I hmin hmax s \<and> s$2 = 0 \<and> s$3=s$1\<rceil> \<lceil>I hmin hmax\<rceil>)
    ) INV I hmin hmax" (is "_ \<ge> ?R")
    by (refinement, auto)
  moreover have
    "?R \<ge> LOOP (
      ctrl hmin hmax;
      (rel_R \<lceil>\<lambda>s. I hmin hmax s \<and> s$2 = 0 \<and> s$3=s$1\<rceil> \<lceil>I hmin hmax\<rceil>)
    ) INV I hmin hmax" (is "_ \<ge> ?R")
    by (simp only: O_assoc, refinement; (force)?, (rule R_assign_law)?) auto
  moreover have
    "?R \<ge> LOOP (ctrl hmin hmax; dyn c\<^sub>i c\<^sub>o hmin hmax \<tau>) INV I hmin hmax"
    apply(simp only: O_assoc, refinement; ((rule tank_diff_inv[OF assms(1)])? | (simp)?))
    using tank_inv_arith1 tank_inv_arith2 assms by auto
  ultimately show ?thesis
    by (auto simp: O_assoc)
qed

no_notation tank_vec_field ("f")
        and tank_flow ("\<phi>")
        and tank_guard ("G")
        and tank_loop_inv ("I")
        and tank_diff_inv ("dI")

end


(*
  File: FOL_Base.thy
  Author: Bohua Zhan

  Theorems in logic needed to setup auto2 for FOL.
*)

theory FOL_Base
  imports FOL
begin

section \<open>Declare type of sets\<close>

declare [[eta_contract = false]]

(* Type of sets *)
typedecl i
instance i :: "term" ..

(* Membership relation *)
axiomatization mem :: "[i, i] \<Rightarrow> o"  (infixl "\<in>" 50)

(* Bounded quantifiers *)
definition Ball :: "[i, i \<Rightarrow> o] \<Rightarrow> o" where
  "Ball(A, P) \<longleftrightarrow> (\<forall>x. x\<in>A \<longrightarrow> P(x))"

definition Bex :: "[i, i \<Rightarrow> o] \<Rightarrow> o" where
  "Bex(A, P) \<longleftrightarrow> (\<exists>x. x\<in>A \<and> P(x))"

syntax
  "_Ball" :: "[pttrn, i, o] \<Rightarrow> o"  ("(3\<forall>_\<in>_./ _)" 10)
  "_Bex" :: "[pttrn, i, o] \<Rightarrow> o"  ("(3\<exists>_\<in>_./ _)" 10)
translations
  "\<forall>x\<in>A. P" \<rightleftharpoons> "CONST Ball(A, \<lambda>x. P)"
  "\<exists>x\<in>A. P" \<rightleftharpoons> "CONST Bex(A, \<lambda>x. P)"

abbreviation not_mem :: "[i, i] \<Rightarrow> o"  (infixl "\<notin>" 50) where
  "x \<notin> y \<equiv> \<not> (x \<in> y)"

section \<open>Theorems in logic used in auto2\<close>

theorem to_contra_form: "Trueprop (A) \<equiv> (\<not>A \<Longrightarrow> False)" by (rule equal_intr_rule) auto
theorem to_contra_form': "Trueprop (\<not>A) \<equiv> (A \<Longrightarrow> False)" by (rule equal_intr_rule) auto

theorem iffD: "A \<longleftrightarrow> B \<Longrightarrow> (A \<longrightarrow> B) \<and> (B \<longrightarrow> A)" by auto
theorem contra_triv: "\<not>A \<Longrightarrow> A \<Longrightarrow> False" by simp
theorem or_intro1: "\<not> (P \<or> Q) \<Longrightarrow> \<not> P" by simp
theorem or_intro2: "\<not> (P \<or> Q) \<Longrightarrow> \<not> Q" by simp
theorem or_cancel1: "\<not>Q \<Longrightarrow> (P \<or> Q) \<longleftrightarrow> P" by auto
theorem or_cancel2: "\<not>P \<Longrightarrow> (P \<or> Q) \<longleftrightarrow> Q" by auto
theorem not_imp: "\<not>(P \<longrightarrow> Q) \<longleftrightarrow> P \<and> \<not>Q" by auto
theorem exE': "(\<And>x. P(x) \<Longrightarrow> Q) \<Longrightarrow> \<exists>x. P(x) \<Longrightarrow> Q" by auto
theorem eq_True: "A \<Longrightarrow> A \<longleftrightarrow> True" by simp
theorem eq_True_inv: "A \<longleftrightarrow> True \<Longrightarrow> A" by simp
theorem disj_True1: "(True \<or> A) \<longleftrightarrow> True" by simp
theorem disj_True2: "(A \<or> True) \<longleftrightarrow> True" by simp
theorem ex_vardef: "\<exists>x. x = a" by simp
theorem nn_create: "A \<Longrightarrow> \<not>\<not>A" by auto
theorem all_trivial: "(\<forall>x. P) \<longleftrightarrow> P" by auto

theorem obj_sym: "Trueprop (t = s) \<equiv> Trueprop (s = t)" by (rule equal_intr_rule) auto
theorem obj_sym_iff: "Trueprop (t \<longleftrightarrow> s) \<equiv> Trueprop (s \<longleftrightarrow> t)" by (rule equal_intr_rule) auto
theorem to_meta_eq: "Trueprop (t = s) \<equiv> (t \<equiv> s)" by (rule equal_intr_rule) auto
theorem to_meta_eq_iff: "Trueprop (t \<longleftrightarrow> s) \<equiv> (t \<equiv> s)" by (rule equal_intr_rule) auto

theorem inv_backward: "P \<longleftrightarrow> Q \<Longrightarrow> \<not>P \<Longrightarrow> \<not>Q" by simp
theorem backward_conv: "(A \<Longrightarrow> B) \<equiv> (\<not>B \<Longrightarrow> \<not>A)" by (rule equal_intr_rule) auto
theorem backward1_conv: "(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (\<not>C \<Longrightarrow> B \<Longrightarrow> \<not>A)" by (rule equal_intr_rule) auto
theorem backward2_conv: "(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (\<not>C \<Longrightarrow> A \<Longrightarrow> \<not>B)" by (rule equal_intr_rule) auto
theorem resolve_conv: "(A \<Longrightarrow> B) \<equiv> (\<not>B \<Longrightarrow> A \<Longrightarrow> False)" by (rule equal_intr_rule) auto

(* Quantifiers: swapping out of ALL or EX *)
theorem swap_ex_conj: "(P \<and> (\<exists>x. Q(x))) \<longleftrightarrow> (\<exists>x. P \<and> Q(x))" by auto
theorem swap_all_disj: "(P \<or> (\<forall>x. Q(x))) \<longleftrightarrow> (\<forall>x. P \<or> Q(x))" by auto

(* Use these instead of original versions to keep names in abstractions. *)
theorem Bex_def': "(\<exists>x\<in>S. P(x)) \<longleftrightarrow> (\<exists>x. x \<in> S \<and> P(x))" using Bex_def by auto
theorem Ball_def': "(\<forall>x\<in>S. P(x)) \<longleftrightarrow> (\<forall>x. x \<in> S \<longrightarrow> P(x))" using Ball_def by auto

(* Taking conjunction of assumptions *)

theorem atomize_conjL: "(A \<Longrightarrow> B \<Longrightarrow> PROP C) \<equiv> (A \<and> B \<Longrightarrow> PROP C)"
proof
  assume 1: "A \<Longrightarrow> B \<Longrightarrow> PROP C" and 2: "A \<and> B"
    have 3: "A" using 2 by auto
    have 4: "B" using 2 by auto
    show "PROP C" using 1[OF 3 4] by assumption
next
  assume 1: "A \<and> B \<Longrightarrow> PROP C" and 2: A and 3: B
    have 4: "A \<and> B" using 2 3 by auto
    show "PROP C" using 1[OF 4] by assumption
qed

(* Other rules *)
theorem imp_conv_disj: "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not>P \<or> Q)" by auto
theorem not_ex: "\<not>(\<exists>x. P(x)) \<longleftrightarrow> (\<forall>x. \<not>P(x))" by simp
theorem not_all: "\<not>(\<forall>x. P(x)) \<longleftrightarrow> (\<exists>x. \<not>P(x))" by simp

(* AC for conj and disj *)
theorem conj_assoc: "(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> Q \<and> R" by simp
theorem disj_assoc: "(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> Q \<or> R" by simp

end


(*  Title:       Safe OCL
    Author:      Denis Nikiforov, March 2019
    Maintainer:  Denis Nikiforov <denis.nikif at gmail.com>
    License:     LGPL
*)
section \<open>Errorable\<close>
theory Errorable
  imports Main
begin

datatype 'a errorable = ErrorFree 'a | Errorable 'a

instantiation errorable :: (order) order
begin

fun less_errorable where
  "ErrorFree \<tau> < ErrorFree \<sigma> = (\<tau> < \<sigma>)"
| "Errorable \<tau> < ErrorFree \<sigma> = False"
| "ErrorFree \<tau> < Errorable \<sigma> = (\<tau> \<le> \<sigma>)"
| "Errorable \<tau> < Errorable \<sigma> = (\<tau> < \<sigma>)"

fun less_eq_errorable where
  "ErrorFree \<tau> \<le> ErrorFree \<sigma> = (\<tau> \<le> \<sigma>)"
| "Errorable \<tau> \<le> ErrorFree \<sigma> = False"
| "ErrorFree \<tau> \<le> Errorable \<sigma> = (\<tau> \<le> \<sigma>)"
| "Errorable \<tau> \<le> Errorable \<sigma> = (\<tau> \<le> \<sigma>)"

lemma less_le_not_le_errorable:
  "\<tau> < \<sigma> \<longleftrightarrow> \<tau> \<le> \<sigma> \<and> \<not> \<sigma> \<le> \<tau>"
  for \<tau> \<sigma> :: "'a errorable"
  by (cases \<tau>; cases \<sigma>; auto)

lemma order_refl_errorable:
  "\<tau> \<le> \<tau>"
  for \<tau> :: "'a errorable"
  by (cases \<tau>; auto)

lemma order_trans_errorable:
  "\<tau> \<le> \<sigma> \<Longrightarrow> \<sigma> \<le> \<rho> \<Longrightarrow> \<tau> \<le> \<rho>"
  for \<tau> \<sigma> \<rho> :: "'a errorable"
  by (cases \<tau>; cases \<sigma>; cases \<rho>; auto)

lemma antisym_errorable:
  "\<tau> \<le> \<sigma> \<Longrightarrow> \<sigma> \<le> \<tau> \<Longrightarrow> \<tau> = \<sigma>"
  for \<tau> \<sigma> :: "'a errorable"
  by (cases \<tau>; cases \<sigma>; auto)

instance
  apply intro_classes
  apply (simp add: less_le_not_le_errorable)
  apply (simp add: order_refl_errorable)
  using order_trans_errorable apply blast
  by (simp add: antisym_errorable)

end

lemma less_x_ErrorFree_intro [intro]:
  "\<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < ErrorFree \<sigma>"
  by simp

lemma less_eq_x_ErrorFree_intro [intro]:
  "\<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> ErrorFree \<sigma>"
  by simp

lemma less_x_Errorable_intro [intro]:
  "\<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> < Errorable \<sigma>"
  "\<tau> = Errorable \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> \<tau> < Errorable \<sigma>"
  by simp_all

lemma less_eq_x_Errorable_intro [intro]:
  "\<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Errorable \<sigma>"
  "\<tau> = Errorable \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> \<tau> \<le> Errorable \<sigma>"
  by simp_all

lemma less_x_ErrorFree [elim!]:
  "\<tau> < ErrorFree \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (erule less_errorable.elims; auto)

lemma less_eq_x_ErrorFree [elim!]:
  "\<tau> \<le> ErrorFree \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (erule less_eq_errorable.elims; auto)

lemma less_x_Errorable [elim!]:
  "\<tau> < Errorable \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Errorable \<rho> \<Longrightarrow> \<rho> < \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (erule less_errorable.elims; auto)

lemma less_eq_x_Errorable [elim!]:
  "\<tau> \<le> Errorable \<sigma> \<Longrightarrow>
   (\<And>\<rho>. \<tau> = ErrorFree \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow>
   (\<And>\<rho>. \<tau> = Errorable \<rho> \<Longrightarrow> \<rho> \<le> \<sigma> \<Longrightarrow> P) \<Longrightarrow> P"
  by (erule less_eq_errorable.elims; auto)

lemma errorable_less_left_simps [simp]:
  "ErrorFree \<rho> < \<sigma> = (\<exists>\<upsilon>.
      \<sigma> = ErrorFree \<upsilon> \<and> \<rho> < \<upsilon> \<or>
      \<sigma> = Errorable \<upsilon> \<and> \<rho> \<le> \<upsilon>)"
  "Errorable \<rho> < \<sigma> = (\<exists>\<upsilon>.
      \<sigma> = Errorable \<upsilon> \<and> \<rho> < \<upsilon>)"
  by (induct \<sigma>; auto)+

lemma errorable_less_eq_left_simps [simp]:
  "ErrorFree \<rho> \<le> \<sigma> = (\<exists>\<upsilon>.
      \<sigma> = ErrorFree \<upsilon> \<and> \<rho> \<le> \<upsilon> \<or>
      \<sigma> = Errorable \<upsilon> \<and> \<rho> \<le> \<upsilon>)"
  "Errorable \<rho> \<le> \<sigma> = (\<exists>\<upsilon>.
      \<sigma> = Errorable \<upsilon> \<and> \<rho> \<le> \<upsilon>)"
  by (auto simp: dual_order.order_iff_strict)

lemma errorable_less_right_simps [simp]:
  "\<tau> < ErrorFree \<upsilon> = (\<exists>\<rho>.
      \<tau> = ErrorFree \<rho> \<and> \<rho> < \<upsilon>)"
  "\<tau> < Errorable \<upsilon> = (\<exists>\<rho>.
      \<tau> = ErrorFree \<rho> \<and> \<rho> \<le> \<upsilon> \<or>
      \<tau> = Errorable \<rho> \<and> \<rho> < \<upsilon>)"
  by auto

lemma errorable_less_eq_right_simps [simp]:
  "\<tau> \<le> ErrorFree \<upsilon> = (\<exists>\<rho>. \<tau> = ErrorFree \<rho> \<and> \<rho> \<le> \<upsilon>)"
  "\<tau> \<le> Errorable \<upsilon> = (\<exists>\<rho>. \<tau> = ErrorFree \<rho> \<and> \<rho> \<le> \<upsilon> \<or> \<tau> = Errorable \<rho> \<and> \<rho> \<le> \<upsilon>)"
  by auto

notation sup (infixl "\<squnion>" 65)

instantiation errorable :: (semilattice_sup) semilattice_sup
begin

primrec sup_errorable where
  "ErrorFree \<tau> \<squnion> \<sigma> = (case \<sigma>
    of ErrorFree \<rho> \<Rightarrow> ErrorFree (\<tau> \<squnion> \<rho>)
     | Errorable \<rho> \<Rightarrow> Errorable (\<tau> \<squnion> \<rho>))"
| "Errorable \<tau> \<squnion> \<sigma> = (case \<sigma>
    of ErrorFree \<rho> \<Rightarrow> Errorable (\<tau> \<squnion> \<rho>)
     | Errorable \<rho> \<Rightarrow> Errorable (\<tau> \<squnion> \<rho>))"

lemma sup_ge1_errorable:
  "\<tau> \<le> \<tau> \<squnion> \<sigma>"
  for \<tau> \<sigma> :: "'a errorable"
  by (cases \<tau>; cases \<sigma>; simp)

lemma sup_commut_errorable:
  "\<tau> \<squnion> \<sigma> = \<sigma> \<squnion> \<tau>"
  for \<tau> \<sigma> :: "'a errorable"
  by (cases \<tau>; cases \<sigma>; simp add: sup.commute)

lemma sup_least_errorable:
  "\<tau> \<le> \<rho> \<Longrightarrow> \<sigma> \<le> \<rho> \<Longrightarrow> \<tau> \<squnion> \<sigma> \<le> \<rho>"
  for \<tau> \<sigma> \<rho> :: "'a errorable"
  by (cases \<tau>; cases \<sigma>; cases \<rho>; simp)

instance
  apply intro_classes
  apply (simp add: sup_ge1_errorable)
  apply (simp add: sup_ge1_errorable sup_commut_errorable)
  by (simp add: sup_least_errorable)

end

primrec unwrap_errorable_type where
  "unwrap_errorable_type (ErrorFree \<tau>) = \<tau>"
| "unwrap_errorable_type (Errorable \<tau>) = \<tau>"

primrec errorable_type where
  "errorable_type (ErrorFree \<tau>) = False"
| "errorable_type (Errorable \<tau>) = True"

abbreviation "error_free_type \<tau> \<equiv> \<not> errorable_type \<tau>"

primrec to_error_free_type where
  "to_error_free_type (ErrorFree \<tau>) = (ErrorFree \<tau>)"
| "to_error_free_type (Errorable \<tau>) = (ErrorFree \<tau>)"

primrec to_errorable_type where
  "to_errorable_type (ErrorFree \<tau>) = (Errorable \<tau>)"
| "to_errorable_type (Errorable \<tau>) = (Errorable \<tau>)"

lemma unwrap_errorable_type_ErrorFree [simp]:
  "unwrap_errorable_type \<circ> ErrorFree = id"
  using comp_def by auto

lemma unwrap_errorable_type_Errorable [simp]:
  "unwrap_errorable_type \<circ> Errorable = id"
  using comp_def by auto

end


theory Stream_of_llist_llist_of_stream2
  imports Main "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (lset: 'a) Llist =
    lnull: LNil
    | LCons (lhd: 'a) (ltl: "'a Llist")
where
 "ltl LNil = LNil"

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

primcorec llist_of_stream2 :: "'a Stream \<Rightarrow> 'a Llist"
  where "llist_of_stream2 s = LCons (shd s) (llist_of_stream2 (stl s))"

primcorec stream_of_llist2 :: "'a Llist \<Rightarrow> 'a Stream"
where "stream_of_llist2 l = SCons (lhd l) (stream_of_llist2 (ltl l))"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"
hipster_obs Stream Lst obsStream stream_of_llist2 llist_of_stream2
(* Nothing found *)
(* Would need an observer for the llist also but can only
have one at a time now*)

theorem stream_of_llist_llist_of_stream2:
  "stream_of_llist2 (llist_of_stream2 xs) = xs"
  by hipster_coinduct_sledgehammer
end


(*  Title:       One procedure
    Author:      Tobias Nipkow, 2001/2006
    Maintainer:  Tobias Nipkow
*)

header "Hoare Logics for 1 Procedure"

theory PLang imports Main begin

subsection{* The language *}

typedecl state

type_synonym bexp = "state \<Rightarrow> bool"

datatype com = Do "(state \<Rightarrow> state set)"
             | Semi  com com            ("_; _"  [60, 60] 10)
             | Cond  bexp com com     ("IF _ THEN _ ELSE _"  60)
             | While bexp com           ("WHILE _ DO _"  60)
             | CALL
             | Local "(state \<Rightarrow> state)" com "(state \<Rightarrow> state \<Rightarrow> state)"
               ("LOCAL _; _; _" [0,0,60] 60)

text{*\noindent There is only one parameterless procedure in the program. Hence
@{term CALL} does not even need to mention the procedure name. There
is no separate syntax for procedure declarations. Instead we declare a HOL
constant that represents the body of the one procedure in the program.*}

consts body :: com

text{*\noindent
As before, command execution is described by transitions
@{text"s -c\<rightarrow> t"}. The only new rule is the one for @{term CALL} ---
it requires no comment:*}

inductive
  exec :: "state \<Rightarrow> com \<Rightarrow> state \<Rightarrow> bool"  ("_/ -_\<rightarrow>/ _" [50,0,50] 50)
where
    Do:     "t \<in> f s \<Longrightarrow> s -Do f\<rightarrow> t"

  | Semi:   "\<lbrakk> s0 -c1\<rightarrow> s1; s1 -c2\<rightarrow> s2 \<rbrakk>
            \<Longrightarrow> s0 -c1;c2\<rightarrow> s2"

  | IfTrue:  "\<lbrakk> b s;  s -c1\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"
  | IfFalse: "\<lbrakk> \<not>b s; s -c2\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2\<rightarrow> t"

  | WhileFalse: "\<not>b s \<Longrightarrow> s -WHILE b DO c\<rightarrow> s"
  | WhileTrue:  "\<lbrakk> b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u \<rbrakk>
                \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"

  | "s -body\<rightarrow> t \<Longrightarrow> s -CALL\<rightarrow> t"

  | Local: "f s -c\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g\<rightarrow> g s t"

lemma [iff]: "(s -c;d\<rightarrow> u) = (\<exists>t. s -c\<rightarrow> t \<and> t -d\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -IF b THEN c ELSE d\<rightarrow> t) =
              (s -if b s then c else d\<rightarrow> t)"
apply(rule iffI)
 apply(auto elim: exec.cases intro:exec.intros)
apply(auto intro:exec.intros split:split_if_asm)
done

lemma unfold_while:
 "(s -WHILE b DO c\<rightarrow> u) =
  (s -IF b THEN c;WHILE b DO c ELSE Do(\<lambda>s. {s})\<rightarrow> u)"
by(auto elim: exec.cases intro:exec.intros split:split_if_asm)

lemma [iff]: "(s -CALL\<rightarrow> t) = (s -body\<rightarrow> t)"
by(blast elim: exec.cases intro:exec.intros)

lemma [iff]: "(s -LOCAL f; c; g\<rightarrow> u) = (\<exists>t. f s -c\<rightarrow> t \<and> u = g s t)"
by(fastforce elim: exec.cases intro:exec.intros)

lemma WhileI: "\<lbrakk>b s; s -c\<rightarrow> t; t -WHILE b DO c\<rightarrow> u\<rbrakk> \<Longrightarrow> s -WHILE b DO c\<rightarrow> u"
by(fastforce elim:exec.WhileTrue)
(*>*)

text{*This semantics turns out not to be fine-grained
enough. The soundness proof for the Hoare logic below proceeds by
induction on the call depth during execution. To make this work we
define a second semantics \mbox{@{text"s -c-n\<rightarrow> t"}} which expresses that the
execution uses at most @{term n} nested procedure invocations, where
@{term n} is a natural number. The rules are straightforward: @{term
n} is just passed around, except for procedure calls, where it is
decremented: *}

inductive
  execn :: "state \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> bool"   ("_/ -_-_\<rightarrow>/ _" [50,0,0,50] 50)
where
  "t \<in> f s \<Longrightarrow> s -Do f-n\<rightarrow> t"

| "\<lbrakk> s0 -c1-n\<rightarrow> s1; s1 -c2-n\<rightarrow> s2 \<rbrakk> \<Longrightarrow> s0 -c1;c2-n\<rightarrow> s2"

| "\<lbrakk>  b s; s -c1-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2-n\<rightarrow> t"
| "\<lbrakk> \<not>b s; s -c2-n\<rightarrow> t \<rbrakk> \<Longrightarrow> s -IF b THEN c1 ELSE c2-n\<rightarrow> t"

| (*<*)WhileFalse:(*>*)"\<not>b s \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> s"
| (*<*)WhileTrue:(*>*)"\<lbrakk>b s; s -c-n\<rightarrow> t; t -WHILE b DO c-n\<rightarrow> u\<rbrakk> \<Longrightarrow> s -WHILE b DO c-n\<rightarrow> u"

| "s -body-n\<rightarrow> t \<Longrightarrow> s -CALL-Suc n\<rightarrow> t"

| "f s -c-n\<rightarrow> t \<Longrightarrow> s -LOCAL f; c; g-n\<rightarrow> g s t"

lemma [iff]: "(s -Do f-n\<rightarrow> t) = (t \<in> f s)"
by(auto elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -c1;c2-n\<rightarrow> u) = (\<exists>t. s -c1-n\<rightarrow> t \<and> t -c2-n\<rightarrow> u)"
by(best elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -IF b THEN c ELSE d-n\<rightarrow> t) =
              (s -if b s then c else d-n\<rightarrow> t)"
apply auto
apply(blast elim: execn.cases intro:execn.intros)+
done

lemma [iff]: "(s -CALL- 0\<rightarrow> t) = False"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -CALL-Suc n\<rightarrow> t) = (s -body-n\<rightarrow> t)"
by(blast elim: execn.cases intro:execn.intros)

lemma [iff]: "(s -LOCAL f; c; g-n\<rightarrow> u) = (\<exists>t. f s -c-n\<rightarrow> t \<and> u = g s t)"
by(auto elim: execn.cases intro:execn.intros)

text{*\noindent By induction on @{prop"s -c-m\<rightarrow> t"} we show
monotonicity w.r.t.\ the call depth:*}

lemma exec_mono[rule_format]: "s -c-m\<rightarrow> t \<Longrightarrow> \<forall>n. m \<le> n \<longrightarrow> s -c-n\<rightarrow> t"
apply(erule execn.induct)
         apply(blast)
        apply(blast)
       apply(simp)
      apply(simp)
     apply(simp add:execn.intros)
    apply(blast intro:execn.intros)
   apply(clarify)
   apply(rename_tac m)
   apply(case_tac m)
    apply simp
   apply simp
  apply blast
done

text{*\noindent With the help of this lemma we prove the expected
relationship between the two semantics: *}

lemma exec_iff_execn: "(s -c\<rightarrow> t) = (\<exists>n. s -c-n\<rightarrow> t)"
apply(rule iffI)
apply(erule exec.induct)
           apply blast
          apply clarify
          apply(rename_tac m n)
          apply(rule_tac x = "max m n" in exI)
          apply(fastforce intro:exec.intros exec_mono simp add:max_def)
         apply fastforce
        apply fastforce
       apply(blast intro:execn.intros)
      apply clarify
      apply(rename_tac m n)
      apply(rule_tac x = "max m n" in exI)
      apply(fastforce elim:execn.WhileTrue exec_mono simp add:max_def)
     apply blast
    apply blast
apply(erule exE, erule execn.induct)
         apply blast
        apply blast
       apply fastforce
      apply fastforce
     apply(erule exec.WhileFalse)
    apply(blast intro: exec.intros)
   apply blast
  apply blast
done

lemma while_lemma[rule_format]:
"s -w-n\<rightarrow> t \<Longrightarrow> !b c. w = WHILE b DO c \<and> P s \<and>
                    (!s s'. P s \<and> b s \<and> s -c-n\<rightarrow> s' \<longrightarrow> P s') \<longrightarrow> P t \<and> \<not>b t"
apply(erule execn.induct)
apply clarify+
defer
apply clarify+
apply(subgoal_tac "P t")
apply blast
apply blast
done

lemma while_rule:
 "\<lbrakk>s -WHILE b DO c-n\<rightarrow> t; P s; \<And>s s'. \<lbrakk>P s; b s; s -c-n\<rightarrow> s' \<rbrakk> \<Longrightarrow> P s'\<rbrakk>
  \<Longrightarrow> P t \<and> \<not>b t"
apply(drule while_lemma)
prefer 2 apply assumption
apply blast
done

end


theory Goodies
  imports
    Main
begin

primrec
  inits :: "'a list \<Rightarrow> 'a list list"
  where
    "inits [] = []"
  | "inits (x # xs) = [x] # map ((#) x) (inits xs)"

definition
  inits_self :: "'a list \<Rightarrow> ('a list \<times> 'a) list"
  where
    "inits_self xs = zip ([] # inits xs) xs"

lemma inits_map: "inits (map f xs) = map (map f) (inits xs)"
  by(induction xs) simp_all

lemma inits_append [simp]: "inits (xs @ ys) = inits xs @ map ((@) xs) (inits ys)"
  by(induction xs) (simp_all)

lemma inits_self_simps [simp]:
    "inits_self [] = []"
    "inits_self (x # xs) = ([], x) # map (apfst ((#) x)) (inits_self xs)"
  by(simp_all add: inits_self_def apfst_def map_prod_def zip_map1[symmetric])

lemma inits_self_map: "inits_self (map f xs) = map (map_prod (map f) f) (inits_self xs)"
  by(induction xs) (simp_all add: apfst_def prod.map_comp o_def)

lemma in_set_inits_self: "(ys, z) \<in> set (inits_self xs) \<longleftrightarrow> (\<exists>zs. xs = ys @ z # zs)"
  by(induction xs arbitrary: ys z)(auto simp add: Cons_eq_append_conv apfst_def map_prod_def)

lemma foldl_append: "foldl (\<lambda>s e. s @ [e]) s l = s @ l"
  by (induction l arbitrary: s) auto

lemma foldl_insert: "foldl (\<lambda>A x. insert (f x) A) A xs = A \<union> (f ` set xs)"
  by(induction xs arbitrary: A) simp_all

lemma foldl_concat_prodl: "foldl (\<lambda>(l, r) x. (l @ g r x, f r x)) (l, r) xs =
    (l @ concat (map (\<lambda>(ys, x). g (foldl f r ys) x) (inits_self xs)), foldl f r xs)"
  by(induction xs arbitrary: l r) (simp_all add: split_def o_def)

end


(*  Title:      HOL/UNITY/Extend.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Extending of state setsExtending of state sets
  function f (forget)    maps the extended state to the original state
  function g (forgotten) maps the extended state to the "extending part"
*)

section{*Extending State Sets*}

theory Extend imports Guar begin

definition
  (*MOVE to Relation.thy?*)
  Restrict :: "[ 'a set, ('a*'b) set] => ('a*'b) set"
  where "Restrict A r = r \<inter> (A <*> UNIV)"

definition
  good_map :: "['a*'b => 'c] => bool"
  where "good_map h <-> surj h & (\<forall>x y. fst (inv h (h (x,y))) = x)"
     (*Using the locale constant "f", this is  f (h (x,y))) = x*)

definition
  extend_set :: "['a*'b => 'c, 'a set] => 'c set"
  where "extend_set h A = h ` (A <*> UNIV)"

definition
  project_set :: "['a*'b => 'c, 'c set] => 'a set"
  where "project_set h C = {x. \<exists>y. h(x,y) \<in> C}"

definition
  extend_act :: "['a*'b => 'c, ('a*'a) set] => ('c*'c) set"
  where "extend_act h = (%act. \<Union>(s,s') \<in> act. \<Union>y. {(h(s,y), h(s',y))})"

definition
  project_act :: "['a*'b => 'c, ('c*'c) set] => ('a*'a) set"
  where "project_act h act = {(x,x'). \<exists>y y'. (h(x,y), h(x',y')) \<in> act}"

definition
  extend :: "['a*'b => 'c, 'a program] => 'c program"
  where "extend h F = mk_program (extend_set h (Init F),
                               extend_act h ` Acts F,
                               project_act h -` AllowedActs F)"

definition
  (*Argument C allows weak safety laws to be projected*)
  project :: "['a*'b => 'c, 'c set, 'c program] => 'a program"
  where "project h C F =
       mk_program (project_set h (Init F),
                   project_act h ` Restrict C ` Acts F,
                   {act. Restrict (project_set h C) act :
                         project_act h ` Restrict C ` AllowedActs F})"

locale Extend =
  fixes f     :: "'c => 'a"
    and g     :: "'c => 'b"
    and h     :: "'a*'b => 'c"    (*isomorphism between 'a * 'b and 'c *)
    and slice :: "['c set, 'b] => 'a set"
  assumes
    good_h:  "good_map h"
  defines f_def: "f z == fst (inv h z)"
      and g_def: "g z == snd (inv h z)"
      and slice_def: "slice Z y == {x. h(x,y) \<in> Z}"

(** These we prove OUTSIDE the locale. **)

subsection{*Restrict*}
(*MOVE to Relation.thy?*)

lemma Restrict_iff [iff]: "((x,y): Restrict A r) = ((x,y): r & x \<in> A)"
by (unfold Restrict_def, blast)

lemma Restrict_UNIV [simp]: "Restrict UNIV = id"
apply (rule ext)
apply (auto simp add: Restrict_def)
done

lemma Restrict_empty [simp]: "Restrict {} r = {}"
by (auto simp add: Restrict_def)

lemma Restrict_Int [simp]: "Restrict A (Restrict B r) = Restrict (A \<inter> B) r"
by (unfold Restrict_def, blast)

lemma Restrict_triv: "Domain r \<subseteq> A ==> Restrict A r = r"
by (unfold Restrict_def, auto)

lemma Restrict_subset: "Restrict A r \<subseteq> r"
by (unfold Restrict_def, auto)

lemma Restrict_eq_mono:
     "[| A \<subseteq> B;  Restrict B r = Restrict B s |]
      ==> Restrict A r = Restrict A s"
by (unfold Restrict_def, blast)

lemma Restrict_imageI:
     "[| s \<in> RR;  Restrict A r = Restrict A s |]
      ==> Restrict A r \<in> Restrict A ` RR"
by (unfold Restrict_def image_def, auto)

lemma Domain_Restrict [simp]: "Domain (Restrict A r) = A \<inter> Domain r"
by blast

lemma Image_Restrict [simp]: "(Restrict A r) `` B = r `` (A \<inter> B)"
by blast

(*Possibly easier than reasoning about "inv h"*)
lemma good_mapI:
     assumes surj_h: "surj h"
         and prem:   "!! x x' y y'. h(x,y) = h(x',y') ==> x=x'"
     shows "good_map h"
apply (simp add: good_map_def)
apply (safe intro!: surj_h)
apply (rule prem)
apply (subst surjective_pairing [symmetric])
apply (subst surj_h [THEN surj_f_inv_f])
apply (rule refl)
done

lemma good_map_is_surj: "good_map h ==> surj h"
by (unfold good_map_def, auto)

(*A convenient way of finding a closed form for inv h*)
lemma fst_inv_equalityI:
     assumes surj_h: "surj h"
         and prem:   "!! x y. g (h(x,y)) = x"
     shows "fst (inv h z) = g z"
by (metis UNIV_I f_inv_into_f pair_collapse prem surj_h)

subsection{*Trivial properties of f, g, h*}

context Extend
begin

lemma f_h_eq [simp]: "f(h(x,y)) = x"
by (simp add: f_def good_h [unfolded good_map_def, THEN conjunct2])

lemma h_inject1 [dest]: "h(x,y) = h(x',y') ==> x=x'"
apply (drule_tac f = f in arg_cong)
apply (simp add: f_def good_h [unfolded good_map_def, THEN conjunct2])
done

lemma h_f_g_equiv: "h(f z, g z) == z"
by (simp add: f_def g_def
            good_h [unfolded good_map_def, THEN conjunct1, THEN surj_f_inv_f])

lemma h_f_g_eq: "h(f z, g z) = z"
by (simp add: h_f_g_equiv)

lemma split_extended_all:
     "(!!z. PROP P z) == (!!u y. PROP P (h (u, y)))"
proof
   assume allP: "\<And>z. PROP P z"
   fix u y
   show "PROP P (h (u, y))" by (rule allP)
 next
   assume allPh: "\<And>u y. PROP P (h(u,y))"
   fix z
   have Phfgz: "PROP P (h (f z, g z))" by (rule allPh)
   show "PROP P z" by (rule Phfgz [unfolded h_f_g_equiv])
qed

end

subsection{*@{term extend_set}: basic properties*}

lemma project_set_iff [iff]:
     "(x \<in> project_set h C) = (\<exists>y. h(x,y) \<in> C)"
by (simp add: project_set_def)

lemma extend_set_mono: "A \<subseteq> B ==> extend_set h A \<subseteq> extend_set h B"
by (unfold extend_set_def, blast)

context Extend
begin

lemma mem_extend_set_iff [iff]: "z \<in> extend_set h A = (f z \<in> A)"
apply (unfold extend_set_def)
apply (force intro: h_f_g_eq [symmetric])
done

lemma extend_set_strict_mono [iff]:
     "(extend_set h A \<subseteq> extend_set h B) = (A \<subseteq> B)"
by (unfold extend_set_def, force)

lemma (in -) extend_set_empty [simp]: "extend_set h {} = {}"
by (unfold extend_set_def, auto)

lemma extend_set_eq_Collect: "extend_set h {s. P s} = {s. P(f s)}"
by auto

lemma extend_set_sing: "extend_set h {x} = {s. f s = x}"
by auto

lemma extend_set_inverse [simp]: "project_set h (extend_set h C) = C"
by (unfold extend_set_def, auto)

lemma extend_set_project_set: "C \<subseteq> extend_set h (project_set h C)"
apply (unfold extend_set_def)
apply (auto simp add: split_extended_all, blast)
done

lemma inj_extend_set: "inj (extend_set h)"
apply (rule inj_on_inverseI)
apply (rule extend_set_inverse)
done

lemma extend_set_UNIV_eq [simp]: "extend_set h UNIV = UNIV"
apply (unfold extend_set_def)
apply (auto simp add: split_extended_all)
done

subsection{*@{term project_set}: basic properties*}

(*project_set is simply image!*)
lemma project_set_eq: "project_set h C = f ` C"
by (auto intro: f_h_eq [symmetric] simp add: split_extended_all)

(*Converse appears to fail*)
lemma project_set_I: "!!z. z \<in> C ==> f z \<in> project_set h C"
by (auto simp add: split_extended_all)

subsection{*More laws*}

(*Because A and B could differ on the "other" part of the state,
   cannot generalize to
      project_set h (A \<inter> B) = project_set h A \<inter> project_set h B
*)
lemma project_set_extend_set_Int: "project_set h ((extend_set h A) \<inter> B) = A \<inter> (project_set h B)"
  by auto

(*Unused, but interesting?*)
lemma project_set_extend_set_Un: "project_set h ((extend_set h A) \<union> B) = A \<union> (project_set h B)"
  by auto

lemma (in -) project_set_Int_subset:
    "project_set h (A \<inter> B) \<subseteq> (project_set h A) \<inter> (project_set h B)"
  by auto

lemma extend_set_Un_distrib: "extend_set h (A \<union> B) = extend_set h A \<union> extend_set h B"
  by auto

lemma extend_set_Int_distrib: "extend_set h (A \<inter> B) = extend_set h A \<inter> extend_set h B"
  by auto

lemma extend_set_INT_distrib: "extend_set h (INTER A B) = (\<Inter>x \<in> A. extend_set h (B x))"
  by auto

lemma extend_set_Diff_distrib: "extend_set h (A - B) = extend_set h A - extend_set h B"
  by auto

lemma extend_set_Union: "extend_set h (Union A) = (\<Union>X \<in> A. extend_set h X)"
  by blast

lemma extend_set_subset_Compl_eq: "(extend_set h A \<subseteq> - extend_set h B) = (A \<subseteq> - B)"
  by (auto simp: extend_set_def)

subsection{*@{term extend_act}*}

(*Can't strengthen it to
  ((h(s,y), h(s',y')) \<in> extend_act h act) = ((s, s') \<in> act & y=y')
  because h doesn't have to be injective in the 2nd argument*)
lemma mem_extend_act_iff [iff]: "((h(s,y), h(s',y)) \<in> extend_act h act) = ((s, s') \<in> act)"
  by (auto simp: extend_act_def)

(*Converse fails: (z,z') would include actions that changed the g-part*)
lemma extend_act_D: "(z, z') \<in> extend_act h act ==> (f z, f z') \<in> act"
  by (auto simp: extend_act_def)

lemma extend_act_inverse [simp]: "project_act h (extend_act h act) = act"
  unfolding extend_act_def project_act_def by blast

lemma project_act_extend_act_restrict [simp]:
     "project_act h (Restrict C (extend_act h act)) =
      Restrict (project_set h C) act"
  unfolding extend_act_def project_act_def by blast

lemma subset_extend_act_D: "act' \<subseteq> extend_act h act ==> project_act h act' \<subseteq> act"
  unfolding extend_act_def project_act_def by force

lemma inj_extend_act: "inj (extend_act h)"
apply (rule inj_on_inverseI)
apply (rule extend_act_inverse)
done

lemma extend_act_Image [simp]:
     "extend_act h act `` (extend_set h A) = extend_set h (act `` A)"
  unfolding extend_set_def extend_act_def by force

lemma extend_act_strict_mono [iff]:
     "(extend_act h act' \<subseteq> extend_act h act) = (act'<=act)"
  by (auto simp: extend_act_def)

lemma (in -) Domain_extend_act:
    "Domain (extend_act h act) = extend_set h (Domain act)"
  unfolding extend_set_def extend_act_def by force

lemma extend_act_Id [simp]: "extend_act h Id = Id"
  unfolding extend_act_def by (force intro: h_f_g_eq [symmetric])

lemma project_act_I:  "!!z z'. (z, z') \<in> act ==> (f z, f z') \<in> project_act h act"
  unfolding project_act_def by (force simp add: split_extended_all)

lemma project_act_Id [simp]: "project_act h Id = Id"
  unfolding project_act_def by force

lemma Domain_project_act: "Domain (project_act h act) = project_set h (Domain act)"
  unfolding project_act_def by (force simp add: split_extended_all)

subsection{*extend*}

text{*Basic properties*}

lemma (in -) Init_extend [simp]:
     "Init (extend h F) = extend_set h (Init F)"
  by (auto simp: extend_def)

lemma (in -) Init_project [simp]:
     "Init (project h C F) = project_set h (Init F)"
  by (auto simp: project_def)

lemma Acts_extend [simp]: "Acts (extend h F) = (extend_act h ` Acts F)"
  by (simp add: extend_def insert_Id_image_Acts)

lemma AllowedActs_extend [simp]:
     "AllowedActs (extend h F) = project_act h -` AllowedActs F"
  by (simp add: extend_def insert_absorb)

lemma (in -) Acts_project [simp]:
     "Acts(project h C F) = insert Id (project_act h ` Restrict C ` Acts F)"
  by (auto simp add: project_def image_iff)

lemma AllowedActs_project [simp]:
     "AllowedActs(project h C F) =
        {act. Restrict (project_set h C) act
               \<in> project_act h ` Restrict C ` AllowedActs F}"
apply (simp (no_asm) add: project_def image_iff)
apply (subst insert_absorb)
apply (auto intro!: bexI [of _ Id] simp add: project_act_def)
done

lemma Allowed_extend: "Allowed (extend h F) = project h UNIV -` Allowed F"
  by (auto simp add: Allowed_def)

lemma extend_SKIP [simp]: "extend h SKIP = SKIP"
apply (unfold SKIP_def)
apply (rule program_equalityI, auto)
done

lemma (in -) project_set_UNIV [simp]: "project_set h UNIV = UNIV"
  by auto

lemma (in -) project_set_Union: "project_set h (Union A) = (\<Union>X \<in> A. project_set h X)"
  by blast

(*Converse FAILS: the extended state contributing to project_set h C
  may not coincide with the one contributing to project_act h act*)
lemma (in -) project_act_Restrict_subset:
     "project_act h (Restrict C act) \<subseteq> Restrict (project_set h C) (project_act h act)"
  by (auto simp add: project_act_def)

lemma project_act_Restrict_Id_eq: "project_act h (Restrict C Id) = Restrict (project_set h C) Id"
  by (auto simp add: project_act_def)

lemma project_extend_eq:
     "project h C (extend h F) =
      mk_program (Init F, Restrict (project_set h C) ` Acts F,
                  {act. Restrict (project_set h C) act
                          \<in> project_act h ` Restrict C `
                                     (project_act h -` AllowedActs F)})"
apply (rule program_equalityI)
  apply simp
 apply (simp add: image_eq_UN)
apply (simp add: project_def)
done

lemma extend_inverse [simp]:
     "project h UNIV (extend h F) = F"
apply (simp (no_asm_simp) add: project_extend_eq image_eq_UN
          subset_UNIV [THEN subset_trans, THEN Restrict_triv])
apply (rule program_equalityI)
apply (simp_all (no_asm))
apply (subst insert_absorb)
apply (simp (no_asm) add: bexI [of _ Id])
apply auto
apply (rename_tac "act")
apply (rule_tac x = "extend_act h act" in bexI, auto)
done

lemma inj_extend: "inj (extend h)"
apply (rule inj_on_inverseI)
apply (rule extend_inverse)
done

lemma extend_Join [simp]: "extend h (F\<squnion>G) = extend h F\<squnion>extend h G"
apply (rule program_equalityI)
apply (simp (no_asm) add: extend_set_Int_distrib)
apply (simp add: image_Un, auto)
done

lemma extend_JN [simp]: "extend h (JOIN I F) = (\<Squnion>i \<in> I. extend h (F i))"
apply (rule program_equalityI)
  apply (simp (no_asm) add: extend_set_INT_distrib)
 apply (simp add: image_UN, auto)
done

(** These monotonicity results look natural but are UNUSED **)

lemma extend_mono: "F \<le> G ==> extend h F \<le> extend h G"
  by (force simp add: component_eq_subset)

lemma project_mono: "F \<le> G ==> project h C F \<le> project h C G"
  by (simp add: component_eq_subset, blast)

lemma all_total_extend: "all_total F ==> all_total (extend h F)"
  by (simp add: all_total_def Domain_extend_act)

subsection{*Safety: co, stable*}

lemma extend_constrains:
     "(extend h F \<in> (extend_set h A) co (extend_set h B)) =
      (F \<in> A co B)"
  by (simp add: constrains_def)

lemma extend_stable:
     "(extend h F \<in> stable (extend_set h A)) = (F \<in> stable A)"
  by (simp add: stable_def extend_constrains)

lemma extend_invariant:
     "(extend h F \<in> invariant (extend_set h A)) = (F \<in> invariant A)"
  by (simp add: invariant_def extend_stable)

(*Projects the state predicates in the property satisfied by  extend h F.
  Converse fails: A and B may differ in their extra variables*)
lemma extend_constrains_project_set:
     "extend h F \<in> A co B ==> F \<in> (project_set h A) co (project_set h B)"
  by (auto simp add: constrains_def, force)

lemma extend_stable_project_set:
     "extend h F \<in> stable A ==> F \<in> stable (project_set h A)"
  by (simp add: stable_def extend_constrains_project_set)

subsection{*Weak safety primitives: Co, Stable*}

lemma reachable_extend_f: "p \<in> reachable (extend h F) ==> f p \<in> reachable F"
  by (induct set: reachable) (auto intro: reachable.intros simp add: extend_act_def image_iff)

lemma h_reachable_extend: "h(s,y) \<in> reachable (extend h F) ==> s \<in> reachable F"
  by (force dest!: reachable_extend_f)

lemma reachable_extend_eq: "reachable (extend h F) = extend_set h (reachable F)"
apply (unfold extend_set_def)
apply (rule equalityI)
apply (force intro: h_f_g_eq [symmetric] dest!: reachable_extend_f, clarify)
apply (erule reachable.induct)
apply (force intro: reachable.intros)+
done

lemma extend_Constrains:
     "(extend h F \<in> (extend_set h A) Co (extend_set h B)) =
      (F \<in> A Co B)"
  by (simp add: Constrains_def reachable_extend_eq extend_constrains
              extend_set_Int_distrib [symmetric])

lemma extend_Stable: "(extend h F \<in> Stable (extend_set h A)) = (F \<in> Stable A)"
  by (simp add: Stable_def extend_Constrains)

lemma extend_Always: "(extend h F \<in> Always (extend_set h A)) = (F \<in> Always A)"
  by (simp add: Always_def extend_Stable)

(** Safety and "project" **)

(** projection: monotonicity for safety **)

lemma (in -) project_act_mono:
     "D \<subseteq> C ==>
      project_act h (Restrict D act) \<subseteq> project_act h (Restrict C act)"
  by (auto simp add: project_act_def)

lemma project_constrains_mono:
     "[| D \<subseteq> C; project h C F \<in> A co B |] ==> project h D F \<in> A co B"
apply (auto simp add: constrains_def)
apply (drule project_act_mono, blast)
done

lemma project_stable_mono:
     "[| D \<subseteq> C;  project h C F \<in> stable A |] ==> project h D F \<in> stable A"
  by (simp add: stable_def project_constrains_mono)

(*Key lemma used in several proofs about project and co*)
lemma project_constrains:
     "(project h C F \<in> A co B)  =
      (F \<in> (C \<inter> extend_set h A) co (extend_set h B) & A \<subseteq> B)"
apply (unfold constrains_def)
apply (auto intro!: project_act_I simp add: ball_Un)
apply (force intro!: project_act_I dest!: subsetD)
(*the <== direction*)
apply (unfold project_act_def)
apply (force dest!: subsetD)
done

lemma project_stable: "(project h UNIV F \<in> stable A) = (F \<in> stable (extend_set h A))"
  by (simp add: stable_def project_constrains)

lemma project_stable_I: "F \<in> stable (extend_set h A) ==> project h C F \<in> stable A"
apply (drule project_stable [THEN iffD2])
apply (blast intro: project_stable_mono)
done

lemma Int_extend_set_lemma:
     "A \<inter> extend_set h ((project_set h A) \<inter> B) = A \<inter> extend_set h B"
  by (auto simp add: split_extended_all)

(*Strange (look at occurrences of C) but used in leadsETo proofs*)
lemma project_constrains_project_set:
     "G \<in> C co B ==> project h C G \<in> project_set h C co project_set h B"
  by (simp add: constrains_def project_def project_act_def, blast)

lemma project_stable_project_set:
     "G \<in> stable C ==> project h C G \<in> stable (project_set h C)"
  by (simp add: stable_def project_constrains_project_set)

subsection{*Progress: transient, ensures*}

lemma extend_transient:
     "(extend h F \<in> transient (extend_set h A)) = (F \<in> transient A)"
  by (auto simp add: transient_def extend_set_subset_Compl_eq Domain_extend_act)

lemma extend_ensures:
     "(extend h F \<in> (extend_set h A) ensures (extend_set h B)) =
      (F \<in> A ensures B)"
  by (simp add: ensures_def extend_constrains extend_transient
        extend_set_Un_distrib [symmetric] extend_set_Diff_distrib [symmetric])

lemma leadsTo_imp_extend_leadsTo:
     "F \<in> A leadsTo B
      ==> extend h F \<in> (extend_set h A) leadsTo (extend_set h B)"
apply (erule leadsTo_induct)
  apply (simp add: leadsTo_Basis extend_ensures)
 apply (blast intro: leadsTo_Trans)
apply (simp add: leadsTo_UN extend_set_Union)
done

subsection{*Proving the converse takes some doing!*}

lemma slice_iff [iff]: "(x \<in> slice C y) = (h(x,y) \<in> C)"
  by (simp add: slice_def)

lemma slice_Union: "slice (Union S) y = (\<Union>x \<in> S. slice x y)"
  by auto

lemma slice_extend_set: "slice (extend_set h A) y = A"
  by auto

lemma project_set_is_UN_slice: "project_set h A = (\<Union>y. slice A y)"
  by auto

lemma extend_transient_slice:
     "extend h F \<in> transient A ==> F \<in> transient (slice A y)"
  by (auto simp: transient_def)

(*Converse?*)
lemma extend_constrains_slice:
     "extend h F \<in> A co B ==> F \<in> (slice A y) co (slice B y)"
  by (auto simp add: constrains_def)

lemma extend_ensures_slice:
     "extend h F \<in> A ensures B ==> F \<in> (slice A y) ensures (project_set h B)"
apply (auto simp add: ensures_def extend_constrains extend_transient)
apply (erule_tac [2] extend_transient_slice [THEN transient_strengthen])
apply (erule extend_constrains_slice [THEN constrains_weaken], auto)
done

lemma leadsTo_slice_project_set:
     "\<forall>y. F \<in> (slice B y) leadsTo CU ==> F \<in> (project_set h B) leadsTo CU"
apply (simp add: project_set_is_UN_slice)
apply (blast intro: leadsTo_UN)
done

lemma extend_leadsTo_slice [rule_format]:
     "extend h F \<in> AU leadsTo BU
      ==> \<forall>y. F \<in> (slice AU y) leadsTo (project_set h BU)"
apply (erule leadsTo_induct)
  apply (blast intro: extend_ensures_slice)
 apply (blast intro: leadsTo_slice_project_set leadsTo_Trans)
apply (simp add: leadsTo_UN slice_Union)
done

lemma extend_leadsTo:
     "(extend h F \<in> (extend_set h A) leadsTo (extend_set h B)) =
      (F \<in> A leadsTo B)"
apply safe
apply (erule_tac [2] leadsTo_imp_extend_leadsTo)
apply (drule extend_leadsTo_slice)
apply (simp add: slice_extend_set)
done

lemma extend_LeadsTo:
     "(extend h F \<in> (extend_set h A) LeadsTo (extend_set h B)) =
      (F \<in> A LeadsTo B)"
  by (simp add: LeadsTo_def reachable_extend_eq extend_leadsTo
              extend_set_Int_distrib [symmetric])

subsection{*preserves*}

lemma project_preserves_I:
     "G \<in> preserves (v o f) ==> project h C G \<in> preserves v"
  by (auto simp add: preserves_def project_stable_I extend_set_eq_Collect)

(*to preserve f is to preserve the whole original state*)
lemma project_preserves_id_I:
     "G \<in> preserves f ==> project h C G \<in> preserves id"
  by (simp add: project_preserves_I)

lemma extend_preserves:
     "(extend h G \<in> preserves (v o f)) = (G \<in> preserves v)"
  by (auto simp add: preserves_def extend_stable [symmetric]
                   extend_set_eq_Collect)

lemma inj_extend_preserves: "inj h ==> (extend h G \<in> preserves g)"
  by (auto simp add: preserves_def extend_def extend_act_def stable_def
                   constrains_def g_def)

subsection{*Guarantees*}

lemma project_extend_Join: "project h UNIV ((extend h F)\<squnion>G) = F\<squnion>(project h UNIV G)"
apply (rule program_equalityI)
  apply (simp add: project_set_extend_set_Int)
 apply (auto simp add: image_eq_UN)
done

lemma extend_Join_eq_extend_D:
     "(extend h F)\<squnion>G = extend h H ==> H = F\<squnion>(project h UNIV G)"
apply (drule_tac f = "project h UNIV" in arg_cong)
apply (simp add: project_extend_Join)
done

(** Strong precondition and postcondition; only useful when
    the old and new state sets are in bijection **)

lemma ok_extend_imp_ok_project: "extend h F ok G ==> F ok project h UNIV G"
apply (auto simp add: ok_def)
apply (drule subsetD)
apply (auto intro!: rev_image_eqI)
done

lemma ok_extend_iff: "(extend h F ok extend h G) = (F ok G)"
apply (simp add: ok_def, safe)
apply force+
done

lemma OK_extend_iff: "OK I (%i. extend h (F i)) = (OK I F)"
apply (unfold OK_def, safe)
apply (drule_tac x = i in bspec)
apply (drule_tac [2] x = j in bspec)
apply force+
done

lemma guarantees_imp_extend_guarantees:
     "F \<in> X guarantees Y ==>
      extend h F \<in> (extend h ` X) guarantees (extend h ` Y)"
apply (rule guaranteesI, clarify)
apply (blast dest: ok_extend_imp_ok_project extend_Join_eq_extend_D
                   guaranteesD)
done

lemma extend_guarantees_imp_guarantees:
     "extend h F \<in> (extend h ` X) guarantees (extend h ` Y)
      ==> F \<in> X guarantees Y"
apply (auto simp add: guar_def)
apply (drule_tac x = "extend h G" in spec)
apply (simp del: extend_Join
            add: extend_Join [symmetric] ok_extend_iff
                 inj_extend [THEN inj_image_mem_iff])
done

lemma extend_guarantees_eq:
     "(extend h F \<in> (extend h ` X) guarantees (extend h ` Y)) =
      (F \<in> X guarantees Y)"
  by (blast intro: guarantees_imp_extend_guarantees
                 extend_guarantees_imp_guarantees)

end

end