(*  Title:   Pair_QuasiBorel_Measure.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection \<open>Binary Product Measure\<close>

theory Pair_QuasiBorel_Measure
  imports "Monad_QuasiBorel"
begin

subsubsection \<open> Binary Product Measure\<close>
text \<open> Special case of \<^cite>\<open>"Heunen_2017"\<close> Proposition 23 where $\Omega = \mathbb{R}\times \mathbb{R}$ and $X = X \times Y$.
      Let $[\alpha,\mu ] \in P(X)$ and $[\beta ,\nu] \in P(Y)$. $\alpha\times\beta$ is the $\alpha$ in Proposition 23. \<close>
definition qbs_prob_pair_measure_t :: "['a qbs_prob_t, 'b qbs_prob_t] \<Rightarrow> ('a \<times> 'b) qbs_prob_t" where
"qbs_prob_pair_measure_t p q  \<equiv> (let (X,\<alpha>,\<mu>) = p;
                                     (Y,\<beta>,\<nu>) = q in
                                 (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f))"

lift_definition qbs_prob_pair_measure :: "['a qbs_prob_space, 'b qbs_prob_space] \<Rightarrow> ('a \<times> 'b) qbs_prob_space" (infix "\<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s" 80)
is qbs_prob_pair_measure_t
  unfolding qbs_prob_pair_measure_t_def
proof auto
  fix X X' :: "'a quasi_borel"
  fix Y Y' :: "'b quasi_borel"
  fix \<alpha> \<alpha>' \<mu> \<mu>' \<beta> \<beta>' \<nu> \<nu>'
  assume h:"qbs_prob_eq (X,\<alpha>,\<mu>) (X',\<alpha>',\<mu>')"
           "qbs_prob_eq (Y,\<beta>,\<nu>) (Y',\<beta>',\<nu>')"
  then have 1: "X = X'" "Y = Y'"
    by(auto simp: qbs_prob_eq_def)
  interpret pqp1: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(1)[OF h(1)] qbs_prob_eq_dest(1)[OF h(2)])
  interpret pqp2: pair_qbs_probs X' \<alpha>' \<mu>' Y' \<beta>' \<nu>'
    by(simp add: pair_qbs_probs_def qbs_prob_eq_dest(2)[OF h(1)] qbs_prob_eq_dest(2)[OF h(2)])
  interpret pqp: pair_qbs_prob "X \<Otimes>\<^sub>Q Y" "map_prod \<alpha> \<beta> \<circ> real_real.g" "distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f" "X' \<Otimes>\<^sub>Q Y'" "map_prod \<alpha>' \<beta>' \<circ> real_real.g" "distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f"
    by(auto intro!: qbs_probI pqp1.P.prob_space_distr pqp2.P.prob_space_distr simp: pair_qbs_prob_def)

  show "qbs_prob_eq (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (X' \<Otimes>\<^sub>Q Y', map_prod \<alpha>' \<beta>' \<circ> real_real.g, distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f)"
  proof(rule pqp.qbs_prob_space_eq_inverse(1))
    show "qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g, distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)
           = qbs_prob_space (X' \<Otimes>\<^sub>Q Y', map_prod \<alpha>' \<beta>' \<circ> real_real.g, distr (\<mu>' \<Otimes>\<^sub>M \<nu>') real_borel real_real.f)"
         (is "?lhs = ?rhs")
    proof -
      have "?lhs = qbs_prob_space (X, \<alpha>, \<mu>) \<bind> (\<lambda>x. qbs_prob_space (Y, \<beta>, \<nu>) \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)))"
        by(simp add: pqp1.qbs_bind_return_pq)
      also have "... = qbs_prob_space (X', \<alpha>', \<mu>') \<bind> (\<lambda>x. qbs_prob_space (Y', \<beta>', \<nu>') \<bind> (\<lambda>y. qbs_return (X' \<Otimes>\<^sub>Q Y') (x, y)))"
        using h by(simp add: qbs_prob_space_eq 1)
      also have "... = ?rhs"
        by(simp add: pqp2.qbs_bind_return_pq)
      finally show ?thesis .
    qed
  qed
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_computation:
  "(qbs_prob_space (X,\<alpha>,\<mu>)) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s (qbs_prob_space (Y,\<beta>,\<nu>)) = qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha> \<beta> \<circ> real_real.g , distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
  "qbs_prob (X \<Otimes>\<^sub>Q Y) (map_prod \<alpha> \<beta> \<circ> real_real.g) (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
  by(simp_all add: qbs_prob_pair_measure.abs_eq qbs_prob_pair_measure_t_def qbs_bind_return_pq)

lemma qbs_prob_pair_measure_qbs:
  "qbs_prob_space_qbs (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) = qbs_prob_space_qbs p \<Otimes>\<^sub>Q qbs_prob_space_qbs q"
  by(transfer,simp add: qbs_prob_pair_measure_t_def Let_def prod.case_eq_if)

lemma(in pair_qbs_probs) qbs_prob_pair_measure_measure:
    shows "qbs_prob_measure (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) = distr (\<mu> \<Otimes>\<^sub>M \<nu>) (qbs_to_measure (X \<Otimes>\<^sub>Q Y)) (map_prod \<alpha> \<beta>)"
  by(simp add: qbs_prob_pair_measure_computation distr_distr comp_assoc)

lemma qbs_prob_pair_measure_morphism:
 "case_prod qbs_prob_pair_measure \<in> monadP_qbs X \<Otimes>\<^sub>Q monadP_qbs Y \<rightarrow>\<^sub>Q monadP_qbs (X \<Otimes>\<^sub>Q Y)"
proof(rule pair_qbs_morphismI)
  fix \<beta>x \<beta>y
  assume h: "\<beta>x \<in> qbs_Mx (monadP_qbs X)" " \<beta>y \<in> qbs_Mx (monadP_qbs Y)"
  then obtain \<alpha>x \<alpha>y gx gy where ha:
   "\<alpha>x \<in> qbs_Mx X" "gx \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel" "\<beta>x = (\<lambda>r. qbs_prob_space (X, \<alpha>x, gx r))"
   "\<alpha>y \<in> qbs_Mx Y" "gy \<in> real_borel \<rightarrow>\<^sub>M prob_algebra real_borel" "\<beta>y = (\<lambda>r. qbs_prob_space (Y, \<alpha>y, gy r))"
    using rep_monadP_qbs_MPx[of \<beta>x X] rep_monadP_qbs_MPx[of \<beta>y Y] by auto
  note [measurable] = ha(2,5)
  have "(\<lambda>(x, y). x \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s y) \<circ> (\<lambda>r. (\<beta>x r, \<beta>y r)) = (\<lambda>r. qbs_prob_space (X \<Otimes>\<^sub>Q Y, map_prod \<alpha>x \<alpha>y \<circ> real_real.g, distr (gx r \<Otimes>\<^sub>M gy r) real_borel real_real.f))"
    apply standard
    using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.qbs_prob_pair_measure_computation[of X \<alpha>x _ Y \<alpha>y]
    by (auto simp: ha pair_qbs_probs_def)
  also have "... \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q Y))"
    using qbs_prob_MPx[OF ha(1,2)] qbs_prob_MPx[OF ha(4,5)] pair_qbs_probs.ab_g_in_Mx[of X \<alpha>x _ Y \<alpha>y]
    by(auto intro!: bexI[where x="map_prod \<alpha>x \<alpha>y \<circ> real_real.g"] bexI[where x="\<lambda>r. distr (gx r \<Otimes>\<^sub>M gy r) real_borel real_real.f"]
         simp: monadP_qbs_MPx_def in_MPx_def pair_qbs_probs_def)
  finally show "(\<lambda>(x, y). x \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s y) \<circ> (\<lambda>r. (\<beta>x r, \<beta>y r)) \<in> qbs_Mx (monadP_qbs (X \<Otimes>\<^sub>Q Y))" .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_nnintegral:
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
  shows "(\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>))) = (\<integral>\<^sup>+ z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
        (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sup>+ x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) x \<partial>distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
    by(simp add: qbs_prob_ennintegral_def[OF assms] qbs_prob_pair_measure_computation)
  also have "... = (\<integral>\<^sup>+ x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) (real_real.f x) \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using assms by(intro nn_integral_distr) auto
  also have "... = ?rhs" by simp
  finally show ?thesis .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integral:
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    shows "(\<integral>\<^sub>Q z. f z \<partial>(qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>))) = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
          (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) x \<partial>distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f)"
    by(simp add: qbs_prob_integral_def[OF assms] qbs_prob_pair_measure_computation)
  also have "... = (\<integral> x. ((f \<circ> map_prod \<alpha> \<beta>) \<circ> real_real.g) (real_real.f x) \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using assms by(intro integral_distr) auto
  also have "... = ?rhs" by simp
  finally show ?thesis .
qed

lemma qbs_prob_pair_measure_eq_bind:
  assumes "p \<in> monadP_qbs_Px X"
      and "q \<in> monadP_qbs_Px Y"
    shows "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q = p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))"
proof -
  obtain \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def hp hq)
  show ?thesis
    by(simp add: hp(1) hq(1) pqp.qbs_prob_pair_measure_computation(1) pqp.qbs_bind_return_pq(1))
qed

subsubsection \<open>Fubini Theorem\<close>
lemma qbs_prob_ennintegral_Fubini_fst:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
      and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. f (x,y) \<partial>q \<partial>p) = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs Y",simplified,OF assms(2)] curry_preserves_morphisms[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]
                qbs_morphism_Pair1'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
                assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
  have "?rhs = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(p \<bind> (\<lambda>x. q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))))"
    by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)])
  also have "... = (\<integral>\<^sup>+\<^sub>Q x. qbs_prob_ennintegral (q \<bind> (\<lambda>y. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) f \<partial>p)"
    by(auto intro!: qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
  also have "... =  (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. qbs_prob_ennintegral (qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)) f \<partial>q \<partial>p)"
    by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
  also have "... = ?lhs"
    using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
  finally show ?thesis by simp
qed

lemma qbs_prob_ennintegral_Fubini_snd:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
      and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. f (x,y) \<partial>p \<partial>q) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  note [simp] = qbs_bind_morphism[OF qbs_morphism_const[of _ "monadP_qbs X",simplified,OF assms(1)] curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]],simplified curry_def,simplified]]
                qbs_morphism_Pair2'[OF _ qbs_return_morphism[of "X \<Otimes>\<^sub>Q Y"]]
                assms(1)[simplified monadP_qbs_Px_def,simplified] assms(2)[simplified monadP_qbs_Px_def,simplified]
  have "?rhs = (\<integral>\<^sup>+\<^sub>Q z. f z \<partial>(q \<bind> (\<lambda>y. p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x,y)))))"
    by(simp add: qbs_prob_pair_measure_eq_bind[OF assms(1,2)] qbs_bind_return_rotate[OF assms(1,2)])
  also have "... = (\<integral>\<^sup>+\<^sub>Q y. qbs_prob_ennintegral (p \<bind> (\<lambda>x. qbs_return (X \<Otimes>\<^sub>Q Y) (x, y))) f \<partial>q)"
    by(auto intro!: qbs_prob_ennintegral_bind[OF assms(2) _ assms(3)])
  also have "... =  (\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. qbs_prob_ennintegral (qbs_return (X \<Otimes>\<^sub>Q Y) (x, y)) f \<partial>p \<partial>q)"
    by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_bind[OF assms(1) _ assms(3)])
  also have "... = ?lhs"
    using assms(3) by(auto intro!: qbs_prob_ennintegral_cong qbs_prob_ennintegral_return)
  finally show ?thesis by simp
