           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               November 2004               |
            |                   June 2005  (modified)   |
            |                   July 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Infra_pair
imports Infra_order
begin

(*****************************************************
                         Pair
 *****************************************************)

 (* Isabelle 2016
consts
  pair_fun :: "('x => 'y) => ('x => 'z) => ('x => ('y * 'z))"
                                           ("(2_ **/ _)" [51,52] 52)
defs
  pair_fun_def : "f ** g == (%x. (f x, g x))"
*)

definition
  pair_fun :: "('x => 'y) => ('x => 'z) => ('x => ('y * 'z))"
                                           ("(2_ **/ _)" [51,52] 52)
  where "f ** g == (%x. (f x, g x))"

(*** lemmas ***)

lemma fst_pair_fun[simp]: "fst o (f ** g) = f"
by (simp add: fun_eq_iff pair_fun_def)
(* by (simp add: expand_fun_eq pair_fun_def) *)

lemma snd_pair_fun[simp]: "snd o (f ** g) = g"
by (simp add: fun_eq_iff pair_fun_def)
(* by (simp add: expand_fun_eq pair_fun_def) *)

lemma pair_eq_decompo:
  "ALL (xc::('x * 'y)) (yc::('x * 'y)).
      (xc = yc) = ((fst xc = fst yc) & (snd xc = snd yc))"
by (simp)

lemma pair_neq_decompo:
  "ALL (xc::('x * 'y)) (yc::('x * 'y)).
      (xc ~= yc) = ((fst xc ~= fst yc) | (snd xc ~= snd yc))"
by (simp)

(*******************************
         <= in pair
 *******************************)

instantiation prod :: (order,order) ord
(* instantiation "*" :: (order,order) ord  *)
begin
definition
  order_pair_def:
     "xc <= yc  ==  (fst xc <= fst yc) & (snd xc <= snd yc)"
definition
  order_less_pair_def:
     "xc <  yc  ==  (fst xc <= fst yc) & (snd xc <=  snd yc) &
                   ((fst xc ~= fst yc) | (snd xc ~=  snd yc))"
instance ..
end

(*
instance "*" :: (order,order) ord
by (intro_classes)

defs
  order_pair_def:
     "xc <= yc  ==  (fst xc <= fst yc) & (snd xc <= snd yc)"
  order_less_pair_def:
     "xc <  yc  ==  (fst xc <= fst yc) & (snd xc <=  snd yc) &
                   ((fst xc ~= fst yc) | (snd xc ~=  snd yc))"
*)

(*** order in pair ***)

instance prod :: (order,order) order
(* instance * :: (order,order) order *)
apply (intro_classes)
apply (unfold order_pair_def order_less_pair_def)
apply (auto simp add: pair_neq_decompo)
done

(*** LUB is decomposed for * ***)

(* only if *)

lemma pair_LUB_decompo_fst_only_if:
  "xc isLUB (Xc::('x::order * 'y::order) set)
   ==> (fst xc isLUB fst ` Xc)"
apply (simp add: isLUB_def isUB_def)
apply (simp add: image_def)
apply (rule conjI)

      (* UB *)
apply (intro allI impI)
apply (simp add: order_pair_def)
apply (erule bexE)
apply (elim conjE)
apply (drule_tac x="fst x" in spec)
apply (drule_tac x="snd x" in spec)
apply (simp)

      (* LUB *)
apply (intro allI impI)
apply (simp add: order_pair_def)
apply (elim conjE)
apply (rotate_tac -1)
apply (drule_tac x="y" in spec)
apply (rotate_tac -1)
apply (drule_tac x="snd xc" in spec)
apply (drule mp)

 apply (intro allI impI)
 apply (drule_tac x="a" in spec)
 apply (drule mp)
  apply (rule_tac x="(a, b)" in bexI, simp)
 apply (simp)

 apply (drule_tac x="a" in spec)
 apply (drule_tac x="b" in spec)
 apply (simp)
 apply (simp)
done

lemma pair_LUB_decompo_snd_only_if:
  "xc isLUB (Xc::('x::order * 'y::order) set)
   ==> (snd xc isLUB snd ` Xc)"
apply (simp add: isLUB_def isUB_def)
apply (simp add: image_def)
apply (rule conjI)

      (* UB *)
apply (intro allI impI)
apply (simp add: order_pair_def)
apply (erule bexE)
apply (elim conjE)
apply (drule_tac x="fst x" in spec)
apply (drule_tac x="snd x" in spec)
apply (simp)

      (* LUB *)
