theory ETCS_Terminal
  imports ETCS_Cartesian
begin

section \<open>Axiom 3: Terminal Objects\<close>

axiomatization
  terminal_func :: "cset \<Rightarrow> cfunc" ("\<beta>\<^bsub>_\<^esub>" 100) and
  one :: "cset"
where
  terminal_func_type[type_rule]: "\<beta>\<^bsub>X\<^esub> : X \<rightarrow> one" and
  terminal_func_unique: "h :  X \<rightarrow> one \<Longrightarrow> h = \<beta>\<^bsub>X\<^esub>" and
  one_separator: "f : X \<rightarrow> Y \<Longrightarrow> g : X \<rightarrow> Y \<Longrightarrow> (\<And> x. x : one \<rightarrow> X \<Longrightarrow> f \<circ>\<^sub>c x = g \<circ>\<^sub>c x) \<Longrightarrow> f = g"

lemma terminal_func_comp:
  "x : X \<rightarrow> Y \<Longrightarrow> \<beta>\<^bsub>Y\<^esub> \<circ>\<^sub>c x = \<beta>\<^bsub>X\<^esub>"
  by (simp add: comp_type terminal_func_type terminal_func_unique)

(* Definition 2.1.16 *)
abbreviation member :: "cfunc \<Rightarrow> cset \<Rightarrow> bool" (infix "\<in>\<^sub>c" 50) where
  "x \<in>\<^sub>c X \<equiv> (x : one \<rightarrow> X)"

definition nonempty :: "cset \<Rightarrow> bool" where
  "nonempty X \<equiv> (\<exists>x. x \<in>\<^sub>c X)"

definition terminal_object :: "cset \<Rightarrow> bool" where
  "terminal_object(X) \<longleftrightarrow> (\<forall> Y. \<exists>! f. f : Y \<rightarrow> X)"

lemma diag_on_elements:
  assumes "x \<in>\<^sub>c X"
  shows "diagonal(X) \<circ>\<^sub>c x = \<langle>x,x\<rangle>"
using assms cfunc_prod_comp cfunc_type_def diagonal_def id_left_unit id_type by auto

lemma one_separator_contrapos:
  assumes "f : X \<rightarrow> Y" "g : X \<rightarrow> Y"
  shows "f \<noteq> g \<Longrightarrow> \<exists> x. x : one \<rightarrow> X \<and> f \<circ>\<^sub>c x \<noteq> g \<circ>\<^sub>c x"
proof -
  have "(\<forall> x. x : one \<rightarrow> X \<longrightarrow> f \<circ>\<^sub>c x = g \<circ>\<^sub>c x) \<longrightarrow> f = g"
    using assms(1) assms(2) one_separator by blast
  then show "f \<noteq> g \<Longrightarrow> \<exists>x. x \<in>\<^sub>c X \<and> f \<circ>\<^sub>c x \<noteq> g \<circ>\<^sub>c x"
    by blast
qed

lemma one_terminal_object: "terminal_object(one)"
  unfolding terminal_object_def
proof auto
  fix Y
  have "\<beta>\<^bsub>Y\<^esub> : Y \<rightarrow> one"
    using terminal_func_type by simp
  then show "\<exists>f. (f : Y \<rightarrow> one)"
    by auto
next
  fix Y f y
  assume "f : Y \<rightarrow> one" "y : Y \<rightarrow> one"
  then have "f = \<beta>\<^bsub>Y\<^esub> \<and> y = \<beta>\<^bsub>Y\<^esub>"
    using terminal_func_unique by auto
  then show "f = y"
    by simp
qed

(* Exercise 2.1.15 *)
lemma terminal_objects_isomorphic:
  assumes "terminal_object X" "terminal_object Y"
  shows "X \<cong> Y"
  unfolding is_isomorphic_def
proof -

  obtain f where f_type: "f : X \<rightarrow> Y" and f_unique: "\<forall>g. g : X \<rightarrow> Y \<longrightarrow> f = g"
    using assms(2) terminal_object_def by force

  obtain g where g_type: "g : Y \<rightarrow> X" and g_unique: "\<forall>f. f : Y \<rightarrow> X \<longrightarrow> g = f"
    using assms(1) terminal_object_def by force

  have g_f_is_id: "g \<circ>\<^sub>c f = id X"
    using assms(1) comp_type f_type g_type id_type terminal_object_def by blast

  have f_g_is_id: "f \<circ>\<^sub>c g = id Y"
    using assms(2) comp_type f_type g_type id_type terminal_object_def by blast

  have f_isomorphism: "isomorphism f"
    unfolding isomorphism_def
    using cfunc_type_def f_type g_type g_f_is_id f_g_is_id
    by (rule_tac x=g in exI, auto)

  show "\<exists>f. f : X \<rightarrow> Y \<and> isomorphism f"
    using f_isomorphism f_type by auto
qed

(* Exercise 2.1.18 *)
lemma element_monomorphism:
  "x \<in>\<^sub>c X \<Longrightarrow> monomorphism x"
  unfolding monomorphism_def
  by (metis cfunc_type_def domain_comp terminal_func_unique)

(* Generalization of Exercise 2.1.18 *)
lemma terminal_el__monomorphism:
  assumes "x : T \<rightarrow> X"
  assumes "terminal_object(T)"
  shows "monomorphism x"
  unfolding monomorphism_def
  by (metis assms cfunc_type_def domain_comp terminal_object_def)

lemma one_unique_element:
  "\<exists>! x. x \<in>\<^sub>c one"
proof (rule_tac a="id one" in ex1I)
  show "id\<^sub>c one \<in>\<^sub>c one"
    by (simp add: id_type)
next
  fix x
  assume "x \<in>\<^sub>c one"
  then show "x = id\<^sub>c one"
    by (metis id_type terminal_func_unique)
qed

lemma one_cross_one_unique_element:
  "\<exists>! x. x \<in>\<^sub>c one \<times>\<^sub>c one"
proof (rule_tac a="diagonal one" in ex1I)
  show "diagonal one \<in>\<^sub>c one \<times>\<^sub>c one"
    by (simp add: cfunc_prod_type diagonal_def id_type)
next
  fix x
  assume x_type: "x \<in>\<^sub>c one \<times>\<^sub>c one"

  have left_eq: "left_cart_proj one one \<circ>\<^sub>c x = id one"
    using x_type one_unique_element by (typecheck_cfuncs, blast)
  have right_eq: "right_cart_proj one one \<circ>\<^sub>c x = id one"
    using x_type one_unique_element by (typecheck_cfuncs, blast)

  then show "x = diagonal one"
    unfolding diagonal_def using cfunc_prod_unique id_type left_eq x_type by blast
qed

(* Proposition 2.1.19 *)
lemma single_elem_iso_one:
  "(\<exists>! x. x \<in>\<^sub>c X) \<longleftrightarrow> X \<cong> one"
proof
  assume X_iso_one: "X \<cong> one"
  then have "one \<cong> X"
    by (simp add: isomorphic_is_symmetric)
  then obtain f where f_type: "f : one \<rightarrow> X" and f_iso: "isomorphism f"
    using is_isomorphic_def by blast

  show "\<exists>!x. x \<in>\<^sub>c X"
  proof (rule_tac a=f in ex1I, auto simp add: f_type)
    fix x
    assume x_type: "x \<in>\<^sub>c X"
    then have \<beta>x_eq_\<beta>f: "\<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c x = \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c f"
      using f_type terminal_func_comp by auto
    have "isomorphism (\<beta>\<^bsub>X\<^esub>)"
      using X_iso_one is_isomorphic_def terminal_func_unique by blast
    then have "monomorphism (\<beta>\<^bsub>X\<^esub>)"
      by (simp add: iso_imp_epi_and_monic)
    then show "x = f"
      unfolding monomorphism_def using \<beta>x_eq_\<beta>f x_type cfunc_type_def f_type terminal_func_type by auto
  qed
next
  assume "\<exists>!x. x \<in>\<^sub>c X"
  then obtain x where x_type: "x : one \<rightarrow> X" and x_unique: "\<forall> y. y : one \<rightarrow> X \<longrightarrow> x = y"
    by blast

  have "terminal_object X"
    unfolding terminal_object_def
  proof
    fix Y
    show "\<exists>!f. f : Y \<rightarrow> X"
    proof (rule_tac a="x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>" in ex1I)
      show "x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub> : Y \<rightarrow> X"
        using comp_type terminal_func_type x_type by blast
    next
      fix xa
      assume xa_type: "xa : Y \<rightarrow> X"
      show "xa = x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
      proof (rule ccontr)
        assume "xa \<noteq> x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
        then obtain y where elems_neq: "xa \<circ>\<^sub>c y \<noteq> (x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>) \<circ>\<^sub>c y" and y_type: "y : one \<rightarrow> Y"
          using one_separator_contrapos[where f=xa, where g="x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>", where X=Y, where Y=X]
          using comp_type terminal_func_type x_type xa_type by blast
        have elem1: "xa \<circ>\<^sub>c y \<in>\<^sub>c X"
          using comp_type xa_type y_type by auto
        have elem2: "(x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>) \<circ>\<^sub>c y \<in>\<^sub>c X"
          using comp_type terminal_func_type x_type y_type by blast
        show False
          using elem1 elem2 elems_neq x_unique by blast
      qed
    qed
  qed
  then show "X \<cong> one"
    by (simp add: one_terminal_object terminal_objects_isomorphic)
qed

(* Converse to Exercise 2.1.15: Part 1 *)
lemma iso_to1_is_term:
  assumes "X \<cong> one"
  shows "terminal_object X"
  unfolding terminal_object_def
