(*
    Title:      Mod_Type.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

section\<open>Class for modular arithmetic\<close>

theory Mod_Type
imports
  "HOL-Library.Numeral_Type"
  "HOL-Analysis.Cartesian_Euclidean_Space"
  Dual_Order
begin

subsection\<open>Definition and properties\<close>

text\<open>Class for modular arithmetic. It is inspired by the locale mod\_type.\<close>

class mod_type = times + wellorder + neg_numeral +
fixes Rep :: "'a => int"
  and Abs :: "int => 'a"
  assumes type: "type_definition Rep Abs {0..<int CARD ('a)}"
  and size1: "1 < int CARD ('a)"
  and zero_def: "0 = Abs 0"
  and one_def:  "1 = Abs 1"
  and add_def:  "x + y = Abs ((Rep x + Rep y) mod (int CARD ('a)))"
  and mult_def: "x * y = Abs ((Rep x * Rep y) mod (int CARD ('a)))"
  and diff_def: "x - y = Abs ((Rep x - Rep y) mod (int CARD ('a)))"
  and minus_def: "- x = Abs ((- Rep x) mod (int CARD ('a)))"
  and strict_mono_Rep: "strict_mono Rep"
begin

lemmas definitions =
  zero_def one_def add_def mult_def minus_def diff_def

lemma Rep_less_n: "Rep x < int CARD ('a)"
  by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])

lemma Rep_le_n: "Rep x \<le> int CARD ('a)"
  by (rule Rep_less_n [THEN order_less_imp_le])

lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
  by (rule type_definition.Rep_inject [OF type, symmetric])

lemma Rep_inverse: "Abs (Rep x) = x"
  by (rule type_definition.Rep_inverse [OF type])

lemma Abs_inverse: "m \<in> {0..<int CARD ('a)} \<Longrightarrow> Rep (Abs m) = m"
  by (rule type_definition.Abs_inverse [OF type])

lemma Rep_Abs_mod: "Rep (Abs (m mod int CARD ('a))) = m mod int CARD ('a)"
  by (simp add: Abs_inverse pos_mod_conj [OF size0])

lemma Rep_Abs_0: "Rep (Abs 0) = 0"
  apply (rule Abs_inverse [of 0])
  using size0 by simp

lemma Rep_0: "Rep 0 = 0"
  by (simp add: zero_def Rep_Abs_0)

lemma Rep_Abs_1: "Rep (Abs 1) = 1"
  by (simp add: Abs_inverse size1)

lemma Rep_1: "Rep 1 = 1"
  by (simp add: one_def Rep_Abs_1)

lemma Rep_mod: "Rep x mod int CARD ('a) = Rep x"
  apply (rule_tac x=x in type_definition.Abs_cases [OF type])
  apply (simp add: type_definition.Abs_inverse [OF type])
done

lemmas Rep_simps =
  Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1

subsection\<open>Conversion between a modular class and the subset of natural numbers associated.\<close>
text\<open>Definitions to make transformations among elements of a modular class and naturals\<close>
definition to_nat :: "'a => nat"
  where "to_nat = nat \<circ> Rep"

definition Abs' :: "int => 'a"
  where "Abs' x = Abs(x mod int CARD ('a))"

definition from_nat :: "nat \<Rightarrow> 'a"
  where "from_nat = (Abs' \<circ> int)"

lemma bij_Rep: "bij_betw (Rep) (UNIV::'a set) {0..<int CARD('a)}"
proof (unfold bij_betw_def, rule conjI)
  show "inj Rep" by (metis strict_mono_imp_inj_on strict_mono_Rep)
  show "range Rep = {0..<int CARD('a)}" using Typedef.type_definition.Rep_range[OF type] .
qed

lemma mono_Rep: "mono Rep" by (metis strict_mono_Rep strict_mono_mono)

lemma Rep_ge_0: "0 \<le> Rep x" using bij_Rep unfolding bij_betw_def by auto