qed

lemma qbs_prob_ennintegral_indep1:
  assumes "p \<in> monadP_qbs_Px X"
      and "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>p)"
          (is "?lhs = _")
proof -
 obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  have "?lhs = (\<integral>\<^sup>+\<^sub>Q y. \<integral>\<^sup>+\<^sub>Q x. f x \<partial>p \<partial>q)"
    using qbs_prob_ennintegral_Fubini_snd[OF assms(1) qbs_prob.qbs_prob_space_in_Px[OF hq(2)] qbs_morphism_fst''[OF assms(2)]]
    by(simp add: hq(1))
  thus ?thesis
    by(simp add: qbs_prob_ennintegral_const)
qed

lemma qbs_prob_ennintegral_indep2:
  assumes "q \<in> monadP_qbs_Px Y"
      and "f \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q z. f (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q y. f y \<partial>q)"
          (is "?lhs = _")
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  have "?lhs = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y. f y \<partial>q \<partial>p)"
    using qbs_prob_ennintegral_Fubini_fst[OF qbs_prob.qbs_prob_space_in_Px[OF hp(2)] assms(1) qbs_morphism_snd''[OF assms(2)]]
    by(simp add: hp(1))
  thus ?thesis
    by(simp add: qbs_prob_ennintegral_const)
qed

lemma qbs_ennintegral_indep_mult:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
          "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
      and "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    shows "(\<integral>\<^sup>+\<^sub>Q z. f (fst z) * g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sup>+\<^sub>Q x. f x \<partial>p) * (\<integral>\<^sup>+\<^sub>Q y. g y \<partial>q)"
          (is "?lhs = ?rhs")
proof -
  have h:"(\<lambda>z. f (fst z) * g (snd z)) \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q\<^sub>\<ge>\<^sub>0"
    using assms(4,3)
    by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)

  have "?lhs = (\<integral>\<^sup>+\<^sub>Q x. \<integral>\<^sup>+\<^sub>Q y .f x * g y \<partial>q \<partial>p)"
    using qbs_prob_ennintegral_Fubini_fst[OF assms(1,2) h] by simp
  also have "... = (\<integral>\<^sup>+\<^sub>Q x. f x * \<integral>\<^sup>+\<^sub>Q y . g y \<partial>q \<partial>p)"
    using qbs_prob_ennintegral_cmult[of q,OF _ assms(4)] assms(2)
    by(simp add: monadP_qbs_Px_def)
  also have "... = ?rhs"
    using qbs_prob_ennintegral_cmult[of p,OF _ assms(3)] assms(1)
    by(simp add: ab_semigroup_mult_class.mult.commute[where b="qbs_prob_ennintegral q g"] monadP_qbs_Px_def)
  finally show ?thesis .
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable:
  assumes "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) f"
    shows "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
          "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> (map_prod \<alpha> \<beta>))"
proof -
  show "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF qbs_prob_pair_measure_qbs assms]
    by simp
next
  have 1:"integrable (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g))"
    using assms[simplified qbs_prob_pair_measure_computation] qbs_integrable_def[of f]
    by simp
  have "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (\<lambda>x. (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (real_real.f x))"
    by(intro integrable_distr[OF _ 1]) simp
  thus "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
    by(simp add: comp_def)
qed

lemma(in pair_qbs_probs) qbs_prob_pair_measure_integrable':
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
      and "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> (map_prod \<alpha> \<beta>))"
    shows "qbs_integrable (qbs_prob_space (X,\<alpha>,\<mu>) \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s qbs_prob_space (Y,\<beta>,\<nu>)) f"
proof -
  have "integrable (distr (\<mu> \<Otimes>\<^sub>M \<nu>) real_borel real_real.f) (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) = integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (\<lambda>x. (f \<circ> (map_prod \<alpha> \<beta> \<circ> real_real.g)) (real_real.f x))"
    by(intro integrable_distr_eq) (use assms(1) in auto)
  thus ?thesis
    using assms qbs_integrable_def
    by(simp add: comp_def qbs_prob_pair_measure_computation)
qed

lemma qbs_integrable_pair_swap:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  shows "qbs_integrable (q \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s p) (\<lambda>(x,y). f (y,x))"
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def hp hq)
  interpret pqp2: pair_qbs_probs Y \<beta> \<nu> X \<alpha> \<mu>
    by(simp add: pair_qbs_probs_def hp hq)

  have "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
       "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
    by(auto simp: pqp.qbs_prob_pair_measure_integrable[OF assms[simplified hp(1) hq(1)]])
  from qbs_morphism_pair_swap[OF this(1)] pqp.integrable_product_swap[OF this(2)]
  have "(\<lambda>(x,y). f (y,x)) \<in> Y \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
        "integrable (\<nu> \<Otimes>\<^sub>M \<mu>) ((\<lambda>(x,y). f (y,x)) \<circ> map_prod \<beta> \<alpha>)"
    by(simp_all add: map_prod_def comp_def split_beta')
  from pqp2.qbs_prob_pair_measure_integrable' [OF this]
  show ?thesis by(simp add: hp(1) hq(1))
qed

lemma qbs_integrable_pair1:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
          "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
          "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f (x,y)\<bar> \<partial>q)"
      and "\<And>x. x \<in> qbs_space X \<Longrightarrow> qbs_integrable q (\<lambda>y. f (x,y))"
    shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
proof -
  obtain \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_monadP_qbs_Px[OF assms(1)] by auto
  obtain \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_monadP_qbs_Px[OF assms(2)] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: pair_qbs_probs_def hp hq)

  have "integrable (\<mu> \<Otimes>\<^sub>M \<nu>) (f \<circ> map_prod \<alpha> \<beta>)"
  proof(rule pqp.Fubini_integrable)
    show "f \<circ> map_prod \<alpha> \<beta> \<in> borel_measurable (\<mu> \<Otimes>\<^sub>M \<nu>)"
      using assms(3) by auto
  next
    have "(\<lambda>x. LINT y|\<nu>. norm ((f \<circ> map_prod \<alpha> \<beta>) (x, y))) = (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f (x,y)\<bar> \<partial>q) \<circ> \<alpha>"
      apply standard subgoal for x
        using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx,of x] assms(3)]
        by(auto intro!: pqp.qp2.qbs_prob_integral_def[symmetric] simp: hq(1))
      done
    moreover have "integrable \<mu> ..."
      using assms(4) pqp.qp1.qbs_integrable_def
      by (simp add: hp(1))
    ultimately show "integrable \<mu> (\<lambda>x. LINT y|\<nu>. norm ((f \<circ> map_prod \<alpha> \<beta>) (x, y)))"
      by simp
  next
    have "\<And>x. integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
    proof-
      fix x
      have "(\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y)) = (\<lambda>y. f (\<alpha> x,y)) \<circ> \<beta>"
        by auto
      moreover have "qbs_integrable (qbs_prob_space (Y, \<beta>, \<nu>)) (\<lambda>y. f (\<alpha> x, y))"
        by(auto intro!: assms(5)[simplified hq(1)] simp: qbs_Mx_to_X)
      ultimately show "integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
        by(simp add: pqp.qp2.qbs_integrable_def)
    qed
    thus "AE x in \<mu>. integrable \<nu> (\<lambda>y. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
      by simp
  qed
  thus ?thesis
    using pqp.qbs_prob_pair_measure_integrable'[OF assms(3)]
    by(simp add: hp(1) hq(1))
qed

lemma qbs_integrable_pair2:
  assumes "p \<in> monadP_qbs_Px X"
          "q \<in> monadP_qbs_Px Y"
          "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
          "qbs_integrable q (\<lambda>y. \<integral>\<^sub>Q x. \<bar>f (x,y)\<bar> \<partial>p)"
      and "\<And>y. y \<in> qbs_space Y \<Longrightarrow> qbs_integrable p (\<lambda>x. f (x,y))"
    shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  using qbs_integrable_pair_swap[OF qbs_integrable_pair1[OF assms(2,1) qbs_morphism_pair_swap[OF assms(3)],simplified,OF assms(4,5)]]
  by simp

lemma qbs_integrable_fst:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  shows "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. f (x,y) \<partial>q)"
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  show "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q)"
  proof(auto simp add: pqp.qp1.qbs_integrable_def hp(1))
    show "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<in> borel_measurable (qbs_to_measure X)"
      using qbs_morphism_integral_fst[OF h0(2,3)] by auto
  next
    have "integrable \<mu> (\<lambda>x. LINT y|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"
      by(intro pqp.integrable_fst') (rule pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]])
    moreover have "\<And>x. ((\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>) x = LINT y|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y)"
     by(auto intro!: pqp.qp2.qbs_prob_integral_def qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)] simp: hq)
    ultimately show "integrable \<mu> ((\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>)"
      using Bochner_Integration.integrable_cong[of \<mu> \<mu> "(\<lambda>x. \<integral>\<^sub>Q y. f (x, y) \<partial>q) \<circ> \<alpha>" " (\<lambda>x. LINT y|\<nu>. (f \<circ> map_prod \<alpha> \<beta>) (x, y))"]
      by simp
  qed
qed

lemma qbs_integrable_snd:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
  shows "qbs_integrable q (\<lambda>y. \<integral>\<^sub>Q x. f (x,y) \<partial>p)"
  using qbs_integrable_fst[OF qbs_integrable_pair_swap[OF assms]]
  by simp

lemma qbs_integrable_indep_mult:
  assumes "qbs_integrable p f"
      and "qbs_integrable q g"
    shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. f (fst x) * g (snd x))"
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<rightarrow>\<^sub>Q \<real>\<^sub>Q" "g \<in> Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms(1)] qbs_integrable_morphism[OF _ assms(2)]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  show ?thesis
  proof(rule qbs_integrable_pair1[OF h0(1,2)],simp_all add: assms(2))
    show "(\<lambda>z. f (fst z) * g (snd z)) \<in>  X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
      using h0(3,4) by(auto intro!: borel_measurable_subalgebra[OF l_product_sets[of X Y]] simp: space_pair_measure lr_adjunction_correspondence)
  next
    show "qbs_integrable p (\<lambda>x. \<integral>\<^sub>Q y. \<bar>f x * g y\<bar> \<partial>q)"
      by(auto intro!: qbs_integrable_mult[OF qbs_integrable_abs[OF assms(1)]]
           simp only: idom_abs_sgn_class.abs_mult qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="\<integral>\<^sub>Q y. \<bar>g y\<bar> \<partial>q"])
  qed
qed