proof
   fix Y
   obtain x where x_type: "x : one \<rightarrow> X" and x_unique: "\<forall> y. y : one \<rightarrow> X \<longrightarrow> x = y"
      using assms single_elem_iso_one by fastforce
   show  "\<exists>!f. f : Y \<rightarrow> X"
      proof (rule_tac a="x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>" in ex1I)
         show "x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub> : Y \<rightarrow> X"
           using comp_type terminal_func_type x_type by blast
      next
         fix xa
         assume xa_type: "xa : Y \<rightarrow> X"
         show "xa = x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
         proof (rule ccontr)
           assume "xa \<noteq> x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>"
           then obtain y where elems_neq: "xa \<circ>\<^sub>c y \<noteq> (x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>) \<circ>\<^sub>c y" and y_type: "y : one \<rightarrow> Y"
             using one_separator_contrapos[where f=xa, where g="x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>", where X=Y, where Y=X]
             using comp_type terminal_func_type x_type xa_type by blast
           have elem1: "xa \<circ>\<^sub>c y \<in>\<^sub>c X"
             using comp_type xa_type y_type by auto
           have elem2: "(x \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>) \<circ>\<^sub>c y \<in>\<^sub>c X"
             using comp_type terminal_func_type x_type y_type by blast
           show False
             using elem1 elem2 elems_neq x_unique by blast
         qed
      qed
qed

(* Converse to Exercise 2.1.15: Part 2 *)

lemma iso_to_term_is_term:
  assumes "X \<cong> Y"
  assumes "terminal_object Y"
  shows "terminal_object X"
  by (meson assms iso_to1_is_term isomorphic_is_transitive one_terminal_object terminal_objects_isomorphic)

(* Proposition 2.1.20 *)
lemma X_is_cart_prod1:
  "is_cart_prod X (id X) (\<beta>\<^bsub>X\<^esub>) X one"
  unfolding is_cart_prod_def
proof auto
  show "id\<^sub>c X : X \<rightarrow> X"
    by (simp add: id_type)
next
  show "\<beta>\<^bsub>X\<^esub> : X \<rightarrow> one"
    by (simp add: terminal_func_type)
next
  fix f g Y
  assume f_type: "f : Y \<rightarrow> X" and g_type: "g : Y \<rightarrow> one"
  then show "\<exists>h. h : Y \<rightarrow> X \<and>
           id\<^sub>c X \<circ>\<^sub>c h = f \<and> \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c h = g \<and> (\<forall>h2. h2 : Y \<rightarrow> X \<and> id\<^sub>c X \<circ>\<^sub>c h2 = f \<and> \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c h2 = g \<longrightarrow> h2 = h)"
  proof (rule_tac x=f in exI, auto)
    show "id X \<circ>\<^sub>c f = f"
      using cfunc_type_def f_type id_left_unit by auto
    show "\<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c f = g"
      by (metis comp_type f_type g_type terminal_func_type terminal_func_unique)
    show "\<And>h2. h2 : Y \<rightarrow> X \<Longrightarrow> h2 = id\<^sub>c X \<circ>\<^sub>c h2"
      using cfunc_type_def id_left_unit by auto
  qed
qed

lemma X_is_cart_prod2:
  "is_cart_prod X (\<beta>\<^bsub>X\<^esub>) (id X) one X"
  unfolding is_cart_prod_def
proof auto
  show "id\<^sub>c X : X \<rightarrow> X"
    by (simp add: id_type)
next
  show "\<beta>\<^bsub>X\<^esub> : X \<rightarrow> one"
    by (simp add: terminal_func_type)
next
  fix f g Z
  assume f_type: "f : Z \<rightarrow> one" and g_type: "g : Z \<rightarrow> X"
  then show "\<exists>h. h : Z \<rightarrow> X \<and>
           \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c h = f \<and> id\<^sub>c X \<circ>\<^sub>c h = g \<and> (\<forall>h2. h2 : Z \<rightarrow> X \<and> \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c h2 = f \<and> id\<^sub>c X \<circ>\<^sub>c h2 = g \<longrightarrow> h2 = h)"
  proof (rule_tac x=g in exI, auto)
    show "id\<^sub>c X \<circ>\<^sub>c g = g"
      using cfunc_type_def g_type id_left_unit by auto
    show "\<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c g = f"
      by (metis comp_type f_type g_type terminal_func_type terminal_func_unique)
    show "\<And>h2. h2 : Z \<rightarrow> X \<Longrightarrow> h2 = id\<^sub>c X \<circ>\<^sub>c h2"
      using cfunc_type_def id_left_unit by auto
  qed
qed

lemma A_x_one_iso_A:
  "X \<times>\<^sub>c one \<cong> X"
  by (metis X_is_cart_prod1 canonical_cart_prod_is_cart_prod cart_prods_isomorphic fst_conv is_isomorphic_def snd_conv)

lemma one_x_A_iso_A:
  "one \<times>\<^sub>c X \<cong> X"
  by (meson A_x_one_iso_A isomorphic_is_transitive product_commutes)

(* concrete examples of above isomorphisms *)

lemma left_cart_proj_one_left_inverse:
  "\<langle>id X,\<beta>\<^bsub>X\<^esub>\<rangle> \<circ>\<^sub>c left_cart_proj X one = id (X \<times>\<^sub>c one)"
  by (typecheck_cfuncs, smt (z3) cfunc_prod_comp cfunc_prod_unique id_left_unit2 id_right_unit2 right_cart_proj_type terminal_func_comp terminal_func_unique)

lemma left_cart_proj_one_right_inverse:
  "left_cart_proj X one \<circ>\<^sub>c \<langle>id X,\<beta>\<^bsub>X\<^esub>\<rangle> = id X"
  using left_cart_proj_cfunc_prod by (typecheck_cfuncs, blast)

lemma right_cart_proj_one_left_inverse:
  "\<langle>\<beta>\<^bsub>X\<^esub>,id X\<rangle> \<circ>\<^sub>c right_cart_proj one X = id (one \<times>\<^sub>c X)"
  by (typecheck_cfuncs, smt (z3) cart_prod_decomp cfunc_prod_comp id_left_unit2 id_right_unit2 right_cart_proj_cfunc_prod terminal_func_comp terminal_func_unique)

lemma right_cart_proj_one_right_inverse:
  "right_cart_proj one X \<circ>\<^sub>c \<langle>\<beta>\<^bsub>X\<^esub>,id X\<rangle> = id X"
  using right_cart_proj_cfunc_prod by (typecheck_cfuncs, blast)

lemma cfunc_cross_prod_right_terminal_decomp:
  assumes "f : X \<rightarrow> Y" "x : one \<rightarrow> Z"
  shows "f \<times>\<^sub>f x = \<langle>f, x \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>\<rangle> \<circ>\<^sub>c left_cart_proj X one"
  using assms by (typecheck_cfuncs, smt (z3) cfunc_cross_prod_def cfunc_prod_comp cfunc_type_def
      comp_associative2 right_cart_proj_type terminal_func_comp terminal_func_unique)

(* Proposition 2.1.21 *)
lemma cart_prod_elem_eq:
  assumes "a \<in>\<^sub>c X \<times>\<^sub>c Y" "b \<in>\<^sub>c 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)

(* Note 2.1.22 *)
lemma  element_pair_eq:
  assumes "x \<in>\<^sub>c X" "x' \<in>\<^sub>c X" "y \<in>\<^sub>c Y" "y' \<in>\<^sub>c Y"
  shows "\<langle>x, y\<rangle> = \<langle>x', y'\<rangle> \<longleftrightarrow> x = x' \<and> y = y'"
  by (metis assms left_cart_proj_cfunc_prod right_cart_proj_cfunc_prod)

(* Proposition 2.1.23 *)
lemma nonempty_right_imp_left_proj_epimorphism:
  "nonempty Y \<Longrightarrow> epimorphism (left_cart_proj X Y)"
proof -
  assume "nonempty Y"
  then obtain y where y_in_Y: "y : one \<rightarrow> Y"
    using nonempty_def by blast
  then have id_eq: "(left_cart_proj X Y) \<circ>\<^sub>c \<langle>id X, y \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>\<rangle> = id X"
    using comp_type id_type left_cart_proj_cfunc_prod terminal_func_type by blast
  then show "epimorphism (left_cart_proj X Y)"
    unfolding epimorphism_def
  proof auto
    fix g h
    assume domain_g: "domain g = codomain (left_cart_proj X Y)"
    assume domain_h: "domain h = codomain (left_cart_proj X Y)"

    assume "g \<circ>\<^sub>c left_cart_proj X Y = h \<circ>\<^sub>c left_cart_proj X Y"
    then have "g \<circ>\<^sub>c left_cart_proj X Y \<circ>\<^sub>c \<langle>id X, y \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>\<rangle> = h \<circ>\<^sub>c left_cart_proj X Y \<circ>\<^sub>c \<langle>id X, y \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>\<rangle>"
      using y_in_Y by (typecheck_cfuncs, simp add: cfunc_type_def comp_associative domain_g domain_h)
    then show "g = h"
      by (metis cfunc_type_def domain_g domain_h id_eq id_right_unit left_cart_proj_type)
  qed
qed

(*Pair to Proposition 2.1.23 *)
lemma nonempty_left_imp_right_proj_epimorphism:
  "nonempty X \<Longrightarrow> epimorphism (right_cart_proj X Y)"
