section \<open>Indexed Products of Probability Mass Functions\<close>

theory Product_PMF_Ext
  imports Main Probability_Ext "HOL-Probability.Product_PMF" Universal_Hash_Families.Preliminary_Results
begin

hide_const "Isolated.discrete"

text \<open>This section introduces a restricted version of @{term "Pi_pmf"} where the default value is @{term "undefined"}
and contains some additional results about that case in addition to @{theory "HOL-Probability.Product_PMF"}\<close>

abbreviation prod_pmf where "prod_pmf I M \<equiv> Pi_pmf I undefined M"

lemma pmf_prod_pmf:
  assumes "finite I"
  shows "pmf (prod_pmf I M) x = (if x \<in> extensional I then \<Prod>i \<in> I. (pmf (M i)) (x i) else 0)"
  by (simp add:  pmf_Pi[OF assms(1)] extensional_def)

lemma PiE_defaut_undefined_eq: "PiE_dflt I undefined M = PiE I M"
  by (simp add:PiE_dflt_def PiE_def extensional_def Pi_def set_eq_iff) blast

lemma set_prod_pmf:
  assumes "finite I"
  shows "set_pmf (prod_pmf I M) = PiE I (set_pmf \<circ> M)"
  by (simp add:set_Pi_pmf[OF assms] PiE_defaut_undefined_eq)

text \<open>A more general version of @{thm [source] "measure_Pi_pmf_Pi"}.\<close>
lemma prob_prod_pmf':
  assumes "finite I"
  assumes "J \<subseteq> I"
  shows "measure (measure_pmf (Pi_pmf I d M)) (Pi J A) = (\<Prod> i \<in> J. measure (M i) (A i))"
proof -
  have a:"Pi J A = Pi I (\<lambda>i. if i \<in> J then A i else UNIV)"
    using assms by (simp add:Pi_def set_eq_iff, blast)
  show ?thesis
    using assms
    by (simp add:if_distrib  a measure_Pi_pmf_Pi[OF assms(1)] prod.If_cases[OF assms(1)] Int_absorb1)
qed

lemma prob_prod_pmf_slice:
  assumes "finite I"
  assumes "i \<in> I"
  shows "measure (measure_pmf (prod_pmf I M)) {\<omega>. P (\<omega> i)} = measure (M i) {\<omega>. P \<omega>}"
  using prob_prod_pmf'[OF assms(1), where J="{i}" and M="M" and A="\<lambda>_. Collect P"]
  by (simp add:assms Pi_def)

definition restrict_dfl where "restrict_dfl f A d = (\<lambda>x. if x \<in> A then f x else d)"

lemma pi_pmf_decompose:
  assumes "finite I"
  shows "Pi_pmf I d M = map_pmf (\<lambda>\<omega>. restrict_dfl (\<lambda>i. \<omega> (f i) i) I d) (Pi_pmf (f ` I) (\<lambda>_. d) (\<lambda>j. Pi_pmf (f -` {j} \<inter> I) d M))"
