(*  Title:      Util_NatInf.thy
    Date:       Oct 2006
    Author:     David Trachtenherz
*)

section \<open>Results for natural arithmetics with infinity\<close>

theory Util_NatInf
imports "HOL-Library.Extended_Nat"
begin

subsection \<open>Arithmetic operations with @{typ enat}\<close>

subsubsection \<open>Additional definitions\<close>

instantiation enat :: modulo
begin

definition
  div_enat_def [code del]: "
  a div b \<equiv> (case a of
    (enat x) \<Rightarrow> (case b of (enat y) \<Rightarrow> enat (x div y) | \<infinity> \<Rightarrow> 0) |
    \<infinity> \<Rightarrow> (case b of (enat y) \<Rightarrow> ((case y of 0 \<Rightarrow> 0 | Suc n \<Rightarrow> \<infinity>)) | \<infinity> \<Rightarrow> \<infinity> ))"
definition
  mod_enat_def [code del]: "
  a mod b \<equiv> (case a of
    (enat x) \<Rightarrow> (case b of (enat y) \<Rightarrow> enat (x mod y) | \<infinity> \<Rightarrow> a) |
    \<infinity> \<Rightarrow> \<infinity>)"

instance ..

end

lemmas enat_arith_defs =
  zero_enat_def one_enat_def
  plus_enat_def diff_enat_def times_enat_def div_enat_def mod_enat_def
declare zero_enat_def[simp]

lemmas ineq0_conv_enat[simp] = i0_less[symmetric, unfolded zero_enat_def]

lemmas iless_eSuc0_enat[simp] = iless_eSuc0[unfolded zero_enat_def]

subsubsection \<open>Addition, difference, order\<close>

lemma diff_eq_conv_nat: "(x - y = (z::nat)) = (if y < x then x = y + z else z = 0)"
by auto
lemma idiff_eq_conv: "
  (x - y = (z::enat)) =
  (if y < x then x = y + z else if x \<noteq> \<infinity> then z = 0 else z = \<infinity>)"
by (case_tac x, case_tac y, case_tac z, auto, case_tac z, auto)
lemmas idiff_eq_conv_enat = idiff_eq_conv[unfolded zero_enat_def]

lemma less_eq_idiff_eq_sum: "y \<le> (x::enat) \<Longrightarrow> (z \<le> x - y) = (z + y \<le> x)"
by (case_tac x, case_tac y, case_tac z, fastforce+)

