theory Env
  imports Main HOLCF
begin

default_sort type

text {*
Our type for environments is a function with a pcpo as the co-domain; this theory collects
related definitions.
*}

subsubsection {* The domain of a pcpo-valued function *}

definition edom :: "('key \<Rightarrow> 'value::pcpo) \<Rightarrow> 'key set" where "edom m = {x. m x \<noteq> \<bottom>}"

lemma bot_edom[simp]: "edom \<bottom> = {}" by (simp add: edom_def)

lemma bot_edom2[simp]: "edom (\<lambda>_ . \<bottom>) = {}" by (simp add: edom_def)

lemma edomIff: "(a \<in> edom m) = (m a \<noteq> \<bottom>)" by (simp add: edom_def)

lemma lookup_not_edom: "x \<notin> edom m \<Longrightarrow> m x = \<bottom>"  by (auto iff:edomIff)

lemma lookup_edom[simp]: "m x \<noteq> \<bottom> \<Longrightarrow> x \<in> edom m"  by (auto iff:edomIff)

subsubsection {* Updates *}

lemma edom_fun_upd_subset: "edom (h (x := v)) \<subseteq> insert x (edom h)"
  by (auto simp add: edom_def)

declare fun_upd_same[simp] fun_upd_other[simp]

subsubsection {* Restriction *}

definition env_restr :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::pcpo) \<Rightarrow> ('a \<Rightarrow> 'b)"
  where "env_restr S m = (\<lambda> x. if x \<in> S then m x else \<bottom>)"

abbreviation env_restr_rev  (infixl "f|`"  110) where "env_restr_rev m S \<equiv> env_restr S m"

notation (latex output) env_restr_rev ("_|\<^bsub>_\<^esub>")

lemma env_restr_empty[simp]: "edom m \<inter> S = {} \<Longrightarrow> m f|` S = \<bottom>"
  by (fastforce simp add: edom_def env_restr_def)

lemma lookup_env_restr[simp]: "x \<in> S \<Longrightarrow> (env_restr S m) x = m x"
  by (fastforce simp add: env_restr_def)

lemma lookup_env_restr_not_there[simp]: "x \<notin> S \<Longrightarrow> (env_restr S m) x = \<bottom>"
  by (fastforce simp add: env_restr_def)

lemma lookup_env_restr_eq: "(m f|` S) x = (if x \<in> S then m x else \<bottom>)"
  by simp

lemma env_restr_eqI: "(\<And>x. x \<in> S \<Longrightarrow> m\<^sub>1 x = m\<^sub>2 x) \<Longrightarrow> m\<^sub>1 f|` S = m\<^sub>2 f|` S"
  by (auto simp add: lookup_env_restr_eq)

lemma env_restr_env_restr[simp]:
 "x f|` d2 f|` d1 = x f|` (d1 \<inter> d2)"
  by (fastforce simp add: env_restr_def)

lemma env_restr_env_restr_subset:
 "d1 \<subseteq> d2 \<Longrightarrow> x f|` d2 f|` d1 = x f|` d1"
 by (metis Int_absorb2 env_restr_env_restr)

lemma env_restr_useless: "edom m \<subseteq> S \<Longrightarrow> m f|` S = m"
  by (rule ext) (auto simp add: lookup_env_restr_eq dest!: set_mp)

lemma env_restr_UNIV[simp]: "m f|` UNIV = m"
  by (rule env_restr_useless) simp

lemma env_restr_fun_upd[simp]: "x \<in> S \<Longrightarrow> m1(x := v) f|` S = (m1 f|` S)(x := v)"
  apply (rule ext)
  apply (case_tac "xa = x")
  apply (auto simp add: lookup_env_restr_eq)
  done

lemma env_restr_fun_upd_other[simp]: "x \<notin> S \<Longrightarrow> m1(x := v) f|` S = m1 f|` S"
  apply (rule ext)
  apply (case_tac "xa = x")
  apply (auto simp add: lookup_env_restr_eq)
  done

lemma env_restr_eq_subset:
  assumes "S \<subseteq> S'"
  and "m1 f|` S' = m2 f|` S'"
  shows "m1 f|` S = m2 f|` S"
using assms
by (metis env_restr_env_restr le_iff_inf)

subsubsection {* Deleting *}

definition env_delete :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b::pcpo)"
  where "env_delete x m = m(x := \<bottom>)"

lemma lookup_env_delete[simp]:
  "x' \<noteq> x \<Longrightarrow> env_delete x m x' = m x'"
  by (simp add: env_delete_def)

lemma lookup_env_delete_None[simp]:
  "env_delete x m x = \<bottom>"
  by (simp add: env_delete_def)

lemma edom_env_delete[simp]:
  "edom (env_delete x m) = edom m - {x}"
  by (auto simp add: env_delete_def edom_def)

lemma edom_env_delete_subset:
  "edom (env_delete x m) \<subseteq> edom m" by auto

lemma env_delete_fun_upd[simp]:
  "env_delete x (m(x := v)) = env_delete x m"
  by (auto simp add: env_delete_def)

lemma env_delete_fun_upd2[simp]:
  "(env_delete x m)(x := v) = m(x := v)"
  by (auto simp add: env_delete_def)

lemma env_delete_fun_upd3[simp]:
  "x \<noteq> y \<Longrightarrow> env_delete x (m(y := v)) = (env_delete x m)(y := v)"
  by (auto simp add: env_delete_def)

lemma env_delete_noop[simp]:
  "x \<notin> edom m \<Longrightarrow> env_delete x m = m"
  by (auto simp add: env_delete_def edom_def)

lemma env_restr_env_delete_other[simp]: "x \<notin> S \<Longrightarrow> env_delete x m f|` S = m f|` S"
  apply (rule ext)
  apply (auto simp add: lookup_env_restr_eq)
  by (metis lookup_env_delete)

lemma env_delete_restr: "env_delete x m = m f|` (-{x})"
  by (auto simp add: lookup_env_restr_eq)

subsubsection {* Merging of two functions *}

text {*
We'd like to have some nice syntax for @{term "override_on"}.
*}

abbreviation override_on_syn ("_ ++\<^bsub>_\<^esub> _" [100, 0, 100] 100) where "f1 ++\<^bsub>S\<^esub> f2 \<equiv> override_on f1 f2 S"

lemma override_on_bot[simp]:
  "\<bottom> ++\<^bsub>S\<^esub> m = m f|` S"
  "m ++\<^bsub>S\<^esub> \<bottom> = m f|` (-S)"
  by (auto simp add: override_on_def env_restr_def)

lemma edom_override_on[simp]: "edom (m1 ++\<^bsub>S\<^esub> m2) = (edom m1 - S) \<union> (edom m2 \<inter> S)"
  by (auto simp add: override_on_def edom_def)

lemma lookup_override_on_eq: "(m1 ++\<^bsub>S\<^esub> m2) x = (if x \<in> S then m2 x else m1 x)"
  by (cases "x \<notin> S") simp_all

lemma override_on_upd_swap:
  "x \<notin> S \<Longrightarrow> \<rho>(x := z) ++\<^bsub>S\<^esub> \<rho>' = (\<rho> ++\<^bsub>S\<^esub> \<rho>')(x := z)"
  by (auto simp add: override_on_def  edom_def)

lemma override_on_upd:
  "x \<in> S \<Longrightarrow> \<rho> ++\<^bsub>S\<^esub> (\<rho>'(x := z)) = (\<rho> ++\<^bsub>S - {x}\<^esub> \<rho>')(x := z)"
  by (auto simp add: override_on_def  edom_def)

lemma env_restr_add: "(m1 ++\<^bsub>S2\<^esub> m2) f|` S = m1 f|` S ++\<^bsub>S2\<^esub> m2 f|` S"
  by (auto simp add: override_on_def  edom_def env_restr_def)

lemma env_delete_add: "env_delete x (m1 ++\<^bsub>S\<^esub> m2) = env_delete x m1 ++\<^bsub>S - {x}\<^esub> env_delete x m2"
  by (auto simp add: override_on_def  edom_def env_restr_def env_delete_def)

end


theory ETCS_Cartesian
  imports ETCS_Base
begin

section \<open>Axiom 2: Cartesian Products\<close>

axiomatization
  cart_prod :: "cset \<Rightarrow> cset \<Rightarrow> cset" (infixr "\<times>\<^sub>c" 65) and
  left_cart_proj :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  right_cart_proj :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" and
  cfunc_prod :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" ("\<langle>_,_\<rangle>")
where
  left_cart_proj_type[type_rule]: "left_cart_proj X Y : X \<times>\<^sub>c Y \<rightarrow> X" and
  right_cart_proj_type[type_rule]: "right_cart_proj X Y : X \<times>\<^sub>c Y \<rightarrow> Y" and
  cfunc_prod_type[type_rule]: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> \<langle>f,g\<rangle> : Z \<rightarrow> X \<times>\<^sub>c Y" and
  left_cart_proj_cfunc_prod: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> left_cart_proj X Y \<circ>\<^sub>c \<langle>f,g\<rangle> = f" and
  right_cart_proj_cfunc_prod: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> right_cart_proj X Y \<circ>\<^sub>c \<langle>f,g\<rangle> = g" and
  cfunc_prod_unique: "f : Z \<rightarrow> X \<Longrightarrow> g : Z \<rightarrow> Y \<Longrightarrow> h : Z \<rightarrow> X \<times>\<^sub>c Y \<Longrightarrow>
    left_cart_proj X Y \<circ>\<^sub>c h = f \<Longrightarrow> right_cart_proj X Y \<circ>\<^sub>c h = g \<Longrightarrow> h = \<langle>f,g\<rangle>"

definition is_cart_prod :: "cset \<Rightarrow> cfunc \<Rightarrow> cfunc \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> bool" where
  "is_cart_prod W \<pi>\<^sub>0 \<pi>\<^sub>1 X Y \<longleftrightarrow>
    (\<pi>\<^sub>0 : W \<rightarrow> X \<and> \<pi>\<^sub>1 : W \<rightarrow> Y \<and>
    (\<forall> f g Z. (f : Z \<rightarrow> X \<and> g : Z \<rightarrow> Y) \<longrightarrow>
      (\<exists> h. h : Z \<rightarrow> W \<and> \<pi>\<^sub>0 \<circ>\<^sub>c h = f \<and> \<pi>\<^sub>1 \<circ>\<^sub>c h = g \<and>
        (\<forall> h2. (h2 : Z \<rightarrow> W \<and> \<pi>\<^sub>0 \<circ>\<^sub>c h2 = f \<and> \<pi>\<^sub>1 \<circ>\<^sub>c h2 = g) \<longrightarrow> h2 = h))))"

abbreviation is_cart_prod_triple :: "cset \<times> cfunc \<times> cfunc \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> bool" where
  "is_cart_prod_triple W\<pi> X Y \<equiv> is_cart_prod (fst W\<pi>) (fst (snd W\<pi>)) (snd (snd W\<pi>)) X Y"

lemma canonical_cart_prod_is_cart_prod:
 "is_cart_prod (X \<times>\<^sub>c Y) (left_cart_proj X Y) (right_cart_proj X Y) X Y"
  unfolding is_cart_prod_def
proof auto
  show "left_cart_proj X Y: X \<times>\<^sub>c Y \<rightarrow> X"
    using left_cart_proj_type by blast
  show "right_cart_proj X Y: X \<times>\<^sub>c Y \<rightarrow> Y"
    using right_cart_proj_type by blast
