Theory Binary_CoProduct_QuasiBorel

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

subsection ‹Coproduct Spaces›

theory Binary_CoProduct_QuasiBorel
  imports "Measure_QuasiBorel_Adjunction"
begin

subsubsection ‹ Binary Coproduct Spaces  ›
definition copair_qbs_Mx :: "['a quasi_borel, 'b quasi_borel]  (real => 'a + 'b) set" where
"copair_qbs_Mx X Y  
  {g.  S  sets real_borel.
  (S = {}    ( α1 qbs_Mx X. g = (λr. Inl (α1 r)))) 
  (S = UNIV  ( α2 qbs_Mx Y. g = (λr. Inr (α2 r)))) 
  ((S  {}  S  UNIV) 
     ( α1 qbs_Mx X.
       α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))))}"


definition copair_qbs :: "['a quasi_borel, 'b quasi_borel]  ('a + 'b) quasi_borel" (infixr <+>Q 65) where
"copair_qbs X Y  Abs_quasi_borel (qbs_space X <+> qbs_space Y, copair_qbs_Mx X Y)"


text ‹ The followin is an equivalent definition of @{term copair_qbs_Mx}. ›
definition copair_qbs_Mx2 :: "['a quasi_borel, 'b quasi_borel]  (real => 'a + 'b) set" where
"copair_qbs_Mx2 X Y  
  {g. (if qbs_space X = {}  qbs_space Y = {} then False
       else if qbs_space X  {}  qbs_space Y = {} then 
                  (α1 qbs_Mx X. g = (λr. Inl (α1 r)))
       else if qbs_space X = {}  qbs_space Y  {} then 
                  (α2 qbs_Mx Y. g = (λr. Inr (α2 r)))
       else 
         (S  sets real_borel. α1 qbs_Mx X. α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r))))) }"

lemma copair_qbs_Mx_equiv :"copair_qbs_Mx (X :: 'a quasi_borel) (Y :: 'b quasi_borel) = copair_qbs_Mx2 X Y"
proof(auto)
(* ⊆ *)
  fix g :: "real  'a + 'b"
  assume "g  copair_qbs_Mx X Y"
  then obtain S where hs:"S sets real_borel  
  (S = {}    ( α1 qbs_Mx X. g = (λr. Inl (α1 r)))) 
  (S = UNIV  ( α2 qbs_Mx Y. g = (λr. Inr (α2 r)))) 
  ((S  {}  S  UNIV) 
     ( α1 qbs_Mx X.
       α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))))"
    by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S  {}  S  UNIV" by auto
  then show "g  copair_qbs_Mx2 X Y"
  proof cases
    assume "S = {}"
    from hs this have " α1 qbs_Mx X. g = (λr. Inl (α1 r))" by simp
    then obtain α1 where h1:"α1 qbs_Mx X  g = (λr. Inl (α1 r))" by auto
    have "qbs_space X  {}"
      using qbs_empty_equiv h1
      by auto
    then have "(qbs_space X  {}  qbs_space Y = {})  (qbs_space X  {}  qbs_space Y  {})"
      by simp
    then show "g  copair_qbs_Mx2 X Y"
    proof
      assume "qbs_space X  {}  qbs_space Y = {}"
      then show "g  copair_qbs_Mx2 X Y" 
        by(simp add: copair_qbs_Mx2_def  α1 qbs_Mx X. g = (λr. Inl (α1 r)))
    next
      assume "qbs_space X  {}  qbs_space Y  {}"
      then obtain α2 where "α2  qbs_Mx Y" using qbs_empty_equiv by force
      define S' :: "real set" 
        where "S'  UNIV"
      define g' :: "real  'a + 'b"
        where "g'  (λr::real. (if (r  S') then Inl (α1 r) else Inr (α2 r)))"
      from qbs_space X  {}  qbs_space Y  {} h1 α2  qbs_Mx Y
      have "g'  copair_qbs_Mx2 X Y" 
        by(force simp add: S'_def g'_def copair_qbs_Mx2_def)
      moreover have "g = g'"
        using h1 by(simp add: g'_def S'_def)
      ultimately show ?thesis
        by simp
    qed
  next
    assume "S = UNIV"
    from hs this have " α2 qbs_Mx Y. g = (λr. Inr (α2 r))" by simp
    then obtain α2 where h2:"α2 qbs_Mx Y  g = (λr. Inr (α2 r))" by auto
    have "qbs_space Y  {}"
      using qbs_empty_equiv h2
      by auto
    then have "(qbs_space X = {}  qbs_space Y  {})  (qbs_space X  {}  qbs_space Y  {})"
      by simp
    then show "g  copair_qbs_Mx2 X Y"
    proof
      assume "qbs_space X = {}  qbs_space Y  {}"
      then show ?thesis
        by(simp add: copair_qbs_Mx2_def  α2 qbs_Mx Y. g = (λr. Inr (α2 r)))
    next
      assume "qbs_space X  {}  qbs_space Y  {}"
      then obtain α1 where "α1  qbs_Mx X" using qbs_empty_equiv by force
      define S' :: "real set"
        where "S'  {}"
      define g' :: "real  'a + 'b"
        where "g'  (λr::real. (if (r  S') then Inl (α1 r) else Inr (α2 r)))"
      from qbs_space X  {}  qbs_space Y  {} h2 α1  qbs_Mx X
      have "g'  copair_qbs_Mx2 X Y" 
        by(force simp add: S'_def g'_def copair_qbs_Mx2_def)
      moreover have "g = g'"
        using h2 by(simp add: g'_def S'_def)
      ultimately show ?thesis
        by simp
    qed
  next
    assume "S  {}  S  UNIV"
    then have 
    h: " α1 qbs_Mx X.
         α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))"
      using hs by simp
    then have "qbs_space X  {}  qbs_space Y  {}"
      by (metis empty_iff qbs_empty_equiv)
    thus ?thesis
      using hs h by(auto simp add: copair_qbs_Mx2_def)
  qed

