\<^marker>\<open>creator "Johannes Hölzl"\<close>
theory Random_Walk
  imports PGCL
begin

lemma add_divide_distrib_ennreal: "(a + b::ennreal) / c = a / c + b / c"
  by (simp add: divide_ennreal_def distrib_right)

lemma e2ennreal_inject: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> e2ennreal x = e2ennreal y \<longleftrightarrow> x = y"
  unfolding e2ennreal_def by (auto simp: max_absorb2 ennreal.e2ennreal'_inject)

lemma e2ennreal_eq_top: "e2ennreal x = top \<longleftrightarrow> x = \<infinity>"
  unfolding top_ennreal_def top_ereal_def
  apply (cases "\<not> 0 \<le> x")
  apply (auto simp add: e2ennreal_neg e2ennreal_infty) []
  apply (rule e2ennreal_inject)
  apply (auto simp: top_ennreal_def)
  done

lemma ennreal_of_enat_add: "ennreal_of_enat (m + n) = ennreal_of_enat m + ennreal_of_enat n"
  by (cases m n rule: enat.exhaust[case_product enat.exhaust]) auto

lemma ennreal_of_enat_eq_top: "ennreal_of_enat e = top \<longleftrightarrow> e = \<infinity>"
  by (cases e) auto

lemma (in MC_syntax) T_translate:
  fixes f
  assumes f: "bij f" and K_f: "\<And>x. K (f x) = map_pmf f (K x)"
  shows "T (f x) = distr (T x) S (smap f)"
proof -
  have f_inv: "f (the_inv f x) = x" and [simp]: "inj f" for x
    using f f_the_inv_into_f[of f UNIV x] by (auto simp: bij_def)
  have K_inv[simp]: "K (the_inv f i) = map_pmf (the_inv f) (K i)" for i
    by (rewrite at "map_pmf _ (K \<hole>)" f_inv[symmetric]) (auto simp: K_f map_pmf_comp the_inv_f_f)

  have "T = (\<lambda>i. distr (T (the_inv f i)) S (smap f))"
  proof (rule T_bisim)
    fix i
    show "prob_space (distr (T (the_inv f i)) S (smap f))"
      by (intro T.prob_space_distr) simp
    show "sets (distr (T (the_inv f i)) S (smap f)) = sets S"
      by simp
    have *: "subprob_space (distr (T x) (stream_space (count_space UNIV)) ((##) x))" for x
      by (intro prob_space_imp_subprob_space T.prob_space_distr) auto

    show "distr (T (the_inv f i)) S (smap f) = measure_pmf (K i) \<bind> (\<lambda>s. distr (distr (T (the_inv f s)) S (smap f)) S ((##) s))"
      apply (subst T_eq_bind)
      apply (subst distr_bind[where K=S])
      apply (auto simp: space_subprob_algebra prob_space_imp_subprob_space T.prob_space_distr K_f)
      apply (subst (1 2) distr_distr)
      apply (auto simp: map_pmf_rep_eq)
      apply (subst bind_distr[where K=S])
      apply (auto simp: space_subprob_algebra prob_space_imp_subprob_space T.prob_space_distr
                        comp_def f_inv
                 intro!: bind_measure_pmf_cong)
      done
  qed
  from this[THEN fun_cong, of "f x"] show ?thesis
    by (simp add: the_inv_f_f)
qed

definition srw :: "int \<Rightarrow> int pmf"
where
  "srw i = map_pmf (\<lambda>True \<Rightarrow> i + 1 | False \<Rightarrow> i - 1) (bernoulli_pmf (1/2))"

lemma set_pmf_srw[simp]: "set_pmf (srw i) = {i - 1, i + 1}"
  by (auto simp add: srw_def set_pmf_bernoulli split: bool.splits)

lemma srw_uminus: "srw (- i) = map_pmf uminus (srw i)"
  apply (intro pmf_eqI)
  unfolding ennreal_inj[symmetric, OF pmf_nonneg pmf_nonneg] ennreal_pmf_map srw_def nn_integral_map_pmf
  apply (subst nn_integral_bernoulli_pmf)
  apply (auto split: split_indicator)
  done

lemma srw_add: "srw (i + t) = map_pmf (\<lambda>i. i + t) (srw i)"
  apply (intro pmf_eqI)
  unfolding ennreal_inj[symmetric, OF pmf_nonneg pmf_nonneg] ennreal_pmf_map srw_def nn_integral_map_pmf
  apply (subst nn_integral_bernoulli_pmf)
  apply (auto split: split_indicator)
  done

context
begin

interpretation srw: MC_syntax srw .

lemma srw_T_uminus: "srw.T (- i) = distr (srw.T i) srw.S (smap uminus)"
  by (rule srw.T_translate)
     (auto simp: srw_uminus bij_def image_iff intro!: exI[of _ "- _"])

lemma srw_T_add: "srw.T (i + t) = distr (srw.T i) srw.S (smap (\<lambda>i. i + t))"
  by (rule srw.T_translate)
     (auto simp: srw_add bij_def image_iff intro!: exI[of _ "_ - t"] inj_onI)

abbreviation h :: "int \<Rightarrow> int stream \<Rightarrow> enat"
where
  "h i \<omega> \<equiv> sfirst (HLD {i}) \<omega>"

abbreviation H :: "int \<Rightarrow> int \<Rightarrow> ennreal"
where
  "H i j \<equiv> (\<integral>\<^sup>+\<omega>. h j (i ## \<omega>) \<partial>srw.T i)"

lemma H_uminus: "H (-i) (-j) = H i j"
  apply (subst srw_T_uminus)
  apply (subst nn_integral_distr)
  using sfirst_translate[of uminus "HLD {-j}" "i ## _"]
  apply (auto simp: HLD_iff[abs_def])
  done

lemma H_add: "H (i + t) (j + t) = H i j"
  apply (subst srw_T_add)
  apply (subst nn_integral_distr)
  using sfirst_translate[of "\<lambda>i. i + t" "HLD {j + t}" "i ## _"]
  apply (auto simp: HLD_iff[abs_def] inj_on_def)
  done

lemma H_split:
  assumes "j \<le> k" "k \<le> i"
  shows "H j i = H j k + H k i"
proof cases
  assume ae: "AE \<omega> in srw.T j. h k (j ## \<omega>) \<noteq> \<infinity>"
  have split_hk:
      "emeasure (srw.T j) (space (srw.T j)) = (\<Sum>n. emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j##\<omega>) = n})"
    using ae
    apply (subst suminf_emeasure)
    apply auto []
    apply (auto simp: disjoint_family_on_def) []
    apply (intro emeasure_eq_AE)
    apply (auto elim: eventually_mono)
    done

  let ?I = "\<lambda>n \<omega>. indicator {\<omega> \<in> space srw.S. h k (j ## \<omega>) = enat n} \<omega> :: ennreal"
  have h_stake: "h k (stake (Suc n) \<omega> @- \<omega>') = enat n \<longleftrightarrow> h k \<omega> = enat n"
    for n \<omega> \<omega>'
    by (induction n arbitrary: \<omega> \<omega>')
       (auto simp: enat_0 sfirst_eq_0 HLD_iff sfirst_Stream eSuc_enat[symmetric])
  have *: "indicator {\<omega> \<in> space srw.S. h k (j ## \<omega>) = enat n} (stake n \<omega> @- \<omega>') = ?I n \<omega>" for n \<omega> \<omega>'
    using h_stake[of n "j ## \<omega>" \<omega>'] by (auto split: split_indicator simp: space_stream_space)
  have **: "(\<integral>\<^sup>+ \<omega>'. ennreal_of_enat (h i (k ## \<omega>')) \<partial>srw.T ((j ## \<omega>) !! n)) * ?I n \<omega> =
    (\<integral>\<^sup>+ \<omega>'. ennreal_of_enat (h i (k ## \<omega>')) \<partial>srw.T k) * ?I n \<omega>" for n \<omega>
    by (auto simp: HLD_iff dest!: sfirst_eq_enatD split: split_indicator)

  have "H j k = \<infinity> * emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j ## \<omega>) = \<infinity>} +
    (\<Sum>n. ennreal n * emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j ## \<omega>) = n})"
    by (subst nn_integral_enat') (auto simp: ennreal_of_nat_eq_real_of_nat)
  moreover have "emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j##\<omega>) = \<infinity>} = 0"
    by (rule AE_iff_measurable[THEN iffD1, OF _ _ ae]) auto
  moreover have "(\<Sum>n. H k i * emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j##\<omega>) = n}) = H k i"
    using split_hk by (subst ennreal_suminf_cmult) (auto simp: )
  ultimately have "H j k + H k i =
      (\<Sum>n. (ennreal n + H k i) * emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j##\<omega>) = n})"
    by (simp add: distrib_right suminf_add[symmetric])
  moreover have "(ennreal n + H k i) * emeasure (srw.T j) {\<omega>\<in>space (srw.T j). h k (j##\<omega>) = n} =
    (\<integral>\<^sup>+\<omega>'. (ennreal n + h i (k ## sdrop n \<omega>')) * ?I n \<omega>' \<partial>srw.T j)" for n
    by (subst srw.nn_integral_T_split[where s=j and n=n])
       (simp_all add: * ** nn_integral_multc nn_integral_add distrib_right sdrop_shift nn_integral_cmult)
  moreover have "(\<integral>\<^sup>+\<omega>. (ennreal n + h i (k ## sdrop n \<omega>)) * ?I n \<omega> \<partial>srw.T j) = (\<integral>\<^sup>+\<omega>. h i (j ## \<omega>) * ?I n \<omega> \<partial>srw.T j)" for n
    apply (intro nn_integral_cong_AE)
    using srw.AE_T_enabled
    apply eventually_elim
  proof (intro ennreal_mult_right_cong refl)
    fix \<omega> assume "srw.enabled j \<omega>" "?I n \<omega> \<noteq> 0"
    then have "srw.enabled j \<omega>" "h k (j ## \<omega>) = enat n" by (auto split: split_indicator_asm)
    with assms(1) have "h i (j ## \<omega>) = enat n + h i (k ## sdrop n \<omega>)"
    proof (induction n arbitrary: \<omega> j)
      case (Suc n) then show ?case
      proof cases
        assume "j \<noteq> k" then show ?case
          using Suc.prems \<open>k \<le> i\<close> Suc.IH[of "shd \<omega>" "stl \<omega>"] srw.enabled_iff[of j \<omega>]
          by (auto simp add: sfirst_eq_eSuc eSuc_enat[symmetric] iadd_Suc)
      qed (simp add: enat_0_iff)
    qed (simp add: sfirst_eq_0 enat_0)
    then show "ennreal (real n) + ennreal_of_enat (h i (k ## sdrop n \<omega>)) = ennreal_of_enat (h i (j ## \<omega>))"
      by (simp add: ennreal_of_enat_add ennreal_of_nat_eq_real_of_nat)
  qed
  ultimately have "H j k + H k i = (\<Sum>n. (\<integral>\<^sup>+\<omega>. h i (j ## \<omega>) * ?I n \<omega> \<partial>srw.T j))"
    by simp
  also have "\<dots> = (\<integral>\<^sup>+\<omega>. h i (j ## \<omega>) * (\<Sum>n. ?I n \<omega>) \<partial>srw.T j)"
    by (simp add: nn_integral_suminf ennreal_suminf_cmult[symmetric] del: ennreal_suminf_cmult)
  also have "\<dots> = (\<integral>\<^sup>+\<omega>. h i (j ## \<omega>) \<partial>srw.T j)"
    apply (rule nn_integral_cong_AE)
    using ae
    apply eventually_elim
    apply (auto simp: suminf_indicator disjoint_family_on_def)
    apply (subst suminf_indicator)
    apply (auto simp add: disjoint_family_on_def space_stream_space split: split_indicator)
    done
  finally show ?thesis
    by simp
next
  assume ae: "\<not> (AE \<omega> in srw.T j. h k (j ## \<omega>) \<noteq> \<infinity>)"
  then have "(\<integral>\<^sup>+\<omega>. h k (j ## \<omega>) \<partial>srw.T j) = \<infinity>"
    using nn_integral_PInf_AE[of "\<lambda>\<omega>. h k (j ## \<omega>)" "srw.T j"] by (auto simp: ennreal_of_enat_eq_top)
  moreover have "(\<integral>\<^sup>+\<omega>. h k (j ## \<omega>) \<partial>srw.T j) \<le> (\<integral>\<^sup>+\<omega>. h i (j ## \<omega>) \<partial>srw.T j)"
    apply (rule nn_integral_mono_AE)
    using srw.AE_T_enabled
  proof (eventually_elim, simp)
    have *: "mono (\<lambda>F \<omega>. if HLD {k} \<omega> then 0 else eSuc (F (stl \<omega>)))"
      by (auto simp: mono_def le_fun_def)
    have **: "\<And>\<omega> j. srw.enabled j \<omega> \<Longrightarrow> j < k \<Longrightarrow> h k \<omega> \<le> h i \<omega>"
      apply (subst sfirst_eq_lfp)
    proof (induction rule: lfp_ordinal_induct[OF *])
      case (1 x \<omega> j)
      from "1.IH"[of "shd \<omega>" "stl \<omega>"] "1.prems" \<open>k \<le> i\<close>
      show ?case
        unfolding srw.enabled_iff[of j \<omega>]
        by (auto simp: eSuc_le_sfirst_iff) (simp_all add: HLD_iff)
    qed (auto intro: SUP_least)

    fix \<omega> show "srw.enabled j \<omega> \<Longrightarrow> h k (j ## \<omega>) \<le> h i (j ## \<omega>)"
      using \<open>j \<le> k\<close> \<open>k \<le> i\<close> by (simp add: sfirst_Stream **)
  qed
  ultimately show ?thesis
    by (simp add: top_unique)
qed

lemma H_eq: "H i j = (lfp (\<lambda>F i. if i = j then 0 else 1 + (F (i + 1) + F (i - 1)) / 2) i)"
proof -
  have cF: "sup_continuous (\<lambda>F i. (if i = j then 0 else 1 + (F (i + 1) + F (i - 1)) / 2)::ennreal)"
    by (intro order_continuous_intros)

  show ?thesis
  proof cases
    assume "i = j" then show ?thesis
      by (subst lfp_unfold[OF sup_continuous_mono[OF cF]])
         (simp add: sfirst_Stream zero_ennreal.rep_eq)
  next
    assume "i \<noteq> j"
    then have "H i j = 1 + lfp (\<lambda>F x. \<integral>\<^sup>+y. (F y + 1) * indicator (-{j}) y \<partial>srw x) i"
      by (simp add: sfirst_Stream nn_integral_add srw.sfirst_lfp)
    also have "\<dots> = (lfp (\<lambda>F x. \<integral>\<^sup>+y. (F y + 1) * indicator (-{j}) y \<partial>srw x) i + 1) * indicator (-{j}) i"
      using \<open>i \<noteq> j\<close> by (simp add: le_fun_def)
    also have "\<dots> = lfp (\<lambda>F x. ((\<integral>\<^sup>+y. F y \<partial>srw x) + 1) * indicator (-{j}) x) i"
      by (subst lfp_rolling[symmetric, where g="\<lambda>F y. (F y + 1) * indicator (-{j}) y"])
         (force simp: mono_def le_fun_def intro!: add_mono nn_integral_mono intro: max.coboundedI1 split: split_indicator)+
    also have "\<dots> = lfp (\<lambda>F i. if i = j then 0 else 1 + (F (i + 1) + F (i - 1)) / 2) i"
      by (intro arg_cong[where f="\<lambda>x. lfp x i"] ext)
         (auto simp: srw_def divide_ennreal_def field_simps)
    finally show ?thesis .
  qed
qed

lemma H_eq_top: assumes "i \<noteq> j" shows "H i j = top"
proof -
  have m_eq: "H i j = (if i = j then 0 else 1 + (H (i + 1) j + H (i - 1) j) / 2)" for i j
    apply (subst srw.nn_integral_T)
    apply simp
    apply (subst srw_def)
    apply (simp add: nn_integral_add divide_ennreal_def[symmetric] add_divide_distrib_ennreal)
    apply (simp add: add_divide_distrib_ennreal[symmetric])
    done
  have m_same[simp]: "H i i = 0" for i
    by (subst m_eq) simp
  have m_uminus[simp]: "H (-i) (-j) = H i j" for i j
    by (rule H_uminus)
  have m_split: "i \<le> k \<Longrightarrow> k \<le> j \<Longrightarrow> H i j = H i k + H k j" for i j k
    using H_split[of i k j] by (simp add: eq_onp_def)
  have m_shift: "H (i + t) (j + t) = H i j" for i j t
    by (rule H_add)

  have m_plus: "H i (i + n) = n * H 0 1" for i :: int and n :: nat
  proof (induction n)
    case 0 then show ?case by simp
  next
    case (Suc n) then show ?case
      using m_split[of i "i + 1" "i + (1 + n)"] m_shift[of 0 i 1] m_shift[of i 1 "i + n"]
      by (simp add: field_simps)
  qed

  { fix i j :: int assume "i < j"
    then obtain n :: nat where j: "j = i + Suc n"
      by (auto simp add: zless_iff_Suc_zadd)
    then have "Suc n * H 0 1 = H i (i + Suc n)"
      unfolding m_plus by simp
    also have "\<dots> = 1 + (H (i + 1) (i + Suc n) + H (i - 1) (i + Suc n)) / 2"
      by (subst m_eq) simp
    also have "\<dots> = 1 + (H i (i + n) + H i (i + int (n + 2))) / 2"
      using m_shift[of i 1 "i + n"] m_shift[of i "-1" "i + n + 2"] by (simp add: field_simps)
    also have "\<dots> = 1 + (2 * of_nat (n + 1) * H 0 1) / 2"
      unfolding m_plus by (simp add: field_simps mult_2)
    also have "\<dots> = 1 + (((n + 1) * H 0 1) * 2) / 2"
      by (simp del: of_nat_add of_nat_Suc add: ac_simps)
    also have "\<dots> = 1 + Suc n * H 0 1"
      by (subst ennreal_mult_divide_eq) auto
    finally have "H 0 1 = top"
      by (cases "H 0 1" rule: ennreal_cases) (auto simp: ennreal_mult_eq_top_iff)
    then have "H i j = top"
      unfolding j m_plus by (simp add: ennreal_mult_eq_top_iff add_eq_0_iff_both_eq_0) }
  note inc = this
  moreover
  have "j < i \<Longrightarrow> H i j = top"
    using inc[of "-i" "-j"] unfolding m_uminus by simp
  ultimately show "H i j = top"
    using \<open>i \<noteq> j\<close> unfolding neq_iff by auto
qed

end

definition random_walk :: "int pgcl"
where
  "random_walk =
    Seq
      (Assign (\<lambda>i. return_pmf 10))
      (While (\<lambda>i. 0 < i)
             (Assign (\<lambda>i. map_pmf (\<lambda>True \<Rightarrow> i + 1 | False \<Rightarrow> i - 1) (bernoulli_pmf (1/2)))))"

lemma ert_random_walk:
  "ert random_walk 0 i = 1 + lfp (\<lambda>F i. 1 + (if 0 < i then 1 + (F (i + 1) + F (i - 1)) / 2 else 0)) (10::int)"
  by (auto simp: random_walk_def divide_ennreal_def distrib_left ac_simps fun_eq_iff
           intro!: arg_cong2[where f=lfp])

lemma ert_random_walk_top:
  "ert random_walk 0 i = top"
proof -
  have F: "mono (\<lambda>F i. (if i = 0 then 0 else 1 + (F (i + 1) + F (i - 1)) / 2)::ennreal)"
    by (auto simp: mono_def le_fun_def add_mono divide_ennreal_def mult_mono)
  have F': "mono (\<lambda>F i. 1 + (if 0 < i then 1 + (F (i + 1) + F (i - 1)) / 2 else 0)::ennreal)"
    by (auto simp: mono_def le_fun_def add_mono divide_ennreal_def mult_mono)
  have "\<And>i. 0 \<le> i \<Longrightarrow>
    lfp (\<lambda>F (i::int). (if i = 0 then 0 else 1 + (F (i + 1) + F (i - 1)) / 2)::ennreal) i \<le>
    lfp (\<lambda>F (i::int). 1 + (if 0 < i then 1 + (F (i + 1) + F (i - 1)) / 2 else 0)) i"
    apply (induction rule: lfp_ordinal_induct[OF F])
    apply (auto intro: SUP_least)
    apply (subst lfp_unfold[OF F'])
    apply (auto intro!: add_increasing[where a=1] add_mono mult_mono simp: divide_ennreal_def)
    done
  from this[of 10] H_eq_top[of 10 0] show ?thesis
    unfolding ert_random_walk H_eq by (simp add: top_unique)
qed

end


(** Score: 8/10
  Unfortunately, left a sorry in a quite straightforward case ...

**)
theory GabrielaLimonta
imports Main "~~/src/HOL/IMP/Big_Step"
begin

fun exec :: "com \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> state option" where
  "exec _ s 0 = None"
| "exec SKIP s (Suc f) = Some s"
| "exec (x::=v) s (Suc f) = Some (s(x:=aval v s))"
| "exec (c1;;c2) s (Suc f) = (
    case (exec c1 s f) of None \<Rightarrow> None | Some s' \<Rightarrow> exec c2 s' f)"
| "exec (IF b THEN c1 ELSE c2) s (Suc f) =
    (if bval b s then exec c1 s f else exec c2 s f)"
| "exec (WHILE b DO c) s (Suc f) = (
    if bval b s then
      (case (exec c s f) of
        None \<Rightarrow> None |
        Some s' \<Rightarrow> exec (WHILE b DO c) s' f)
    else Some s)"

text {* The two directions are proved separately. The proof of the first
  direction should be quite straightforward, and is left to you. *}
lemma exec_imp_bigstep: "exec c s f = Some s' \<Longrightarrow> (c,s) \<Rightarrow> s'"
proof (induction arbitrary: s' rule: exec.induct[case_names None SKIP ASS SEMI IF WHILE])
print_cases
case (None uu sa)
  from this have False by auto
  thus ?case by blast
next
case (SKIP sa f)
  from this have "sa = s'" by auto
  thus ?case using `sa = s'` by auto
next
case (ASS x v sa f)
  from this have "s' = sa(x := aval v sa)" by auto
  thus ?case by blast
next
case (SEMI c1 c2 sa f)
  thus ?case by (auto split: option.split_asm)
next
case (IF b c1 c2 sa f)
  thus ?case by (metis IfFalse IfTrue exec.simps(5))
next
case (WHILE b c sa f)
  thus ?case
  (** Why give up on such a simple proof?
    When applying auto, you find unsplit if and unsplit option-case.
    So just add the split-rules ... and you are done!
  **)
  by (auto split: split_if_asm option.splits)
  (**sorry**)
qed

lemma exec_mono: "exec c s f = Some s' \<Longrightarrow> exec c s (f+k) = Some s'"
proof (induction c s f arbitrary: s'
    rule: exec.induct[case_names None SKIP ASS SEMI IF WHILE])
print_cases
case (None uu s s')
  from this have False by simp
  thus ?case by blast
next
case (SKIP s f s')
  from this have "s' = s" by simp
  thus ?case by auto
next
case (ASS x v s f s')
  from this have "s' = s(x := aval v s)" by simp
  thus ?case by auto
next
case (SEMI c1 c2 s f)
  thus ?case by (auto split: option.split option.split_asm)
next
case (IF b c1 c2 s f s')
  thus ?case by auto
next
case (WHILE b c s i s')
  thus ?case by (auto split: option.split_asm)
qed

lemma bigstep_imp_si:
  "(c,s) \<Rightarrow> s' \<Longrightarrow> \<exists>k. exec c s k = Some s'"
proof (induct rule: big_step_induct)
print_cases
  case (Skip s) have "exec SKIP s 1 = Some s" by auto
  thus ?case by blast
next
  case (WhileTrue b s1 c s2 s3)
  then obtain f1 f2 where "exec c s1 f1 = Some s2"
    and "exec (WHILE b DO c) s2 f2 = Some s3" by auto
  with exec_mono[of c s1 f1 s2 f2]
    exec_mono[of "WHILE b DO c" s2 f2 s3 f1] have
    "exec c s1 (f1+f2) = Some s2"
    and "exec (WHILE b DO c) s2 (f2+f1) = Some s3"
    by auto
  hence "exec (WHILE b DO c) s1 (Suc (f1+f2)) = Some s3"
    using `bval b s1` by (auto simp add: add_ac)
  thus ?case by blast
next
  case (Seq c1 s1 s2 c2 s3)
  then obtain f1 f2 where "exec c1 s1 f1 = Some s2" and "exec c2 s2 f2 = Some s3"
    by auto
  with exec_mono[of c1 s1 f1 s2 f2]
    exec_mono[of c2 s2 f2 s3 f1]
  have
    "exec c1 s1 (f1+f2) = Some s2" and "exec c2 s2 (f2+f1) = Some s3"
    by auto
  hence "exec (c1;;c2) s1 (Suc (f1+f2)) = Some s3" by (auto simp add: add_ac)
  thus ?case by blast
next
  case (Assign x a s)
  have "exec (x::=a) s (Suc 0) = Some (s(x := aval a s))" by auto
  thus ?case by blast
next
  case (IfTrue b s c1 t c2)
  then obtain f where "exec c1 s f = Some t" by auto
  from this and `bval b s` and `(c1, s) \<Rightarrow> t`
  have "exec (IF b THEN c1 ELSE c2) s (Suc f) = Some t" by auto
  thus ?case by blast
next
  case (IfFalse b s c2 t c1)
  then obtain f where "exec c2 s f = Some t" by auto
  from this and `\<not>bval b s` and `(c2, s) \<Rightarrow> t`
  have "exec (IF b THEN c1 ELSE c2) s (Suc f) = Some t" by auto
  thus ?case by blast
next
  case (WhileFalse b s c)
  from this have "exec (WHILE b DO c) s (Suc 0) = Some s" by auto
  thus ?case by blast
qed

text {* Finally, prove the main theorem of the homework: *}
theorem exec_equiv_bigstep: "(\<exists>k. exec c s k = Some s') \<longleftrightarrow> (c,s) \<Rightarrow> s'"
  proof
  assume "\<exists>k. exec c s k = Some s'"
  then obtain f where "exec c s f = Some s'" by auto
  thus "(c,s) \<Rightarrow> s'" using exec_imp_bigstep[of c s f] by auto
next
  assume "(c,s) \<Rightarrow> s'"
  then show "\<exists>k. exec c s k = Some s'" using bigstep_imp_si[of c s s'] by auto
qed

end


section {*  Section 10.4 *}

theory Ex1
imports "../LCF"
begin

axiomatization
  P     :: "'a \<Rightarrow> tr" and
  G     :: "'a \<Rightarrow> 'a" and
  H     :: "'a \<Rightarrow> 'a" and
  K     :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
where
  P_strict:     "P(UU) = UU" and
  K:            "K = (\<lambda>h x. P(x) \<Rightarrow> x | h(h(G(x))))" and
  H:            "H = FIX(K)"

declare P_strict [simp] K [simp]

lemma H_unfold: "H = K(H)"
  apply (simplesubst H)
  apply (rule FIX_eq [symmetric])
  done

lemma H_strict [simp]: "H(UU)=UU"
  apply (simplesubst H_unfold)
  apply simp
  done

lemma H_idemp_lemma: "\<forall>x. H(FIX(K,x)) = FIX(K,x)"
  apply (induct K)
  apply simp
  apply (simp split: COND_cases_iff)
  apply (intro strip)
  apply (subst H_unfold)
  apply simp
  done

lemma H_idemp: "\<forall>x. H(H(x)) = H(x)"
  apply (rule H_idemp_lemma [folded H])
  done

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_list_concat_map_bind
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) y2 = y2"
| "x (cons2 z2 xs) y2 = cons2 z2 (x xs y2)"

fun y :: "'a list => ('a => 'b list) => 'b list" where
"y (nil2) y2 = nil2"
| "y (cons2 z2 xs) y2 = x (y2 z2) (y xs y2)"

fun map :: "('a => 'b) => 'a list => 'b list" where
"map f (nil2) = nil2"
| "map f (cons2 y2 xs) = cons2 (f y2) (map f xs)"

fun concat :: "('a list) list => 'a list" where
"concat (nil2) = nil2"
| "concat (cons2 y2 xs) = x y2 (concat xs)"

theorem property0 :
  "((concat (map f xs)) = (y xs f))"
  oops

end


(*  Title:       Verification and refinement of hybrid systems in the relational KAT
    Author:      Jonathan Julián Huerta y Munive, 2020
    Maintainer:  Jonathan Julián Huerta y Munive <jonjulian23@gmail.com>
*)

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

text \<open> We use our relational model to obtain verification and refinement components for hybrid
programs. We devise three methods for reasoning with evolution commands and their continuous
dynamics: providing flows, solutions or invariants. \<close>

theory HS_VC_KAT_rel
  imports
    "../HS_ODEs"
    "HS_VC_KAT"
    "../HS_VC_KA_rel"

begin

interpretation rel_tests: test_semiring "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" "\<lambda>x. Id \<inter> ( - x)"
  by (standard, auto)

interpretation rel_kat: kat "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl "\<lambda>x. Id \<inter> ( - x)"
  by (unfold_locales)

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_kat.Hoare P X Q}"

interpretation rel_rkat: rkat "(\<union>)" "(O)" Id "{}" "(\<subseteq>)" "(\<subset>)" rtrancl "(\<lambda>X. Id \<inter> - X)" rel_R
  by (standard, auto simp: rel_R_def rel_kat.Hoare_def)

subsubsection \<open> Regular programs\<close>

text \<open> Lemmas for manipulation of predicates in the relational model \<close>

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

notation Id ("skip")
     and empty ("abort")
     and relcomp (infixr ";" 75)

no_notation Archimedean_Field.ceiling ("\<lceil>_\<rceil>")
        and Archimedean_Field.floor_ceiling_class.floor ("\<lfloor>_\<rfloor>")
        and tau ("\<tau>")
        and n_op ("n _" [90] 91)

definition p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> = {(s,s) |s. P s}"

lemma p2r_simps[simp]:
  "\<lceil>P\<rceil> \<le> \<lceil>Q\<rceil> = (\<forall>s. P s \<longrightarrow> Q s)"
  "(\<lceil>P\<rceil> = \<lceil>Q\<rceil>) = (\<forall>s. P s = Q s)"
  "(\<lceil>P\<rceil> ; \<lceil>Q\<rceil>) = \<lceil>\<lambda> s. P s \<and> Q s\<rceil>"
  "(\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil>) = \<lceil>\<lambda> s. P s \<or> Q s\<rceil>"
  "rel_tests.t \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  "(- Id) \<union> \<lceil>P\<rceil> = - \<lceil>\<lambda>s. \<not> P s\<rceil>"
  "Id \<inter> (- \<lceil>P\<rceil>) = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  unfolding p2r_def by auto

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

lemma RdL_is_rRKAT: "(\<forall>x. {(x,x)}; R1 \<subseteq> {(x,x)}; R2) = (R1 \<subseteq> R2)"
  by auto (* Refinement in dL is that of rKAT *)

\<comment> \<open> Hoare Triples \<close>

abbreviation relHoare ("\<^bold>{_\<^bold>}_\<^bold>{_\<^bold>}")
  where "\<^bold>{P\<^bold>}X\<^bold>{Q\<^bold>} \<equiv> rel_kat.Hoare \<lceil>P\<rceil> X \<lceil>Q\<rceil>"

lemma rel_kat_H: "\<^bold>{P\<^bold>} X \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<forall>s s'. P s \<longrightarrow> (s,s') \<in> X \<longrightarrow> Q s')"
  by (simp add: rel_kat.Hoare_def, auto simp add: p2r_def)

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

lemma sH_skip[simp]: "\<^bold>{P\<^bold>} skip \<^bold>{Q\<^bold>} \<longleftrightarrow> \<lceil>P\<rceil> \<le> \<lceil>Q\<rceil>"
  unfolding rel_kat_H by simp

lemma H_skip: "\<^bold>{P\<^bold>} skip \<^bold>{P\<^bold>}"
  by simp

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

lemma sH_test[simp]: "\<^bold>{P\<^bold>} \<lceil>R\<rceil> \<^bold>{Q\<^bold>} = (\<forall>s. P s \<longrightarrow> R s \<longrightarrow> Q s)"
  by (subst rel_kat_H, simp add: p2r_def)

\<comment> \<open> Abort \<close>

lemma sH_abort[simp]: "\<^bold>{P\<^bold>} abort \<^bold>{Q\<^bold>} \<longleftrightarrow> True"
  unfolding rel_kat_H by simp

lemma H_abort: "\<^bold>{P\<^bold>} abort \<^bold>{Q\<^bold>}"
  by simp

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

definition assign :: "'b \<Rightarrow> ('a^'b \<Rightarrow> 'a) \<Rightarrow> ('a^'b) rel" ("(2_ ::= _)" [70, 65] 61)
  where "(x ::= e) \<equiv> {(s, vec_upd s x (e s))| s. True}"

lemma sH_assign[simp]: "\<^bold>{P\<^bold>} (x ::= e) \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> Q (\<chi> j. ((($) s)(x := (e s))) j))"
  unfolding rel_kat_H vec_upd_def assign_def by (auto simp: fun_upd_def)

lemma H_assign: "P = (\<lambda>s. Q (\<chi> j. ((($) s)(x := (e s))) j)) \<Longrightarrow> \<^bold>{P\<^bold>} (x ::= e) \<^bold>{Q\<^bold>}"
  by simp

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

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

lemma sH_nondet_assign[simp]:
  "\<^bold>{P\<^bold>} (x ::= ?) \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<forall>s. P s \<longrightarrow> (\<forall>k. Q (\<chi> j. ((($) s)(x := k)) j)))"
  unfolding rel_kat_H vec_upd_def nondet_assign_def by (auto simp: fun_upd_def)

lemma H_nondet_assign: "\<^bold>{\<lambda>s. \<forall>k. P (\<chi> j. ((($) s)(x := k)) j)\<^bold>} (x ::= ?) \<^bold>{P\<^bold>}"
  by simp

\<comment> \<open> Sequential Composition \<close>

lemma H_seq: "\<^bold>{P\<^bold>} X \<^bold>{R\<^bold>} \<Longrightarrow> \<^bold>{R\<^bold>} Y \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} X;Y \<^bold>{Q\<^bold>}"
  using rel_kat.H_seq .

lemma sH_seq: "\<^bold>{P\<^bold>} X;Y \<^bold>{Q\<^bold>} = \<^bold>{P\<^bold>} X \<^bold>{\<lambda>s. \<forall>s'. (s, s') \<in> Y \<longrightarrow> Q s'\<^bold>}"
  unfolding rel_kat_H by auto

lemma H_assignl:
  assumes "\<^bold>{K\<^bold>} X \<^bold>{Q\<^bold>}"
    and "\<forall>s. P s \<longrightarrow> K (vec_lambda ((($) s)(x := e s)))"
  shows "\<^bold>{P\<^bold>} (x ::= e);X \<^bold>{Q\<^bold>}"
  apply(rule H_seq, subst sH_assign)
  using assms by auto

\<comment> \<open> Nondeterministic Choice \<close>

lemma sH_choice: "\<^bold>{P\<^bold>} X \<union> Y \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<^bold>{P\<^bold>} X \<^bold>{Q\<^bold>} \<and> \<^bold>{P\<^bold>} Y \<^bold>{Q\<^bold>})"
  unfolding rel_kat_H by auto

lemma H_choice: "\<^bold>{P\<^bold>} X \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} Y \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} X \<union> Y \<^bold>{Q\<^bold>}"
  using rel_kat.H_choice .

\<comment> \<open> Conditional Statement \<close>

abbreviation cond_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel"
  ("IF _ THEN _ ELSE _" [64,64] 63)
  where "IF B THEN X ELSE Y \<equiv> rel_kat.kat_cond \<lceil>B\<rceil> X Y"

lemma sH_cond[simp]:
  "\<^bold>{P\<^bold>} (IF B THEN X ELSE Y) \<^bold>{Q\<^bold>} \<longleftrightarrow> (\<^bold>{\<lambda>s. P s \<and> B s\<^bold>} X \<^bold>{Q\<^bold>} \<and> \<^bold>{\<lambda>s. P s \<and> \<not> B s\<^bold>} Y \<^bold>{Q\<^bold>})"
  by (auto simp: rel_kat.H_cond_iff rel_kat_H)

lemma H_cond:
  "\<^bold>{\<lambda>s. P s \<and> B s\<^bold>} X \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{\<lambda>s. P s \<and> \<not> B s\<^bold>} Y \<^bold>{Q\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} (IF B THEN X ELSE Y) \<^bold>{Q\<^bold>}"
  by simp

\<comment> \<open> While Loop \<close>

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel"
  ("WHILE _ INV _ DO _" [64,64,64] 63)
  where "WHILE B INV I DO X \<equiv> rel_kat.kat_while_inv \<lceil>B\<rceil> \<lceil>I\<rceil> X"

lemma sH_whileI: "\<forall>s. P s \<longrightarrow> I s \<Longrightarrow> \<forall>s. I s \<and> \<not> B s \<longrightarrow> Q s \<Longrightarrow> \<^bold>{\<lambda>s. I s \<and> B s\<^bold>} X \<^bold>{I\<^bold>}
  \<Longrightarrow> \<^bold>{P\<^bold>} (WHILE B INV I DO X) \<^bold>{Q\<^bold>}"
  by (rule rel_kat.H_while_inv, auto simp: p2r_def rel_kat.Hoare_def, fastforce)

lemma "\<^bold>{\<lambda>s. P s \<and> B s\<^bold>} X \<^bold>{\<lambda>s. P s\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} (WHILE B INV I DO X) \<^bold>{\<lambda>s. P s \<and> \<not> B s\<^bold>}"
  using rel_kat.H_while[of "\<lceil>P\<rceil>" "\<lceil>B\<rceil>" X]
  unfolding rel_kat.kat_while_inv_def by auto

\<comment> \<open> Finite Iteration \<close>

abbreviation loopi_sugar :: "'a rel \<Rightarrow> 'a pred \<Rightarrow> 'a rel" ("LOOP _ INV _ " [64,64] 63)
  where "LOOP X INV I \<equiv> rel_kat.kat_loop_inv X \<lceil>I\<rceil>"

lemma H_loop: "\<^bold>{P\<^bold>} X \<^bold>{P\<^bold>} \<Longrightarrow> \<^bold>{P\<^bold>} (LOOP X INV I) \<^bold>{P\<^bold>}"
  by (auto intro: rel_kat.H_loop)

lemma H_loopI: "\<^bold>{I\<^bold>} X \<^bold>{I\<^bold>} \<Longrightarrow> \<lceil>P\<rceil> \<subseteq> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<subseteq> \<lceil>Q\<rceil> \<Longrightarrow> \<^bold>{P\<^bold>} (LOOP X INV I) \<^bold>{Q\<^bold>}"
  using rel_kat.H_loop_inv[of "\<lceil>P\<rceil>" "\<lceil>I\<rceil>" X "\<lceil>Q\<rceil>"] by auto

subsubsection \<open> Evolution commands \<close>

\<comment> \<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 rel" ("EVOL")
  where "EVOL \<phi> G U = {(s,s') |s s'. s' \<in> g_orbit (\<lambda>t. \<phi> t s) G (U s)}"

lemma sH_g_evol[simp]:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "\<^bold>{P\<^bold>} (EVOL \<phi> G U) \<^bold>{Q\<^bold>} = (\<forall>s. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  unfolding rel_kat_H g_evol_def g_orbit_eq by auto

lemma H_g_evol:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  assumes "P = (\<lambda>s. (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  shows "\<^bold>{P\<^bold>} (EVOL \<phi> G U) \<^bold>{Q\<^bold>}"
  by (simp add: assms)

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

definition g_ode :: "(real \<Rightarrow> ('a::banach)\<Rightarrow>'a) \<Rightarrow> 'a pred \<Rightarrow> ('a \<Rightarrow> real set) \<Rightarrow> 'a set \<Rightarrow> real \<Rightarrow>
  'a rel" ("(1x\<acute>=_ & _ on _ _ @ _)")
  where "(x\<acute>= f & G on T S @ t\<^sub>0) = {(s,s') |s s'. s' \<in> g_orbital f G T S t\<^sub>0 s}"

lemma H_g_orbital:
  "P = (\<lambda>s. (\<forall>X\<in>ivp_sols f U S t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> Q (X t))) \<Longrightarrow>
  \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  unfolding rel_kat_H g_ode_def g_orbital_eq by clarsimp

lemma sH_g_orbital: "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>} =
  (\<forall>s. P s \<longrightarrow> (\<forall>X\<in>ivp_sols f U S t\<^sub>0 s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (X \<tau>)) \<longrightarrow> Q (X t)))"
  unfolding g_orbital_eq g_ode_def rel_kat_H by auto

context local_flow
begin

lemma sH_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 "\<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<^bold>{Q\<^bold>} =
  (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
proof(unfold sH_g_orbital, clarsimp, safe)
  fix s t
  assume hyps: "s \<in> S" "P s" "t \<in> U s" "\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (\<phi> \<tau> s)"
    and main: "\<forall>s. P s \<longrightarrow> (\<forall>X\<in>Sols (\<lambda>t. f) U S 0 s. \<forall>t\<in>U s. (\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)) \<longrightarrow> Q (X t))"
  hence "(\<lambda>t. \<phi> t s) \<in> Sols (\<lambda>t. f) U S 0 s"
    using in_ivp_sols assms by blast
  thus "Q (\<phi> t s)"
    using main hyps by fastforce
next
  fix s X t
  assume hyps: "P s" "X \<in> Sols (\<lambda>t. f) U S 0 s" "t \<in> U s"  "\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (X \<tau>)"
    and main: "\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>. \<tau> \<in> U s \<and> \<tau> \<le> t \<longrightarrow> G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  hence obs: "s \<in> S"
    using ivp_sols_def[of "\<lambda>t. f"] init_time by auto
  hence "\<forall>\<tau>\<in>down (U s) t. X \<tau> = \<phi> \<tau> s"
    using eq_solution hyps assms by blast
  thus "Q (X t)"
    using hyps main obs by auto
qed

lemma H_g_ode_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
    and "P = (\<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)))"
  shows "\<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<^bold>{Q\<^bold>}"
  using assms apply(subst sH_g_ode_subset[OF assms(1)])
  unfolding assms by auto

lemma sH_g_ode: "\<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<^bold>{Q\<^bold>} =
  (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  by (subst sH_g_ode_subset, auto simp: init_time interval_time)

lemma sH_g_ode_ivl: "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> \<^bold>{P\<^bold>} (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {0..t}) S @ 0) \<^bold>{Q\<^bold>} =
  (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)))"
  apply(subst sH_g_ode_subset; clarsimp, (force)?)
  using init_time interval_time mem_is_interval_1_I by blast

lemma sH_orbit: "\<^bold>{P\<^bold>} ({(s,s') | s s'. s' \<in> \<gamma>\<^sup>\<phi> s}) \<^bold>{Q\<^bold>} = (\<forall>s \<in> S. P s \<longrightarrow> (\<forall> t \<in> T. Q (\<phi> t s)))"
  using sH_g_ode unfolding orbit_def g_ode_def by auto

end

\<comment> \<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 rel" ("(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 sH_g_orbital_guard:
  assumes "R = (\<lambda>s. G s \<and> Q s)"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>} = \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{R\<^bold>}"
  using assms unfolding g_orbital_eq rel_kat_H ivp_sols_def g_ode_def by auto

lemma sH_g_orbital_inv:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "\<^bold>{I\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{I\<^bold>}" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows " \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  using assms(1) apply(rule_tac p'="\<lceil>I\<rceil>" in rel_kat.H_consl, simp)
  using assms(3) apply(rule_tac q'="\<lceil>I\<rceil>" in rel_kat.H_consr, simp)
  using assms(2) by simp

lemma sH_diff_inv[simp]: "\<^bold>{I\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{I\<^bold>} = diff_invariant I f U S t\<^sub>0 G"
  unfolding diff_invariant_eq rel_kat_H g_orbital_eq g_ode_def by auto

lemma H_g_ode_inv: "\<^bold>{I\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{I\<^bold>} \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow>
  \<lceil>\<lambda>s. I s \<and> G s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> \<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0 DINV I) \<^bold>{Q\<^bold>}"
  unfolding g_ode_inv_def apply(rule_tac q'="\<lceil>\<lambda>s. I s \<and> G s\<rceil>" in rel_kat.H_consr, simp)
  apply(subst sH_g_orbital_guard[symmetric], force)
  by (rule_tac I="I" in sH_g_orbital_inv, simp_all)

subsection \<open> Refinement Components \<close>

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

lemma R_skip: "(\<forall>s. P s \<longrightarrow> Q s) \<Longrightarrow> skip \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule rel_rkat.R2, simp)

\<comment> \<open> Abort \<close>

lemma R_abort: "abort \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule rel_rkat.R2, simp)

\<comment> \<open> Sequential Composition \<close>

lemma R_seq: "(rel_R \<lceil>P\<rceil> \<lceil>R\<rceil>) ; (rel_R \<lceil>R\<rceil> \<lceil>Q\<rceil>) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using rel_rkat.R_seq by blast

lemma R_seq_law: "X \<le> rel_R \<lceil>P\<rceil> \<lceil>R\<rceil> \<Longrightarrow> Y \<le> rel_R \<lceil>R\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> X; Y \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding rel_rkat.spec_def by (rule H_seq)

lemmas R_seq_mono = relcomp_mono

\<comment> \<open> Nondeterministic Choice \<close>

lemma R_choice: "(rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>) \<union> (rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using rel_rkat.R_choice[of "\<lceil>P\<rceil>" "\<lceil>Q\<rceil>"] .

lemma R_choice_law: "X \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> Y \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> X \<union> Y \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using le_supI .

lemma R_choice_mono: "P' \<subseteq> P \<Longrightarrow> Q' \<subseteq> Q \<Longrightarrow> P' \<union> Q' \<subseteq> P \<union> Q"
  using Un_mono .

\<comment> \<open> Assignment \<close>

lemma R_assign: "(x ::= e) \<le> rel_R \<lceil>\<lambda>s. P (\<chi> j. ((($) s)(x := e s)) j)\<rceil> \<lceil>P\<rceil>"
  unfolding rel_rkat.spec_def by (rule H_assign, clarsimp simp: fun_upd_def)

lemma R_assign_law:
  "(\<forall>s. P s \<longrightarrow> Q (\<chi> j. ((($) s)(x := (e s))) j)) \<Longrightarrow> (x ::= e) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_assign[symmetric] by (rule rel_rkat.R2)

lemma R_assignl: "P = (\<lambda>s. R (\<chi> j. ((($) s)(x := e s)) j)) \<Longrightarrow>
  (x ::= e) ; rel_R \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law)
  by (rule_tac R_assign_law, simp_all)

lemma R_assignr: "R = (\<lambda>s. Q (\<chi> j. ((($) s)(x := e s)) j)) \<Longrightarrow>
  rel_R \<lceil>P\<rceil> \<lceil>R\<rceil>; (x ::= e) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law, simp)
  by (rule_tac R_assign_law, simp)

lemma "(x ::= e) ; rel_R \<lceil>Q\<rceil> \<lceil>Q\<rceil> \<le> rel_R \<lceil>(\<lambda>s. Q (\<chi> j. ((($) s)(x := e s)) j))\<rceil> \<lceil>Q\<rceil>"
  by (rule R_assignl) simp

lemma "rel_R \<lceil>Q\<rceil> \<lceil>(\<lambda>s. Q (\<chi> j. ((($) s)(x := e s)) j))\<rceil>; (x ::= e) \<le> rel_R \<lceil>Q\<rceil> \<lceil>Q\<rceil>"
  by (rule R_assignr) simp

\<comment> \<open> Nondeterministic Assignment \<close>

lemma R_nondet_assign: "(x ::= ?) \<le> rel_R \<lceil>\<lambda>s. \<forall>k. P (\<chi> j. ((($) s)(x := k)) j)\<rceil> \<lceil>P\<rceil>"
  unfolding rel_rkat.spec_def by (rule H_nondet_assign)

lemma R_nondet_assign_law:
  "(\<forall>s. P s \<longrightarrow> (\<forall>k. Q (\<chi> j. ((($) s)(x := k)) j))) \<Longrightarrow> (x ::= ?) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_nondet_assign[symmetric] by (rule rel_rkat.R2)

\<comment> \<open> Conditional Statement \<close>

lemma R_cond:
  "(IF B THEN rel_R \<lceil>\<lambda>s. B s \<and> P s\<rceil> \<lceil>Q\<rceil> ELSE rel_R \<lceil>\<lambda>s. \<not> B s \<and> P s\<rceil> \<lceil>Q\<rceil>) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  using rel_rkat.R_cond[of "\<lceil>B\<rceil>" "\<lceil>P\<rceil>" "\<lceil>Q\<rceil>"] by simp

lemma R_cond_mono: "X \<le> X' \<Longrightarrow> Y \<le> Y' \<Longrightarrow> (IF P THEN X ELSE Y) \<le> IF P THEN X' ELSE Y'"
  by (auto simp: rel_kat.kat_cond_def)

lemma R_cond_law: "X \<le> rel_R \<lceil>\<lambda>s. B s \<and> P s\<rceil> \<lceil>Q\<rceil> \<Longrightarrow> Y \<le> rel_R \<lceil>\<lambda>s. \<not> B s \<and> P s\<rceil> \<lceil>Q\<rceil> \<Longrightarrow>
  (IF B THEN X ELSE Y) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule order_trans; (rule R_cond_mono)?, (rule R_cond)?) auto

\<comment> \<open> While Loop \<close>

lemma R_while: "K = (\<lambda>s. P s \<and> \<not> B s) \<Longrightarrow>
  WHILE B INV I DO (rel_R \<lceil>\<lambda>s. P s \<and> B s\<rceil> \<lceil>P\<rceil>) \<le> rel_R \<lceil>P\<rceil> \<lceil>K\<rceil>"
  unfolding rel_kat.kat_while_inv_def using rel_rkat.R_while[of "\<lceil>B\<rceil>" "\<lceil>P\<rceil>"] by simp

lemma R_whileI:
  "X \<le> rel_R \<lceil>I\<rceil> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>\<lambda>s. I s \<and> B s\<rceil> \<Longrightarrow> \<lceil>\<lambda>s. I s \<and> \<not> B s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow>
  WHILE B INV I DO X \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule rel_rkat.R2, rule rel_kat.H_while_inv, auto simp: rel_kat_H rel_rkat.spec_def)

lemma R_while_mono: "X \<le> X' \<Longrightarrow> (WHILE P INV I DO X) \<subseteq> WHILE P INV I DO X'"
  by (simp add: rel_dioid.mult_isol rel_dioid.mult_isor rel_ka.conway.dagger_iso
      rel_kat.kat_while_def rel_kat.kat_while_inv_def)

lemma R_while_law: "X \<le> rel_R \<lceil>\<lambda>s. P s \<and> B s\<rceil> \<lceil>P\<rceil> \<Longrightarrow> Q = (\<lambda>s. P s \<and> \<not> B s) \<Longrightarrow>
  (WHILE B INV I DO X) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule order_trans; (rule R_while_mono)?, (rule R_while)?)

\<comment> \<open> Finite Iteration \<close>

lemma R_loop:"LOOP rel_R \<lceil>P\<rceil> \<lceil>P\<rceil> INV I \<le> rel_R \<lceil>P\<rceil> \<lceil>P\<rceil>"
  using rel_rkat.R_loop .

lemma R_loopI:
  "X \<le> rel_R \<lceil>I\<rceil> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>I\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow> LOOP X INV I \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding rel_rkat.spec_def using H_loopI by blast

lemma R_loop_mono: "X \<le> X' \<Longrightarrow> LOOP X INV I \<subseteq> LOOP X' INV I"
  unfolding rel_kat.kat_loop_inv_def by (simp add: rel_ka.star_iso)

\<comment> \<open> Evolution command (flow) \<close>

lemma R_g_evol:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "(EVOL \<phi> G U) \<le> rel_R \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> P (\<phi> t s)\<rceil> \<lceil>P\<rceil>"
  unfolding rel_rkat.spec_def by (rule H_g_evol, simp)

lemma R_g_evol_law:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "(\<forall>s. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow> (EVOL \<phi> G U) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_g_evol[symmetric] rel_rkat.spec_def .

lemma R_g_evoll:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "P = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> R (\<phi> t s)) \<Longrightarrow>
  (EVOL \<phi> G U) ; rel_R \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law)
  by (rule_tac R_g_evol_law, simp_all)

lemma R_g_evolr:
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "R = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)) \<Longrightarrow>
  rel_R \<lceil>P\<rceil> \<lceil>R\<rceil>; (EVOL \<phi> G U) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply(rule_tac R=R in R_seq_law, simp)
  by (rule_tac R_g_evol_law, simp)

lemma
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "EVOL \<phi> G U ; rel_R \<lceil>Q\<rceil> \<lceil>Q\<rceil> \<le> rel_R \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_evoll) simp

lemma
  fixes \<phi> :: "('a::preorder) \<Rightarrow> 'b \<Rightarrow> 'b"
  shows "rel_R \<lceil>Q\<rceil> \<lceil>\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)\<rceil>; EVOL \<phi> G U \<le> rel_R \<lceil>Q\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_evolr) simp

\<comment> \<open> Evolution command (ode) \<close>

context local_flow
begin

lemma R_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) \<le>
  rel_R \<lceil>\<lambda>s. s\<in>S \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> P (\<phi> t s))\<rceil> \<lceil>P\<rceil>"
  unfolding rel_rkat.spec_def by (rule H_g_ode_subset[OF assms], simp_all)