lemma qbs_integrable_indep1:
  assumes "qbs_integrable p f"
  shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. f (fst x))"
  using qbs_integrable_indep_mult[OF assms qbs_integrable_const[of q 1]]
  by simp

lemma qbs_integrable_indep2:
  assumes "qbs_integrable q g"
  shows "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>x. g (snd x))"
  using qbs_integrable_pair_swap[OF qbs_integrable_indep1[OF assms],of p]
  by(simp add: split_beta')

lemma qbs_prob_integral_Fubini_fst:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
    shows "(\<integral>\<^sub>Q x. \<integral>\<^sub>Q y. f (x,y) \<partial>q \<partial>p) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  have "?lhs = (\<integral> x. \<integral>\<^sub>Q y. f (\<alpha> x, y) \<partial>q \<partial>\<mu>)"
    using qbs_morphism_integral_fst[OF h0(2) h0(3)]
    by(auto intro!: pqp.qp1.qbs_prob_integral_def simp: hp(1))
  also have "... = (\<integral>x. \<integral>y. f (\<alpha> x, \<beta> y) \<partial>\<nu> \<partial>\<mu>)"
    using qbs_morphism_Pair1'[OF qbs_Mx_to_X(2)[OF pqp.qp1.in_Mx] h0(3)]
    by(auto intro!: Bochner_Integration.integral_cong pqp.qp2.qbs_prob_integral_def
              simp: hq(1))
  also have "... = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using pqp.integral_fst'[OF pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]]
    by(simp add: map_prod_def comp_def)
  also have "... = ?rhs"
    by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
  finally show ?thesis .
qed

lemma qbs_prob_integral_Fubini_snd:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
    shows "(\<integral>\<^sub>Q y. \<integral>\<^sub>Q x. f (x,y) \<partial>p \<partial>q) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
          (is "?lhs = ?rhs")
proof -
  obtain X \<alpha> \<mu> where hp:
    "p = qbs_prob_space (X, \<alpha>, \<mu>)" "qbs_prob X \<alpha> \<mu>"
    using rep_qbs_prob_space[of p] by auto
  obtain Y \<beta> \<nu> where hq:
   "q = qbs_prob_space (Y, \<beta>, \<nu>)" "qbs_prob Y \<beta> \<nu>"
    using rep_qbs_prob_space[of q] by auto
  interpret pqp: pair_qbs_probs X \<alpha> \<mu> Y \<beta> \<nu>
    by(simp add: hp hq  pair_qbs_probs_def)
  have h0: "p \<in> monadP_qbs_Px X" "q \<in> monadP_qbs_Px Y" "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q \<real>\<^sub>Q"
    using qbs_integrable_morphism[OF _ assms,simplified qbs_prob_pair_measure_qbs]
    by(simp_all add: monadP_qbs_Px_def hp(1) hq(1))

  have "?lhs = (\<integral> y. \<integral>\<^sub>Q x. f (x,\<beta> y) \<partial>p \<partial>\<nu>)"
    using qbs_morphism_integral_snd[OF h0(1) h0(3)]
    by(auto intro!: pqp.qp2.qbs_prob_integral_def simp: hq(1))
  also have "... = (\<integral>y. \<integral>x. f (\<alpha> x, \<beta> y) \<partial>\<mu> \<partial>\<nu>)"
    using qbs_morphism_Pair2'[OF qbs_Mx_to_X(2)[OF pqp.qp2.in_Mx] h0(3)]
    by(auto intro!: Bochner_Integration.integral_cong pqp.qp1.qbs_prob_integral_def
              simp: hp(1))
  also have "... = (\<integral>z. (f \<circ> map_prod \<alpha> \<beta>) z \<partial>(\<mu> \<Otimes>\<^sub>M \<nu>))"
    using pqp.integral_snd[of "curry (f \<circ> map_prod \<alpha> \<beta>)"] pqp.qbs_prob_pair_measure_integrable(2)[OF assms[simplified hp(1) hq(1)]]
    by(simp add: map_prod_def comp_def split_beta')
  also have "... = ?rhs"
    by(simp add: pqp.qbs_prob_pair_measure_integral[OF h0(3)] hp(1) hq(1))
  finally show ?thesis .
qed

lemma qbs_prob_integral_indep1:
  assumes "qbs_integrable p f"
  shows "(\<integral>\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q x. f x \<partial>p)"
  using qbs_prob_integral_Fubini_snd[OF qbs_integrable_indep1[OF assms],of q]
  by(simp add: qbs_prob_integral_const)

lemma qbs_prob_integral_indep2:
  assumes "qbs_integrable q g"
  shows "(\<integral>\<^sub>Q z. g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q y. g y \<partial>q)"
  using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep2[OF assms],of p]
  by(simp add: qbs_prob_integral_const)

lemma qbs_prob_integral_indep_mult:
  assumes "qbs_integrable p f"
      and "qbs_integrable q g"
    shows "(\<integral>\<^sub>Q z. f (fst z) * g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q x. f x \<partial>p) * (\<integral>\<^sub>Q y. g y \<partial>q)"
          (is "?lhs = ?rhs")
proof -
  have "?lhs = (\<integral>\<^sub>Q x. \<integral>\<^sub>Q y. f x * g y \<partial>q \<partial>p)"
    using qbs_prob_integral_Fubini_fst[OF qbs_integrable_indep_mult[OF assms]]
    by simp
  also have "... = (\<integral>\<^sub>Q x. f x * (\<integral>\<^sub>Q y.  g y \<partial>q) \<partial>p)"
    by(simp add: qbs_prob_integral_cmult)
  also have "... = ?rhs"
    by(simp add: qbs_prob_integral_cmult ab_semigroup_mult_class.mult.commute[where b="\<integral>\<^sub>Q y.  g y \<partial>q"])
  finally show ?thesis .
qed

lemma qbs_prob_var_indep_plus:
  assumes "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (f z)\<^sup>2)"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (g z)\<^sup>2)"
          "qbs_integrable (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. (f z) * (g z))"
      and "(\<integral>\<^sub>Q z. f z * g z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q z. f z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * (\<integral>\<^sub>Q z. g z \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
    shows "qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. f z + g z) = qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f + qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"
  unfolding qbs_prob_var_def