proof -
  assume "nonempty X"
  then obtain y where y_in_Y: "y: one \<rightarrow> X"
    using nonempty_def by blast
  then have id_eq: "(right_cart_proj X Y) \<circ>\<^sub>c \<langle>y \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle> = id Y"
     using comp_type id_type right_cart_proj_cfunc_prod terminal_func_type by blast
  then show "epimorphism (right_cart_proj X Y)"
    unfolding epimorphism_def
  proof auto
    fix g h
    assume domain_g: "domain g = codomain (right_cart_proj X Y)"
    assume domain_h: "domain h = codomain (right_cart_proj X Y)"

    assume "g \<circ>\<^sub>c right_cart_proj X Y = h \<circ>\<^sub>c right_cart_proj X Y"
    then have "g \<circ>\<^sub>c right_cart_proj X Y \<circ>\<^sub>c \<langle>y \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle> = h \<circ>\<^sub>c right_cart_proj X Y \<circ>\<^sub>c \<langle>y \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle>"
      using y_in_Y by (typecheck_cfuncs, simp add: cfunc_type_def comp_associative domain_g domain_h)
    then show "g = h"
      by (metis cfunc_type_def domain_g domain_h id_eq id_right_unit right_cart_proj_type)
  qed
qed

lemma prod_with_empty_is_empty1:
  assumes "\<not>(nonempty A)"
  shows "\<not>(nonempty (A \<times>\<^sub>c B))"
  by (meson assms comp_type left_cart_proj_type nonempty_def)

lemma prod_with_empty_is_empty2:
  assumes "\<not>(nonempty B)"
  shows "\<not>(nonempty (A \<times>\<^sub>c B))"
  using assms cart_prod_decomp nonempty_def by blast

(* Definition 2.1.24 *)
definition injective :: "cfunc \<Rightarrow> bool" where
 "injective f  \<longleftrightarrow> (\<forall> x y. (x \<in>\<^sub>c domain f \<and> y \<in>\<^sub>c domain f \<and> f \<circ>\<^sub>c x = f \<circ>\<^sub>c y) \<longrightarrow> x = y)"

(* Exercise 2.1.26 *)
lemma monomorphism_imp_injective:
  "monomorphism f \<Longrightarrow> injective f"
  by (simp add: cfunc_type_def injective_def monomorphism_def)

(* Proposition 2.1.27 *)
lemma injective_imp_monomorphism:
  assumes "f \<in> ETCS_func"
  shows "injective f \<Longrightarrow> monomorphism f"
  unfolding monomorphism_def injective_def
proof safe
  fix g h
  assume f_inj: "\<forall>x y. x \<in>\<^sub>c domain f \<and> y \<in>\<^sub>c domain f \<and> f \<circ>\<^sub>c x = f \<circ>\<^sub>c y \<longrightarrow> x = y"
  assume cd_g_eq_d_f: "codomain g = domain f"
  assume cd_h_eq_d_f: "codomain h = domain f"
  assume fg_eq_fh: "f \<circ>\<^sub>c g = f \<circ>\<^sub>c h"

  obtain X Y where f_type: "f : X \<rightarrow> Y"
    using assms cfunc_type_def by blast
  obtain A where g_type: "g : A \<rightarrow> X" and h_type: "h : A \<rightarrow> X"
    by (metis cd_g_eq_d_f cd_h_eq_d_f cfunc_type_def domain_comp f_type fg_eq_fh)

  have "(\<forall>x. x \<in>\<^sub>c A \<longrightarrow> g \<circ>\<^sub>c x = h \<circ>\<^sub>c x)"
  proof auto
    fix x
    assume x_in_A: "x \<in>\<^sub>c A"

    have "f \<circ>\<^sub>c (g \<circ>\<^sub>c x) = f \<circ>\<^sub>c (h \<circ>\<^sub>c x)"
      using g_type h_type x_in_A f_type comp_associative2 fg_eq_fh by (typecheck_cfuncs, auto)
    then show "g \<circ>\<^sub>c x = h \<circ>\<^sub>c x"
      using cd_h_eq_d_f cfunc_type_def comp_type f_inj g_type h_type x_in_A by presburger
  qed
  then show "g = h"
    using g_type h_type one_separator by auto
qed

(* Definition 2.1.28 *)
definition surjective :: "cfunc \<Rightarrow> bool" where
 "surjective f  \<longleftrightarrow> (\<forall>y. y \<in>\<^sub>c codomain f \<longrightarrow> (\<exists>x. x \<in>\<^sub>c domain f \<and> f \<circ>\<^sub>c x = y))"

lemma surjective_def2:
  assumes "f : X \<rightarrow> Y"
  shows "surjective f  \<longleftrightarrow> (\<forall>y. y \<in>\<^sub>c Y \<longrightarrow> (\<exists>x. x \<in>\<^sub>c X \<and> f \<circ>\<^sub>c x = y))"
  using assms unfolding surjective_def cfunc_type_def by auto

(* Exercise 2.1.30 *)
lemma surjective_is_epimorphism:
  "surjective f \<Longrightarrow> epimorphism f"
  unfolding surjective_def epimorphism_def
proof (cases "nonempty (codomain f)", auto)
  fix g h
  assume f_surj: "\<forall>y. y \<in>\<^sub>c codomain f \<longrightarrow> (\<exists>x. x \<in>\<^sub>c domain f \<and> f \<circ>\<^sub>c x = y)"
  assume d_g_eq_cd_f: "domain g = codomain f"
  assume d_h_eq_cd_f: "domain h = codomain f"
  assume gf_eq_hf: "g \<circ>\<^sub>c f = h \<circ>\<^sub>c f"
  assume nonempty: "nonempty (codomain f)"

  obtain X Y where f_type: "f : X \<rightarrow> Y"
    using nonempty cfunc_type_def f_surj nonempty_def by auto
  obtain A where g_type: "g : Y \<rightarrow> A" and h_type: "h : Y \<rightarrow> A"
    by (metis cfunc_type_def codomain_comp d_g_eq_cd_f d_h_eq_cd_f f_type gf_eq_hf)

  show "g = h"
  proof (rule ccontr)
    assume "g \<noteq> h"
    then obtain y where y_in_X: "y \<in>\<^sub>c Y" and gy_neq_hy: "g \<circ>\<^sub>c y \<noteq> h \<circ>\<^sub>c y"
      using g_type h_type one_separator by blast
    then obtain x where "x \<in>\<^sub>c X" and "f \<circ>\<^sub>c x = y"
      using cfunc_type_def f_surj f_type by auto
    then have "g \<circ>\<^sub>c f \<noteq> h \<circ>\<^sub>c f"
      using comp_associative2 f_type g_type gy_neq_hy h_type by auto
    then show False
      using gf_eq_hf by auto
  qed
next
  fix g h
  assume empty: "\<not> nonempty (codomain f)"
  assume "domain g = codomain f" "domain h = codomain f"
  then show "g \<circ>\<^sub>c f = h \<circ>\<^sub>c f \<Longrightarrow> g = h"
    by (metis empty cfunc_type_def codomain_comp nonempty_def one_separator)
qed

lemma cart_prod_extract_left:
  assumes "f : one \<rightarrow> X" "g : one \<rightarrow> Y"
  shows "\<langle>f, g\<rangle> = \<langle>id X, g \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>\<rangle> \<circ>\<^sub>c f"
proof -
  have "\<langle>f, g\<rangle> = \<langle>id X \<circ>\<^sub>c f, g \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub> \<circ>\<^sub>c f\<rangle>"
    using assms by (typecheck_cfuncs, metis id_left_unit2 id_right_unit2 id_type one_unique_element)
  also have "... = \<langle>id X, g \<circ>\<^sub>c \<beta>\<^bsub>X\<^esub>\<rangle> \<circ>\<^sub>c f"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  then show ?thesis
    using calculation by auto
qed

lemma cart_prod_extract_right:
  assumes "f : one \<rightarrow> X" "g : one \<rightarrow> Y"
  shows "\<langle>f, g\<rangle> = \<langle>f \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle> \<circ>\<^sub>c g"
proof -
  have "\<langle>f, g\<rangle> = \<langle>f \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub> \<circ>\<^sub>c g, id Y \<circ>\<^sub>c g\<rangle>"
    using assms by (typecheck_cfuncs, metis id_left_unit2 id_right_unit2 id_type one_unique_element)
  also have "... = \<langle>f \<circ>\<^sub>c \<beta>\<^bsub>Y\<^esub>, id Y\<rangle> \<circ>\<^sub>c g"
    using assms by (typecheck_cfuncs, simp add: cfunc_prod_comp comp_associative2)
  then show ?thesis
    using calculation by auto
qed

subsection \<open>More Results on Cartesian Products\<close>

lemma cfunc_cross_prod_surj:
  assumes type_assms: "f : A \<rightarrow> C" "g : B \<rightarrow> D"
  assumes f_surj: "surjective f" and g_surj: "surjective g"
  shows "surjective (f \<times>\<^sub>f g)"
  unfolding surjective_def
proof(auto)
  fix y
  assume y_type: "y \<in>\<^sub>c codomain (f \<times>\<^sub>f g)"
  have fg_type: "f \<times>\<^sub>f g: (A \<times>\<^sub>c  B) \<rightarrow> (C \<times>\<^sub>c D)"
    using assms by typecheck_cfuncs
  then have "y \<in>\<^sub>c (C \<times>\<^sub>c D)"
    using cfunc_type_def y_type by auto
  then have "\<exists> c d. c \<in>\<^sub>c C \<and> d \<in>\<^sub>c D \<and> y = \<langle>c,d\<rangle>"
    using cart_prod_decomp by blast
  then obtain c d where y_def: "c \<in>\<^sub>c C \<and> d \<in>\<^sub>c D \<and> y = \<langle>c,d\<rangle>"
    by blast
  then have "\<exists> a b. a \<in>\<^sub>c A \<and> b \<in>\<^sub>c B \<and> f \<circ>\<^sub>c a = c \<and> g \<circ>\<^sub>c b = d"
    by (metis cfunc_type_def f_surj g_surj surjective_def type_assms)
  then obtain a b where ab_def: "a \<in>\<^sub>c A \<and> b \<in>\<^sub>c B \<and> f \<circ>\<^sub>c a = c \<and> g \<circ>\<^sub>c b = d"
    by blast
  then obtain x where x_def: "x = \<langle>a,b\<rangle>"
    by auto
  have x_type: "x \<in>\<^sub>c domain (f \<times>\<^sub>f g)"
    using ab_def cfunc_prod_type cfunc_type_def fg_type x_def by auto
  have "(f \<times>\<^sub>f g) \<circ>\<^sub>c x = y"
    using ab_def cfunc_cross_prod_comp_cfunc_prod type_assms(1) type_assms(2) x_def y_def by blast
  then show "\<exists>x. x \<in>\<^sub>c domain (f \<times>\<^sub>f g) \<and> (f \<times>\<^sub>f g) \<circ>\<^sub>c x = y"
    using x_type by blast