next
  fix f g Z
  assume f_type: "f: Z \<rightarrow> X"
  assume g_type: "g: Z \<rightarrow> Y"
  show "\<exists>h. h : Z \<rightarrow> X \<times>\<^sub>c Y \<and>
           left_cart_proj X Y \<circ>\<^sub>c h = f \<and>
           right_cart_proj X Y \<circ>\<^sub>c h = g \<and>
           (\<forall>h2. h2 : Z \<rightarrow> X \<times>\<^sub>c Y \<and>
                 left_cart_proj X Y \<circ>\<^sub>c h2 = f \<and> right_cart_proj X Y \<circ>\<^sub>c h2 = g \<longrightarrow>
                 h2 = h)"
    apply (rule_tac x="\<langle>f,g\<rangle>" in exI)
    apply auto
       apply (simp add: cfunc_prod_type f_type g_type)
       using f_type g_type left_cart_proj_cfunc_prod apply blast
       using f_type g_type right_cart_proj_cfunc_prod apply blast
       using cfunc_prod_unique f_type g_type by blast
qed

(*Proposition 2.1.8*: Suppose that both (W,\<pi>_0,\<pi>_1) and (W',\<pi>'_0,\<pi>'_1) are
Cartesian products of X and Y.  Then there is an isomorphism f:W\<rightarrow>W' such that
\<pi>'_0f = \<pi>_0 and \<pi>'_1f = \<pi>_1.*)
lemma cart_prods_isomorphic:
  assumes W_cart_prod:  "is_cart_prod_triple (W, \<pi>\<^sub>0, \<pi>\<^sub>1) X Y"
  assumes W'_cart_prod: "is_cart_prod_triple (W', \<pi>'\<^sub>0, \<pi>'\<^sub>1) X Y"
  shows "\<exists> f. f : W \<rightarrow> W' \<and> isomorphism f \<and> \<pi>'\<^sub>0 \<circ>\<^sub>c f = \<pi>\<^sub>0 \<and> \<pi>'\<^sub>1 \<circ>\<^sub>c f = \<pi>\<^sub>1"