apply (intro allI impI)
apply (simp add: order_pair_def)
apply (elim conjE)
apply (rotate_tac -1)
apply (drule_tac x="fst xc" in spec)
apply (rotate_tac -1)
apply (drule_tac x="y" in spec)
apply (drule mp)

 apply (intro allI impI)
 apply (drule_tac x="b" in spec)
 apply (drule mp)
  apply (rule_tac x="(a, b)" in bexI, simp)
 apply (simp)

 apply (drule_tac x="a" in spec)
 apply (drule_tac x="b" in spec)
 apply (simp)
 apply (simp)
done

(* if *)

lemma pair_LUB_decompo_if:
  "(fst xc isLUB fst ` Xc) & (snd xc isLUB snd ` Xc)
          ==> xc isLUB (Xc::('x::order * 'y::order) set)"
apply (simp add: isLUB_def isUB_def)
apply (simp add: image_def)
apply (rule conjI)

apply (intro allI impI)
apply (simp add: order_pair_def)
apply (elim conjE)
apply (drule_tac x="a" in spec)
apply (drule mp)
apply (rule_tac x="(a, b)" in bexI)
apply (simp)
apply (simp)

apply (rotate_tac 1)
apply (drule_tac x="b" in spec)
apply (drule mp)
apply (rule_tac x="(a, b)" in bexI)
apply (simp)
apply (simp)
apply (simp)

(*** least ***)

apply (intro allI impI)
apply (elim conjE)
apply (rotate_tac 2)
apply (drule_tac x="a" in spec)
apply (rotate_tac 1)
apply (drule_tac x="b" in spec)

apply (drule mp)
apply (intro allI impI)
apply (erule bexE)
apply (drule_tac x="y" in spec)
apply (rotate_tac -1)
apply (drule_tac x="snd x" in spec)
apply (simp add: order_pair_def)

apply (drule mp)
apply (intro allI impI)
apply (erule bexE)
apply (drule_tac x="fst x" in spec)
apply (rotate_tac -1)
apply (drule_tac x="y" in spec)
apply (simp add: order_pair_def)

apply (simp add: order_pair_def)
done

(* iff *)

lemma pair_LUB_decompo:
  "xc isLUB (Xc::('x::order * 'y::order) set)
   = ((fst xc isLUB fst ` Xc) & (snd xc isLUB snd ` Xc))"
apply (rule iffI)
apply (simp add: pair_LUB_decompo_fst_only_if pair_LUB_decompo_snd_only_if)
apply (simp add: pair_LUB_decompo_if)
done

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Tensor CP-Rank\<close>

theory Tensor_Rank
imports Tensor_Unit_Vec
begin

inductive cprank_max1::"'a::ring_1 tensor \<Rightarrow> bool" where
order1: "order A \<le> 1 \<Longrightarrow> cprank_max1 A" |
higher_order: "order A = 1 \<Longrightarrow> cprank_max1 B \<Longrightarrow> cprank_max1 (A \<otimes> B)"

lemma cprank_max1_order0: "cprank_max1 B \<Longrightarrow> order A = 0 \<Longrightarrow> cprank_max1 (A \<otimes> B)"
proof (induction B rule:cprank_max1.induct)
  case order1
  then show ?case by (simp add: cprank_max1.order1)