qed

lemma cfunc_cross_prod_surj_converse:
  assumes type_assms: "f : A \<rightarrow> C" "g : B \<rightarrow> D"
  assumes "surjective (f \<times>\<^sub>f g)"
  shows "(surjective (f)) \<and> (surjective (g))"
  unfolding surjective_def
proof(auto)
  fix y
  assume y_type: "y \<in>\<^sub>c codomain f"
  then have y_type2:  "y \<in>\<^sub>c C"
    using cfunc_type_def type_assms(1) by auto
  oops

lemma cfunc_cross_prod_mono_converse:
  assumes type_assms: "f : X \<rightarrow> Y" "g : Z \<rightarrow> W"
  assumes fg_inject: "injective (f \<times>\<^sub>f g)"
  assumes nonempty: "nonempty(X)" "nonempty(Z)"
  shows "injective f \<and> injective g"
  unfolding injective_def
proof (auto)
  fix x y
  assume x_type: "x \<in>\<^sub>c domain f"
  assume y_type: "y \<in>\<^sub>c domain f"
  assume equals: "f \<circ>\<^sub>c x = f \<circ>\<^sub>c y"
  have fg_type: "(f \<times>\<^sub>f g) : (X \<times>\<^sub>c Z) \<rightarrow> (Y \<times>\<^sub>c W)"
    by (simp add: cfunc_cross_prod_type type_assms)
  have x_type2: "x \<in>\<^sub>c X"
    using cfunc_type_def type_assms(1) x_type by auto
  have y_type2: "y \<in>\<^sub>c X"
    using cfunc_type_def type_assms(1) y_type by auto
  show "x = y"
        proof -
          obtain b where b_def: "b \<in>\<^sub>c Z"
            using nonempty(2) nonempty_def by blast

          have xb_type: "\<langle>x,b\<rangle> \<in>\<^sub>c X \<times>\<^sub>c Z"
            by (simp add: b_def cfunc_prod_type x_type2)
          have yb_type: "\<langle>y,b\<rangle> \<in>\<^sub>c X \<times>\<^sub>c Z"
            by (simp add: b_def cfunc_prod_type y_type2)
          have "(f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>x,b\<rangle> = \<langle>f \<circ>\<^sub>c x,g \<circ>\<^sub>c b\<rangle>"
            using b_def cfunc_cross_prod_comp_cfunc_prod type_assms(1) type_assms(2) x_type2 by blast
          also have "... = \<langle>f \<circ>\<^sub>c y,g \<circ>\<^sub>c b\<rangle>"
            by (simp add: equals)
          also have "... = (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>y,b\<rangle>"
            using b_def cfunc_cross_prod_comp_cfunc_prod type_assms(1) type_assms(2) y_type2 by auto
          then have "\<langle>x,b\<rangle> = \<langle>y,b\<rangle>"
            by (metis calculation cfunc_type_def fg_inject fg_type injective_def xb_type yb_type)
          then show "x = y"
            using b_def element_pair_eq x_type2 y_type2 by auto
        qed
      next
fix x y
  assume x_type: "x \<in>\<^sub>c domain g"
  assume y_type: "y \<in>\<^sub>c domain g"
  assume equals: "g \<circ>\<^sub>c x = g \<circ>\<^sub>c y"
  have fg_type: "(f \<times>\<^sub>f g) : (X \<times>\<^sub>c Z) \<rightarrow> (Y \<times>\<^sub>c W)"
    by (simp add: cfunc_cross_prod_type type_assms)
  have x_type2: "x \<in>\<^sub>c Z"
    using cfunc_type_def type_assms(2) x_type by auto
   have y_type2: "y \<in>\<^sub>c Z"
    using cfunc_type_def type_assms(2) y_type by auto
show "x = y"
        proof -
          obtain b where b_def: "b \<in>\<^sub>c X"
            using nonempty(1) nonempty_def by blast
          have xb_type: "\<langle>b,x\<rangle> \<in>\<^sub>c X \<times>\<^sub>c Z"
            by (simp add: b_def cfunc_prod_type x_type2)
          have yb_type: "\<langle>b,y\<rangle> \<in>\<^sub>c X \<times>\<^sub>c Z"
            by (simp add: b_def cfunc_prod_type y_type2)
          have "(f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>b,x\<rangle> = \<langle>f \<circ>\<^sub>c b,g \<circ>\<^sub>c x\<rangle>"
            using b_def cfunc_cross_prod_comp_cfunc_prod type_assms(1) type_assms(2) x_type2 by blast
          also have "... = \<langle>f \<circ>\<^sub>c b,g \<circ>\<^sub>c x\<rangle>"
            by (simp add: equals)
          also have "... = (f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>b,y\<rangle>"
            using b_def cfunc_cross_prod_comp_cfunc_prod equals type_assms(1) type_assms(2) y_type2 by auto
          then have "\<langle>b,x\<rangle> = \<langle>b,y\<rangle>"
            by (metis \<open>(f \<times>\<^sub>f g) \<circ>\<^sub>c \<langle>b,x\<rangle> = \<langle>f \<circ>\<^sub>c b,g \<circ>\<^sub>c x\<rangle>\<close> cfunc_type_def fg_inject fg_type injective_def xb_type yb_type)
          then show "x = y"
            using b_def element_pair_eq x_type2 y_type2 by auto
        qed
      qed

(*The next lemma shows us that unless
  both domains are nonempty we gain no new information.
 That is, it will be the case that f\<times>g is injective, and we
cannot infer from this that f or g are injective since
 f\<times>g will be injective no matter what.*)

lemma the_nonempty_assumption_above_is_always_required:
  assumes "f : X \<rightarrow> Y" "g : Z \<rightarrow> W"
  assumes "\<not>(nonempty(X)) \<or> \<not>(nonempty(Z))"
  shows "injective (f \<times>\<^sub>f g)"
  unfolding injective_def
proof(cases "nonempty(X)", auto)
  fix x y
  assume nonempty:  "nonempty X"
  assume x_type: "x  \<in>\<^sub>c domain (f \<times>\<^sub>f g)"
  assume "y \<in>\<^sub>c domain (f \<times>\<^sub>f g)"
  then have "\<not>(nonempty(Z))"
    using nonempty assms(3) by blast
  have fg_type: "(f \<times>\<^sub>f g) : (X \<times>\<^sub>c Z) \<rightarrow> (Y \<times>\<^sub>c W)"
    by (typecheck_cfuncs, simp add: assms(1) assms(2))
  then have "x  \<in>\<^sub>c (X \<times>\<^sub>c Z)"
    using x_type cfunc_type_def by auto
  then have "\<exists>z. z\<in>\<^sub>c Z"
    using cart_prod_decomp by blast
  then have False
    using assms(3) nonempty nonempty_def by blast
  then show "x=y"
    by auto
next
  fix x y
  assume X_is_empty: "\<not> nonempty X"
  assume x_type: "x  \<in>\<^sub>c domain (f \<times>\<^sub>f g)"
  assume "y \<in>\<^sub>c domain (f \<times>\<^sub>f g)"
  have fg_type: "(f \<times>\<^sub>f g) : (X \<times>\<^sub>c Z) \<rightarrow> (Y \<times>\<^sub>c W)"
    by (typecheck_cfuncs, simp add: assms(1) assms(2))
  then have "x  \<in>\<^sub>c (X \<times>\<^sub>c Z)"
    using x_type cfunc_type_def by auto
  then have "\<exists>z. z\<in>\<^sub>c X"
    using cart_prod_decomp by blast
  then have False
    using assms(3) X_is_empty nonempty_def by blast
  then show "x=y"
    by auto
qed

lemma nonempty_cfunc_cross_prod_decomp:
  assumes f_type: "f : A \<times>\<^sub>c B \<rightarrow> C \<times>\<^sub>c D"
  assumes A_nonempty: "a \<in>\<^sub>c A" and B_nonempty: "b \<in>\<^sub>c B"
  assumes "\<And> a b1 b2. a \<in>\<^sub>c A \<Longrightarrow> b1 \<in>\<^sub>c B \<Longrightarrow> b2 \<in>\<^sub>c B \<Longrightarrow>
    left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a, b1\<rangle> = left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a, b2\<rangle>"
  assumes "\<And> a1 a2 b. a1 \<in>\<^sub>c A \<Longrightarrow> a2 \<in>\<^sub>c A \<Longrightarrow> b \<in>\<^sub>c B \<Longrightarrow>
    right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a1, b\<rangle> = right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a2, b\<rangle>"
  shows "\<exists>! g. \<exists>! h. g : A \<rightarrow> C \<and> h : B \<rightarrow> D \<and> f = g \<times>\<^sub>f h"