proof -
  obtain f where f_def: "f : W \<rightarrow> W' \<and> \<pi>'\<^sub>0 \<circ>\<^sub>c f = \<pi>\<^sub>0 \<and> \<pi>'\<^sub>1 \<circ>\<^sub>c f = \<pi>\<^sub>1"
    using W'_cart_prod W_cart_prod unfolding is_cart_prod_def by (metis fstI sndI)

  obtain g where g_def: "g : W' \<rightarrow> W \<and> \<pi>\<^sub>0 \<circ>\<^sub>c g = \<pi>'\<^sub>0 \<and> \<pi>\<^sub>1 \<circ>\<^sub>c g = \<pi>'\<^sub>1"
      using W'_cart_prod W_cart_prod unfolding is_cart_prod_def by (metis fstI sndI)

  have fg0: "\<pi>'\<^sub>0 \<circ>\<^sub>c (f \<circ>\<^sub>c g) = \<pi>'\<^sub>0"
    using W'_cart_prod comp_associative2 f_def g_def is_cart_prod_def by auto
  have fg1: "\<pi>'\<^sub>1 \<circ>\<^sub>c (f \<circ>\<^sub>c g) = \<pi>'\<^sub>1"
    using W'_cart_prod comp_associative2 f_def g_def is_cart_prod_def by auto

  obtain idW' where "idW' : W' \<rightarrow> W' \<and> (\<forall> h2. (h2 : W' \<rightarrow> W' \<and> \<pi>'\<^sub>0 \<circ>\<^sub>c h2 = \<pi>'\<^sub>0 \<and> \<pi>'\<^sub>1 \<circ>\<^sub>c h2 = \<pi>'\<^sub>1) \<longrightarrow> h2 = idW')"
    using W'_cart_prod unfolding is_cart_prod_def by (metis fst_conv snd_conv)
  then have fg: "f \<circ>\<^sub>c g = id W'"
  proof auto
    assume idW'_unique: "\<forall>h2. h2 : W' \<rightarrow> W' \<and> \<pi>'\<^sub>0 \<circ>\<^sub>c h2 = \<pi>'\<^sub>0 \<and> \<pi>'\<^sub>1 \<circ>\<^sub>c h2 = \<pi>'\<^sub>1 \<longrightarrow> h2 = idW'"
    have 1: "f \<circ>\<^sub>c g = idW'"
      using idW'_unique apply (erule_tac x="f \<circ>\<^sub>c g" in allE, auto)
      using cfunc_type_def codomain_comp domain_comp f_def fg0 fg1 g_def by auto
    have 2: "id W' = idW'"
      using idW'_unique apply (erule_tac x="f \<circ>\<^sub>c g" in allE, auto)
      using W'_cart_prod id_right_unit2 id_type is_cart_prod_def by auto
    from 1 2 show "f \<circ>\<^sub>c g = id W'"
      by auto
  qed

  have gf0: "\<pi>\<^sub>0 \<circ>\<^sub>c (g \<circ>\<^sub>c f) = \<pi>\<^sub>0"
    using W_cart_prod comp_associative2 f_def g_def is_cart_prod_def by auto
  have gf1: "\<pi>\<^sub>1 \<circ>\<^sub>c (g \<circ>\<^sub>c f) = \<pi>\<^sub>1"
    using W_cart_prod comp_associative2 f_def g_def is_cart_prod_def by auto

  obtain idW where "idW : W \<rightarrow> W \<and> (\<forall> h2. (h2 : W \<rightarrow> W \<and> \<pi>\<^sub>0 \<circ>\<^sub>c h2 = \<pi>\<^sub>0 \<and> \<pi>\<^sub>1 \<circ>\<^sub>c h2 = \<pi>\<^sub>1) \<longrightarrow> h2 = idW)"
    using W_cart_prod unfolding is_cart_prod_def by (metis fst_conv snd_conv)
  then have gf: "g \<circ>\<^sub>c f = id W"
  proof auto
    assume idW_unique: "\<forall>h2. h2 : W \<rightarrow> W \<and> \<pi>\<^sub>0 \<circ>\<^sub>c h2 = \<pi>\<^sub>0 \<and> \<pi>\<^sub>1 \<circ>\<^sub>c h2 = \<pi>\<^sub>1 \<longrightarrow> h2 = idW"
    have 1: "g \<circ>\<^sub>c f = idW"
      using idW_unique apply (erule_tac x="g \<circ>\<^sub>c f" in allE, auto)
      using cfunc_type_def codomain_comp domain_comp f_def gf0 gf1 g_def by auto
    have 2: "id W = idW"
      using idW_unique apply (erule_tac x="id W" in allE, auto)
      using W_cart_prod id_right_unit2 id_type is_cart_prod_def by auto
    from 1 2 show "g \<circ>\<^sub>c f = id W"
      by auto
  qed

  have f_iso: "isomorphism f"
    unfolding isomorphism_def apply (rule_tac x=g in exI, auto)
    using cfunc_type_def f_def g_def fg gf by auto

  from f_iso f_def show "\<exists>f. f : W \<rightarrow> W' \<and> isomorphism f \<and> \<pi>'\<^sub>0 \<circ>\<^sub>c f = \<pi>\<^sub>0 \<and> \<pi>'\<^sub>1 \<circ>\<^sub>c f = \<pi>\<^sub>1"
    by auto
qed

(*Product commutes*)

lemma product_commutes:
  "A \<times>\<^sub>c B \<cong> B \<times>\<^sub>c A"
proof -
  have qprod_type: "\<langle>right_cart_proj B A, left_cart_proj B A\<rangle> : B \<times>\<^sub>c A \<rightarrow> A \<times>\<^sub>c B"
    by (simp add: cfunc_prod_type left_cart_proj_type right_cart_proj_type)
  have pprod_type: "\<langle>right_cart_proj A B, left_cart_proj A B\<rangle> : A \<times>\<^sub>c B \<rightarrow> B \<times>\<^sub>c A"
    by (simp add: cfunc_prod_type left_cart_proj_type right_cart_proj_type)
  have id_AB: "\<langle>right_cart_proj B A, left_cart_proj B A\<rangle> \<circ>\<^sub>c \<langle>right_cart_proj A B, left_cart_proj A B\<rangle> = id(A \<times>\<^sub>c B)"
    by (smt cfunc_prod_unique cfunc_type_def comp_associative comp_type id_right_unit id_type left_cart_proj_cfunc_prod left_cart_proj_type pprod_type qprod_type right_cart_proj_cfunc_prod right_cart_proj_type)
  have fact1: "\<langle>right_cart_proj A B, left_cart_proj A B\<rangle> \<circ>\<^sub>c \<langle>right_cart_proj B A, left_cart_proj B A\<rangle>: B \<times>\<^sub>c A \<rightarrow>  B \<times>\<^sub>c A"
    by (meson comp_type pprod_type qprod_type)
  have id_BA: "\<langle>right_cart_proj A B, left_cart_proj A B\<rangle> \<circ>\<^sub>c \<langle>right_cart_proj B A, left_cart_proj B A\<rangle> = id(B \<times>\<^sub>c A)"
    by (smt cfunc_prod_unique comp_associative2 comp_type id_right_unit2 id_type left_cart_proj_cfunc_prod left_cart_proj_type pprod_type qprod_type right_cart_proj_cfunc_prod right_cart_proj_type)

  show "A \<times>\<^sub>c B \<cong> B \<times>\<^sub>c A"
    by (metis cfunc_type_def id_AB id_BA is_isomorphic_def isomorphism_def pprod_type qprod_type)
  qed

(*Definition 2.1.9*)
definition diagonal :: "cset \<Rightarrow> cfunc" where
  "diagonal(X) = \<langle>id(X),id(X)\<rangle>"

lemma diagonal_type[type_rule]:
  "diagonal X : X \<rightarrow> X \<times>\<^sub>c X"
  unfolding diagonal_def by (simp add: cfunc_prod_type id_type)

(*Note at the end of Definition 2.1.9*)
lemma diag_mono:
"monomorphism(diagonal(X))"
proof -
  have f1: "left_cart_proj X X \<circ>\<^sub>c diagonal X = id(X)"
    by (metis diagonal_def id_type left_cart_proj_cfunc_prod)
  show "monomorphism(diagonal(X))"
    by (metis cfunc_type_def comp_monic_imp_monic diagonal_type f1 id_isomorphism iso_imp_epi_and_monic left_cart_proj_type)
qed

(*Definition 2.1.10*)
definition cfunc_cross_prod :: "cfunc \<Rightarrow> cfunc \<Rightarrow> cfunc" (infixr "\<times>\<^sub>f" 55) where
  "f \<times>\<^sub>f g = \<langle>f \<circ>\<^sub>c left_cart_proj (domain f) (domain g), g \<circ>\<^sub>c right_cart_proj (domain f) (domain g)\<rangle>"

lemma cfunc_cross_prod_def2:
  assumes "f : X \<rightarrow> Y" "g : V\<rightarrow> W"
  shows "f \<times>\<^sub>f g = \<langle>f \<circ>\<^sub>c left_cart_proj X V, g \<circ>\<^sub>c right_cart_proj X V\<rangle>"
  using assms cfunc_cross_prod_def cfunc_type_def by auto

lemma cfunc_cross_prod_type[type_rule]:
  "f : W \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Z \<Longrightarrow> f \<times>\<^sub>f g : W \<times>\<^sub>c X \<rightarrow> Y \<times>\<^sub>c Z"
  unfolding cfunc_cross_prod_def
  using cfunc_prod_type cfunc_type_def comp_type left_cart_proj_type right_cart_proj_type by auto

lemma left_cart_proj_cfunc_cross_prod:
  "f : W \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Z \<Longrightarrow> left_cart_proj Y Z \<circ>\<^sub>c f \<times>\<^sub>f g = f \<circ>\<^sub>c left_cart_proj W X"
  unfolding cfunc_cross_prod_def
  using cfunc_type_def comp_type left_cart_proj_cfunc_prod left_cart_proj_type right_cart_proj_type by (smt (verit))

lemma right_cart_proj_cfunc_cross_prod:
  "f : W \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Z \<Longrightarrow> right_cart_proj Y Z \<circ>\<^sub>c f \<times>\<^sub>f g = g \<circ>\<^sub>c right_cart_proj W X"
  unfolding cfunc_cross_prod_def
  using cfunc_type_def comp_type right_cart_proj_cfunc_prod left_cart_proj_type right_cart_proj_type by (smt (verit))

lemma cfunc_cross_prod_unique: "f : W \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Z \<Longrightarrow> h : W \<times>\<^sub>c X \<rightarrow> Y \<times>\<^sub>c Z \<Longrightarrow>
    left_cart_proj Y Z \<circ>\<^sub>c h = f \<circ>\<^sub>c left_cart_proj W X \<Longrightarrow>
    right_cart_proj Y Z \<circ>\<^sub>c h = g \<circ>\<^sub>c right_cart_proj W X \<Longrightarrow> h = f \<times>\<^sub>f g"
  unfolding cfunc_cross_prod_def
  using cfunc_prod_unique cfunc_type_def comp_type left_cart_proj_type right_cart_proj_type by auto

(*Proposition 2.1.11*)
lemma identity_distributes_across_composition:
  assumes f_type: "f : A \<rightarrow> B" and g_type: "g : B \<rightarrow> C"
  shows "id(X) \<times>\<^sub>f (g  \<circ>\<^sub>c f) = (id(X) \<times>\<^sub>f g) \<circ>\<^sub>c (id(X) \<times>\<^sub>f f)"
proof -
  from cfunc_cross_prod_unique
  have uniqueness: "\<forall>h. h : X \<times>\<^sub>c A \<rightarrow> X \<times>\<^sub>c C \<and>
    left_cart_proj X C \<circ>\<^sub>c h = id\<^sub>c X \<circ>\<^sub>c left_cart_proj X A \<and>
    right_cart_proj X C \<circ>\<^sub>c h = (g \<circ>\<^sub>c f) \<circ>\<^sub>c right_cart_proj X A \<longrightarrow>
    h = id\<^sub>c X \<times>\<^sub>f (g \<circ>\<^sub>c f)"
    by (meson comp_type f_type g_type id_type)

  have left_eq: "left_cart_proj X C \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f f) = id\<^sub>c X \<circ>\<^sub>c left_cart_proj X A"
    using assms apply (typecheck_cfuncs)
    thm type_rule
    by (smt comp_associative2 id_left_unit2 left_cart_proj_cfunc_cross_prod left_cart_proj_type)
  have right_eq: "right_cart_proj X C \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c (id\<^sub>c X \<times>\<^sub>f f) = (g \<circ>\<^sub>c f) \<circ>\<^sub>c right_cart_proj X A"
    using assms apply (typecheck_cfuncs)
    by (smt comp_associative2 right_cart_proj_cfunc_cross_prod right_cart_proj_type)

  show "id\<^sub>c X \<times>\<^sub>f g \<circ>\<^sub>c f = (id\<^sub>c X \<times>\<^sub>f g) \<circ>\<^sub>c id\<^sub>c X \<times>\<^sub>f f"
    using assms left_eq right_eq uniqueness by (typecheck_cfuncs, auto)
qed

lemma cfunc_cross_prod_comp_cfunc_prod:
  assumes a_type: "a : A \<rightarrow> W" and b_type: "b : A \<rightarrow> X"
  assumes f_type: "f : W \<rightarrow> Y" and g_type: "g : X \<rightarrow> Z"
  shows "(f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>a, b\<rangle> = \<langle>f \<circ>\<^sub>c a, g \<circ>\<^sub>c b\<rangle>"
proof -
  from cfunc_prod_unique have uniqueness:
    "\<forall>h. h : A \<rightarrow> Y \<times>\<^sub>c Z \<and> left_cart_proj Y Z \<circ>\<^sub>c h = f \<circ>\<^sub>c a \<and> right_cart_proj Y Z \<circ>\<^sub>c h = g \<circ>\<^sub>c b \<longrightarrow>
      h = \<langle>f \<circ>\<^sub>c a, g \<circ>\<^sub>c b\<rangle>"
    using assms comp_type by blast

  have "left_cart_proj Y Z \<circ>\<^sub>c (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>a, b\<rangle> = f \<circ>\<^sub>c left_cart_proj W X \<circ>\<^sub>c \<langle>a, b\<rangle>"
    using assms by (typecheck_cfuncs, simp add: comp_associative2 left_cart_proj_cfunc_cross_prod)
  then have left_eq: "left_cart_proj Y Z \<circ>\<^sub>c (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>a, b\<rangle> = f \<circ>\<^sub>c a"
    using a_type b_type left_cart_proj_cfunc_prod by auto

  have "right_cart_proj Y Z \<circ>\<^sub>c (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>a, b\<rangle> = g \<circ>\<^sub>c right_cart_proj W X \<circ>\<^sub>c \<langle>a, b\<rangle>"
    using assms by (typecheck_cfuncs, simp add: comp_associative2 right_cart_proj_cfunc_cross_prod)
  then have right_eq: "right_cart_proj Y Z \<circ>\<^sub>c (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>a, b\<rangle> = g \<circ>\<^sub>c b"
    using a_type b_type right_cart_proj_cfunc_prod by auto

  show "(f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>a,b\<rangle> = \<langle>f \<circ>\<^sub>c a,g \<circ>\<^sub>c b\<rangle>"
    using uniqueness left_eq right_eq assms apply (erule_tac x="f \<times>\<^sub>f g \<circ>\<^sub>c \<langle>a,b\<rangle>" in allE)
    by (meson cfunc_cross_prod_type cfunc_prod_type comp_type uniqueness)
qed

lemma cfunc_prod_comp:
  assumes f_type: "f : X \<rightarrow> Y"
  assumes a_type: "a : Y \<rightarrow> A" and b_type: "b : Y \<rightarrow> B"
  shows "\<langle>a, b\<rangle> \<circ>\<^sub>c f = \<langle>a \<circ>\<^sub>c f, b \<circ>\<^sub>c f\<rangle>"
proof -

  have same_type: "\<langle>a, b\<rangle> \<circ>\<^sub>c f : X \<rightarrow> A \<times>\<^sub>c B"
    using a_type b_type cfunc_prod_type comp_type f_type by auto
  have same_left_proj: "left_cart_proj A B \<circ>\<^sub>c \<langle>a, b\<rangle> \<circ>\<^sub>c f = a \<circ>\<^sub>c f"
    using assms by (typecheck_cfuncs, simp add: comp_associative2 left_cart_proj_cfunc_prod)
  have same_right_proj: "right_cart_proj A B \<circ>\<^sub>c \<langle>a, b\<rangle> \<circ>\<^sub>c f = b \<circ>\<^sub>c f"
    using assms comp_associative2 right_cart_proj_cfunc_prod by (typecheck_cfuncs, auto)

  show "\<langle>a,b\<rangle> \<circ>\<^sub>c f = \<langle>a \<circ>\<^sub>c f, b \<circ>\<^sub>c f\<rangle>"
    using a_type b_type cfunc_prod_unique comp_type f_type same_left_proj same_right_proj same_type by blast
qed

(*Exercise 2.1.12: Product of identities is identity of product*)
lemma id_cross_prod: "id(X) \<times>\<^sub>f id(Y) = id(X \<times>\<^sub>c Y)"
  unfolding cfunc_cross_prod_def
  by (metis cfunc_prod_unique cfunc_type_def id_left_unit id_right_unit id_type left_cart_proj_type right_cart_proj_type)

(*Exercise 2.1.14: diagonal_commutes_cross_product*)
lemma cfunc_cross_prod_comp_diagonal:
  assumes "f: X \<rightarrow> Y"
  shows "(f \<times>\<^sub>f f) \<circ>\<^sub>c diagonal(X) = diagonal(Y) \<circ>\<^sub>c f"
  unfolding diagonal_def
proof -
  have "(f \<times>\<^sub>f f) \<circ>\<^sub>c \<langle>id\<^sub>c X, id\<^sub>c X\<rangle> = \<langle>f \<circ>\<^sub>c id\<^sub>c X, f \<circ>\<^sub>c id\<^sub>c X\<rangle>"
    using assms cfunc_cross_prod_comp_cfunc_prod id_type by blast
  also have "... = \<langle>f, f\<rangle>"
    using assms cfunc_type_def id_right_unit by auto
  also have "... = \<langle>id\<^sub>c Y \<circ>\<^sub>c f, id\<^sub>c Y \<circ>\<^sub>c f\<rangle>"
    using assms cfunc_type_def id_left_unit by auto
  also have "... = \<langle>id\<^sub>c Y, id\<^sub>c Y\<rangle> \<circ>\<^sub>c f"
    using assms cfunc_prod_comp id_type by fastforce
  then show "(f \<times>\<^sub>f f) \<circ>\<^sub>c \<langle>id\<^sub>c X,id\<^sub>c X\<rangle> = \<langle>id\<^sub>c Y,id\<^sub>c Y\<rangle> \<circ>\<^sub>c f"
    using calculation by auto
qed

lemma cfunc_cross_prod_comp_cfunc_cross_prod:
  assumes "a : A \<rightarrow> X" "b : B \<rightarrow> Y" "x : X \<rightarrow> Z" "y : Y \<rightarrow> W"
  shows "(x \<times>\<^sub>f y) \<circ>\<^sub>c (a \<times>\<^sub>f b) = (x \<circ>\<^sub>c a) \<times>\<^sub>f (y \<circ>\<^sub>c b)"
proof -
  have "(x \<times>\<^sub>f y) \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c left_cart_proj A B , b \<circ>\<^sub>c right_cart_proj A B\<rangle>
      = \<langle>x \<circ>\<^sub>c a \<circ>\<^sub>c left_cart_proj A B, y \<circ>\<^sub>c b \<circ>\<^sub>c right_cart_proj A B\<rangle>"
    by (meson assms cfunc_cross_prod_comp_cfunc_prod comp_type left_cart_proj_type right_cart_proj_type)
  then show "(x \<times>\<^sub>f y) \<circ>\<^sub>c a \<times>\<^sub>f b = (x \<circ>\<^sub>c a) \<times>\<^sub>f y \<circ>\<^sub>c b"
    using assms cfunc_type_def cfunc_cross_prod_def comp_associative2 left_cart_proj_type right_cart_proj_type
    by (typecheck_cfuncs, auto)
qed

lemma cart_prod_eq:
  assumes "a : Z \<rightarrow> X \<times>\<^sub>c Y" "b : Z \<rightarrow>  X \<times>\<^sub>c Y"
  shows "a = b \<longleftrightarrow>
    (left_cart_proj X Y \<circ>\<^sub>c a = left_cart_proj X Y \<circ>\<^sub>c b
      \<and> right_cart_proj X Y \<circ>\<^sub>c a = right_cart_proj X Y \<circ>\<^sub>c b)"
  by (metis (full_types) assms cfunc_prod_unique comp_type left_cart_proj_type right_cart_proj_type)

lemma cart_prod_eqI:
  assumes "a : Z \<rightarrow> X \<times>\<^sub>c Y" "b : Z \<rightarrow>  X \<times>\<^sub>c Y"
  assumes "(left_cart_proj X Y \<circ>\<^sub>c a = left_cart_proj X Y \<circ>\<^sub>c b
      \<and> right_cart_proj X Y \<circ>\<^sub>c a = right_cart_proj X Y \<circ>\<^sub>c b)"
  shows "a = b"
  using assms cart_prod_eq by blast