next
  case (higher_order A' B)
  then have "order (A \<otimes> A') = 1" by simp
  then show ?case using higher_order cprank_max1.higher_order by (metis mult.assoc)
qed

lemma cprank_max1_order_le1: "order A \<le> 0 \<Longrightarrow> cprank_max1 B \<Longrightarrow> cprank_max1 (A \<otimes> B)"
by (simp add: cprank_max1_order0)

lemma cprank_max1_prod: "cprank_max1 A \<Longrightarrow> cprank_max1 B \<Longrightarrow> cprank_max1 (A \<otimes> B)"
  apply(induction A rule: cprank_max1.induct)
 apply (meson higher_order le_neq_trans less_one cprank_max1_order0)
by (simp add: higher_order mult.assoc)

lemma cprank_max1_prod_list:
assumes "\<And>B. B\<in>set Bs \<Longrightarrow> cprank_max1 B"
shows "cprank_max1 (prod_list Bs)"
  using assms by (induction Bs, metis dims_smult dims_tensor0 list.size(3) prod_list.Nil order1 order_0_multiple_of_one zero_le_one, simp add: cprank_max1_prod)

lemma cprank_max1_prod_listE:
  fixes A::"'a::comm_ring_1 tensor"
  assumes "cprank_max1 A"
  obtains Bs a where "\<And>B. B\<in>set Bs \<Longrightarrow> order B = 1" "a \<cdot> prod_list Bs = A"
using assms proof (induction A arbitrary:thesis rule:cprank_max1.induct)
  case (order1 A)
  then show ?case
  proof (cases "order A = 0")
    case True
    then obtain a where "A = a \<cdot> prod_list []" using order_0_multiple_of_one using prod_list.Nil by auto
    then show ?thesis using length_pos_if_in_set order1.prems by fastforce
  next
    case False
    then have "order A = 1" using order1 by linarith
    then have "A = 1 \<cdot> prod_list [A]" by (simp add: smult_1)
    then show ?thesis by (metis \<open>order A = 1\<close> length_greater_0_conv length_pos_if_in_set order1.prems set_ConsD)
  qed
next
  case (higher_order A B)
  then obtain Bs b where "(\<And>B'. B' \<in> set Bs \<Longrightarrow> order B' = 1)" "b \<cdot> prod_list Bs = B" by metis
  then have "(\<And>B. B \<in> set (A # Bs) \<Longrightarrow> order B = 1)" using higher_order by auto
  have "A \<otimes> B = b \<cdot> (A \<otimes> prod_list Bs)" using smult_prod_extract2  \<open>b \<cdot> prod_list Bs = B\<close> by metis
  then show ?case by (metis \<open>\<And>Ba. Ba \<in> set (A # Bs) \<Longrightarrow> order Ba = 1\<close> higher_order.prems prod_list.Cons)
qed

inductive cprank_max :: "nat \<Rightarrow> 'a::ring_1 tensor \<Rightarrow> bool" where
cprank_max0: "cprank_max 0 (tensor0 ds)" |
cprank_max_Suc: "dims A = dims B \<Longrightarrow> cprank_max1 A \<Longrightarrow> cprank_max j B \<Longrightarrow> cprank_max (Suc j) (A+B)"

lemma cprank_max1: "cprank_max1 A \<Longrightarrow> cprank_max 1 A"
  by (metis One_nat_def dims_tensor0 cprank_max.simps cprank_max0 tensor_add_0_right)

lemma cprank_max_plus: "cprank_max i A \<Longrightarrow> cprank_max j B \<Longrightarrow> dims A = dims B \<Longrightarrow> cprank_max (i+j) (A+B)"
apply (induction A rule:cprank_max.induct)
 apply auto[1]
by (metis add_Suc plus_assoc plus_dim1 cprank_max.intros(2))

lemma cprank_max_listsum:
assumes "\<And>A. A\<in>set As \<Longrightarrow> dims A = ds"
and "\<And>A. A\<in>set As \<Longrightarrow> cprank_max n A"
shows "cprank_max (n*length As) (listsum ds As)"
using assms proof (induction As)
  case Nil
  then show ?case using listsum_Nil cprank_max.simps by fastforce
next
  case (Cons A As)
  then show ?case using cprank_max_plus[of n A "n * length As" "listsum ds As"]
    by (simp add: length_Cons list.set_intros(1) listsum_Cons listsum_dims set_subset_Cons subsetCE)
qed

lemma cprank_maxE:
assumes "cprank_max n A"
obtains BS where "(\<And>B. B\<in>set BS \<Longrightarrow> cprank_max1 B)" and "(\<And>B. B\<in>set BS \<Longrightarrow> dims A = dims B)" and "listsum (dims A) BS = A" and "length BS = n"
using assms proof (induction arbitrary:thesis rule:cprank_max.induct)
  case (cprank_max0 ds)
  have "Tensor_Plus.listsum (dims (tensor0 ds)) [] = tensor0 ds" by (simp add: listsum_Nil)
  then show ?case using cprank_max0.prems by fastforce
next
  case (cprank_max_Suc A B j)
  then obtain BS where BS_def:"(\<And>B. B \<in> set BS \<Longrightarrow> cprank_max1 B)" "(\<And>B'. B' \<in> set BS \<Longrightarrow> dims B' = dims B)"
                       "listsum (dims B) BS = B" "length BS = j" by metis
  then have "listsum (dims (A + B)) (A # BS) = A + B"
    by (simp add: listsum_Cons cprank_max_Suc.hyps(1))
  then show ?case using BS_def length_Cons cprank_max_Suc.hyps(2) cprank_max_Suc.prems set_ConsD
    by (metis plus_dim1 cprank_max_Suc.hyps(1))
qed

lemma cprank_maxI:
assumes "\<And>B. B\<in>set BS \<Longrightarrow> cprank_max1 B"
and "\<And>B. B\<in>set BS \<Longrightarrow> dims B = ds"
shows "cprank_max (length BS) (listsum ds BS)"
using assms proof (induction BS)
  case Nil
  then show ?case by (simp add: listsum_Nil cprank_max0)
next
  case (Cons B BS)
  then show ?case
    by (simp add: length_Cons list.set_intros(1) list.set_intros(2) listsum_Cons listsum_dims cprank_max_Suc)
qed

lemma cprank_max_0E: "cprank_max 0 A \<Longrightarrow> A = tensor0 (dims A)" by (metis dims_tensor0 length_0_conv cprank_max0 cprank_maxE)

lemma listsum_prod_distr_right:
assumes "(\<And>C. C\<in>set CS \<Longrightarrow> dims C = ds)"
shows "A \<otimes> listsum ds CS = listsum (dims A @ ds) (map (\<lambda>C. A \<otimes> C) CS)"
using assms proof (induction CS)
  case Nil
  then show ?case by (simp add:listsum_Nil)
next
  case (Cons C CS)
  then have "dims C = dims (listsum ds CS)" by (simp add: list.set_intros(1) list.set_intros(2) listsum_dims)
  then show ?case unfolding listsum_Cons list.map(2)
    using tensor_prod_distr_right Cons.IH Cons.prems list.set_intros(2) by fastforce
qed

lemma cprank_max_prod_order1:
assumes "order A = 1"
and "cprank_max n B"
shows "cprank_max n (A\<otimes>B)"
proof -
  obtain CS where "(\<And>C. C\<in>set CS \<Longrightarrow> cprank_max1 C)"
              and "(\<And>C. C\<in>set CS \<Longrightarrow> dims C = dims B)"
              and "listsum (dims B) CS = B"
              and "length CS = n"
    using assms(2) cprank_maxE by metis
  define CS' where "CS' = map (\<lambda>C. A\<otimes>C) CS"
  then have "\<And>C'. C'\<in>set CS' \<Longrightarrow> cprank_max1 C'"
    using assms(1) higher_order \<open>\<And>C. C \<in> set CS \<Longrightarrow> cprank_max1 C\<close> imageE set_map by auto
  have "listsum (dims A @ dims B) CS' = A\<otimes>B" using CS'_def \<open>Tensor_Plus.listsum (dims B) CS = B\<close>
    using \<open>\<And>Ca. Ca \<in> set CS \<Longrightarrow> dims Ca = dims B\<close> listsum_prod_distr_right by fastforce
  then show ?thesis by (metis (mono_tags, lifting) CS'_def \<open>\<And>C'. C' \<in> set CS' \<Longrightarrow> cprank_max1 C'\<close> \<open>\<And>Ca. Ca \<in> set CS \<Longrightarrow> dims Ca = dims B\<close> \<open>length CS = n\<close> dims_tensor_prod imageE length_map cprank_maxI set_map)
qed

lemma cprank_max_upper_bound: (* Stronger bound is possible, one of the factors in prod_list can be dropped. *)
shows "cprank_max (prod_list (dims A)) A"
proof (induction A rule:subtensor_induct)
  case (order_0 A)
  then have "cprank_max 1 A" using order1 cprank_max1 by force
  then show ?case using order_0 by auto
next
  case (order_step A)
  define Bs where "Bs = map (\<lambda>i. unit_vec (hd (dims A)) i \<otimes> subtensor A i) [0..<hd (dims A)]"
  have "\<And>B. B \<in> set Bs \<Longrightarrow> dims A = dims B"
  proof -
    fix B assume "B \<in> set Bs"
    obtain i where "i<hd (dims A)" "Bs!i=B" using Bs_def \<open>B \<in> set Bs\<close> by auto
    then have "dims (unit_vec (hd (dims A)) i \<otimes> subtensor A i) = dims A"
      using dims_unit_vec order_step.hyps
      by (metis append_Cons dims_subtensor dims_tensor_prod list.exhaust_sel self_append_conv2)
    then show "dims A = dims B" using Bs_def \<open>Bs ! i = B\<close> \<open>i < hd (dims A)\<close> by auto
  qed
  have "\<And>B. B \<in> set Bs \<Longrightarrow> cprank_max (prod_list (tl (dims A))) B"
  proof -
    fix B assume "B \<in> set Bs"
    obtain i where "i<hd (dims A)" "Bs!i=B" using Bs_def \<open>B \<in> set Bs\<close> by auto
    then have "cprank_max (prod_list (tl (dims A))) (unit_vec (hd (dims A)) i \<otimes> subtensor A i)"
      by (metis One_nat_def dims_subtensor dims_unit_vec length_Cons list.size(3) order_step.IH order_step.hyps cprank_max_prod_order1)
    then show "cprank_max (prod_list (tl (dims A))) B" using Bs_def \<open>Bs ! i = B\<close> \<open>i < hd (dims A)\<close> by auto
  qed
  then show ?case using subtensor_decomposition[OF order_step.hyps] cprank_max_listsum
    by (metis (no_types, lifting) Bs_def \<open>\<And>Ba. Ba \<in> set Bs \<Longrightarrow> dims A = dims Ba\<close> diff_zero length_map length_upt list.exhaust_sel prod_list.Cons mult.commute order_step.hyps)
qed

definition cprank :: "'a::ring_1 tensor \<Rightarrow> nat" where
"cprank A = (LEAST n. cprank_max n A)"

lemma cprank_upper_bound: "cprank A \<le> prod_list (dims A)"
unfolding cprank_def using cprank_max_upper_bound Least_le by fastforce

lemma cprank_max_cprank: "cprank_max (cprank A) A"
  unfolding cprank_def using cprank_max_upper_bound by (metis LeastI)

end


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

subsection \<open>Product Spaces\<close>

theory Binary_Product_QuasiBorel
  imports "Measure_QuasiBorel_Adjunction"
begin

subsubsection \<open> Binary Product Spaces \<close>
definition pair_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> (real => 'a \<times> 'b) set" where
"pair_qbs_Mx X Y \<equiv> {f. fst \<circ> f \<in> qbs_Mx X \<and> snd \<circ> f \<in> qbs_Mx Y}"

definition pair_qbs :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<times> 'b) quasi_borel" (infixr "\<Otimes>\<^sub>Q" 80) where
"pair_qbs X Y = Abs_quasi_borel (qbs_space X \<times> qbs_space Y, pair_qbs_Mx X Y)"

lemma pair_qbs_f[simp]: "pair_qbs_Mx X Y \<subseteq> UNIV \<rightarrow> qbs_space X \<times> qbs_space Y"
  unfolding pair_qbs_Mx_def
  by (auto simp: mem_Times_iff[of _ "qbs_space X" "qbs_space Y"]; fastforce)

lemma pair_qbs_closed1: "qbs_closed1 (pair_qbs_Mx (X::'a quasi_borel) (Y::'b quasi_borel))"
  unfolding pair_qbs_Mx_def qbs_closed1_def
  by (metis (no_types, lifting) comp_assoc mem_Collect_eq qbs_closed1_dest)

lemma pair_qbs_closed2: "qbs_closed2 (qbs_space X \<times> qbs_space Y) (pair_qbs_Mx X Y)"
  unfolding qbs_closed2_def pair_qbs_Mx_def
  by auto

lemma pair_qbs_closed3: "qbs_closed3 (pair_qbs_Mx (X::'a quasi_borel) (Y::'b quasi_borel))"
proof(auto simp add: qbs_closed3_def pair_qbs_Mx_def)
  fix P :: "real \<Rightarrow> nat"
  fix Fi :: "nat \<Rightarrow> real \<Rightarrow> 'a \<times> 'b"
  define Fj :: "nat \<Rightarrow> real \<Rightarrow> 'a" where "Fj \<equiv> \<lambda>j.(fst \<circ> Fi j)"
  assume "\<forall>i. fst \<circ> Fi i \<in> qbs_Mx X \<and> snd \<circ> Fi i \<in> qbs_Mx Y"
  then have "\<forall>i. Fj i \<in> qbs_Mx X" by (simp add: Fj_def)
  moreover assume "\<forall>i. P -` {i} \<in> sets real_borel"
  ultimately have "(\<lambda>r. Fj (P r) r) \<in> qbs_Mx X"
    by auto
  moreover have "fst \<circ> (\<lambda>r. Fi (P r) r) = (\<lambda>r. Fj (P r) r)" by (auto simp add: Fj_def)
  ultimately show "fst \<circ> (\<lambda>r. Fi (P r) r) \<in> qbs_Mx X" by simp
next
  fix P :: "real \<Rightarrow> nat"
  fix Fi :: "nat \<Rightarrow> real \<Rightarrow> 'a \<times> 'b"
  define Fj :: "nat \<Rightarrow> real \<Rightarrow> 'b" where "Fj \<equiv> \<lambda>j.(snd \<circ> Fi j)"
  assume "\<forall>i. fst \<circ> Fi i \<in> qbs_Mx X \<and> snd \<circ> Fi i \<in> qbs_Mx Y"
  then have "\<forall>i. Fj i \<in> qbs_Mx Y" by (simp add: Fj_def)
  moreover assume "\<forall>i. P -` {i} \<in> sets real_borel"
  ultimately have "(\<lambda>r. Fj (P r) r) \<in> qbs_Mx Y"
    by auto
  moreover have "snd \<circ> (\<lambda>r. Fi (P r) r) = (\<lambda>r. Fj (P r) r)" by (auto simp add: Fj_def)
  ultimately show "snd \<circ> (\<lambda>r. Fi (P r) r) \<in> qbs_Mx Y" by simp
qed

lemma pair_qbs_correct: "Rep_quasi_borel (X \<Otimes>\<^sub>Q Y) = (qbs_space X \<times> qbs_space Y, pair_qbs_Mx X Y)"
  unfolding pair_qbs_def
  by(auto intro!: Abs_quasi_borel_inverse pair_qbs_f simp: pair_qbs_closed3 pair_qbs_closed2 pair_qbs_closed1)

lemma pair_qbs_space[simp]: "qbs_space (X \<Otimes>\<^sub>Q Y) = qbs_space X \<times> qbs_space Y"
  by (simp add: qbs_space_def pair_qbs_correct)

lemma pair_qbs_Mx[simp]: "qbs_Mx (X \<Otimes>\<^sub>Q Y) = pair_qbs_Mx X Y"
  by (simp add: qbs_Mx_def pair_qbs_correct)

lemma pair_qbs_morphismI:
  assumes "\<And>\<alpha> \<beta>. \<alpha> \<in> qbs_Mx X \<Longrightarrow> \<beta> \<in> qbs_Mx Y
           \<Longrightarrow> f \<circ> (\<lambda>r. (\<alpha> r, \<beta> r)) \<in> qbs_Mx Z"
    shows "f \<in> (X \<Otimes>\<^sub>Q Y) \<rightarrow>\<^sub>Q Z"
proof(rule qbs_morphismI)
  fix \<alpha>
  assume 1:"\<alpha> \<in> qbs_Mx (X \<Otimes>\<^sub>Q Y)"
  have "f \<circ> \<alpha> = f \<circ> (\<lambda>r. ((fst \<circ> \<alpha>) r, (snd \<circ> \<alpha>) r))"
    by auto
  also have "... \<in> qbs_Mx Z"
    using 1 assms[of "fst \<circ> \<alpha>" "snd \<circ> \<alpha>"]
    by(simp add: pair_qbs_Mx_def)
  finally show "f \<circ> \<alpha> \<in> qbs_Mx Z" .
qed

lemma fst_qbs_morphism:
  "fst \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q X"
  by(auto simp add: qbs_morphism_def pair_qbs_Mx_def)

lemma snd_qbs_morphism:
  "snd \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Y"
  by(auto simp add: qbs_morphism_def pair_qbs_Mx_def)

lemma qbs_morphism_pair_iff:
 "f \<in> X \<rightarrow>\<^sub>Q Y \<Otimes>\<^sub>Q Z \<longleftrightarrow> fst \<circ> f \<in> X \<rightarrow>\<^sub>Q Y \<and> snd \<circ> f \<in> X \<rightarrow>\<^sub>Q Z"
  by(auto intro!: qbs_morphismI qbs_morphism_comp[OF _ fst_qbs_morphism,of f X Y Z ]qbs_morphism_comp[OF _ snd_qbs_morphism,of f X Y Z]
            simp: pair_qbs_Mx_def comp_assoc[symmetric])

lemma qbs_morphism_Pair1:
  assumes "x \<in> qbs_space X"
  shows "Pair x \<in> Y \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
  using assms
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def comp_def)

lemma qbs_morphism_Pair1':
  assumes "x \<in> qbs_space X"
      and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
    shows "(\<lambda>y. f (x,y)) \<in> Y \<rightarrow>\<^sub>Q Z"
  using qbs_morphism_comp[OF qbs_morphism_Pair1[OF assms(1)] assms(2)]
  by(simp add: comp_def)

lemma qbs_morphism_Pair2:
  assumes "y \<in> qbs_space Y"
  shows "(\<lambda>x. (x,y)) \<in> X \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
  using assms
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def comp_def)

lemma qbs_morphism_Pair2':
  assumes "y \<in> qbs_space Y"
      and "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
    shows "(\<lambda>x. f (x,y)) \<in> X \<rightarrow>\<^sub>Q Z"
  using qbs_morphism_comp[OF qbs_morphism_Pair2[OF assms(1)] assms(2)]
  by(simp add: comp_def)

lemma qbs_morphism_fst'':
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
  shows "(\<lambda>k. f (fst k)) \<in> X \<Otimes>\<^sub>Q Z \<rightarrow>\<^sub>Q Y"
  using qbs_morphism_comp[OF fst_qbs_morphism assms,of Z]
  by(simp add: comp_def)

lemma qbs_morphism_snd'':
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
  shows "(\<lambda>k. f (snd k)) \<in> Z \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
  using qbs_morphism_comp[OF snd_qbs_morphism assms,of Z]
  by(simp add: comp_def)

lemma qbs_morphism_tuple:
  assumes "f \<in> Z \<rightarrow>\<^sub>Q X"
      and "g \<in> Z \<rightarrow>\<^sub>Q Y"
    shows "(\<lambda>z. (f z, g z)) \<in> Z \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q Y"
proof(rule qbs_morphismI,simp)
  fix \<alpha>
  assume  h:"\<alpha> \<in> qbs_Mx Z"
  then have "(\<lambda>z. (f z, g z)) \<circ> \<alpha> \<in> UNIV \<rightarrow> qbs_space X \<times> qbs_space Y"
    using assms qbs_morphismE(2)[OF assms(1)] qbs_morphismE(2)[OF assms(2)]
    by fastforce
  moreover have "fst \<circ> ((\<lambda>z. (f z, g z)) \<circ> \<alpha>) = f \<circ> \<alpha>" by auto
  moreover have "... \<in> qbs_Mx X"
    using assms(1) h by auto
  moreover have "snd \<circ> ((\<lambda>z. (f z, g z)) \<circ> \<alpha>) = g \<circ> \<alpha>" by auto
  moreover have "... \<in> qbs_Mx Y"
    using assms(2) h by auto
  ultimately show "(\<lambda>z. (f z, g z)) \<circ> \<alpha> \<in> pair_qbs_Mx X Y"
    by (simp add: pair_qbs_Mx_def)
qed

lemma qbs_morphism_map_prod:
  assumes "f \<in> X \<rightarrow>\<^sub>Q Y"
      and "g \<in> X' \<rightarrow>\<^sub>Q Y'"
    shows "map_prod f g \<in> X \<Otimes>\<^sub>Q X'\<rightarrow>\<^sub>Q Y \<Otimes>\<^sub>Q Y'"
proof(rule pair_qbs_morphismI)
  fix \<alpha> \<beta>
  assume h:"\<alpha> \<in> qbs_Mx X"
           "\<beta> \<in> qbs_Mx X'"
  have [simp]: "fst \<circ> (map_prod f g \<circ> (\<lambda>r. (\<alpha> r, \<beta> r))) = f \<circ> \<alpha>" by auto
  have [simp]: "snd \<circ> (map_prod f g \<circ> (\<lambda>r. (\<alpha> r, \<beta> r))) = g \<circ> \<beta>" by auto
  show "map_prod f g \<circ> (\<lambda>r. (\<alpha> r, \<beta> r)) \<in> qbs_Mx (Y \<Otimes>\<^sub>Q Y')"
    using h assms by(auto simp: pair_qbs_Mx_def)
qed

lemma qbs_morphism_pair_swap':
  "(\<lambda>(x,y). (y,x)) \<in> (X::'a quasi_borel) \<Otimes>\<^sub>Q (Y::'b quasi_borel) \<rightarrow>\<^sub>Q Y \<Otimes>\<^sub>Q X"
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)

lemma qbs_morphism_pair_swap:
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
  shows "(\<lambda>(x,y). f (y,x)) \<in> Y \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Z"
proof -
  have "(\<lambda>(x,y). f (y,x)) = f \<circ> (\<lambda>(x,y). (y,x))" by auto
  thus ?thesis
    using qbs_morphism_comp[of "(\<lambda>(x,y). (y,x))" "Y \<Otimes>\<^sub>Q X" _ f] qbs_morphism_pair_swap' assms
    by auto
qed

lemma qbs_morphism_pair_assoc1:
 "(\<lambda>((x,y),z). (x,(y,z))) \<in> (X \<Otimes>\<^sub>Q Y) \<Otimes>\<^sub>Q Z \<rightarrow>\<^sub>Q X \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q Z)"
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)