proof (rule_tac a="left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id A, b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle>" in ex1I)
  show "\<exists>!h. left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle> : A \<rightarrow> C \<and>
         h : B \<rightarrow> D \<and> f = (left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle>) \<times>\<^sub>f h"
  proof (rule_tac a="right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle> a \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>, id B\<rangle>" in ex1I, auto)
    show "left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle> : A \<rightarrow> C"
      using assms by typecheck_cfuncs
    show "right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>,id\<^sub>c B\<rangle> : B \<rightarrow> D"
      using assms by typecheck_cfuncs

    show "f = (left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle>) \<times>\<^sub>f right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>,id\<^sub>c B\<rangle>"
    proof (subst cart_prod_eq[where Z="A \<times>\<^sub>c B", where X=C, where Y=D], auto)
      show "f : A \<times>\<^sub>c B \<rightarrow> C \<times>\<^sub>c D"
        using f_type by auto
      show "(left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle>) \<times>\<^sub>f right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>,id\<^sub>c B\<rangle>
          : A \<times>\<^sub>c B \<rightarrow> C \<times>\<^sub>c D"
        using assms by typecheck_cfuncs

      show "left_cart_proj C D \<circ>\<^sub>c f =
        left_cart_proj C D \<circ>\<^sub>c
          (left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle>)
            \<times>\<^sub>f right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>,id\<^sub>c B\<rangle>"
        (is "left_cart_proj C D \<circ>\<^sub>c f = left_cart_proj C D \<circ>\<^sub>c (?left \<times>\<^sub>f ?right)")
      proof -
        have "left_cart_proj C D \<circ>\<^sub>c (?left \<times>\<^sub>f ?right) = ?left \<circ>\<^sub>c left_cart_proj A B"
          using assms left_cart_proj_cfunc_cross_prod by (typecheck_cfuncs, blast)
        also have "... = left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>left_cart_proj A B,b \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>\<rangle>"
          using assms by (typecheck_cfuncs, smt cfunc_prod_comp comp_associative2 id_left_unit2 terminal_func_comp)
        also have "... = left_cart_proj C D \<circ>\<^sub>c f"
        proof (rule one_separator[where X="A \<times>\<^sub>c B", where Y=C])
          show "left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>left_cart_proj A B,b \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>\<rangle> : A \<times>\<^sub>c B \<rightarrow> C"
            using assms by typecheck_cfuncs
          show "left_cart_proj C D \<circ>\<^sub>c f : A \<times>\<^sub>c B \<rightarrow> C"
            using assms by typecheck_cfuncs
        next
          fix x
          assume x_type: "x \<in>\<^sub>c A \<times>\<^sub>c B"
          then obtain xa xb where xa_xb_types: "xa \<in>\<^sub>c A" "xb \<in>\<^sub>c B" and x_def: "x = \<langle>xa, xb\<rangle>"
            using cart_prod_decomp by blast

          have "(left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>left_cart_proj A B,b \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>\<rangle>) \<circ>\<^sub>c x
            = left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>left_cart_proj A B \<circ>\<^sub>c \<langle>xa, xb\<rangle>, b \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub> \<circ>\<^sub>c \<langle>xa, xb\<rangle>\<rangle>"
            unfolding x_def using assms xa_xb_types
            by (typecheck_cfuncs, smt cfunc_prod_comp comp_associative2)
          also have "... = left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>xa, b\<rangle>"
            using assms xa_xb_types
            by (typecheck_cfuncs, metis id_right_unit2 id_type left_cart_proj_cfunc_prod one_unique_element)
          also have "... = left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c x"
            unfolding x_def by (simp add: B_nonempty assms(4) xa_xb_types)
          also have "... = (left_cart_proj C D \<circ>\<^sub>c f) \<circ>\<^sub>c x"
            using assms x_type by (typecheck_cfuncs, metis comp_associative2)
          then show "(left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>left_cart_proj A B,b \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>\<rangle>) \<circ>\<^sub>c x = (left_cart_proj C D \<circ>\<^sub>c f) \<circ>\<^sub>c x"
            using calculation by auto
        qed
        then show "left_cart_proj C D \<circ>\<^sub>c f = left_cart_proj C D \<circ>\<^sub>c (?left \<times>\<^sub>f ?right)"
          using calculation by auto
      qed

      show "right_cart_proj C D \<circ>\<^sub>c f =
        right_cart_proj C D \<circ>\<^sub>c
          (left_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>id\<^sub>c A,b \<circ>\<^sub>c \<beta>\<^bsub>A\<^esub>\<rangle>)
            \<times>\<^sub>f right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>B\<^esub>,id\<^sub>c B\<rangle>"
        (is "right_cart_proj C D \<circ>\<^sub>c f = right_cart_proj C D \<circ>\<^sub>c (?left \<times>\<^sub>f ?right)")
      proof -
        have "right_cart_proj C D \<circ>\<^sub>c (?left \<times>\<^sub>f ?right) = ?right \<circ>\<^sub>c right_cart_proj A B"
          using assms right_cart_proj_cfunc_cross_prod by (typecheck_cfuncs, blast)
        also have "... = right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>, right_cart_proj A B\<rangle>"
          using assms by (typecheck_cfuncs, smt cfunc_prod_comp comp_associative2 id_left_unit2 terminal_func_comp)
        also have "... = right_cart_proj C D \<circ>\<^sub>c f"
        proof (rule one_separator[where X="A \<times>\<^sub>c B", where Y=D])
          show "right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>,right_cart_proj A B\<rangle> : A \<times>\<^sub>c B \<rightarrow> D"
            using assms by typecheck_cfuncs
          show "right_cart_proj C D \<circ>\<^sub>c f : A \<times>\<^sub>c B \<rightarrow> D"
            using assms by typecheck_cfuncs
        next
          fix x
          assume x_type: "x \<in>\<^sub>c A \<times>\<^sub>c B"
          then obtain xa xb where xa_xb_types: "xa \<in>\<^sub>c A" "xb \<in>\<^sub>c B" and x_def: "x = \<langle>xa, xb\<rangle>"
            using cart_prod_decomp by blast

          have "(right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>,right_cart_proj A B\<rangle>) \<circ>\<^sub>c x
            = right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub> \<circ>\<^sub>c \<langle>xa, xb\<rangle>, right_cart_proj A B \<circ>\<^sub>c \<langle>xa, xb\<rangle>\<rangle>"
            unfolding x_def using assms xa_xb_types
            by (typecheck_cfuncs, smt cfunc_prod_comp comp_associative2)
          also have "... = right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a, xb\<rangle>"
            using assms xa_xb_types
            by (typecheck_cfuncs, metis id_right_unit2 id_type right_cart_proj_cfunc_prod one_unique_element)
          also have "... = right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c x"
            unfolding x_def by (simp add: A_nonempty assms(5) xa_xb_types)
          also have "... = (right_cart_proj C D \<circ>\<^sub>c f) \<circ>\<^sub>c x"
            using assms x_type by (typecheck_cfuncs, metis comp_associative2)
          then show "(right_cart_proj C D \<circ>\<^sub>c f \<circ>\<^sub>c \<langle>a \<circ>\<^sub>c \<beta>\<^bsub>A \<times>\<^sub>c B\<^esub>,right_cart_proj A B\<rangle>) \<circ>\<^sub>c x = (right_cart_proj C D \<circ>\<^sub>c f) \<circ>\<^sub>c x"
            using calculation by auto
        qed
        then show "right_cart_proj C D \<circ>\<^sub>c f = right_cart_proj C D \<circ>\<^sub>c (?left \<times>\<^sub>f ?right)"
          using calculation by auto
      qed
    qed
  next
    fix x
    oops

end


(* Title: UD/Tests/UD_Tests.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

A test suite for the framework UD.
*)

section\<open>Test suite for UD\<close>
theory UD_Tests
  imports
    "../UD"
    "../../IML_UT/IML_UT"
    Complex_Main
begin

subsection\<open>Background\<close>

(*
The following two definitions were copied from
HOL-Analysis.Elementary_Topology with minor amendments
to avoid unnecessary dependencies
*)
definition (in topological_space) islimpt:: "'a \<Rightarrow> 'a set \<Rightarrow> bool"
  where "islimpt x S \<longleftrightarrow> (\<forall>T. x\<in>T \<longrightarrow> open T \<longrightarrow> (\<exists>y\<in>S. y\<in>T \<and> y\<noteq>x))"
definition closure :: "('a::topological_space) set \<Rightarrow> 'a set"
  where "closure S = S \<union> {x. islimpt x S}"

ud \<open>topological_space.closed\<close>
ud \<open>islimpt\<close>

lemma closed_with: "closed \<equiv> closed.with open"
  unfolding closed_def closed.with_def .

definition closure_with :: "('a set \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "closure_with \<tau> \<equiv> \<lambda>S. S \<union> {x. islimpt.with \<tau> x S}"

lemma closure_with: "closure \<equiv> closure_with open"
  unfolding closure_def islimpt.with closure_with_def .

subsection\<open>Tests\<close>

ML_file\<open>UD_TEST_UNOVERLOAD_DEFINITION.ML\<close>

ML\<open>
Lecker.test_group @{context} () [ud_test_unoverload_definition.test_suite]
\<close>

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Polynomials in a Finite Field\<close>
text \<open>We connect polynomials in a prime field with integer polynomials modulo some prime.\<close>

theory Poly_Mod_Finite_Field
  imports
  Finite_Field
  Polynomial_Interpolation.Ring_Hom_Poly
  "HOL-Types_To_Sets.Types_To_Sets"
  Missing_Multiset2
  Poly_Mod
begin

(* TODO: Move -- General transfer rule *)
declare rel_mset_Zero[transfer_rule]

lemma mset_transfer[transfer_rule]: "(list_all2 rel ===> rel_mset rel) mset mset"
proof (intro rel_funI)
  show "list_all2 rel xs ys \<Longrightarrow> rel_mset rel (mset xs) (mset ys)" for xs ys
  proof (induct xs arbitrary: ys)
    case Nil
    then show ?case by auto
  next
    case IH: (Cons x xs)
    then show ?case by (auto dest!:msed_rel_invL simp: list_all2_Cons1 intro!:rel_mset_Plus)
  qed