lemma cart_prod_eq2:
  assumes "a : Z \<rightarrow> X" "b : Z \<rightarrow> Y" "c : Z \<rightarrow>  X" "d : Z \<rightarrow>  Y"
  shows "\<langle>a, b\<rangle> = \<langle>c,d\<rangle> \<longleftrightarrow> (a = c \<and> b = d)"
  by (metis assms left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)

lemma cart_prod_decomp:
  assumes "a : A \<rightarrow> X \<times>\<^sub>c Y"
  shows "\<exists> x y. a = \<langle>x, y\<rangle> \<and> x : A \<rightarrow> X \<and> y : A \<rightarrow> Y"
proof (rule_tac x="left_cart_proj X Y \<circ>\<^sub>c a" in exI, rule_tac x="right_cart_proj X Y \<circ>\<^sub>c a" in exI, auto)
  show "a = \<langle>left_cart_proj X Y \<circ>\<^sub>c a,right_cart_proj X Y \<circ>\<^sub>c a\<rangle>"
    using assms cfunc_prod_unique comp_type left_cart_proj_type right_cart_proj_type by blast
  show "left_cart_proj X Y \<circ>\<^sub>c a : A \<rightarrow>  X"
    using assms left_cart_proj_type comp_type by auto
  show "right_cart_proj X Y \<circ>\<^sub>c a : A \<rightarrow> Y"
    using assms right_cart_proj_type comp_type by auto
qed

lemma cfunc_cross_prod_mono:
  assumes type_assms: "f : X \<rightarrow> Y" "g : Z \<rightarrow> W"
  assumes f_mono: "monomorphism f" and g_mono: "monomorphism g"
  shows "monomorphism (f \<times>\<^sub>f g)"
  using type_assms
proof (typecheck_cfuncs, unfold monomorphism_def3, auto)
  fix x y A
  assume x_type: "x : A \<rightarrow> X \<times>\<^sub>c Z"
  assume y_type: "y : A \<rightarrow> X \<times>\<^sub>c Z"

  obtain x1 x2 where x_expand: "x = \<langle>x1, x2\<rangle>" and x1_x2_type: "x1 : A \<rightarrow> X" "x2 : A \<rightarrow> Z"
    using cfunc_prod_unique comp_type left_cart_proj_type right_cart_proj_type x_type by blast
  obtain y1 y2 where y_expand: "y = \<langle>y1, y2\<rangle>" and y1_y2_type: "y1 : A \<rightarrow> X" "y2 : A \<rightarrow> Z"
    using cfunc_prod_unique comp_type left_cart_proj_type right_cart_proj_type y_type by blast

  assume "(f \<times>\<^sub>f g) \<circ>\<^sub>c x = (f \<times>\<^sub>f g) \<circ>\<^sub>c y"
  then have "(f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>x1, x2\<rangle> = (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>y1, y2\<rangle>"
    using x_expand y_expand by blast
  then have "\<langle>f \<circ>\<^sub>c x1, g \<circ>\<^sub>c x2\<rangle> = \<langle>f \<circ>\<^sub>c y1, g \<circ>\<^sub>c y2\<rangle>"
    using cfunc_cross_prod_comp_cfunc_prod type_assms x1_x2_type y1_y2_type by auto
  then have "f \<circ>\<^sub>c x1 = f \<circ>\<^sub>c y1 \<and> g \<circ>\<^sub>c x2 = g \<circ>\<^sub>c y2"
    by (meson cart_prod_eq2 comp_type type_assms x1_x2_type y1_y2_type)
  then have "x1 = y1 \<and> x2 = y2"
    using cfunc_type_def f_mono g_mono monomorphism_def type_assms x1_x2_type y1_y2_type by auto
  then have "\<langle>x1, x2\<rangle> = \<langle>y1, y2\<rangle>"
    by blast
  then show "x = y"
    by (simp add: x_expand y_expand)
qed

subsection \<open>Useful Cartesian product permuting functions\<close>

subsubsection \<open>Swapping a Cartesian product\<close>

definition swap :: "cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "swap X Y = \<langle>right_cart_proj X Y, left_cart_proj X Y\<rangle>"

lemma swap_type[type_rule]: "swap X Y : X \<times>\<^sub>c Y \<rightarrow> Y \<times>\<^sub>c X"
  unfolding swap_def by (simp add: cfunc_prod_type left_cart_proj_type right_cart_proj_type)

lemma swap_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y"
  shows "swap X Y \<circ>\<^sub>c \<langle>x, y\<rangle> = \<langle>y, x\<rangle>"
proof -
  have "swap X Y \<circ>\<^sub>c \<langle>x, y\<rangle> = \<langle>right_cart_proj X Y,left_cart_proj X Y\<rangle> \<circ>\<^sub>c \<langle>x,y\<rangle>"
    unfolding swap_def by auto
  also have "... = \<langle>right_cart_proj X Y \<circ>\<^sub>c \<langle>x,y\<rangle>, left_cart_proj X Y \<circ>\<^sub>c \<langle>x,y\<rangle>\<rangle>"
    by (meson assms cfunc_prod_comp cfunc_prod_type left_cart_proj_type right_cart_proj_type)
  also have "... = \<langle>y, x\<rangle>"
    using assms left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

lemma swap_cross_prod:
  assumes "x : A \<rightarrow> X" "y : B \<rightarrow> Y"
  shows "swap X Y \<circ>\<^sub>c (x \<times>\<^sub>f y) = (y \<times>\<^sub>f x) \<circ>\<^sub>c swap A B"
proof -
  have "swap X Y \<circ>\<^sub>c (x \<times>\<^sub>f y) = swap X Y \<circ>\<^sub>c \<langle>x \<circ>\<^sub>c left_cart_proj A B, y \<circ>\<^sub>c right_cart_proj A B\<rangle>"
    using assms unfolding cfunc_cross_prod_def cfunc_type_def by auto
  also have "... = \<langle>y \<circ>\<^sub>c right_cart_proj A B, x \<circ>\<^sub>c left_cart_proj A B\<rangle>"
    by (meson assms comp_type left_cart_proj_type right_cart_proj_type swap_ap)
  also have "... = (y \<times>\<^sub>f x) \<circ>\<^sub>c \<langle>right_cart_proj A B, left_cart_proj A B\<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_cross_prod_comp_cfunc_prod)
  also have "... = (y \<times>\<^sub>f x) \<circ>\<^sub>c swap A B"
    unfolding swap_def by auto
  then show ?thesis
    using calculation by auto
qed

lemma swap_idempotent:
  "swap Y X \<circ>\<^sub>c swap X Y = id (X \<times>\<^sub>c Y)"
  by (metis swap_def cfunc_prod_unique id_right_unit2 id_type left_cart_proj_type
      right_cart_proj_type swap_ap)

lemma swap_mono:
  "monomorphism(swap X Y)"
  by (metis cfunc_type_def iso_imp_epi_and_monic isomorphism_def swap_idempotent swap_type)

subsubsection \<open>Permuting a Cartesian product to associate to the right\<close>

definition associate_right :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "associate_right X Y Z =
    \<langle>
      left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z,
      \<langle>
        right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z,
        right_cart_proj (X \<times>\<^sub>c Y) Z
      \<rangle>
    \<rangle>"

lemma associate_right_type[type_rule]: "associate_right X Y Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
  unfolding associate_right_def by (meson cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type)

lemma associate_right_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "associate_right X Y Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle> = \<langle>x, \<langle>y, z\<rangle>\<rangle>"
  (is "?lhs = ?rhs")
proof -
  have xy_z_type: "\<langle>\<langle>x,y\<rangle>,z\<rangle> : A \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
    by (simp add: assms cfunc_prod_type)
  have ll_type: "left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> X"
    using comp_type left_cart_proj_type by blast
  have rl_r_type:
    "\<langle>right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z,right_cart_proj (X \<times>\<^sub>c Y) Z\<rangle>
      : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> Y \<times>\<^sub>c Z"
    using cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type by blast

  have "?lhs = \<langle>
    left_cart_proj X Y \<circ>\<^sub>c  left_cart_proj (X \<times>\<^sub>c Y) Z,
      \<langle>
        right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z,
        right_cart_proj (X \<times>\<^sub>c Y) Z
      \<rangle>
    \<rangle> \<circ>\<^sub>c \<langle>\<langle>x,y\<rangle>,z\<rangle>"
    unfolding associate_right_def by auto
  also have "... = \<langle>
    (left_cart_proj X Y \<circ>\<^sub>c  left_cart_proj (X \<times>\<^sub>c Y) Z) \<circ>\<^sub>c \<langle>\<langle>x,y\<rangle>,z\<rangle>,
      \<langle>
        (right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z),
        right_cart_proj (X \<times>\<^sub>c Y) Z
      \<rangle> \<circ>\<^sub>c \<langle>\<langle>x,y\<rangle>,z\<rangle>
    \<rangle>"
    using cfunc_prod_comp ll_type rl_r_type xy_z_type by blast
  also have "... = \<langle>
    (left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z) \<circ>\<^sub>c \<langle>\<langle>x,y\<rangle>,z\<rangle>,
      \<langle>
        (right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z) \<circ>\<^sub>c \<langle>\<langle>x,y\<rangle>,z\<rangle>,
        right_cart_proj (X \<times>\<^sub>c Y) Z \<circ>\<^sub>c \<langle>\<langle>x,y\<rangle>,z\<rangle>
      \<rangle>
    \<rangle>"
    by (smt cfunc_prod_comp comp_type left_cart_proj_type right_cart_proj_type xy_z_type)
  also have "... = \<langle>left_cart_proj X Y \<circ>\<^sub>c \<langle>x,y\<rangle>, \<langle>right_cart_proj X Y \<circ>\<^sub>c \<langle>x,y\<rangle>, z\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, smt comp_associative2 left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = ?rhs"
    using assms left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

lemma associate_right_crossprod_ap:
  assumes "x : A \<rightarrow> X" "y : B \<rightarrow> Y" "z : C \<rightarrow> Z"
  shows "associate_right X Y Z \<circ>\<^sub>c ((x \<times>\<^sub>f y) \<times>\<^sub>f z) = (x \<times>\<^sub>f (y\<times>\<^sub>f z)) \<circ>\<^sub>c  associate_right A B C"