lemma R_g_ode_rule_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
  shows "(\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule rel_rkat.R2, subst sH_g_ode_subset[OF assms], auto)

lemma R_g_odel_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
    and "P = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> R (\<phi> t s))"
  shows "(x\<acute>= (\<lambda>t. f) & G on U S @ 0) ; rel_R \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (rule_tac R=R in R_seq_law, rule_tac R_g_ode_rule_subset)
  by (simp_all add: assms)

lemma R_g_oder_subset:
  assumes "\<And>s. s \<in> S \<Longrightarrow> 0 \<in> U s \<and> is_interval (U s) \<and> U s \<subseteq> T"
    and "R = (\<lambda>s. \<forall>t\<in>U s. (\<forall>\<tau>\<in>down (U s) t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))"
  shows "rel_R \<lceil>P\<rceil> \<lceil>R\<rceil>; (x\<acute>= (\<lambda>t. f) & G on U S @ 0) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  apply (rule_tac R=R in R_seq_law, simp)
  by (rule_tac R_g_ode_rule_subset, simp_all add: assms)

lemma R_g_ode: "(x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<le>
  rel_R \<lceil>\<lambda>s. s\<in>S \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> P (\<phi> t s))\<rceil> \<lceil>P\<rceil>"
  by (rule R_g_ode_subset, auto simp: init_time interval_time)