(* ⊇ *)
next
  fix g :: "real  'a + 'b"
  assume "g  copair_qbs_Mx2 X Y"
  then have
  h: "if qbs_space X = {}  qbs_space Y = {} then False
      else if qbs_space X  {}  qbs_space Y = {} then 
                  (α1 qbs_Mx X. g = (λr. Inl (α1 r)))
      else if qbs_space X = {}  qbs_space Y  {} then 
                  (α2 qbs_Mx Y. g = (λr. Inr (α2 r)))
      else 
          (S  sets real_borel. α1 qbs_Mx X. α2 qbs_Mx Y.
           g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r))))"
    by(simp add: copair_qbs_Mx2_def)
  consider "(qbs_space X = {}  qbs_space Y = {})" |
           "(qbs_space X  {}  qbs_space Y = {})" |
           "(qbs_space X = {}  qbs_space Y  {})" |
           "(qbs_space X  {}  qbs_space Y  {})" by auto
  then show "g  copair_qbs_Mx X Y"
  proof cases
    assume "qbs_space X = {}  qbs_space Y = {}"
    then show ?thesis
      using g  copair_qbs_Mx2 X Y by(simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X  {}  qbs_space Y = {}"
    from h this have "α1 qbs_Mx X. g = (λr. Inl (α1 r))" by simp
    thus ?thesis
      by(auto simp add: copair_qbs_Mx_def)
  next
    assume "qbs_space X = {}  qbs_space Y  {}"
    from h this have "α2 qbs_Mx Y. g = (λr. Inr (α2 r))" by simp
    thus ?thesis
      unfolding copair_qbs_Mx_def 
      by(force simp add: copair_qbs_Mx_def)
  next
    assume "qbs_space X  {}  qbs_space Y  {}"
    from h this have 
        "S  sets real_borel. α1 qbs_Mx X. α2 qbs_Mx Y.
           g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))" by simp
    then show ?thesis
    proof(auto simp add: exE)
      fix S
      fix α1
      fix α2
      assume "S  sets real_borel"
             "α1  qbs_Mx X"
             "α2  qbs_Mx Y"
             "g = (λr. if r  S then Inl (α1 r)
                                else Inr (α2 r))"
      consider "S = {}" | "S = UNIV" | "S  {}  S  UNIV" by auto
      then show "(λr. if r  S then Inl (α1 r) else Inr (α2 r))  copair_qbs_Mx X Y"
      proof cases
        assume "S = {}"
        then have [simp]: "(λr. if r  S then Inl (α1 r) else Inr (α2 r)) = (λr. Inr (α2 r))"
          by simp
        have "UNIV  sets real_borel" by simp
        then show ?thesis
          using α2  qbs_Mx Y unfolding copair_qbs_Mx_def
          by(auto intro! : bexI[where x=UNIV])
      next
        assume "S = UNIV"
        then have "(λr. if r  S then Inl (α1 r) else Inr (α2 r)) = (λr. Inl (α1 r))"
          by simp
        then show ?thesis
          using α1  qbs_Mx X 
          by(auto simp add: copair_qbs_Mx_def)
      next
        assume "S  {}  S  UNIV"
        then show ?thesis
          using S  sets real_borel α1  qbs_Mx X α2  qbs_Mx Y
          by(auto simp add: copair_qbs_Mx_def)
      qed  
    qed
  qed