proof-

  have "associate_right X Y Z \<circ>\<^sub>c ((x \<times>\<^sub>f y)\<times>\<^sub>f z) =
        associate_right X Y Z \<circ>\<^sub>c \<langle>\<langle>x  \<circ>\<^sub>c left_cart_proj A B, y  \<circ>\<^sub>c (right_cart_proj A B)\<rangle> \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C , z \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) C \<rangle>"
    using assms by(unfold cfunc_cross_prod_def2, typecheck_cfuncs, unfold cfunc_cross_prod_def2, auto)
  also have "... = associate_right X Y Z \<circ>\<^sub>c \<langle>\<langle>x  \<circ>\<^sub>c left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C, y  \<circ>\<^sub>c (right_cart_proj A B) \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C \<rangle>  , z \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) C \<rangle>"
    using assms  cfunc_prod_comp comp_associative2 by (typecheck_cfuncs, auto)
  also have "... = \<langle>x  \<circ>\<^sub>c left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C, \<langle>y  \<circ>\<^sub>c (right_cart_proj A B) \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C   , z \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) C \<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: associate_right_ap)
  also have "... = \<langle>x  \<circ>\<^sub>c left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C,  (y \<times>\<^sub>f z)\<circ>\<^sub>c \<langle>(right_cart_proj A B) \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C   ,right_cart_proj (A \<times>\<^sub>c B) C \<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_cross_prod_comp_cfunc_prod)
  also have "... = (x \<times>\<^sub>f (y\<times>\<^sub>f z)) \<circ>\<^sub>c \<langle>left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C,\<langle>(right_cart_proj A B) \<circ>\<^sub>c left_cart_proj (A\<times>\<^sub>cB) C   ,right_cart_proj (A \<times>\<^sub>c B) C \<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_cross_prod_comp_cfunc_prod)
  also have "... = (x \<times>\<^sub>f (y\<times>\<^sub>f z)) \<circ>\<^sub>c  associate_right A B C"
    unfolding associate_right_def by auto
  then show ?thesis using calculation by auto
qed

subsubsection \<open>Permuting a Cartesian product to associate to the left\<close>

definition associate_left :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "associate_left X Y Z =
    \<langle>
      \<langle>
        left_cart_proj X (Y \<times>\<^sub>c Z),
        left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)
      \<rangle>,
      right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)
    \<rangle>"

lemma associate_left_type[type_rule]: "associate_left X Y Z : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
  unfolding associate_left_def
  by (meson cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type)

lemma associate_left_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "associate_left X Y Z \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle> = \<langle>\<langle>x, y\<rangle>, z\<rangle>"
  (is "?lhs = ?rhs")
proof -
  have x_yz_type: "\<langle>x, \<langle>y, z\<rangle>\<rangle> : A \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
    by (simp add: assms cfunc_prod_type)
  have yz_type: "\<langle>y, z\<rangle> : A \<rightarrow> Y \<times>\<^sub>c Z"
    by (simp add: assms cfunc_prod_type)
  have rr_type: "right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> Z"
    using comp_type right_cart_proj_type by blast
  have lr_type: "left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> Y"
    using comp_type left_cart_proj_type right_cart_proj_type by blast
  have l_ll_type:
    "\<langle>left_cart_proj X (Y \<times>\<^sub>c Z), left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)\<rangle>
      : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> X \<times>\<^sub>c Y"
    using cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type by blast

  have "?lhs = \<langle>
      \<langle>
        left_cart_proj X (Y \<times>\<^sub>c Z),
        left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)
      \<rangle>,
      right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)
    \<rangle> \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>"
    unfolding associate_left_def by auto
  also have "... = \<langle>
      \<langle>
        left_cart_proj X (Y \<times>\<^sub>c Z),
        left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)
      \<rangle> \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>,
      right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)  \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>
    \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>
      \<langle>
        left_cart_proj X (Y \<times>\<^sub>c Z) \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>,
        left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>
      \<rangle> ,
      right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)  \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>
    \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>\<langle>x, left_cart_proj Y Z \<circ>\<^sub>c \<langle>y, z\<rangle>\<rangle>, right_cart_proj Y Z \<circ>\<^sub>c \<langle>y, z\<rangle>\<rangle>"
    using assms(1) left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod yz_type by auto
  also have "... = ?rhs"
    using assms left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

lemma right_left:
 "(associate_right A B C) \<circ>\<^sub>c (associate_left A B C) = id (A \<times>\<^sub>c (B \<times>\<^sub>c C))"
    by (smt associate_left_def associate_right_ap cfunc_cross_prod_def cfunc_prod_unique comp_type id_cross_prod id_domain id_left_unit2 left_cart_proj_type right_cart_proj_type)

lemma left_right:
 "(associate_left A B C) \<circ>\<^sub>c (associate_right A B C) = id ((A \<times>\<^sub>c B) \<times>\<^sub>c C)"
    by (smt associate_left_ap associate_right_def cfunc_cross_prod_def cfunc_prod_unique comp_type id_cross_prod id_domain id_left_unit2 left_cart_proj_type right_cart_proj_type)

lemma product_associates:
  "A \<times>\<^sub>c (B \<times>\<^sub>c C)  \<cong> (A \<times>\<^sub>c B) \<times>\<^sub>c C"
    by (metis associate_left_type associate_right_type cfunc_type_def is_isomorphic_def isomorphism_def left_right right_left)

lemma associate_left_crossprod_ap:
  assumes "x : A \<rightarrow> X" "y : B \<rightarrow> Y" "z : C \<rightarrow> Z"
  shows "associate_left X Y Z \<circ>\<^sub>c (x \<times>\<^sub>f (y\<times>\<^sub>f z)) = ((x \<times>\<^sub>f y)\<times>\<^sub>f z) \<circ>\<^sub>c  associate_left A B C"
proof-
  have "associate_left X Y Z \<circ>\<^sub>c (x \<times>\<^sub>f (y\<times>\<^sub>f z)) =
        associate_left X Y Z \<circ>\<^sub>c \<langle>x \<circ>\<^sub>c left_cart_proj A (B\<times>\<^sub>cC), \<langle>y \<circ>\<^sub>c left_cart_proj B C,z \<circ>\<^sub>c right_cart_proj B C \<rangle>   \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC)\<rangle>"
    using assms by(unfold cfunc_cross_prod_def2, typecheck_cfuncs, unfold cfunc_cross_prod_def2, auto)
  also have "... = associate_left X Y Z \<circ>\<^sub>c \<langle>x \<circ>\<^sub>c left_cart_proj A (B\<times>\<^sub>cC), \<langle>y \<circ>\<^sub>c left_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC),z \<circ>\<^sub>c right_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>   \<rangle>"
    using assms  cfunc_prod_comp comp_associative2 by (typecheck_cfuncs, auto)
  also have "... = \<langle>\<langle>x \<circ>\<^sub>c left_cart_proj A (B\<times>\<^sub>cC), y \<circ>\<^sub>c left_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>,z \<circ>\<^sub>c right_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>"
    using assms by (typecheck_cfuncs, simp add: associate_left_ap)
  also have "... = \<langle>(x \<times>\<^sub>f y)\<circ>\<^sub>c \<langle> left_cart_proj A (B\<times>\<^sub>cC), left_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>,z \<circ>\<^sub>c right_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_cross_prod_comp_cfunc_prod)
  also have "... = ((x \<times>\<^sub>f y)\<times>\<^sub>f z) \<circ>\<^sub>c \<langle>\<langle>left_cart_proj A (B\<times>\<^sub>cC), left_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>,right_cart_proj B C \<circ>\<^sub>c right_cart_proj A (B\<times>\<^sub>cC) \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_cross_prod_comp_cfunc_prod)
  also have "... = ((x \<times>\<^sub>f y)\<times>\<^sub>f z) \<circ>\<^sub>c  associate_left A B C"
    unfolding associate_left_def by auto
  then show ?thesis using calculation by auto
qed

    subsubsection \<open>Distributing over a Cartesian product from the right\<close>

definition distribute_right_left :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "distribute_right_left X Y Z =
    \<langle>left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z, right_cart_proj (X \<times>\<^sub>c Y) Z\<rangle>"

lemma distribute_right_left_type[type_rule]:
  "distribute_right_left X Y Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> X \<times>\<^sub>c Z"
  unfolding distribute_right_left_def
  using cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type by blast

lemma distribute_right_left_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "distribute_right_left X Y Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle> = \<langle>x, z\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have xyz_type: "\<langle>\<langle>x, y\<rangle>, z\<rangle> : A \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
    by (simp add: assms cfunc_prod_type)
  have ll_type: "left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> X"
    using comp_type left_cart_proj_type by blast
  have "?lhs =
    \<langle>left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z, right_cart_proj (X \<times>\<^sub>c Y) Z\<rangle> \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>"
    unfolding distribute_right_left_def by simp
  also have "... = \<langle>left_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>,
      right_cart_proj (X \<times>\<^sub>c Y) Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>\<rangle>"
    using assms cfunc_prod_comp comp_associative2 by (typecheck_cfuncs, auto)
  also have "... = \<langle>left_cart_proj X Y \<circ>\<^sub>c \<langle>x, y\<rangle>, z\<rangle>"
    by (metis assms cfunc_prod_type left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = ?rhs"
    using assms(1) assms(2) left_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

definition distribute_right_right :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "distribute_right_right X Y Z =
    \<langle>right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z, right_cart_proj (X \<times>\<^sub>c Y) Z\<rangle>"

lemma distribute_right_right_type[type_rule]:
  "distribute_right_right X Y Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> Y \<times>\<^sub>c Z"
  unfolding distribute_right_right_def
  using cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type by blast

lemma distribute_right_right_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "distribute_right_right X Y Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle> = \<langle>y, z\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have xyz_type: "\<langle>\<langle>x, y\<rangle>, z\<rangle> : A \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
    by (simp add: assms cfunc_prod_type)
  have rl_type: "right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> Y"
    using comp_type right_cart_proj_type left_cart_proj_type by blast
  have "?lhs =
    \<langle>right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z, right_cart_proj (X \<times>\<^sub>c Y) Z\<rangle> \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>"
    unfolding distribute_right_right_def by simp
  also have "... = \<langle>right_cart_proj X Y \<circ>\<^sub>c left_cart_proj (X \<times>\<^sub>c Y) Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>,
      right_cart_proj (X \<times>\<^sub>c Y) Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>right_cart_proj X Y \<circ>\<^sub>c \<langle>x, y\<rangle>, z\<rangle>"
    by (metis assms cfunc_prod_type left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = ?rhs"
    using assms(1) assms(2) right_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

definition distribute_right :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "distribute_right X Y Z = \<langle>distribute_right_left X Y Z, distribute_right_right X Y Z\<rangle>"

lemma distribute_right_type[type_rule]:
  "distribute_right X Y Z : (X \<times>\<^sub>c Y) \<times>\<^sub>c Z \<rightarrow> (X \<times>\<^sub>c Z) \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
  unfolding distribute_right_def
  by (simp add: cfunc_prod_type distribute_right_left_type distribute_right_right_type)

lemma distribute_right_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "distribute_right X Y Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle> = \<langle>\<langle>x, z\<rangle>, \<langle>y, z\<rangle>\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have xyz_type: "\<langle>\<langle>x, y\<rangle>, z\<rangle> : A \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
    by (simp add: assms cfunc_prod_type)
  have "?lhs = \<langle>distribute_right_left X Y Z, distribute_right_right X Y Z\<rangle> \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>"
    unfolding distribute_right_def by simp
  also have "... = \<langle>distribute_right_left X Y Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>, distribute_right_right X Y Z \<circ>\<^sub>c \<langle>\<langle>x, y\<rangle>, z\<rangle>\<rangle>"
    using cfunc_prod_comp distribute_right_left_type distribute_right_right_type xyz_type by blast
  also have "... = ?rhs"
    using assms distribute_right_left_ap distribute_right_right_ap by auto
  then show ?thesis
    using calculation by auto
qed

lemma distribute_right_mono:
  "monomorphism (distribute_right X Y Z)"
proof (typecheck_cfuncs, unfold monomorphism_def3, auto)
  fix g h A
  assume g_type: "g : A \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
  then obtain g1 g2 g3 where g_expand: "g = \<langle>\<langle>g1, g2\<rangle>, g3\<rangle>"
      and g1_g2_g3_types: "g1 : A \<rightarrow> X" "g2 : A \<rightarrow> Y" "g3 : A \<rightarrow> Z"
    using cart_prod_decomp by blast
  assume h_type: "h : A \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c Z"
  then obtain h1 h2 h3 where h_expand: "h = \<langle>\<langle>h1, h2\<rangle>, h3\<rangle>"
      and h1_h2_h3_types: "h1 : A \<rightarrow> X" "h2 : A \<rightarrow> Y" "h3 : A \<rightarrow> Z"
    using cart_prod_decomp by blast

  assume "distribute_right X Y Z \<circ>\<^sub>c g = distribute_right X Y Z \<circ>\<^sub>c h"
  then have "distribute_right X Y Z \<circ>\<^sub>c \<langle>\<langle>g1, g2\<rangle>, g3\<rangle> = distribute_right X Y Z \<circ>\<^sub>c \<langle>\<langle>h1, h2\<rangle>, h3\<rangle>"
    using g_expand h_expand by auto
  then have "\<langle>\<langle>g1, g3\<rangle>, \<langle>g2, g3\<rangle>\<rangle> = \<langle>\<langle>h1, h3\<rangle>, \<langle>h2, h3\<rangle>\<rangle>"
    using distribute_right_ap g1_g2_g3_types h1_h2_h3_types by auto
  then have "\<langle>g1, g3\<rangle> = \<langle>h1, h3\<rangle> \<and> \<langle>g2, g3\<rangle> = \<langle>h2, h3\<rangle>"
    using g1_g2_g3_types h1_h2_h3_types cart_prod_eq2 by (typecheck_cfuncs, auto)
  then have "g1 = h1 \<and> g2 = h2 \<and> g3 = h3"
    using g1_g2_g3_types h1_h2_h3_types cart_prod_eq2 by auto
  then have "\<langle>\<langle>g1, g2\<rangle>, g3\<rangle> = \<langle>\<langle>h1, h2\<rangle>, h3\<rangle>"
    by simp
  then show "g = h"
    by (simp add: g_expand h_expand)
qed

subsubsection \<open>Distributing over a Cartesian product from the left\<close>

definition distribute_left_left :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "distribute_left_left X Y Z =
    \<langle>left_cart_proj X (Y \<times>\<^sub>c Z), left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)\<rangle>"

lemma distribute_left_left_type[type_rule]:
  "distribute_left_left X Y Z : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> X \<times>\<^sub>c Y"
  unfolding distribute_left_left_def
  using cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type by blast

lemma distribute_left_left_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "distribute_left_left X Y Z \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle> = \<langle>x, y\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have xyz_type: "\<langle>x, \<langle>y, z\<rangle>\<rangle> : A \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
    by (simp add: assms cfunc_prod_type)
  have ll_type: "left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> Y"
    using comp_type left_cart_proj_type right_cart_proj_type by blast
  have "?lhs =
    \<langle>left_cart_proj X (Y \<times>\<^sub>c Z), left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)\<rangle> \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>"
    unfolding distribute_left_left_def by simp
  also have "... = \<langle>left_cart_proj X (Y \<times>\<^sub>c Z) \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>,
    left_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>x, left_cart_proj Y Z \<circ>\<^sub>c \<langle>y, z\<rangle>\<rangle>"
    by (metis assms cfunc_prod_type left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = ?rhs"
    using assms(2) assms(3) left_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

definition distribute_left_right :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "distribute_left_right X Y Z =
    \<langle>left_cart_proj X (Y \<times>\<^sub>c Z), right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)\<rangle>"