lemma qbs_morphism_pair_assoc2:
 "(\<lambda>(x,(y,z)). ((x,y),z)) \<in> X \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q Z) \<rightarrow>\<^sub>Q (X \<Otimes>\<^sub>Q Y) \<Otimes>\<^sub>Q Z"
  by(auto intro!: qbs_morphismI simp: pair_qbs_Mx_def split_beta' comp_def)

lemma pair_qbs_fst:
  assumes "qbs_space Y \<noteq> {}"
  shows "map_qbs fst (X \<Otimes>\<^sub>Q Y) = X"
proof(rule qbs_eqI)
  show "qbs_Mx (map_qbs fst (X \<Otimes>\<^sub>Q Y)) = qbs_Mx X"
  proof auto
    fix \<alpha>x
    assume hx:"\<alpha>x \<in> qbs_Mx X"
    obtain \<alpha>y where hy:"\<alpha>y \<in> qbs_Mx Y"
      using qbs_empty_equiv[of Y] assms
      by auto
    show "\<exists>\<alpha>\<in>pair_qbs_Mx X Y. \<alpha>x = fst \<circ> \<alpha>"
      by(auto intro!: exI[where x="\<lambda>r. (\<alpha>x r, \<alpha>y r)"] simp: pair_qbs_Mx_def hx hy comp_def)
  qed (simp add: pair_qbs_Mx_def)
qed

lemma pair_qbs_snd:
  assumes "qbs_space X \<noteq> {}"
  shows "map_qbs snd (X \<Otimes>\<^sub>Q Y) = Y"
proof(rule qbs_eqI)
  show "qbs_Mx (map_qbs snd (X \<Otimes>\<^sub>Q Y)) = qbs_Mx Y"
  proof auto
    fix \<alpha>y
    assume hy:"\<alpha>y \<in> qbs_Mx Y"
    obtain \<alpha>x where hx:"\<alpha>x \<in> qbs_Mx X"
      using qbs_empty_equiv[of X] assms
      by auto
    show "\<exists>\<alpha>\<in>pair_qbs_Mx X Y. \<alpha>y = snd \<circ> \<alpha>"
      by(auto intro!: exI[where x="\<lambda>r. (\<alpha>x r, \<alpha>y r)"] simp: pair_qbs_Mx_def hx hy comp_def)
  qed (simp add: pair_qbs_Mx_def)
qed

text \<open> The following lemma corresponds to \<^cite>\<open>"Heunen_2017"\<close> Proposition 19(1). \<close>
lemma r_preserves_product :
  "measure_to_qbs (X \<Otimes>\<^sub>M Y) = measure_to_qbs X \<Otimes>\<^sub>Q measure_to_qbs Y"
  by(auto intro!: qbs_eqI simp: measurable_pair_iff pair_qbs_Mx_def)

lemma l_product_sets[simp,measurable_cong]:
  "sets (qbs_to_measure X \<Otimes>\<^sub>M qbs_to_measure Y) \<subseteq> sets (qbs_to_measure (X \<Otimes>\<^sub>Q Y))"
proof(rule sets_pair_in_sets,simp)
  fix A B
  assume h:"A \<in> sigma_Mx X"
           "B \<in> sigma_Mx Y"
  then obtain Ua Ub where hu:
   "A = Ua \<inter> qbs_space X" "\<forall>\<alpha>\<in>qbs_Mx X. \<alpha> -` Ua \<in> sets real_borel"
   "B = Ub \<inter> qbs_space Y" "\<forall>\<alpha>\<in>qbs_Mx Y. \<alpha> -` Ub \<in> sets real_borel"
    by(auto simp add: sigma_Mx_def)
  show "A \<times> B \<in> sigma_Mx (X \<Otimes>\<^sub>Q Y)"
  proof(simp add: sigma_Mx_def, rule exI[where x="Ua \<times> Ub"])
    show "A \<times> B = Ua \<times> Ub \<inter> qbs_space X \<times> qbs_space Y \<and>
    (\<forall>\<alpha>\<in>pair_qbs_Mx X Y. \<alpha> -` (Ua \<times> Ub) \<in> sets real_borel)"
      using hu by(auto simp add: pair_qbs_Mx_def vimage_Times)
  qed
qed

lemma(in pair_standard_borel) l_r_r_sets[simp,measurable_cong]:
 "sets (qbs_to_measure (measure_to_qbs M \<Otimes>\<^sub>Q measure_to_qbs N)) = sets (M \<Otimes>\<^sub>M N)"
  by(simp only: r_preserves_product[symmetric]) (rule standard_borel_lr_sets_ident)

end