qed


lemma copair_qbs_f[simp]: "copair_qbs_Mx X Y  UNIV  qbs_space X <+> qbs_space Y"
proof
  fix g
  assume "g  copair_qbs_Mx X Y"
  then obtain S where hs:"S sets real_borel  
  (S = {}    ( α1 qbs_Mx X. g = (λr. Inl (α1 r)))) 
  (S = UNIV  ( α2 qbs_Mx Y. g = (λr. Inr (α2 r)))) 
  ((S  {}  S  UNIV) 
     ( α1 qbs_Mx X.
       α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))))"
   by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S  {}  S  UNIV" by auto
  then show "g  UNIV  qbs_space X <+> qbs_space Y"
  proof cases
    assume "S = {}"
    then show ?thesis
      using hs by auto
  next
    assume "S = UNIV"
    then show ?thesis
      using hs by auto
  next
    assume "S  {}  S  UNIV"
    then have " α1 qbs_Mx X.  α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))" using hs by simp
    then show ?thesis 
      by(auto simp add: exE)
  qed
qed

lemma copair_qbs_closed1: "qbs_closed1 (copair_qbs_Mx X Y)"
proof(auto simp add: qbs_closed1_def)
  fix g
  fix f
  assume "g  copair_qbs_Mx X Y"
         "f  real_borel M real_borel"
  then have "g  copair_qbs_Mx2 X Y" using copair_qbs_Mx_equiv by auto
  consider "(qbs_space X = {}  qbs_space Y = {})" |
           "(qbs_space X  {}  qbs_space Y = {})" |
           "(qbs_space X = {}  qbs_space Y  {})" |
           "(qbs_space X  {}  qbs_space Y  {})" by auto
  then have "g  f  copair_qbs_Mx2 X Y"
  proof cases
    assume "qbs_space X = {}  qbs_space Y = {}"
    then show ?thesis
      using g  copair_qbs_Mx2 X Y qbs_empty_equiv by(simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X  {}  qbs_space Y = {}"
    then obtain α1 where h1:"α1 qbs_Mx X  g = (λr. Inl (α1 r))"
      using g  copair_qbs_Mx2 X Y by(auto simp add: copair_qbs_Mx2_def)
    then have "α1  f  qbs_Mx X" 
      using f  real_borel M real_borel by auto
    moreover have "g  f = (λr. Inl ((α1  f) r))"
      using h1 by auto
    ultimately show ?thesis
      using qbs_space X  {}  qbs_space Y = {} by(force simp add: copair_qbs_Mx2_def)
  next
    assume "(qbs_space X = {}  qbs_space Y  {})"
    then obtain α2 where h2:"α2 qbs_Mx Y  g = (λr. Inr (α2 r))"
      using g  copair_qbs_Mx2 X Y by(auto simp add: copair_qbs_Mx2_def)
    then have "α2  f  qbs_Mx Y" 
      using f  real_borel M real_borel by auto
    moreover have "g  f = (λr. Inr ((α2  f) r))"
      using h2 by auto
    ultimately show ?thesis
      using (qbs_space X = {}  qbs_space Y  {}) by(force simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X  {}  qbs_space Y  {}"
    then have "S  sets real_borel. α1 qbs_Mx X. α2 qbs_Mx Y.
          g = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))"
      using g  copair_qbs_Mx2 X Y by(simp add: copair_qbs_Mx2_def)
    then show ?thesis
    proof(auto simp add: exE)
      fix S
      fix α1
      fix α2
      assume "S  sets real_borel"
             "α1 qbs_Mx X"
             "α2  qbs_Mx Y"
             "g = (λr. if r  S then Inl (α1 r) else Inr (α2 r))"
      have "f -` S  sets real_borel"
        using f  real_borel M real_borel S  sets real_borel
        by (simp add: measurable_sets_borel)
      moreover have "α1  f  qbs_Mx X"
        using α1 qbs_Mx X f  real_borel M real_borel qbs_decomp
        by(auto simp add: qbs_closed1_def)
      moreover have "α2  f  qbs_Mx Y"
        using α2 qbs_Mx Y f  real_borel M real_borel qbs_decomp
        by(auto simp add: qbs_closed1_def)
      moreover have 
        "(λr. if r  S then Inl (α1 r) else Inr (α2 r))  f = (λr. if r  f -` S then Inl ((α1  f) r) else Inr ((α2  f) r))"
        by auto
      ultimately show "(λr. if r  S then Inl (α1 r)  else Inr (α2 r))  f  copair_qbs_Mx2 X Y"
        using qbs_space X  {}  qbs_space Y  {} by(force simp add: copair_qbs_Mx2_def)
    qed
  qed
  thus "g  f  copair_qbs_Mx X Y"
    using copair_qbs_Mx_equiv by auto