lemma distribute_left_right_type[type_rule]:
  "distribute_left_right X Y Z : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> X \<times>\<^sub>c Z"
  unfolding distribute_left_right_def
  using cfunc_prod_type comp_type left_cart_proj_type right_cart_proj_type by blast

lemma distribute_left_right_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "distribute_left_right X Y Z \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle> = \<langle>x, z\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have xyz_type: "\<langle>x, \<langle>y, z\<rangle>\<rangle> : A \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
    by (simp add: assms cfunc_prod_type)
  have rl_type: "right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> Z"
    using comp_type left_cart_proj_type right_cart_proj_type by blast
  have "?lhs =
    \<langle>left_cart_proj X (Y \<times>\<^sub>c Z), right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z)\<rangle> \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>"
    unfolding distribute_left_right_def by simp
  also have "... = \<langle>left_cart_proj X (Y \<times>\<^sub>c Z) \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>,
    right_cart_proj Y Z \<circ>\<^sub>c right_cart_proj X (Y \<times>\<^sub>c Z) \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>x, right_cart_proj Y Z \<circ>\<^sub>c \<langle>y, z\<rangle>\<rangle>"
    by (metis assms cfunc_prod_type left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = ?rhs"
    using assms(2) assms(3) right_cart_proj_cfunc_prod by auto
  then show ?thesis
    using calculation by auto
qed

definition distribute_left :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "distribute_left X Y Z = \<langle>distribute_left_left X Y Z, distribute_left_right X Y Z\<rangle>"

lemma distribute_left_type[type_rule]:
  "distribute_left X Y Z : X \<times>\<^sub>c (Y \<times>\<^sub>c Z) \<rightarrow> (X \<times>\<^sub>c Y) \<times>\<^sub>c (X \<times>\<^sub>c Z)"
  unfolding distribute_left_def
  by (simp add: cfunc_prod_type distribute_left_left_type distribute_left_right_type)

lemma distribute_left_ap:
  assumes "x : A \<rightarrow> X" "y : A \<rightarrow> Y" "z : A \<rightarrow> Z"
  shows "distribute_left X Y Z \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle> = \<langle>\<langle>x, y\<rangle>, \<langle>x, z\<rangle>\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have xyz_type: "\<langle>x, \<langle>y, z\<rangle>\<rangle> : A \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
    by (simp add: assms cfunc_prod_type)
  have "?lhs = \<langle>distribute_left_left X Y Z, distribute_left_right X Y Z\<rangle> \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>"
    unfolding distribute_left_def by simp
  also have "... = \<langle>distribute_left_left X Y Z \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>, distribute_left_right X Y Z \<circ>\<^sub>c \<langle>x, \<langle>y, z\<rangle>\<rangle>\<rangle>"
    using cfunc_prod_comp distribute_left_left_type distribute_left_right_type xyz_type by blast
  also have "... = ?rhs"
    using assms distribute_left_left_ap distribute_left_right_ap by auto
  then show ?thesis
    using calculation by auto
qed

lemma distribute_left_mono:
  "monomorphism (distribute_left X Y Z)"
proof (typecheck_cfuncs, unfold monomorphism_def3, auto)
  fix g h A
  assume g_type: "g : A \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
  then obtain g1 g2 g3 where g_expand: "g = \<langle>g1, \<langle>g2, g3\<rangle>\<rangle>"
      and g1_g2_g3_types: "g1 : A \<rightarrow> X" "g2 : A \<rightarrow> Y" "g3 : A \<rightarrow> Z"
    using cart_prod_decomp by blast
  assume h_type: "h : A \<rightarrow> X \<times>\<^sub>c (Y \<times>\<^sub>c Z)"
  then obtain h1 h2 h3 where h_expand: "h = \<langle>h1, \<langle>h2, h3\<rangle>\<rangle>"
      and h1_h2_h3_types: "h1 : A \<rightarrow> X" "h2 : A \<rightarrow> Y" "h3 : A \<rightarrow> Z"
    using cart_prod_decomp by blast

  assume "distribute_left X Y Z \<circ>\<^sub>c g = distribute_left X Y Z \<circ>\<^sub>c h"
  then have "distribute_left X Y Z \<circ>\<^sub>c \<langle>g1, \<langle>g2, g3\<rangle>\<rangle> = distribute_left X Y Z \<circ>\<^sub>c \<langle>h1, \<langle>h2, h3\<rangle>\<rangle>"
    using g_expand h_expand by auto
  then have "\<langle>\<langle>g1, g2\<rangle>, \<langle>g1, g3\<rangle>\<rangle> = \<langle>\<langle>h1, h2\<rangle>, \<langle>h1, h3\<rangle>\<rangle>"
    using distribute_left_ap g1_g2_g3_types h1_h2_h3_types by auto
  then have "\<langle>g1, g2\<rangle> = \<langle>h1, h2\<rangle> \<and> \<langle>g1, g3\<rangle> = \<langle>h1, h3\<rangle>"
    using g1_g2_g3_types h1_h2_h3_types cart_prod_eq2 by (typecheck_cfuncs, auto)
  then have "g1 = h1 \<and> g2 = h2 \<and> g3 = h3"
    using g1_g2_g3_types h1_h2_h3_types cart_prod_eq2 by auto
  then have "\<langle>g1, \<langle>g2, g3\<rangle>\<rangle> = \<langle>h1, \<langle>h2, h3\<rangle>\<rangle>"
    by simp
  then show "g = h"
    by (simp add: g_expand h_expand)
qed

subsubsection \<open>Selecting pairs from a pair of pairs\<close>

definition outers :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "outers A B C D = \<langle>
      left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      right_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle>"

lemma outers_type[type_rule]: "outers A B C D : (A \<times>\<^sub>c B) \<times>\<^sub>c (C \<times>\<^sub>c D) \<rightarrow> (A \<times>\<^sub>c D)"
  unfolding outers_def by typecheck_cfuncs

lemma outers_apply:
  assumes "a : Z \<rightarrow> A" "b : Z \<rightarrow> B" "c : Z \<rightarrow> C" "d : Z \<rightarrow> D"
  shows "outers A B C D \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c,d\<rangle>\<rangle> = \<langle>a,d\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have "?lhs = \<langle>
      left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      right_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle> \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c,d\<rangle>\<rangle>"
    unfolding outers_def by auto
  also have "... = \<langle>
      left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>,
      right_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>
    \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>left_cart_proj A B \<circ>\<^sub>c \<langle>a,b\<rangle>, right_cart_proj C D \<circ>\<^sub>c \<langle>c,d\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = \<langle>a, d\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  then show ?thesis
    using calculation by auto
qed

definition inners :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "inners A B C D = \<langle>
      right_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      left_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle>"

lemma inners_type[type_rule]: "inners A B C D : (A \<times>\<^sub>c B) \<times>\<^sub>c (C \<times>\<^sub>c D) \<rightarrow> (B \<times>\<^sub>c C)"
  unfolding inners_def by typecheck_cfuncs

lemma inners_apply:
  assumes "a : Z \<rightarrow> A" "b : Z \<rightarrow> B" "c : Z \<rightarrow> C" "d : Z \<rightarrow> D"
  shows "inners A B C D \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle> = \<langle>b,c\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have "?lhs = \<langle>
      right_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      left_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle> \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>"
    unfolding inners_def by auto
  also have "... = \<langle>
      right_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>,
      left_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>
    \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>right_cart_proj A B \<circ>\<^sub>c \<langle>a,b\<rangle>, left_cart_proj C D \<circ>\<^sub>c \<langle>c,d\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = \<langle>b, c\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  then show ?thesis
    using calculation by auto
qed

definition lefts :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "lefts A B C D = \<langle>
      left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      left_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle>"

lemma lefts_type[type_rule]: "lefts A B C D : (A \<times>\<^sub>c B) \<times>\<^sub>c (C \<times>\<^sub>c D) \<rightarrow> (A \<times>\<^sub>c C)"
  unfolding lefts_def by typecheck_cfuncs

lemma lefts_apply:
  assumes "a : Z \<rightarrow> A" "b : Z \<rightarrow> B" "c : Z \<rightarrow> C" "d : Z \<rightarrow> D"
  shows "lefts A B C D \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle> = \<langle>a,c\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have "?lhs = \<langle>
      left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      left_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle> \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>"
    unfolding lefts_def by (auto)
  also have "... = \<langle>
      left_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>,
      left_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>
    \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>left_cart_proj A B \<circ>\<^sub>c \<langle>a,b\<rangle>, left_cart_proj C D \<circ>\<^sub>c \<langle>c,d\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = \<langle>a, c\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod)
  then show ?thesis
    using calculation by auto