qed

abbreviation to_int_poly :: "'a :: finite mod_ring poly \<Rightarrow> int poly" where
  "to_int_poly \<equiv> map_poly to_int_mod_ring"

interpretation to_int_poly_hom: map_poly_inj_zero_hom to_int_mod_ring ..

lemma irreducible\<^sub>d_def_0:
  fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  shows "irreducible\<^sub>d f = (degree f \<noteq> 0 \<and>
  (\<forall> g h. degree g \<noteq> 0 \<longrightarrow> degree h \<noteq> 0 \<longrightarrow> f \<noteq> g * h))"
proof-
  have "degree g \<noteq> 0 \<Longrightarrow> g \<noteq> 0" for g :: "'a poly" by auto
  note 1 = degree_mult_eq[OF this this, simplified]
  then show ?thesis by (force elim!: irreducible\<^sub>dE)
qed

subsection \<open>Transferring to class-based mod-ring\<close>

locale poly_mod_type = poly_mod m
  for m and ty :: "'a :: nontriv itself" +
  assumes m: "m = CARD('a)"
begin

lemma m1: "m > 1" using nontriv[where 'a = 'a] by (auto simp:m)

sublocale poly_mod_2 using m1 by unfold_locales

definition MP_Rel :: "int poly \<Rightarrow> 'a mod_ring poly \<Rightarrow> bool"
  where "MP_Rel f f' \<equiv> (Mp f = to_int_poly f')"

definition M_Rel :: "int \<Rightarrow> 'a mod_ring \<Rightarrow> bool"
  where "M_Rel x x' \<equiv> (M x = to_int_mod_ring x')"

definition "MF_Rel \<equiv> rel_prod M_Rel (rel_mset MP_Rel)"

lemma to_int_mod_ring_plus: "to_int_mod_ring ((x :: 'a mod_ring) + y) = M (to_int_mod_ring x + to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma to_int_mod_ring_times: "to_int_mod_ring ((x :: 'a mod_ring) * y) = M (to_int_mod_ring x * to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma degree_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) degree_m degree"
  unfolding MP_Rel_def rel_fun_def
  by (auto intro!: degree_map_poly)

lemma eq_M_Rel[transfer_rule]: "(M_Rel ===> M_Rel ===> (=)) (\<lambda> x y. M x = M y) (=)"
  unfolding M_Rel_def rel_fun_def by auto

interpretation to_int_mod_ring_hom: map_poly_inj_zero_hom to_int_mod_ring..

lemma eq_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (=m) (=)"
  unfolding MP_Rel_def rel_fun_def by auto

lemma eq_Mf_Rel[transfer_rule]: "(MF_Rel ===> MF_Rel ===> (=)) (\<lambda> x y. Mf x = Mf y) (=)"
proof (intro rel_funI, goal_cases)
  case (1 cfs Cfs dgs Dgs)
  obtain c fs where cfs: "cfs = (c,fs)" by force
  obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
  obtain d gs where dgs: "dgs = (d,gs)" by force
  obtain D Gs where Dgs: "Dgs = (D,Gs)" by force
  note pairs = cfs Cfs dgs Dgs
  from 1[unfolded pairs MF_Rel_def rel_prod.simps]
  have *[transfer_rule]: "M_Rel c C" "M_Rel d D" "rel_mset MP_Rel fs Fs" "rel_mset MP_Rel gs Gs"
    by auto
  have eq1: "(M c = M d) = (C = D)" by transfer_prover
  from *(3)[unfolded rel_mset_def] obtain fs' Fs' where fs_eq: "mset fs' = fs" "mset Fs' = Fs"
    and rel_f: "list_all2 MP_Rel fs' Fs'" by auto
  from *(4)[unfolded rel_mset_def] obtain gs' Gs' where gs_eq: "mset gs' = gs" "mset Gs' = Gs"
    and rel_g: "list_all2 MP_Rel gs' Gs'" by auto
  have eq2: "(image_mset Mp fs = image_mset Mp gs) = (Fs = Gs)"
    using *(3-4)
  proof (induct fs arbitrary: Fs gs Gs)
    case (empty Fs gs Gs)
    from empty(1) have Fs: "Fs = {#}" unfolding rel_mset_def by auto
    with empty show ?case by (cases gs; cases Gs; auto simp: rel_mset_def)
  next
    case (add f fs Fs' gs' Gs')
    note [transfer_rule] = add(3)
    from msed_rel_invL[OF add(2)]
    obtain Fs F where Fs': "Fs' = Fs + {#F#}" and rel[transfer_rule]:
      "MP_Rel f F" "rel_mset MP_Rel fs Fs" by auto
    note IH = add(1)[OF rel(2)]
    {
      from add(3)[unfolded rel_mset_def] obtain gs Gs where id: "mset gs = gs'" "mset Gs = Gs'"
        and rel: "list_all2 MP_Rel gs Gs" by auto
      have "Mp f \<in># image_mset Mp gs' \<longleftrightarrow> F \<in># Gs'"
      proof -
        have "?thesis = ((Mp f \<in> Mp ` set gs) = (F \<in> set Gs))"
          unfolding id[symmetric] by simp
        also have \<dots> using rel
        proof (induct gs Gs rule: list_all2_induct)
          case (Cons g gs G Gs)
          note [transfer_rule] = Cons(1-2)
          have id: "(Mp g = Mp f) = (F = G)" by (transfer, auto)
          show ?case using id Cons(3) by auto
        qed auto
        finally show ?thesis by simp
      qed
    } note id = this
    show ?case
    proof (cases "Mp f \<in># image_mset Mp gs'")
      case False
      have "Mp f \<in># image_mset Mp (fs + {#f#})" by auto
      with False have F: "image_mset Mp (fs + {#f#}) \<noteq> image_mset Mp gs'" by metis
      with False[unfolded id] show ?thesis unfolding Fs' by auto
    next
      case True
      then obtain g where fg: "Mp f = Mp g" and g: "g \<in># gs'" by auto
      from g obtain gs where gs': "gs' = add_mset g gs" by (rule mset_add)
      from msed_rel_invL[OF add(3)[unfolded gs']]
      obtain Gs G where Gs': "Gs' = Gs + {# G #}" and gG[transfer_rule]: "MP_Rel g G" and
        gsGs: "rel_mset MP_Rel gs Gs" by auto
      have FG: "F = G" by (transfer, simp add: fg)
      note IH = IH[OF gsGs]
      show ?thesis unfolding gs' Fs' Gs' by (simp add: fg IH FG)
    qed
  qed
  show "(Mf cfs = Mf dgs) = (Cfs = Dgs)" unfolding pairs Mf_def split
    by (simp add: eq1 eq2)
qed

lemmas coeff_map_poly_of_int = coeff_map_poly[of of_int, OF of_int_0]

lemma plus_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) (+) (+)"
  unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x f y g)
  have "Mp (x + y) = Mp (Mp x + Mp y)" by simp
  also have "\<dots> = Mp (map_poly to_int_mod_ring f + map_poly to_int_mod_ring g)" unfolding 1 ..
  also have "\<dots> = map_poly to_int_mod_ring (f + g)" unfolding poly_eq_iff Mp_coeff
       by (auto simp: to_int_mod_ring_plus)
  finally show ?case .
qed

lemma times_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))"
  unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x f y g)
  have "Mp (x * y) = Mp (Mp x * Mp y)" by simp
  also have "\<dots> = Mp (map_poly to_int_mod_ring f * map_poly to_int_mod_ring g)" unfolding 1 ..
  also have "\<dots> = map_poly to_int_mod_ring (f * g)"
  proof -
    { fix n :: nat
      define A where "A = {.. n}"
      have "finite A" unfolding A_def by auto
      then have "M (\<Sum>i\<le>n. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) =
           to_int_mod_ring (\<Sum>i\<le>n. coeff f i * coeff g (n - i))"
        unfolding A_def[symmetric]
      proof (induct A)
        case (insert a A)
        have "?case = ?case" (is "(?l = ?r) = _") by simp
        have "?r = to_int_mod_ring (coeff f a * coeff g (n - a) + (\<Sum>i\<in> A. coeff f i * coeff g (n - i)))"
          using insert(1-2) by auto
        note r = this[unfolded to_int_mod_ring_plus to_int_mod_ring_times]
        from insert(1-2) have "?l = M (to_int_mod_ring (coeff f a) * to_int_mod_ring (coeff g (n - a))
          + M (\<Sum>i\<in>A. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))))"
          by simp
        also have "M (\<Sum>i\<in>A. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) = to_int_mod_ring (\<Sum>i\<in>A. coeff f i * coeff g (n - i))"
          unfolding insert ..
        finally
        show ?case unfolding r by simp
      qed auto
    }
    then show ?thesis by (auto intro!:poly_eqI simp: coeff_mult  Mp_coeff)
  qed
  finally show ?case .
qed

lemma smult_MP_Rel[transfer_rule]: "(M_Rel ===> MP_Rel ===> MP_Rel) smult smult"
  unfolding MP_Rel_def M_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x x' f f')
  thus ?case unfolding poly_eq_iff coeff Mp_coeff
    coeff_smult M_def
  proof (intro allI, goal_cases)
    case (1 n)
    have "x * coeff f n mod m = (x mod m) * (coeff f n mod m) mod m"
      by (simp add: mod_simps)
    also have "\<dots> = to_int_mod_ring x' * (to_int_mod_ring (coeff f' n)) mod m"
      using 1 by auto
    also have " \<dots> = to_int_mod_ring (x' * coeff f' n)"
      unfolding to_int_mod_ring_times M_def by simp
    finally show ?case by auto
  qed