lemma bij_Abs: "bij_betw (Abs) {0..<int CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  show "inj_on Abs {0..<int CARD('a)}" by (metis inj_on_inverseI type type_definition.Abs_inverse)
  show "Abs ` {0..<int CARD('a)} = (UNIV::'a set)" by (metis type type_definition.univ)
qed

corollary bij_Abs': "bij_betw (Abs') {0..<int CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  show "inj_on Abs' {0..<int CARD('a)}"
    unfolding inj_on_def Abs'_def
    by (auto, metis Rep_Abs_mod mod_pos_pos_trivial)
  show "Abs' ` {0..<int CARD('a)} = (UNIV::'a set)"
  proof (unfold image_def Abs'_def, auto)
    fix x show "\<exists>xa\<in>{0..<int CARD('a)}. x = Abs xa"
      by (rule bexI[of _ "Rep x"], auto simp add: Rep_less_n[of x] Rep_ge_0[of x], metis Rep_inverse)
  qed
qed

lemma bij_from_nat: "bij_betw (from_nat) {0..<CARD('a)} (UNIV::'a set)"
proof (unfold bij_betw_def, rule conjI)
  have set_eq: "{0::int..<int CARD('a)} = int` {0..<CARD('a)}" apply (auto)
  proof -
    fix x::int  assume x1: "(0::int) \<le> x" and x2: "x < int CARD('a)" show "x \<in> int ` {0::nat..<CARD('a)}"
    proof (unfold image_def, auto, rule bexI[of _ "nat x"])
      show " x = int (nat x)" using x1 by auto
      show "nat x \<in> {0::nat..<CARD('a)}" using x1 x2 by auto
    qed
  qed
  show "inj_on (from_nat::nat\<Rightarrow>'a) {0::nat..<CARD('a)}"
  proof (unfold from_nat_def , rule comp_inj_on)
    show "inj_on int {0::nat..<CARD('a)}" by (metis inj_of_nat subset_inj_on top_greatest)
    show "inj_on (Abs'::int=>'a) (int ` {0::nat..<CARD('a)})"
      using bij_Abs unfolding bij_betw_def set_eq
      by (metis (hide_lams, no_types) Abs'_def Abs_inverse Rep_inverse Rep_mod inj_on_def set_eq)
  qed
  show "(from_nat::nat=>'a)` {0::nat..<CARD('a)} = UNIV"
    unfolding from_nat_def using bij_Abs'
    unfolding bij_betw_def set_eq o_def by blast
qed

lemma to_nat_is_inv: "the_inv_into {0..<CARD('a)} (from_nat::nat=>'a) = (to_nat::'a=>nat)"
proof (unfold the_inv_into_def fun_eq_iff from_nat_def to_nat_def o_def, clarify)
  fix x::"'a" show "(THE y::nat. y \<in> {0::nat..<CARD('a)} \<and> Abs' (int y) = x) = nat (Rep x)"
  proof (rule the_equality, auto)
    show " Abs' (Rep x) = x" by (metis Abs'_def Rep_inverse Rep_mod)
    show "nat (Rep x) < CARD('a)" by (metis (full_types) Rep_less_n nat_int size0 zless_nat_conj)
    assume x:  "\<not> (0::int) \<le> Rep x" show "(0::nat) < CARD('a)" and "Abs' (0::int) = x"
      using Rep_ge_0 x by auto
  next
    fix y::nat assume y: "y < CARD('a)"
    have "(Rep(Abs'(int y)::'a)) = (Rep((Abs(int y mod int CARD('a)))::'a))" unfolding Abs'_def ..
    also have "... =  (Rep (Abs (int y)::'a))" using zmod_int[of y "CARD('a)"]
      using y mod_less by auto
    also have "... =  (int y)" proof (rule Abs_inverse) show "int y \<in> {0::int..<int CARD('a)}"
      using y by auto qed
    finally show "y = nat (Rep (Abs' (int y)::'a))" by (metis nat_int)
  qed
qed

lemma bij_to_nat: "bij_betw (to_nat) (UNIV::'a set) {0..<CARD('a)}"
  using bij_betw_the_inv_into[OF bij_from_nat] unfolding to_nat_is_inv .

lemma finite_mod_type: "finite (UNIV::'a set)"
  using finite_imageD[of "to_nat" "UNIV::'a set"] using bij_to_nat unfolding bij_betw_def by auto

subclass (in mod_type) finite by (intro_classes, rule finite_mod_type)

lemma least_0: "(LEAST n. n \<in> (UNIV::'a set)) = 0"
proof (rule Least_equality, auto)
  fix y::"'a"
  have "(0::'a) \<le> Abs (Rep y mod int CARD('a))" using strict_mono_Rep unfolding strict_mono_def
  by (metis (hide_lams, mono_tags) Rep_0 Rep_ge_0 strict_mono_Rep strict_mono_less_eq)
  also have "... = y" by (metis Rep_inverse Rep_mod)
  finally show "(0::'a) \<le> y" .
qed

lemma add_to_nat_def: "x + y = from_nat (to_nat x + to_nat y)"
  unfolding from_nat_def to_nat_def o_def using Rep_ge_0[of x] using Rep_ge_0[of y]
  using Rep_less_n[of x] Rep_less_n[of y]
  unfolding Abs'_def unfolding add_def[of x y] by auto

lemma to_nat_1: "to_nat 1 = 1"
  by (simp add: to_nat_def Rep_1)

lemma add_def':
  shows "x + y = Abs' (Rep x + Rep y)" unfolding Abs'_def using add_def by simp

lemma Abs'_0:
  shows "Abs' (CARD('a))=(0::'a)" by (metis (hide_lams, mono_tags) Abs'_def mod_self zero_def)

lemma Rep_plus_one_le_card:
  assumes a: "a + 1 \<noteq> 0"
  shows "(Rep a) + 1 < CARD ('a)"
proof (rule ccontr)
  assume "\<not> Rep a + 1 < CARD('a)" hence to_nat_eq_card: "Rep a + 1 = CARD('a)"
    using Rep_less_n
    by (simp add: add1_zle_eq order_class.less_le)
  have "a+1 = Abs' (Rep a + Rep (1::'a))" using add_def' by auto
  also have "... = Abs' ((Rep a) + 1)" using Rep_1 by simp
  also have "... = Abs' (CARD('a))" unfolding to_nat_eq_card ..
  also have "... = 0" using Abs'_0 by auto
  finally show False using a by contradiction
qed

lemma to_nat_plus_one_less_card: "\<forall>a. a+1 \<noteq> 0 --> to_nat a + 1 < CARD('a)"
proof (clarify)
fix a
assume a: "a + 1 \<noteq> 0"
have "Rep a + 1 < int CARD('a)" using Rep_plus_one_le_card[OF a] by auto
hence "nat (Rep a + 1) < nat (int CARD('a))" unfolding zless_nat_conj using size0 by fast
thus "to_nat a + 1 < CARD('a)" unfolding to_nat_def o_def using nat_add_distrib[OF Rep_ge_0] by simp
qed

corollary to_nat_plus_one_less_card':
assumes "a+1 \<noteq> 0"
shows "to_nat a + 1 < CARD('a)" using to_nat_plus_one_less_card assms by simp

lemma strict_mono_to_nat: "strict_mono to_nat"
  using strict_mono_Rep
  unfolding strict_mono_def to_nat_def using Rep_ge_0 by (metis comp_apply nat_less_eq_zless)

lemma to_nat_eq [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
  using injD [OF bij_betw_imp_inj_on[OF bij_to_nat]] by blast

lemma mod_type_forall_eq [simp]: "(\<forall>j::'a. (to_nat j)<CARD('a) \<longrightarrow> P j) = (\<forall>a. P a)"
proof (auto)
  fix a assume a: "\<forall>j. (to_nat::'a=>nat) j < CARD('a) \<longrightarrow> P j"
  have "(to_nat::'a=>nat) a < CARD('a)" using bij_to_nat unfolding bij_betw_def by auto
  thus "P a" using a by auto
qed

lemma to_nat_from_nat:
  assumes t:"to_nat j = k"
  shows "from_nat k = j"
proof -
  have "from_nat k = from_nat (to_nat j)"  unfolding t ..
  also have "... = from_nat (the_inv_into {0..<CARD('a)} (from_nat) j)" unfolding to_nat_is_inv ..
  also have "... = j"
  proof (rule f_the_inv_into_f)
    show "inj_on from_nat {0..<CARD('a)}" by (metis bij_betw_imp_inj_on bij_from_nat)
    show "j \<in> from_nat ` {0..<CARD('a)}" by (metis UNIV_I bij_betw_def bij_from_nat)
  qed
  finally show "from_nat k = j" .
qed

lemma to_nat_mono:
  assumes ab: "a < b"
  shows "to_nat a < to_nat b"
  using strict_mono_to_nat unfolding strict_mono_def using assms by fast

lemma to_nat_mono':
  assumes ab: "a \<le> b"
  shows "to_nat a \<le> to_nat b"
proof (cases "a=b")
  case True thus ?thesis by auto
next
  case False
  hence "a<b" using ab by simp
  thus ?thesis using to_nat_mono by fastforce
qed

lemma least_mod_type:
  shows "0 \<le> (n::'a)"
  using least_0 by (metis (full_types) Least_le UNIV_I)

lemma to_nat_from_nat_id:
  assumes x: "x<CARD('a)"
  shows "to_nat ((from_nat x)::'a) = x"
  unfolding to_nat_is_inv[symmetric] proof (rule the_inv_into_f_f)
  show "inj_on (from_nat::nat=>'a) {0..<CARD('a)}" using bij_from_nat unfolding bij_betw_def by auto
  show "x \<in> {0..<CARD('a)}" using x by simp
qed

lemma from_nat_to_nat_id[simp]:
  shows "from_nat (to_nat x) = x" by (metis to_nat_from_nat)

lemma from_nat_to_nat:
  assumes t:"from_nat j = k" and j: "j<CARD('a)"
  shows "to_nat k = j" by (metis j t to_nat_from_nat_id)

lemma from_nat_mono:
  assumes i_le_j: "i<j" and j: "j<CARD('a)"
  shows "(from_nat i::'a) < from_nat j"
proof -
have i: "i<CARD('a)" using i_le_j j by simp
obtain a where a: "i=to_nat a"
  using bij_to_nat unfolding bij_betw_def using i to_nat_from_nat_id by metis
obtain b where b: "j=to_nat b"
  using bij_to_nat unfolding bij_betw_def using j to_nat_from_nat_id by metis
show ?thesis by (metis a b from_nat_to_nat_id i_le_j strict_mono_less strict_mono_to_nat)
qed

lemma from_nat_mono':
  assumes i_le_j: "i \<le> j" and "j<CARD ('a)"
  shows "(from_nat i::'a) \<le> from_nat j"
proof (cases "i=j")
  case True
  have "(from_nat i::'a) = from_nat j" using True by simp
  thus ?thesis by simp
next
  case False
  hence "i<j" using i_le_j by simp
  thus ?thesis by (metis assms(2) from_nat_mono less_imp_le)
qed

lemma to_nat_suc:
  assumes "to_nat (x)+1 < CARD ('a)"
  shows "to_nat (x + 1::'a) = (to_nat x) + 1"
proof -
  have "(x::'a) + 1 = from_nat (to_nat x + to_nat (1::'a))" unfolding add_to_nat_def ..
  hence "to_nat ((x::'a) + 1) = to_nat (from_nat (to_nat x + to_nat (1::'a))::'a)" by presburger
  also have "... = to_nat (from_nat (to_nat x + 1)::'a)" unfolding to_nat_1 ..
  also have "... = (to_nat x + 1)" by (metis assms to_nat_from_nat_id)
  finally show ?thesis .
qed

lemma to_nat_le:
  assumes "y < from_nat k"
  shows  "to_nat y < k"
proof (cases "k<CARD('a)")
  case True show ?thesis by (metis (full_types) True assms to_nat_from_nat_id to_nat_mono)
next
  case False have "to_nat y < CARD ('a)" using bij_to_nat unfolding bij_betw_def by auto
  thus ?thesis using False by auto
qed

lemma le_Suc:
  assumes ab: "a < (b::'a)"
  shows "a + 1 \<le> b"
proof -
  have "a + 1 = (from_nat (to_nat (a + 1))::'a)" using from_nat_to_nat_id [of "a+1",symmetric] .
  also have "... \<le> (from_nat (to_nat (b::'a))::'a)"
  proof (rule from_nat_mono')
    have "to_nat a < to_nat b" using ab by (metis to_nat_mono)
    hence "to_nat a + 1 \<le> to_nat b" by simp
    thus "to_nat b < CARD ('a)" using bij_to_nat unfolding  bij_betw_def by auto
    hence "to_nat a + 1 < CARD ('a)" by (metis \<open>to_nat a + 1 \<le> to_nat b\<close> preorder_class.le_less_trans)
    thus "to_nat (a + 1) \<le> to_nat b" by (metis \<open>to_nat a + 1 \<le> to_nat b\<close> to_nat_suc)
  qed
  also have "... = b" by (metis from_nat_to_nat_id)
  finally show "a + (1::'a) \<le> b" .
qed

lemma le_Suc':
assumes ab: "a + 1 \<le> b"
  and less_card: "(to_nat a) + 1 < CARD ('a)"
  shows "a < b"
proof -
  have "a = (from_nat (to_nat a)::'a)" using from_nat_to_nat_id [of "a",symmetric] .
  also have "... < (from_nat (to_nat b)::'a)"
  proof (rule from_nat_mono)
    show "to_nat b < CARD('a)" using bij_to_nat unfolding  bij_betw_def by auto
    have "to_nat (a + 1) \<le>  to_nat b" using ab by (metis to_nat_mono')
    hence "to_nat (a) + 1 \<le>  to_nat b"  using to_nat_suc[OF less_card] by auto
    thus "to_nat a < to_nat b" by simp
  qed
  finally show "a < b" by (metis to_nat_from_nat)
qed

lemma Suc_le:
  assumes less_card: "(to_nat a) + 1 < CARD ('a)"
  shows "a < a + 1"
proof -
  have "(to_nat a) < (to_nat a) + 1" by simp
  hence "(to_nat a) < to_nat (a + 1)" by (metis less_card to_nat_suc)
  hence "(from_nat (to_nat a)::'a) < from_nat (to_nat (a + 1))"
    by (rule from_nat_mono, metis less_card to_nat_suc)
  thus "a < a + 1" by (metis to_nat_from_nat)
qed

lemma Suc_le':
  fixes a::'a
  assumes "a + 1 \<noteq> 0"
  shows "a < a + 1" using Suc_le to_nat_plus_one_less_card assms by blast

lemma from_nat_not_eq:
  assumes a_eq_to_nat: "a \<noteq> to_nat b"
  and a_less_card: "a<CARD('a)"
  shows "from_nat a \<noteq> b"
proof (rule ccontr)
  assume "\<not> from_nat a \<noteq> b" hence "from_nat a = b" by simp
  hence "to_nat ((from_nat a)::'a) = to_nat b" by auto
  thus False by (metis a_eq_to_nat a_less_card to_nat_from_nat_id)
qed

lemma Suc_less:
  fixes i::'a
  assumes "i<j"
  and "i+1 \<noteq> j"
  shows "i+1<j" by (metis assms le_Suc le_neq_trans)

lemma Greatest_is_minus_1: "\<forall>a::'a. a \<le> -1"
proof (clarify)
  fix a::'a
  have zero_ge_card_1: "0 \<le> int CARD('a) - 1" using size1 by auto
  have card_less: "int CARD('a) - 1 < int CARD('a)" by auto
  have not_zero: "1 mod int CARD('a) \<noteq> 0"
    by (metis (hide_lams, mono_tags) Rep_Abs_1 Rep_mod zero_neq_one)
  have int_card: "int (CARD('a) - 1) = int CARD('a) - 1" using of_nat_diff[of 1 "CARD ('a)"]
    using size1 by simp
  have "a = Abs' (Rep a)" by (metis (hide_lams, mono_tags) Rep_0 add_0_right add_def'
      monoid_add_class.add.right_neutral)
  also have "... = Abs' (int (nat (Rep a)))" by (metis Rep_ge_0 int_nat_eq)
  also have "...  \<le> Abs' (int (CARD('a) - 1))"
  proof (rule from_nat_mono'[unfolded from_nat_def o_def, of "nat (Rep a)" "CARD('a) - 1"])
    show "nat (Rep a) \<le> CARD('a) - 1" using Rep_less_n
      using int_card nat_le_iff by auto
    show "CARD('a) - 1 < CARD('a)" using finite_UNIV_card_ge_0 finite_mod_type by fastforce
  qed
  also have "... = - 1"
  unfolding Abs'_def unfolding minus_def zmod_zminus1_eq_if unfolding Rep_1
  apply (rule cong [of Abs], rule refl)
  unfolding if_not_P [OF not_zero]
  unfolding int_card
  unfolding mod_pos_pos_trivial[OF zero_ge_card_1 card_less]
  using mod_pos_pos_trivial[OF _ size1] by presburger
  finally show "a \<le> -1" by fastforce
qed

lemma a_eq_minus_1: "\<forall>a::'a. a+1 = 0 \<longrightarrow> a = -1"
  by (metis eq_neg_iff_add_eq_0)

lemma forall_from_nat_rw:
  shows "(\<forall>x\<in>{0..<CARD('a)}. P (from_nat x::'a)) = (\<forall>x. P (from_nat x))"
proof (auto)
  fix y assume *: "\<forall>x\<in>{0..<CARD('a)}. P (from_nat x)"
  have "from_nat y \<in> (UNIV::'a set)" by auto
  from this obtain x where x1: "from_nat y = (from_nat x::'a)" and x2: "x\<in>{0..<CARD('a)}"
    using bij_from_nat unfolding bij_betw_def
    by (metis from_nat_to_nat_id rangeI the_inv_into_onto to_nat_is_inv)
  show "P (from_nat y::'a)" unfolding x1 using * x2 by simp
qed

lemma from_nat_eq_imp_eq:
  assumes f_eq: "from_nat x = (from_nat xa::'a)"
and x: "x<CARD('a)" and xa: "xa<CARD('a)"
  shows "x=xa" using assms from_nat_not_eq by metis

lemma to_nat_less_card:
  fixes j::"'a"
  shows "to_nat j < CARD ('a)"
  using bij_to_nat unfolding bij_betw_def by auto

lemma from_nat_0: "from_nat 0 = 0"
  unfolding from_nat_def o_def of_nat_0 Abs'_def mod_0 zero_def ..
lemma to_nat_0: "to_nat 0 = 0" unfolding to_nat_def o_def Rep_0 nat_0 ..
lemma to_nat_eq_0: "(to_nat x = 0) = (x = 0)" using to_nat_0 to_nat_from_nat by auto

lemma suc_not_zero:
  assumes "to_nat a + 1 \<noteq> CARD('a)"
  shows "a+1 \<noteq> 0"
proof (rule ccontr, simp)
  assume a_plus_one_zero: "a + 1 = 0"
  hence rep_eq_card: "Rep a + 1 = CARD('a)"
    using assms to_nat_0 Suc_eq_plus1 Suc_lessI Zero_not_Suc to_nat_less_card to_nat_suc
    by (metis (hide_lams, mono_tags))
  moreover have "Rep a + 1 < CARD('a)"
    using Abs'_0 Rep_1 Suc_eq_plus1 Suc_lessI Suc_neq_Zero add_def' assms
    rep_eq_card to_nat_0 to_nat_less_card to_nat_suc by (metis (hide_lams, mono_tags))
  ultimately show False by fastforce
qed

lemma from_nat_suc:
shows "from_nat (j + 1) = from_nat j + 1"
unfolding from_nat_def o_def Abs'_def add_def' Rep_1 Rep_Abs_mod
unfolding of_nat_add apply (subst mod_add_left_eq) unfolding of_nat_1 ..

lemma to_nat_plus_1_set:
shows "to_nat a + 1 \<in> {1..<CARD('a)+1}"
using to_nat_less_card by simp

end

lemma from_nat_CARD:
  shows "from_nat (CARD('a)) = (0::'a::{mod_type})"
  unfolding from_nat_def o_def Abs'_def by (simp add: zero_def)

subsection\<open>Instantiations\<close>

instantiation bit0 and bit1:: (finite) mod_type
begin

definition "(Rep::'a bit0 => int)  x = Rep_bit0 x"
definition "(Abs::int => 'a bit0) x = Abs_bit0' x"

definition "(Rep::'a bit1 => int)  x = Rep_bit1 x"
definition "(Abs::int => 'a bit1) x = Abs_bit1' x"

instance
proof
  show "(0::'a bit0) = Abs (0::int)" unfolding Abs_bit0_def Abs_bit0'_def zero_bit0_def by auto
  show "(1::int) < int CARD('a bit0)" by (metis bit0.size1)
  show "type_definition (Rep::'a bit0 => int) (Abs:: int => 'a bit0) {0::int..<int CARD('a bit0)}"
  proof (unfold type_definition_def Rep_bit0_def [abs_def]
      Abs_bit0_def [abs_def] Abs_bit0'_def, intro conjI)
    show "\<forall>x::'a bit0. Rep_bit0 x \<in> {0::int..<int CARD('a bit0)}"
      unfolding card_bit0 unfolding of_nat_mult
      using Rep_bit0 [where ?'a = "'a"] by simp
    show "\<forall>x::'a bit0. Abs_bit0 (Rep_bit0 x mod int CARD('a bit0)) = x"
      by (metis Rep_bit0_inverse bit0.Rep_mod)
    show "\<forall>y::int. y \<in> {0::int..<int CARD('a bit0)}
      \<longrightarrow> Rep_bit0 ((Abs_bit0::int => 'a bit0) (y mod int CARD('a bit0))) = y"
      by (metis bit0.Abs_inverse bit0.Rep_mod)
  qed
  show "(1::'a bit0) = Abs (1::int)" unfolding Abs_bit0_def Abs_bit0'_def one_bit0_def
    by (metis bit0.of_nat_eq of_nat_1 one_bit0_def)
  fix x y :: "'a bit0"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def plus_bit0_def Abs_bit0'_def by fastforce
  show "x * y = Abs (Rep x * Rep y mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def times_bit0_def Abs_bit0'_def by fastforce
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def minus_bit0_def Abs_bit0'_def by fastforce
  show "- x = Abs (- Rep x mod int CARD('a bit0))"
    unfolding Abs_bit0_def Rep_bit0_def uminus_bit0_def Abs_bit0'_def by fastforce
  show "(0::'a bit1) = Abs (0::int)" unfolding Abs_bit1_def Abs_bit1'_def zero_bit1_def by auto
  show "(1::int) < int CARD('a bit1)" by (metis bit1.size1)
  show "(1::'a bit1) = Abs (1::int)" unfolding Abs_bit1_def Abs_bit1'_def one_bit1_def
    by (metis bit1.of_nat_eq of_nat_1 one_bit1_def)
  fix x y :: "'a bit1"
  show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit1))"
    unfolding Abs_bit1_def Abs_bit1'_def Rep_bit1_def plus_bit1_def by fastforce
  show "x * y = Abs (Rep x * Rep y mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def times_bit1_def Abs_bit1'_def by fastforce
  show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def minus_bit1_def Abs_bit1'_def by fastforce
  show "- x = Abs (- Rep x mod int CARD('a bit1))"
    unfolding Abs_bit1_def Rep_bit1_def uminus_bit1_def Abs_bit1'_def by fastforce
  show "type_definition (Rep::'a bit1 => int) (Abs:: int => 'a bit1) {0::int..<int CARD('a bit1)}"
  proof (unfold type_definition_def Rep_bit1_def [abs_def]
      Abs_bit1_def [abs_def] Abs_bit1'_def, intro conjI)
    have int_2: "int 2 = 2" by auto
   show "\<forall>x::'a bit1. Rep_bit1 x \<in> {0::int..<int CARD('a bit1)}"
      unfolding card_bit1
      unfolding of_nat_Suc of_nat_mult
      using Rep_bit1 [where ?'a = "'a"]
      unfolding int_2 ..
   show "\<forall>x::'a bit1. Abs_bit1 (Rep_bit1 x mod int CARD('a bit1)) = x"
      by (metis Rep_bit1_inverse bit1.Rep_mod)
   show "\<forall>y::int. y \<in> {0::int..<int CARD('a bit1)}
    \<longrightarrow> Rep_bit1 ((Abs_bit1::int => 'a bit1) (y mod int CARD('a bit1))) = y"
   by (metis bit1.Abs_inverse bit1.Rep_mod)
  qed
  show "strict_mono (Rep::'a bit0 => int)" unfolding strict_mono_def
    by (metis Rep_bit0_def less_bit0_def)
  show "strict_mono (Rep::'a bit1 => int)" unfolding strict_mono_def
    by (metis Rep_bit1_def less_bit1_def)
qed
end

end


theory T83
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(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, 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. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(*
  File:    Liouville_Numbers.thy
  Author:  Manuel Eberl <eberlm@in.tum.de>

  The definition of Liouville numbers and their standard construction, plus the proof
  that any Liouville number is transcendental.
*)

theory Liouville_Numbers
imports
  Complex_Main
  "HOL-Computational_Algebra.Polynomial"
  Liouville_Numbers_Misc
begin

(*
  TODO: Move definition of algebraic numbers out of Algebraic_Numbers to reduce unnecessary
  dependencies.
*)

text \<open>
A Liouville number is a real number that can be approximated well -- but not perfectly --
by a sequence of rational numbers. ``Well``, in this context, means that the error of the
 $n$-th rational in the sequence is bounded by the $n$-th power of its denominator.

Our approach will be the following:
\begin{itemize}
\item Liouville numbers cannot be rational.
\item Any irrational algebraic number cannot be approximated in the Liouville sense
\item Therefore, all Liouville numbers are transcendental.
\item The standard construction fulfils all the properties of Liouville numbers.
\end{itemize}
\<close>

subsection \<open>Definition of Liouville numbers\<close>

text \<open>
  The following definitions and proofs are largely adapted from those in the Wikipedia
  article on Liouville numbers.~\cite{wikipedia}
\<close>

text \<open>
  A Liouville number is a real number that can be approximated well -- but not perfectly --
  by a sequence of rational numbers. The error of the $n$-th term $\frac{p_n}{q_n}$ is at most
  $q_n^{-n}$, where $p_n\in\isasymint$ and $q_n \in\isasymint_{\geq 2}$.

  We will say that such a number can be approximated in the Liouville sense.
\<close>
locale liouville =
  fixes x :: real and p q :: "nat \<Rightarrow> int"
  assumes approx_int_pos: "abs (x - p n / q n) > 0"
      and denom_gt_1:     "q n > 1"
      and approx_int:     "abs (x - p n / q n) < 1 / of_int (q n) ^ n"

text \<open>
  First, we show that any Liouville number is irrational.
\<close>
lemma (in liouville) irrational: "x \<notin> \<rat>"
proof
  assume "x \<in> \<rat>"
  then obtain c d :: int where d: "x = of_int c / of_int d" "d > 0"
    by (elim Rats_cases') simp
  define n where "n = Suc (nat \<lceil>log 2 d\<rceil>)"
  note q_gt_1 = denom_gt_1[of n]

  have neq: "c * q n \<noteq> d * p n"
  proof
    assume "c * q n = d * p n"
    hence "of_int (c * q n) = of_int (d * p n)" by (simp only: )
    with approx_int_pos[of n] d q_gt_1 show False by (auto simp: field_simps)
  qed
  hence abs_pos: "0 < abs (c * q n - d * p n)" by simp

  from q_gt_1 d have "of_int d = 2 powr log 2 d" by (subst powr_log_cancel) simp_all
  also from d have "log 2 (of_int d) \<ge> log 2 1" by (subst log_le_cancel_iff) simp_all
  hence "2 powr log 2 d \<le> 2 powr of_nat (nat \<lceil>log 2 d\<rceil>)"
    by (intro powr_mono) simp_all
  also have "\<dots> = of_int (2 ^ nat \<lceil>log 2 d\<rceil>)"
    by (subst powr_realpow) simp_all
  finally have "d \<le> 2 ^ nat \<lceil>log 2 (of_int d)\<rceil>"
    by (subst (asm) of_int_le_iff)
  also have "\<dots> * q n \<le> q n ^ Suc (nat \<lceil>log 2 (of_int d)\<rceil>)"
    by (subst power_Suc, subst mult.commute, intro mult_left_mono power_mono,
        insert q_gt_1) simp_all
  also from q_gt_1 have "\<dots> = q n ^ n" by (simp add: n_def)
  finally have "1 / of_int (q n ^ n) \<le> 1 / real_of_int (d * q n)" using q_gt_1 d
    by (intro divide_left_mono Rings.mult_pos_pos of_int_pos, subst of_int_le_iff) simp_all
  also have "\<dots> \<le> of_int (abs (c * q n - d * p n)) / real_of_int (d * q n)" using q_gt_1 d abs_pos
    by (intro divide_right_mono) (linarith, simp)
  also have "\<dots> = abs (x - of_int (p n) / of_int (q n))" using q_gt_1 d(2)
    by (simp_all add: divide_simps d(1) mult_ac)
  finally show False using approx_int[of n] by simp
qed

text \<open>
  Next, any irrational algebraic number cannot be approximated with rational
  numbers in the Liouville sense.
\<close>
lemma liouville_irrational_algebraic:
  fixes x :: real
  assumes irrationsl: "x \<notin> \<rat>" and "algebraic x"
  obtains c :: real and n :: nat
    where "c > 0" and "\<And>(p::int) (q::int). q > 0 \<Longrightarrow> abs (x - p / q) > c / of_int q ^ n"
proof -
  from \<open>algebraic x\<close> guess p by (elim algebraicE) note p = this
  define n where "n = degree p"

  \<comment> \<open>The derivative of @{term p} is bounded within @{term "{x-1..x+1}"}.\<close>
  let ?f = "\<lambda>t. \<bar>poly (pderiv p) t\<bar>"
  define M where "M = (SUP t\<in>{x-1..x+1}. ?f t)"
  define roots where "roots = {x. poly p x = 0} - {x}"

  define A_set where "A_set = {1, 1/M} \<union> {abs (x' - x) |x'. x' \<in> roots}"
  define A' where "A' = Min A_set"
  define A  where "A = A' / 2"
  \<comment> \<open>We define @{term A} to be a positive real number that is less than @{term 1},
      @{term "1/M"} and any distance from @{term x} to another root of @{term p}.\<close>

  \<comment> \<open>Properties of @{term M}, our upper bound for the derivative of @{term p}:\<close>
  have "\<exists>s\<in>{x-1..x+1}. \<forall>y\<in>{x-1..x+1}. ?f s \<ge> ?f y"
    by (intro continuous_attains_sup) (auto intro!: continuous_intros)
  hence bdd: "bdd_above (?f ` {x-1..x+1})" by auto

  have M_pos: "M > 0"
  proof -
    from p have "pderiv p \<noteq> 0" by (auto dest!: pderiv_iszero)
    hence "finite {x. poly (pderiv p) x = 0}" using poly_roots_finite by blast
    moreover have "\<not>finite {x-1..x+1}" by (simp add: infinite_Icc)
    ultimately have "\<not>finite ({x-1..x+1} - {x. poly (pderiv p) x = 0})" by simp
    hence "{x-1..x+1} - {x. poly (pderiv p) x = 0} \<noteq> {}" by (intro notI) simp
    then obtain t where t: "t \<in> {x-1..x+1}" and "poly (pderiv p) t \<noteq> 0" by blast
    hence "0 < ?f t" by simp
    also from t and bdd have "\<dots> \<le> M" unfolding M_def by (rule cSUP_upper)
    finally show "M > 0" .
  qed

  have M_sup: "?f t \<le> M" if "t \<in> {x-1..x+1}" for t
  proof -
    from that and bdd show "?f t \<le> M"
      unfolding M_def by (rule cSUP_upper)
  qed

  \<comment> \<open>Properties of @{term A}:\<close>
  from p poly_roots_finite[of p] have "finite A_set"
    unfolding A_set_def roots_def by simp
  have "x \<notin> roots" unfolding roots_def by auto
  hence "A' > 0" using Min_gr_iff[OF \<open>finite A_set\<close>, folded A'_def, of 0]
    by (auto simp: A_set_def M_pos)
  hence A_pos: "A > 0" by (simp add: A_def)

  from \<open>A' > 0\<close> have "A < A'" by (simp add: A_def)
  moreover from Min_le[OF \<open>finite A_set\<close>, folded A'_def]
    have "A' \<le> 1" "A' \<le> 1/M" "\<And>x'. x' \<noteq> x \<Longrightarrow> poly p x' = 0 \<Longrightarrow> A' \<le> abs (x' - x)"
    unfolding A_set_def roots_def by auto
  ultimately have A_less: "A < 1" "A < 1/M" "\<And>x'. x' \<noteq> x \<Longrightarrow> poly p x' = 0 \<Longrightarrow> A < abs (x' - x)"
    by fastforce+

  \<comment> \<open>Finally: no rational number can approximate @{term x} ``well enough''.\<close>
  have "\<forall>(a::int) (b :: int). b > 0 \<longrightarrow> \<bar>x - of_int a / of_int b\<bar> > A / of_int b ^ n"
  proof (intro allI impI, rule ccontr)
    fix a b :: int
    assume b: "b > 0" and "\<not>(A / of_int b ^ n < \<bar>x - of_int a / of_int b\<bar>)"
    hence ab: "abs (x - of_int a / of_int b) \<le> A / of_int b ^ n" by simp
    also from A_pos b have "A / of_int b ^ n \<le> A / 1"
      by (intro divide_left_mono) simp_all
    finally have ab': "abs (x - a / b) \<le> A" by simp
    also have "\<dots> \<le> 1" using A_less by simp
    finally have ab'': "a / b \<in> {x-1..x+1}" by auto

    have no_root: "poly p (a / b) \<noteq> 0"
    proof
      assume "poly p (a / b) = 0"
      moreover from \<open>x \<notin> \<rat>\<close> have "x \<noteq> a / b" by auto
      ultimately have "A < abs (a / b - x)" using A_less(3) by simp
      with ab' show False by simp
    qed

    have "\<exists>x0\<in>{x-1..x+1}. poly p (a / b) - poly p x = (a / b - x) * poly (pderiv p) x0"
      using ab'' by (intro poly_MVT') (auto simp: min_def max_def)
    with p obtain x0 :: real where x0:
        "x0 \<in> {x-1..x+1}" "poly p (a / b) = (a / b - x) * poly (pderiv p) x0" by auto

    from x0(2) no_root have deriv_pos: "poly (pderiv p) x0 \<noteq> 0" by auto

    from b p no_root have p_ab: "abs (poly p (a / b)) \<ge> 1 / of_int b ^ n"
      unfolding n_def by (intro int_poly_rat_no_root_ge)

    note ab
    also from A_less b have "A / of_int b ^ n < (1/M) / of_int b ^ n"
      by (intro divide_strict_right_mono) simp_all
    also have "\<dots> = (1 / b ^ n) / M" by simp
    also from M_pos ab p_ab have "\<dots> \<le> abs (poly p (a / b)) / M"
      by (intro divide_right_mono) simp_all
    also from deriv_pos M_pos x0(1)
      have "\<dots> \<le> abs (poly p (a / b)) / abs (poly (pderiv p) x0)"
      by (intro divide_left_mono M_sup) simp_all
    also have "\<bar>poly p (a / b)\<bar> = \<bar>a / b - x\<bar> * \<bar>poly (pderiv p) x0\<bar>"
      by (subst x0(2)) (simp add: abs_mult)
    with deriv_pos have "\<bar>poly p (a / b)\<bar> / \<bar>poly (pderiv p) x0\<bar> = \<bar>x - a / b\<bar>"
      by (subst nonzero_divide_eq_eq) simp_all
    finally show False by simp
  qed
  with A_pos show ?thesis using that[of A n] by blast
qed

text \<open>
  Since Liouville numbers are irrational, but can be approximated well by rational
  numbers in the Liouville sense, they must be transcendental.
\<close>
lemma (in liouville) transcendental: "\<not>algebraic x"
proof
  assume "algebraic x"
  from liouville_irrational_algebraic[OF irrational this] guess c n . note cn = this

  define r where "r = nat \<lceil>log 2 (1 / c)\<rceil>"
  define m where "m = n + r"
  from cn(1) have "(1/c) = 2 powr log 2 (1/c)" by (subst powr_log_cancel) simp_all
  also have "log 2 (1/c) \<le> of_nat (nat \<lceil>log 2 (1/c)\<rceil>)" by linarith
  hence "2 powr log 2 (1/c) \<le> 2 powr \<dots>" by (intro powr_mono) simp_all
  also have "\<dots> = 2 ^ r" unfolding r_def by (simp add: powr_realpow)
  finally have "1 / (2^r) \<le> c" using cn(1) by (simp add: field_simps)

  have "abs (x - p m / q m) < 1 / of_int (q m) ^ m" by (rule approx_int)
  also have "\<dots> = (1 / of_int (q m) ^ r) * (1 / real_of_int (q m) ^ n)"
    by (simp add: m_def power_add)
  also from denom_gt_1[of m] have "1 / real_of_int (q m) ^ r \<le> 1 / 2 ^ r"
    by (intro divide_left_mono power_mono) simp_all
  also have "\<dots> \<le> c" by fact
  finally have "abs (x - p m / q m) < c / of_int (q m) ^ n"
    using denom_gt_1[of m] by - (simp_all add: divide_right_mono)
  with cn(2)[of "q m" "p m"] denom_gt_1[of m] show False by simp
qed

subsection \<open>Standard construction for Liouville numbers\<close>

text \<open>
  We now define the standard construction for Liouville numbers.
\<close>
definition standard_liouville :: "(nat \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> real" where
  "standard_liouville p q = (\<Sum>k. p k / of_int q ^ fact (Suc k))"

lemma standard_liouville_summable:
  fixes p :: "nat \<Rightarrow> int" and q :: int
  assumes "q > 1" "range p \<subseteq> {0..<q}"
  shows   "summable (\<lambda>k. p k / of_int q ^ fact (Suc k))"
proof (rule summable_comparison_test')
  from assms(1) show "summable (\<lambda>n. (1 / q) ^ n)"
    by (intro summable_geometric) simp_all
next
  fix n :: nat
  from assms have "p n \<in> {0..<q}" by blast
  with assms(1) have "norm (p n / of_int q ^ fact (Suc n)) \<le>
                        q / of_int q ^ (fact (Suc n))" by (auto simp: field_simps)
  also from assms(1) have "\<dots> = 1 / of_int q ^ (fact (Suc n) - 1)"
    by (subst power_diff) (auto simp del: fact_Suc)
  also have "Suc n \<le> fact (Suc n)" by (rule fact_ge_self)
  with assms(1) have "1 / real_of_int q ^ (fact (Suc n) - 1) \<le> 1 / of_int q ^ n"
    by (intro divide_left_mono power_increasing)
       (auto simp del: fact_Suc simp add: algebra_simps)
  finally show "norm (p n / of_int q ^ fact (Suc n)) \<le> (1 / q) ^ n"
    by (simp add: power_divide)
qed

lemma standard_liouville_sums:
  assumes "q > 1" "range p \<subseteq> {0..<q}"
  shows   "(\<lambda>k. p k / of_int q ^ fact (Suc k)) sums standard_liouville p q"
  using standard_liouville_summable[OF assms] unfolding standard_liouville_def
  by (simp add: summable_sums)

text \<open>
  Now we prove that the standard construction indeed yields Liouville numbers.
\<close>
lemma standard_liouville_is_liouville:
  assumes "q > 1" "range p \<subseteq> {0..<q}" "frequently (\<lambda>n. p n \<noteq> 0) sequentially"
  defines "b \<equiv> \<lambda>n. q ^ fact (Suc n)"
  defines "a \<equiv> \<lambda>n. (\<Sum>k\<le>n. p k * q ^ (fact (Suc n) - fact (Suc k)))"
  shows   "liouville (standard_liouville p q) a b"
proof
  fix n :: nat
  from assms(1) have "1 < q ^ 1" by simp
  also from assms(1) have "\<dots> \<le> b n" unfolding b_def
    by (intro power_increasing) (simp_all del: fact_Suc)
  finally show "b n > 1" .

  note summable = standard_liouville_summable[OF assms(1,2)]
  let ?S = "\<Sum>k. p (k + n + 1) / of_int q ^ (fact (Suc (k + n + 1)))"
  let ?C = "(q - 1) / of_int q ^ (fact (n+2))"

  have "a n / b n = (\<Sum>k\<le>n. p k * (of_int q ^ (fact (n+1) - fact (k+1)) / of_int q ^ (fact (n+1))))"
    by (simp add: a_def b_def sum_divide_distrib of_int_sum)
  also have "\<dots> = (\<Sum>k\<le>n. p k / of_int q ^ (fact (Suc k)))"
    by (intro sum.cong refl, subst inverse_divide [symmetric], subst power_diff [symmetric])
       (insert assms(1), simp_all add: divide_simps fact_mono_nat del: fact_Suc)
  also have "standard_liouville p q - \<dots> = ?S" unfolding standard_liouville_def
    by (subst diff_eq_eq) (intro suminf_split_initial_segment' summable)
  finally have "abs (standard_liouville p q - a n / b n) = abs ?S" by (simp only: )
  moreover from assms have "?S \<ge> 0"
    by (intro suminf_nonneg allI divide_nonneg_pos summable_ignore_initial_segment summable) force+
  ultimately have eq: "abs (standard_liouville p q - a n / b n) = ?S" by simp

  also have "?S \<le> (\<Sum>k. ?C * (1 / q) ^ k)"
  proof (intro suminf_le allI summable_ignore_initial_segment summable)
    from assms show "summable (\<lambda>k. ?C * (1 / q) ^ k)"
      by (intro summable_mult summable_geometric) simp_all
  next
    fix k :: nat
    from assms have "p (k + n + 1) \<le> q - 1" by force
    with \<open>q > 1\<close> have "p (k + n + 1) / of_int q ^ fact (Suc (k + n + 1)) \<le>
                         (q - 1) / of_int q ^ (fact (Suc (k + n + 1)))"
      by (intro divide_right_mono) (simp_all del: fact_Suc)
    also from \<open>q > 1\<close> have "\<dots> \<le> (q - 1) / of_int q ^ (fact (n+2) + k)"
      using fact_ineq[of "n+2" k]
      by (intro divide_left_mono power_increasing) (simp_all add: add_ac)
    also have "\<dots> = ?C * (1 / q) ^ k"
      by (simp add: field_simps power_add del: fact_Suc)
    finally show "p (k + n + 1) / of_int q ^ fact (Suc (k + n + 1)) \<le> \<dots>" .
  qed
  also from assms have "\<dots> = ?C * (\<Sum>k. (1 / q) ^ k)"
    by (intro suminf_mult summable_geometric) simp_all
  also from assms have "(\<Sum>k. (1 / q) ^ k) = 1 / (1 - 1 / q)"
    by (intro suminf_geometric) simp_all
  also from assms(1) have "?C * \<dots> = of_int q ^ 1 / of_int q ^ fact (n + 2)"
    by (simp add: field_simps)
  also from assms(1) have "\<dots> \<le> of_int q ^ fact (n + 1) / of_int q ^ fact (n + 2)"
    by (intro divide_right_mono power_increasing) (simp_all add: field_simps del: fact_Suc)
  also from assms(1) have "\<dots> = 1 / (of_int q ^ (fact (n + 2) - fact (n + 1)))"
    by (subst power_diff) simp_all
  also have "fact (n + 2) - fact (n + 1) = (n + 1) * fact (n + 1)" by (simp add: algebra_simps)
  also from assms(1) have "1 / (of_int q ^ \<dots>) < 1 / (real_of_int q ^ (fact (n + 1) * n))"
    by (intro divide_strict_left_mono power_increasing mult_right_mono) simp_all
  also have "\<dots> = 1 / of_int (b n) ^ n"
    by (simp add: power_mult b_def power_divide del: fact_Suc)
  finally show "\<bar>standard_liouville p q - a n / b n\<bar> < 1 / of_int (b n) ^ n" .

  from assms(3) obtain k where k: "k \<ge> n + 1" "p k \<noteq> 0"
    by (auto simp: frequently_def eventually_at_top_linorder)
  define k' where "k' = k - n - 1"
  from assms k have "p k \<ge> 0" by force
  with k assms have k': "p (k' + n + 1) > 0" unfolding k'_def by force
  with assms(1,2) have "?S > 0"
    by (intro suminf_pos2[of _ k'] summable_ignore_initial_segment summable)
       (force intro!: divide_pos_pos divide_nonneg_pos)+
  with eq show "\<bar>standard_liouville p q - a n / b n\<bar> > 0" by (simp only: )
qed

text \<open>
  We can now show our main result: any standard Liouville number is transcendental.
\<close>
theorem transcendental_standard_liouville:
  assumes "q > 1" "range p \<subseteq> {0..<q}" "frequently (\<lambda>k. p k \<noteq> 0) sequentially"
  shows   "\<not>algebraic (standard_liouville p q)"
proof -
  from assms interpret
    liouville "standard_liouville p q"
              "\<lambda>n. (\<Sum>k\<le>n. p k * q ^ (fact (Suc n) - fact (Suc k)))"
              "\<lambda>n. q ^ fact (Suc n)"
    by (rule standard_liouville_is_liouville)
  from transcendental show ?thesis .
qed

text \<open>
  In particular: The the standard construction for constant sequences, such as the
  ``classic'' Liouville constant $\sum_{n=1}^\infty 10^{-n!} = 0.11000100\ldots$,
  are transcendental.

  This shows that Liouville numbers exists and therefore gives a concrete and
  elementary proof that transcendental numbers exist.
\<close>
corollary transcendental_standard_standard_liouville:
  "a \<in> {0<..<b} \<Longrightarrow> \<not>algebraic (standard_liouville (\<lambda>_. int a) (int b))"
  by (intro transcendental_standard_liouville) auto

corollary transcendental_liouville_constant:
  "\<not>algebraic (standard_liouville (\<lambda>_. 1) 10)"
  by (intro transcendental_standard_liouville) auto

end


(* Title: Examples/Vector_Spaces/VS_Modules.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Modules\<close>
theory VS_Modules
  imports
    VS_Groups
    Complex_Main
begin

subsection\<open>\<^text>\<open>module_with\<close>\<close>

locale module_with = ab_group_add plus\<^sub>M zero\<^sub>M minus\<^sub>M uminus\<^sub>M
  for plus\<^sub>M :: "['m, 'm] \<Rightarrow> 'm" (infixl \<open>+\<^sub>M\<close> 65)
    and zero\<^sub>M (\<open>0\<^sub>M\<close>)
    and minus\<^sub>M (infixl \<open>-\<^sub>M\<close> 65)
    and uminus\<^sub>M (\<open>-\<^sub>M _\<close> [81] 80) +
  fixes scale :: "['cr1::comm_ring_1, 'm] \<Rightarrow> 'm" (infixr "*s\<^sub>w\<^sub>i\<^sub>t\<^sub>h" 75)
  assumes scale_right_distrib[algebra_simps]:
    "a *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h (x +\<^sub>M y) = a *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x +\<^sub>M a *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h y"
    and scale_left_distrib[algebra_simps]:
      "(a + b) *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x = a *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x +\<^sub>M b *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x"
    and scale_scale[simp]: "a *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h (b *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x) = (a * b) *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x"
    and scale_one[simp]: "1 *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h x = x"

lemma module_with_overloaded[ud_with]: "module = module_with (+) 0 (-) uminus"
  unfolding module_def module_with_def module_with_axioms_def
  by (simp add: comm_ring_1_axioms ab_group_add_axioms)

locale module_pair_with =
  M\<^sub>1: module_with plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1 +
  M\<^sub>2: module_with plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
  for plus\<^sub>M\<^sub>_\<^sub>1 :: "['m_1, 'm_1] \<Rightarrow> 'm_1" (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>1 (\<open>0\<^sub>M\<^sub>'_\<^sub>1\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>1 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>1 (\<open>-\<^sub>M\<^sub>'_\<^sub>1 _\<close> [81] 80)
    and scale\<^sub>1 (infixr \<open>*s\<^sub>w\<^sub>i\<^sub>t\<^sub>h\<^sub>'_\<^sub>1\<close> 75)
    and plus\<^sub>M\<^sub>_\<^sub>2 :: "['m_2, 'm_2] \<Rightarrow> 'm_2" (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>2 (\<open>0\<^sub>M\<^sub>'_\<^sub>2\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>2 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>2 (\<open>-\<^sub>M\<^sub>'_\<^sub>2 _\<close> [81] 80)
    and scale\<^sub>2 (infixr \<open>*s\<^sub>w\<^sub>i\<^sub>t\<^sub>h\<^sub>'_\<^sub>2\<close> 75)

lemma module_pair_with_overloaded[ud_with]:
  "module_pair =
    (
      \<lambda>scale\<^sub>1 scale\<^sub>2.
        module_pair_with (+) 0 (-) uminus scale\<^sub>1 (+) 0 (-) uminus scale\<^sub>2
    )"
  unfolding module_pair_def module_pair_with_def
  unfolding module_with_overloaded
  ..

locale module_hom_with =
  M\<^sub>1: module_with plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1 +
  M\<^sub>2: module_with plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
  for plus\<^sub>M\<^sub>_\<^sub>1 :: "['m_1, 'm_1] \<Rightarrow> 'm_1" (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>1 (\<open>0\<^sub>M\<^sub>'_\<^sub>1\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>1 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>1 (\<open>-\<^sub>M\<^sub>'_\<^sub>1 _\<close> [81] 80)
    and scale\<^sub>1 (infixr \<open>*s\<^sub>w\<^sub>i\<^sub>t\<^sub>h\<^sub>'_\<^sub>1\<close> 75)
    and plus\<^sub>M\<^sub>_\<^sub>2 :: "['m_2, 'm_2] \<Rightarrow> 'm_2" (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>2 (\<open>0\<^sub>M\<^sub>'_\<^sub>2\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>2 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>2 (\<open>-\<^sub>M\<^sub>'_\<^sub>2 _\<close> [81] 80)
    and scale\<^sub>2 (infixr \<open>*s\<^sub>w\<^sub>i\<^sub>t\<^sub>h\<^sub>'_\<^sub>2\<close> 75) +
  fixes f :: "'m_1 \<Rightarrow> 'm_2"
  assumes add: "f (b1 +\<^sub>M\<^sub>_\<^sub>1 b2) = f b1 +\<^sub>M\<^sub>_\<^sub>2 f b2"
    and scale: "f (r *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h\<^sub>_\<^sub>1 b) = r *s\<^sub>w\<^sub>i\<^sub>t\<^sub>h\<^sub>_\<^sub>2 f b"
begin

sublocale module_pair_with ..

end

lemma module_hom_with_overloaded[ud_with]:
  "module_hom =
    (
      \<lambda>scale\<^sub>1 scale\<^sub>2.
        module_hom_with (+) 0 (-) uminus scale\<^sub>1 (+) 0 (-) uminus scale\<^sub>2
    )"
  unfolding
    module_hom_def module_hom_axioms_def
    module_hom_with_def module_hom_with_axioms_def
  unfolding module_with_overloaded
  ..
ud \<open>module.subspace\<close> (\<open>(with _ _ _ : \<guillemotleft>subspace\<guillemotright> _)\<close> [1000, 999, 998, 1000] 10)
ud \<open>module.span\<close> (\<open>(with _ _ _ : \<guillemotleft>span\<guillemotright> _)\<close> [1000, 999, 998, 1000] 10)
ud \<open>module.dependent\<close>
  (\<open>(with _ _ _ _ : \<guillemotleft>dependent\<guillemotright> _)\<close> [1000, 999, 998, 997, 1000] 10)
ud \<open>module.representation\<close>
  (
    \<open>(with _ _ _ _ : \<guillemotleft>representation\<guillemotright> _ _)\<close>
    [1000, 999, 998, 997, 1000, 999] 10
  )

abbreviation independent_with
  (\<open>(with _ _ _ _ : \<guillemotleft>independent\<guillemotright> _)\<close> [1000, 999, 998, 997, 1000] 10)
  where
    "(with zero\<^sub>C\<^sub>R\<^sub>1 zero\<^sub>M  scale\<^sub>M plus\<^sub>M : \<guillemotleft>independent\<guillemotright> s) \<equiv>
      \<not>(with zero\<^sub>C\<^sub>R\<^sub>1 zero\<^sub>M scale\<^sub>M plus\<^sub>M : \<guillemotleft>dependent\<guillemotright> s)"

lemma span_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "(
      A ===>
      (A ===> A ===> A) ===>
      ((=) ===> A ===> A) ===>
      rel_set A ===>
      rel_set A
    ) span.with span.with"
  unfolding span.with_def
proof(intro rel_funI)
  fix p p' z z' X X' and s s'::"'c \<Rightarrow> _"
  assume transfer_rules[transfer_rule]:
    "(A ===> A ===> A) p p'"
    "A z z'"
    "((=) ===> A ===> A) s s'"
    "rel_set A X X'"
  have "Domainp A z" using \<open>A z z'\<close> by force
  have *: "t \<subseteq> X \<Longrightarrow> (\<forall>x\<in>t. Domainp A x)" for t
    by (meson Domainp.DomainI \<open>rel_set A X X'\<close> rel_setD1 subsetD)
  note swt = sum_with_transfer
    [
      OF assms(1,2,2),
      THEN rel_funD,
      THEN rel_funD,
      THEN rel_funD,
      THEN rel_funD,
      OF transfer_rules(1,2)
    ]
  have DsI: "Domainp A (sum_with p z r t)"
    if "\<And>x. x \<in> t \<Longrightarrow> Domainp A (r x)" "t \<subseteq> Collect (Domainp A)" for r t
    by (metis that Domainp_sum_with transfer_rules(1,2))
  from Domainp_apply2I[OF transfer_rules(3)]
  have Domainp_sI: "Domainp A x \<Longrightarrow> Domainp A (s y x)" for x y by auto
  show "rel_set A
    {sum_with p z (\<lambda>a. s (r a) a) t |t r. finite t \<and> t \<subseteq> X}
        {sum_with p' z' (\<lambda>a. s' (r a) a) t |t r. finite t \<and> t \<subseteq> X'}"
    apply transfer_prover_start
    apply transfer_step+
    by (insert *) (auto intro!: DsI Domainp_sI)
qed

lemma dependent_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "(
      (=) ===>
      A ===>
      (A ===> A ===> A) ===>
      ((=) ===> A ===> A) ===>
      rel_set A ===>
      (=)
    ) dependent.with dependent.with"
  unfolding dependent.with_def
proof(intro rel_funI)
  fix p p' z z' X X' and zb zb' ::'c and s s'::"'c \<Rightarrow> _"
  assume [transfer_rule]:
    "(A ===> A ===> A) p p'"
    "A z z'"
    "zb = zb'"
    "((=) ===> A ===> A) s s'"
    "rel_set A X X'"
  have *: "t \<subseteq> X \<Longrightarrow> (\<forall>x\<in>t. Domainp A x)" for t
    by (meson Domainp.DomainI \<open>rel_set A X X'\<close> rel_setD1 subsetD)
  show
    "(
        \<exists>t u.
          finite t \<and>
          t \<subseteq> X \<and>
          sum_with p z (\<lambda>v. s (u v) v) t = z \<and>
          (\<exists>v\<in>t. u v \<noteq> zb)
     ) =
      (
        \<exists>t u.
          finite t \<and>
          t \<subseteq> X' \<and>
          sum_with p' z' (\<lambda>v. s' (u v) v) t = z' \<and>
          (\<exists>v\<in>t. u v \<noteq> zb')
      )"
    apply transfer_prover_start
    apply transfer_step+
    by (insert *) (auto intro!: comm_monoid_add_ow.sum_with_closed)
qed

ctr relativization
  synthesis ctr_simps
  assumes [transfer_rule]: "is_equality A" "bi_unique B"
  trp (?'a A) and (?'b B)
  in subspace_with: subspace.with_def

subsection\<open>\<open>module_ow\<close>\<close>

subsubsection\<open>Definitions and common properties\<close>

text\<open>Single module.\<close>

locale module_ow = ab_group_add_ow U\<^sub>M plus\<^sub>M zero\<^sub>M minus\<^sub>M uminus\<^sub>M
  for U\<^sub>M :: "'m set"
    and plus\<^sub>M (infixl \<open>+\<^sub>M\<close> 65)
    and zero\<^sub>M (\<open>0\<^sub>M\<close>)
    and minus\<^sub>M (infixl \<open>-\<^sub>M\<close> 65)
    and uminus\<^sub>M (\<open>-\<^sub>M _\<close> [81] 80) +
  fixes scale :: "['cr1::comm_ring_1, 'm] \<Rightarrow> 'm" (infixr "*s\<^sub>M" 75)
  assumes scale_closed[simp, intro]: "x \<in> U\<^sub>M \<Longrightarrow> a *s\<^sub>M x \<in> U\<^sub>M"
    and scale_right_distrib[algebra_simps]:
    "\<lbrakk> x \<in> U\<^sub>M; y \<in> U\<^sub>M \<rbrakk> \<Longrightarrow> a *s\<^sub>M (x +\<^sub>M y) = a *s\<^sub>M x +\<^sub>M a *s\<^sub>M y"
    and scale_left_distrib[algebra_simps]:
      "x \<in> U\<^sub>M \<Longrightarrow> (a + b) *s\<^sub>M x = a *s\<^sub>M x +\<^sub>M b *s\<^sub>M x"
    and scale_scale[simp]:
      "x \<in> U\<^sub>M \<Longrightarrow> a *s\<^sub>M (b *s\<^sub>M x) = (a * b) *s\<^sub>M x"
    and scale_one[simp]: "x \<in> U\<^sub>M \<Longrightarrow> 1 *s\<^sub>M x = x"
begin

lemma scale_closed'[simp]: "\<forall>a. \<forall>x\<in>U\<^sub>M. a *s\<^sub>M x \<in> U\<^sub>M" by simp

lemma minus_closed'[simp]: "\<forall>x\<in>U\<^sub>M. \<forall>y\<in>U\<^sub>M. x -\<^sub>M y \<in> U\<^sub>M"
  by (simp add: ab_diff_conv_add_uminus add_closed' uminus_closed)

lemma uminus_closed'[simp]: "\<forall>x\<in>U\<^sub>M. -\<^sub>M x \<in> U\<^sub>M" by (simp add: uminus_closed)

tts_register_sbts \<open>(*s\<^sub>M)\<close> | U\<^sub>M
  by (rule tts_AB_C_transfer[OF scale_closed])
    (auto simp: bi_unique_eq right_total_eq)

tts_register_sbts plus\<^sub>M | U\<^sub>M
  by (rule tts_AB_C_transfer[OF add_closed])
    (auto simp: bi_unique_eq right_total_eq)

tts_register_sbts zero\<^sub>M | U\<^sub>M
  by (meson Domainp.cases zero_closed)

end

text\<open>Pair of modules.\<close>

locale module_pair_ow =
  M\<^sub>1: module_ow U\<^sub>M\<^sub>_\<^sub>1 plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1 +
  M\<^sub>2: module_ow U\<^sub>M\<^sub>_\<^sub>2 plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
  for U\<^sub>M\<^sub>_\<^sub>1 :: "'m_1 set"
    and plus\<^sub>M\<^sub>_\<^sub>1 (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>1 (\<open>0\<^sub>M\<^sub>'_\<^sub>1\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>1 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>1 (\<open>-\<^sub>M\<^sub>'_\<^sub>1 _\<close> [81] 80)
    and scale\<^sub>1 :: "['cr1::comm_ring_1, 'm_1] \<Rightarrow> 'm_1" (infixr \<open>*s\<^sub>M\<^sub>'_\<^sub>1\<close> 75)
    and U\<^sub>M\<^sub>_\<^sub>2 :: "'m_2 set"
    and plus\<^sub>M\<^sub>_\<^sub>2 (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>2 (\<open>0\<^sub>M\<^sub>'_\<^sub>2\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>2 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>2 (\<open>-\<^sub>M\<^sub>'_\<^sub>2 _\<close> [81] 80)
    and scale\<^sub>2 :: "['cr1::comm_ring_1, 'm_2] \<Rightarrow> 'm_2" (infixr \<open>*s\<^sub>M\<^sub>'_\<^sub>2\<close> 75)

text\<open>Module homomorphisms.\<close>

locale module_hom_ow =
  M\<^sub>1: module_ow U\<^sub>M\<^sub>_\<^sub>1 plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1 +
  M\<^sub>2: module_ow U\<^sub>M\<^sub>_\<^sub>2 plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
  for U\<^sub>M\<^sub>_\<^sub>1 :: "'m_1 set"
    and plus\<^sub>M\<^sub>_\<^sub>1 (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>1 (\<open>0\<^sub>M\<^sub>'_\<^sub>1\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>1 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>1\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>1 (\<open>-\<^sub>M\<^sub>'_\<^sub>1 _\<close> [81] 80)
    and scale\<^sub>1 :: "['cr1::comm_ring_1, 'm_1] \<Rightarrow> 'm_1" (infixr \<open>*s\<^sub>M\<^sub>'_\<^sub>1\<close> 75)
    and U\<^sub>M\<^sub>_\<^sub>2 :: "'m_2 set"
    and plus\<^sub>M\<^sub>_\<^sub>2 (infixl \<open>+\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and zero\<^sub>M\<^sub>_\<^sub>2 (\<open>0\<^sub>M\<^sub>'_\<^sub>2\<close>)
    and minus\<^sub>M\<^sub>_\<^sub>2 (infixl \<open>-\<^sub>M\<^sub>'_\<^sub>2\<close> 65)
    and uminus\<^sub>M\<^sub>_\<^sub>2 (\<open>-\<^sub>M\<^sub>'_\<^sub>2 _\<close> [81] 80)
    and scale\<^sub>2 :: "['cr1::comm_ring_1, 'm_2] \<Rightarrow> 'm_2" (infixr \<open>*s\<^sub>M\<^sub>'_\<^sub>2\<close> 75) +
  fixes f :: "'m_1 \<Rightarrow> 'm_2"
  assumes f_closed[simp]: "f ` U\<^sub>M\<^sub>_\<^sub>1 \<subseteq> U\<^sub>M\<^sub>_\<^sub>2"
    and add: "\<lbrakk> b1 \<in> U\<^sub>M\<^sub>_\<^sub>1; b2 \<in> U\<^sub>M\<^sub>_\<^sub>1 \<rbrakk> \<Longrightarrow> f (b1 +\<^sub>M\<^sub>_\<^sub>1 b2) = f b1 +\<^sub>M\<^sub>_\<^sub>2 f b2"
    and scale: "\<lbrakk> r \<in> U\<^sub>C\<^sub>R\<^sub>1; b \<in> U\<^sub>M\<^sub>_\<^sub>1 \<rbrakk> \<Longrightarrow> f (r *s\<^sub>M\<^sub>_\<^sub>1 b) = r *s\<^sub>M\<^sub>_\<^sub>2 f b"
begin

tts_register_sbts f | \<open>U\<^sub>M\<^sub>_\<^sub>1\<close> and \<open>U\<^sub>M\<^sub>_\<^sub>2\<close> by (rule tts_AB_transfer[OF f_closed])

lemma f_closed'[simp]: "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. f x \<in> U\<^sub>M\<^sub>_\<^sub>2" using f_closed by blast

sublocale module_pair_ow ..

end

subsubsection\<open>Transfer.\<close>

lemma module_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique B" "right_total B"
  fixes PP lhs
  defines
    "PP \<equiv>
      (
        (B ===> B ===> B) ===>
        B ===>
        (B ===> B ===> B) ===>
        (B ===> B) ===>
        ((=) ===> B ===> B) ===>
        (=)
      )"
    and
      "lhs \<equiv>
        (
          \<lambda> plus\<^sub>M zero\<^sub>M minus\<^sub>M uminus\<^sub>M scale.
          module_ow (Collect (Domainp B)) plus\<^sub>M zero\<^sub>M minus\<^sub>M uminus\<^sub>M scale
        )"
  shows "PP lhs (module_with)"
proof-
  let ?rhs =
    "(
      \<lambda>plus\<^sub>M zero\<^sub>M minus\<^sub>M uminus\<^sub>M scale.
        (\<forall>a \<in> UNIV. \<forall>x \<in> UNIV. scale a x \<in> UNIV) \<and>
         module_with plus\<^sub>M zero\<^sub>M minus\<^sub>M uminus\<^sub>M scale
    )"
  have "PP lhs ?rhs"
    unfolding
      PP_def lhs_def
      module_ow_def module_with_def
      module_ow_axioms_def module_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by (intro ext) blast
  then show ?thesis by simp
qed

lemma module_pair_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]:
    "bi_unique B\<^sub>1" "right_total B\<^sub>1" "bi_unique B\<^sub>2" "right_total B\<^sub>2"
  fixes PP lhs
  defines
    "PP \<equiv>
      (
        (B\<^sub>1 ===> B\<^sub>1 ===> B\<^sub>1) ===>
        B\<^sub>1 ===>
        (B\<^sub>1 ===> B\<^sub>1 ===> B\<^sub>1) ===>
        (B\<^sub>1 ===> B\<^sub>1) ===>
        ((=) ===> B\<^sub>1 ===> B\<^sub>1) ===>
        (B\<^sub>2 ===> B\<^sub>2 ===> B\<^sub>2) ===>
        B\<^sub>2 ===>
        (B\<^sub>2 ===> B\<^sub>2 ===> B\<^sub>2) ===>
        (B\<^sub>2 ===> B\<^sub>2) ===>
        ((=) ===> B\<^sub>2 ===> B\<^sub>2) ===>
        (=)
    )"
    and
      "lhs \<equiv>
        (
          \<lambda>
            plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
            plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2.
          module_pair_ow
            (Collect (Domainp B\<^sub>1)) plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
            (Collect (Domainp B\<^sub>2)) plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
        )"
    shows "PP lhs module_pair_with"
  unfolding PP_def lhs_def
proof(intro rel_funI)
  let ?rhs =
    "(
      \<lambda>
        plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
        plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2.
          (\<forall>a \<in> UNIV. \<forall>x \<in> UNIV. scale\<^sub>1 a x \<in> UNIV) \<and>
          (\<forall>a \<in> UNIV. \<forall>x \<in> UNIV. scale\<^sub>2 a x \<in> UNIV) \<and>
          module_pair_with
            plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
            plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
    )"
  fix
    plus\<^sub>M\<^sub>_\<^sub>1 plus\<^sub>M\<^sub>_\<^sub>1'
    zero\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1'
    minus\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1'
    uminus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1'
    plus\<^sub>M\<^sub>_\<^sub>2 plus\<^sub>M\<^sub>_\<^sub>2'
    zero\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2'
    minus\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2'
    uminus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2'
    and scale\<^sub>1 :: "'f::comm_ring_1 \<Rightarrow> 'a \<Rightarrow> 'a" and scale\<^sub>1'
    and scale\<^sub>2 :: "'f::comm_ring_1 \<Rightarrow> 'c \<Rightarrow> 'c" and scale\<^sub>2'
  assume [transfer_rule]:
    "(B\<^sub>1 ===> B\<^sub>1 ===> B\<^sub>1) plus\<^sub>M\<^sub>_\<^sub>1 plus\<^sub>M\<^sub>_\<^sub>1'"
    "B\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1'"
    "(B\<^sub>1 ===> B\<^sub>1 ===> B\<^sub>1) minus\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1'"
    "(B\<^sub>1 ===> B\<^sub>1) uminus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1'"
    "(B\<^sub>2 ===> B\<^sub>2 ===> B\<^sub>2) plus\<^sub>M\<^sub>_\<^sub>2 plus\<^sub>M\<^sub>_\<^sub>2'"
    "B\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2'"
    "(B\<^sub>2 ===> B\<^sub>2 ===> B\<^sub>2) minus\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2'"
    "(B\<^sub>2 ===> B\<^sub>2) uminus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2'"
    "((=) ===> B\<^sub>1 ===> B\<^sub>1) scale\<^sub>1 scale\<^sub>1'"
    "((=) ===> B\<^sub>2 ===> B\<^sub>2) scale\<^sub>2 scale\<^sub>2'"
  show
    "module_pair_ow
      (Collect (Domainp B\<^sub>1)) plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
      (Collect (Domainp B\<^sub>2)) plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
      =
    module_pair_with
      plus\<^sub>M\<^sub>_\<^sub>1' zero\<^sub>M\<^sub>_\<^sub>1' minus\<^sub>M\<^sub>_\<^sub>1' uminus\<^sub>M\<^sub>_\<^sub>1' scale\<^sub>1'
      plus\<^sub>M\<^sub>_\<^sub>2' zero\<^sub>M\<^sub>_\<^sub>2' minus\<^sub>M\<^sub>_\<^sub>2' uminus\<^sub>M\<^sub>_\<^sub>2' scale\<^sub>2'"
    unfolding module_pair_ow_def module_pair_with_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
qed

lemma module_hom_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]:
    "bi_unique B\<^sub>1" "right_total B\<^sub>1" "bi_unique B\<^sub>2" "right_total B\<^sub>2"
  fixes PP lhs
  defines
    "PP \<equiv>
      (
        (B\<^sub>1 ===> B\<^sub>1 ===> B\<^sub>1) ===>
        B\<^sub>1 ===>
        (B\<^sub>1 ===> B\<^sub>1 ===> B\<^sub>1) ===>
        (B\<^sub>1 ===> B\<^sub>1) ===>
        ((=) ===> B\<^sub>1 ===> B\<^sub>1) ===>
        (B\<^sub>2 ===> B\<^sub>2 ===> B\<^sub>2) ===>
        B\<^sub>2 ===>
        (B\<^sub>2 ===> B\<^sub>2 ===> B\<^sub>2) ===>
        (B\<^sub>2 ===> B\<^sub>2) ===>
        ((=) ===> B\<^sub>2 ===> B\<^sub>2) ===>
        (B\<^sub>1 ===> B\<^sub>2) ===>
        (=)
      )"
    and
      "lhs \<equiv>
        (
          \<lambda>
            plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
            plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
            f.
          module_hom_ow
            (Collect (Domainp B\<^sub>1)) plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
            (Collect (Domainp B\<^sub>2)) plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
            f
        )"
    shows "PP lhs module_hom_with"
proof-
  let ?rhs =
    "(
      \<lambda>
        plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
        plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
        f.
        (\<forall>x \<in> UNIV. f x \<in> UNIV) \<and>
        module_hom_with
          plus\<^sub>M\<^sub>_\<^sub>1 zero\<^sub>M\<^sub>_\<^sub>1 minus\<^sub>M\<^sub>_\<^sub>1 uminus\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1
          plus\<^sub>M\<^sub>_\<^sub>2 zero\<^sub>M\<^sub>_\<^sub>2 minus\<^sub>M\<^sub>_\<^sub>2 uminus\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
          f
    )"
  have "PP lhs ?rhs"
    unfolding
      PP_def lhs_def
      module_hom_ow_def module_hom_with_def
      module_hom_ow_axioms_def module_hom_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by (intro ext) blast
  then show ?thesis by simp
qed

subsection\<open>\<open>module_on\<close>\<close>

subsubsection\<open>Definitions and common properties\<close>

locale module_on =
  fixes U\<^sub>M
    and scale :: "'a::comm_ring_1 \<Rightarrow> 'b::ab_group_add \<Rightarrow> 'b" (infixr "*s" 75)
  assumes scale_right_distrib_on[algebra_simps]:
      "\<lbrakk> x \<in> U\<^sub>M; y \<in> U\<^sub>M \<rbrakk> \<Longrightarrow> a *s (x + y) = a *s x + a *s y"
    and scale_left_distrib_on[algebra_simps]:
      "x \<in> U\<^sub>M \<Longrightarrow> (a + b) *s x = a *s x + b *s x"
    and scale_scale_on[simp]: "x \<in> U\<^sub>M \<Longrightarrow> a *s (b *s x) = (a * b) *s x"
    and scale_one_on[simp]: "x \<in> U\<^sub>M \<Longrightarrow> 1 *s x = x"
    and closed_add: "\<lbrakk> x \<in> U\<^sub>M; y \<in> U\<^sub>M \<rbrakk> \<Longrightarrow> x + y \<in> U\<^sub>M"
    and closed_zero: "0 \<in> U\<^sub>M"
    and closed_scale: "x \<in> U\<^sub>M \<Longrightarrow> a *s x \<in> U\<^sub>M"
begin

lemma S_ne: "U\<^sub>M \<noteq> {}" using closed_zero by auto

lemma scale_minus_left_on:
  assumes "x \<in> U\<^sub>M"
  shows "scale (- a) x = - scale a x"
  by
    (
      metis
        add_cancel_right_right scale_left_distrib_on neg_eq_iff_add_eq_0 assms
    )

lemma closed_uminus:
  assumes "x \<in> U\<^sub>M"
  shows "-x \<in> U\<^sub>M"
  by (metis assms closed_scale scale_minus_left_on scale_one_on)

sublocale implicit\<^sub>M: ab_group_add_ow U\<^sub>M \<open>(+)\<close> 0 \<open>(-)\<close> uminus
  by unfold_locales (simp_all add: closed_add closed_zero closed_uminus)

sublocale implicit\<^sub>M: module_ow U\<^sub>M \<open>(+)\<close> 0 \<open>(-)\<close> uminus \<open>(*s)\<close>
  by unfold_locales
    (simp_all add: closed_scale scale_right_distrib_on scale_left_distrib_on)

definition subspace :: "'b set \<Rightarrow> bool"
  where subspace_on_def: "subspace T \<longleftrightarrow>
    0 \<in> T \<and> (\<forall>x\<in>T. \<forall>y\<in>T. x + y \<in> T) \<and> (\<forall>c. \<forall>x\<in>T. c *s x \<in> T)"

definition span :: "'b set \<Rightarrow> 'b set"
  where span_on_def: "span b = {sum (\<lambda>a. r a *s  a) t | t r. finite t \<and> t \<subseteq> b}"

definition dependent :: "'b set \<Rightarrow> bool"
  where dependent_on_def: "dependent s \<longleftrightarrow>
    (\<exists>t u. finite t \<and> t \<subseteq> s \<and> (sum (\<lambda>v. u v *s v) t = 0 \<and> (\<exists>v\<in>t. u v \<noteq> 0)))"

lemma implicit_subspace_with[tts_implicit]: "subspace.with (+) 0 (*s) = subspace"
  unfolding subspace_on_def subspace.with_def ..

lemma implicit_dependent_with[tts_implicit]:
  "dependent.with 0 0 (+) (*s) = dependent"
  unfolding dependent_on_def dependent.with_def sum_with ..

lemma implicit_span_with[tts_implicit]: "span.with 0 (+) (*s) = span"
  unfolding span_on_def span.with_def sum_with ..

end

lemma implicit_module_ow[tts_implicit]:
  "module_ow U\<^sub>M (+) 0 (-) uminus = module_on U\<^sub>M"
proof (intro ext iffI)
  fix s::"'a\<Rightarrow>'b\<Rightarrow>'b" assume "module_on U\<^sub>M s"
  then interpret module_on U\<^sub>M s .
  show "module_ow U\<^sub>M (+) 0 (-) uminus s"
    by (simp add: implicit\<^sub>M.module_ow_axioms)
next
  fix s::"'a\<Rightarrow>'b\<Rightarrow>'b" assume "module_ow U\<^sub>M (+) 0 (-) uminus s"
  then interpret module_ow U\<^sub>M \<open>(+)\<close> 0 \<open>(-)\<close> uminus s .
  show "module_on U\<^sub>M s"
    by (simp add: scale_left_distrib scale_right_distrib module_on.intro)
qed

locale module_pair_on =
  M\<^sub>1: module_on U\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1 + M\<^sub>2: module_on U\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
  for U\<^sub>M\<^sub>_\<^sub>1:: "'b::ab_group_add set"
    and U\<^sub>M\<^sub>_\<^sub>2::"'c::ab_group_add set"
    and scale\<^sub>1::"'a::comm_ring_1 \<Rightarrow> _ \<Rightarrow> _" (infixr \<open>*s\<^sub>1\<close> 75)
    and scale\<^sub>2::"'a::comm_ring_1 \<Rightarrow> _ \<Rightarrow> _" (infixr \<open>*s\<^sub>2\<close> 75)
begin

sublocale implicit\<^sub>M: module_pair_ow
  U\<^sub>M\<^sub>_\<^sub>1 \<open>(+)\<close> 0 \<open>(-)\<close> uminus scale\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 \<open>(+)\<close> 0 \<open>(-)\<close> uminus scale\<^sub>2
  by unfold_locales

end

lemma implicit_module_pair_ow[tts_implicit]:
  "module_pair_ow U\<^sub>M\<^sub>_\<^sub>1 (+) 0 (-) uminus scale\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (+) 0 (-) uminus scale\<^sub>2 =
    module_pair_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>1 scale\<^sub>2"
  unfolding module_pair_ow_def implicit_module_ow module_pair_on_def ..

locale module_hom_on = M\<^sub>1: module_on U\<^sub>M\<^sub>_\<^sub>1 scale\<^sub>1 + M\<^sub>2: module_on U\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>2
  for U\<^sub>M\<^sub>_\<^sub>1 :: "'b::ab_group_add set" and U\<^sub>M\<^sub>_\<^sub>2 :: "'c::ab_group_add set"
    and scale\<^sub>1 :: "'a::comm_ring_1 \<Rightarrow> 'b \<Rightarrow> 'b" (infixr \<open>*s\<^sub>1\<close> 75)
    and scale\<^sub>2 :: "'a::comm_ring_1 \<Rightarrow> 'c \<Rightarrow> 'c" (infixr \<open>*s\<^sub>2\<close> 75) +
  fixes f :: "'b \<Rightarrow> 'c"
  assumes hom_closed: "f ` U\<^sub>M\<^sub>_\<^sub>1 \<subseteq> U\<^sub>M\<^sub>_\<^sub>2"
    and add: "\<And>b1 b2. \<lbrakk> b1 \<in> U\<^sub>M\<^sub>_\<^sub>1; b2 \<in> U\<^sub>M\<^sub>_\<^sub>1 \<rbrakk> \<Longrightarrow> f (b1 + b2) = f b1 + f b2"
    and scale: "\<And>b. b \<in> U\<^sub>M\<^sub>_\<^sub>1 \<Longrightarrow> f (r *s\<^sub>1 b) = r *s\<^sub>2 f b"
begin

sublocale module_pair_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>1 scale\<^sub>2 by unfold_locales

sublocale implicit\<^sub>M: module_hom_ow
  U\<^sub>M\<^sub>_\<^sub>1 \<open>(+)\<close> 0 \<open>(-)\<close> uminus scale\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 \<open>(+)\<close> 0 \<open>(-)\<close> uminus scale\<^sub>2
  by unfold_locales (simp_all add: hom_closed add scale)

end

lemma implicit_module_hom_ow[tts_implicit]:
  "module_hom_ow U\<^sub>M\<^sub>_\<^sub>1 (+) 0 (-) uminus scale\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (+) 0 (-) uminus scale\<^sub>2 =
    module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 scale\<^sub>1 scale\<^sub>2"
  unfolding
    module_hom_ow_def
    module_hom_on_def
    module_hom_ow_axioms_def
    module_hom_on_axioms_def
    tts_implicit
  by (intro ext) auto

subsection\<open>Relativization.\<close>

context module_on
begin

tts_context
  tts: (?'b to \<open>U\<^sub>M::'b set\<close>)
  rewriting ctr_simps
  substituting implicit\<^sub>M.module_ow_axioms
    and implicit\<^sub>M.ab_group_add_ow_axioms
  eliminating \<open>?a \<in> U\<^sub>M\<close> and \<open>?B \<subseteq> U\<^sub>M\<close> through auto
  applying
    [
      OF
        implicit\<^sub>M.carrier_ne
        implicit\<^sub>M.add_closed'
        implicit\<^sub>M.minus_closed'
        implicit\<^sub>M.uminus_closed'
        implicit\<^sub>M.scale_closed',
      unfolded tts_implicit
    ]
begin

tts_lemma scale_left_commute:
  assumes "x \<in> U\<^sub>M"
  shows "a *s b *s x = b *s a *s x"
    is module.scale_left_commute.

tts_lemma scale_zero_left:
  assumes "x \<in> U\<^sub>M"
  shows "0 *s x = 0"
    is module.scale_zero_left.

tts_lemma scale_minus_left:
  assumes "x \<in> U\<^sub>M"
  shows "- a *s x = - (a *s x)"
    is module.scale_minus_left.

tts_lemma scale_left_diff_distrib:
  assumes "x \<in> U\<^sub>M"
  shows "(a - b) *s x = a *s x - b *s x"
    is module.scale_left_diff_distrib.

tts_lemma scale_sum_left:
  assumes "x \<in> U\<^sub>M"
  shows "sum f A *s x = (\<Sum>a\<in>A. f a *s x)"
    is module.scale_sum_left.

tts_lemma scale_zero_right: "a *s 0 = 0"
    is module.scale_zero_right.

tts_lemma scale_minus_right:
  assumes "x \<in> U\<^sub>M"
  shows "a *s - x = - (a *s x)"
    is module.scale_minus_right.

tts_lemma scale_right_diff_distrib:
  assumes "x \<in> U\<^sub>M" and "y \<in> U\<^sub>M"
  shows "a *s (x - y) = a *s x - a *s y"
    is module.scale_right_diff_distrib.

tts_lemma scale_sum_right:
  assumes "range f \<subseteq> U\<^sub>M"
  shows "a *s sum f A = (\<Sum>x\<in>A. a *s f x)"
    is module.scale_sum_right.

tts_lemma sum_constant_scale:
  assumes "y \<in> U\<^sub>M"
  shows "(\<Sum>x\<in>A. y) = of_nat (card A) *s y"
    is module.sum_constant_scale.

tts_lemma subspace_def:
  assumes "S \<subseteq> U\<^sub>M"
  shows "subspace S =
    (0 \<in> S \<and> (\<forall>x. \<forall>y\<in>S. x *s y \<in> S) \<and> (\<forall>x\<in>S. \<forall>y\<in>S. x + y \<in> S))"
    is module.subspace_def.

tts_lemma subspaceI:
  assumes "S \<subseteq> U\<^sub>M"
    and "0 \<in> S"
    and "\<And>x y. \<lbrakk>x \<in> U\<^sub>M; y \<in> U\<^sub>M; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> x + y \<in> S"
    and "\<And>c x. \<lbrakk>x \<in> U\<^sub>M; x \<in> S\<rbrakk> \<Longrightarrow> c *s x \<in> S"
  shows "subspace S"
    is module.subspaceI.

tts_lemma subspace_single_0: "subspace {0}"
    is module.subspace_single_0.

tts_lemma subspace_0:
  assumes "S \<subseteq> U\<^sub>M" and "subspace S"
  shows "0 \<in> S"
    is module.subspace_0.

tts_lemma subspace_add:
  assumes "S \<subseteq> U\<^sub>M" and "subspace S" and "x \<in> S" and "y \<in> S"
  shows "x + y \<in> S"
    is module.subspace_add.

tts_lemma subspace_scale:
  assumes "S \<subseteq> U\<^sub>M" and "subspace S" and "x \<in> S"
  shows "c *s x \<in> S"
    is module.subspace_scale.

tts_lemma subspace_neg:
  assumes "S \<subseteq> U\<^sub>M" and "subspace S" and "x \<in> S"
  shows "- x \<in> S"
    is module.subspace_neg.

tts_lemma subspace_diff:
  assumes "S \<subseteq> U\<^sub>M" and "subspace S" and "x \<in> S" and "y \<in> S"
  shows "x - y \<in> S"
    is module.subspace_diff.

tts_lemma subspace_sum:
  assumes "A \<subseteq> U\<^sub>M"
    and "range f \<subseteq> U\<^sub>M"
    and "subspace A"
    and "\<And>x. x \<in> B \<Longrightarrow> f x \<in> A"
  shows "sum f B \<in> A"
    is module.subspace_sum.

tts_lemma subspace_inter:
  assumes "A \<subseteq> U\<^sub>M" and "B \<subseteq> U\<^sub>M" and "subspace A" and "subspace B"
  shows "subspace (A \<inter> B)"
    is module.subspace_inter.

tts_lemma span_explicit':
  assumes "b \<subseteq> U\<^sub>M"
  shows "span b =
    {
      x \<in> U\<^sub>M. \<exists>f.
        x = (\<Sum>v\<in>{x \<in> U\<^sub>M. f x \<noteq> 0}. f v *s v) \<and>
        finite {x \<in> U\<^sub>M. f x \<noteq> 0} \<and>
        (\<forall>x\<in>U\<^sub>M. f x \<noteq> 0 \<longrightarrow> x \<in> b)
    }"
   is module.span_explicit'.

tts_lemma span_finite:
  assumes "S \<subseteq> U\<^sub>M" and "finite S"
  shows "span S = range (\<lambda>u. \<Sum>v\<in>S. u v *s v)"
    is module.span_finite.

tts_lemma span_induct_alt:
  assumes "x \<in> U\<^sub>M"
    and "S \<subseteq> U\<^sub>M"
    and "x \<in> span S"
    and "h 0"
    and "\<And>c x y. \<lbrakk>x \<in> U\<^sub>M; y \<in> U\<^sub>M; x \<in> S; h y\<rbrakk> \<Longrightarrow> h (c *s x + y)"
  shows "h x"
    is module.span_induct_alt.

tts_lemma span_mono:
  assumes "B \<subseteq> U\<^sub>M" and "A \<subseteq> B"
  shows "span A \<subseteq> span B"
    is module.span_mono.

tts_lemma span_base:
  assumes "S \<subseteq> U\<^sub>M" and "a \<in> S"
  shows "a \<in> span S"
    is module.span_base.

tts_lemma span_superset:
  assumes "S \<subseteq> U\<^sub>M"
  shows "S \<subseteq> span S"
    is module.span_superset.

tts_lemma span_zero:
  assumes "S \<subseteq> U\<^sub>M"
  shows "0 \<in> span S"
    is module.span_zero.

tts_lemma span_add:
  assumes "x \<in> U\<^sub>M"
    and "S \<subseteq> U\<^sub>M"
    and "y \<in> U\<^sub>M"
    and "x \<in> span S"
    and "y \<in> span S"
  shows "x + y \<in> span S"
    is module.span_add.

tts_lemma span_scale:
  assumes "x \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M" and "x \<in> span S"
  shows "c *s x \<in> span S"
    is module.span_scale.

tts_lemma subspace_span:
  assumes "S \<subseteq> U\<^sub>M"
  shows "subspace (span S)"
    is module.subspace_span.

tts_lemma span_neg:
  assumes "x \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M" and "x \<in> span S"
  shows "- x \<in> span S"
    is module.span_neg.

tts_lemma span_diff:
  assumes "x \<in> U\<^sub>M"
    and "S \<subseteq> U\<^sub>M"
    and "y \<in> U\<^sub>M"
    and "x \<in> span S"
    and "y \<in> span S"
  shows "x - y \<in> span S"
    is module.span_diff.

tts_lemma span_sum:
  assumes "range f \<subseteq> U\<^sub>M" and "S \<subseteq> U\<^sub>M" and "\<And>x. x \<in> A \<Longrightarrow> f x \<in> span S"
  shows "sum f A \<in> span S"
    is module.span_sum.

tts_lemma span_minimal:
  assumes "T \<subseteq> U\<^sub>M" and "S \<subseteq> T" and "subspace T"
  shows "span S \<subseteq> T"
    is module.span_minimal.

tts_lemma span_subspace_induct:
  assumes "x \<in> U\<^sub>M"
    and "S \<subseteq> U\<^sub>M"
    and "P \<subseteq> U\<^sub>M"
    and "x \<in> span S"
    and "subspace P"
    and "\<And>x. x \<in> S \<Longrightarrow> x \<in> P"
  shows "x \<in> P"
    given module.span_subspace_induct
    by simp

tts_lemma span_induct:
  assumes "x \<in> U\<^sub>M"
    and "S \<subseteq> U\<^sub>M"
    and "x \<in> span S"
    and "subspace {x. P x \<and> x \<in> U\<^sub>M}"
    and "\<And>x. x \<in> S \<Longrightarrow> P x"
  shows "P x"
    given module.span_induct by blast

tts_lemma span_empty: "span {} = {0}"
    is module.span_empty.

tts_lemma span_subspace:
  assumes "B \<subseteq> U\<^sub>M" and "A \<subseteq> B" and "B \<subseteq> span A" and "subspace B"
  shows "span A = B"
    is module.span_subspace.

tts_lemma span_span:
  assumes "A \<subseteq> U\<^sub>M"
  shows "span (span A) = span A"
    is module.span_span.

tts_lemma span_add_eq:
  assumes "x \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M" and "y \<in> U\<^sub>M" and "x \<in> span S"
  shows "(x + y \<in> span S) = (y \<in> span S)"
    is module.span_add_eq.

tts_lemma span_add_eq2:
  assumes "y \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M" and "x \<in> U\<^sub>M" and "y \<in> span S"
  shows "(x + y \<in> span S) = (x \<in> span S)"
    is module.span_add_eq2.

tts_lemma span_singleton:
  assumes "x \<in> U\<^sub>M"
  shows "span {x} = range (\<lambda>k. k *s x)"
    is module.span_singleton.

tts_lemma span_Un:
  assumes "S \<subseteq> U\<^sub>M" and "T \<subseteq> U\<^sub>M"
  shows "span (S \<union> T) =
    {x \<in> U\<^sub>M. \<exists>a\<in>U\<^sub>M. \<exists>b\<in>U\<^sub>M. x = a + b \<and> a \<in> span S \<and> b \<in> span T}"
    is module.span_Un.

tts_lemma span_insert:
  assumes "a \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M"
  shows "span (insert a S) = {x \<in> U\<^sub>M. \<exists>y. x - y *s a \<in> span S}"
    is module.span_insert.

tts_lemma span_breakdown:
  assumes "S \<subseteq> U\<^sub>M" and "a \<in> U\<^sub>M" and "b \<in> S" and "a \<in> span S"
  shows "\<exists>x. a - x *s b \<in> span (S - {b})"
    is module.span_breakdown.

tts_lemma span_breakdown_eq:
  assumes "x \<in> U\<^sub>M" and "a \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M"
  shows "(x \<in> span (insert a S)) = (\<exists>y. x - y *s a \<in> span S)"
    is module.span_breakdown_eq.

tts_lemma span_clauses:
  "\<lbrakk>S \<subseteq> U\<^sub>M; a \<in> S\<rbrakk> \<Longrightarrow> a \<in> span S"
  "S \<subseteq> U\<^sub>M \<Longrightarrow> 0 \<in> span S"
  "\<lbrakk>x \<in> U\<^sub>M; S \<subseteq> U\<^sub>M; y \<in> U\<^sub>M; x \<in> span S; y \<in> span S\<rbrakk> \<Longrightarrow> x + y \<in> span S"
  "\<lbrakk>x \<in> U\<^sub>M; S \<subseteq> U\<^sub>M; x \<in> span S\<rbrakk> \<Longrightarrow> c *s x \<in> span S"
  is module.span_clauses.

tts_lemma span_eq_iff:
  assumes "s \<subseteq> U\<^sub>M"
  shows "(span s = s) = subspace s"
    is module.span_eq_iff.

tts_lemma span_eq:
  assumes "S \<subseteq> U\<^sub>M" and "T \<subseteq> U\<^sub>M"
  shows "(span S = span T) = (S \<subseteq> span T \<and> T \<subseteq> span S)"
    is module.span_eq.

tts_lemma eq_span_insert_eq:
  assumes "x \<in> U\<^sub>M" and "y \<in> U\<^sub>M" and "S \<subseteq> U\<^sub>M" and "x - y \<in> span S"
  shows "span (insert x S) = span (insert y S)"
    is module.eq_span_insert_eq.

tts_lemma dependent_mono:
  assumes "A \<subseteq> U\<^sub>M" and "dependent B" and "B \<subseteq> A"
  shows "dependent A"
    is module.dependent_mono.

tts_lemma independent_mono:
  assumes "A \<subseteq> U\<^sub>M" and "\<not> dependent A" and "B \<subseteq> A"
  shows "\<not> dependent B"
    is module.independent_mono.

tts_lemma dependent_zero:
  assumes "A \<subseteq> U\<^sub>M" and "0 \<in> A"
  shows "dependent A"
    is module.dependent_zero.

tts_lemma independent_empty: "\<not> dependent {}"
    is module.independent_empty.

tts_lemma independentD:
  assumes "s \<subseteq> U\<^sub>M"
    and "\<not> dependent s"
    and "finite t"
    and "t \<subseteq> s"
    and "(\<Sum>v\<in>t. u v *s v) = 0"
    and "v \<in> t"
  shows "u v = 0"
    is module.independentD.

tts_lemma independent_Union_directed:
  assumes "C \<subseteq> Pow U\<^sub>M"
    and "\<And>c d. \<lbrakk>c \<subseteq> U\<^sub>M; d \<subseteq> U\<^sub>M; c \<in> C; d \<in> C\<rbrakk> \<Longrightarrow> c \<subseteq> d \<or> d \<subseteq> c"
    and "\<And>c. \<lbrakk>c \<subseteq> U\<^sub>M; c \<in> C\<rbrakk> \<Longrightarrow> \<not> dependent c"
  shows "\<not> dependent (\<Union> C)"
    is module.independent_Union_directed.

tts_lemma dependent_finite:
  assumes "S \<subseteq> U\<^sub>M" and "finite S"
  shows "dependent S = (\<exists>x. (\<exists>y\<in>S. x y \<noteq> 0) \<and> (\<Sum>v\<in>S. x v *s v) = 0)"
    is module.dependent_finite.

tts_lemma independentD_alt:
  assumes "B \<subseteq> U\<^sub>M"
    and "x \<in> U\<^sub>M"
    and "\<not> dependent B"
    and "finite {x \<in> U\<^sub>M. X x \<noteq> 0}"
    and "{x \<in> U\<^sub>M. X x \<noteq> 0} \<subseteq> B"
    and "(\<Sum>x | x \<in> U\<^sub>M \<and> X x \<noteq> 0. X x *s x) = 0"
  shows "X x = 0"
    is module.independentD_alt.

tts_lemma spanning_subset_independent:
  assumes "A \<subseteq> U\<^sub>M" and "B \<subseteq> A" and "\<not> dependent A" and "A \<subseteq> span B"
  shows "A = B"
    is module.spanning_subset_independent.

tts_lemma unique_representation:
  assumes "basis \<subseteq> U\<^sub>M"
    and "\<not> dependent basis"
    and "\<And>v. \<lbrakk>v \<in> U\<^sub>M; f v \<noteq> 0\<rbrakk> \<Longrightarrow> v \<in> basis"
    and "\<And>v. \<lbrakk>v \<in> U\<^sub>M; g v \<noteq> 0\<rbrakk> \<Longrightarrow> v \<in> basis"
    and "finite {x \<in> U\<^sub>M. f x \<noteq> 0}"
    and "finite {x \<in> U\<^sub>M. g x \<noteq> 0}"
    and
      "(\<Sum>v\<in>{x \<in> U\<^sub>M. f x \<noteq> 0}. f v *s v) = (\<Sum>v\<in>{x \<in> U\<^sub>M. g x \<noteq> 0}. g v *s v)"
  shows "\<forall>x\<in>U\<^sub>M. f x = g x"
    is module.unique_representation[unfolded fun_eq_iff].

tts_lemma independentD_unique:
  assumes "B \<subseteq> U\<^sub>M"
    and "\<not> dependent B"
    and "finite {x \<in> U\<^sub>M. X x \<noteq> 0}"
    and "{x \<in> U\<^sub>M. X x \<noteq> 0} \<subseteq> B"
    and "finite {x \<in> U\<^sub>M. Y x \<noteq> 0}"
    and "{x \<in> U\<^sub>M. Y x \<noteq> 0} \<subseteq> B"
    and "(\<Sum>x | x \<in> U\<^sub>M \<and> X x \<noteq> 0. X x *s x) =
      (\<Sum>x | x \<in> U\<^sub>M \<and> Y x \<noteq> 0. Y x *s x)"
  shows "\<forall>x\<in>U\<^sub>M. X x = Y x"
    is module.independentD_unique[unfolded fun_eq_iff].

tts_lemma subspace_UNIV: "subspace U\<^sub>M"
  is module.subspace_UNIV.

tts_lemma span_UNIV: "span U\<^sub>M = U\<^sub>M"
  is module.span_UNIV.

tts_lemma span_alt:
  assumes "B \<subseteq> U\<^sub>M"
  shows
    "span B =
      {
        x \<in> U\<^sub>M. \<exists>f.
          x = (\<Sum>x | x \<in> U\<^sub>M \<and> f x \<noteq> 0. f x *s x) \<and>
          finite {x \<in> U\<^sub>M. f x \<noteq> 0} \<and>
          {x \<in> U\<^sub>M. f x \<noteq> 0} \<subseteq> B
      }"
    is module.span_alt.

tts_lemma dependent_alt:
  assumes "B \<subseteq> U\<^sub>M"
  shows "dependent B =
    (
      \<exists>f.
        finite {v \<in> U\<^sub>M. f v \<noteq> 0} \<and>
        {v \<in> U\<^sub>M. f v \<noteq> 0} \<subseteq> B \<and>
        (\<exists>v\<in>U\<^sub>M. f v \<noteq> 0) \<and>
        (\<Sum>x | x \<in> U\<^sub>M \<and> f x \<noteq> 0. f x *s x) = 0
    )"
    is module.dependent_alt.

tts_lemma independent_alt:
  assumes "B \<subseteq> U\<^sub>M"
  shows
    "(\<not> dependent B) =
      (
        \<forall>f.
          finite {x \<in> U\<^sub>M. f x \<noteq> 0} \<longrightarrow>
          {x \<in> U\<^sub>M. f x \<noteq> 0} \<subseteq> B \<longrightarrow>
          (\<Sum>x | x \<in> U\<^sub>M \<and> f x \<noteq> 0. f x *s x) = 0 \<longrightarrow>
          (\<forall>x\<in>U\<^sub>M. f x = 0)
    )"
    is module.independent_alt.

tts_lemma subspace_Int:
  assumes "range s \<subseteq> Pow U\<^sub>M" and "\<And>i. i \<in> I \<Longrightarrow> subspace (s i)"
  shows "subspace (\<Inter> (s ` I) \<inter> U\<^sub>M)"
    is module.subspace_Int.

tts_lemma subspace_Inter:
  assumes "f \<subseteq> Pow U\<^sub>M" and "Ball f subspace"
  shows "subspace (\<Inter> f \<inter> U\<^sub>M)"
    is module.subspace_Inter.

tts_lemma module_hom_scale_self: "module_hom_on U\<^sub>M U\<^sub>M (*s) (*s) ((*s) c)"
  is module.module_hom_scale_self.

tts_lemma module_hom_scale_left:
  assumes "x \<in> U\<^sub>M"
  shows "module_hom_on UNIV U\<^sub>M (*) (*s) (\<lambda>r. r *s x)"
  is module.module_hom_scale_left.

tts_lemma module_hom_id: "module_hom_on U\<^sub>M U\<^sub>M (*s) (*s) id"
  is module.module_hom_id.

tts_lemma module_hom_ident: "module_hom_on U\<^sub>M U\<^sub>M (*s) (*s) (\<lambda>x. x)"
  is module.module_hom_ident.

tts_lemma module_hom_uminus: "module_hom_on U\<^sub>M U\<^sub>M (*s) (*s) uminus"
  is module.module_hom_uminus.

end

tts_context
  tts: (?'b to \<open>U\<^sub>M::'b set\<close>)
  rewriting ctr_simps
  substituting implicit\<^sub>M.module_ow_axioms
    and implicit\<^sub>M.ab_group_add_ow_axioms
  eliminating \<open>?a \<in> U\<^sub>M\<close> and \<open>?B \<subseteq> U\<^sub>M\<close> through clarsimp
  applying
    [
      OF
        implicit\<^sub>M.carrier_ne
        implicit\<^sub>M.add_closed'
        implicit\<^sub>M.minus_closed'
        implicit\<^sub>M.uminus_closed'
        implicit\<^sub>M.scale_closed',
      unfolded tts_implicit
    ]
begin

tts_lemma span_explicit:
  assumes "b \<subseteq> U\<^sub>M"
  shows "span b =
    {x \<in> U\<^sub>M. \<exists>y\<subseteq>U\<^sub>M. \<exists>f. (finite y \<and> y \<subseteq> b) \<and> x = (\<Sum>a\<in>y. f a *s a)}"
  given module.span_explicit by auto

tts_lemma span_unique:
  assumes "S \<subseteq> U\<^sub>M"
    and "T \<subseteq> U\<^sub>M"
    and "S \<subseteq> T"
    and "subspace T"
    and "\<And>T'. \<lbrakk>T' \<subseteq> U\<^sub>M; S \<subseteq> T'; subspace T'\<rbrakk> \<Longrightarrow> T \<subseteq> T'"
  shows "span S = T"
    is module.span_unique.

tts_lemma dependent_explicit:
  assumes "V \<subseteq> U\<^sub>M"
  shows "dependent V =
    (\<exists>U\<subseteq>U\<^sub>M. \<exists>f. finite U \<and> U \<subseteq> V \<and> (\<exists>v\<in>U. f v \<noteq> 0) \<and> (\<Sum>v\<in>U. f v *s v) = 0)"
    given module.dependent_explicit by auto

tts_lemma independent_explicit_module:
  assumes "V \<subseteq> U\<^sub>M"
  shows "(\<not> dependent V) =
    (
      \<forall>U\<subseteq>U\<^sub>M. \<forall>f. \<forall>v\<in>U\<^sub>M.
        finite U \<longrightarrow>
        U \<subseteq> V \<longrightarrow>
        (\<Sum>u\<in>U. f u *s u) = 0 \<longrightarrow>
        v \<in> U \<longrightarrow>
        f v = 0
    )"
    given module.independent_explicit_module by auto

end

end

context module_pair_on
begin

tts_context
  tts: (?'b to \<open>U\<^sub>M\<^sub>_\<^sub>1::'b set\<close>) and (?'c to \<open>U\<^sub>M\<^sub>_\<^sub>2::'c set\<close>)
  rewriting ctr_simps
  substituting M\<^sub>1.implicit\<^sub>M.module_ow_axioms
    and M\<^sub>2.implicit\<^sub>M.module_ow_axioms
    and M\<^sub>1.implicit\<^sub>M.ab_group_add_ow_axioms
    and M\<^sub>2.implicit\<^sub>M.ab_group_add_ow_axioms
    and implicit\<^sub>M.module_pair_ow_axioms
  eliminating through auto
  applying [unfolded tts_implicit]
begin

tts_lemma module_hom_zero: "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. 0)"
    is module_pair.module_hom_zero.

tts_lemma module_hom_add:
  assumes "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. f x \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. g x \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) f"
    and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) g"
  shows "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. f x + g x)"
    is module_pair.module_hom_add.

tts_lemma module_hom_sub:
  assumes "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. f x \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. g x \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) f"
    and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) g"
  shows "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. f x - g x)"
    is module_pair.module_hom_sub.

tts_lemma module_hom_neg:
  assumes "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. f x \<in> U\<^sub>M\<^sub>_\<^sub>2" and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) f"
  shows "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. - f x)"
    is module_pair.module_hom_neg.

tts_lemma module_hom_scale:
  assumes "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. f x \<in> U\<^sub>M\<^sub>_\<^sub>2" and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) f"
  shows "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. c *s\<^sub>2 f x)"
    is module_pair.module_hom_scale.

tts_lemma module_hom_compose_scale:
  assumes "c \<in> U\<^sub>M\<^sub>_\<^sub>2" and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 UNIV (*s\<^sub>1) (*) f"
  shows "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. f x *s\<^sub>2 c)"
    is module_pair.module_hom_compose_scale.

tts_lemma module_hom_sum:
  assumes "\<forall>u. \<forall>v\<in>U\<^sub>M\<^sub>_\<^sub>1. f u v \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "\<And>i. i \<in> I \<Longrightarrow> module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (f i)"
    and "I = {} \<Longrightarrow> module_on U\<^sub>M\<^sub>_\<^sub>1 (*s\<^sub>1) \<and> module_on U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>2)"
  shows "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) (\<lambda>x. \<Sum>i\<in>I. f i x)"
  is module_pair.module_hom_sum.

tts_lemma module_hom_eq_on_span:
  assumes "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. f x \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "\<forall>x\<in>U\<^sub>M\<^sub>_\<^sub>1. g x \<in> U\<^sub>M\<^sub>_\<^sub>2"
    and "B \<subseteq> U\<^sub>M\<^sub>_\<^sub>1"
    and "x \<in> U\<^sub>M\<^sub>_\<^sub>1"
    and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) f"
    and "module_hom_on U\<^sub>M\<^sub>_\<^sub>1 U\<^sub>M\<^sub>_\<^sub>2 (*s\<^sub>1) (*s\<^sub>2) g"
    and "\<And>x. \<lbrakk>x \<in> U\<^sub>M\<^sub>_\<^sub>1; x \<in> B\<rbrakk> \<Longrightarrow> f x = g x"
    and "x \<in> M\<^sub>1.span B"
  shows "f x = g x"
    is module_pair.module_hom_eq_on_span.

end

end

text\<open>\newpage\<close>

end