qed

definition rights :: "cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cset \<Rightarrow> cfunc" where
  "rights A B C D = \<langle>
      right_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      right_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle>"

lemma rights_type[type_rule]: "rights A B C D : (A \<times>\<^sub>c B) \<times>\<^sub>c (C \<times>\<^sub>c D) \<rightarrow> (B \<times>\<^sub>c D)"
  unfolding rights_def by typecheck_cfuncs

lemma rights_apply:
  assumes "a : Z \<rightarrow> A" "b : Z \<rightarrow> B" "c : Z \<rightarrow> C" "d : Z \<rightarrow> D"
  shows "rights A B C D \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle> = \<langle>b,d\<rangle>"
    (is "?lhs = ?rhs")
proof -
  have "?lhs = \<langle>
      right_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D),
      right_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D)
    \<rangle> \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>"
    unfolding rights_def using assms comp_associative2 by auto
  also have "... = \<langle>
      right_cart_proj A B \<circ>\<^sub>c left_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>,
      right_cart_proj C D \<circ>\<^sub>c right_cart_proj (A \<times>\<^sub>c B) (C \<times>\<^sub>c D) \<circ>\<^sub>c \<langle>\<langle>a,b\<rangle>, \<langle>c, d\<rangle>\<rangle>
    \<rangle>"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  also have "... = \<langle>right_cart_proj A B \<circ>\<^sub>c \<langle>a,b\<rangle>, right_cart_proj C D \<circ>\<^sub>c \<langle>c,d\<rangle>\<rangle>"
    using assms by (typecheck_cfuncs, simp add: left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)
  also have "... = \<langle>b, d\<rangle>"
    using assms by (typecheck_cfuncs, simp add: right_cart_proj_cfunc_prod)
  then show ?thesis
    using calculation by auto
qed

end


theory T48
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


theory Binary_Sum_Measure
imports Probability
begin

definition sum_measure (infixr "\<Oplus>\<^sub>M" 70) where
  "A \<Oplus>\<^sub>M B = measure_of (space A <+> space B)
                        ({Inl`X |X. X \<in> sets A} \<union> {Inr`X |X. X \<in> sets B})
                        (\<lambda>X. emeasure A (Inl -` X) + emeasure B (Inr -` X))"

lemma sum_measure_closed:
  "{Inl`X |X. X \<in> sets A} \<union> {Inr`X |X. X \<in> sets B} \<subseteq> Pow (space A <+> space B)"
  using sets.space_closed[of A] sets.space_closed[of B] by (auto intro!: imageI)

lemma space_sum_measure: "space (A \<Oplus>\<^sub>M B) = space A <+> space B"
  unfolding sum_measure_def by (rule space_measure_of[OF sum_measure_closed])

lemma Inl_vimage_Inr [simp]: "Inl -` Inr ` X = {}"
  and Inr_vimage_Inl [simp]: "Inr -` Inl ` Y = {}"
  by auto

lemma sets_sum_measure:
  "sets (sum_measure A B) = {Inl`X \<union> Inr`Y |X Y. X \<in> sets A \<and> Y \<in> sets B}"
proof-
  let ?\<Omega> = "space A <+> space B"
  let ?M = "{Inl`X |X. X \<in> sets A} \<union> {Inr`X |X. X \<in> sets B}"
  let ?M' = "{Inl`X \<union> Inr`Y |X Y. X \<in> sets A \<and> Y \<in> sets B}"
  have "sets (sum_measure A B) = sigma_sets ?\<Omega> ?M"
    unfolding sum_measure_def using sum_measure_closed by (rule sets_measure_of)
  also have "... = ?M'"
  proof (intro equalityI subsetI)
    fix X assume "X \<in> ?M'"
    then obtain X1 X2 where X: "X = Inl`X1 \<union> Inr`X2" and "X1 \<in> sets A" "X2 \<in> sets B" by auto
    hence X12: "Inl`X1 \<in> ?M" "Inr`X2 \<in> ?M" by blast+
    thus "X \<in> sigma_sets ?\<Omega> ?M"
      by (subst X) (intro sigma_sets_Un[OF sigma_sets.Basic sigma_sets.Basic] X12)
  next
    fix X assume X: "X \<in> sigma_sets ?\<Omega> ?M"
    show "X \<in> ?M'"
    proof (induction rule: sigma_sets.induct[OF X])
      fix X assume "X \<in> ?M"
      thus "X \<in> ?M'" by blast
    next
      show "{} \<in> ?M'" by blast
    next
      fix X assume X: "X \<in> ?M'"
      then obtain X1 X2 where X: "X = Inl`X1 \<union> Inr`X2" and "X1 \<in> sets A" "X2 \<in> sets B" by auto
      hence "Inl`(space A - X1) \<union> Inr`(space B - X2) \<in> ?M'" by auto
      also have "Inl`(space A - X1) \<union> Inr`(space B - X2) = ?\<Omega> - X" by (subst X) blast
      finally show "?\<Omega> - X \<in> ?M'" .
    next
      fix X :: "nat \<Rightarrow> _"
      assume X: "\<And>i. X i \<in> ?M'"
      def X1 \<equiv> "\<lambda>i. Inl -` X i" and X2 \<equiv> "\<lambda>i. Inr -` X i"
      from X have X_decomp: "\<And>i. X i = Inl`X1 i \<union> Inr`X2 i"
        unfolding X1_def X2_def using UNIV_sum by auto
      hence "(\<Union>i. X i) = Inl`(\<Union>i. X1 i) \<union> Inr`(\<Union>i. X2 i)" by auto
      moreover {
        fix i
        from X[of i] have "X1 i \<in> sets A" "X2 i \<in> sets B" unfolding X1_def X2_def
          by (force simp: inj_vimage_image_eq)+
      }
      hence "(\<Union>i. X1 i) \<in> sets A" "(\<Union>i. X2 i) \<in> sets B" using sets.countable_UN by blast+
      ultimately show "(\<Union>i. X i) \<in> ?M'" by blast
    qed
  qed
  finally show ?thesis .
qed

lemma sets_sum_measure_cong [measurable_cong, cong]:
  "sets M1 = sets M1' \<Longrightarrow> sets M2 = sets M2' \<Longrightarrow> sets (M1 \<Oplus>\<^sub>M M2) = sets (M1' \<Oplus>\<^sub>M M2')"
  unfolding sets_sum_measure by (simp cong: sets_eq_imp_space_eq)

lemma sum_measureI1 [intro, simp, measurable]: "x \<in> sets A \<Longrightarrow> Inl`x \<in> sets (A \<Oplus>\<^sub>M B)"
  and sum_measureI2 [intro, simp, measurable]: "x \<in> sets D \<Longrightarrow> Inr`x \<in> sets (C \<Oplus>\<^sub>M D)"
  by (auto simp: sets_sum_measure)

lemma sum_measureE:
  assumes "x \<in> sets (A \<Oplus>\<^sub>M B)"
  obtains x1 x2 where "x = Inl`x1 \<union> Inr`x2"
  using assms by (subst (asm) sets_sum_measure) blast

lemma measurable_sum_measureI1:
  assumes 1: "f \<in> (space M1 <+> space M2) \<rightarrow> space M"
  assumes 2: "\<And>X. X \<in> sets M \<Longrightarrow> Inl -` f -` X \<inter> space M1 \<in> sets M1"
  assumes 3: "\<And>X. X \<in> sets M \<Longrightarrow> Inr -` f -` X \<inter> space M2 \<in> sets M2"
  shows "f \<in> measurable (M1 \<Oplus>\<^sub>M M2) M"
proof (rule measurableI)
  fix x assume "x \<in> space (M1 \<Oplus>\<^sub>M M2)"
  with 1 show "f x \<in> space M" by (simp add: space_sum_measure Pi_iff)
next
  fix X assume X: "X \<in> sets M"
  have "f -` X = Inl`Inl-`f-`X \<union> Inr`Inr-`f-`X"
    by (subst (1 2) image_vimage_eq, subst Int_Un_distrib[symmetric], subst UNIV_sum[symmetric]) simp
  hence "f -` X \<inter> space (M1 \<Oplus>\<^sub>M M2) = Inl`(Inl-`f-`X \<inter> space M1) \<union> Inr`(Inr-`f-`X \<inter> space M2)"
    by (auto simp: space_sum_measure)
  with 2[OF X] 3[OF X] show "f -` X \<inter> space (M1 \<Oplus>\<^sub>M M2) \<in> sets (M1 \<Oplus>\<^sub>M M2)"
    by (subst sets_sum_measure) blast
qed

lemma measurable_sum_measureI2:
  fixes M1 :: "'a measure" and M2 :: "'b measure"
  assumes 1: "f \<in> space M \<rightarrow> space M1 <+> space M2"
  assumes 2: "\<And>X. X \<in> sets M1 \<Longrightarrow> f -` Inl ` X \<inter> space M \<in> sets M"
  assumes 3: "\<And>X. X \<in> sets M2 \<Longrightarrow> f -` Inr ` X \<inter> space M \<in> sets M"
  shows "f \<in> measurable M (M1 \<Oplus>\<^sub>M M2)"
unfolding sum_measure_def
proof (rule measurable_measure_of)
  show "{Inl ` X |X. X \<in> sets M1} \<union> {Inr ` X |X. X \<in> sets M2} \<subseteq> Pow (space M1 <+> space M2)"
    by (fact sum_measure_closed)
  show "f \<in> space M \<rightarrow> space M1 <+> space M2" by fact
  fix X assume "X \<in> {Inl ` X |X. X \<in> sets M1} \<union> {Inr ` X |X. X \<in> sets M2}"
  thus "f -` X \<inter> space M \<in> sets M" using 2 3 by blast
qed

lemma measurable_Inl [measurable]: "Inl \<in> measurable M1 (M1 \<Oplus>\<^sub>M M2)"
  by (rule measurable_sum_measureI2) (auto simp: vimage_image_eq)

lemma measurable_Inr [measurable]: "Inr \<in> measurable M2 (M1 \<Oplus>\<^sub>M M2)"
  by (rule measurable_sum_measureI2) (auto simp: vimage_image_eq)

lemma measurable_case_sum [measurable (raw)]:
  "f \<in> measurable M1 M \<Longrightarrow> g \<in> measurable M2 M \<Longrightarrow> case_sum f g \<in> measurable (M1 \<Oplus>\<^sub>M M2) M"
  by (intro measurable_sum_measureI1) (auto dest: measurable_space simp: vimage_comp comp_def)

lemma measurable_sum:
  assumes "f \<circ> Inl \<in> measurable M1 M" "f \<circ> Inr \<in> measurable M2 M"
  shows   "f \<in> measurable (M1 \<Oplus>\<^sub>M M2) M"