proof -
  show "(\<integral>\<^sub>Q z. (f z + g z - \<integral>\<^sub>Q w. f w + g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) = (\<integral>\<^sub>Q z. (f z - qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f)\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) + (\<integral>\<^sub>Q z. (g z - qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g)\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
       (is "?lhs = ?rhs")
  proof -
    have "?lhs = (\<integral>\<^sub>Q z. ((f z - (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))) + (g z - (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))))\<^sup>2 \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
      by(simp add: qbs_prob_integral_add[OF assms(1,3)] add_diff_add)
    also have "... = (\<integral>\<^sub>Q z. (f z - (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))\<^sup>2 + (g z - (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))\<^sup>2 + (2 * f z * g z - 2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * g z - (2 * f z * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) - 2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)) * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)))) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))"
      by(simp add: comm_semiring_1_class.power2_sum comm_semiring_1_cancel_class.left_diff_distrib' ring_class.right_diff_distrib)
    also have "... = ?rhs"
      using qbs_prob_integral_add[OF qbs_integrable_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]] qbs_integrable_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]]]
            qbs_prob_integral_add[OF qbs_integrable_sq[OF assms(1,2)] qbs_integrable_sq[OF assms(3,4)]]
            qbs_prob_integral_diff[OF qbs_integrable_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]] qbs_integrable_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]]
            qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(5),of 2,simplified comm_semiring_1_class.semiring_normalization_rules(18)] qbs_integrable_mult[OF assms(3),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f"]]
            qbs_prob_integral_diff[OF qbs_integrable_mult[OF assms(1),of "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g",simplified ab_semigroup_mult_class.mult_ac(1)[where b="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of _ _ "qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]] qbs_integrable_const[of _ "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]]
            qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" 2 "\<lambda>z. f z * g z",simplified assms(6) comm_semiring_1_class.semiring_normalization_rules(18)]
            qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * (\<integral>\<^sub>Q w. f w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))" g]
            qbs_prob_integral_cmult[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * (\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q))" f,simplified semigroup_mult_class.mult.assoc[of 2 "\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"] ab_semigroup_mult_class.mult.commute[where a="qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"] comm_semiring_1_class.semiring_normalization_rules(18)[of 2 _ "\<integral>\<^sub>Q w. g w \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"]]
            qbs_prob_integral_const[of "p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q" "2 * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) f * qbs_prob_integral (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) g"]
      by simp
    finally show ?thesis .
  qed
qed

lemma qbs_prob_var_indep_plus':
  assumes "qbs_integrable p f"
          "qbs_integrable p (\<lambda>x. (f x)\<^sup>2)"
          "qbs_integrable q g"
      and "qbs_integrable q (\<lambda>x. (g x)\<^sup>2)"
    shows "qbs_prob_var (p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q) (\<lambda>z. f (fst z) + g (snd z)) = qbs_prob_var p f + qbs_prob_var q g"
  using qbs_prob_var_indep_plus[OF qbs_integrable_indep1[OF assms(1)] qbs_integrable_indep1[OF assms(2)] qbs_integrable_indep2[OF assms(3)] qbs_integrable_indep2[OF assms(4)] qbs_integrable_indep_mult[OF assms(1) assms(3)] qbs_prob_integral_indep_mult[OF assms(1) assms(3),simplified  qbs_prob_integral_indep1[OF assms(1),of q,symmetric] qbs_prob_integral_indep2[OF assms(3),of p,symmetric]]]
        qbs_prob_integral_indep1[OF qbs_integrable_sq[OF assms(1,2)],of q "\<integral>\<^sub>Q z. f (fst z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"] qbs_prob_integral_indep2[OF qbs_integrable_sq[OF assms(3,4)],of p "\<integral>\<^sub>Q z. g (snd z) \<partial>(p \<Otimes>\<^sub>Q\<^sub>m\<^sub>e\<^sub>s q)"]
  by(simp add: qbs_prob_var_def qbs_prob_integral_indep1[OF assms(1)] qbs_prob_integral_indep2[OF assms(3)])

end


(* original Author: Martin Desharnais
    updated to version 2016 by Michaël Noël Divo
*)
(*<*)
theory Examples
  imports Main
begin
hide_const Nil Cons
hide_type list
(*>*)

text {*
This section only presents briefly the most used constructions in the formalizations described in
this thesis. It is not expected from the reader to fully understand the proofs presented in this
report; it is sufficient to recognize key concepts such as induction and case analysis.

The theorem proving community is subdivided in two groups: automatic theorem proving (ATP) and
interactive theorem proving (ITP). Each has its own set of goals, motivations, methodologies,
tools and terminology. In ATP, one must formulate its context and equations in some logical
formalism and ask the theorem prover to find a proof. The limiting factor is the algorithm used by
the tool. Examples of such provers include SPASS, Vampire and Z3. In ITP, one must also formulate
its context and equations in some logical formalism, although usually a more expressive one, but
must also give instructions guiding the prover. The term proof assistant is sometime used to
highlight this collaboration between the human and the machine. Here, the limiting factor is the
ability of the human to guide its tool. Examples of interactive theorem provers include Agda, Coq
and Isabelle. Isabelle is a generic interactive theorem prover for implementing logical formalisms
and Isabelle/HOL is its specialization to a formalism called higher order logic.

An Isabelle theory file serves as the basic unit of encapsulation of formalizations and reusable
libraries. It is analogous to modules in programming languages. Every definition and theorem
developed must belong to a theory and can be made accessible to other theories by importing them.

Types and function definitions serve to describe entities and how to operate on them. They work in a
very similar way to their counterpart in functional programming languages. A new type is introduced
with the \texttt{datatype} command, followed by the name of the type and the different constructors
separated by a \texttt{|}. Following is the standard definition of the type of parametric
lists:\footnote{Prefixing an element with a descriptive name, as done for the arguments of the
@{text Cons} constructor, is a common pattern in Isabelle/HOL. The syntax is always
\texttt{name : element}.}
*}

datatype 'a list = Nil | Cons (head: 'a) (tail: "'a list")

text {*
The datatype consists of two constructors. The first one, @{const Nil}, is used to represent the
empty list while the second one, @{const Cons}, is used to add an element in front of an existing
list. Using those two primitives, a list can be created by successive application of the @{const
Cons} constructor (e.g. @{term [source] "Cons 1 (Cons 2 (Cons 3 Nil))"}). The \emph{'a} in front
of the name is a placeholder for a concrete type that must be provide later (e.g. the type of the
previous example could be @{typ "nat list"}).

Function definitions can take many forms in Isabelle/HOL. A primitively recursive function is
introduced with the \texttt{primrec} command and defined by pattern matching over its arguments.
Each pattern match entry must then provide the value to which the function evaluates. Following is a
definition of a higher order function (i.e. a function that takes a function as argument) that
checks if all the elements of a list are ordered with respect to a binary predicate provided as an
argument:
*}

primrec ordered :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "ordered p Nil = True" |
  "ordered p (Cons x xs) = (case xs of
     Nil \<Rightarrow> True |
     Cons y ys \<Rightarrow> p x y \<and> ordered p xs)"

text {*
An alternative way in which this function could be defined is inductively. Introduced with the
\texttt{inductive} command, it allows to express Boolean functions by providing an inductive
definition of when the function should evaluate to true, leaving all the other cases to false. The
definition consists of base cases and possibly many inductive cases. Following is the same function
defined inductively:\footnote{Here, a descriptive name have been given to each rule. The base
cases are @{text empty_list} and @{text singleton_list} while the inductive case is @{text
arbitrary_list}.}
*}

inductive ordered' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  empty_list:
    "ordered' p Nil" |
  singleton_list:
    "ordered' p (Cons x Nil)" |
  arbitrary_list:
    "p x1 x2 \<Longrightarrow> ordered' p (Cons x2 xs) \<Longrightarrow> ordered' p (Cons x1 (Cons x2 xs))"

text {*
Theorems, also named lemmas, are true facts involving the defined elements. They could be compared
to the assertions used in programming languages. The main difference is that asserts are validate by
evaluating the expression while theorems are validated by a formal proof. This is the point where
the analogy with programming languages stops since this concept is unique to theorem provers. In
Isabelle/HOL, a proof can take two forms: a low level sequence of \texttt{apply} steps or higher
level structured definition. Following is an example of a lemma that proves, using the low level
style, that the list of increasing natural numbers are ordered with respect to the usual comparison
operation:
*}

(* changed apply style proof for Isar one line proof*)
lemma "ordered (\<lambda>x (y :: nat). x < y) (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil))))"
  by (simp add: ordered.simps)

text {*
This proof is easily checked by a computer but very hard to read for a human. For this reason, the
alternative structured Isar proof language was designed to allow the writing of more human-friendly
proofs. Following is a theorem showing that, whenever the @{const ordered} function returns true for
a given predicate and list, the @{const ordered'} function will also return true:\footnote{In
Isabelle, every unbound term is implicitly universally quantified:
$n + 1 > n \: \equiv \: (\forall n. \ n + 1 > n)$.}
*}

lemma primrec_imp_inductive:
  "ordered f xs \<Longrightarrow> ordered' f xs"
proof (induction xs rule: list.induct)
  case Nil
  thus ?case by (auto intro: ordered'.intros)
next
  case (Cons y ys)
  thus ?case by (cases ys rule: list.exhaust) (auto intro: ordered'.intros)
qed

text {*
This proof is still easily checked by a computer but is also more readable for a human. It is easy
to see that the proof works by induction on the list @{term xs}, that the base case (@{const Nil})
is first proved and that in the inductive case (@{const Cons}), a cases analysis of the values the
argument @{term ys} can take is performed.

For a more comprehensive introduction to Isabelle/HOL, the reader is encourage to start with the
first part of the book \emph{Concrete Semantics} \cite{nipkow-klein-2014-concrete-semantics} and
continue, for a deeper understanding, with the more exhaustive tutorial
\cite{nipkow-et-al-2014-tutorial} distributed with the system.
*}

(*<*)
end
(*>*)


(*
  Author: Mohammad Abdulaziz, Fred Kurz
*)
theory SAS_Plus_Representation
imports State_Variable_Representation
begin

section "SAS+ Representation"

text \<open> We now continue by defining a concrete implementation of SAS+.\<close>

text \<open> SAS+ operators and SAS+ problems again use records. In contrast to STRIPS, the operator
effect is contracted into a single list however since we now potentially deal with more than two
possible values for each problem variable. \<close>

record  ('variable, 'domain) sas_plus_operator =
  precondition_of :: "('variable, 'domain) assignment list"
  effect_of :: "('variable, 'domain) assignment list"

record  ('variable, 'domain) sas_plus_problem =
  variables_of :: "'variable list" ("(_\<^sub>\<V>\<^sub>+)" [1000] 999)
  operators_of :: "('variable, 'domain) sas_plus_operator list" ("(_\<^sub>\<O>\<^sub>+)" [1000] 999)
  initial_of :: "('variable, 'domain) state" ("(_\<^sub>I\<^sub>+)" [1000] 999)
  goal_of :: "('variable, 'domain) state" ("(_\<^sub>G\<^sub>+)" [1000] 999)
  range_of :: "'variable \<rightharpoonup> 'domain list"

definition range_of':: "('variable, 'domain) sas_plus_problem \<Rightarrow> 'variable \<Rightarrow> 'domain set"  ("\<R>\<^sub>+ _ _" 52)
  where
  "range_of' \<Psi> v \<equiv>
     (case sas_plus_problem.range_of \<Psi> v of None \<Rightarrow> {}
           | Some as \<Rightarrow> set as)"

definition to_precondition
  :: "('variable, 'domain) sas_plus_operator \<Rightarrow> ('variable, 'domain) assignment list"
  where "to_precondition \<equiv> precondition_of"

definition to_effect
  :: "('variable, 'domain) sas_plus_operator \<Rightarrow> ('variable, 'domain) Effect"
  where "to_effect op \<equiv> [(v, a) . (v, a) \<leftarrow> effect_of op]"

type_synonym  ('variable, 'domain) sas_plus_plan
  = "('variable, 'domain) sas_plus_operator list"

type_synonym  ('variable, 'domain) sas_plus_parallel_plan
  = "('variable, 'domain) sas_plus_operator list list"

abbreviation  empty_operator
  :: "('variable, 'domain) sas_plus_operator" ("\<rho>")
  where "empty_operator \<equiv> \<lparr> precondition_of = [], effect_of = [] \<rparr>"

definition is_valid_operator_sas_plus
  :: "('variable, 'domain) sas_plus_problem  \<Rightarrow> ('variable, 'domain) sas_plus_operator \<Rightarrow> bool"
  where "is_valid_operator_sas_plus \<Psi> op \<equiv> let
      pre = precondition_of op
      ; eff = effect_of op
      ; vs = variables_of \<Psi>
      ; D = range_of \<Psi>
    in list_all (\<lambda>(v, a). ListMem v vs) pre
      \<and> list_all (\<lambda>(v, a). (D v \<noteq> None) \<and> ListMem a (the (D v))) pre
      \<and> list_all (\<lambda>(v, a). ListMem v vs) eff
      \<and> list_all (\<lambda>(v, a). (D v \<noteq> None) \<and> ListMem a (the (D v))) eff
      \<and> list_all (\<lambda>(v, a). list_all (\<lambda>(v', a'). v \<noteq> v' \<or> a = a') pre) pre
      \<and> list_all (\<lambda>(v, a). list_all (\<lambda>(v', a'). v \<noteq> v' \<or> a = a') eff) eff"

definition "is_valid_problem_sas_plus \<Psi>
  \<equiv> let ops = operators_of \<Psi>
      ; vs = variables_of \<Psi>
      ; I = initial_of \<Psi>
      ; G = goal_of \<Psi>
      ; D = range_of \<Psi>
    in list_all (\<lambda>v. D v \<noteq> None) vs
    \<and> list_all (is_valid_operator_sas_plus \<Psi>) ops
    \<and> (\<forall>v. I v \<noteq> None \<longleftrightarrow> ListMem v vs)
    \<and> (\<forall>v. I v \<noteq> None \<longrightarrow> ListMem (the (I v)) (the (D v)))
    \<and> (\<forall>v. G v \<noteq> None \<longrightarrow> ListMem v (variables_of \<Psi>))
    \<and> (\<forall>v. G v \<noteq> None \<longrightarrow> ListMem (the (G v)) (the (D v)))"

definition is_operator_applicable_in
  :: "('variable, 'domain) state
    \<Rightarrow> ('variable, 'domain) sas_plus_operator
    \<Rightarrow> bool"
  where "is_operator_applicable_in s op
    \<equiv> map_of (precondition_of op) \<subseteq>\<^sub>m s"

(* TODO rename execute_operator_in *)
definition execute_operator_sas_plus
  :: "('variable, 'domain) state
    \<Rightarrow> ('variable, 'domain) sas_plus_operator
    \<Rightarrow> ('variable, 'domain) state" (infixl "\<then>\<^sub>+" 52)
  where "execute_operator_sas_plus s op \<equiv> s ++ map_of (effect_of op)"

\<comment> \<open> Set up simp rules to keep use of local parameters transparent within proofs (i.e.
automatically substitute definitions). \<close>

lemma range_of_not_empty:
  "(sas_plus_problem.range_of \<Psi> v \<noteq> None \<and> sas_plus_problem.range_of \<Psi> v \<noteq> Some [])
    \<longleftrightarrow> (\<R>\<^sub>+ \<Psi> v) \<noteq> {}"
  apply (cases "sas_plus_problem.range_of \<Psi> v")
  by (auto simp add: SAS_Plus_Representation.range_of'_def)

lemma is_valid_operator_sas_plus_then:
  fixes \<Psi>::"('v,'d) sas_plus_problem"
  assumes "is_valid_operator_sas_plus \<Psi> op"
  shows "\<forall>(v, a) \<in> set (precondition_of op). v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>(v, a) \<in> set (precondition_of op). (\<R>\<^sub>+ \<Psi> v) \<noteq> {} \<and> a \<in> \<R>\<^sub>+ \<Psi> v"
    and "\<forall>(v, a) \<in> set (effect_of op). v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>(v, a) \<in> set (effect_of op). (\<R>\<^sub>+ \<Psi> v) \<noteq> {} \<and> a \<in> \<R>\<^sub>+ \<Psi> v"
    and "\<forall>(v, a) \<in> set (precondition_of op). \<forall>(v', a') \<in> set (precondition_of op). v \<noteq> v' \<or> a = a'"
    and "\<forall>(v, a) \<in> set (effect_of op).
      \<forall>(v', a') \<in> set (effect_of op). v \<noteq> v' \<or> a = a'"
proof -
  let ?vs = "sas_plus_problem.variables_of \<Psi>"
    and ?pre = "precondition_of op"
    and ?eff = "effect_of op"
    and ?D = "sas_plus_problem.range_of \<Psi>"
  have "\<forall>(v, a)\<in>set ?pre. v \<in> set ?vs"
    and "\<forall>(v, a)\<in>set ?pre.
          (?D v \<noteq> None) \<and>
          a \<in> set (the (?D v))"
    and "\<forall>(v, a)\<in>set ?eff. v \<in> set ?vs"
    and "\<forall>(v, a)\<in>set ?eff.
          (?D v \<noteq> None) \<and>
          a \<in> set (the (?D v))"
    and "\<forall>(v, a)\<in>set ?pre.
          \<forall>(v', a')\<in>set ?pre. v \<noteq> v' \<or> a = a'"
    and "\<forall>(v, a)\<in>set ?eff.
      \<forall>(v', a')\<in>set ?eff. v \<noteq> v' \<or> a = a'"
    using assms
    unfolding is_valid_operator_sas_plus_def Let_def list_all_iff ListMem_iff
    by meson+
  moreover have "\<forall>(v, a) \<in> set ?pre. v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>(v, a) \<in> set ?eff. v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>(v, a) \<in> set ?pre. \<forall>(v', a') \<in> set ?pre. v \<noteq> v' \<or> a = a'"
    and "\<forall>(v, a) \<in> set ?eff. \<forall>(v', a') \<in> set ?eff. v \<noteq> v' \<or> a = a'"
    using calculation
    unfolding variables_of_def
    by blast+
  moreover {
    have "\<forall>(v, a) \<in> set ?pre. (?D v \<noteq> None) \<and> a \<in> set (the (?D v))"
      using assms
      unfolding is_valid_operator_sas_plus_def Let_def list_all_iff ListMem_iff
      by argo
    hence "\<forall>(v, a) \<in> set ?pre. ((\<R>\<^sub>+ \<Psi> v) \<noteq> {}) \<and> a \<in> \<R>\<^sub>+ \<Psi> v"
      using range_of'_def
      by fastforce
  }
  moreover {
    have "\<forall>(v, a) \<in> set ?eff. (?D v \<noteq> None) \<and> a \<in> set (the (?D v))"
      using assms
      unfolding is_valid_operator_sas_plus_def Let_def list_all_iff ListMem_iff
      by argo
    hence "\<forall>(v, a) \<in> set ?eff. ((\<R>\<^sub>+ \<Psi> v) \<noteq> {}) \<and> a \<in> \<R>\<^sub>+ \<Psi> v"
      using range_of'_def
      by fastforce
  }
  ultimately show "\<forall>(v, a) \<in> set (precondition_of op). v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>(v, a) \<in> set (precondition_of op). (\<R>\<^sub>+ \<Psi> v) \<noteq> {} \<and> a \<in> \<R>\<^sub>+ \<Psi> v"
    and "\<forall>(v, a) \<in> set (effect_of op). v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>(v, a) \<in> set (effect_of op). (\<R>\<^sub>+ \<Psi> v) \<noteq> {} \<and> a \<in> \<R>\<^sub>+ \<Psi> v"
    and "\<forall>(v, a) \<in> set (precondition_of op). \<forall>(v', a') \<in> set (precondition_of op). v \<noteq> v' \<or> a = a'"
    and "\<forall>(v, a) \<in> set (effect_of op).
      \<forall>(v', a') \<in> set (effect_of op). v \<noteq> v' \<or> a = a'"
    by blast+
qed

(* TODO can be replaced by proof for sublocale? *)
lemma is_valid_problem_sas_plus_then:
  fixes \<Psi>::"('v,'d) sas_plus_problem"
  assumes "is_valid_problem_sas_plus \<Psi>"
  shows "\<forall>v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+). (\<R>\<^sub>+ \<Psi> v) \<noteq> {}"
    and "\<forall>op \<in> set ((\<Psi>)\<^sub>\<O>\<^sub>+). is_valid_operator_sas_plus \<Psi> op"
    and "dom ((\<Psi>)\<^sub>I\<^sub>+) = set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>v \<in> dom ((\<Psi>)\<^sub>I\<^sub>+). the (((\<Psi>)\<^sub>I\<^sub>+) v) \<in> \<R>\<^sub>+ \<Psi> v"
    and "dom ((\<Psi>)\<^sub>G\<^sub>+) \<subseteq> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>v \<in> dom ((\<Psi>)\<^sub>G\<^sub>+). the (((\<Psi>)\<^sub>G\<^sub>+) v) \<in> \<R>\<^sub>+ \<Psi> v"
proof -
  let ?vs = "sas_plus_problem.variables_of \<Psi>"
    and ?ops = "sas_plus_problem.operators_of \<Psi>"
    and ?I = "sas_plus_problem.initial_of \<Psi>"
    and ?G = "sas_plus_problem.goal_of \<Psi>"
    and ?D = "sas_plus_problem.range_of \<Psi>"
  {
    fix v
    have "(?D v \<noteq> None \<and> ?D v \<noteq> Some []) \<longleftrightarrow> ((\<R>\<^sub>+ \<Psi> v) \<noteq> {})"
      by (cases "?D v"; (auto simp: range_of'_def))
  } note nb = this
  have nb\<^sub>1: "\<forall>v \<in> set ?vs. ?D v \<noteq> None"
    and "\<forall>op \<in> set ?ops. is_valid_operator_sas_plus \<Psi> op"
    and "\<forall>v. (?I v \<noteq> None) = (v \<in> set ?vs)"
    and nb\<^sub>2: "\<forall>v. ?I v \<noteq> None \<longrightarrow> the (?I v) \<in> set (the (?D v))"
    and "\<forall>v. ?G v \<noteq> None \<longrightarrow> v \<in> set ?vs"
    and nb\<^sub>3: "\<forall>v. ?G v \<noteq> None \<longrightarrow> the (?G v) \<in> set (the (?D v))"
    using assms
    unfolding SAS_Plus_Representation.is_valid_problem_sas_plus_def Let_def
      list_all_iff ListMem_iff
    by argo+
  then have G3: "\<forall>op \<in> set ((\<Psi>)\<^sub>\<O>\<^sub>+). is_valid_operator_sas_plus \<Psi> op"
    and G4: "dom ((\<Psi>)\<^sub>I\<^sub>+) = set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and G5: "dom ((\<Psi>)\<^sub>G\<^sub>+) \<subseteq> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    unfolding variables_of_def operators_of_def
    by auto+
  moreover {
    fix v
    assume "v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    then have "?D v \<noteq> None"
      using nb\<^sub>1
      by force+
  } note G6 = this
  moreover {
    fix v
    assume "v \<in> dom ((\<Psi>)\<^sub>I\<^sub>+)"
    moreover have "((\<Psi>)\<^sub>I\<^sub>+) v \<noteq> None"
      using calculation
      by blast+
    moreover {
      have "v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
        using G4 calculation(1)
        by argo
      then have "sas_plus_problem.range_of \<Psi> v \<noteq> None"
        using range_of_not_empty
        unfolding range_of'_def
        using G6
        by fast+
      hence "set (the (?D v)) = \<R>\<^sub>+ \<Psi> v"
        by (simp add: \<open>sas_plus_problem.range_of \<Psi> v \<noteq> None\<close> option.case_eq_if range_of'_def)
    }
    ultimately have "the (((\<Psi>)\<^sub>I\<^sub>+) v) \<in> \<R>\<^sub>+ \<Psi> v"
      using nb\<^sub>2
      by force
  }
  moreover {
    fix v
    assume "v \<in> dom ((\<Psi>)\<^sub>G\<^sub>+)"
    then have "((\<Psi>)\<^sub>G\<^sub>+) v \<noteq> None"
      by blast
    moreover {
      have "v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
        using G5 calculation(1)
        by fast
      then have "sas_plus_problem.range_of \<Psi> v \<noteq> None"
        using range_of_not_empty
        using G6
        by fast+
      hence "set (the (?D v)) = \<R>\<^sub>+ \<Psi> v"
        by (simp add: \<open>sas_plus_problem.range_of \<Psi> v \<noteq> None\<close> option.case_eq_if range_of'_def)
    }
    ultimately have "the (((\<Psi>)\<^sub>G\<^sub>+) v) \<in> \<R>\<^sub>+ \<Psi> v"
      using nb\<^sub>3
      by auto
  }
  ultimately show "\<forall>v \<in> set ((\<Psi>)\<^sub>\<V>\<^sub>+). (\<R>\<^sub>+ \<Psi> v) \<noteq> {}"
    and "\<forall>op \<in> set((\<Psi>)\<^sub>\<O>\<^sub>+). is_valid_operator_sas_plus \<Psi> op"
    and "dom ((\<Psi>)\<^sub>I\<^sub>+) = set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>v \<in> dom ((\<Psi>)\<^sub>I\<^sub>+). the (((\<Psi>)\<^sub>I\<^sub>+) v) \<in> \<R>\<^sub>+ \<Psi> v"
    and "dom ((\<Psi>)\<^sub>G\<^sub>+) \<subseteq> set ((\<Psi>)\<^sub>\<V>\<^sub>+)"
    and "\<forall>v \<in> dom ((\<Psi>)\<^sub>G\<^sub>+). the (((\<Psi>)\<^sub>G\<^sub>+) v) \<in> \<R>\<^sub>+ \<Psi> v"
    by blast+
qed

end


(*******************************************************************************

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/Refinement.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Refinement.thy 132773 2016-12-09 15:30:22Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  Minimal infrastructure for invariants and refinements

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Models, Invariants and Refinements\<close>

theory Refinement imports Infra
begin

(******************************************************************************)
subsection \<open>Specifications, reachability, and behaviours.\<close>
(******************************************************************************)

text \<open>Transition systems are multi-pointed graphs.\<close>

record 's TS =
  init :: "'s set"
  trans :: "('s \<times> 's) set"

text \<open>The inductive set of reachable states.\<close>

inductive_set
  reach ::  "('s, 'a) TS_scheme \<Rightarrow> 's set"
  for T :: "('s, 'a) TS_scheme"
where
  r_init [intro]:  "s \<in> init T \<Longrightarrow> s \<in> reach T"
| r_trans [intro]: "\<lbrakk> (s, t) \<in> trans T; s \<in> reach T \<rbrakk> \<Longrightarrow> t \<in> reach T"

(* inductive_cases reach_invert: "t \<in> reach T" *)

subsubsection \<open>Finite behaviours\<close>
(******************************************************************************)

text \<open>Note that behaviours grow at the head of the list, i.e., the initial
state is at the end.\<close>

inductive_set
  beh :: "('s, 'a) TS_scheme \<Rightarrow> ('s list) set"
  for T :: "('s, 'a) TS_scheme"
where
  b_empty [iff]: "[] \<in> beh T"
| b_init [intro]: "s \<in> init T \<Longrightarrow> [s] \<in> beh T"
| b_trans [intro]: "\<lbrakk> s # b \<in> beh T; (s, t) \<in> trans T \<rbrakk> \<Longrightarrow> t # s # b \<in> beh T"

inductive_cases beh_non_empty: "s # b \<in> beh T"

text \<open>Behaviours are prefix closed.\<close>

lemma beh_immediate_prefix_closed:
  "s # b \<in> beh T \<Longrightarrow> b \<in> beh T"
by (erule beh_non_empty, auto)

lemma beh_prefix_closed:
  "c @ b \<in> beh T \<Longrightarrow> b \<in> beh T"
by (induct c, auto dest!: beh_immediate_prefix_closed)

text \<open>States in behaviours are exactly reachable.\<close>

lemma reach_equiv_beh_states: "reach T = \<Union> (set`(beh T))"
by (auto intro!: reach_in_beh beh_in_reach)

subsubsection \<open>Specifications, observability, and implementation\<close>
(******************************************************************************)

text \<open>Specifications add an observer function to transition systems.\<close>

record ('s, 'o) spec = "'s TS" +
  obs :: "'s \<Rightarrow> 'o"

lemma beh_obs_upd [simp]: "beh (S(| obs := x |)) = beh S"
by (safe) (erule beh.induct, auto)+

lemma reach_obs_upd [simp]: "reach (S(| obs := x |)) = reach S"
by (safe) (erule reach.induct, auto)+

text \<open>Observable behaviour and reachability.\<close>

definition
  obeh :: "('s, 'o) spec \<Rightarrow> ('o list) set" where
  "obeh S \<equiv> (map (obs S))`(beh S)"

definition
  oreach :: "('s, 'o) spec \<Rightarrow> 'o set" where
  "oreach S \<equiv> (obs S)`(reach S)"

lemma oreach_equiv_obeh_states:
  "oreach S = \<Union> (set`(obeh S))"
by (auto simp add: reach_equiv_beh_states oreach_def obeh_def)

lemma obeh_pi_translation:
  "(map pi)`(obeh S) = obeh (S(| obs := pi o (obs S) |))"
by (auto simp add: obeh_def image_comp)

lemma oreach_pi_translation:
  "pi`(oreach S) = oreach (S(| obs := pi o (obs S) |))"
by (auto simp add: oreach_def)

text \<open>A predicate $P$ on the states of a specification is \emph{observable}
if it cannot distinguish between states yielding the same observation.
Equivalently, $P$ is observable if it is the inverse image under the
observation function of a predicate on observations.\<close>

definition
  observable :: "['s \<Rightarrow> 'o, 's set] \<Rightarrow> bool"
where
  "observable ob P \<equiv> \<forall>s s'. ob s = ob s' \<longrightarrow> s' \<in> P \<longrightarrow> s \<in> P"

definition
  observable2 :: "['s \<Rightarrow> 'o, 's set] \<Rightarrow> bool"
where
  "observable2 ob P \<equiv> \<exists>Q. P = ob-`Q"

definition
  observable3 :: "['s \<Rightarrow> 'o, 's set] \<Rightarrow> bool"
where
  "observable3 ob P \<equiv> ob-`ob`P \<subseteq> P"    \<comment> \<open>other direction holds trivially\<close>

lemma observableE [elim]:
  "\<lbrakk>observable ob P; ob s = ob s'; s' \<in> P\<rbrakk> \<Longrightarrow> s \<in> P"
by (unfold observable_def) (fast)

lemma observable2_equiv_observable: "observable2 ob P = observable ob P"
by (unfold observable_def observable2_def) (auto)

lemma observable3_equiv_observable2: "observable3 ob P = observable2 ob P"
by (unfold observable3_def observable2_def) (auto)

lemma observable_id [simp]: "observable id P"
by (simp add: observable_def)

text \<open>The set extension of a function @{term "ob"} is the left adjoint of
a Galois connection on the powerset lattices over domain and range of @{term "ob"}
where the right adjoint is the inverse image function.\<close>

declare image_vimage_subset [simp, intro]
declare vimage_image_subset [simp, intro]

text \<open>Similar but "reversed" (wrt to adjointness) relationships only hold under
additional conditions.\<close>

lemma image_r_vimage_l: "\<lbrakk> Q \<subseteq> ob`P; observable ob P \<rbrakk> \<Longrightarrow> ob-`Q \<subseteq> P"
by (auto)

lemma vimage_l_image_r: "\<lbrakk> ob-`Q \<subseteq> P; Q \<subseteq> range ob \<rbrakk> \<Longrightarrow> Q \<subseteq> ob`P"
by (drule image_mono [where f=ob], auto)

text \<open>Internal and external invariants\<close>

lemma external_from_internal_invariant:
  "\<lbrakk> reach S \<subseteq> P; (obs S)`P \<subseteq> Q \<rbrakk>
  \<Longrightarrow> oreach S \<subseteq> Q"
by (auto simp add: oreach_def)

lemma external_from_internal_invariant_vimage:
  "\<lbrakk> reach S \<subseteq> P; P \<subseteq> (obs S)-`Q \<rbrakk>
  \<Longrightarrow> oreach S \<subseteq> Q"
by (erule external_from_internal_invariant) (auto)

lemma external_to_internal_invariant_vimage:
  "\<lbrakk> oreach S \<subseteq> Q; (obs S)-`Q \<subseteq> P \<rbrakk>
  \<Longrightarrow> reach S \<subseteq> P"
by (auto simp add: oreach_def)

lemma external_to_internal_invariant:
  "\<lbrakk> oreach S \<subseteq> Q; Q \<subseteq> (obs S)`P; observable (obs S) P \<rbrakk>
  \<Longrightarrow> reach S \<subseteq> P"
by (erule external_to_internal_invariant_vimage) (auto)

lemma external_equiv_internal_invariant_vimage:
  "\<lbrakk> P = (obs S)-`Q \<rbrakk>
  \<Longrightarrow> (oreach S \<subseteq> Q) = (reach S \<subseteq> P)"
by (fast intro: external_from_internal_invariant_vimage
                external_to_internal_invariant_vimage
         del: subsetI)

lemma external_equiv_internal_invariant:
  "\<lbrakk> (obs S)`P = Q; observable (obs S) P \<rbrakk>
  \<Longrightarrow> (oreach S \<subseteq> Q) = (reach S \<subseteq> P)"
by (rule external_equiv_internal_invariant_vimage) (auto)

text \<open>Our notion of implementation is inclusion of observable behaviours.\<close>

definition
  implements :: "['p \<Rightarrow> 'o, ('s, 'o) spec, ('t, 'p) spec] \<Rightarrow> bool" where
  "implements pi Sa Sc \<equiv> (map pi)`(obeh Sc) \<subseteq> obeh Sa"

text \<open>Reflexivity and transitivity\<close>

lemma implements_refl: "implements id S S"
by (auto simp add: implements_def)

lemma implements_trans:
  "\<lbrakk> implements pi1 S1 S2; implements pi2 S2 S3 \<rbrakk>
  \<Longrightarrow> implements (pi1 o pi2) S1 S3"
by (fastforce simp add: implements_def image_subset_iff)

text \<open>Preservation of external invariants\<close>

lemma implements_oreach:
  "implements pi Sa Sc \<Longrightarrow> pi`(oreach Sc) \<subseteq> oreach Sa"
by (auto simp add: implements_def oreach_equiv_obeh_states dest!: subsetD)

lemma external_invariant_preservation:
  "\<lbrakk> oreach Sa \<subseteq> Q; implements pi Sa Sc \<rbrakk>
  \<Longrightarrow> pi`(oreach Sc) \<subseteq> Q"
by (rule subset_trans [OF implements_oreach]) (auto)

lemma external_invariant_translation:
  "\<lbrakk> oreach Sa \<subseteq> Q; pi-`Q \<subseteq> P; implements pi Sa Sc \<rbrakk>
  \<Longrightarrow> oreach Sc \<subseteq> P"
apply (rule subset_trans [OF vimage_image_subset, of pi])
apply (rule subset_trans [where B="pi-`Q"])
apply (intro vimage_mono external_invariant_preservation, auto)
done

text \<open>Preservation of internal invariants\<close>

lemma internal_invariant_translation:
  "\<lbrakk> reach Sa \<subseteq> Pa; Pa \<subseteq> obs Sa -` Qa; pi -` Qa \<subseteq> Q; obs S -` Q \<subseteq> P;
     implements pi Sa S \<rbrakk>
  \<Longrightarrow> reach S \<subseteq> P"
by (rule external_from_internal_invariant_vimage [
      THEN external_invariant_translation,
      THEN external_to_internal_invariant_vimage])

(******************************************************************************)
subsection \<open>Invariants\<close>
(******************************************************************************)

text \<open>First we define Hoare triples over transition relations and then
we derive proof rules to establish invariants.\<close>

subsubsection \<open>Hoare triples\<close>
(******************************************************************************)

definition
  PO_hoare :: "['s set, ('s \<times> 's) set, 's set] \<Rightarrow> bool"
     ("(3{_} _ {> _})" [0, 0, 0] 90)
where
  "{pre} R {> post} \<equiv> R``pre \<subseteq> post"

lemmas PO_hoare_defs = PO_hoare_def Image_def

lemma "{P} R {> Q} = (\<forall>s t. s \<in> P \<longrightarrow> (s, t) \<in> R \<longrightarrow> t \<in> Q)"
by (auto simp add: PO_hoare_defs)

text \<open>Some essential facts about Hoare triples.\<close>

lemma hoare_conseq_left [intro]:
  "\<lbrakk> {P'} R {> Q}; P \<subseteq> P' \<rbrakk>
  \<Longrightarrow> {P} R {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_conseq_right:
  "\<lbrakk> {P} R {> Q'}; Q' \<subseteq> Q \<rbrakk>
  \<Longrightarrow> {P} R {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_false_left [simp]:
  "{{}} R {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_true_right [simp]:
  "{P} R {> UNIV}"
by (auto simp add: PO_hoare_defs)

lemma hoare_conj_right [intro!]:
  "\<lbrakk> {P} R {> Q1}; {P} R {> Q2} \<rbrakk>
  \<Longrightarrow> {P} R {> Q1 \<inter> Q2}"
by (auto simp add: PO_hoare_defs)

text \<open>Special transition relations.\<close>

lemma hoare_stop [simp, intro!]:
  "{P} {} {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_skip [simp, intro!]:
  "P \<subseteq> Q \<Longrightarrow> {P} Id {> Q}"
by (auto simp add: PO_hoare_defs)

lemma hoare_trans_Un [iff]:
  "{P} R1 \<union> R2 {> Q} = ({P} R1 {> Q} \<and> {P} R2 {> Q})"
by (auto simp add: PO_hoare_defs)

lemma hoare_trans_UN [iff]:
  "{P} \<Union> x. R x {> Q} = (\<forall>x. {P} R x {> Q})"
by (auto simp add: PO_hoare_defs)

subsubsection \<open>Characterization of reachability\<close>
(******************************************************************************)

lemma reach_init: "reach T \<subseteq> I \<Longrightarrow> init T \<subseteq> I"
by (auto dest: subsetD)

lemma reach_trans: "reach T \<subseteq> I \<Longrightarrow> {reach T} trans T {> I}"
by (auto simp add: PO_hoare_defs)

text \<open>Useful consequences.\<close>

corollary init_reach [iff]: "init T \<subseteq> reach T"
by (rule reach_init, simp)

corollary trans_reach [iff]: "{reach T} trans T {> reach T}"
by (rule reach_trans, simp)

subsubsection \<open>Invariant proof rules\<close>
(******************************************************************************)

text \<open>Basic proof rule for invariants.\<close>

lemma inv_rule_basic:
  "\<lbrakk> init T \<subseteq> P; {P} (trans T) {> P} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> P"
by (safe, erule reach.induct, auto simp add: PO_hoare_def)

text \<open>General invariant proof rule. This rule is complete (set
@{term "I = reach T"}).\<close>

lemma inv_rule:
  "\<lbrakk> init T \<subseteq> I; I \<subseteq> P; {I} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> P"
apply (rule subset_trans, auto)              \<comment> \<open>strengthen goal\<close>
apply (erule reach.induct, auto simp add: PO_hoare_def)
done

text \<open>The following rule is equivalent to the previous one.\<close>

lemma INV_rule:
  "\<lbrakk> init T \<subseteq> I; {I \<inter> reach T} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> I"
by (safe, erule reach.induct, auto simp add: PO_hoare_defs)

text \<open>Proof of equivalence.\<close>

lemma inv_rule_from_INV_rule:
  "\<lbrakk> init T \<subseteq> I; I \<subseteq> P; {I} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> P"
apply (rule subset_trans, auto del: subsetI)
apply (rule INV_rule, auto)
done

lemma INV_rule_from_inv_rule:
  "\<lbrakk> init T \<subseteq> I; {I \<inter> reach T} (trans T) {> I} \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> I"
by (rule_tac I="I \<inter> reach T" in inv_rule, auto)

text \<open>Incremental proof rule for invariants using auxiliary invariant(s).
This rule might have become obsolete by addition of $INV\_rule$.\<close>

lemma inv_rule_incr:
  "\<lbrakk> init T \<subseteq> I; {I \<inter> J} (trans T) {> I}; reach T \<subseteq> J \<rbrakk>
  \<Longrightarrow> reach T \<subseteq> I"
by (rule INV_rule, auto)

(******************************************************************************)
subsection \<open>Refinement\<close>
(******************************************************************************)

text \<open>Our notion of refinement is simulation. We first define a general
notion of relational Hoare tuple, which we then use to define the refinement
proof obligation.  Finally, we show that observation-consistent refinement
of specifications implies the implementation relation between them.\<close>

subsubsection \<open>Relational Hoare tuples\<close>
(******************************************************************************)

text \<open>Relational Hoare tuples formalize the following generalized simulation
diagram:

\begin{verbatim}
                           o -- Ra --> o
                           |           |
                          pre         post
                           |           |
                           v           V
                           o -- Rc --> o
\end{verbatim}

Here, $Ra$ and $Rc$ are the abstract and concrete transition relations,
and $pre$ and $post$ are the pre- and post-relations.
(In the definiton below, the operator @{term "(O)"} stands for relational
composition, which is defined as follows: @{thm relcomp_def [no_vars]}.)\<close>

definition
  PO_rhoare ::
    "[('s \<times> 't) set, ('s \<times> 's) set, ('t \<times> 't) set, ('s \<times> 't) set] \<Rightarrow> bool"
     ("(4{_} _, _ {> _})" [0, 0, 0] 90)
where
  "{pre} Ra, Rc {> post} \<equiv> pre O Rc \<subseteq> Ra O post"

lemmas PO_rhoare_defs = PO_rhoare_def relcomp_unfold

text \<open>Facts about relational Hoare tuples.\<close>

lemma relhoare_conseq_left [intro]:
  "\<lbrakk> {pre'} Ra, Rc {> post}; pre \<subseteq> pre' \<rbrakk>
  \<Longrightarrow> {pre} Ra, Rc {> post}"
by (auto simp add: PO_rhoare_defs dest!: subsetD)

lemma relhoare_conseq_right:                    \<comment> \<open>do NOT declare [intro]\<close>
  "\<lbrakk> {pre} Ra, Rc {> post'}; post' \<subseteq> post \<rbrakk>
  \<Longrightarrow> {pre} Ra, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_false_left [simp]:               \<comment> \<open>do NOT declare [intro]\<close>
  "{ {} } Ra, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_true_right [simp]:                \<comment> \<open>not true in general\<close>
  "{pre} Ra, Rc {> UNIV} = (Domain (pre O Rc) \<subseteq> Domain Ra)"
by (auto simp add: PO_rhoare_defs)

lemma Domain_rel_comp [intro]:
  "Domain pre \<subseteq> R \<Longrightarrow> Domain (pre O Rc) \<subseteq> R"
by (auto simp add: Domain_def)

lemma rel_hoare_skip [iff]: "{R} Id, Id {> R}"
by (auto simp add: PO_rhoare_def)

text \<open>Reflexivity and transitivity.\<close>

lemma relhoare_refl [simp]: "{Id} R, R {> Id}"
by (auto simp add: PO_rhoare_defs)

lemma rhoare_trans:
  "\<lbrakk> {R1} T1, T2 {> R1}; {R2} T2, T3 {> R2} \<rbrakk>
  \<Longrightarrow> {R1 O R2} T1, T3 {> R1 O R2}"
apply (auto simp add: PO_rhoare_def del: subsetI)
apply (drule subset_refl [THEN relcomp_mono, where r=R1])
apply (drule subset_refl [THEN [2] relcomp_mono, where s=R2])
apply (auto simp add: O_assoc del: subsetI)
done

text \<open>Conjunction in the post-relation cannot be split in general.  However,
here are two useful special cases.  In the first case the abstract transtition
relation is deterministic and in the second case one conjunct is a cartesian
product of two state predicates.\<close>

lemma relhoare_conj_right_det:
  "\<lbrakk> {pre} Ra, Rc {> post1}; {pre} Ra, Rc {> post2};
     single_valued Ra \<rbrakk>                           \<comment> \<open>only for deterministic \<open>Ra\<close>!\<close>
  \<Longrightarrow> {pre} Ra, Rc {> post1 \<inter> post2}"
by (auto simp add: PO_rhoare_defs dest: single_valuedD dest!: subsetD)

lemma relhoare_conj_right_cartesian [intro]:
  "\<lbrakk> {Domain pre} Ra {> I}; {Range pre} Rc {> J};
     {pre} Ra, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} Ra, Rc {> post \<inter> I \<times> J}"
by (force simp add: PO_rhoare_defs PO_hoare_defs Domain_def Range_def)

text \<open>Separate rule for cartesian products.\<close>

corollary relhoare_cartesian:
  "\<lbrakk> {Domain pre} Ra {> I}; {Range pre} Rc {> J};
     {pre} Ra, Rc {> post} \<rbrakk>                      \<comment> \<open>any post, including \<open>UNIV\<close>!\<close>
  \<Longrightarrow> {pre} Ra, Rc {> I \<times> J}"
by (auto intro: relhoare_conseq_right)

text \<open>Unions of transition relations.\<close>

lemma relhoare_concrete_Un [simp]:
  "{pre} Ra, Rc1 \<union> Rc2 {> post}
   = ({pre} Ra, Rc1 {> post} \<and> {pre} Ra, Rc2 {> post})"
apply (auto simp add: PO_rhoare_defs)
apply (auto dest!: subsetD)
done

lemma relhoare_concrete_UN [simp]:
  "{pre} Ra, \<Union>x. Rc x {> post} = (\<forall>x. {pre} Ra, Rc x {> post})"
apply (auto simp add: PO_rhoare_defs)
apply (auto dest!: subsetD)
done

lemma relhoare_abstract_Un_left [intro]:
  "\<lbrakk> {pre} Ra1, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} Ra1 \<union> Ra2, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_abstract_Un_right [intro]:
  "\<lbrakk> {pre} Ra2, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} Ra1 \<union> Ra2, Rc {> post}"
by (auto simp add: PO_rhoare_defs)

lemma relhoare_abstract_UN [intro!]:   \<comment> \<open>might be too aggressive?\<close>
  "\<lbrakk> {pre} Ra x, Rc {> post} \<rbrakk>
  \<Longrightarrow> {pre} \<Union>x. Ra x, Rc {> post}"
apply (auto simp add: PO_rhoare_defs)
apply (auto dest!: subsetD)
done

subsubsection \<open>Refinement proof obligations\<close>
(******************************************************************************)

text \<open>A transition system refines another one if the initial states and the
transitions are refined.
Initial state refinement means that for each concrete initial state there is
a related abstract one. Transition refinement means that the simulation
relation is preserved (as expressed by a relational Hoare tuple).
\<close>

definition
  PO_refines ::
    "[('s \<times> 't) set, ('s, 'a) TS_scheme, ('t, 'b) TS_scheme] \<Rightarrow> bool"
where
  "PO_refines R Ta Tc \<equiv> (
       init Tc \<subseteq> R``(init Ta)
     \<and> {R} (trans Ta), (trans Tc) {> R}
  )"

lemma PO_refinesE [elim]:
  "\<lbrakk> PO_refines R Ta Tc; \<lbrakk> init Tc \<subseteq> R``(init Ta); {R} (trans Ta), (trans Tc) {> R} \<rbrakk> \<Longrightarrow> P \<rbrakk>
 \<Longrightarrow> P"
by (simp add: PO_refines_def)

text \<open>Basic refinement rule. This is just an introduction rule for the
definition.\<close>

lemma refine_basic:
  "\<lbrakk> init Tc \<subseteq> R``(init Ta); {R} (trans Ta), (trans Tc) {> R} \<rbrakk>
  \<Longrightarrow> PO_refines R Ta Tc"
by (simp add: PO_refines_def)

text \<open>The following proof rule uses individual invariants @{term "I"}
and @{term "J"} of the concrete and abstract systems to strengthen the
simulation relation $R$.

The hypotheses state that these state predicates are indeed invariants.
Note that the pre-condition of the invariant preservation hypotheses for
@{term "I"} and @{term "J"} are strengthened by adding the predicates
@{term "Domain (R \<inter> UNIV \<times> J)"} and @{term "Range (R \<inter> I \<times> UNIV)"},
respectively.  In particular, the latter predicate may be essential, if a
concrete invariant depends on the simulation relation and an abstract invariant,
i.e. to "transport" abstract invariants to the concrete system.\<close>

lemma refine_init_using_invariants:
  "\<lbrakk> init Tc \<subseteq> R``(init Ta); init Ta \<subseteq> I; init Tc \<subseteq> J \<rbrakk>
  \<Longrightarrow> init Tc \<subseteq> (R \<inter> I \<times> J)``(init Ta)"
by (auto simp add: Image_def dest!: bspec subsetD)

lemma refine_trans_using_invariants:
  "\<lbrakk> {R \<inter> I \<times> J} (trans Ta), (trans Tc) {> R};
     {I \<inter> Domain (R \<inter> UNIV \<times> J)} (trans Ta) {> I};
     {J \<inter> Range (R \<inter> I \<times> UNIV)} (trans Tc) {> J} \<rbrakk>
  \<Longrightarrow> {R \<inter> I \<times> J} (trans Ta), (trans Tc) {> R  \<inter> I \<times> J}"
by (rule relhoare_conj_right_cartesian) (auto)

text \<open>This is our main rule for refinements.\<close>

lemma refine_using_invariants:
  "\<lbrakk> {R \<inter> I \<times> J} (trans Ta), (trans Tc) {> R};
     {I \<inter> Domain (R \<inter> UNIV \<times> J)} (trans Ta) {> I};
     {J \<inter> Range (R \<inter> I \<times> UNIV)} (trans Tc) {> J};
     init Tc \<subseteq> R``(init Ta);
     init Ta \<subseteq> I; init Tc \<subseteq> J \<rbrakk>
  \<Longrightarrow> PO_refines (R \<inter> I \<times> J) Ta Tc"
by (unfold PO_refines_def)
   (intro refine_init_using_invariants refine_trans_using_invariants conjI)

subsubsection \<open>Deriving invariants from refinements\<close>
(******************************************************************************)

text \<open>Some invariants can only be proved after the simulation has been
established, because they depend on the simulation relation and some abstract
invariants.  Here is a rule to derive invariant theorems from the refinement.\<close>

lemma PO_refines_implies_Range_trans:
  "PO_refines R Ta Tc \<Longrightarrow> {Range R} trans Tc {> Range R}"
by (auto simp add: PO_refines_def PO_rhoare_def PO_hoare_def)

lemma PO_refines_implies_Range_invariant:
  "PO_refines R Ta Tc \<Longrightarrow> reach Tc \<subseteq> Range R"
by (rule INV_rule)
   (auto intro!: PO_refines_implies_Range_init
                 PO_refines_implies_Range_trans)

text \<open>The following rules are more useful in proofs.\<close>

corollary INV_init_from_refinement:
  "\<lbrakk> PO_refines R Ta Tc; Range R \<subseteq> I \<rbrakk>
  \<Longrightarrow> init Tc \<subseteq> I"
by (drule PO_refines_implies_Range_init, auto)

corollary INV_trans_from_refinement:
  "\<lbrakk> PO_refines R Ta Tc; K \<subseteq> Range R; Range R \<subseteq> I \<rbrakk>
  \<Longrightarrow> {K} trans Tc {> I}"
apply (drule PO_refines_implies_Range_trans)
apply (auto intro: hoare_conseq_right)
done

corollary INV_from_refinement:
  "\<lbrakk> PO_refines R Ta Tc; Range R \<subseteq> I \<rbrakk>
  \<Longrightarrow> reach Tc \<subseteq> I"
by (drule PO_refines_implies_Range_invariant, fast)

subsubsection \<open>Refinement of specifications\<close>
(******************************************************************************)

text \<open>Lift relation membership to finite sequences\<close>

inductive_set
  seq_lift :: "('s \<times> 't) set \<Rightarrow> ('s list \<times> 't list) set"
  for R :: "('s \<times> 't) set"
where
  sl_nil [iff]: "([], []) \<in> seq_lift R"
| sl_cons [intro]:
    "\<lbrakk> (xs, ys) \<in> seq_lift R; (x, y) \<in> R \<rbrakk> \<Longrightarrow> (x#xs, y#ys) \<in> seq_lift R"

inductive_cases sl_cons_right_invert: "(ba', t # bc) \<in> seq_lift R"

text \<open>For each concrete behaviour there is a related abstract one.\<close>

lemma behaviour_refinement:
  "\<lbrakk> PO_refines R Ta Tc; bc \<in> beh Tc\<rbrakk>
  \<Longrightarrow> \<exists>ba \<in> beh Ta. (ba, bc) \<in> seq_lift R"
apply (erule beh.induct, auto)
  \<comment> \<open>case: singleton\<close>
  apply (clarsimp simp add: PO_refines_def Image_def)
  apply (drule subsetD, auto)

  \<comment> \<open>case: cons; first construct related abstract state\<close>
  apply (erule sl_cons_right_invert, clarsimp)
  apply (rename_tac s bc s' ba t)
  \<comment> \<open>now construct abstract transition\<close>
  apply (auto simp add: PO_refines_def PO_rhoare_def)
  apply (thin_tac "X \<subseteq> Y" for X Y)
  apply (drule subsetD, auto)
done

text \<open>Observation consistency of a relation is defined using a mediator
function @{term "pi"} to abstract the concrete observation.  This allows us
to also refine the observables as we move down a refinement branch.
\<close>

definition
  obs_consistent ::
    "[('s \<times> 't) set, 'p \<Rightarrow> 'o, ('s, 'o) spec, ('t, 'p) spec] \<Rightarrow> bool"
where
  "obs_consistent R pi Sa Sc \<equiv> (\<forall>s t. (s, t) \<in> R \<longrightarrow> pi (obs Sc t) = obs Sa s)"

lemma obs_consistent_refl [iff]: "obs_consistent Id id S S"
by (simp add: obs_consistent_def)

lemma obs_consistent_trans [intro]:
  "\<lbrakk> obs_consistent R1 pi1 S1 S2; obs_consistent R2 pi2 S2 S3 \<rbrakk>
  \<Longrightarrow> obs_consistent (R1 O R2) (pi1 o pi2) S1 S3"
by (auto simp add: obs_consistent_def)

lemma obs_consistent_empty: "obs_consistent {} pi Sa Sc"
by (auto simp add: obs_consistent_def)

lemma obs_consistent_conj2 [intro]:
  "obs_consistent R pi Sa Sc \<Longrightarrow> obs_consistent (R' \<inter> R) pi Sa Sc"
by (auto simp add: obs_consistent_def)

lemma obs_consistent_behaviours:
  "\<lbrakk> obs_consistent R pi Sa Sc; bc \<in> beh Sc; ba \<in> beh Sa; (ba, bc) \<in> seq_lift R\<rbrakk>
  \<Longrightarrow> map pi (map (obs Sc) bc) = map (obs Sa) ba"
by (erule seq_lift.induct) (auto simp add: obs_consistent_def)

text \<open>Definition of refinement proof obligations.\<close>

definition
  refines ::
    "[('s \<times> 't) set, 'p \<Rightarrow> 'o, ('s, 'o) spec, ('t, 'p) spec] \<Rightarrow> bool"
where
  "refines R pi Sa Sc \<equiv> obs_consistent R pi Sa Sc \<and> PO_refines R Sa Sc"

lemmas refines_defs =
  refines_def PO_refines_def

lemma refinesI:
  "\<lbrakk> PO_refines R Sa Sc; obs_consistent R pi Sa Sc \<rbrakk>
  \<Longrightarrow> refines R pi Sa Sc"
by (simp add: refines_def)

lemma refinesE [elim]:
  "\<lbrakk> refines R pi Sa Sc; \<lbrakk> PO_refines R Sa Sc; obs_consistent R pi Sa Sc \<rbrakk> \<Longrightarrow> P \<rbrakk>
  \<Longrightarrow> P"
by (simp add: refines_def)

text \<open>Reflexivity and transitivity of refinement.\<close>

lemma refinement_reflexive: "refines Id id S S"
by (auto simp add: refines_defs)

lemma refinement_transitive:
  "\<lbrakk> refines R1 pi1 S1 S2; refines R2 pi2 S2 S3 \<rbrakk>
  \<Longrightarrow> refines (R1 O R2) (pi1 o pi2) S1 S3"
apply (auto simp add: refines_defs del: subsetI
            intro: rhoare_trans)
apply (fastforce dest: Image_mono)
done

text \<open>Soundness of refinement for proving implementation\<close>

lemma observable_behaviour_refinement:
  "\<lbrakk> refines R pi Sa Sc; bc \<in> obeh Sc \<rbrakk> \<Longrightarrow> map pi bc \<in> obeh Sa"
by (auto simp add: refines_def obeh_def image_def
         dest!: behaviour_refinement obs_consistent_behaviours)

theorem refinement_soundness:
  "refines R pi Sa Sc \<Longrightarrow> implements pi Sa Sc"
by (auto simp add: implements_def
         elim!: observable_behaviour_refinement)

text \<open>Extended versions of refinement proof rules including observations\<close>

lemmas Refinement_basic = refine_basic [THEN refinesI]
lemmas Refinement_using_invariants = refine_using_invariants [THEN refinesI]

lemma refines_reachable_strengthening:
  "refines R pi Sa Sc \<Longrightarrow> refines (R \<inter> reach Sa \<times> reach Sc) pi Sa Sc"
by (auto intro!: Refinement_using_invariants)

text \<open>Inhertitance of internal invariants through refinements\<close>

lemma INV_init_from_Refinement:
  "\<lbrakk>refines R pi Sa Sc; Range R \<subseteq> I\<rbrakk> \<Longrightarrow> init Sc \<subseteq> I"
by (blast intro: INV_init_from_refinement)

lemma INV_trans_from_Refinement:
  " \<lbrakk>refines R pi Sa Sc; K \<subseteq> Range R; Range R \<subseteq> I\<rbrakk> \<Longrightarrow> {K} TS.trans Sc {> I}"
by (blast intro: INV_trans_from_refinement)

lemma INV_from_Refinement_basic:
  "\<lbrakk> refines R pi Sa Sc; Range R \<subseteq> I \<rbrakk> \<Longrightarrow> reach Sc \<subseteq> I"
by (rule INV_from_refinement) blast

lemma INV_from_Refinement_using_invariants:
  assumes "refines R pi Sa Sc" "Range (R \<inter> I \<times> J) \<subseteq> K"   \<comment> \<open>EQUIV: \<open>R``I \<inter> J\<close>\<close>
          "reach Sa \<subseteq> I" "reach Sc \<subseteq> J"
  shows "reach Sc \<subseteq> K"
proof (rule INV_from_Refinement_basic)
  show "refines (R \<inter> reach Sa \<times> reach Sc) pi Sa Sc" using assms(1)
    by (rule refines_reachable_strengthening)
next
  show "Range (R \<inter> reach Sa \<times> reach Sc) \<subseteq> K" using assms(2-4) by blast
qed

end