lemma eSuc_pred: "0 < n \<Longrightarrow> eSuc (n - eSuc 0) = n"
apply (case_tac n)
apply (simp add: eSuc_enat)+
done
lemmas eSuc_pred_enat = eSuc_pred[unfolded zero_enat_def]
lemmas iadd_0_enat[simp] = add_0_left[where 'a = enat, unfolded zero_enat_def]
lemmas iadd_0_right_enat[simp] = add_0_right[where 'a=enat, unfolded zero_enat_def]

lemma ile_add1: "(n::enat) \<le> n + m"
by (case_tac m, case_tac n, simp_all)
lemma ile_add2: "(n::enat) \<le> m + n"
by (simp only: add.commute[of m] ile_add1)

lemma iadd_iless_mono: "\<lbrakk> (i::enat) < j; k < l \<rbrakk> \<Longrightarrow> i + k < j + l"
by (case_tac i, case_tac k, case_tac j, case_tac l, simp_all)

lemma trans_ile_iadd1: "i \<le> (j::enat) \<Longrightarrow> i \<le> j + m"
by (rule order_trans[OF _ ile_add1])
lemma trans_ile_iadd2: "i \<le> (j::enat) \<Longrightarrow> i \<le> m + j"
by (rule order_trans[OF _ ile_add2])

lemma trans_iless_iadd1: "i < (j::enat) \<Longrightarrow> i < j + m"
by (rule order_less_le_trans[OF _ ile_add1])
lemma trans_iless_iadd2: "i < (j::enat) \<Longrightarrow> i < m + j"
by (rule order_less_le_trans[OF _ ile_add2])

lemma iadd_ileD2: "m + k \<le> (n::enat) \<Longrightarrow> k \<le> n"
by (rule iadd_ileD1, simp only: add.commute[of m])

lemma idiff_ile_mono2: "m \<le> (n::enat) \<Longrightarrow> l - n \<le> l - m"
by (case_tac m, case_tac n, case_tac l, simp_all, case_tac l, simp_all)

lemma idiff_iless_mono: "\<lbrakk> m < (n::enat); l \<le> m \<rbrakk> \<Longrightarrow> m - l < n - l"
by (case_tac m, case_tac n, case_tac l, simp_all, case_tac l, simp_all)

lemma idiff_iless_mono2: "\<lbrakk> m < (n::enat); m < l \<rbrakk> \<Longrightarrow> l - n \<le> l - m"
by (case_tac m, case_tac n, case_tac l, simp_all, case_tac l, simp_all)

subsubsection \<open>Multiplication and division\<close>

lemmas imult_infinity_enat[simp] = imult_infinity[unfolded zero_enat_def]
lemmas imult_infinity_right_enat[simp] = imult_infinity_right[unfolded zero_enat_def]

lemma idiv_enat_enat[simp, code]: "enat a div enat b = enat (a div b)"
unfolding div_enat_def by simp

lemma idiv_infinity: "0 < n \<Longrightarrow> (\<infinity>::enat) div n = \<infinity>"
unfolding div_enat_def
apply (case_tac n, simp_all)
apply (rename_tac n1, case_tac n1, simp_all)
done

lemmas idiv_infinity_enat[simp] = idiv_infinity[unfolded zero_enat_def]

lemma idiv_infinity_right[simp]: "n \<noteq> \<infinity> \<Longrightarrow> n div (\<infinity>::enat) = 0"
unfolding div_enat_def by (case_tac n, simp_all)

lemma idiv_infinity_if: "n div \<infinity> = (if n = \<infinity> then \<infinity> else 0::enat)"
unfolding div_enat_def
by (case_tac n, simp_all)

lemmas idiv_infinity_if_enat = idiv_infinity_if[unfolded zero_enat_def]

lemmas imult_0_enat[simp] = mult_zero_left[where 'a=enat,unfolded zero_enat_def]
lemmas imult_0_right_enat[simp] = mult_zero_right[where 'a=enat,unfolded zero_enat_def]

lemmas imult_is_0_enat = imult_is_0[unfolded zero_enat_def]
lemmas enat_0_less_mult_iff_enat = enat_0_less_mult_iff[unfolded zero_enat_def]

lemma imult_infinity_if: "\<infinity> * n = (if n = 0 then 0 else \<infinity>::enat)"
by (case_tac n, simp_all)
lemma imult_infinity_right_if: "n * \<infinity> = (if n = 0 then 0 else \<infinity>::enat)"
by (case_tac n, simp_all)
lemmas imult_infinity_if_enat = imult_infinity_if[unfolded zero_enat_def]
lemmas imult_infinity_right_if_enat = imult_infinity_right_if[unfolded zero_enat_def]

lemmas imult_is_infinity_enat = imult_is_infinity[unfolded zero_enat_def]

lemma idiv_by_0: "(a::enat) div 0 = 0"
unfolding div_enat_def by (case_tac a, simp_all)
lemmas idiv_by_0_enat[simp, code] = idiv_by_0[unfolded zero_enat_def]

lemma idiv_0: "0 div (a::enat) = 0"
unfolding div_enat_def by (case_tac a, simp_all)
lemmas idiv_0_enat[simp, code] = idiv_0[unfolded zero_enat_def]

lemma imod_by_0: "(a::enat) mod 0 = a"
unfolding mod_enat_def by (case_tac a, simp_all)
lemmas imod_by_0_enat[simp, code] = imod_by_0[unfolded zero_enat_def]

lemma imod_0: "0 mod (a::enat) = 0"
unfolding mod_enat_def by (case_tac a, simp_all)
lemmas imod_0_enat[simp, code] = imod_0[unfolded zero_enat_def]

lemma imod_enat_enat[simp, code]: "enat a mod enat b = enat (a mod b)"
unfolding mod_enat_def by simp
lemma imod_infinity[simp, code]: "\<infinity> mod n = (\<infinity>::enat)"
unfolding mod_enat_def by simp
lemma imod_infinity_right[simp, code]: "n mod (\<infinity>::enat) = n"
unfolding mod_enat_def by (case_tac n) simp_all

lemma idiv_self: "\<lbrakk> 0 < (n::enat); n \<noteq> \<infinity> \<rbrakk> \<Longrightarrow> n div n = 1"
by (case_tac n, simp_all add: one_enat_def)
lemma imod_self: "n \<noteq> \<infinity> \<Longrightarrow> (n::enat) mod n = 0"
by (case_tac n, simp_all)

lemma idiv_iless: "m < (n::enat) \<Longrightarrow> m div n = 0"
by (case_tac m, simp_all) (case_tac n, simp_all)
lemma imod_iless: "m < (n::enat) \<Longrightarrow> m mod n = m"
by (case_tac m, simp_all) (case_tac n, simp_all)

lemma imod_iless_divisor: "\<lbrakk> 0 < (n::enat); m \<noteq> \<infinity> \<rbrakk>  \<Longrightarrow> m mod n < n"
by (case_tac m, simp_all) (case_tac n, simp_all)
lemma imod_ile_dividend: "(m::enat) mod n \<le> m"
by (case_tac m, simp_all) (case_tac n, simp_all)
lemma idiv_ile_dividend: "(m::enat) div n \<le> m"
by (case_tac m, simp_all) (case_tac n, simp_all)

lemma idiv_imult2_eq: "(a::enat) div (b * c) = a div b div c"
apply (case_tac a, case_tac b, case_tac c, simp_all add: div_mult2_eq)
apply (simp add: imult_infinity_if)
apply (case_tac "b = 0", simp)
apply (case_tac "c = 0", simp)
apply (simp add: idiv_infinity[OF enat_0_less_mult_iff[THEN iffD2]])
done

lemma imult_ile_mono: "\<lbrakk> (i::enat) \<le> j; k \<le> l \<rbrakk> \<Longrightarrow> i * k \<le> j * l"
apply (case_tac i, case_tac j, case_tac k, case_tac l, simp_all add: mult_le_mono)
apply (case_tac k, case_tac l, simp_all)
apply (case_tac k, case_tac l, simp_all)
done

lemma imult_ile_mono1: "(i::enat) \<le> j \<Longrightarrow> i * k \<le> j * k"
by (rule imult_ile_mono[OF _ order_refl])

lemma imult_ile_mono2: "(i::enat) \<le> j \<Longrightarrow> k * i \<le> k * j"
by (rule imult_ile_mono[OF order_refl])

lemma imult_iless_mono1: "\<lbrakk> (i::enat) < j; 0 < k; k \<noteq> \<infinity> \<rbrakk> \<Longrightarrow> i * k \<le> j * k"
by (case_tac i, case_tac j, case_tac k, simp_all)
lemma imult_iless_mono2: "\<lbrakk> (i::enat) < j; 0 < k; k \<noteq> \<infinity> \<rbrakk> \<Longrightarrow> k * i \<le> k * j"
by (simp only: mult.commute[of k], rule imult_iless_mono1)

lemma imod_1: "(enat m) mod eSuc 0 = 0"
by (simp add: eSuc_enat)
lemmas imod_1_enat[simp, code] = imod_1[unfolded zero_enat_def]

lemma imod_iadd_self2: "(m + enat n) mod (enat n) = m mod (enat n)"
by (case_tac m, simp_all)

lemma imod_iadd_self1: "(enat n + m) mod (enat n) = m mod (enat n)"
by (simp only: add.commute[of _ m] imod_iadd_self2)

lemma idiv_imod_equality: "(m::enat) div n * n + m mod n + k = m + k"
by (case_tac m, simp_all) (case_tac n, simp_all)
lemma imod_idiv_equality: "(m::enat) div n * n + m mod n = m"
by (insert idiv_imod_equality[of m n 0], simp)

lemma idiv_ile_mono: "m \<le> (n::enat) \<Longrightarrow> m div k \<le> n div k"
apply (case_tac "k = 0", simp)
apply (case_tac m, case_tac k, simp_all)
apply (case_tac n)
 apply (simp add: div_le_mono)
apply (simp add: idiv_infinity)
apply (simp add: i0_lb[unfolded zero_enat_def])
done
lemma idiv_ile_mono2: "\<lbrakk> 0 < m; m \<le> (n::enat) \<rbrakk> \<Longrightarrow> k div n \<le> k div m"
apply (case_tac "n = 0", simp)
apply (case_tac m, case_tac k, simp_all)
apply (case_tac n)
 apply (simp add: div_le_mono2)
apply simp
done

end


header {* Algebra of Monotonic Boolean Transformers *}

theory  Mono_Bool_Tran_Algebra
imports Mono_Bool_Tran
begin

text{*
In this section we introduce the {\em algebra of monotonic boolean transformers}.
This is a bounded distributive lattice with a monoid operation, a
dual operator and an iteration operator. The standard model for this
algebra is the set of monotonic boolean transformers introduced
in the previous section.
*}

class dual =
  fixes dual::"'a \<Rightarrow> 'a" ("_ ^ o" [81] 80)

class omega =
  fixes omega::"'a \<Rightarrow> 'a" ("_ ^ \<omega>" [81] 80)

class star =
  fixes star::"'a \<Rightarrow> 'a" ("(_ ^ *)" [81] 80)

class dual_star =
  fixes dual_star::"'a \<Rightarrow> 'a" ("(_ ^ \<otimes>)" [81] 80)

class mbt_algebra = monoid_mult + dual + omega + distrib_lattice + order_top + order_bot + star + dual_star +
  assumes
      dual_le: "(x \<le> y) = (y ^ o \<le> x ^ o)"
  and dual_dual [simp]: "(x ^ o) ^ o = x"
  and dual_comp: "(x * y) ^ o = x ^ o * y ^ o"
  and dual_one [simp]: "1 ^ o = 1"
  and top_comp [simp]: "\<top> * x = \<top>"
  and inf_comp: "(x \<sqinter> y) * z = (x * z) \<sqinter> (y * z)"
  and le_comp: "x \<le> y \<Longrightarrow> z * x \<le> z * y"
  and dual_neg: "(x * \<top>) \<sqinter> (x ^ o * \<bottom>) = \<bottom>"
  and omega_fix: "x ^ \<omega> = (x * (x ^ \<omega>)) \<sqinter> 1"
  and omega_least: "(x * z) \<sqinter> y \<le> z \<Longrightarrow> (x ^ \<omega>) * y \<le> z"
  and star_fix: "x ^ * = (x * (x ^ *)) \<sqinter> 1"
  and star_greatest: "z \<le> (x * z) \<sqinter> y \<Longrightarrow> z \<le> (x ^ *) * y"
  and dual_star_def: "(x ^ \<otimes>) = (((x ^ o) ^ *) ^ o)"
begin

lemma le_comp_right: "x \<le> y \<Longrightarrow> x * z \<le> y * z"
  apply (cut_tac x = x and y = y and z = z in inf_comp)
  apply (simp add: inf_absorb1)
  apply (subgoal_tac "x * z \<sqinter> (y * z) \<le> y * z")
  apply simp
  by (rule inf_le2)

subclass bounded_lattice
  proof qed

end

instantiation MonoTran :: (complete_boolean_algebra) mbt_algebra
begin

lift_definition dual_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
  is dual_fun
  by (fact mono_dual_fun)

lift_definition omega_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
  is omega_fun
  by (fact mono_omega_fun)

lift_definition star_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
  is star_fun
  by (fact mono_star_fun)

definition dual_star_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran"
where
  "(x::('a MonoTran)) ^ \<otimes> = ((x ^ o) ^ *) ^ o"

instance proof
  fix x y :: "'a MonoTran" show "(x \<le> y) = (y ^ o \<le> x ^ o)"
    apply transfer
    apply (auto simp add: fun_eq_iff le_fun_def)
    apply (drule_tac x = "-xa" in spec)
    apply simp
    done
next
  fix x :: "'a MonoTran" show "(x ^ o) ^ o = x"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x y :: "'a MonoTran" show "(x * y) ^ o = x ^ o * y ^ o"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  show "(1\<Colon>'a MonoTran) ^ o = 1"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x :: "'a MonoTran" show "\<top> * x = \<top>"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x y z :: "'a MonoTran" show "(x \<sqinter> y) * z = (x * z) \<sqinter> (y * z)"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
next
  fix x y z :: "'a MonoTran" assume A: "x \<le> y" from A show " z * x \<le> z * y"
    apply transfer
    apply (auto simp add: le_fun_def elim: monoE)
    done
next
  fix x :: "'a MonoTran" show "x * \<top> \<sqinter> (x ^ o * \<bottom>) = \<bottom>"
    apply transfer
    apply (simp add: fun_eq_iff inf_compl_bot)
    done
next
  fix x :: "'a MonoTran" show "x ^ \<omega> = x * x ^ \<omega> \<sqinter> 1"
    apply transfer
    apply (simp add: fun_eq_iff)
    apply (simp add: omega_fun_def Omega_fun_def)
    apply (subst lfp_unfold, simp_all add: ac_simps)
    apply (auto intro!: mono_comp mono_comp_fun)
    done
next
  fix x y z :: "'a MonoTran" assume A: "x * z \<sqinter> y \<le> z" from A show "x ^ \<omega> * y \<le> z"
    apply transfer
    apply (auto simp add: lfp_omega lfp_def)
    apply (rule Inf_lower)
    apply (auto simp add: Omega_fun_def ac_simps)
    done
next
  fix x :: "'a MonoTran" show "x ^ * = x * x ^ * \<sqinter> 1"
    apply transfer
    apply (auto simp add: star_fun_def Omega_fun_def)
    apply (subst gfp_unfold, simp_all add: ac_simps)
    apply (auto intro!: mono_comp mono_comp_fun)
    done
next
  fix x y z :: "'a MonoTran" assume A: "z \<le> x * z \<sqinter> y" from A show "z \<le> x ^ * * y"
    apply transfer
    apply (auto simp add: gfp_star gfp_def)
    apply (rule Sup_upper)
    apply (auto simp add: Omega_fun_def)
    done
next
  fix x :: "'a MonoTran" show "x ^ \<otimes> = ((x ^ o) ^ *) ^ o"
    by (simp add: dual_star_MonoTran_def)
qed

end

context mbt_algebra begin

lemma dual_top [simp]: "\<top> ^ o = \<bottom>"
  apply (rule antisym, simp_all)
  by (subst dual_le, simp)

lemma dual_bot [simp]: "\<bottom> ^ o = \<top>"
  apply (rule antisym, simp_all)
  by (subst dual_le, simp)

lemma dual_inf: "(x \<sqinter> y) ^ o = (x ^ o) \<squnion> (y ^ o)"
  apply (rule antisym, simp_all, safe)
  apply (subst dual_le, simp, safe)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp)
  by (subst dual_le, simp)

lemma dual_sup: "(x \<squnion> y) ^ o = (x ^ o) \<sqinter> (y ^ o)"
  apply (rule antisym, simp_all, safe)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp)
  apply (subst dual_le, simp, safe)
  apply (subst dual_le, simp)
  by (subst dual_le, simp)

lemma sup_comp: "(x \<squnion> y) * z = (x * z) \<squnion> (y * z)"
  apply (subgoal_tac "((x ^ o \<sqinter> y ^ o) * z ^ o) ^ o = ((x ^ o * z ^ o) \<sqinter> (y ^ o * z ^ o)) ^ o")
  apply (simp add: dual_inf dual_comp)
  by (simp add: inf_comp)

lemma dual_eq: "x ^ o = y ^ o \<Longrightarrow> x = y"
  apply (subgoal_tac "(x ^ o) ^ o = (y ^ o) ^ o")
  apply (subst (asm) dual_dual)
  apply (subst (asm) dual_dual)
  by simp_all

lemma dual_neg_top [simp]: "(x ^ o * \<bottom>) \<squnion> (x * \<top>) = \<top>"
  apply (rule dual_eq)
  by(simp add: dual_sup dual_comp dual_neg)

lemma [simp]: "(x * \<bottom>) * y = x * \<bottom>"
  by (simp add: mult.assoc)

lemma gt_one_comp: "1 \<le> x \<Longrightarrow> y \<le> x * y"
  by (cut_tac x = 1 and y = x and z = y in le_comp_right, simp_all)

  theorem omega_comp_fix: "x ^ \<omega> * y = (x * (x ^ \<omega>) * y) \<sqinter> y"
  apply (subst omega_fix)
  by (simp add: inf_comp)

  theorem dual_star_fix: "x^\<otimes> = (x * (x^\<otimes>)) \<squnion> 1"
    by (metis dual_comp dual_dual dual_inf dual_one dual_star_def star_fix)

  theorem star_comp_fix: "x ^ * * y = (x * (x ^ *) * y) \<sqinter> y"
  apply (subst star_fix)
  by (simp add: inf_comp)

  theorem dual_star_comp_fix: "x^\<otimes> * y = (x * (x^\<otimes>) * y) \<squnion> y"
  apply (subst dual_star_fix)
  by (simp add: sup_comp)

  theorem dual_star_least: "(x * z) \<squnion> y \<le> z \<Longrightarrow> (x^\<otimes>) * y \<le> z"
    apply (subst dual_le)
    apply (simp add: dual_star_def dual_comp)
    apply (rule star_greatest)
    apply (subst dual_le)
    by (simp add: dual_inf dual_comp)

  lemma omega_one [simp]: "1 ^ \<omega> = \<bottom>"
    apply (rule antisym, simp_all)
    by (cut_tac x = "1::'a" and y = 1 and z = \<bottom> in omega_least, simp_all)

  lemma omega_mono: "x \<le> y \<Longrightarrow> x ^ \<omega> \<le> y ^ \<omega>"
    apply (cut_tac x = x and y = 1 and z = "y ^ \<omega>" in omega_least, simp_all)
    apply (subst (2) omega_fix, simp_all)
    apply (rule_tac y = "x * y ^ \<omega>" in order_trans, simp)
    by (rule le_comp_right, simp)
end

sublocale mbt_algebra < conjunctive "inf" "inf" "times"
done
sublocale mbt_algebra < disjunctive "sup" "sup" "times"
done

context mbt_algebra begin
lemma dual_conjunctive: "x \<in> conjunctive \<Longrightarrow> x ^ o \<in> disjunctive"
  apply (simp add: conjunctive_def disjunctive_def)
  apply safe
  apply (rule dual_eq)
  by (simp add: dual_comp dual_sup)

lemma dual_disjunctive: "x \<in> disjunctive \<Longrightarrow> x ^ o \<in> conjunctive"
  apply (simp add: conjunctive_def disjunctive_def)
  apply safe
  apply (rule dual_eq)
  by (simp add: dual_comp dual_inf)

lemma comp_pres_conj: "x \<in> conjunctive \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> x * y \<in> conjunctive"
  apply (subst conjunctive_def, safe)
  by (simp add: mult.assoc conjunctiveD)

lemma comp_pres_disj: "x \<in> disjunctive \<Longrightarrow> y \<in> disjunctive \<Longrightarrow> x * y \<in> disjunctive"
  apply (subst disjunctive_def, safe)
  by (simp add: mult.assoc disjunctiveD)

lemma start_pres_conj: "x \<in> conjunctive \<Longrightarrow> (x ^ *) \<in> conjunctive"
  apply (subst conjunctive_def, safe)
  apply (rule antisym, simp_all)
  apply (metis inf_le1 inf_le2 le_comp)
  apply (rule star_greatest)
  apply (subst conjunctiveD, simp)
  apply (subst star_comp_fix)
  apply (subst star_comp_fix)
  by (metis inf.assoc inf_left_commute mult.assoc order_refl)

lemma dual_star_pres_disj: "x \<in> disjunctive \<Longrightarrow> x^\<otimes> \<in> disjunctive"
  apply (simp add: dual_star_def)
  apply (rule dual_conjunctive)
  apply (rule start_pres_conj)
  by (rule dual_disjunctive, simp)

subsection{*Assertions*}

text{*
Usually, in Kleene algebra with tests or in other progrm algebras, tests or assertions
or assumptions are defined using an existential quantifier. An element of the algebra
is a test if it has a complement with respect to $\bot$ and $1$. In this formalization
assertions can be defined much simpler using the dual operator.
*}

definition
   "assertion = {x . x \<le> 1 \<and> (x * \<top>) \<sqinter> (x ^ o) = x}"

lemma assertion_prop: "x \<in> assertion \<Longrightarrow> (x * \<top>) \<sqinter> 1 = x"
  apply (simp add: assertion_def)
  apply safe
  apply (rule antisym)
  apply simp_all
  proof -
    assume [simp]: "x \<le> 1"
    assume A: "x * \<top> \<sqinter> x ^ o = x"
    have "x * \<top> \<sqinter> 1 \<le> x * \<top> \<sqinter> x ^ o"
      apply simp
      apply (rule_tac y = 1 in order_trans)
      apply simp
      apply (subst dual_le)
      by simp
    also have "\<dots> = x" by (cut_tac A, simp)
    finally show "x * \<top> \<sqinter> 1 \<le> x" .
  next
    assume A: "x * \<top> \<sqinter> x ^ o = x"
    have "x = x * \<top> \<sqinter> x ^ o" by (simp add: A)
    also have "\<dots> \<le> x * \<top>" by simp
    finally show "x \<le> x * \<top>" .
  qed

lemma dual_assertion_prop: "x \<in> assertion \<Longrightarrow> ((x ^ o) * \<bottom>) \<squnion> 1 = x ^ o"
  apply (rule dual_eq)
  by (simp add: dual_sup dual_comp assertion_prop)

lemma assertion_disjunctive: "x \<in> assertion \<Longrightarrow> x \<in> disjunctive"
  apply (simp add: disjunctive_def, safe)
  apply (drule assertion_prop)
  proof -
    assume A: "x * \<top> \<sqinter> 1 = x"
    fix y z::"'a"
    have "x * (y \<squnion> z) = (x * \<top> \<sqinter> 1) * (y \<squnion> z)" by (cut_tac  A, simp)
    also have "\<dots> = (x * \<top>) \<sqinter> (y \<squnion> z)" by (simp add: inf_comp)
    also have "\<dots> = ((x * \<top>) \<sqinter> y) \<squnion> ((x * \<top>) \<sqinter> z)" by (simp add: inf_sup_distrib)
    also have "\<dots> = (((x * \<top>) \<sqinter> 1) * y) \<squnion> (((x * \<top>) \<sqinter> 1) * z)" by (simp add: inf_comp)
    also have "\<dots> = x * y \<squnion> x * z" by (cut_tac  A, simp)
    finally show "x * (y \<squnion> z) = x * y \<squnion> x * z" .
  qed

lemma Abs_MonoTran_injective: "mono x \<Longrightarrow> mono y \<Longrightarrow> Abs_MonoTran x = Abs_MonoTran y \<Longrightarrow> x = y"
  apply (subgoal_tac "Rep_MonoTran (Abs_MonoTran x) = Rep_MonoTran (Abs_MonoTran y)")
  apply (subst (asm) Abs_MonoTran_inverse, simp)
  by (subst (asm) Abs_MonoTran_inverse, simp_all)
end

lemma mbta_MonoTran_disjunctive: "Rep_MonoTran ` disjunctive = Apply.disjunctive"
  apply (simp add: disjunctive_def Apply.disjunctive_def)
  apply transfer
  apply auto
  proof -
    fix f :: "'a \<Rightarrow> 'a" and a b
    assume prem: "\<forall>y. mono y \<longrightarrow> (\<forall>z. mono z \<longrightarrow> f \<circ> y \<squnion> z = (f \<circ> y) \<squnion> (f \<circ> z))"
    { fix g h :: "'b \<Rightarrow> 'a"
      assume "mono g" and "mono h"
      then have "f \<circ> g \<squnion> h = (f \<circ> g) \<squnion> (f \<circ> h)"
        using prem by blast
    } note * = this
    assume "mono f"
    show "f (a \<squnion> b) = f a \<squnion> f b" (is "?P = ?Q")
    proof (rule order_antisym)
      show "?P \<le> ?Q"
        using * [of "\<lambda>_. a" "\<lambda>_. b"] by (simp add: comp_def fun_eq_iff)
    next
      from `mono f` show "?Q \<le> ?P" by (rule Lattices.semilattice_sup_class.mono_sup)
    qed
  next
    fix f :: "'a \<Rightarrow> 'a"
    assume "\<forall>y z. f (y \<squnion> z) = f y \<squnion> f z"
    then have *: "\<And>y z. f (y \<squnion> z) = f y \<squnion> f z" by blast
    show "mono f"
    proof
      fix a b :: 'a
      assume "a \<le> b"
      then show "f a \<le> f b"
        unfolding sup.order_iff * [symmetric] by simp
    qed
  qed

lemma assertion_MonoTran: "assertion = Abs_MonoTran ` assertion_fun"
    apply (safe)
    apply (subst assertion_fun_disj_less_one)
    apply (simp add: image_def)
    apply (rule_tac x = "Rep_MonoTran x" in bexI)
    apply (simp add: Rep_MonoTran_inverse)
    apply safe
    apply (drule assertion_disjunctive)
    apply (unfold mbta_MonoTran_disjunctive [THEN sym], simp)
    apply (simp add: assertion_def less_eq_MonoTran_def one_MonoTran_def Abs_MonoTran_inverse)
    apply (simp add: assertion_def)
    by (simp_all add: inf_MonoTran_def less_eq_MonoTran_def
      times_MonoTran_def dual_MonoTran_def top_MonoTran_def Abs_MonoTran_inverse one_MonoTran_def assertion_fun_dual)

context mbt_algebra begin
lemma assertion_conjunctive: "x \<in> assertion \<Longrightarrow> x \<in> conjunctive"
  apply (simp add: conjunctive_def, safe)
  apply (drule assertion_prop)
  proof -
    assume A: "x * \<top> \<sqinter> 1 = x"
    fix y z::"'a"
    have "x * (y \<sqinter> z) = (x * \<top> \<sqinter> 1) * (y \<sqinter> z)" by (cut_tac  A, simp)
    also have "\<dots> = (x * \<top>) \<sqinter> (y \<sqinter> z)" by (simp add: inf_comp)
    also have "\<dots> = ((x * \<top>) \<sqinter> y) \<sqinter> ((x * \<top>) \<sqinter> z)"
      apply (rule antisym, simp_all, safe)
      apply (rule_tac y = "y \<sqinter> z" in order_trans)
      apply (rule inf_le2)
      apply simp
      apply (rule_tac y = "y \<sqinter> z" in order_trans)
      apply (rule inf_le2)
      apply simp_all
      apply (simp add: inf_assoc)
      apply (rule_tac y = " x * \<top> \<sqinter> y" in order_trans)
      apply (rule inf_le1)
      apply simp
      apply (rule_tac y = " x * \<top> \<sqinter> z" in order_trans)
      apply (rule inf_le2)
      by simp
    also have "\<dots> = (((x * \<top>) \<sqinter> 1) * y) \<sqinter> (((x * \<top>) \<sqinter> 1) * z)" by (simp add: inf_comp)
    also have "\<dots> = (x * y) \<sqinter> (x * z)" by (cut_tac  A, simp)
    finally show "x * (y \<sqinter> z) = (x * y) \<sqinter> (x * z)" .
  qed

lemma dual_assertion_conjunctive: "x \<in> assertion \<Longrightarrow> x ^ o \<in> conjunctive"
  apply (drule assertion_disjunctive)
  by (rule dual_disjunctive, simp)

lemma dual_assertion_disjunct: "x \<in> assertion \<Longrightarrow> x ^ o \<in> disjunctive"
  apply (drule assertion_conjunctive)
  by (rule dual_conjunctive, simp)

lemma [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<sqinter> y \<le> x * y"
  apply (simp add: assertion_def, safe)
  proof -
  assume A: "x \<le> 1"
  assume B: "x * \<top> \<sqinter> x ^ o = x"
  assume C: "y \<le> 1"
  assume D: "y * \<top> \<sqinter> y ^ o = y"
  have "x \<sqinter> y = (x * \<top> \<sqinter> x ^ o) \<sqinter> (y * \<top> \<sqinter> y ^ o)" by (cut_tac B D, simp)
  also have "\<dots> \<le> (x * \<top>) \<sqinter> (((x^o) * (y * \<top>)) \<sqinter> ((x^o) * (y^o)))"
    apply (simp, safe)
      apply (rule_tac y = "x * \<top> \<sqinter> x ^ o" in order_trans)
      apply (rule inf_le1)
      apply simp
      apply (rule_tac y = "y * \<top>" in order_trans)
      apply (rule_tac y = "y * \<top> \<sqinter> y ^ o" in order_trans)
      apply (rule inf_le2)
      apply simp
      apply (rule gt_one_comp)
      apply (subst dual_le, simp add: A)
      apply (rule_tac y = "y ^ o" in order_trans)
      apply (rule_tac y = "y * \<top> \<sqinter> y ^ o" in order_trans)
      apply (rule inf_le2)
      apply simp
      apply (rule gt_one_comp)
      by (subst dual_le, simp add: A)
    also have "... = ((x * \<top>) \<sqinter> (x ^ o)) * ((y * \<top>) \<sqinter> (y ^ o))"
      apply (cut_tac x = x in dual_assertion_conjunctive)
      apply (cut_tac A, cut_tac B, simp add: assertion_def)
      by (simp add: inf_comp conjunctiveD)
    also have "... = x * y"
      by (cut_tac B, cut_tac D, simp)
    finally show "x \<sqinter> y \<le> x * y" .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> x * y \<le> y"
  by (unfold assertion_def, cut_tac x = x and y = 1 and z = y in le_comp_right, simp_all)

lemma [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x * y \<le> x"
  apply (subgoal_tac "x * y \<le> (x * \<top>) \<sqinter> (x ^ o)")
  apply (simp add: assertion_def)
  apply (simp, safe)
  apply (rule le_comp, simp)
  apply (rule_tac y = 1 in order_trans)
  apply (rule_tac y = y in order_trans)
  apply simp
  apply (simp add: assertion_def)
  by (subst dual_le, simp add: assertion_def)

lemma assertion_inf_comp_eq: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<sqinter> y = x * y"
  by (rule antisym, simp_all)

lemma one_right_assertion [simp]: "x \<in> assertion \<Longrightarrow> x * 1 = x"
  apply (drule assertion_prop)
  proof -
    assume A: "x * \<top> \<sqinter> 1 = x"
    have "x * 1 = (x * \<top> \<sqinter> 1) * 1" by (simp add: A)
    also have "\<dots> = x * \<top> \<sqinter> 1" by (simp add: inf_comp)
    also have "\<dots> = x" by (simp add: A)
    finally show ?thesis .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> x \<squnion> 1 = 1"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]: "x \<in> assertion \<Longrightarrow> 1 \<squnion> x = 1"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]: "x \<in> assertion \<Longrightarrow> x \<sqinter> 1 = x"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]: "x \<in> assertion \<Longrightarrow> 1 \<sqinter> x = x"
  by (rule antisym, simp_all add: assertion_def)

lemma [simp]:  "x \<in> assertion \<Longrightarrow> x \<le> x * \<top>"
  by (cut_tac x = 1 and y = \<top> and z = x in le_comp, simp_all)

lemma [simp]: "x \<in> assertion \<Longrightarrow> x \<le> 1"
  by (simp add: assertion_def)

definition
  "neg_assert (x::'a) = (x ^ o * \<bottom>) \<sqinter> 1"

lemma sup_uminus[simp]: "x \<in> assertion \<Longrightarrow> x \<squnion> neg_assert x = 1"
  apply (simp add: neg_assert_def)
  apply (simp add: sup_inf_distrib)
  apply (rule antisym, simp_all)
  apply (unfold assertion_def)
  apply safe
  apply (subst dual_le)
  apply (simp add: dual_sup dual_comp)
  apply (subst inf_commute)
  by simp

lemma inf_uminus[simp]: "x \<in> assertion \<Longrightarrow> x \<sqinter> neg_assert x = \<bottom>"
  apply (simp add: neg_assert_def)
  apply (rule antisym, simp_all)
  apply (rule_tac y = "x \<sqinter> (x ^ o * \<bottom>)" in order_trans)
  apply simp
  apply (rule_tac y = "x ^ o * \<bottom> \<sqinter> 1" in order_trans)
  apply (rule inf_le2)
  apply simp
  apply (rule_tac y = "(x * \<top>)  \<sqinter> (x ^ o * \<bottom>)" in order_trans)
  apply simp
  apply (rule_tac y = x in order_trans)
  apply simp_all
  by (simp add: dual_neg)

lemma uminus_assertion[simp]: "x \<in> assertion \<Longrightarrow> neg_assert x \<in> assertion"
  apply (subst assertion_def)
  apply (simp add: neg_assert_def)
  apply (simp add: inf_comp dual_inf dual_comp inf_sup_distrib)
  apply (subst inf_commute)
  by (simp add: dual_neg)

lemma uminus_uminus [simp]: "x \<in> assertion \<Longrightarrow> neg_assert (neg_assert x) = x"
  apply (simp add: neg_assert_def)
  by (simp add: dual_inf dual_comp sup_comp assertion_prop)

lemma dual_comp_neg [simp]: "x ^ o * y \<squnion> (neg_assert x) * \<top> = x ^ o * y"
  apply (simp add: neg_assert_def inf_comp)
  apply (rule antisym, simp_all)
  by (rule le_comp, simp)

lemma [simp]: "(neg_assert x) ^ o * y \<squnion> x * \<top> = (neg_assert x) ^ o * y"
  apply (simp add: neg_assert_def inf_comp dual_inf dual_comp sup_comp)
  by (rule antisym, simp_all)

lemma [simp]: " x * \<top> \<squnion> (neg_assert x) ^ o * y= (neg_assert x) ^ o * y"
  by (simp add: neg_assert_def inf_comp dual_inf dual_comp sup_comp)

lemma inf_assertion [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<sqinter> y \<in> assertion"
  apply (subst assertion_def)
  apply safe
  apply (rule_tac y = x in order_trans)
  apply simp_all
  apply (simp add: assertion_inf_comp_eq)
  proof -
    assume A: "x \<in> assertion"
    assume B: "y \<in> assertion"
    have C: "(x * \<top>) \<sqinter> (x ^ o) = x"
      by (cut_tac A, unfold assertion_def, simp)
    have D: "(y * \<top>) \<sqinter> (y ^ o) = y"
      by (cut_tac B, unfold assertion_def, simp)
    have "x * y = ((x * \<top>) \<sqinter> (x ^ o)) * ((y * \<top>) \<sqinter> (y ^ o))" by (simp add: C D)
    also have "\<dots> = x * \<top> \<sqinter> ((x ^ o) * ((y * \<top>) \<sqinter> (y ^ o)))" by (simp add: inf_comp)
    also have "\<dots> =  x * \<top> \<sqinter> ((x ^ o) * (y * \<top>)) \<sqinter> ((x ^ o) *(y ^ o))"
      by (cut_tac A, cut_tac x = x in dual_assertion_conjunctive, simp_all add: conjunctiveD inf_assoc)
    also have "\<dots> = (((x * \<top>) \<sqinter> (x ^ o)) * (y * \<top>)) \<sqinter> ((x ^ o) *(y ^ o))"
      by (simp add: inf_comp)
    also have "\<dots> = (x * y * \<top>)  \<sqinter> ((x * y) ^ o)" by (simp add: C mult.assoc dual_comp)
    finally show "(x * y * \<top>)  \<sqinter> ((x * y) ^ o) = x * y" by simp
  qed

lemma comp_assertion [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x * y \<in> assertion"
  by (subst assertion_inf_comp_eq [THEN sym], simp_all)

lemma sup_assertion [simp]: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> x \<squnion> y \<in> assertion"
  apply (subst assertion_def)
  apply safe
  apply (unfold assertion_def)
  apply simp
  apply safe
  proof -
    assume [simp]: "x \<le> 1"
    assume [simp]: "y \<le> 1"
    assume A: "x * \<top> \<sqinter> x ^ o = x"
    assume B: "y * \<top> \<sqinter> y ^ o = y"
    have "(y * \<top>) \<sqinter> (x ^ o) \<sqinter> (y ^ o) = (x ^ o) \<sqinter> (y * \<top>) \<sqinter> (y ^ o)" by (simp add: inf_commute)
    also have "\<dots> = (x ^ o) \<sqinter> ((y * \<top>) \<sqinter> (y ^ o))" by (simp add: inf_assoc)
    also have "\<dots> = (x ^ o) \<sqinter> y" by (simp add: B)
    also have "\<dots> = y"
      apply (rule antisym, simp_all)
      apply (rule_tac y = 1 in order_trans)
      apply simp
      by (subst dual_le, simp)
    finally have [simp]: "(y * \<top>) \<sqinter> (x ^ o) \<sqinter> (y ^ o) = y" .
    have "x * \<top> \<sqinter> (x ^ o) \<sqinter> (y ^ o) = x \<sqinter> (y ^ o)"  by (simp add: A)
    also have "\<dots> = x"
      apply (rule antisym, simp_all)
      apply (rule_tac y = 1 in order_trans)
      apply simp
      by (subst dual_le, simp)
    finally have [simp]: "x * \<top> \<sqinter> (x ^ o) \<sqinter> (y ^ o) = x" .
    have "(x \<squnion> y) * \<top> \<sqinter> (x \<squnion> y) ^ o = (x * \<top> \<squnion> y * \<top>) \<sqinter> ((x ^ o) \<sqinter> (y ^ o))" by (simp add: sup_comp dual_sup)
    also have "\<dots> = x \<squnion> y" by (simp add: inf_sup_distrib inf_assoc [THEN sym])
    finally show "(x \<squnion> y) * \<top> \<sqinter> (x \<squnion> y) ^ o = x \<squnion> y" .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> x * x = x"
  by (simp add: assertion_inf_comp_eq [THEN sym])

lemma [simp]: "x \<in> assertion \<Longrightarrow> (x ^ o) * (x ^ o) = x ^ o"
  apply (rule dual_eq)
  by (simp add: dual_comp assertion_inf_comp_eq [THEN sym])

lemma [simp]: "x \<in> assertion \<Longrightarrow> x * (x ^ o) = x"
  proof -
    assume A: "x \<in> assertion"
    have B: "x * \<top> \<sqinter> (x ^ o) = x" by (cut_tac A, unfold assertion_def, simp)
    have "x * x ^ o = (x * \<top> \<sqinter> (x ^ o)) * x ^ o" by (simp add: B)
    also have "\<dots> = x * \<top> \<sqinter> (x ^ o)" by (cut_tac A, simp add: inf_comp)
    also have "\<dots> = x" by (simp add: B)
    finally show ?thesis .
  qed

lemma [simp]: "x \<in> assertion \<Longrightarrow> (x ^ o) * x = x ^ o"
  apply (rule dual_eq)
  by (simp add: dual_comp)

lemma [simp]: "\<bottom> \<in> assertion"
  by (unfold assertion_def, simp)

lemma [simp]: "1 \<in> assertion"
  by (unfold assertion_def, simp)

subsection {*Weakest precondition of true*}

definition
  "wpt x = (x * \<top>) \<sqinter> 1"

lemma wpt_is_assertion [simp]: "wpt x \<in> assertion"
  apply (unfold wpt_def assertion_def, safe)
  apply simp
  apply (simp add: inf_comp dual_inf dual_comp inf_sup_distrib)
  apply (rule antisym)
  by (simp_all add: dual_neg)

lemma wpt_comp: "(wpt x) * x = x"
  apply (simp add: wpt_def inf_comp)
  apply (rule antisym, simp_all)
  by (cut_tac x = 1 and y = \<top> and z = x in le_comp, simp_all)

lemma wpt_comp_2: "wpt (x * y) = wpt (x * (wpt y))"
  by (simp add: wpt_def inf_comp mult.assoc)

lemma wpt_assertion [simp]: "x \<in> assertion \<Longrightarrow> wpt x = x"
  by (simp add: wpt_def assertion_prop)

lemma wpt_le_assertion: "x \<in> assertion \<Longrightarrow> x * y = y \<Longrightarrow> wpt y \<le> x"
  apply (simp add: wpt_def)
  proof -
    assume A: "x \<in> assertion"
    assume B: "x * y = y"
    have "y * \<top> \<sqinter> 1 = x * (y * \<top>) \<sqinter> 1" by (simp add: B mult.assoc [THEN sym])
    also have "\<dots> \<le> x * \<top> \<sqinter> 1"
      apply simp
      apply (rule_tac y = "x * (y * \<top>)" in order_trans)
      apply simp_all
      by (rule le_comp, simp)
    also have "\<dots> = x" by (cut_tac A, simp add: assertion_prop)
    finally show "y * \<top> \<sqinter> 1 \<le> x" .
  qed

lemma wpt_choice: "wpt (x \<sqinter> y) = wpt x \<sqinter> wpt y"
  apply (simp add: wpt_def inf_comp)
  proof -
    have "x * \<top> \<sqinter> 1 \<sqinter> (y * \<top> \<sqinter> 1) = x * \<top> \<sqinter> ((y * \<top> \<sqinter> 1) \<sqinter> 1)" apply (subst inf_assoc) by (simp add: inf_commute)
    also have "... = x * \<top> \<sqinter> (y * \<top> \<sqinter> 1)" by (subst inf_assoc, simp)
    also have "... = (x * \<top>) \<sqinter> (y * \<top>) \<sqinter> 1" by (subst inf_assoc, simp)
    finally show "x * \<top> \<sqinter> (y * \<top>) \<sqinter> 1 = x * \<top> \<sqinter> 1 \<sqinter> (y * \<top> \<sqinter> 1)" by simp
  qed
end

context lattice begin
lemma [simp]: "x \<le> y \<Longrightarrow> x \<sqinter> y = x"
  by (simp add: inf_absorb1)
end

context mbt_algebra begin

lemma wpt_dual_assertion_comp: "x \<in> assertion \<Longrightarrow> y \<in> assertion \<Longrightarrow> wpt ((x ^ o) * y) = (neg_assert x) \<squnion> y"
  apply (simp add: wpt_def neg_assert_def)
  proof -
    assume A: "x \<in> assertion"
    assume B: "y \<in> assertion"
    have C: "((x ^ o) * \<bottom>) \<squnion> 1 = x ^ o"
      by (rule dual_assertion_prop, rule A)
    have "x ^ o * y * \<top> \<sqinter> 1 = (((x ^ o) * \<bottom>) \<squnion> 1) * y * \<top> \<sqinter> 1" by (simp add: C)
    also have "\<dots> = ((x ^ o) * \<bottom> \<squnion> (y * \<top>)) \<sqinter> 1" by (simp add: sup_comp)
    also have "\<dots> = (((x ^ o) * \<bottom>) \<sqinter> 1) \<squnion> ((y * \<top>) \<sqinter> 1)" by (simp add: inf_sup_distrib2)
    also have "\<dots> = (((x ^ o) * \<bottom>) \<sqinter> 1) \<squnion> y" by (cut_tac B, drule assertion_prop, simp)
    finally show "x ^ o * y * \<top> \<sqinter> 1 = (((x ^ o) * \<bottom>) \<sqinter> 1) \<squnion> y" .
  qed

lemma le_comp_left_right: "x \<le> y \<Longrightarrow> u \<le> v \<Longrightarrow> x * u \<le> y * v"
  apply (rule_tac y = "x * v" in order_trans)
  apply (rule le_comp, simp)
  by (rule le_comp_right, simp)

lemma wpt_dual_assertion: "x \<in> assertion \<Longrightarrow> wpt (x ^ o) = 1"
  apply (simp add: wpt_def)
  apply (rule antisym)
  apply simp_all
  apply (cut_tac x = 1 and y = "x ^ o" and u = 1 and v = \<top> in le_comp_left_right)
  apply simp_all
  apply (subst dual_le)
  by simp

lemma assertion_commute: "x \<in> assertion \<Longrightarrow> y \<in> conjunctive \<Longrightarrow> y * x = wpt(y * x) * y"
  apply (simp add: wpt_def)
  apply (simp add: inf_comp)
  apply (drule_tac x = y and y = "x * \<top>" and z = 1 in conjunctiveD)
  by (simp add: mult.assoc [THEN sym] assertion_prop)

lemma wpt_mono: "x \<le> y \<Longrightarrow> wpt x \<le> wpt y"
  apply (simp add: wpt_def)
  apply (rule_tac y = "x * \<top>" in order_trans, simp_all)
  by (rule le_comp_right, simp)

lemma "a \<in> conjunctive \<Longrightarrow> x * a \<le> a * y \<Longrightarrow> (x ^ \<omega>) * a \<le> a * (y ^ \<omega>)"
  apply (rule omega_least)
  apply (simp add: mult.assoc [THEN sym])
  apply (rule_tac y = "a * y * y ^ \<omega> \<sqinter> a" in order_trans)
  apply (simp)
  apply (rule_tac y = "x * a * y ^ \<omega>" in order_trans, simp_all)
  apply (rule le_comp_right, simp)
  apply (simp add: mult.assoc)
  apply (subst (2) omega_fix)
  by (simp add: conjunctiveD)

lemma [simp]: "x \<le> 1 \<Longrightarrow> y * x \<le> y"
  by (cut_tac x = x and y = 1 and z = y in le_comp, simp_all)

lemma [simp]: "x \<le> x * \<top>"
  by (cut_tac x = 1 and y = \<top> and z = x in le_comp, simp_all)

lemma [simp]: "x * \<bottom> \<le> x"
  by (cut_tac x = \<bottom> and y = 1 and z = x in le_comp, simp_all)

end

subsection{*Monotonic Boolean trasformers algebra with post condition statement*}

definition
  "post_fun (p::'a::order) q = (if p \<le> q then (\<top>::'b::{order_bot,order_top}) else \<bottom>)"

lemma mono_post_fun [simp]: "mono (post_fun (p::_::{order_bot,order_top}))"
  apply (simp add: post_fun_def mono_def, safe)
  apply (subgoal_tac "p \<le> y", simp)
  apply (rule_tac y = x in order_trans)
  apply simp_all
  done

lemma post_refin [simp]: "mono S \<Longrightarrow> ((S p)::'a::bounded_lattice) \<sqinter> (post_fun p) x \<le> S x"
  apply (simp add: le_fun_def assert_fun_def post_fun_def, safe)
  by (rule_tac f = S in monoD, simp_all)

class post_mbt_algebra = mbt_algebra +
  fixes post :: "'a \<Rightarrow> 'a"
  assumes post_1: "(post x) * x * \<top> = \<top>"
  and post_2: "y * x * \<top> \<sqinter> (post x) \<le> y"

instantiation MonoTran :: (complete_boolean_algebra) post_mbt_algebra
begin

lift_definition post_MonoTran :: "'a::complete_boolean_algebra MonoTran \<Rightarrow> 'a::complete_boolean_algebra MonoTran"
  is "\<lambda>x. post_fun (x \<top>)"
  by (rule mono_post_fun)

instance proof
  fix x :: "'a MonoTran" show "post x * x * \<top> = \<top>"
    apply transfer
    apply (simp add: fun_eq_iff)
    done
  fix x y :: "'a MonoTran" show "y * x * \<top> \<sqinter> post x \<le> y"
    apply transfer
    apply (simp add: le_fun_def)
    done
qed

end

subsection{*Complete monotonic Boolean transformers algebra*}

class complete_mbt_algebra = post_mbt_algebra + complete_distrib_lattice +
  assumes Inf_comp: "(Inf X) * z = (INF x : X . (x * z))"

instance MonoTran :: (complete_boolean_algebra) complete_mbt_algebra
  apply intro_classes
  unfolding INF_def
  apply transfer
  apply (simp add: Inf_comp_fun INF_def [symmetric])
  done

context complete_mbt_algebra begin
lemma dual_Inf: "(Inf X) ^ o = (SUP x: X . x ^ o)"
  apply (rule antisym)
  apply (subst dual_le, simp)
  apply (rule Inf_greatest)
  apply (subst dual_le, simp)
  apply (rule SUP_upper, simp)
  apply (rule SUP_least)
  apply (subst dual_le, simp)
  by (rule Inf_lower, simp)

lemma dual_Sup: "(Sup X) ^ o = (INF x: X . x ^ o)"
  apply (rule antisym)
  apply (rule INF_greatest)
  apply (subst dual_le, simp)
  apply (rule Sup_upper, simp)
  apply (subst dual_le, simp)
  apply (rule Sup_least)
  apply (subst dual_le, simp)
  by (rule INF_lower, simp)

lemma INF_comp: "(INFIMUM A f) * z = (INF a : A . (f a) * z)"
  unfolding INF_def Inf_comp
  apply (subgoal_tac "((\<lambda>x\<Colon>'a. x * z) ` f ` A) = ((\<lambda>a\<Colon>'b. f a * z) ` A)")
  by auto

lemma dual_INF: "(INFIMUM A f) ^ o = (SUP a : A . (f a) ^ o)"
  unfolding INF_def SUP_def Inf_comp dual_Inf
  apply (subgoal_tac "(dual ` f ` A) = ((\<lambda>a\<Colon>'b. f a ^ o) ` A)")
  by auto

lemma dual_SUP: "(SUPREMUM A f) ^ o = (INF a : A . (f a) ^ o)"
  unfolding INF_def dual_Sup SUP_def
  apply (subgoal_tac "(dual ` f ` A) = ((\<lambda>a\<Colon>'b. f a ^ o) ` A)")
  by auto

lemma Sup_comp: "(Sup X) * z = (SUP x : X . (x * z))"
  apply (rule dual_eq)
  by (simp add: dual_comp dual_Sup dual_SUP INF_comp)

lemma SUP_comp: "(SUPREMUM A f) * z = (SUP a : A . (f a) * z)"
  unfolding SUP_def Sup_comp
  apply (subgoal_tac "((\<lambda>x\<Colon>'a. x * z) ` f ` A) = ((\<lambda>a\<Colon>'b. f a * z) ` A)")
  by auto

lemma Sup_assertion [simp]: "X \<subseteq> assertion \<Longrightarrow> Sup X \<in> assertion"
  apply (unfold assertion_def)
  apply safe
  apply (rule Sup_least)
  apply blast
  apply (simp add: Sup_comp dual_Sup SUP_def Sup_inf del: Sup_image_eq)
  apply (subgoal_tac "((\<lambda>y . y \<sqinter> INFIMUM X dual) ` (\<lambda>x . x * \<top>) ` X) = X")
  apply simp
  proof -
    assume A: "X \<subseteq> {x. x \<le> 1 \<and> x * \<top> \<sqinter> x ^ o = x}"
    have B [simp]: "!! x . x \<in> X \<Longrightarrow>  x * \<top> \<sqinter> (INFIMUM X dual) = x"
      proof -
        fix x
        assume C: "x \<in> X"
        have "x * \<top> \<sqinter> INFIMUM X dual = x * \<top> \<sqinter> (x ^ o \<sqinter> INFIMUM X dual)"
          apply (subgoal_tac "INFIMUM X dual = (x ^ o \<sqinter> INFIMUM X dual)", simp)
          apply (rule antisym, simp_all)
          by (unfold INF_def, rule Inf_lower, cut_tac C, simp)
        also have "\<dots> = x \<sqinter> INFIMUM X dual" by (unfold  inf_assoc [THEN sym], cut_tac A, cut_tac C, auto)
        also have "\<dots> = x"
          apply (rule antisym, simp_all)
          apply (rule INF_greatest)
          apply (cut_tac A C)
          apply (rule_tac y = 1 in order_trans)
          apply auto[1]
          by (subst dual_le, auto)
        finally show "x * \<top> \<sqinter> INFIMUM X dual = x" .
      qed
      show "(\<lambda>y. y \<sqinter> INFIMUM X dual) ` (\<lambda>x . x * \<top>) ` X = X"
        by (unfold image_def, auto)
    qed

lemma Sup_range_assertion [simp]: "(!!w . p w \<in> assertion) \<Longrightarrow> Sup (range p) \<in> assertion"
  by (rule Sup_assertion, auto)

lemma Sup_less_assertion [simp]: "(!!w . p w \<in> assertion) \<Longrightarrow> Sup_less p w \<in> assertion"
  by (unfold Sup_less_def, rule Sup_assertion, auto)

theorem omega_lfp:
  "x ^ \<omega> * y = lfp (\<lambda> z . (x * z) \<sqinter> y)"
  apply (rule antisym)
  apply (rule lfp_greatest)
  apply (drule omega_least, simp)
  apply (rule lfp_lowerbound)
  apply (subst (2) omega_fix)
  by (simp add: inf_comp mult.assoc)
end

lemma [simp]: "mono (\<lambda> (t::'a::mbt_algebra) . x * t \<sqinter> y)"
  apply (simp add: mono_def, safe)
  apply (rule_tac y = "x * xa" in order_trans, simp)
  by (rule le_comp, simp)

class mbt_algebra_fusion = mbt_algebra +
  assumes fusion: "(\<forall> t . x * t \<sqinter> y \<sqinter> z \<le> u * (t \<sqinter> z) \<sqinter> v)
          \<Longrightarrow> (x ^ \<omega>) * y \<sqinter> z \<le> (u ^ \<omega>) * v "

lemma
    "class.mbt_algebra_fusion (1::'a::complete_mbt_algebra) (op *) (op \<sqinter>) (op \<le>) (op <) (op \<squnion>) dual dual_star omega star \<bottom> \<top>"
    apply unfold_locales
    apply (cut_tac h = "\<lambda> t . t \<sqinter> z" and f = "\<lambda> t . x * t \<sqinter> y" and g = "\<lambda> t . u * t \<sqinter> v" in weak_fusion)
    apply (rule inf_Disj)
    apply simp_all
    apply (simp add: le_fun_def)
    by  (simp add: omega_lfp)

context mbt_algebra_fusion
begin

lemma omega_pres_conj: "x \<in> conjunctive \<Longrightarrow> x ^ \<omega> \<in> conjunctive"
  apply (subst omega_star, simp)
  apply (rule comp_pres_conj)
  apply (rule assertion_conjunctive, simp)
  by (rule start_pres_conj, simp)
end

end


(*  Title:      HOL/Metis_Examples/Trans_Closure.thy
    Author:     Lawrence C. Paulson, Cambridge University Computer Laboratory
    Author:     Jasmin Blanchette, TU Muenchen

Metis example featuring the transitive closure.
*)

section \<open>Metis Example Featuring the Transitive Closure\<close>

theory Trans_Closure
imports MainRLT
begin

declare [[metis_new_skolem]]

type_synonym addr = nat

datatype val
  = Unit        \<comment> \<open>dummy result value of void expressions\<close>
  | Null        \<comment> \<open>null reference\<close>
  | Bool bool   \<comment> \<open>Boolean value\<close>
  | Intg int    \<comment> \<open>integer value\<close>
  | Addr addr   \<comment> \<open>addresses of objects in the heap\<close>

consts R :: "(addr \<times> addr) set"

consts f :: "addr \<Rightarrow> val"

lemma "\<lbrakk>f c = Intg x; \<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x; (a, b) \<in> R\<^sup>*; (b, c) \<in> R\<^sup>*\<rbrakk>
       \<Longrightarrow> \<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*"
(* sledgehammer *)
proof -
  assume A1: "f c = Intg x"
  assume A2: "\<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x"
  assume A3: "(a, b) \<in> R\<^sup>*"
  assume A4: "(b, c) \<in> R\<^sup>*"
  have F1: "f c \<noteq> f b" using A2 A1 by metis
  have F2: "\<forall>u. (b, u) \<in> R \<longrightarrow> (a, u) \<in> R\<^sup>*" using A3 by (metis transitive_closure_trans(6))
  have F3: "\<exists>x. (b, x b c R) \<in> R \<or> c = b" using A4 by (metis converse_rtranclE)
  have "c \<noteq> b" using F1 by metis
  hence "\<exists>u. (b, u) \<in> R" using F3 by metis
  thus "\<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*" using F2 by metis
qed

lemma "\<lbrakk>f c = Intg x; \<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x; (a, b) \<in> R\<^sup>*; (b,c) \<in> R\<^sup>*\<rbrakk>
       \<Longrightarrow> \<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*"
(* sledgehammer [isar_proofs, compress = 2] *)
proof -
  assume A1: "f c = Intg x"
  assume A2: "\<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x"
  assume A3: "(a, b) \<in> R\<^sup>*"
  assume A4: "(b, c) \<in> R\<^sup>*"
  have "b \<noteq> c" using A1 A2 by metis
  hence "\<exists>x\<^sub>1. (b, x\<^sub>1) \<in> R" using A4 by (metis converse_rtranclE)
  thus "\<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*" using A3 by (metis transitive_closure_trans(6))
qed

lemma "\<lbrakk>f c = Intg x; \<forall>y. f b = Intg y \<longrightarrow> y \<noteq> x; (a, b) \<in> R\<^sup>*; (b, c) \<in> R\<^sup>*\<rbrakk>
       \<Longrightarrow> \<exists>c. (b, c) \<in> R \<and> (a, c) \<in> R\<^sup>*"
apply (erule_tac x = b in converse_rtranclE)
 apply metis
by (metis transitive_closure_trans(6))

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_30
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun elem :: "Nat => Nat list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 y (Z) = False"
| "t2 (Z) (S z2) = True"
| "t2 (S x2) (S z2) = t2 x2 z2"
  (*t2 x y = x < y*)

fun ins :: "Nat => Nat list => Nat list" where
  "ins y (nil2) = cons2 y (nil2)"
| "ins y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (ins y xs))"

theorem property0 :
  "elem y (ins y xs)"
  (*why induction on "xs" instead of y?
    Because the innermost recursive function, ins, is defined with the case distinction
    on the second argument.
    Because "y" appears in two different places.*)
  apply(induct xs (*arbitrary: y*))(*generalization is optional.*)
   apply clarsimp
   apply(induct_tac y)
    apply auto[1]
   apply auto[1]
  apply clarsimp(*This clarsimp uses the induction hypothesis.*)
    (*without the meta-universal quantifier the following induction becomes unnecessarily hard.*)
    (*Why "\<And>y. x y y"?
      because of "\<not> x y y" in the premises.*)
  apply(subgoal_tac "\<And>y. x y y")
   apply fastforce
  apply(induct_tac ya)
  by auto

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Matrix Kernel\<close>

text \<open>We define the kernel of a matrix $A$ and prove the following properties.

\begin{itemize}
\item The kernel stays invariant when multiplying $A$ with an invertible matrix from the left.
\item The dimension of the kernel stays invariant when
  multiplying $A$ with an invertible matrix from the right.
\item The function find-base-vectors returns a basis of the kernel if $A$ is in row-echelon form.
\item The dimension of the kernel of a block-diagonal matrix is the sum of the dimensions of
  the kernels of the blocks.
\item There is an executable algorithm which computes the dimension of the kernel of a matrix
  (which just invokes Gauss-Jordan and then counts the number of pivot elements).
\end{itemize}
\<close>

theory Matrix_Kernel
imports
  VS_Connect
  Missing_VectorSpace
  Determinant
begin

hide_const real_vector.span
hide_const (open) Real_Vector_Spaces.span
hide_const real_vector.dim
hide_const (open) Real_Vector_Spaces.dim

definition mat_kernel :: "'a :: comm_ring_1 mat \<Rightarrow> 'a vec set" where
  "mat_kernel A = { v . v \<in> carrier_vec (dim_col A) \<and> A *\<^sub>v v = 0\<^sub>v (dim_row A)}"

lemma mat_kernelI: assumes "A \<in> carrier_mat nr nc" "v \<in> carrier_vec nc" "A *\<^sub>v v = 0\<^sub>v nr"
  shows "v \<in> mat_kernel A"
  using assms unfolding mat_kernel_def by auto

lemma mat_kernelD: assumes "A \<in> carrier_mat nr nc" "v \<in> mat_kernel A"
  shows "v \<in> carrier_vec nc" "A *\<^sub>v v = 0\<^sub>v nr"
  using assms unfolding mat_kernel_def by auto

lemma mat_kernel: assumes "A \<in> carrier_mat nr nc"
  shows "mat_kernel A = {v. v \<in> carrier_vec nc \<and> A *\<^sub>v v = 0\<^sub>v nr}"
  unfolding mat_kernel_def using assms by auto

lemma mat_kernel_carrier:
  assumes "A \<in> carrier_mat nr nc" shows "mat_kernel A \<subseteq> carrier_vec nc"
  using assms mat_kernel by auto

lemma mat_kernel_mult_subset: assumes A: "A \<in> carrier_mat nr nc"
  and B: "B \<in> carrier_mat n nr"
  shows "mat_kernel A \<subseteq> mat_kernel (B * A)"
proof -
  from A B have BA: "B * A \<in> carrier_mat n nc" by auto
  show ?thesis unfolding mat_kernel[OF BA] mat_kernel[OF A] using A B by auto
qed

lemma mat_kernel_mult_eq: assumes A: "A \<in> carrier_mat nr nc"
  and B: "B \<in> carrier_mat nr nr"
  and C: "C \<in> carrier_mat nr nr"
  and inv: "C * B = 1\<^sub>m nr"
  shows "mat_kernel (B * A) = mat_kernel A"
proof
  from B A have BA: "B * A \<in> carrier_mat nr nc" by auto
  show "mat_kernel A \<subseteq> mat_kernel (B * A)" by (rule mat_kernel_mult_subset[OF A B])
  {
    fix v
    assume v: "v \<in> mat_kernel (B * A)"
    from mat_kernelD[OF BA this] have v: "v \<in> carrier_vec nc" and z: "B * A *\<^sub>v v = 0\<^sub>v nr" by auto
    from arg_cong[OF z, of "\<lambda> v. C *\<^sub>v v"]
    have "C *\<^sub>v (B * A *\<^sub>v v) = 0\<^sub>v nr" using C v by auto
    also have "C *\<^sub>v (B * A *\<^sub>v v) = ((C * B) * A) *\<^sub>v v"
      unfolding assoc_mult_mat_vec[symmetric, OF C BA v]
      unfolding assoc_mult_mat[OF C B A] by simp
    also have "\<dots> = A *\<^sub>v v" unfolding inv using A v by auto
    finally have "v \<in> mat_kernel A"
      by (intro mat_kernelI[OF A v])
  }
  thus "mat_kernel (B * A) \<subseteq> mat_kernel A" by auto
qed

locale kernel =
  fixes nr :: nat
    and nc :: nat
    and A :: "'a :: field mat"
  assumes A: "A \<in> carrier_mat nr nc"
begin

sublocale NC: vec_space "TYPE('a)" nc .

abbreviation "VK \<equiv> NC.V\<lparr>carrier := mat_kernel A\<rparr>"

sublocale Ker: vectorspace class_ring VK
  rewrites "carrier VK = mat_kernel A"
    and [simp]: "add VK = (+)"
    and [simp]: "zero VK = 0\<^sub>v nc"
    and [simp]: "module.smult VK = (\<cdot>\<^sub>v)"
    and "carrier class_ring = UNIV"
    and "monoid.mult class_ring = (*)"
    and "add class_ring = (+)"
    and "one class_ring = 1"
    and "zero class_ring = 0"
    and "a_inv (class_ring :: 'a ring) = uminus"
    and "a_minus (class_ring :: 'a ring) = minus"
    and "pow (class_ring :: 'a ring) = (^)"
    and "finsum (class_ring :: 'a ring) = sum"
    and "finprod (class_ring :: 'a ring) = prod"
    and "m_inv (class_ring :: 'a ring) x = (if x = 0 then div0 else inverse x)"
  apply (intro vectorspace.intro)
  apply (rule NC.submodule_is_module)
  apply (unfold_locales)
  by (insert A mult_add_distrib_mat_vec[OF A] mult_mat_vec[OF A] mat_kernel[OF A], auto simp: class_ring_simps)

abbreviation "basis \<equiv> Ker.basis"
abbreviation "span \<equiv> Ker.span"
abbreviation "lincomb \<equiv> Ker.lincomb"
abbreviation "dim \<equiv> Ker.dim"
abbreviation "lin_dep \<equiv> Ker.lin_dep"
abbreviation "lin_indpt \<equiv> Ker.lin_indpt"
abbreviation "gen_set \<equiv> Ker.gen_set"

lemma finsum_same:
  assumes "f : S \<rightarrow> mat_kernel A"
  shows "finsum VK f S = finsum NC.V f S"
  using assms
proof (induct S rule: infinite_finite_induct)
  case (insert s S)
    hence base: "finite S" "s \<notin> S"
      and f_VK: "f : S \<rightarrow> mat_kernel A" "f s : mat_kernel A" by auto
    hence f_NC: "f : S \<rightarrow> carrier_vec nc" "f s : carrier_vec nc" using mat_kernel[OF A] by auto
    have IH: "finsum VK f S = finsum NC.V f S" using insert f_VK by auto
    thus ?case
      unfolding NC.M.finsum_insert[OF base f_NC]
      unfolding Ker.finsum_insert[OF base f_VK]
      by simp
qed auto

lemma lincomb_same:
  assumes S_kernel: "S \<subseteq> mat_kernel A"
  shows "lincomb a S = NC.lincomb a S"
  unfolding Ker.lincomb_def
  unfolding NC.lincomb_def
  apply(subst finsum_same)
  using S_kernel Ker.smult_closed[unfolded module_vec_simps class_ring_simps] by auto

lemma span_same:
  assumes S_kernel: "S \<subseteq> mat_kernel A"
  shows "span S = NC.span S"
proof (rule;rule)
  fix v assume L: "v : span S" show "v : NC.span S"
  proof -
    obtain a U where know: "finite U" "U \<subseteq> S" "a : U \<rightarrow> UNIV" "v = lincomb a U"
      using L unfolding Ker.span_def by auto
    hence v: "v = NC.lincomb a U" using lincomb_same S_kernel by auto
    show ?thesis
      unfolding NC.span_def by (rule,intro exI conjI;fact)
  qed
  next fix v assume R: "v : NC.span S" show "v : span S"
  proof -
    obtain a U where know: "finite U" "U \<subseteq> S" "v = NC.lincomb a U"
      using R unfolding NC.span_def by auto
    hence v: "v = lincomb a U" using lincomb_same S_kernel by auto
    show ?thesis unfolding Ker.span_def by (rule, intro exI conjI, insert v know, auto)
  qed
qed

lemma lindep_same:
  assumes S_kernel: "S \<subseteq> mat_kernel A"
  shows "Ker.lin_dep S = NC.lin_dep S"
proof
  note [simp] = module_vec_simps class_ring_simps
  { assume L: "Ker.lin_dep S"
    then obtain v a U
    where finU: "finite U" and US: "U \<subseteq> S"
      and lc: "lincomb a U = 0\<^sub>v nc"
      and vU: "v \<in> U"
      and av0: "a v \<noteq> 0"
      unfolding Ker.lin_dep_def by auto
    have lc': "NC.lincomb a U = 0\<^sub>v nc"
      using lc lincomb_same US S_kernel by auto
    show "NC.lin_dep S" unfolding NC.lin_dep_def
      by (intro exI conjI, insert finU US lc' vU av0, auto)
  }
  assume R: "NC.lin_dep S"
  then obtain v a U
  where finU: "finite U" and US: "U \<subseteq> S"
    and lc: "NC.lincomb a U = 0\<^sub>v nc"
    and vU: "v : U"
    and av0: "a v \<noteq> 0"
    unfolding NC.lin_dep_def by auto
  have lc': "lincomb a U = zero VK"
    using lc lincomb_same US S_kernel by auto
  show "Ker.lin_dep S" unfolding Ker.lin_dep_def
    by (intro exI conjI,insert finU US lc' vU av0, auto)
qed

lemma lincomb_index:
  assumes i: "i < nc"
    and Xk: "X \<subseteq> mat_kernel A"
  shows "lincomb a X $ i = sum (\<lambda>x. a x * x $ i) X"
proof -
  have X: "X \<subseteq> carrier_vec nc" using Xk mat_kernel_def A by auto
  show ?thesis
    using vec_space.lincomb_index[OF i X]
    using lincomb_same[OF Xk] by auto
qed

end

definition kernel_dim :: "'a :: field mat \<Rightarrow> nat" where
  [code del]: "kernel_dim A = kernel.dim (dim_col A) A"

lemma (in kernel) kernel_dim [simp]: "kernel_dim A = dim" unfolding kernel_dim_def
  using A by simp

lemma kernel_dim_code[code]:
  "kernel_dim A = dim_col A - length (pivot_positions (gauss_jordan_single A))"
proof -
  define nr where "nr = dim_row A"
  define nc where "nc = dim_col A"
  let ?B = "gauss_jordan_single A"
  have A: "A \<in> carrier_mat nr nc" unfolding nr_def nc_def by auto
  from gauss_jordan_single[OF A refl]
    obtain P Q where AB: "?B = P * A" and QP: "Q * P = 1\<^sub>m nr" and
    P: "P \<in> carrier_mat nr nr" and Q: "Q \<in> carrier_mat nr nr" and B: "?B \<in> carrier_mat nr nc"
    and row: "row_echelon_form ?B" by auto
  interpret K: kernel nr nc ?B
    by (unfold_locales, rule B)
  from mat_kernel_mult_eq[OF A P Q QP, folded AB]
  have "kernel_dim A = K.dim" unfolding kernel_dim_def using A by simp
  also have "\<dots> = nc - length (pivot_positions ?B)" using find_base_vectors[OF row B] by auto
  also have "\<dots> = dim_col A - length (pivot_positions ?B)"
    unfolding nc_def by simp
  finally show ?thesis .
qed

lemma kernel_one_mat: fixes A :: "'a :: field mat" and n :: nat
  defines A: "A \<equiv> 1\<^sub>m n"
  shows
    "kernel.dim n A = 0"
    "kernel.basis n A {}"
proof -
  have Ac: "A \<in> carrier_mat n n" unfolding A by auto
  have "pivot_fun A id n"
    unfolding A by (rule pivot_funI, auto)
  hence row: "row_echelon_form A" unfolding row_echelon_form_def A by auto
  have "{i. i < n \<and> row A i \<noteq> 0\<^sub>v n} = {0 ..< n}" unfolding A by auto
  hence id: "card {i. i < n \<and> row A i \<noteq> 0\<^sub>v n} = n" by auto
  interpret kernel n n A by (unfold_locales, rule Ac)
  from find_base_vectors[OF row Ac, unfolded id]
  show "dim = 0" "basis {}" by auto
qed

lemma kernel_upper_triangular: assumes A: "A \<in> carrier_mat n n"
  and ut: "upper_triangular A" and 0: "0 \<notin> set (diag_mat A)"
  shows "kernel.dim n A = 0" "kernel.basis n A {}"
proof -
  define ma where "ma = diag_mat A"
  from det_upper_triangular[OF ut A] have "det A = prod_list (diag_mat A)" .
  also have "\<dots> \<noteq> 0" using 0 unfolding ma_def[symmetric]
    by (induct ma, auto)
  finally have "det A \<noteq> 0" .
  from det_non_zero_imp_unit[OF A this, unfolded Units_def, of "()"]
    obtain B where B: "B \<in> carrier_mat n n" and BA: "B * A = 1\<^sub>m n" and AB: "A * B = 1\<^sub>m n"
    by (auto simp: ring_mat_def)
  from mat_kernel_mult_eq[OF A B A AB, unfolded BA]
  have id: "mat_kernel A = mat_kernel (1\<^sub>m n)" ..
  show "kernel.dim n A = 0" "kernel.basis n A {}"
    unfolding id by (rule kernel_one_mat)+
qed

lemma kernel_basis_exists: assumes A: "A \<in> carrier_mat nr nc"
  shows "\<exists> B. finite B \<and> kernel.basis nc A B"
proof -
  obtain C where gj: "gauss_jordan_single A = C" by auto
  from gauss_jordan_single[OF A gj]
  obtain P Q where CPA: "C = P * A" and QP: "Q * P = 1\<^sub>m nr"
    and P: "P \<in> carrier_mat nr nr" and Q: "Q \<in> carrier_mat nr nr"
    and C: "C \<in> carrier_mat nr nc" and row: "row_echelon_form C"
    by auto
  from find_base_vectors[OF row C] have "\<exists> B. finite B \<and> kernel.basis nc C B" by blast
  also have "mat_kernel C = mat_kernel A" unfolding CPA
    by (rule mat_kernel_mult_eq[OF A P Q QP])
  finally show ?thesis .
qed

lemma mat_kernel_mult_right_gen_set: assumes A: "A \<in> carrier_mat nr nc"
  and B: "B \<in> carrier_mat nc nc"
  and C: "C \<in> carrier_mat nc nc"
  and inv: "B * C = 1\<^sub>m nc"
  and gen_set: "kernel.gen_set nc (A * B) gen" and gen: "gen \<subseteq> mat_kernel (A * B)"
  shows "kernel.gen_set nc A (((*\<^sub>v) B) ` gen)" "(*\<^sub>v) B ` gen \<subseteq> mat_kernel A" "card (((*\<^sub>v) B) ` gen) = card gen"
proof -
  let ?AB = "A * B"
  let ?gen = "((*\<^sub>v) B) ` gen"
  from A B have AB: "A * B \<in> carrier_mat nr nc" by auto
  from B have dimB: "dim_row B = nc" by auto
  from inv B C have CB: "C * B = 1\<^sub>m nc" by (metis mat_mult_left_right_inverse)
  interpret AB: kernel nr nc ?AB
    by (unfold_locales, rule AB)
  interpret A: kernel nr nc A
    by (unfold_locales, rule A)
  {
    fix w
    assume "w \<in> ?gen"
    then obtain v where w: "w = B *\<^sub>v v" and v: "v \<in> gen" by auto
    from v have "v \<in> mat_kernel ?AB" using gen by auto
    hence v: "v \<in> carrier_vec nc" and 0: "?AB *\<^sub>v v = 0\<^sub>v nr" unfolding mat_kernel[OF AB] by auto
    have "?AB *\<^sub>v v = A *\<^sub>v w" unfolding w using v A B by simp
    with 0 have 0: "A *\<^sub>v w = 0\<^sub>v nr" by auto
    from w B v have w: "w \<in> carrier_vec nc" by auto
    from 0 w have "w \<in> mat_kernel A" unfolding mat_kernel[OF A] by auto
  }
  thus genn: "?gen \<subseteq> mat_kernel A" by auto
  hence one_dir: "A.span ?gen \<subseteq> mat_kernel A" by fastforce
  {
    fix v v'
    assume v: "v \<in> gen" and v': "v' \<in> gen" and id: "B *\<^sub>v v = B *\<^sub>v v'"
    from v v' have v: "v \<in> carrier_vec nc" and v': "v' \<in> carrier_vec nc"
      using gen unfolding mat_kernel[OF AB] by auto
    from arg_cong[OF id, of "\<lambda> v. C *\<^sub>v v"]
    have "v = v'" using v v'
      unfolding assoc_mult_mat_vec[symmetric, OF C B v]
        assoc_mult_mat_vec[symmetric, OF C B v'] CB
      by auto
  } note inj = this
  hence inj_gen: "inj_on ((*\<^sub>v) B) gen" unfolding inj_on_def by auto
  show "card ?gen = card gen" using inj_gen by (rule card_image)
  {
    fix v
    let ?Cv = "C *\<^sub>v v"
    assume "v \<in> mat_kernel A"
    from mat_kernelD[OF A this] have v: "v \<in> carrier_vec nc" and 0: "A *\<^sub>v v = 0\<^sub>v nr" by auto
    have "?AB *\<^sub>v ?Cv = (A * (B * C)) *\<^sub>v v" using A B C v
      by (subst assoc_mult_mat_vec[symmetric, OF AB C v], subst assoc_mult_mat[OF A B C], simp)
    also have "\<dots> = 0\<^sub>v nr" unfolding inv using 0 A v by simp
    finally have 0: "?AB *\<^sub>v ?Cv = 0\<^sub>v nr" and Cv: "?Cv \<in> carrier_vec nc" using C v by auto
    hence "?Cv \<in> mat_kernel ?AB" unfolding mat_kernel[OF AB] by auto
    with gen_set have "?Cv \<in> AB.span gen" by auto
    from this[unfolded AB.Ker.span_def] obtain a gen' where
      Cv: "?Cv = AB.lincomb a gen'" and sub: "gen' \<subseteq> gen" and fin: "finite gen'" by auto
    let ?gen' = "((*\<^sub>v) B) ` gen'"
    from sub gen have gen': "gen' \<subseteq> mat_kernel ?AB" by auto
    have lin1: "AB.lincomb a gen' \<in> carrier_vec nc"
      using AB.Ker.lincomb_closed[OF gen', of a]
      unfolding mat_kernel[OF AB] by (auto simp: class_field_def)
    hence dim1: "dim_vec (AB.lincomb a gen') = nc" by auto
    hence dim1b: "dim_vec (B *\<^sub>v (AB.Ker.lincomb a gen')) = nc" using B by auto
    from genn sub have genn': "?gen' \<subseteq> mat_kernel A" by auto
    from gen sub have gen'nc: "gen' \<subseteq> carrier_vec nc" unfolding mat_kernel[OF AB] by auto
    define a' where "a' = (\<lambda> b. a (C *\<^sub>v b))"
    from A.Ker.lincomb_closed[OF genn']
    have lin2: "A.Ker.lincomb a' ?gen' \<in> carrier_vec nc"
      unfolding mat_kernel[OF A] by (auto simp: class_field_def)
    hence dim2: "dim_vec (A.Ker.lincomb a' ?gen') = nc" by auto
    have "v = B *\<^sub>v ?Cv"
      by (unfold assoc_mult_mat_vec[symmetric, OF B C v] inv, insert v, simp)
    hence "v = B *\<^sub>v AB.Ker.lincomb a gen'" unfolding Cv by simp
    also have "\<dots> = A.Ker.lincomb a' ?gen'"
    proof (rule eq_vecI; unfold dim1 dim1b dim2)
      fix i
      assume i: "i < nc"
      with dimB have ii: "i < dim_row B" by auto
      from sub inj have inj: "inj_on ((*\<^sub>v) B) gen'" unfolding inj_on_def by auto
      {
        fix v
        assume "v \<in> gen'"
        with gen'nc have v: "v \<in> carrier_vec nc" by auto
        hence "a' (B *\<^sub>v v) = a v" unfolding a'_def assoc_mult_mat_vec[symmetric, OF C B v] CB by auto
      } note a' = this
      have "A.Ker.lincomb a' ?gen' $ i = (\<Sum>v\<in>(*\<^sub>v) B ` gen'. a' v * v $ i)"
        unfolding A.lincomb_index[OF i genn']  by simp
      also have "\<dots> = (\<Sum>v\<in>gen'. a v * ((B *\<^sub>v v) $ i))"
        by (rule sum.reindex_cong[OF inj refl], auto simp: a')
      also have "\<dots> = (\<Sum>v\<in>gen'. (\<Sum>j = 0..< nc. a v * row B i $ j * v $ j))"
        unfolding mult_mat_vec_def dimB scalar_prod_def index_vec[OF i]
        by (rule sum.cong, insert gen'nc, auto simp: sum_distrib_left ac_simps)
      also have "\<dots> = (\<Sum>j = 0 ..< nc. (\<Sum>v \<in> gen'. a v * row B i $ j * v $ j))"
        by (rule sum.swap)
      also have "\<dots> = (\<Sum>j = 0..<nc. row B i $ j * (\<Sum>v\<in>gen'. a v * v $ j))"
        by (rule sum.cong, auto simp: sum_distrib_left ac_simps)
      also have "\<dots> = (B *\<^sub>v AB.Ker.lincomb a gen') $ i"
        unfolding index_mult_mat_vec[OF ii]
        unfolding scalar_prod_def dim1
        by (rule sum.cong[OF refl], subst AB.lincomb_index[OF _ gen'], auto)
      finally show "(B *\<^sub>v AB.Ker.lincomb a gen') $ i = A.Ker.lincomb a' ?gen' $ i" ..
    qed auto
    finally have "v \<in> A.Ker.span ?gen" using sub fin
      unfolding A.Ker.span_def by (auto simp: class_field_def intro!: exI[of _ a'] exI[of _ ?gen'])
  }
  hence other_dir: "A.Ker.span ?gen \<supseteq> mat_kernel A" by fastforce
  from one_dir other_dir show "kernel.gen_set nc A (((*\<^sub>v) B) ` gen)" by auto
qed

lemma mat_kernel_mult_right_basis: assumes A: "A \<in> carrier_mat nr nc"
  and B: "B \<in> carrier_mat nc nc"
  and C: "C \<in> carrier_mat nc nc"
  and inv: "B * C = 1\<^sub>m nc"
  and fin: "finite gen"
  and basis: "kernel.basis nc (A * B) gen"
  shows "kernel.basis nc A (((*\<^sub>v) B) ` gen)"
  "card (((*\<^sub>v) B) ` gen) = card gen"
proof -
  let ?AB = "A * B"
  let ?gen = "((*\<^sub>v) B) ` gen"
  from A B have AB: "?AB \<in> carrier_mat nr nc" by auto
  from B have dimB: "dim_row B = nc" by auto
  from inv B C have CB: "C * B = 1\<^sub>m nc" by (metis mat_mult_left_right_inverse)
  interpret AB: kernel nr nc ?AB
    by (unfold_locales, rule AB)
  interpret A: kernel nr nc A
    by (unfold_locales, rule A)
  from basis[unfolded AB.Ker.basis_def] have gen_set: "AB.gen_set gen" and genAB: "gen \<subseteq> mat_kernel ?AB" by auto
  from mat_kernel_mult_right_gen_set[OF A B C inv gen_set genAB]
  have gen: "A.gen_set ?gen" and sub: "?gen \<subseteq> mat_kernel A" and card: "card ?gen = card gen" .
  from card show "card ?gen = card gen" .
  from fin have fing: "finite ?gen" by auto
  from gen have gen: "A.Ker.span ?gen = mat_kernel A" by auto
  have ABC: "A * B * C = A" using A B C inv by simp
  from kernel_basis_exists[OF A] obtain bas where finb: "finite bas" and bas: "A.basis bas" by auto
  from bas have bas': "A.gen_set bas" "bas \<subseteq> mat_kernel A" unfolding A.Ker.basis_def by auto
  let ?bas = "(*\<^sub>v) C ` bas"
  from mat_kernel_mult_right_gen_set[OF AB C B CB, unfolded ABC, OF bas']
  have bas': "?bas \<subseteq> mat_kernel ?AB" "AB.Ker.span ?bas = mat_kernel ?AB" "card ?bas = card bas" by auto
  from finb bas have cardb: "A.dim = card bas" by (rule A.Ker.dim_basis)
  from fin basis have cardg: "AB.dim = card gen" by (rule AB.Ker.dim_basis)
  from AB.Ker.gen_ge_dim[OF _ bas'(1-2)] finb bas'(3) cardb cardg
  have ineq1: "card gen \<le> A.dim" by auto
  from A.Ker.dim_gen_is_basis[OF fing sub gen, unfolded card, OF this]
  show "A.basis ?gen" .
qed

lemma mat_kernel_dim_mult_eq_right: assumes A: "A \<in> carrier_mat nr nc"
  and B: "B \<in> carrier_mat nc nc"
  and C: "C \<in> carrier_mat nc nc"
  and BC: "B * C = 1\<^sub>m nc"
  shows "kernel.dim nc (A * B) = kernel.dim nc A"
proof -
  let ?AB = "A * B"
  from A B have AB: "?AB \<in> carrier_mat nr nc" by auto
  interpret AB: kernel nr nc ?AB
    by (unfold_locales, rule AB)
  interpret A: kernel nr nc A
    by (unfold_locales, rule A)
  from kernel_basis_exists[OF AB] obtain bas where finb: "finite bas" and bas: "AB.basis bas" by auto
  let ?bas = "((*\<^sub>v) B) ` bas"
  from mat_kernel_mult_right_basis[OF A B C BC finb bas] finb
  have bas': "A.basis ?bas" and finb': "finite ?bas" and card: "card ?bas = card bas" by auto
  show "AB.dim = A.dim" unfolding A.Ker.dim_basis[OF finb' bas'] AB.Ker.dim_basis[OF finb bas] card ..
qed

locale vardim =
  fixes f_ty :: "'a :: field itself"
begin

abbreviation "M == \<lambda>k. module_vec TYPE('a) k"

abbreviation "span == \<lambda>k. LinearCombinations.module.span class_ring (M k)"
abbreviation "lincomb == \<lambda>k. module.lincomb (M k)"
abbreviation "lin_dep == \<lambda>k. module.lin_dep class_ring (M k)"
abbreviation "padr m v == v @\<^sub>v 0\<^sub>v m"
definition "unpadr m v == vec (dim_vec v - m) (\<lambda>i. v $ i)"
abbreviation "padl m v == 0\<^sub>v m @\<^sub>v v"
definition "unpadl m v == vec (dim_vec v - m) (\<lambda>i. v $ (m+i))"

lemma unpadr_padr[simp]: "unpadr m (padr m v) = v" unfolding unpadr_def by auto
lemma unpadl_padl[simp]: "unpadl m (padl m v) = v" unfolding unpadl_def by auto

lemma padr_unpadr[simp]: "v : padr m ` U \<Longrightarrow> padr m (unpadr m v) = v" by auto
lemma padl_unpadl[simp]: "v : padl m ` U \<Longrightarrow> padl m (unpadl m v) = v" by auto

(* somehow not automatically proven *)
lemma padr_image:
  assumes "U \<subseteq> carrier_vec n" shows "padr m ` U \<subseteq> carrier_vec (n + m)"
proof(rule subsetI)
  fix v assume "v : padr m ` U"
  then obtain u where "u : U" and vmu: "v = padr m u" by auto
  hence "u : carrier_vec n" using assms by auto
  thus "v : carrier_vec (n + m)"
    unfolding vmu
    using zero_carrier_vec[of m] append_carrier_vec by metis
qed

lemma padr_inj:
  shows "inj_on (padr m) (carrier_vec n :: 'a vec set)"
  apply(intro inj_onI) using append_vec_eq by auto

lemma padl_inj:
  shows "inj_on (padl m) (carrier_vec n :: 'a vec set)"
  apply(intro inj_onI)
  using append_vec_eq[OF zero_carrier_vec zero_carrier_vec] by auto

lemma lincomb_pad:
  fixes m n a
  assumes U: "(U :: 'a vec set) \<subseteq> carrier_vec n"
      and finU: "finite U"
  defines "goal pad unpad W == pad m (lincomb n a W) = lincomb (n+m) (a o unpad m) (pad m ` W)"
  shows "goal padr unpadr U" (is ?R) and "goal padl unpadl U" (is "?L")
proof -
  interpret N: vectorspace class_ring "M n" using vec_vs.
  interpret NM: vectorspace class_ring "M (n+m)" using vec_vs.
  note [simp] = module_vec_simps class_ring_simps
  have "?R \<and> ?L" using finU U
  proof (induct set:finite)
    case empty thus ?case
      unfolding goal_def unfolding N.lincomb_def NM.lincomb_def by auto next
    case (insert u U)
      hence finU: "finite U"
        and U: "U \<subseteq> carrier_vec n"
        and u[simp]: "u : carrier_vec n"
        and uU: "u \<notin> U"
        and auU: "a : insert u U \<rightarrow> UNIV"
        and aU: "a : U \<rightarrow> UNIV"
        and au: "a u : UNIV"
        by auto
      have IHr: "goal padr unpadr U" and IHl: "goal padl unpadl U"
        using insert(3) U aU by auto
      note N_lci = N.lincomb_insert2[unfolded module_vec_simps]
      note NM_lci = NM.lincomb_insert2[unfolded module_vec_simps]
      have auu[simp]: "a u \<cdot>\<^sub>v u : carrier_vec n" using au u by simp
      have laU[simp]: "lincomb n a U : carrier_vec n"
        using N.lincomb_closed[unfolded module_vec_simps class_ring_simps, OF U aU].
      let ?m0 = "0\<^sub>v m :: 'a vec"
      have m0: "?m0 : carrier_vec m" by auto
      have ins: "lincomb n a (insert u U) = a u \<cdot>\<^sub>v u + lincomb n a U"
        using N_lci[OF finU U] auU uU u by auto
      show ?case
      proof
        have "padr m (a u \<cdot>\<^sub>v u + lincomb n a U) =
          (a u \<cdot>\<^sub>v u + lincomb n a U) @\<^sub>v (?m0 + ?m0)" by auto
        also have "... = padr m (a u \<cdot>\<^sub>v u) + padr m (lincomb n a U)"
          using append_vec_add[symmetric, OF auu laU]
          using zero_carrier_vec[of m] by metis
        also have "padr m (lincomb n a U) = lincomb (n+m) (a o unpadr m) (padr m ` U)"
          using IHr unfolding goal_def.
        also have "padr m (a u \<cdot>\<^sub>v u) = a u \<cdot>\<^sub>v padr m u" by auto
        also have "... = (a o unpadr m) (padr m u) \<cdot>\<^sub>v padr m u" by auto
        also have "... + lincomb (n+m) (a o unpadr m) (padr m ` U) =
          lincomb (n+m) (a o unpadr m) (insert (padr m u) (padr m ` U))"
          apply(subst NM_lci[symmetric])
          using finU uU U append_vec_eq[OF u] by auto
        also have "insert (padr m u) (padr m ` U) = padr m ` insert u U"
          by auto
        finally show "goal padr unpadr (insert u U)" unfolding goal_def ins.
        have [simp]: "n+m = m+n" by auto
        have "padl m (a u \<cdot>\<^sub>v u + lincomb n a U) =
          (?m0 + ?m0) @\<^sub>v (a u \<cdot>\<^sub>v u + lincomb n a U)" by auto
        also have "... = padl m (a u \<cdot>\<^sub>v u) + padl m (lincomb n a U)"
          using append_vec_add[symmetric, OF _ _ auu laU]
          using zero_carrier_vec[of m] by metis
        also have "padl m (lincomb n a U) = lincomb (n+m) (a o unpadl m) (padl m ` U)"
          using IHl unfolding goal_def.
        also have "padl m (a u \<cdot>\<^sub>v u) = a u \<cdot>\<^sub>v padl m u" by auto
        also have "... = (a o unpadl m) (padl m u) \<cdot>\<^sub>v padl m u" by auto
        also have "... + lincomb (n+m) (a o unpadl m) (padl m ` U) =
          lincomb (n+m) (a o unpadl m) (insert (padl m u) (padl m ` U))"
          apply(subst NM_lci[symmetric])
          using finU uU U append_vec_eq[OF m0] by auto
        also have "insert (padl m u) (padl m ` U) = padl m ` insert u U"
          by auto
        finally show "goal padl unpadl (insert u U)" unfolding goal_def ins.
      qed
  qed
  thus ?R ?L by auto
qed

lemma span_pad:
  assumes U: "(U::'a vec set) \<subseteq> carrier_vec n"
  defines "goal pad m == pad m ` span n U = span (n+m) (pad m ` U)"
  shows "goal padr m" "goal padl m"
proof -
  interpret N: vectorspace class_ring "M n" using vec_vs.
  interpret NM: vectorspace class_ring "M (n+m)" using vec_vs.
  { fix pad :: "'a vec \<Rightarrow> 'a vec" and unpad :: "'a vec \<Rightarrow> 'a vec"
    assume main: "\<And>A a. A \<subseteq> U \<Longrightarrow> finite A \<Longrightarrow>
      pad (lincomb n a A) = lincomb (n+m) (a o unpad) (pad ` A)"
    assume [simp]: "\<And>v. unpad (pad v) = v"
    assume pU: "pad ` U \<subseteq> carrier_vec (n+m)"
    have "pad ` (span n U) = span (n+m) (pad ` U)"
    proof (intro Set.equalityI subsetI)
      fix x assume "x : pad ` (span n U)"
      then obtain v where "v : span n U" and xv: "x = pad v" by auto
      then obtain a A
        where AU: "A \<subseteq> U" and finA: "finite A" and a: "a : A \<rightarrow> UNIV"
          and vaA: "v = lincomb n a A"
        unfolding N.span_def by auto
      hence A: "A \<subseteq> carrier_vec n" using U by auto
      show "x : span (n+m) (pad ` U)" unfolding NM.span_def
      proof (intro CollectI exI conjI)
        show "x = lincomb (n+m) (a o unpad) (pad ` A)"
          using xv vaA main[OF AU finA] by auto
        show "pad ` A \<subseteq> pad ` U" using AU by auto
      qed (insert finA, auto simp: class_ring_simps)
      next
      fix x assume "x : span (n+m) (pad ` U)"
      then obtain a' A'
        where A'U: "A' \<subseteq> pad ` U" and finA': "finite A'" and a': "a' : A' \<rightarrow> UNIV"
          and xa'A': "x = lincomb (n+m) a' A'"
        unfolding NM.span_def by auto
      then obtain A where finA: "finite A" and AU: "A \<subseteq> U" and A'A: "A' = pad ` A"
        using finite_subset_image[OF finA' A'U] by auto
      hence A: "A \<subseteq> carrier_vec n" using U by auto
      have A': "A' \<subseteq> carrier_vec (n+m)" using A'U pU by auto
      define a where "a = a' o pad"
      define a'' where "a'' = (a' o pad) o unpad"
      have a: "a : A \<rightarrow> UNIV" by auto
      have restr: "restrict a' A' = restrict a'' A'"
      proof(rule restrict_ext)
        fix u' assume "u' : A'"
        then obtain u where "u : A" and "u' = pad u" unfolding A'A by auto
        thus "a' u' = a'' u'" unfolding a''_def a_def by auto
      qed
      have "x = lincomb (n+m) a' A'" using xa'A' unfolding A'A.
      also have "... = lincomb (n+m) a'' A'"
        apply (subst NM.lincomb_restrict)
        using finA' A' restr by (auto simp: module_vec_simps class_ring_simps)
      also have "... = lincomb (n+m) a'' (pad ` A)" unfolding A'A..
      also have "... = pad (lincomb n a A)"
        unfolding a''_def using main[OF AU finA] unfolding a_def by auto
      finally show "x : pad ` (span n U)" unfolding N.span_def
      apply(rule image_eqI, intro CollectI exI conjI)
        using finA AU by (auto simp: class_ring_simps)
    qed
  }
  note main = this
  have AUC: "\<And>A. A \<subseteq> U \<Longrightarrow> A \<subseteq> carrier_vec n" using U by simp
  have [simp]: "n+m = m+n" by auto
  show "goal padr m" unfolding goal_def
    apply (subst main[OF _ _ padr_image[OF U]])
    using lincomb_pad[OF AUC] unpadr_padr by auto
  show "goal padl m" unfolding goal_def
    apply (subst main)
    using lincomb_pad[OF AUC] unpadl_padl padl_image[OF U] by auto
qed

lemma kernel_padr:
  assumes aA: "a : mat_kernel (A :: 'a :: field mat)"
      and A: "A : carrier_mat nr1 nc1"
      and B: "B : carrier_mat nr1 nc2"
      and D: "D : carrier_mat nr2 nc2"
  shows "padr nc2 a : mat_kernel (four_block_mat A B (0\<^sub>m nr2 nc1) D)" (is "_ : mat_kernel ?ABCD")
  unfolding mat_kernel_def
proof (rule, intro conjI)
  have [simp]: "dim_row A = nr1" "dim_row D = nr2" "dim_row ?ABCD = nr1 + nr2" using A D by auto
  have a: "a : carrier_vec nc1" using mat_kernel_carrier[OF A] aA by auto
  show "?ABCD *\<^sub>v padr nc2 a = 0\<^sub>v (dim_row ?ABCD)" (is "?l = ?r")
  proof
    fix i assume i: "i < dim_vec ?r"
    hence "?l $ i = row ?ABCD i \<bullet> padr nc2 a" by auto
    also have "... = 0"
    proof (cases "i < nr1")
      case True
        hence rows: "row A i : carrier_vec nc1" "row B i : carrier_vec nc2"
          using A B by auto
        have "row ?ABCD i = row A i @\<^sub>v row B i"
          using row_four_block_mat(1)[OF A B _ D True] by auto
        also have "... \<bullet> padr nc2 a = row A i \<bullet> a + row B i \<bullet> 0\<^sub>v nc2"
          using scalar_prod_append[OF rows] a by auto
        also have "row A i \<bullet> a = (A *\<^sub>v a) $ i" using True A by auto
        also have "... = 0" using mat_kernelD[OF A aA] True by auto
        also have "row B i \<bullet> 0\<^sub>v nc2 = 0" using True rows by auto
        finally show ?thesis by simp
      next case False
        let ?C = "0\<^sub>m nr2 nc1"
        let ?i = "i - nr1"
        have rows:
            "row ?C ?i : carrier_vec nc1" "row D ?i : carrier_vec nc2"
          using D i False A by auto
        have "row ?ABCD i = row ?C ?i @\<^sub>v row D ?i"
          using row_four_block_mat(2)[OF A B _ D False] i A D by auto
        also have "... \<bullet> padr nc2 a = row ?C ?i \<bullet> a + row D ?i \<bullet> 0\<^sub>v nc2"
          using scalar_prod_append[OF rows] a by auto
        also have "row ?C ?i \<bullet> a = 0\<^sub>v nc1 \<bullet> a" using False A i by auto
        also have "... = 0" using a by auto
        also have "row D ?i \<bullet> 0\<^sub>v nc2 = 0" using False rows by auto
        finally show ?thesis by simp
    qed
    finally show "?l $ i = ?r $ i" using i by auto
  qed auto
  show "padr nc2 a : carrier_vec (dim_col ?ABCD)" using a A D by auto
qed

lemma kernel_padl:
  assumes dD: "d \<in> mat_kernel (D :: 'a :: field mat)"
      and A: "A \<in> carrier_mat nr1 nc1"
      and C: "C \<in> carrier_mat nr2 nc1"
      and D: "D \<in> carrier_mat nr2 nc2"
  shows "padl nc1 d \<in> mat_kernel (four_block_mat A (0\<^sub>m nr1 nc2) C D)" (is "_ \<in> mat_kernel ?ABCD")
  unfolding mat_kernel_def
proof (rule, intro conjI)
  have [simp]: "dim_row A = nr1" "dim_row D = nr2" "dim_row ?ABCD = nr1 + nr2" using A D by auto
  have d: "d : carrier_vec nc2" using mat_kernel_carrier[OF D] dD by auto
  show "?ABCD *\<^sub>v padl nc1 d = 0\<^sub>v (dim_row ?ABCD)" (is "?l = ?r")
  proof
    fix i assume i: "i < dim_vec ?r"
    hence "?l $ i = row ?ABCD i \<bullet> padl nc1 d" by auto
    also have "... = 0"
    proof (cases "i < nr1")
      case True
        let ?B = "0\<^sub>m nr1 nc2"
        have rows: "row A i : carrier_vec nc1" "row ?B i : carrier_vec nc2"
          using A True by auto
        have "row ?ABCD i = row A i @\<^sub>v row ?B i"
          using row_four_block_mat(1)[OF A _ C D True] by auto
        also have "... \<bullet> padl nc1 d = row A i \<bullet> 0\<^sub>v nc1 + row ?B i \<bullet> d"
          using scalar_prod_append[OF rows] d by auto
        also have "row A i \<bullet> 0\<^sub>v nc1 = 0" using A True by auto
        also have "row ?B i \<bullet> d = 0" using True d by auto
        finally show ?thesis by simp
      next case False
        let ?i = "i - nr1"
        have rows:
            "row C ?i : carrier_vec nc1" "row D ?i : carrier_vec nc2"
          using C D i False A by auto
        have "row ?ABCD i = row C ?i @\<^sub>v row D ?i"
          using row_four_block_mat(2)[OF A _ C D False] i A D by auto
        also have "... \<bullet> padl nc1 d = row C ?i \<bullet> 0\<^sub>v nc1 + row D ?i \<bullet> d"
          using scalar_prod_append[OF rows] d by auto
        also have "row C ?i \<bullet> 0\<^sub>v nc1 = 0" using False A C i by auto
        also have "row D ?i \<bullet> d = (D *\<^sub>v d) $ ?i" using D d False i by auto
        also have "... = 0" using mat_kernelD[OF D dD] using False i by auto
        finally show ?thesis by simp
    qed
    finally show "?l $ i = ?r $ i" using i by auto
  qed auto
  show "padl nc1 d : carrier_vec (dim_col ?ABCD)" using d A D by auto
qed

lemma mat_kernel_split:
  assumes A: "A \<in> carrier_mat n n"
      and D: "D \<in> carrier_mat m m"
      and kAD: "k \<in> mat_kernel (four_block_mat A (0\<^sub>m n m) (0\<^sub>m m n) D)"
           (is "_ \<in> mat_kernel ?A00D")
  shows "vec_first k n \<in> mat_kernel A" (is "?a \<in> _")
    and "vec_last k m \<in> mat_kernel D" (is "?d \<in> _")
proof -
  have "0\<^sub>v n @\<^sub>v 0\<^sub>v m = 0\<^sub>v (n+m)" by auto
  also
    have A00D: "?A00D : carrier_mat (n+m) (n+m)" using four_block_carrier_mat[OF A D].
    hence k: "k : carrier_vec (n+m)" using kAD mat_kernel_carrier by auto
    hence "?a @\<^sub>v ?d = k" by simp
    hence "0\<^sub>v (n+m) = ?A00D *\<^sub>v (?a @\<^sub>v ?d)" using mat_kernelD[OF A00D] kAD by auto
  also have "... = A *\<^sub>v ?a @\<^sub>v D *\<^sub>v ?d"
    using mult_mat_vec_split[OF A D] by auto
  finally have "0\<^sub>v n @\<^sub>v 0\<^sub>v m = A *\<^sub>v ?a @\<^sub>v D *\<^sub>v ?d".
  hence "0\<^sub>v n = A *\<^sub>v ?a \<and> 0\<^sub>v m = D *\<^sub>v ?d"
    apply(subst append_vec_eq[of _ n, symmetric]) using A D by auto
  thus "?a : mat_kernel A" "?d : mat_kernel D" unfolding mat_kernel_def using A D by auto
qed

lemma padr_padl_eq:
  assumes v: "v : carrier_vec n"
  shows "padr m v = padl n u \<longleftrightarrow> v = 0\<^sub>v n \<and> u = 0\<^sub>v m"
  apply (subst append_vec_eq) using v by auto

lemma pad_disjoint:
  assumes A: "A \<subseteq> carrier_vec n" and A0: "0\<^sub>v n \<notin> A" and B: "B \<subseteq> carrier_vec m"
  shows "padr m ` A \<inter> padl n ` B = {}" (is "?A \<inter> ?B = _")
proof (intro equals0I)
  fix ab assume "ab : ?A \<inter> ?B"
  then obtain a b
    where "ab = padr m a" "ab = padl n b" and dim: "a : A" "b : B" by force
  hence "padr m a = padl n b" by auto
  hence "a = 0\<^sub>v n" using dim A B by auto
  thus "False" using dim A0 by auto
qed

lemma padr_padl_lindep:
  assumes A: "A \<subseteq> carrier_vec n" and liA: "~ lin_dep n A"
      and B: "B \<subseteq> carrier_vec m" and liB: "~ lin_dep m B"
  shows "~ lin_dep (n+m) (padr m ` A \<union> padl n ` B)" (is "~ lin_dep _ (?A \<union> ?B)")
proof -
  interpret N: vectorspace class_ring "M n" using vec_vs.
  interpret M: vectorspace class_ring "M m" using vec_vs.
  interpret NM: vectorspace class_ring "M (n+m)" using vec_vs.
  note [simp] = module_vec_simps class_ring_simps
  have AB: "?A \<union> ?B \<subseteq> carrier_vec (n+m)"
    using padr_image[OF A] padl_image[OF B] by auto
  show ?thesis
    unfolding NM.lin_dep_def
    unfolding not_ex not_imp[symmetric] not_not
  proof(intro allI impI)
    fix U f u
    assume finU: "finite U"
       and UAB: "U \<subseteq> ?A \<union> ?B"
       and f: "f : U \<rightarrow> carrier class_ring"
       and 0: "lincomb (n+m) f U = \<zero>\<^bsub>M (n+m)\<^esub>"
       and uU: "u : U"
    let ?UA = "U \<inter> ?A" and ?UB = "U \<inter> ?B"
    have "?UA \<subseteq> ?A" "?UB \<subseteq> ?B" by auto
    then obtain A' B'
      where A'A: "A' \<subseteq> A" and B'B: "B' \<subseteq> B"
        and UAA': "?UA = padr m ` A'" and UBB': "?UB = padl n ` B'"
      unfolding subset_image_iff by auto
    hence A': "A' \<subseteq> carrier_vec n" and B': "B' \<subseteq> carrier_vec m" using A B by auto
    have finA': "finite A'" and finB': "finite B'"
    proof -
      have "padr m ` A' \<subseteq> U" "padl n ` B' \<subseteq> U" using UAA' UBB' by auto
      hence pre: "finite (padr m ` A')" "finite (padl n ` B')"
        using finite_subset[OF _ finU] by auto
      show "finite A'"
        apply (rule finite_imageD) using subset_inj_on[OF padr_inj A'] pre by auto
      show "finite B'"
        apply (rule finite_imageD) using subset_inj_on[OF padl_inj B'] pre by auto
    qed
    have "0\<^sub>v n \<notin> A" using N.zero_nin_lin_indpt[OF _ liA] A class_semiring.one_zeroI by auto
    hence "?A \<inter> ?B = {}" using pad_disjoint A B by auto
    hence disj: "?UA \<inter> ?UB = {}" by auto
    have split: "U = padr m ` A' \<union> padl n ` B'"
      unfolding UAA'[symmetric] UBB'[symmetric] using UAB by auto
    show "f u = \<zero>\<^bsub>(class_ring::'a ring)\<^esub>"
    proof -
      let ?a = "f \<circ> padr m"
      let ?b = "f \<circ> padl n"
      have lcA': "lincomb n ?a A' : carrier_vec n" using N.lincomb_closed A' by auto
      have lcB': "lincomb m ?b B' : carrier_vec m" using M.lincomb_closed B' by auto

      have "0\<^sub>v n @\<^sub>v 0\<^sub>v m = 0\<^sub>v (n+m)" by auto
      also have "... = lincomb (n+m) f U" using 0 by auto
      also have "U = ?UA \<union> ?UB" using UAB by auto
      also have "lincomb (n+m) f ... = lincomb (n+m) f ?UA + lincomb (n+m) f ?UB"
        apply(subst NM.lincomb_union) using A B finU disj by auto
      also have "lincomb (n+m) f ?UA = lincomb (n+m) (restrict f ?UA) ?UA"
        apply (subst NM.lincomb_restrict) using A finU by auto
      also have "restrict f ?UA = restrict (?a \<circ> unpadr m) ?UA"
        apply(rule restrict_ext) by auto
      also have "lincomb (n+m) ... ?UA = lincomb (n+m) (?a \<circ> unpadr m) ?UA"
        apply(subst NM.lincomb_restrict) using A finU by auto
      also have "?UA = padr m ` A'" using UAA'.
      also have "lincomb (n+m) (?a \<circ> unpadr m) ... =
        padr m (lincomb n ?a A')"
        using lincomb_pad(1)[OF A' finA',symmetric].
      also have "lincomb (n+m) f ?UB = lincomb (n+m) (restrict f ?UB) ?UB"
        apply (subst NM.lincomb_restrict) using B finU by auto
      also have "restrict f ?UB = restrict (?b \<circ> unpadl n) ?UB"
        apply(rule restrict_ext) by auto
      also have "lincomb (n+m) ... ?UB = lincomb (n+m) (?b \<circ> unpadl n) ?UB"
        apply(subst NM.lincomb_restrict) using B finU by auto
      also have "n+m = m+n" by auto
      also have "?UB = padl n ` B'" using UBB'.
      also have "lincomb (m+n) (?b \<circ> unpadl n) ... =
        padl n (lincomb m ?b B')"
        using lincomb_pad(2)[OF B' finB',symmetric].
      also have "padr m (lincomb n ?a A') + ... =
          (lincomb n ?a A' + 0\<^sub>v n) @\<^sub>v (0\<^sub>v m + lincomb m ?b B')"
        apply (rule append_vec_add) using lcA' lcB' by auto
      also have "... = lincomb n ?a A' @\<^sub>v lincomb m ?b B'" using lcA' lcB' by auto
      finally have "0\<^sub>v n @\<^sub>v 0\<^sub>v m = lincomb n ?a A' @\<^sub>v lincomb m ?b B'".
      hence "0\<^sub>v n = lincomb n ?a A' \<and> 0\<^sub>v m = lincomb m ?b B'"
        apply(subst append_vec_eq[symmetric]) using lcA' lcB' by auto
      from conjunct1[OF this] conjunct2[OF this]
      have "?a : A' \<rightarrow> {0}" "?b : B' \<rightarrow> {0}"
        using N.not_lindepD[OF liA finA' A'A]
        using M.not_lindepD[OF liB finB' B'B] by auto
      hence "f : padr m ` A' \<rightarrow> {0}" "f : padl n ` B' \<rightarrow> {0}" by auto
      hence "f : padr m ` A' \<union> padl n ` B' \<rightarrow> {0}" by auto
      hence "f : U \<rightarrow> {0}" using split by auto
      hence "f u = 0" using uU by auto
      thus ?thesis by simp
    qed
  qed
qed

end

lemma kernel_four_block_0_mat:
  assumes Adef: "(A :: 'a::field mat) = four_block_mat B (0\<^sub>m n m) (0\<^sub>m m n) D"
  and B: "B \<in> carrier_mat n n"
  and D: "D \<in> carrier_mat m m"
  shows "kernel.dim (n + m) A = kernel.dim n B + kernel.dim m D"
proof -
  have [simp]: "n + m = m + n" by auto
  have A: "A \<in> carrier_mat (n+m) (n+m)"
    using Adef four_block_carrier_mat[OF B D] by auto
  interpret vardim "TYPE('a)".
  interpret MN: vectorspace class_ring "M (n+m)" using vec_vs.
  interpret KA: kernel "n+m" "n+m" A by (unfold_locales, rule A)
  interpret KB: kernel n n B by (unfold_locales, rule B)
  interpret KD: kernel m m D by (unfold_locales, rule D)

  note [simp] = module_vec_simps

  from kernel_basis_exists[OF B]
    obtain baseB where fin_bB: "finite baseB" and bB: "KB.basis baseB" by blast
  hence bBkB: "baseB \<subseteq> mat_kernel B" unfolding KB.Ker.basis_def by auto
  hence bBc: "baseB \<subseteq> carrier_vec n" using mat_kernel_carrier[OF B] by auto
  have bB0: "0\<^sub>v n \<notin> baseB"
    using bB unfolding KB.Ker.basis_def
    using KB.Ker.vs_zero_lin_dep[OF bBkB] by auto
  have bBkA: "padr m ` baseB \<subseteq> mat_kernel A"
  proof
    fix a assume "a : padr m ` baseB"
    then obtain b where ab: "a = padr m b" and "b : baseB" by auto
    hence "b : mat_kernel B" using bB unfolding KB.Ker.basis_def by auto
    hence "padr m b : mat_kernel A"
      unfolding Adef using kernel_padr[OF _ B _ D] by auto
    thus "a : mat_kernel A" using ab by auto
  qed
  from kernel_basis_exists[OF D]
    obtain baseD where fin_bD: "finite baseD" and bD: "KD.basis baseD" by blast
  hence bDkD: "baseD \<subseteq> mat_kernel D" unfolding KD.Ker.basis_def by auto
  hence bDc: "baseD \<subseteq> carrier_vec m" using mat_kernel_carrier[OF D] by auto
  have bDkA: "padl n ` baseD \<subseteq> mat_kernel A"
  proof
    fix a assume "a : padl n ` baseD"
    then obtain d where ad: "a = padl n d" and "d : baseD" by auto
    hence "d : mat_kernel D" using bD unfolding KD.Ker.basis_def by auto
    hence "padl n d : mat_kernel A"
      unfolding Adef using kernel_padl[OF _ B _ D] by auto
    thus "a : mat_kernel A" using ad by auto
  qed
  let ?BD = "(padr m ` baseB \<union> padl n ` baseD)"
  have finBD: "finite ?BD" using fin_bB fin_bD by auto
  have "KA.basis  ?BD"
    unfolding KA.Ker.basis_def
  proof (intro conjI Set.equalityI)
    show BDk: "?BD \<subseteq> mat_kernel A" using bBkA bDkA by auto
    also have "mat_kernel A \<subseteq> carrier_vec (m+n)" using mat_kernel_carrier A by auto
    finally have BD: "?BD \<subseteq> carrier (M (n + m))" by auto
    show "mat_kernel A \<subseteq> KA.Ker.span ?BD"
      unfolding KA.span_same[OF BDk]
    proof
      have BD: "?BD \<subseteq> carrier_vec (n+m)" (is "_ \<subseteq> ?R")
      proof(rule)
        fix v assume "v : ?BD"
        moreover
        { assume "v : padr m ` baseB"
          then obtain b where "b : baseB" and vb: "v = padr m b" by auto
          hence "b : carrier_vec n" using bBc by auto
          hence "v : ?R" unfolding vb apply(subst append_carrier_vec) by auto
        }
        moreover
        { assume "v : padl n ` baseD"
          then obtain d where "d : baseD" and vd: "v = padl n d" by auto
          hence "d : carrier_vec m" using bDc by auto
          hence "v : ?R" unfolding vd apply(subst append_carrier_vec) by auto
        }
        ultimately show "v: ?R" by auto
      qed
      fix a assume a: "a : mat_kernel A"
      hence "a : carrier_vec (n+m)" using a mat_kernel_carrier[OF A] by auto
      hence "a = vec_first a n @\<^sub>v vec_last a m" (is "_ = ?b @\<^sub>v ?d") by simp
      also have "... = padr m ?b + padl n ?d" by auto
      finally have 1: "a = padr m ?b + padl n ?d".

      have subkernel: "?b : mat_kernel B" "?d : mat_kernel D"
        using mat_kernel_split[OF B D] a Adef by auto
      hence "?b : span n baseB"
        using bB unfolding KB.Ker.basis_def using KB.span_same by auto
      hence "padr m ?b : padr m ` span n baseB" by auto
      also have "padr m ` span n baseB = span (n+m) (padr m ` baseB)"
        using span_pad[OF bBc] by auto
      also have "... \<subseteq> span (n+m) ?BD" using MN.span_is_monotone by auto
      finally have 2: "padr m ?b : span (n+m) ?BD".
      have "?d : span m baseD"
        using subkernel bD unfolding KD.Ker.basis_def using KD.span_same by auto
      hence "padl n ?d : padl n ` span m baseD" by auto
      also have "padl n ` span m baseD = span (n+m) (padl n ` baseD)"
        using span_pad[OF bDc] by auto
      also have "... \<subseteq> span (n+m) ?BD" using MN.span_is_monotone by auto
      finally have 3: "padl n ?d : span (n+m) ?BD".

      have "padr m ?b + padl n ?d : span (n+m) ?BD"
        using MN.span_add1[OF _ 2 3] BD by auto
      thus "a \<in> span (n+m) ?BD" using 1 by auto
    qed
    show "KA.Ker.span ?BD \<subseteq> mat_kernel A" using KA.Ker.span_closed[OF BDk] by auto
    have li: "~ lin_dep n baseB" "~ lin_dep m baseD"
      using bB[unfolded KB.Ker.basis_def]
      unfolding KB.lindep_same[OF bBkB]
      using bD[unfolded KD.Ker.basis_def]
      unfolding KD.lindep_same[OF bDkD] by auto
    show "~ KA.Ker.lin_dep ?BD"
      unfolding KA.lindep_same[OF BDk]
      apply(rule padr_padl_lindep) using bBc bDc li by auto
  qed
  hence "KA.dim = card ?BD" using KA.Ker.dim_basis[OF finBD] by auto
  also have "card ?BD = card (padr m ` baseB) + card (padl n ` baseD)"
    apply(rule card_Un_disjoint)
    using pad_disjoint[OF bBc bB0 bDc] fin_bB fin_bD by auto
  also have "... = card baseB + card baseD"
    using card_image[OF subset_inj_on[OF padr_inj]]
    using card_image[OF subset_inj_on[OF padl_inj]] bBc bDc by auto
  also have "card baseB = KB.dim" using KB.Ker.dim_basis[OF fin_bB] bB by auto
  also have "card baseD = KD.dim" using KD.Ker.dim_basis[OF fin_bD] bD by auto
  finally show ?thesis.

qed

lemma similar_mat_wit_kernel_dim: assumes A: "A \<in> carrier_mat n n"
  and wit: "similar_mat_wit A B P Q"
  shows "kernel.dim n A = kernel.dim n B"
proof -
  from similar_mat_witD2[OF A wit]
  have QP: "Q * P = 1\<^sub>m n" and AB: "A = P * B * Q" and
    A: "A \<in> carrier_mat n n" and B: "B \<in> carrier_mat n n" and P: "P \<in> carrier_mat n n" and Q: "Q \<in> carrier_mat n n" by auto
  from P B have PB: "P * B \<in> carrier_mat n n" by auto
  show ?thesis unfolding AB mat_kernel_dim_mult_eq_right[OF PB Q P QP] mat_kernel_mult_eq[OF B P Q QP]
    by simp
qed

end