proof (rule measurable_sum_measureI1)
  from assms show "f \<in> space M1 <+> space M2 \<rightarrow> space M"
    by (auto simp: comp_def[abs_def] dest: measurable_space )
  fix X assume X: "X \<in> sets M"
  from X and assms show "Inl -` f -` X \<inter> space M1 \<in> sets M1"
                    and "Inr -` f -` X \<inter> space M2 \<in> sets M2" by (auto simp: vimage_comp)
qed

lemma emeasure_sum_measure:
  assumes "A \<in> sets (M1 \<Oplus>\<^sub>M M2)"
  shows   "emeasure (M1 \<Oplus>\<^sub>M M2) A = emeasure M1 (Inl -` A) + emeasure M2 (Inr -` A)"
proof (rule emeasure_measure_of[OF sum_measure_def sum_measure_closed])
  show "A \<in> sets (M1 \<Oplus>\<^sub>M M2)" by fact
  show "positive (sets (M1 \<Oplus>\<^sub>M M2)) (\<lambda>X. emeasure M1 (Inl -` X) + emeasure M2 (Inr -` X))"
    by (auto simp: sets_sum_measure positive_def intro!: ereal_add_nonneg_nonneg)
  show "countably_additive (sets (M1 \<Oplus>\<^sub>M M2)) (\<lambda>X. emeasure M1 (Inl -` X) + emeasure M2 (Inr -` X))"
  proof (rule countably_additiveI)
    fix X :: "nat \<Rightarrow> _"
    assume range_X: "range X \<subseteq> sets (M1 \<Oplus>\<^sub>M M2)"
    assume disj_X:  "disjoint_family X"

    def X1 \<equiv> "\<lambda>i. Inl -` X i" and X2 \<equiv> "\<lambda>i. Inr -` X i"
    {
      fix i
      from range_X have "X i \<in> sets (M1 \<Oplus>\<^sub>M M2)" by blast
      hence "X1 i \<in> sets M1" "X2 i \<in> sets M2" unfolding X1_def X2_def
        by (force simp: inj_vimage_image_eq sets_sum_measure)+
    }
    hence range_X12: "range X1 \<subseteq> sets M1" "range X2 \<subseteq> sets M2" by blast+
    from disj_X have disj_X12: "disjoint_family X1" "disjoint_family X2"
      by (auto simp: X1_def X2_def disjoint_family_on_def)

    have "(\<Sum>i. emeasure M1 (Inl -` X i) + emeasure M2 (Inr -` X i)) =
          (\<Sum>i. emeasure M1 (X1 i)) + (\<Sum>i. emeasure M2 (X2 i))"
      unfolding X1_def X2_def by (intro suminf_add_ereal emeasure_nonneg)
    also have "(\<Sum>i. emeasure M1 (X1 i)) = emeasure M1 (\<Union>i. X1 i)"
      using range_X12(1) disj_X12(1) by (rule suminf_emeasure)
    also have "(\<Sum>i. emeasure M2 (X2 i)) = emeasure M2 (\<Union>i. X2 i)"
      using range_X12(2) disj_X12(2) by (rule suminf_emeasure)
    also have "(\<Union>i. X1 i) = Inl -` (\<Union>i. X i)" by (auto simp: X1_def)
    also have "(\<Union>i. X2 i) = Inr -` (\<Union>i. X i)" by (auto simp: X2_def)
    finally show "(\<Sum>i. emeasure M1 (Inl -` X i) + emeasure M2 (Inr -` X i)) =
                  emeasure M1 (Inl -` (\<Union>i. X i)) + emeasure M2 (Inr -` (\<Union>i. X i))" .
  qed
qed

lemma emeasure_sum_Inl: "A \<in> sets M1 \<Longrightarrow> emeasure (M1 \<Oplus>\<^sub>M M2) (Inl ` A) = emeasure M1 A"
  by (subst emeasure_sum_measure) (auto simp: vimage_image_eq)

lemma emeasure_sum_Inr: "A \<in> sets M2 \<Longrightarrow> emeasure (M1 \<Oplus>\<^sub>M M2) (Inr ` A) = emeasure M2 A"
  by (subst emeasure_sum_measure) (auto simp: vimage_image_eq)

locale sum_sigma_finite = M1: sigma_finite_measure M1 + M2: sigma_finite_measure M2
  for M1 :: "'a measure" and M2 :: "'b measure"

sublocale sum_sigma_finite \<subseteq> P: sigma_finite_measure "M1 \<Oplus>\<^sub>M M2"
proof-
  from M1.sigma_finite_countable guess A by (elim exE conjE)
  note A = this
  from M2.sigma_finite_countable guess B by (elim exE conjE)
  note B = this
  def AB \<equiv> "(\<lambda>X. Inl`X) ` A \<union> (\<lambda>X. Inr`X) ` B"
  show "sigma_finite_measure (M1 \<Oplus>\<^sub>M M2)"
  proof (unfold_locales, rule exI[of _ AB], intro conjI ballI)
    from A(1) B(1) show "countable AB" by (simp add: AB_def)
    from A(2) B(2) show "AB \<subseteq> sets (M1 \<Oplus>\<^sub>M M2)"
      by (auto simp: AB_def intro!: sum_measureI1)

    show "\<Union>AB = space (M1 \<Oplus>\<^sub>M M2)"
    proof (intro equalityI subsetI)
      fix x assume "x \<in> \<Union>AB"
      with A(2-3) B(2-3) show "x \<in> space (M1 \<Oplus>\<^sub>M M2)" unfolding AB_def
        by (cases x) (auto simp: space_sum_measure)
    next
      fix x assume "x \<in> space (M1 \<Oplus>\<^sub>M M2)"
      with A(3) B(3) show "x \<in> \<Union>AB"
      unfolding AB_def by (cases x) (auto simp: space_sum_measure inj_image_mem_iff)
    qed

    fix X assume "X \<in> AB"
    moreover with `AB \<subseteq> sets (M1 \<Oplus>\<^sub>M M2)` have "X \<in> sets (M1 \<Oplus>\<^sub>M M2)" by blast
    moreover note A(4) B(4)
    ultimately show "emeasure (M1 \<Oplus>\<^sub>M M2) X \<noteq> \<infinity>"
      unfolding AB_def by (fastforce simp: emeasure_sum_measure vimage_image_eq)
  qed
qed

lemma sigma_finite_sum_measure:
  assumes A: "sigma_finite_measure A" and B: "sigma_finite_measure B"
  shows "sigma_finite_measure (A \<Oplus>\<^sub>M B)"
proof -
  interpret A: sigma_finite_measure A by fact
  interpret B: sigma_finite_measure B by fact
  interpret AB: sum_sigma_finite A  B ..
  show ?thesis ..
qed

lemma AE_sum:
  "(AE x in (M1 \<Oplus>\<^sub>M M2). P x) \<longleftrightarrow> (AE x in M1. P (Inl x)) \<and> (AE x in M2. P (Inr x))" (is "?Q = ?R")
proof
  assume ?Q
  then guess X by (rule AE_E)
  note X = this
  from X(1) have "{x \<in> space M1. \<not>P (Inl x)} \<subseteq> Inl -` X"
             and "{x \<in> space M2. \<not>P (Inr x)} \<subseteq> Inr -` X"
    by (auto simp: space_sum_measure)
  moreover from X have "emeasure M1 (Inl -` X) + emeasure M2 (Inr -` X) = 0"
    by (auto simp: emeasure_sum_measure)
  hence "emeasure M1 (Inl -` X) = 0 \<and> emeasure M2 (Inr -` X) = 0"
    by (subst (asm) ereal_add_nonneg_eq_0_iff) (simp_all add: emeasure_nonneg)
  moreover from X have "Inl -` X \<in> sets M1" "Inr -` X \<in> sets M2"
    by (fastforce simp: sets_sum_measure vimage_image_eq)+
  ultimately show "(AE x in M1. P (Inl x)) \<and> (AE x in M2. P (Inr x))"
    by (intro conjI AE_I) simp_all
next
  assume ?R
  hence R1: "AE x in M1. P (Inl x)" and R2: "AE x in M2. P (Inr x)" by blast+
  from R1 guess X by (elim AE_E)
  note X = this
  from R2 guess Y by (elim AE_E)
  note Y = this
  from X Y have "{x \<in> space (M1 \<Oplus>\<^sub>M M2). \<not>P x} \<subseteq> Inl`X \<union> Inr`Y"
    by (auto simp: space_sum_measure)
  moreover from X Y have "emeasure (M1 \<Oplus>\<^sub>M M2) (Inl`X \<union> Inr`Y) = 0"
    by (subst plus_emeasure[symmetric]) (auto simp: emeasure_sum_Inl emeasure_sum_Inr)
  moreover from X Y have "Inl`X \<union> Inr`Y \<in> sets (M1 \<Oplus>\<^sub>M M2)" by simp
  ultimately show ?Q by (rule AE_I)
qed

lemma AE_sumI:
  "AE x in M1. P (Inl x) \<Longrightarrow> AE x in M2. P (Inr x) \<Longrightarrow> AE x in (M1 \<Oplus>\<^sub>M M2). P x"
  by (simp add: AE_sum)

lemma AE_sumD1: "AE x in (M1 \<Oplus>\<^sub>M M2). P x \<Longrightarrow> AE x in M1. P (Inl x)"
  and AE_sumD2: "AE x in (M1 \<Oplus>\<^sub>M M2). P x \<Longrightarrow> AE x in M2. P (Inr x)"
  by (simp_all add: AE_sum)

end


(*
    Author:      René Thiemann
    License:     LPGL
*)
subsection \<open>Displaying Polynomials\<close>

text \<open>We define a method which converts polynomials to strings and registers it in the Show class.\<close>

theory Show_Poly
imports
  Show_Instances
  "~~/src/HOL/Library/Polynomial"
begin

fun show_factor :: "nat \<Rightarrow> string" where
  "show_factor 0 = []"
| "show_factor (Suc 0) = ''x''"
| "show_factor n = ''x^'' @ show n"

fun show_coeff_factor where
  "show_coeff_factor c n = (if n = 0 then show c else if c = 1 then show_factor n else show c @ show_factor n)"

fun show_poly_main :: "nat \<Rightarrow> 'a :: {zero,one,show} list \<Rightarrow> string" where
  "show_poly_main _ [] = ''0''"
| "show_poly_main n [c] = show_coeff_factor c n"
| "show_poly_main n (c # cs) = (if c = 0 then show_poly_main (Suc n) cs else
    show_coeff_factor c n @ '' + '' @ show_poly_main (Suc n) cs)"

definition show_poly :: "'a :: {zero,one,show}poly \<Rightarrow> string" where
  "show_poly p = show_poly_main 0 (coeffs p)"

definition showsp_poly :: "'a :: {zero,one,show}poly showsp"
where
  "showsp_poly p x = shows_string (show_poly x)"

instantiation poly :: ("{show,one,zero}") "show"
begin

definition "shows_prec p (x :: 'a poly) = showsp_poly p x"
definition "shows_list (ps :: 'a poly list) = showsp_list shows_prec 0 ps"

lemma show_law_poly [show_law_simps]:
  "shows_prec p (a :: 'a poly) (r @ s) = shows_prec p a r @ s"
  by (simp add: shows_prec_poly_def showsp_poly_def show_law_simps)

instance by standard (auto simp: shows_list_poly_def show_law_simps)

end

end