lemma R_g_ode_law: "(\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_g_ode[symmetric] by (rule rel_rkat.R2)

lemma R_g_odel: "P = (\<lambda>s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> R (\<phi> t s)) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) ; rel_R \<lceil>R\<rceil> \<lceil>Q\<rceil> \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_odel_subset, auto simp: init_time interval_time)

lemma R_g_oder: "R = (\<lambda>s. \<forall>t\<in>T. (\<forall>\<tau>\<in>down T t. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s)) \<Longrightarrow>
  rel_R \<lceil>P\<rceil> \<lceil>R\<rceil>; (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. T) S @ 0) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (rule R_g_oder_subset, auto simp: init_time interval_time)

lemma R_g_ode_ivl:
  "t \<ge> 0 \<Longrightarrow> t \<in> T \<Longrightarrow> (\<forall>s\<in>S. P s \<longrightarrow> (\<forall>t\<in>{0..t}. (\<forall>\<tau>\<in>{0..t}. G (\<phi> \<tau> s)) \<longrightarrow> Q (\<phi> t s))) \<Longrightarrow>
  (x\<acute>= (\<lambda>t. f) & G on (\<lambda>s. {0..t}) S @ 0) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding sH_g_ode_ivl[symmetric] by (rule rel_rkat.R2)