proof -
  have fin_F_I:"finite (f ` I)" using assms by blast

  have "finite I \<Longrightarrow> ?thesis"
    using fin_F_I
  proof (induction "f ` I" arbitrary: I rule:finite_induct)
    case empty
    then show ?case by (simp add:restrict_dfl_def)
  next
    case (insert x F)
    have a: "(f -` {x} \<inter> I) \<union> (f -` F \<inter> I) = I"
      using insert(4) by blast
    have b: "F = f `  (f -` F \<inter> I) " using insert(2,4)
      by (auto simp add:set_eq_iff image_def vimage_def)
    have c: "finite (f -` F \<inter> I)" using insert by blast
    have d: "\<And>j. j \<in> F \<Longrightarrow> (f -` {j} \<inter> (f -` F \<inter> I)) = (f -` {j} \<inter> I)"
      using insert(4) by blast

    have " Pi_pmf I d M = Pi_pmf ((f -` {x} \<inter> I) \<union> (f -` F \<inter> I)) d M"
      by (simp add:a)
    also have "... = map_pmf (\<lambda>(g, h) i. if i \<in> f -` {x} \<inter> I then g i else h i)
      (pair_pmf (Pi_pmf (f -` {x} \<inter> I) d M) (Pi_pmf (f -` F \<inter> I) d M))"
      using insert by (subst Pi_pmf_union) auto
    also have "... = map_pmf (\<lambda>(g,h) i. if f i = x \<and> i \<in> I then g i else if f i \<in> F \<and> i \<in> I then h (f i) i else d)
      (pair_pmf (Pi_pmf (f -` {x} \<inter> I) d M) (Pi_pmf F (\<lambda>_. d) (\<lambda>j. Pi_pmf (f -` {j} \<inter> (f -` F \<inter> I)) d M)))"
      by (simp add:insert(3)[OF b c] map_pmf_comp case_prod_beta' apsnd_def map_prod_def
          pair_map_pmf2 b[symmetric] restrict_dfl_def) (metis fst_conv snd_conv)
    also have "... = map_pmf (\<lambda>(g,h) i. if i \<in> I then (h(x := g)) (f i) i else d)
      (pair_pmf (Pi_pmf (f -` {x} \<inter> I) d M) (Pi_pmf F (\<lambda>_. d) (\<lambda>j. Pi_pmf (f -` {j} \<inter> I) d M)))"
      using insert(4) d
      by (intro arg_cong2[where f="map_pmf"] ext) (auto simp add:case_prod_beta' cong:Pi_pmf_cong)
    also have "... = map_pmf (\<lambda>\<omega> i. if i \<in> I then \<omega> (f i) i else d) (Pi_pmf (insert x F) (\<lambda>_. d) (\<lambda>j. Pi_pmf (f -` {j} \<inter> I) d M))"
      by (simp add:Pi_pmf_insert[OF insert(1,2)] map_pmf_comp case_prod_beta')
    finally show ?case by (simp add:insert(4) restrict_dfl_def)
  qed
  thus ?thesis using assms by blast
qed

lemma restrict_dfl_iter: "restrict_dfl (restrict_dfl f I d) J d = restrict_dfl f (I \<inter> J) d"
  by (rule ext, simp add:restrict_dfl_def)

lemma indep_vars_restrict':
  assumes "finite I"
  shows "prob_space.indep_vars (Pi_pmf I d M) (\<lambda>_. discrete) (\<lambda>i \<omega>. restrict_dfl \<omega> (f -` {i} \<inter> I) d) (f ` I)"
proof -
  let ?Q = "(Pi_pmf (f ` I) (\<lambda>_. d) (\<lambda>i. Pi_pmf (I \<inter> f -` {i}) d M))"
  have a:"prob_space.indep_vars ?Q (\<lambda>_. discrete) (\<lambda>i \<omega>. \<omega> i) (f ` I)"
    using assms by (intro indep_vars_Pi_pmf, blast)
  have b: "AE x in measure_pmf ?Q. \<forall>i\<in>f ` I. x i = restrict_dfl (\<lambda>i. x (f i) i) (I \<inter> f -` {i}) d"
    using assms
    by (auto simp add:PiE_dflt_def restrict_dfl_def AE_measure_pmf_iff set_Pi_pmf comp_def Int_commute)
  have "prob_space.indep_vars ?Q (\<lambda>_. discrete) (\<lambda>i x. restrict_dfl (\<lambda>i. x (f i) i) (I \<inter> f -` {i}) d) (f ` I)"
    by (rule prob_space.indep_vars_cong_AE[OF prob_space_measure_pmf b a],  simp)
  thus ?thesis
    using prob_space_measure_pmf
    by (auto intro!:prob_space.indep_vars_distr simp:pi_pmf_decompose[OF assms, where f="f"]
        map_pmf_rep_eq comp_def restrict_dfl_iter Int_commute)
qed

lemma indep_vars_restrict_intro':
  assumes "finite I"
  assumes "\<And>i \<omega>. i \<in> J \<Longrightarrow> X' i \<omega> = X' i (restrict_dfl \<omega> (f -` {i} \<inter> I) d)"
  assumes "J = f ` I"
  assumes "\<And>\<omega> i. i \<in> J \<Longrightarrow>  X' i \<omega> \<in> space (M' i)"
  shows "prob_space.indep_vars (measure_pmf (Pi_pmf I d p)) M' (\<lambda>i \<omega>. X' i \<omega>) J"
proof -
  define M where "M \<equiv> measure_pmf (Pi_pmf I d p)"
  interpret prob_space "M"
    using M_def prob_space_measure_pmf by blast
  have "indep_vars (\<lambda>_. discrete) (\<lambda>i x. restrict_dfl x (f -` {i} \<inter> I) d) (f ` I)"
    unfolding M_def  by (rule indep_vars_restrict'[OF assms(1)])
  hence "indep_vars M' (\<lambda>i \<omega>. X' i (restrict_dfl \<omega> ( f -` {i} \<inter> I) d)) (f ` I)"
    using assms(4)
    by (intro indep_vars_compose2[where Y="X'" and N="M'" and M'="\<lambda>_. discrete"])  (auto simp:assms(3))
  hence "indep_vars M' (\<lambda>i \<omega>. X' i \<omega>) (f ` I)"
    using assms(2)[symmetric]
    by (simp add:assms(3) cong:indep_vars_cong)
  thus ?thesis
    unfolding M_def using assms(3) by simp
qed

lemma
  fixes f :: "'b \<Rightarrow> ('c :: {second_countable_topology,banach,real_normed_field})"
  assumes "finite I"
  assumes "i \<in> I"
  assumes "integrable (measure_pmf (M i)) f"
  shows  integrable_Pi_pmf_slice: "integrable (Pi_pmf I d M) (\<lambda>x. f (x i))"
  and expectation_Pi_pmf_slice: "integral\<^sup>L (Pi_pmf I d M) (\<lambda>x. f (x i)) = integral\<^sup>L (M i) f"
proof -
  have a:"distr (Pi_pmf I d M) (M i) (\<lambda>\<omega>. \<omega> i) = distr (Pi_pmf I d M) discrete (\<lambda>\<omega>. \<omega> i)"
    by (rule distr_cong, auto)

  have b: "measure_pmf.random_variable (M i) borel f"
    using assms(3) by simp

  have c:"integrable (distr (Pi_pmf I d M) (M i) (\<lambda>\<omega>. \<omega> i)) f"
    using assms(1,2,3)
    by (subst a, subst map_pmf_rep_eq[symmetric], subst Pi_pmf_component, auto)

  show "integrable (Pi_pmf I d M) (\<lambda>x. f (x i))"
    by (rule integrable_distr[where f="f" and M'="M i"])  (auto intro: c)

  have "integral\<^sup>L (Pi_pmf I d M) (\<lambda>x. f (x i)) = integral\<^sup>L (distr (Pi_pmf I d M) (M i) (\<lambda>\<omega>. \<omega> i)) f"
    using b by (intro integral_distr[symmetric], auto)
  also have "... =  integral\<^sup>L (map_pmf (\<lambda>\<omega>. \<omega> i) (Pi_pmf I d M)) f"
    by (subst a, subst map_pmf_rep_eq[symmetric], simp)
  also have "... =  integral\<^sup>L (M i) f"
    using assms(1,2) by (simp add: Pi_pmf_component)
  finally show "integral\<^sup>L (Pi_pmf I d M) (\<lambda>x. f (x i)) = integral\<^sup>L (M i) f" by simp
qed

text \<open>This is an improved version of @{thm [source] "expectation_prod_Pi_pmf"}.
It works for general normed fields instead of non-negative real functions .\<close>

lemma expectation_prod_Pi_pmf:
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> ('c :: {second_countable_topology,banach,real_normed_field})"
  assumes "finite I"
  assumes "\<And>i. i \<in> I \<Longrightarrow> integrable (measure_pmf (M i)) (f i)"
  shows   "integral\<^sup>L (Pi_pmf I d M) (\<lambda>x. (\<Prod>i \<in> I. f i (x i))) = (\<Prod> i \<in> I. integral\<^sup>L (M i) (f i))"
proof -
  have a: "prob_space.indep_vars (measure_pmf (Pi_pmf I d M)) (\<lambda>_. borel) (\<lambda>i \<omega>. f i (\<omega> i)) I"
    by (intro prob_space.indep_vars_compose2[where Y="f" and M'="\<lambda>_. discrete"]
        prob_space_measure_pmf indep_vars_Pi_pmf assms(1)) auto
  have "integral\<^sup>L (Pi_pmf I d M) (\<lambda>x. (\<Prod>i \<in> I. f i (x i))) = (\<Prod> i \<in> I. integral\<^sup>L (Pi_pmf I d M) (\<lambda>x. f i (x i)))"
    by (intro prob_space.indep_vars_lebesgue_integral prob_space_measure_pmf assms(1,2)
        a integrable_Pi_pmf_slice) auto
  also have "... = (\<Prod> i \<in> I. integral\<^sup>L (M i) (f i))"
    by (intro prod.cong expectation_Pi_pmf_slice assms(1,2)) auto
  finally show ?thesis by simp
qed

lemma variance_prod_pmf_slice:
  fixes f :: "'a \<Rightarrow> real"
  assumes "i \<in> I" "finite I"
  assumes "integrable (measure_pmf (M i)) (\<lambda>\<omega>. f \<omega>^2)"
  shows "prob_space.variance (Pi_pmf I d M) (\<lambda>\<omega>. f (\<omega> i)) = prob_space.variance (M i) f"
proof -
  have a:"integrable (measure_pmf (M i)) f"
    using assms(3) measure_pmf.square_integrable_imp_integrable by auto
  have b:" integrable (measure_pmf (Pi_pmf I d M)) (\<lambda>x. (f (x i))\<^sup>2)"
    by (rule integrable_Pi_pmf_slice[OF assms(2) assms(1)], metis assms(3))
  have c:" integrable (measure_pmf (Pi_pmf I d M)) (\<lambda>x. (f (x i)))"
    by (rule integrable_Pi_pmf_slice[OF assms(2) assms(1)], metis a)

  have "measure_pmf.expectation (Pi_pmf I d M) (\<lambda>x. (f (x i))\<^sup>2) - (measure_pmf.expectation (Pi_pmf I d M) (\<lambda>x. f (x i)))\<^sup>2 =
      measure_pmf.expectation (M i) (\<lambda>x. (f x)\<^sup>2) - (measure_pmf.expectation (M i) f)\<^sup>2"
    using assms a b c by ((subst expectation_Pi_pmf_slice[OF assms(2,1)])?, simp)+

  thus ?thesis
    using assms a b c by (simp add: measure_pmf.variance_eq)
qed

lemma Pi_pmf_bind_return:
  assumes "finite I"
  shows "Pi_pmf I d (\<lambda>i. M i \<bind> (\<lambda>x. return_pmf (f i x))) = Pi_pmf I d' M \<bind> (\<lambda>x. return_pmf (\<lambda>i. if i \<in> I then f i (x i) else d))"
  using assms by (simp add: Pi_pmf_bind[where d'="d'"])

end


\<^marker>\<open>creator "Josh Chen"\<close>
\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Subtraction (truncated)\<close>
theory Nat_Sub
  imports Nat_Add
begin

definition "nat_sub m n \<equiv> nat_rec n m pred"

lemma nat_sub_type [type]: "nat_sub : Nat \<Rightarrow> Nat \<Rightarrow> Nat"
  unfolding nat_sub_def by discharge_types

bundle isa_set_nat_sub_syntax begin notation nat_sub (infixl "-" 65) end
bundle no_isa_set_nat_sub_syntax begin no_notation nat_sub (infixl "-" 65) end

unbundle isa_set_nat_sub_syntax

lemma nat_sub_zero_eq [simp]: "m - 0 = m"
  unfolding nat_sub_def by simp

lemma Nat_sub_succ_eq [simp]: "n : Nat \<Longrightarrow> m - succ n = pred (m - n)"
  unfolding nat_sub_def by simp

lemma Nat_pred_sub_eq [simp]: "m : Nat \<Longrightarrow> pred n - m = pred (n - m)"
  by (induction m rule: Nat_induct) auto

lemma Nat_sub_eq_zero_if_le: "n : Nat \<Longrightarrow> m \<le> n \<Longrightarrow> m - n = 0"
proof (induction n arbitrary: m rule: Nat_induct)
  case (succ n)
  then show ?case
  proof (cases "m = 0")
    case True
    then have "m \<le> n" by simp
    with succ.IH have "0 = m - n" by simp
    then have "0 = pred (m - n)" by simp
    also have "... = m - succ n" by simp
    finally show "m - succ n = 0" by simp
  next
    case False
    then have "pred m < succ n" using Nat_pred_lt_if_le_if_ne_zero by auto
    then have "pred m \<le> n" using le_if_lt_succ by auto
    with succ.IH have "0 = pred m - n" by simp
    also have "... = m - succ n" by simp
    finally show "m - succ n = 0" by simp
  qed
qed simp

lemma Nat_zero_sub_eq [simp]: "m : Nat \<Longrightarrow> 0 - m = 0"
  by (rule Nat_sub_eq_zero_if_le) auto

lemma Nat_sub_self_eq [simp]: "m : Nat \<Longrightarrow> m - m = 0"
  by (rule Nat_sub_eq_zero_if_le) auto

lemma Nat_succ_sub_succ_eq [simp]:
  "m : Nat \<Longrightarrow> n : Nat \<Longrightarrow> succ m - succ n = m - n"
  unfolding nat_sub_def by (rule Nat_induct[of n]) auto

lemma Nat_sub_lt_sub_if_le_if_lt:
  assumes "m : Nat"
  and "l < m"
  and "n \<le> l"
  shows "l - n < m - n"
proof -
  from assms have "n : Nat" "l : Nat"
    by (auto intro: Nat_if_lt_Nat Nat_if_le_Nat)
  then show ?thesis using assms
  proof (induction n arbitrary: l m rule: Nat_induct)
    case (succ n)
    have "l - n \<noteq> 0"
    proof -
      from succ.prems have "n < l" using Nat_lt_if_succ_le by auto
      then have "n - n < l - n" by (subst succ.IH) auto
      then show ?thesis using Nat_zero_lt_iff_ne_zero by simp
    qed
    moreover have "l - n < m - n"
    proof (rule succ.IH)
      from succ.prems show "n \<le> l" by (auto intro: Nat_le_if_succ_le)
    qed discharge_types
    ultimately have "pred (l - n) < pred (m - n)"
      by (auto intro!: Nat_pred_lt_pred_if_lt_if_ne_zero)
    then show ?case by simp
  qed simp
qed

corollary Nat_zero_lt_sub_if_lt:
  assumes "n : Nat"
  and "m < n"
  shows "0 < n - m"
  using assms Nat_sub_lt_sub_if_le_if_lt[OF assms le_self]
    by (auto dest: Nat_if_lt_Nat)

lemma Nat_lt_if_sub_lt_sub:
  assumes "l : Nat" "m : Nat" "n : Nat"
  and "l - n < m - n"
  shows "l < m"
using \<open>n : Nat\<close> assms
proof (induction n arbitrary: l m rule: Nat_induct)
  case (succ n)
  then have "pred l - n < pred m - n" by simp
  with succ.IH have "pred l < pred m" by simp
  with Nat_lt_if_pred_lt_pred show ?case by simp
qed simp

corollary Nat_lt_if_zero_lt_sub:
  assumes "m : Nat" "n : Nat"
  and "0 < m - n"
  shows "n < m"
proof -
  from \<open>0 < m - n\<close> have "n - n < m - n" by simp
  then show ?thesis by (intro Nat_lt_if_sub_lt_sub[of n m n]) discharge_types
qed

corollary Nat_zero_lt_sub_iff_lt:
  "\<lbrakk>m : Nat; n : Nat\<rbrakk> \<Longrightarrow> 0 < n - m \<longleftrightarrow> m < n"
  using Nat_zero_lt_sub_if_lt Nat_lt_if_sub_lt_sub[of m n m] by auto

lemma Nat_succ_sub_eq_if_le:
  assumes "m : Nat"
  and "n \<le> m"
  shows "succ m - n = succ (m - n)"
proof (cases n rule: NatE)
  fix n' assume "n' : Nat" and [simp]: "n = succ n'"
  have "succ m - n = m - n'" by (simp del: Nat_sub_succ_eq)
  also have "... = succ (pred (m - n'))"
  proof (subst Nat_succ_pred_eq_if_ne_zero)
    from \<open>n \<le> m\<close> have "n' < m" by (auto intro: Nat_lt_if_succ_le)
    then show "m - n' \<noteq> 0"
      using Nat_zero_lt_sub_if_lt ne_if_lt[symmetric] by auto
  qed auto
  also have "... = succ (m - n)" by simp
  finally show "succ m - n = succ (m - n)" .
qed (auto intro: Nat_if_le_Nat[OF assms])

lemma Nat_sub_pred_eq_succ_if_le_if_ne_zero:
  assumes "m : Nat"
  and "n \<noteq> 0"
  and "n \<le> m"
  shows "m - pred n = succ (m - n)"
proof (cases n rule: NatE)
   (*TODO: should be derivable automatically*)
  from assms show "n : Nat" using Nat_if_le_Nat by auto
  fix n' assume "n' : Nat" and [simp]: "n = succ n'"
  then have "m - pred n = m - n'" by simp
  also have "... = succ (pred (m - n'))"
  proof (subst Nat_succ_pred_eq_if_ne_zero)
    from \<open>n \<le> m\<close> have "n' < m" by (auto intro: Nat_lt_if_succ_le)
    then show "m - n' \<noteq> 0"
      using Nat_zero_lt_sub_if_lt ne_if_lt[symmetric] by auto
  qed auto
  also have "...  = succ (m - n)" by simp
  finally show "m - pred n = succ (m - n)" .
qed (insert \<open>n \<noteq> 0\<close>, auto)

lemma Nat_add_sub_assoc:
  assumes "l : Nat" "m : Nat" "n \<le> m"
  shows "l + m - n = l + (m - n)"
proof -
  (*TODO: should be derivable automatically*)
  from assms have "n : Nat" using Nat_if_le_Nat by auto
  then show "?thesis" using assms
  proof (induction n arbitrary: l m rule: Nat_induct)
    case (succ n)
    have "l + m - succ n = pred (l + m - n)" using Nat_sub_succ_eq by simp
    also have "... = pred (l + (m - n))"
      by (subst succ.IH) (auto intro: Nat_le_if_succ_le)
    also have "... = l + pred (m - n)"
    proof (subst Nat_add_pred_eq)
      from \<open>succ n \<le> m\<close> have "n < m" using Nat_lt_if_succ_le by simp
      then have "n - n < m - n" by (intro Nat_sub_lt_sub_if_le_if_lt) auto
      then show "m - n \<noteq> 0" using Nat_zero_lt_iff_ne_zero by simp
    qed auto
    also have "... = l + (m - succ n)" using Nat_sub_succ_eq by simp
    finally show ?case .
  qed simp
qed

lemma Nat_sub_add_eq_sub_sub:
  assumes "l : Nat" "m : Nat" "n: Nat"
  shows "l - (m + n) = l - m - n"
using \<open>n : Nat\<close> assms
proof (induction n rule: Nat_induct)
  case (succ n)
  have "l - (m + succ n) = pred (l - (m + n))" by simp
  also with succ.IH have "... = pred (l - m - n)" by simp
  also have "... = l - m - succ n" by simp
  finally show ?case .
qed simp

lemma Nat_sub_sub_eq_sub_sub:
  assumes "l : Nat" "m : Nat" "n : Nat"
  shows "l - m - n = l - n - m"
  by (simp only: Nat_sub_add_eq_sub_sub[symmetric] Nat_add_comm)

end


theory Chapter10_1
imports "HOL-IMP.Def_Init"
begin

text\<open>
\section*{Chapter 10}

\exercise
Define the definite initialisation analysis as two recursive functions
\<close>

fun ivars :: "com \<Rightarrow> vname set" where
  "ivars SKIP = {}" |
  "ivars (x ::= _) = {x}" |
  "ivars (c\<^sub>1;; c\<^sub>2) = ivars c\<^sub>1 \<union> ivars c\<^sub>2" |
  "ivars (IF _ THEN c\<^sub>1 ELSE c\<^sub>2) = ivars c\<^sub>1 \<inter> ivars c\<^sub>2" |
  "ivars (WHILE _ DO _) = {}"

fun ok :: "vname set \<Rightarrow> com \<Rightarrow> bool" where
  "ok A SKIP = True" |
  "ok A (x ::= a) \<longleftrightarrow> vars a \<subseteq> A" |
  "ok A (c\<^sub>1;; c\<^sub>2) \<longleftrightarrow> ok A c\<^sub>1 \<and> ok (A \<union> ivars c\<^sub>1) c\<^sub>2" |
  "ok A (IF b THEN c\<^sub>1 ELSE c\<^sub>2) \<longleftrightarrow> vars b \<subseteq> A \<and> ok A c\<^sub>1 \<and> ok A c\<^sub>2" |
  "ok A (WHILE b DO c) \<longleftrightarrow> vars b \<subseteq> A \<and> ok A c"

text\<open>
such that @{const ivars} computes the set of definitely initialised variables
and @{const ok} checks that only initialised variable are accessed.
Prove
\<close>

lemma "D A c A' \<Longrightarrow> A' = A \<union> ivars c \<and> ok A c"
  by (induct A c A' rule: D.induct) auto

lemma "ok A c \<Longrightarrow> D A c (A \<union> ivars c)"
proof (induct A c rule: ok.induct)
  case (3 A c\<^sub>1 c\<^sub>2)
  then show ?case by (auto simp add: Un_assoc intro: D.intros)
next
  case (4 A b c\<^sub>1 c\<^sub>2)
  then show ?case by (auto simp add: sup_inf_distrib1 intro: D.intros)
qed (auto intro: D.intros)

text\<open>
\endexercise
\<close>

end


(*  Title:      HOL/Induct/Com.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1997  University of Cambridge

Example of Mutual Induction via Iteratived Inductive Definitions: Commands
*)

section\<open>Mutual Induction via Iteratived Inductive Definitions\<close>

theory Com imports Main begin

typedecl loc
type_synonym state = "loc => nat"

datatype
  exp = N nat
      | X loc
      | Op "nat => nat => nat" exp exp
      | valOf com exp          ("VALOF _ RESULTIS _"  60)
and
  com = SKIP
      | Assign loc exp         (infixl ":=" 60)
      | Semi com com           ("_;;_"  [60, 60] 60)
      | Cond exp com com       ("IF _ THEN _ ELSE _"  60)
      | While exp com          ("WHILE _ DO _"  60)

subsection \<open>Commands\<close>

text\<open>Execution of commands\<close>

abbreviation (input)
  generic_rel  ("_/ -|[_]-> _" [50,0,50] 50)  where
  "esig -|[eval]-> ns == (esig,ns) \<in> eval"

text\<open>Command execution.  Natural numbers represent Booleans: 0=True, 1=False\<close>

inductive_set
  exec :: "((exp*state) * (nat*state)) set => ((com*state)*state)set"
  and exec_rel :: "com * state => ((exp*state) * (nat*state)) set => state => bool"
    ("_/ -[_]-> _" [50,0,50] 50)
  for eval :: "((exp*state) * (nat*state)) set"
  where
    "csig -[eval]-> s == (csig,s) \<in> exec eval"

  | Skip:    "(SKIP,s) -[eval]-> s"

  | Assign:  "(e,s) -|[eval]-> (v,s') ==> (x := e, s) -[eval]-> s'(x:=v)"

  | Semi:    "[| (c0,s) -[eval]-> s2; (c1,s2) -[eval]-> s1 |]
             ==> (c0 ;; c1, s) -[eval]-> s1"

  | IfTrue: "[| (e,s) -|[eval]-> (0,s');  (c0,s') -[eval]-> s1 |]
             ==> (IF e THEN c0 ELSE c1, s) -[eval]-> s1"

  | IfFalse: "[| (e,s) -|[eval]->  (Suc 0, s');  (c1,s') -[eval]-> s1 |]
              ==> (IF e THEN c0 ELSE c1, s) -[eval]-> s1"

  | WhileFalse: "(e,s) -|[eval]-> (Suc 0, s1)
                 ==> (WHILE e DO c, s) -[eval]-> s1"

  | WhileTrue:  "[| (e,s) -|[eval]-> (0,s1);
                    (c,s1) -[eval]-> s2;  (WHILE e DO c, s2) -[eval]-> s3 |]
                 ==> (WHILE e DO c, s) -[eval]-> s3"

declare exec.intros [intro]

inductive_cases
        [elim!]: "(SKIP,s) -[eval]-> t"
    and [elim!]: "(x:=a,s) -[eval]-> t"
    and [elim!]: "(c1;;c2, s) -[eval]-> t"
    and [elim!]: "(IF e THEN c1 ELSE c2, s) -[eval]-> t"
    and exec_WHILE_case: "(WHILE b DO c,s) -[eval]-> t"

text\<open>Justifies using "exec" in the inductive definition of "eval"\<close>
lemma exec_mono: "A<=B ==> exec(A) <= exec(B)"
apply (rule subsetI)
apply (simp add: split_paired_all)
apply (erule exec.induct)
apply blast+
done

lemma [pred_set_conv]:
  "((\<lambda>x x' y y'. ((x, x'), (y, y')) \<in> R) <= (\<lambda>x x' y y'. ((x, x'), (y, y')) \<in> S)) = (R <= S)"
  unfolding subset_eq
  by (auto simp add: le_fun_def)

lemma [pred_set_conv]:
  "((\<lambda>x x' y. ((x, x'), y) \<in> R) <= (\<lambda>x x' y. ((x, x'), y) \<in> S)) = (R <= S)"
  unfolding subset_eq
  by (auto simp add: le_fun_def)

text\<open>Command execution is functional (deterministic) provided evaluation is\<close>
theorem single_valued_exec: "single_valued ev ==> single_valued(exec ev)"
apply (simp add: single_valued_def)
apply (intro allI)
apply (rule impI)
apply (erule exec.induct)
apply (blast elim: exec_WHILE_case)+
done

subsection \<open>Expressions\<close>

text\<open>Evaluation of arithmetic expressions\<close>

inductive_set
  eval    :: "((exp*state) * (nat*state)) set"
  and eval_rel :: "[exp*state,nat*state] => bool"  (infixl "-|->" 50)
  where
    "esig -|-> ns == (esig, ns) \<in> eval"

  | N [intro!]: "(N(n),s) -|-> (n,s)"

  | X [intro!]: "(X(x),s) -|-> (s(x),s)"

  | Op [intro]: "[| (e0,s) -|-> (n0,s0);  (e1,s0)  -|-> (n1,s1) |]
                 ==> (Op f e0 e1, s) -|-> (f n0 n1, s1)"

  | valOf [intro]: "[| (c,s) -[eval]-> s0;  (e,s0)  -|-> (n,s1) |]
                    ==> (VALOF c RESULTIS e, s) -|-> (n, s1)"

  monos exec_mono

inductive_cases
        [elim!]: "(N(n),sigma) -|-> (n',s')"
    and [elim!]: "(X(x),sigma) -|-> (n,s')"
    and [elim!]: "(Op f a1 a2,sigma)  -|-> (n,s')"
    and [elim!]: "(VALOF c RESULTIS e, s) -|-> (n, s1)"

lemma var_assign_eval [intro!]: "(X x, s(x:=n)) -|-> (n, s(x:=n))"
  by (rule fun_upd_same [THEN subst]) fast

text\<open>Make the induction rule look nicer -- though \<open>eta_contract\<close> makes the new
    version look worse than it is...\<close>

lemma split_lemma: "{((e,s),(n,s')). P e s n s'} = Collect (case_prod (%v. case_prod (case_prod P v)))"
  by auto

text\<open>New induction rule.  Note the form of the VALOF induction hypothesis\<close>
lemma eval_induct
  [case_names N X Op valOf, consumes 1, induct set: eval]:
  "[| (e,s) -|-> (n,s');
      !!n s. P (N n) s n s;
      !!s x. P (X x) s (s x) s;
      !!e0 e1 f n0 n1 s s0 s1.
         [| (e0,s) -|-> (n0,s0); P e0 s n0 s0;
            (e1,s0) -|-> (n1,s1); P e1 s0 n1 s1
         |] ==> P (Op f e0 e1) s (f n0 n1) s1;
      !!c e n s s0 s1.
         [| (c,s) -[eval Int {((e,s),(n,s')). P e s n s'}]-> s0;
            (c,s) -[eval]-> s0;
            (e,s0) -|-> (n,s1); P e s0 n s1 |]
         ==> P (VALOF c RESULTIS e) s n s1
   |] ==> P e s n s'"
apply (induct set: eval)
apply blast
apply blast
apply blast
apply (frule Int_lower1 [THEN exec_mono, THEN subsetD])
apply (auto simp add: split_lemma)
done

text\<open>Lemma for \<open>Function_eval\<close>.  The major premise is that \<open>(c,s)\<close> executes to \<open>s1\<close>
  using eval restricted to its functional part.  Note that the execution
  \<open>(c,s) -[eval]-> s2\<close> can use unrestricted \<open>eval\<close>!  The reason is that
  the execution \<open>(c,s) -[eval Int {...}]-> s1\<close> assures us that execution is
  functional on the argument \<open>(c,s)\<close>.
\<close>
lemma com_Unique:
 "(c,s) -[eval Int {((e,s),(n,t)). \<forall>nt'. (e,s) -|-> nt' --> (n,t)=nt'}]-> s1
  ==> \<forall>s2. (c,s) -[eval]-> s2 --> s2=s1"
apply (induct set: exec)
      apply simp_all
      apply blast
     apply force
    apply blast
   apply blast
  apply blast
 apply (blast elim: exec_WHILE_case)
apply (erule_tac V = "(c,s2) -[ev]-> s3" for c ev in thin_rl)
apply clarify
apply (erule exec_WHILE_case, blast+)
done

text\<open>Expression evaluation is functional, or deterministic\<close>
theorem single_valued_eval: "single_valued eval"
apply (unfold single_valued_def)
apply (intro allI, rule impI)
apply (simp (no_asm_simp) only: split_tupled_all)
apply (erule eval_induct)
apply (drule_tac [4] com_Unique)
apply (simp_all (no_asm_use))
apply blast+
done

lemma eval_N_E [dest!]: "(N n, s) -|-> (v, s') ==> (v = n & s' = s)"
  by (induct e == "N n" s v s' set: eval) simp_all

text\<open>This theorem says that "WHILE TRUE DO c" cannot terminate\<close>
lemma while_true_E:
    "(c', s) -[eval]-> t ==> c' = WHILE (N 0) DO c ==> False"
  by (induct set: exec) auto

subsection\<open>Equivalence of IF e THEN c;;(WHILE e DO c) ELSE SKIP  and
       WHILE e DO c\<close>

lemma while_if1:
     "(c',s) -[eval]-> t
      ==> c' = WHILE e DO c ==>
          (IF e THEN c;;c' ELSE SKIP, s) -[eval]-> t"
  by (induct set: exec) auto

lemma while_if2:
     "(c',s) -[eval]-> t
      ==> c' = IF e THEN c;;(WHILE e DO c) ELSE SKIP ==>
          (WHILE e DO c, s) -[eval]-> t"
  by (induct set: exec) auto

theorem while_if:
     "((IF e THEN c;;(WHILE e DO c) ELSE SKIP, s) -[eval]-> t)  =
      ((WHILE e DO c, s) -[eval]-> t)"
by (blast intro: while_if1 while_if2)

subsection\<open>Equivalence of  (IF e THEN c1 ELSE c2);;c
                         and  IF e THEN (c1;;c) ELSE (c2;;c)\<close>

lemma if_semi1:
     "(c',s) -[eval]-> t
      ==> c' = (IF e THEN c1 ELSE c2);;c ==>
          (IF e THEN (c1;;c) ELSE (c2;;c), s) -[eval]-> t"
  by (induct set: exec) auto

lemma if_semi2:
     "(c',s) -[eval]-> t
      ==> c' = IF e THEN (c1;;c) ELSE (c2;;c) ==>
          ((IF e THEN c1 ELSE c2);;c, s) -[eval]-> t"
  by (induct set: exec) auto

theorem if_semi: "(((IF e THEN c1 ELSE c2);;c, s) -[eval]-> t)  =
                  ((IF e THEN (c1;;c) ELSE (c2;;c), s) -[eval]-> t)"
  by (blast intro: if_semi1 if_semi2)

subsection\<open>Equivalence of  VALOF c1 RESULTIS (VALOF c2 RESULTIS e)
                  and  VALOF c1;;c2 RESULTIS e
\<close>

lemma valof_valof1:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF c1 RESULTIS (VALOF c2 RESULTIS e) ==>
          (VALOF c1;;c2 RESULTIS e, s) -|-> (v,s')"
  by (induct set: eval) auto

lemma valof_valof2:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF c1;;c2 RESULTIS e ==>
          (VALOF c1 RESULTIS (VALOF c2 RESULTIS e), s) -|-> (v,s')"
  by (induct set: eval) auto

theorem valof_valof:
     "((VALOF c1 RESULTIS (VALOF c2 RESULTIS e), s) -|-> (v,s'))  =
      ((VALOF c1;;c2 RESULTIS e, s) -|-> (v,s'))"
  by (blast intro: valof_valof1 valof_valof2)

subsection\<open>Equivalence of  VALOF SKIP RESULTIS e  and  e\<close>

lemma valof_skip1:
     "(e',s) -|-> (v,s')
      ==> e' = VALOF SKIP RESULTIS e ==>
          (e, s) -|-> (v,s')"
  by (induct set: eval) auto

lemma valof_skip2:
    "(e,s) -|-> (v,s') ==> (VALOF SKIP RESULTIS e, s) -|-> (v,s')"
  by blast

theorem valof_skip:
    "((VALOF SKIP RESULTIS e, s) -|-> (v,s'))  =  ((e, s) -|-> (v,s'))"
  by (blast intro: valof_skip1 valof_skip2)

subsection\<open>Equivalence of  VALOF x:=e RESULTIS x  and  e\<close>

lemma valof_assign1:
     "(e',s) -|-> (v,s'')
      ==> e' = VALOF x:=e RESULTIS X x ==>
          (\<exists>s'. (e, s) -|-> (v,s') & (s'' = s'(x:=v)))"
  by (induct set: eval) (simp_all del: fun_upd_apply, clarify, auto)

lemma valof_assign2:
    "(e,s) -|-> (v,s') ==> (VALOF x:=e RESULTIS X x, s) -|-> (v,s'(x:=v))"
  by blast

end


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

section \<open> Verification components for hybrid systems \<close>

text \<open> A light-weight version of the verification components. We define the forward box
operator to compute weakest liberal preconditions (wlps) of hybrid programs. Then we
introduce three methods for verifying correctness specifications of the continuous
dynamics of a HS. \<close>

theory HS_VC_Spartan
  imports "Framed_ODEs.Dynamical_Systems"

begin

type_synonym 'a pred = "'a \<Rightarrow> bool"

no_notation Transitive_Closure.rtrancl ("(_\<^sup>*)" [1000] 999)

notation Union ("\<mu>")
     and g_orbital ("(1x\<acute>=_ & _ on _ _ @ _)")

subsection \<open>Verification of regular programs\<close>

text \<open> Lemmas for verification condition generation \<close>

definition fbox :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b pred \<Rightarrow> 'a pred" ("|_] _" [61,81] 82)
  where "|F] P = (\<lambda>s. (\<forall>s'. s' \<in> F s \<longrightarrow> P s'))"

lemma fbox_iso: "P \<le> Q \<Longrightarrow> |F] P \<le> |F] Q"
  unfolding fbox_def by auto

lemma fbox_anti: "\<forall>s. F\<^sub>1 s \<subseteq> F\<^sub>2 s \<Longrightarrow> |F\<^sub>2] P \<le> |F\<^sub>1] P"
  unfolding fbox_def by auto

lemma fbox_invariants:
  assumes "I \<le> |F] I" and "J \<le> |F] J"
  shows "(\<lambda>s. I s \<and> J s) \<le> |F] (\<lambda>s. I s \<and> J s)"
    and "(\<lambda>s. I s \<or> J s) \<le> |F] (\<lambda>s. I s \<or> J s)"
  using assms unfolding fbox_def by auto

definition fdia :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'b pred \<Rightarrow> 'a pred" ("|_\<rangle> _" [61,81] 82)
  where "|F\<rangle> P = (\<lambda>s. (\<exists>s'. s' \<in> F s \<and> P s'))"

\<comment> \<open> Skip \<close>

abbreviation "skip \<equiv> (\<lambda>s. {s})"

lemma fbox_eta[simp]: "|skip] P = P"
  unfolding fbox_def by simp

\<comment> \<open> Tests \<close>

definition test :: "'a pred \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1\<questiondown>_?)")
  where "\<questiondown>P? = (\<lambda>s. {x. x = s \<and> P x})"

lemma fbox_test[simp]: "(\<lambda>s. ( |\<questiondown>P?] Q) s) = (\<lambda>s. P s \<longrightarrow> Q s)"
  unfolding fbox_def test_def by simp

\<comment> \<open> Assignments \<close>

definition vec_upd :: "'a^'n \<Rightarrow> 'n \<Rightarrow> 'a \<Rightarrow> 'a^'n"
  where "vec_upd s i a = (\<chi> j. ((($) s)(i := a)) j)"

lemma vec_upd_eq: "vec_upd s i a = (\<chi> j. if j = i then a else s$j)"
  by (simp add: vec_upd_def)

definition assign :: "'n \<Rightarrow> ('a^'n \<Rightarrow> 'a) \<Rightarrow> 'a^'n \<Rightarrow> ('a^'n) set" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) = (\<lambda>s. {vec_upd s x (e s)})"

lemma fbox_assign[simp]: "|x ::= e] Q = (\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j))"
  unfolding vec_upd_def assign_def by (subst fbox_def) simp

\<comment> \<open> Nondeterministic assignments \<close>

definition nondet_assign :: "'n \<Rightarrow> 'a^'n \<Rightarrow> ('a^'n) set" ("(2_ ::= ? )" [70] 61)
  where "(x ::= ?) = (\<lambda>s. {(vec_upd s x k)|k. True})"

lemma fbox_nondet_assign[simp]: "|x ::= ?] P = (\<lambda>s. \<forall>k. P (\<chi> j. if j = x then k else s$j))"
  unfolding fbox_def nondet_assign_def vec_upd_eq apply(simp add: fun_eq_iff, safe)
  by (erule_tac x="(\<chi> j. if j = x then k else _ $ j)" in allE, auto)

\<comment> \<open> Nondeterministic choice \<close>

lemma fbox_choice: "|(\<lambda>s. F s \<union> G s)] P = (\<lambda>s. ( |F] P) s \<and> ( |G] P) s)"
  unfolding fbox_def by auto

lemma le_fbox_choice_iff: "P \<le> |(\<lambda>s. F s \<union> G s)] Q \<longleftrightarrow> P \<le> |F] Q \<and> P \<le> |G] Q"
  unfolding fbox_def by auto

\<comment> \<open> Sequential composition \<close>

definition kcomp :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('b \<Rightarrow> 'c set) \<Rightarrow> ('a  \<Rightarrow> 'c set)" (infixl ";" 75) where
  "F ; G = \<mu> \<circ> \<P> G \<circ> F"

lemma kcomp_eq: "(f ; g) x = \<Union> {g y |y. y \<in> f x}"
  unfolding kcomp_def image_def by auto

lemma fbox_kcomp[simp]: "|G ; F] P = |G] |F] P"
  unfolding fbox_def kcomp_def by auto

lemma hoare_kcomp:
  assumes "P \<le> |G] R" "R \<le> |F] Q"
  shows "P \<le> |G ; F] Q"
  apply(subst fbox_kcomp)
  by (rule order.trans[OF assms(1)]) (rule fbox_iso[OF assms(2)])

\<comment> \<open> Conditional statement \<close>

definition ifthenelse :: "'a pred \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set)"
  ("IF _ THEN _ ELSE _" [64,64,64] 63) where
  "IF P THEN X ELSE Y \<equiv> (\<lambda>s. if P s then X s else Y s)"

lemma fbox_if_then_else[simp]:
  "|IF T THEN X ELSE Y] Q = (\<lambda>s. (T s \<longrightarrow> ( |X] Q) s) \<and> (\<not> T s \<longrightarrow> ( |Y] Q) s))"
  unfolding fbox_def ifthenelse_def by auto

lemma hoare_if_then_else:
  assumes "(\<lambda>s. P s \<and> T s) \<le> |X] Q"
    and "(\<lambda>s. P s \<and> \<not> T s) \<le> |Y] Q"
  shows "P \<le> |IF T THEN X ELSE Y] Q"
  using assms unfolding fbox_def ifthenelse_def by auto

\<comment> \<open> Finite iteration \<close>

definition kpower :: "('a \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a set)"
  where "kpower f n = (\<lambda>s. ((;) f ^^ n) skip s)"

lemma kpower_base:
  shows "kpower f 0 s = {s}" and "kpower f (Suc 0) s = f s"
  unfolding kpower_def by(auto simp: kcomp_eq)

lemma kpower_simp: "kpower f (Suc n) s = (f ; kpower f n) s"
  unfolding kcomp_eq
  apply(induct n)
  unfolding kpower_base
   apply(force simp: subset_antisym)
  unfolding kpower_def kcomp_eq by simp

definition kleene_star :: "('a \<Rightarrow> 'a set) \<Rightarrow> ('a \<Rightarrow> 'a set)" ("(_\<^sup>*)" [1000] 999)
  where "(f\<^sup>*) s = \<Union> {kpower f n s |n. n \<in> UNIV}"

lemma kpower_inv:
  fixes F :: "'a \<Rightarrow> 'a set"
  assumes "\<forall>s. I s \<longrightarrow> (\<forall>s'. s' \<in> F s \<longrightarrow> I s')"
  shows "\<forall>s. I s \<longrightarrow> (\<forall>s'. s' \<in> (kpower F n s) \<longrightarrow> I s')"
  apply(clarsimp, induct n)
  unfolding kpower_base kpower_simp
   apply(simp_all add: kcomp_eq, clarsimp)
  apply(subgoal_tac "I y", simp)
  using assms by blast

lemma kstar_inv: "I \<le> |F] I \<Longrightarrow> I \<le> |F\<^sup>*] I"
  unfolding kleene_star_def fbox_def
  apply clarsimp
  apply(unfold le_fun_def, subgoal_tac "\<forall>x. I x \<longrightarrow> (\<forall>s'. s' \<in> F x \<longrightarrow> I s')")
  using kpower_inv[of I F] by blast simp

lemma fbox_kstarI:
  assumes "P \<le> I" and "I \<le> Q" and "I \<le> |F] I"
  shows "P \<le> |F\<^sup>*] Q"
proof-
  have "I \<le> |F\<^sup>*] I"
    using assms(3) kstar_inv by blast
  hence "P \<le> |F\<^sup>*] I"
    using assms(1) by auto
  also have "|F\<^sup>*] I \<le> |F\<^sup>*] Q"
    by (rule fbox_iso[OF assms(2)])
  finally show ?thesis .
qed

definition loopi :: "('a \<Rightarrow> 'a set) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> 'a set)" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP F INV I \<equiv> (F\<^sup>*)"

lemma change_loopI: "LOOP X INV G = LOOP X INV I"
  unfolding loopi_def by simp

lemma fbox_loopI: "P \<le> I \<Longrightarrow> I \<le> Q \<Longrightarrow> I \<le> |F] I \<Longrightarrow> P \<le> |LOOP F INV I] Q"
  unfolding loopi_def using fbox_kstarI[of "P"] by simp

lemma wp_loopI_break:
  "P \<le> |Y] I \<Longrightarrow> I \<le> |X] I \<Longrightarrow> I \<le> Q \<Longrightarrow> P \<le> |Y ; (LOOP X INV I)] Q"
  by (rule hoare_kcomp, force) (rule fbox_loopI, auto)

subsection \<open> Verification of hybrid programs \<close>

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

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

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

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

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

context local_flow
begin

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

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

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

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

end

text \<open> Verification with differential invariants \<close>

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

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

lemma fbox_g_orbital_inv:
  assumes "P \<le> I" and "I \<le> |x\<acute>=f & G on U S @ t\<^sub>0] I" and "I \<le> Q"
  shows "P \<le> |x\<acute>=f & G on U S @ t\<^sub>0] Q"
  using assms(1)
  apply(rule order.trans)
  using assms(2)
  apply(rule order.trans)
  by (rule fbox_iso[OF assms(3)])

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

lemma diff_inv_guard_ignore:
  assumes "I \<le> |x\<acute>= f & (\<lambda>s. True) on U S @ t\<^sub>0] I"
  shows "I \<le> |x\<acute>= f & G on U S @ t\<^sub>0] I"
  using assms unfolding fbox_diff_inv diff_inv_eq image_le_pred by auto

context local_flow
begin

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

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

end

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

subsection \<open> Derivation of the rules of dL \<close>

text \<open> We derive rules of differential dynamic logic (dL). This allows the components to reason
in the style of that logic. \<close>

abbreviation g_dl_ode ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set"
  ("(1x\<acute>=_ & _)") where "(x\<acute>=f & G) \<equiv> (x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0)"

abbreviation g_dl_ode_inv ::"(('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a \<Rightarrow> 'a set" ("(1x\<acute>=_ & _ DINV _)")
  where "(x\<acute>=f & G DINV I) \<equiv> (x\<acute>=(\<lambda>t. f) & G on (\<lambda>s. {t. t \<ge> 0}) UNIV @ 0 DINV I)"

lemma diff_solve_axiom1:
  assumes "local_flow f UNIV UNIV \<phi>"
  shows "|x\<acute>= f & G] Q =
  (\<lambda>s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  by (subst local_flow.fbox_g_ode_subset[OF assms], auto)

lemma diff_solve_axiom2:
  fixes c::"'a::{heine_borel, banach}"
  shows "|x\<acute>=(\<lambda>s. c) & G] Q =
  (\<lambda>s. \<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s + \<tau> *\<^sub>R c)) \<longrightarrow> Q (s + t *\<^sub>R c))"
  by (subst local_flow.fbox_g_ode_subset[OF line_is_local_flow, of UNIV], auto)

lemma diff_solve_rule:
  assumes "local_flow f UNIV UNIV \<phi>"
    and "\<forall>s. P s \<longrightarrow> (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "P \<le> |x\<acute>= f & G] Q"
  using assms by(subst local_flow.fbox_g_ode_subset[OF assms(1)]) auto

lemma diff_weak_axiom1: "( |x\<acute>= f & G on U S @ t\<^sub>0] G) s"
  unfolding fbox_def g_orbital_eq by auto

lemma diff_weak_axiom2: "|x\<acute>= f & G on T S @ t\<^sub>0] Q = |x\<acute>= f & G on T S @ t\<^sub>0] (\<lambda>s. G s \<longrightarrow> Q s)"
  unfolding fbox_g_orbital image_def by force

lemma diff_weak_rule: "G \<le> Q \<Longrightarrow> P \<le> |x\<acute>= f & G on T S @ t\<^sub>0] Q"
  by(auto intro: g_orbitalD simp: le_fun_def g_orbital_eq fbox_def)

lemma fbox_g_orbital_eq_univD:
  assumes "|x\<acute>= f & G on U S @ t\<^sub>0] C = (\<lambda>s. True)"
    and "\<forall>\<tau>\<in>(down (U s) t). x \<tau> \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
  shows "\<forall>\<tau>\<in>(down (U s) t). C (x \<tau>)"
proof
  fix \<tau> assume "\<tau> \<in> (down (U s) t)"
  hence "x \<tau> \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    using assms(2) by blast
  also have "\<forall>s'. s' \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s \<longrightarrow> C s'"
    using assms(1) unfolding fbox_def by meson
  ultimately show "C (x \<tau>)"
    by blast
qed

lemma diff_cut_axiom:
  assumes "|x\<acute>= f & G on U S @ t\<^sub>0] C = (\<lambda>s. True)"
  shows "|x\<acute>= f & G on U S @ t\<^sub>0] Q = |x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0] Q"
proof(rule_tac f="\<lambda> x. |x] Q" in HOL.arg_cong, rule ext, rule subset_antisym)
  fix s
  {fix s' assume "s' \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    then obtain \<tau>::real and X where x_ivp: "X \<in> Sols U S f t\<^sub>0 s"
      and "X \<tau> = s'" and "\<tau> \<in> U s" and guard_x:"\<P> X (down (U s) \<tau>) \<subseteq> {s. G s}"
      using g_orbitalD[of s' "f" G U S t\<^sub>0 s]  by blast
    have "\<forall>t\<in>(down (U s) \<tau>). \<P> X (down (U s) t) \<subseteq> {s. G s}"
      using guard_x by (force simp: image_def)
    also have "\<forall>t\<in>(down (U s) \<tau>). t \<in> U s"
      using \<open>\<tau> \<in> U s\<close> closed_segment_subset_interval by auto
    ultimately have "\<forall>t\<in>(down (U s) \<tau>). X t \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp] by (metis (mono_tags, lifting))
    hence "\<forall>t\<in>(down (U s) \<tau>). C (X t)"
      using assms unfolding fbox_def by meson
    hence "s' \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s"
      using g_orbitalI[OF x_ivp \<open>\<tau> \<in> U s\<close>] guard_x \<open>X \<tau> = s'\<close> by fastforce}
  thus "(x\<acute>= f & G on U S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s"
    by blast
next show "\<And>s. (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s \<subseteq> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    by (auto simp: g_orbital_eq)
qed

lemma diff_cut_rule:
  assumes fbox_C: "P \<le> |x\<acute>= f & G on U S @ t\<^sub>0] C"
    and fbox_Q: "P \<le> |x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0] Q"
  shows "P \<le> |x\<acute>= f & G on U S @ t\<^sub>0] Q"
proof(subst fbox_def, subst g_orbital_eq, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s assume "P s" and "t \<in> U s"
    and x_ivp:"X \<in> Sols U S f t\<^sub>0 s"
    and guard_x:"\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)"
  have "\<forall>\<tau>\<in>(down (U s) t). X \<tau> \<in> (x\<acute>= f & G on U S @ t\<^sub>0) s"
    using g_orbitalI[OF x_ivp] guard_x unfolding image_le_pred by auto
  hence "\<forall>\<tau>\<in>(down (U s) t). C (X \<tau>)"
    using fbox_C \<open>P s\<close> by (subst (asm) fbox_def, auto)
  hence "X t \<in> (x\<acute>= f & (\<lambda>s. G s \<and> C s) on U S @ t\<^sub>0) s"
    using guard_x \<open>t \<in> U s\<close> by (auto intro!: g_orbitalI x_ivp)
  thus "Q (X t)"
    using \<open>P s\<close> fbox_Q by (subst (asm) fbox_def) auto
qed

lemma diff_inv_axiom1:
  assumes "G s \<longrightarrow> I s" and "diff_inv (\<lambda>s. {t. t \<ge> 0}) UNIV G (\<lambda>t. f) 0 I"
  shows "( |x\<acute>= f & G] I) s"
  using assms unfolding fbox_g_orbital diff_inv_eq apply clarsimp
  by (erule_tac x=s in allE, frule ivp_solsD(2), clarsimp)

lemma diff_inv_axiom2:
  assumes "picard_lindeloef (\<lambda>t. f) UNIV UNIV 0"
    and "\<And>s. {t::real. t \<ge> 0} \<subseteq> picard_lindeloef.ex_ivl (\<lambda>t. f) UNIV UNIV 0 s"
    and "diff_inv (\<lambda>s. {t::real. t \<ge> 0}) UNIV G (\<lambda>t. f) 0 I"
  shows "|x\<acute>= f & G] I = |(\<lambda>s. {x. s = x \<and> G s})] I"
proof(unfold fbox_g_orbital, subst fbox_def, clarsimp simp: fun_eq_iff)
  fix s
  let "?ex_ivl s" = "picard_lindeloef.ex_ivl (\<lambda>t. f) UNIV UNIV 0 s"
  let "?lhs s" =
    "\<forall>X\<in>Sols (\<lambda>s. {t. t \<ge> 0}) UNIV (\<lambda>t. f) 0 s. \<forall>t\<ge>0. (\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)) \<longrightarrow> I (X t)"
  obtain X where xivp1: "X \<in> Sols (\<lambda>s. ?ex_ivl s) UNIV (\<lambda>t. f) 0 s"
    using picard_lindeloef.flow_in_ivp_sols_ex_ivl[OF assms(1)] by auto
  have xivp2: "X \<in> Sols (\<lambda>s. Collect ((\<le>) 0)) UNIV (\<lambda>t. f) 0 s"
    by (rule in_ivp_sols_subset[OF _ _ xivp1], simp_all add: assms(2))
  hence shyp: "X 0 = s"
    using ivp_solsD by auto
  have dinv: "\<forall>s. I s \<longrightarrow> ?lhs s"
    using assms(3) unfolding diff_inv_eq by auto
  {assume "?lhs s" and "G s"
    hence "I s"
      by (erule_tac x=X in ballE, erule_tac x=0 in allE, auto simp: shyp xivp2)}
  hence "?lhs s \<longrightarrow> (G s \<longrightarrow> I s)"
    by blast
  moreover
  {assume "G s \<longrightarrow> I s"
    hence "?lhs s"
      apply(clarify, subgoal_tac "\<forall>\<tau>. 0 \<le> \<tau> \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)")
       apply(erule_tac x=0 in allE, frule ivp_solsD(2), simp)
      using dinv by blast+}
  ultimately show "?lhs s = (G s \<longrightarrow> I s)"
    by blast
qed

lemma diff_inv_rule:
  assumes "P \<le> I" and "diff_inv U S G f t\<^sub>0 I" and "I \<le> Q"
  shows "P \<le> |x\<acute>= f & G on U S @ t\<^sub>0] Q"
  apply(rule fbox_g_orbital_inv[OF assms(1) _ assms(3)])
  unfolding fbox_diff_inv using assms(2) .

end