qed

lemma copair_qbs_closed2: "qbs_closed2 (qbs_space X <+> qbs_space Y) (copair_qbs_Mx X Y)"
proof(auto simp add: qbs_closed2_def)
  fix x
  assume "x  qbs_space X"
  define α1 :: "real  _" where "α1  (λr. x)"
  have "α1  qbs_Mx X" using x  qbs_space X qbs_decomp 
    by(force simp add: qbs_closed2_def α1_def )
  moreover have "(λr. Inl x) = (λl. Inl (α1 l))" by (simp add: α1_def)
  moreover have "{}  sets real_borel" by auto
  ultimately show "(λr. Inl x)  copair_qbs_Mx X Y"
    by(auto simp add: copair_qbs_Mx_def)
next
  fix y
  assume "y  qbs_space Y"
  define α2 :: "real  _" where "α2  (λr. y)"
  have "α2  qbs_Mx Y" using y  qbs_space Y qbs_decomp 
    by(force simp add: qbs_closed2_def α2_def )
  moreover have "(λr. Inr y) = (λl. Inr (α2 l))" by (simp add: α2_def)
  moreover have "UNIV  sets real_borel" by auto
  ultimately show "(λr. Inr y)  copair_qbs_Mx X Y"
    unfolding copair_qbs_Mx_def
    by(auto intro!: bexI[where x=UNIV])
qed