qed

lemma one_M_Rel[transfer_rule]: "M_Rel 1 1"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma one_MP_Rel[transfer_rule]: "MP_Rel 1 1"
  unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
  unfolding m by auto

lemma zero_M_Rel[transfer_rule]: "M_Rel 0 0"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma zero_MP_Rel[transfer_rule]: "MP_Rel 0 0"
  unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
  unfolding m by auto

lemma listprod_MP_Rel[transfer_rule]: "(list_all2 MP_Rel ===> MP_Rel) prod_list prod_list"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  thus ?case
  proof (induct xs ys rule: list_all2_induct)
    case (Cons x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one_MP_Rel)
qed

lemma prod_mset_MP_Rel[transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel) prod_mset prod_mset"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  have "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))" "MP_Rel 1 1" by transfer_prover+
  from 1 this show ?case
  proof (induct xs ys rule: rel_mset_induct)
    case (add R x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one_MP_Rel)
qed

lemma right_unique_MP_Rel[transfer_rule]: "right_unique MP_Rel"
  unfolding right_unique_def MP_Rel_def by auto

lemma M_to_int_mod_ring: "M (to_int_mod_ring (x :: 'a mod_ring)) = to_int_mod_ring x"
  unfolding M_def unfolding m by (transfer, auto)

lemma Mp_to_int_poly: "Mp (to_int_poly (f :: 'a mod_ring poly)) = to_int_poly f"
  by (auto simp: poly_eq_iff Mp_coeff M_to_int_mod_ring)

lemma right_total_M_Rel[transfer_rule]: "right_total M_Rel"
  unfolding right_total_def M_Rel_def using M_to_int_mod_ring by blast

lemma left_total_M_Rel[transfer_rule]: "left_total M_Rel"
  unfolding left_total_def M_Rel_def[abs_def]
proof
  fix x
  show "\<exists> x' :: 'a mod_ring. M x = to_int_mod_ring x'"  unfolding M_def unfolding m
    by (rule exI[of _ "of_int x"], transfer, simp)
qed

lemma bi_total_M_Rel[transfer_rule]: "bi_total M_Rel"
  using right_total_M_Rel left_total_M_Rel by (metis bi_totalI)

lemma right_total_MP_Rel[transfer_rule]: "right_total MP_Rel"
  unfolding right_total_def MP_Rel_def
proof
  fix f :: "'a mod_ring poly"
  show "\<exists>x. Mp x = to_int_poly f"
    by (intro exI[of _ "to_int_poly f"], simp add: Mp_to_int_poly)
qed

lemma to_int_mod_ring_of_int_M: "to_int_mod_ring (of_int x :: 'a mod_ring) = M x" unfolding M_def
  unfolding m by transfer auto

lemma Mp_f_representative: "Mp f = to_int_poly (map_poly of_int f :: 'a mod_ring poly)"
  unfolding Mp_def by (auto intro: poly_eqI simp: coeff_map_poly to_int_mod_ring_of_int_M)

lemma left_total_MP_Rel[transfer_rule]: "left_total MP_Rel"
  unfolding left_total_def MP_Rel_def[abs_def] using Mp_f_representative by blast

lemma bi_total_MP_Rel[transfer_rule]: "bi_total MP_Rel"
  using right_total_MP_Rel left_total_MP_Rel by (metis bi_totalI)

lemma bi_total_MF_Rel[transfer_rule]: "bi_total MF_Rel"
  unfolding MF_Rel_def[abs_def]
  by (intro prod.bi_total_rel multiset.bi_total_rel bi_total_MP_Rel bi_total_M_Rel)

lemma right_total_MF_Rel[transfer_rule]: "right_total MF_Rel"
  using bi_total_MF_Rel unfolding bi_total_alt_def by auto

lemma left_total_MF_Rel[transfer_rule]: "left_total MF_Rel"
  using bi_total_MF_Rel unfolding bi_total_alt_def by auto

lemma domain_RT_rel[transfer_domain_rule]: "Domainp MP_Rel = (\<lambda> f. True)"
proof
  fix f :: "int poly"
  show "Domainp MP_Rel f = True" unfolding MP_Rel_def[abs_def] Domainp.simps
    by (auto simp: Mp_f_representative)
qed

lemma mem_MP_Rel[transfer_rule]: "(MP_Rel ===> rel_set MP_Rel ===> (=)) (\<lambda> x Y. \<exists>y \<in> Y. eq_m x y) (\<in>)"
proof (intro rel_funI iffI)
  fix x y X Y assume xy: "MP_Rel x y" and XY: "rel_set MP_Rel X Y"
  { assume "\<exists>x' \<in> X. x =m x'"
    then obtain x' where x'X: "x' \<in> X" and xx': "x =m x'" by auto
    with xy have x'y: "MP_Rel x' y" by (auto simp: MP_Rel_def)
    from rel_setD1[OF XY x'X] obtain y' where "MP_Rel x' y'" and "y' \<in> Y" by auto
    with x'y
    show "y \<in> Y" by (auto simp: MP_Rel_def)
  }
  assume "y \<in> Y"
  from rel_setD2[OF XY this] obtain x' where x'X: "x' \<in> X" and x'y: "MP_Rel x' y" by auto
  from xy x'y have "x =m x'" by (auto simp: MP_Rel_def)
  with x'X show "\<exists>x' \<in> X. x =m x'" by auto
qed

lemma conversep_MP_Rel_OO_MP_Rel [simp]: "MP_Rel\<inverse>\<inverse> OO MP_Rel = (=)"
  using Mp_to_int_poly by (intro ext, auto simp: OO_def MP_Rel_def)

lemma MP_Rel_OO_conversep_MP_Rel [simp]: "MP_Rel OO MP_Rel\<inverse>\<inverse> = eq_m"
  by (intro ext, auto simp: OO_def MP_Rel_def Mp_f_representative)

lemma conversep_MP_Rel_OO_eq_m [simp]: "MP_Rel\<inverse>\<inverse> OO eq_m = MP_Rel\<inverse>\<inverse>"
  by (intro ext, auto simp: OO_def MP_Rel_def)

lemma eq_m_OO_MP_Rel [simp]: "eq_m OO MP_Rel = MP_Rel"
  by (intro ext, auto simp: OO_def MP_Rel_def)

lemma eq_mset_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> rel_mset MP_Rel ===> (=)) (rel_mset eq_m) (=)"
proof (intro rel_funI iffI)
  fix A B X Y
  assume AX: "rel_mset MP_Rel A X" and BY: "rel_mset MP_Rel B Y"
  {
    assume AB: "rel_mset eq_m A B"
    from AX have "rel_mset MP_Rel\<inverse>\<inverse> X A" by (simp add: multiset.rel_flip)
    note rel_mset_OO[OF this AB]
    note rel_mset_OO[OF this BY]
    then show "X = Y" by (simp add: multiset.rel_eq)
  }
  assume "X = Y"
  with BY have "rel_mset MP_Rel\<inverse>\<inverse> X B" by (simp add: multiset.rel_flip)
  from rel_mset_OO[OF AX this]
  show "rel_mset eq_m A B" by simp
qed

lemma dvd_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (dvdm) (dvd)"
  unfolding dvdm_def[abs_def] dvd_def[abs_def]
  by transfer_prover

lemma irreducible_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible_m irreducible"
  unfolding irreducible_m_def irreducible_def
  by transfer_prover

lemma irreducible\<^sub>d_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible\<^sub>d_m irreducible\<^sub>d"
  unfolding irreducible\<^sub>d_m_def[abs_def] irreducible\<^sub>d_def[abs_def]
  by transfer_prover

lemma UNIV_M_Rel[transfer_rule]: "rel_set M_Rel {0..<m} UNIV"
  unfolding rel_set_def M_Rel_def[abs_def] M_def
  by (auto simp: M_def m, goal_cases, metis to_int_mod_ring_of_int_mod_ring, (transfer, auto)+)

lemma coeff_MP_Rel [transfer_rule]: "(MP_Rel ===> (=) ===> M_Rel) coeff coeff"
  unfolding rel_fun_def M_Rel_def MP_Rel_def Mp_coeff[symmetric] by auto

lemma M_1_1: "M 1 = 1" unfolding M_def unfolding m by simp

lemma square_free_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) square_free_m square_free"
  unfolding square_free_m_def[abs_def] square_free_def[abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma mset_factors_m_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel ===> (=)) mset_factors_m mset_factors"
  unfolding mset_factors_def mset_factors_m_def
  by (transfer_prover_start, transfer_step+, auto dest:eq_m_irreducible_m)

lemma coprime_MP_Rel [transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) coprime_m coprime"
  unfolding coprime_m_def[abs_def] coprime_def' [abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma prime_elem_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) prime_elem_m prime_elem"
  unfolding prime_elem_m_def prime_elem_def by transfer_prover

end

context poly_mod_2 begin

lemma non_empty: "{0..<m} \<noteq> {}" using m1 by auto

lemma type_to_set:
  assumes type_def: "\<exists>(Rep :: 'b \<Rightarrow> int) Abs. type_definition Rep Abs {0 ..< m :: int}"
  shows "class.nontriv (TYPE('b))" (is ?a) and "m = int CARD('b)" (is ?b)
proof -
  from type_def obtain rep :: "'b \<Rightarrow> int" and abs :: "int \<Rightarrow> 'b" where t: "type_definition rep abs {0 ..< m}" by auto
  have "card (UNIV :: 'b set) = card {0 ..< m}" using t by (rule type_definition.card)
  also have "\<dots> = m" using m1 by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using m1 by auto
qed

end

locale poly_mod_prime_type = poly_mod_type m ty for m :: int and
  ty :: "'a :: prime_card itself"