end

\<comment> \<open> Evolution command (invariants) \<close>

lemma R_g_ode_inv: "diff_invariant I f T S t\<^sub>0 G \<Longrightarrow> \<lceil>P\<rceil> \<le> \<lceil>I\<rceil> \<Longrightarrow> \<lceil>\<lambda>s. I s \<and> G s\<rceil> \<le> \<lceil>Q\<rceil> \<Longrightarrow>
  (x\<acute>=f & G on T S @ t\<^sub>0 DINV I) \<le> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  unfolding rel_rkat.spec_def by (auto simp: H_g_ode_inv)

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 rel" ("(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 rel" ("(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_rule1:
  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 "\<^bold>{P\<^bold>} (x\<acute>= f & G) \<^bold>{Q\<^bold>}"
  using assms by(subst local_flow.sH_g_ode_subset, auto)

lemma diff_solve_rule2:
  fixes c::"'a::{heine_borel, banach}"
  assumes "\<forall>s. P s \<longrightarrow> (\<forall>t\<ge>0. (\<forall>\<tau>\<in>{0..t}. G (s + \<tau> *\<^sub>R c)) \<longrightarrow> Q (s + t *\<^sub>R c))"
  shows "\<^bold>{P\<^bold>} (x\<acute>=(\<lambda>s. c) & G) \<^bold>{Q\<^bold>}"
  apply(subst local_flow.sH_g_ode_subset[where T=UNIV and \<phi>="(\<lambda> t x. x + t *\<^sub>R c)"])
  using line_is_local_flow assms by auto

lemma diff_weak_rule:
  assumes "\<lceil>G\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  using assms unfolding g_orbital_eq rel_kat_H ivp_sols_def g_ode_def by auto

lemma diff_cut_rule:
  assumes wp_C:"rel_kat.Hoare \<lceil>P\<rceil> (x\<acute>= f & G on U S @ t\<^sub>0) \<lceil>C\<rceil>"
    and wp_Q:"rel_kat.Hoare \<lceil>P\<rceil> (x\<acute>= f & (\<lambda> s. G s \<and> C s) on U S @ t\<^sub>0) \<lceil>Q\<rceil>"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
proof(subst rel_kat_H, simp add: g_orbital_eq p2r_def g_ode_def, clarsimp)
  fix t::real and X::"real \<Rightarrow> 'a" and s
  assume "P s" and "t \<in> U s"
    and x_ivp:"X \<in> ivp_sols f U S t\<^sub>0 s"
    and guard_x:"\<forall>x. x \<in> U s \<and> x \<le> t \<longrightarrow> G (X x)"
  have "\<forall>t\<in>(down (U s) t). X t \<in> g_orbital f G U S t\<^sub>0 s"
    using g_orbitalI[OF x_ivp] guard_x by auto
  hence "\<forall>t\<in>(down (U s) t). C (X t)"
    using wp_C \<open>P s\<close> by (subst (asm) rel_kat_H, auto simp: g_ode_def)
  hence "X t \<in> g_orbital f (\<lambda>s. G s \<and> C s) 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> wp_Q by (subst (asm) rel_kat_H) (auto simp: g_ode_def)
qed

lemma diff_inv_rule:
  assumes "\<lceil>P\<rceil> \<le> \<lceil>I\<rceil>" and "diff_invariant I f U S t\<^sub>0 G" and "\<lceil>I\<rceil> \<le> \<lceil>Q\<rceil>"
  shows "\<^bold>{P\<^bold>} (x\<acute>= f & G on U S @ t\<^sub>0) \<^bold>{Q\<^bold>}"
  apply(subst g_ode_inv_def[symmetric, where I=I], rule H_g_ode_inv)
  unfolding sH_diff_inv using assms by auto

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(* Title: Adaptation of example from HOL/Hoare/Separation
   Author: Gerwin Klein, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Example from HOL/Hoare/Separation"

theory Simple_Separation_Example
imports
  "HOL-Hoare.Hoare_Logic_Abort"
  Sep_Heap_Instance
  Sep_Tactics
begin

declare [[syntax_ambiguity_warning = false]]

type_synonym heap = "(nat \<Rightarrow> nat option)"

(* This syntax isn't ideal, but this is what is used in the original *)
definition maps_to:: "nat \<Rightarrow> nat \<Rightarrow> heap \<Rightarrow> bool" ("_ \<mapsto> _" [56,51] 56)
  where "x \<mapsto> y \<equiv> \<lambda>h. h = [x \<mapsto> y]"

(* If you don't mind syntax ambiguity: *)
notation pred_ex  (binder "\<exists>" 10)

(* could be generated automatically *)
definition maps_to_ex :: "nat \<Rightarrow> heap \<Rightarrow> bool" ("_ \<mapsto> -" [56] 56)
  where "x \<mapsto> - \<equiv> \<exists>y. x \<mapsto> y"

(* could be generated automatically *)
lemma maps_to_maps_to_ex [elim!]:
  "(p \<mapsto> v) s \<Longrightarrow> (p \<mapsto> -) s"
  by (auto simp: maps_to_ex_def)

(* The basic properties of maps_to: *)
lemma maps_to_write:
  "(p \<mapsto> - ** P) H \<Longrightarrow> (p \<mapsto> v ** P) (H (p \<mapsto> v))"
  apply (clarsimp simp: sep_conj_def maps_to_def maps_to_ex_def split: option.splits)
  apply (rule_tac x=y in exI)
  apply (auto simp: sep_disj_fun_def map_convs map_add_def split: option.splits)
  done

lemma points_to:
  "(p \<mapsto> v ** P) H \<Longrightarrow> the (H p) = v"
  by (auto elim!: sep_conjE
           simp: sep_disj_fun_def maps_to_def map_convs map_add_def
           split: option.splits)

(* This differs from the original and uses separation logic for the definition. *)
primrec
  list :: "nat \<Rightarrow> nat list \<Rightarrow> heap \<Rightarrow> bool"
where
  "list i [] = (\<langle>i=0\<rangle> and \<box>)"
| "list i (x#xs) = (\<langle>i=x \<and> i\<noteq>0\<rangle> and (EXS j. i \<mapsto> j ** list j xs))"

lemma list_empty [simp]:
  shows "list 0 xs = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (cases xs) auto

(* The examples from Hoare/Separation.thy *)
lemma "VARS x y z w h
 {(x \<mapsto> y ** z \<mapsto> w) h}
 SKIP
 {x \<noteq> z}"
  apply vcg
  apply(auto elim!: sep_conjE simp: maps_to_def sep_disj_fun_def domain_conv)
done

lemma "VARS H x y z w
 {(P ** Q) H}
 SKIP
 {(Q ** P) H}"
  apply vcg
  apply(simp add: sep_conj_commute)
done

lemma "VARS H
 {p\<noteq>0 \<and> (p \<mapsto> - ** list q qs) H}
 H := H(p \<mapsto> q)
 {list p (p#qs) H}"
  apply vcg
  apply (auto intro: maps_to_write)
done

text \<open>First a proof without using tactics\<close>
lemma "VARS H p q r
  {(list p Ps ** list q Qs) H}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (list p ps ** list q qs) H \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {list q (rev Ps @ Qs) H}"
  apply vcg
    apply fastforce
   apply clarsimp
   apply (case_tac ps, simp)
   apply (rename_tac p ps')
   apply (rule_tac x = "ps'" in exI)
   apply (rule_tac x = "p # qs" in exI)
   apply clarsimp
   apply (clarsimp simp: sep_conj_exists sep_conj_ac)
   apply (rule_tac x = "q" in exI)
   thm points_to
   apply (subst (asm) sep_conj_ac)
   apply (subst (asm) sep_conj_commute)
   apply (simp add: sep_conj_assoc)
   apply (frule points_to)
   apply simp
   thm maps_to_write
   apply (subst sep_conj_assoc[symmetric])
   apply (subst sep_conj_commute)
   apply (simp add: sep_conj_assoc)
   apply (rule maps_to_write)
   thm maps_to_maps_to_ex
   apply (drule sep_conj_impl1[rotated])
    apply (erule maps_to_maps_to_ex)
   apply (rule sep_conj_impl1[rotated])
    apply (subst sep_conj_ac, assumption)
   apply assumption
  apply clarsimp
  done

text \<open>Now with tactics\<close>
lemma "VARS H p q r
  {(list p Ps ** list q Qs) H}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (list p ps ** list q qs) H \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {list q (rev Ps @ Qs) H}"
  apply vcg
    apply fastforce
   apply clarsimp
   apply (case_tac ps, simp)
   apply (rename_tac p q ps qs p' ps')
   apply (clarsimp simp: sep_conj_exists sep_conj_ac)
   apply (subst points_to, sep_solve)
   apply (rule_tac x = "ps'" in exI)
   apply (rule_tac x = "p # qs" in exI)
   apply (simp add: sep_conj_exists sep_conj_ac)
   apply (rule exI)
   apply (sep_rule (direct) maps_to_write) \<comment> \<open>note: demonstrates computation\<close>
   apply (sep_solve add: maps_to_maps_to_ex)
  apply clarsimp
  done

end