lemma copair_qbs_closed3: "qbs_closed3 (copair_qbs_Mx X Y)"
proof(auto simp add: qbs_closed3_def)
  fix P :: "real  nat"
  fix Fi :: "nat  real _ + _"
  assume "i. P -` {i}  sets real_borel"
         "i. Fi i  copair_qbs_Mx X Y"
  then have "i. Fi i  copair_qbs_Mx2 X Y" using copair_qbs_Mx_equiv by blast
  consider "(qbs_space X = {}  qbs_space Y = {})" |
           "(qbs_space X  {}  qbs_space Y = {})" |
           "(qbs_space X = {}  qbs_space Y  {})" |
           "(qbs_space X  {}  qbs_space Y  {})" by auto
  then have "(λr. Fi (P r) r)  copair_qbs_Mx2 X Y"
  proof cases
    assume "qbs_space X = {}  qbs_space Y = {}"
    then show ?thesis
      using i. Fi i  copair_qbs_Mx2 X Y qbs_empty_equiv 
      by(simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X  {}  qbs_space Y = {}"
    then have "i. αi. αi  qbs_Mx X  Fi i = (λr. Inl (αi r))"
      using i. Fi i  copair_qbs_Mx2 X Y by(auto simp add: copair_qbs_Mx2_def)
    then have "α1. i. α1 i  qbs_Mx X  Fi i = (λr. Inl (α1 i r))"
      by(rule choice)
    then obtain α1 :: "nat  real  _" 
      where h1: "i. α1 i  qbs_Mx X  Fi i = (λr. Inl (α1 i r))" by auto
    define β :: "real  _" 
      where "β  (λr. α1 (P r) r)"
    from i. P -` {i}  sets real_borel h1
    have "β  qbs_Mx X"
      by (simp add: β_def)
    moreover have "(λr. Fi (P r) r) = (λr. Inl (β r))"
      using h1 by(simp add: β_def)
    ultimately show ?thesis
      using qbs_space X  {}  qbs_space Y = {} by (auto simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X = {}  qbs_space Y  {}"
    then have "i. αi. αi  qbs_Mx Y  Fi i = (λr. Inr (αi r))"
      using i. Fi i  copair_qbs_Mx2 X Y by(auto simp add: copair_qbs_Mx2_def)
    then have "α2. i. α2 i  qbs_Mx Y  Fi i = (λr. Inr (α2 i r))"
      by(rule choice)
    then obtain α2 :: "nat  real  _" 
      where h2: "i. α2 i  qbs_Mx Y  Fi i = (λr. Inr (α2 i r))" by auto
    define β :: "real  _" 
      where "β  (λr. α2 (P r) r)"
    from i. P -` {i}  sets real_borel h2 qbs_decomp
    have "β  qbs_Mx Y"
      by(simp add: β_def)
    moreover have "(λr. Fi (P r) r) = (λr. Inr (β r))"
      using h2 by(simp add: β_def)
    ultimately show ?thesis
      using qbs_space X = {}  qbs_space Y  {} by (auto simp add: copair_qbs_Mx2_def)
  next
    assume "qbs_space X  {}  qbs_space Y  {}"
    then have "i. Si. Si  sets real_borel  (α1i qbs_Mx X. α2i qbs_Mx Y.
                   Fi i = (λr::real. (if (r  Si) then Inl (α1i r) else Inr (α2i r))))"
      using i. Fi i  copair_qbs_Mx2 X Y by (auto simp add: copair_qbs_Mx2_def)
    then have "S. i. S i  sets real_borel  (α1i qbs_Mx X. α2i qbs_Mx Y.
                   Fi i = (λr::real. (if (r  S i) then Inl (α1i r) else Inr (α2i r))))"
      by(rule choice)
    then obtain S :: "nat  real set" 
      where hs :"i. S i  sets real_borel  (α1i qbs_Mx X. α2i qbs_Mx Y.
                   Fi i = (λr::real. (if (r  S i) then Inl (α1i r) else Inr (α2i r))))"
      by auto
    then have "i. α1i. α1i  qbs_Mx X  (α2i qbs_Mx Y.
               Fi i = (λr::real. (if (r  S i) then Inl (α1i r) else Inr (α2i r))))"
      by blast
    then have "α1. i. α1 i  qbs_Mx X  (α2i qbs_Mx Y.
               Fi i = (λr::real. (if (r  S i) then Inl (α1 i r) else Inr (α2i r))))"
      by(rule choice)
    then obtain α1 
      where h1: "i. α1 i  qbs_Mx X  (α2i qbs_Mx Y.
               Fi i = (λr::real. (if (r  S i) then Inl (α1 i r) else Inr (α2i r))))"
      by auto
    define β1 :: "real  _" 
      where "β1  (λr. α1 (P r) r)"
    from i. P -` {i}  sets real_borel h1 qbs_decomp
    have "β1  qbs_Mx X"
      by(simp add: β1_def)
    from h1 have "i. α2i. α2i qbs_Mx Y 
               Fi i = (λr::real. (if (r  S i) then Inl (α1 i r) else Inr (α2i r)))"
      by auto
    then have "α2. i. α2 i qbs_Mx Y 
               Fi i = (λr::real. (if (r  S i) then Inl (α1 i r) else Inr (α2 i r)))"
      by(rule choice)
    then obtain α2 
      where h2: "i. α2 i qbs_Mx Y 
               Fi i = (λr::real. (if (r  S i) then Inl (α1 i r) else Inr (α2 i r)))"
      by auto
    define β2 :: "real  _" 
      where "β2  (λr. α2 (P r) r)"
    from i. P -` {i}  sets real_borel h2 qbs_decomp
    have "β2  qbs_Mx Y"
      by(simp add: β2_def)
    define A :: "nat  real set"
      where "A  (λi. S i  P -` {i})"
    have "i. A i  sets real_borel"
      using A_def i. P -` {i}  sets real_borel hs by blast
    define S' :: "real set"
      where "S'  {r. r  S (P r)}"
    have "S' = (i::nat. A i)"
      by(auto simp add: S'_def A_def)
    hence "S'  sets real_borel"
      using i. A i  sets real_borel by auto
    from h2 have "(λr. Fi (P r) r) = (λr. (if r  S' then Inl (β1  r)
                                                      else Inr (β2 r)))"
      by(auto simp add: β1_def β2_def S'_def)
    thus "(λr. Fi (P r) r)  copair_qbs_Mx2 X Y"
      using qbs_space X  {}  qbs_space Y  {} S'  sets real_borel β1  qbs_Mx X β2  qbs_Mx Y
      by(auto simp add: copair_qbs_Mx2_def)
  qed
  thus "(λr. Fi (P r) r)  copair_qbs_Mx X Y"
    using copair_qbs_Mx_equiv by auto
qed

lemma copair_qbs_correct: "Rep_quasi_borel (copair_qbs X Y) = (qbs_space X <+> qbs_space Y, copair_qbs_Mx X Y)"
  unfolding copair_qbs_def
  by(auto intro!: Abs_quasi_borel_inverse copair_qbs_f simp: copair_qbs_closed2 copair_qbs_closed1 copair_qbs_closed3)

lemma copair_qbs_space[simp]: "qbs_space (copair_qbs X Y) = qbs_space X <+> qbs_space Y"
  by(simp add: qbs_space_def copair_qbs_correct)

lemma copair_qbs_Mx[simp]: "qbs_Mx (copair_qbs X Y) = copair_qbs_Mx X Y"
  by(simp add: qbs_Mx_def copair_qbs_correct)


lemma Inl_qbs_morphism:
  "Inl  X Q X <+>Q Y"
proof(rule qbs_morphismI)
  fix α
  assume "α  qbs_Mx X"
  moreover have "Inl  α = (λr. Inl (α r))" by auto
  ultimately show "Inl  α  qbs_Mx (X <+>Q Y)"
    by(auto simp add: copair_qbs_Mx_def)
qed

lemma Inr_qbs_morphism:
  "Inr  Y Q X <+>Q Y"
proof(rule qbs_morphismI)
  fix α
  assume "α  qbs_Mx Y"
  moreover have "Inr  α = (λr. Inr (α r))" by auto
  ultimately show "Inr  α  qbs_Mx (X <+>Q Y)"
    by(auto intro!: bexI[where x=UNIV] simp add: copair_qbs_Mx_def)
qed

lemma case_sum_preserves_morphisms:
  assumes "f  X Q Z"
      and "g  Y Q Z"
    shows "case_sum f g  X <+>Q Y Q Z"
proof(rule qbs_morphismI;auto)
  fix α
  assume "α  copair_qbs_Mx X Y"
  then obtain S where hs:"S sets real_borel  
  (S = {}    ( α1 qbs_Mx X. α = (λr. Inl (α1 r)))) 
  (S = UNIV  ( α2 qbs_Mx Y. α = (λr. Inr (α2 r)))) 
  ((S  {}  S  UNIV) 
     ( α1 qbs_Mx X.
       α2 qbs_Mx Y.
          α = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))))"
    by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S  {}  S  UNIV" by auto
  then show "case_sum f g  α  qbs_Mx Z"
  proof cases
    assume "S = {}"
    then obtain α1 where h1: "α1 qbs_Mx X  α = (λr. Inl (α1 r))"
      using hs by auto
    then have "f  α1  qbs_Mx Z"
      using assms by(auto simp add: qbs_morphism_def)
    moreover have "case_sum f g  α = f  α1"
      using h1 by auto
    ultimately show ?thesis by simp
  next
    assume "S = UNIV"
    then obtain α2 where h2: "α2 qbs_Mx Y  α = (λr. Inr (α2 r))"
      using hs by auto
    then have "g  α2  qbs_Mx Z"
      using assms by(auto simp add: qbs_morphism_def)
    moreover have "case_sum f g  α = g  α2"
      using h2 by auto
    ultimately show ?thesis by simp
  next
    assume "S  {}  S  UNIV"
    then obtain α1 α2 where h: "α1 qbs_Mx X  α2 qbs_Mx Y 
         α = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))"
      using hs by auto
    define F :: "nat  real  _"
      where "F  (λi r. (if i = 0 then (f  α1) r
                                    else (g  α2) r))"
    define P :: "real  nat"
      where "P  (λr. if r  S then 0 else 1)"
    have "f  α1  qbs_Mx Z"
      using assms h by(simp add: qbs_morphism_def)
    have "g  α2  qbs_Mx Z"
      using assms h by(simp add: qbs_morphism_def)
    have "i. F i  qbs_Mx Z"
    proof(auto simp add: F_def)
      fix i :: nat
      consider "i = 0" | "i  0" by auto
      then show "(λr. if i = 0 then (f  α1) r else (g  α2) r)  qbs_Mx Z"
      proof cases
        assume "i = 0"
        then have "(λr. if i = 0 then (f  α1) r else (g  α2) r) = f  α1" by auto
        then show ?thesis
          using f  α1  qbs_Mx Z by simp
      next
        assume "i  0"
        then have "(λr. if i = 0 then (f  α1) r else (g  α2) r) = g  α2" by auto
        then show ?thesis
          using g  α2  qbs_Mx Z by simp
      qed
    qed
    moreover have "i. P -`{i}  sets real_borel"
    proof
      fix i :: nat
      consider "i = 0" | "i = 1" | "i  0  i  1" by auto
      then show "P -`{i}  sets real_borel"
      proof cases
        assume "i = 0"
        then show ?thesis
          using hs by(simp add: P_def)
      next
        assume "i = 1"
        then show ?thesis
          using hs by (simp add: P_def borel_comp)
      next
        assume "i  0  i  1"
        then show ?thesis by(simp add: P_def)
      qed
    qed
    ultimately have "(λr. F (P r) r)  qbs_Mx Z"
      by simp
    moreover have "case_sum f g  α = (λr. F (P r) r)"
      using h by(auto simp add: F_def P_def)
    ultimately show "case_sum f g  α  qbs_Mx Z" by simp
  qed