begin

lemma factorization_MP_Rel [transfer_rule]:
  "(MP_Rel ===> MF_Rel ===> (=)) factorization_m (factorization Irr_Mon)"
  unfolding rel_fun_def
proof (intro allI impI, goal_cases)
  case (1 f F cfs Cfs)
  note [transfer_rule] = 1(1)
  obtain c fs where cfs: "cfs = (c,fs)" by force
  obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
  from 1(2)[unfolded rel_prod.simps cfs Cfs MF_Rel_def]
  have tr[transfer_rule]: "M_Rel c C" "rel_mset MP_Rel fs Fs" by auto
  have eq: "(f =m smult c (prod_mset fs) = (F = smult C (prod_mset Fs)))"
    by transfer_prover
  have "set_mset Fs \<subseteq> Irr_Mon = (\<forall> x \<in># Fs. irreducible\<^sub>d x \<and> monic x)" unfolding Irr_Mon_def by auto
  also have "\<dots> = (\<forall>f\<in>#fs. irreducible\<^sub>d_m f \<and> monic (Mp f))"
  proof (rule sym, transfer_prover_start, transfer_step+)
    {
      fix f
      assume "f \<in># fs"
      have "monic (Mp f) \<longleftrightarrow> M (coeff f (degree_m f)) = M 1"
        unfolding Mp_coeff[symmetric] by simp
    }
    thus "(\<forall>f\<in>#fs. irreducible\<^sub>d_m f \<and> monic (Mp f)) =
      (\<forall>x\<in>#fs. irreducible\<^sub>d_m x \<and> M (coeff x (degree_m x)) = M 1)" by auto
  qed
  finally
  show "factorization_m f cfs = factorization Irr_Mon F Cfs" unfolding cfs Cfs
    factorization_m_def factorization_def split eq by simp
qed

lemma unique_factorization_MP_Rel [transfer_rule]: "(MP_Rel ===> MF_Rel ===> (=))
  unique_factorization_m (unique_factorization Irr_Mon)"
  unfolding rel_fun_def
proof (intro allI impI, goal_cases)
  case (1 f F cfs Cfs)
  note [transfer_rule] = 1(1,2)
  let ?F = "factorization Irr_Mon F"
  let ?f = "factorization_m f"
  let ?R = "Collect ?F"
  let ?L = "Mf ` Collect ?f"
  note X_to_x = right_total_MF_Rel[unfolded right_total_def, rule_format]
  {
    fix X
    assume "X \<in> ?R"
    hence F: "?F X" by simp
    from X_to_x[of X] obtain x where rel[transfer_rule]: "MF_Rel x X" by blast
    from F[untransferred] have "Mf x \<in> ?L" by blast
    with rel have "\<exists> x. Mf x \<in> ?L \<and> MF_Rel x X" by blast
  } note R_to_L = this
  show "unique_factorization_m f cfs = unique_factorization Irr_Mon F Cfs" unfolding
    unique_factorization_m_def unique_factorization_def
  proof -
    have fF: "?F Cfs = ?f cfs" by transfer simp
    have "(?L = {Mf cfs}) = (?L \<subseteq> {Mf cfs} \<and> Mf cfs \<in> ?L)" by blast
    also have "?L \<subseteq> {Mf cfs} = (\<forall> dfs. ?f dfs \<longrightarrow> Mf dfs = Mf cfs)" by blast
    also have "\<dots> = (\<forall> y. ?F y \<longrightarrow> y = Cfs)" (is "?left = ?right")
    proof (rule; intro allI impI)
      fix Dfs
      assume *: ?left and F: "?F Dfs"
      from X_to_x[of Dfs] obtain dfs where [transfer_rule]: "MF_Rel dfs Dfs" by auto
      from F[untransferred] have f: "?f dfs" .
      from *[rule_format, OF f] have eq: "Mf dfs = Mf cfs" by simp
      have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp)
      thus "Dfs = Cfs" using eq by simp
    next
      fix dfs
      assume *: ?right and f: "?f dfs"
      from left_total_MF_Rel obtain Dfs where
        rel[transfer_rule]: "MF_Rel dfs Dfs" unfolding left_total_def by blast
      have "?F Dfs" by (transfer, rule f)
      from *[rule_format, OF this] have eq: "Dfs = Cfs" .
      have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp)
      thus "Mf dfs = Mf cfs" using eq by simp
    qed
    also have "Mf cfs \<in> ?L = (\<exists> dfs. ?f dfs \<and> Mf cfs = Mf dfs)" by auto
    also have "\<dots> = ?F Cfs"  unfolding fF
    proof
      assume "\<exists> dfs. ?f dfs \<and> Mf cfs  = Mf dfs"
      then obtain dfs where f: "?f dfs" and id: "Mf dfs = Mf cfs" by auto
      from f have "?f (Mf dfs)" by simp
      from this[unfolded id] show "?f cfs" by simp
    qed blast
    finally show "(?L = {Mf cfs}) = (?R = {Cfs})" by auto
  qed
qed

end

context begin
private lemma 1: "poly_mod_type TYPE('a :: nontriv) m = (m = int CARD('a))"
  and 2: "class.nontriv TYPE('a) = (CARD('a) \<ge> 2)"
  unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto

private lemma 3: "poly_mod_prime_type TYPE('b) m = (m = int CARD('b))"
  and 4: "class.prime_card TYPE('b :: prime_card) = prime CARD('b :: prime_card)"
  unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto

lemmas poly_mod_type_simps = 1 2 3 4
end

lemma remove_duplicate_premise: "(PROP P \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> PROP Q)" (is "?l \<equiv> ?r")
proof (intro Pure.equal_intr_rule)
  assume p: "PROP P" and ppq: "PROP ?l"
  from ppq[OF p p] show "PROP Q".
next
  assume p: "PROP P" and pq: "PROP ?r"
  from pq[OF p] show "PROP Q".
qed

context poly_mod_prime begin

lemma type_to_set:
  assumes type_def: "\<exists>(Rep :: 'b \<Rightarrow> int) Abs. type_definition Rep Abs {0 ..< p :: int}"
  shows "class.prime_card (TYPE('b))" (is ?a) and "p = int CARD('b)" (is ?b)
proof -
  from prime have p2: "p \<ge> 2" by (rule prime_ge_2_int)
  from type_def obtain rep :: "'b \<Rightarrow> int" and abs :: "int \<Rightarrow> 'b" where t: "type_definition rep abs {0 ..< p}" by auto
  have "card (UNIV :: 'b set) = card {0 ..< p}" using t by (rule type_definition.card)
  also have "\<dots> = p" using p2 by auto
  finally show ?b ..
  then show ?a unfolding class.prime_card_def using prime p2 by auto
qed
end

(* it will be nice to be able to automate this *)

lemmas (in poly_mod_type) prime_elem_m_dvdm_multD = prime_elem_dvd_multD
  [where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_2) prime_elem_m_dvdm_multD = poly_mod_type.prime_elem_m_dvdm_multD
  [unfolded poly_mod_type_simps, internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas(in poly_mod_prime_type) degree_m_mult_eq = degree_mult_eq
  [where 'a = "'a mod_ring", untransferred]
lemmas(in poly_mod_prime) degree_m_mult_eq = poly_mod_prime_type.degree_m_mult_eq
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma(in poly_mod_prime) irreducible\<^sub>d_lifting:
  assumes n: "n \<noteq> 0"
    and deg: "poly_mod.degree_m (p^n) f = degree_m f"
    and irr: "irreducible\<^sub>d_m f"
  shows "poly_mod.irreducible\<^sub>d_m (p^n) f"
proof -
  interpret q: poly_mod_2 "p^n" unfolding poly_mod_2_def using n m1 by auto
  show "q.irreducible\<^sub>d_m f"
  proof (rule q.irreducible\<^sub>d_mI)
    from deg irr show "q.degree_m f > 0" by (auto elim: irreducible\<^sub>d_mE)
    then have pdeg_f: "degree_m f \<noteq> 0" by (simp add: deg)
    note pMp_Mp = Mp_Mp_pow_is_Mp[OF n m1]
    fix g h
    assume deg_g: "degree g < q.degree_m f" and deg_h: "degree h < q.degree_m f"
      and eq: "q.eq_m f (g * h)"
    from eq have p_f: "f =m (g * h)" using pMp_Mp by metis
    have "\<not>g =m 0" and "\<not>h =m 0"
      apply (metis degree_0 mult_zero_left Mp_0 p_f pdeg_f poly_mod.mult_Mp(1))
      by (metis degree_0 mult_eq_0_iff Mp_0 mult_Mp(2) p_f pdeg_f)
    note [simp] = degree_m_mult_eq[OF this]
    from degree_m_le[of g] deg_g
    have 2: "degree_m g < degree_m f" by (fold deg, auto)
    from degree_m_le[of h] deg_h
    have 3: "degree_m h < degree_m f" by (fold deg, auto)
    from irreducible\<^sub>d_mD(2)[OF irr 2 3] p_f
    show False by auto
  qed
qed

(* Lifting UFD properties *)
lemmas (in poly_mod_prime_type) mset_factors_exist =
  mset_factors_exist[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_exist = poly_mod_prime_type.mset_factors_exist
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) mset_factors_unique =
  mset_factors_unique[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_unique = poly_mod_prime_type.mset_factors_unique
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) prime_elem_iff_irreducible =
  prime_elem_iff_irreducible[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) prime_elem_iff_irreducible[simp] = poly_mod_prime_type.prime_elem_iff_irreducible
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) irreducible_connect =
  irreducible_connect_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_connect[simp] = poly_mod_prime_type.irreducible_connect
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) irreducible_degree =
  irreducible_degree_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_degree = poly_mod_prime_type.irreducible_degree
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

end