qed


lemma map_sum_preserves_morphisms:
  assumes "f  X  Q Y"
      and "g  X' Q Y'"
    shows "map_sum f g  X <+>Q X' Q Y <+>Q Y'"
proof(rule qbs_morphismI,simp)
  fix α
  assume "α  copair_qbs_Mx X X'"
  then obtain S where hs:"S sets real_borel  
  (S = {}    ( α1 qbs_Mx X. α = (λr. Inl (α1 r)))) 
  (S = UNIV  ( α2 qbs_Mx X'. α = (λr. Inr (α2 r)))) 
  ((S  {}  S  UNIV) 
     ( α1 qbs_Mx X.
       α2 qbs_Mx X'.
          α = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))))"
    by (auto simp add: copair_qbs_Mx_def)
  consider "S = {}" | "S = UNIV" | "S  {}  S  UNIV" by auto
  then show "map_sum f g  α  copair_qbs_Mx Y Y'"
  proof cases
    assume "S = {}"
    then obtain α1 where h1: "α1 qbs_Mx X  α = (λr. Inl (α1 r))"
      using hs by auto
    define f' :: "real  _" where "f'  f  α1"
    then have "f'  qbs_Mx Y"
      using assms h1 by(simp add: qbs_morphism_def)
    moreover have "map_sum f g  α = (λr. Inl (f' r))"
      using h1 by (auto simp add: f'_def)
    moreover have "{}  sets real_borel" by simp
    ultimately show ?thesis
      by(auto simp add: copair_qbs_Mx_def)
  next
    assume "S = UNIV"
    then obtain α2 where h2: "α2 qbs_Mx X'  α = (λr. Inr (α2 r))"
      using hs by auto
    define g' :: "real  _" where "g'  g  α2"
    then have "g'  qbs_Mx Y'"
      using assms h2 by(simp add: qbs_morphism_def)
    moreover have "map_sum f g  α = (λr. Inr (g' r))"
      using h2 by (auto simp add: g'_def)
    ultimately show ?thesis
      by(auto intro!: bexI[where x=UNIV] simp add: copair_qbs_Mx_def)
  next
    assume "S  {}  S  UNIV"
    then obtain α1 α2 where h: "α1 qbs_Mx X  α2 qbs_Mx X' 
         α = (λr::real. (if (r  S) then Inl (α1 r) else Inr (α2 r)))"
      using hs by auto
    define f' :: "real  _" where "f'  f  α1"
    define g' :: "real  _" where "g'  g  α2"
    have "f'  qbs_Mx Y"
      using assms h by(auto simp: f'_def)
    moreover have "g'  qbs_Mx Y'"
      using assms h by(auto simp: g'_def)
    moreover have "map_sum f g  α = (λr::real. (if (r  S) then Inl (f' r) else Inr (g' r)))"
      using h by(auto simp add: f'_def g'_def)
    moreover have "S  sets real_borel" using hs by simp
    ultimately show ?thesis
      using S  {}  S  UNIV by(auto simp add: copair_qbs_Mx_def)
  qed
qed


end